diff options
Diffstat (limited to 'src/LambdaCube')
-rw-r--r-- | src/LambdaCube/Compiler/Lexer.hs | 11 | ||||
-rw-r--r-- | src/LambdaCube/Compiler/Parser.hs | 32 |
2 files changed, 25 insertions, 18 deletions
diff --git a/src/LambdaCube/Compiler/Lexer.hs b/src/LambdaCube/Compiler/Lexer.hs index 83446799..f7c96bf6 100644 --- a/src/LambdaCube/Compiler/Lexer.hs +++ b/src/LambdaCube/Compiler/Lexer.hs | |||
@@ -205,10 +205,14 @@ data Namespace = Namespace | |||
205 | } | 205 | } |
206 | deriving (Show) | 206 | deriving (Show) |
207 | 207 | ||
208 | namespace' = namespaceLevel <$> namespace | ||
209 | |||
208 | tick = (\case TypeLevel -> switchTick; _ -> id) . fromMaybe ExpLevel . namespaceLevel | 210 | tick = (\case TypeLevel -> switchTick; _ -> id) . fromMaybe ExpLevel . namespaceLevel |
209 | 211 | ||
210 | tick' c = (`tick` c) <$> namespace | 212 | tick' c = (`tick` c) <$> namespace |
211 | 213 | ||
214 | switchNamespace = \case ExpLevel -> TypeLevel; TypeLevel -> ExpLevel | ||
215 | |||
212 | switchTick ('\'': n) = n | 216 | switchTick ('\'': n) = n |
213 | switchTick n = '\'': n | 217 | switchTick n = '\'': n |
214 | 218 | ||
@@ -217,7 +221,7 @@ modifyLevel f = local $ (first . second) $ \(Namespace l p) -> Namespace (f <$> | |||
217 | typeNS, expNS, switchNS :: P a -> P a | 221 | typeNS, expNS, switchNS :: P a -> P a |
218 | typeNS = modifyLevel $ const TypeLevel | 222 | typeNS = modifyLevel $ const TypeLevel |
219 | expNS = modifyLevel $ const ExpLevel | 223 | expNS = modifyLevel $ const ExpLevel |
220 | switchNS = modifyLevel $ \case ExpLevel -> TypeLevel; TypeLevel -> ExpLevel | 224 | switchNS = modifyLevel $ switchNamespace |
221 | 225 | ||
222 | ifNoCNamespace p = namespace >>= \ns -> if constructorNamespace ns then mzero else p | 226 | ifNoCNamespace p = namespace >>= \ns -> if constructorNamespace ns then mzero else p |
223 | 227 | ||
@@ -236,7 +240,7 @@ upperLetter = satisfy isUpper <|> ifNoCNamespace identStart | |||
236 | 240 | ||
237 | --upperCase, lowerCase, symbols, colonSymbols, backquotedIdent :: P SName | 241 | --upperCase, lowerCase, symbols, colonSymbols, backquotedIdent :: P SName |
238 | 242 | ||
239 | upperCase_ = identifier (tick' =<< maybeStartWith (=='\'') ((:) <$> upperLetter <*> many identLetter)) <?> "uppercase ident" | 243 | upperCase = identifier (tick' =<< maybeStartWith (=='\'') ((:) <$> upperLetter <*> many identLetter)) <?> "uppercase ident" |
240 | lowerCase = identifier ((:) <$> lowerLetter <*> many identLetter) <?> "lowercase ident" | 244 | lowerCase = identifier ((:) <$> lowerLetter <*> many identLetter) <?> "lowercase ident" |
241 | backquotedIdent = identifier ((:) <$ char '`' <*> identStart <*> many identLetter <* char '`') <?> "backquoted ident" | 245 | backquotedIdent = identifier ((:) <$ char '`' <*> identStart <*> many identLetter <* char '`') <?> "backquoted ident" |
242 | symbols = operator (some opLetter) <?> "symbols" | 246 | symbols = operator (some opLetter) <?> "symbols" |
@@ -250,8 +254,7 @@ patVar = second f <$> lowerCase where | |||
250 | lhsOperator = lcSymbols <|> backquotedIdent | 254 | lhsOperator = lcSymbols <|> backquotedIdent |
251 | rhsOperator = symbols <|> backquotedIdent | 255 | rhsOperator = symbols <|> backquotedIdent |
252 | varId = lowerCase <|> parens (symbols <|> backquotedIdent) | 256 | varId = lowerCase <|> parens (symbols <|> backquotedIdent) |
253 | upperCase = upperCase_ | 257 | upperLower = lowerCase <|> upperCase <|> parens symbols |
254 | upperLower = lowerCase <|> upperCase_ <|> parens (symbols <|> backquotedIdent) | ||
255 | 258 | ||
256 | --qIdent = {-qualified_ todo-} (lowerCase <|> upperCase) | 259 | --qIdent = {-qualified_ todo-} (lowerCase <|> upperCase) |
257 | 260 | ||
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs index d7205c5d..8430caa7 100644 --- a/src/LambdaCube/Compiler/Parser.hs +++ b/src/LambdaCube/Compiler/Parser.hs | |||
@@ -364,26 +364,30 @@ parseTerm_ prec = case prec of | |||
364 | ope = pure . Left <$> (rhsOperator <|> psn ("'EqCTt" <$ reservedOp "~")) | 364 | ope = pure . Left <$> (rhsOperator <|> psn ("'EqCTt" <$ reservedOp "~")) |
365 | ex pr = pure . Right <$> parseTerm pr | 365 | ex pr = pure . Right <$> parseTerm pr |
366 | PrecApp -> | 366 | PrecApp -> |
367 | apps' <$> try "record" ((SGlobal <$> upperCase) <* reservedOp "{") <*> commaSep (lowerCase *> reservedOp "=" *> ((,) Visible <$> parseTerm PrecLam)) <* reservedOp "}" | 367 | apps' <$> try "record" ((SGlobal <$> upperCase) <* symbol "{") <*> commaSep (lowerCase *> reservedOp "=" *> ((,) Visible <$> parseTerm PrecLam)) <* symbol "}" |
368 | <|> apps' <$> parseTerm PrecSwiz <*> many (hiddenTerm (parseTTerm PrecSwiz) $ parseTerm PrecSwiz) | 368 | <|> apps' <$> parseTerm PrecSwiz <*> many (hiddenTerm (parseTTerm PrecSwiz) $ parseTerm PrecSwiz) |
369 | PrecSwiz -> level PrecProj $ \t -> mkSwizzling t <$> lexeme (try "swizzling" $ char '%' *> manyNM 1 4 (satisfy (`elem` ("xyzwrgba" :: String)))) | 369 | PrecSwiz -> level PrecProj $ \t -> mkSwizzling t <$> lexeme (try "swizzling" $ char '%' *> manyNM 1 4 (satisfy (`elem` ("xyzwrgba" :: String)))) |
370 | PrecProj -> level PrecAtom $ \t -> try "projection" $ mkProjection t <$ char '.' <*> sepBy1 (uncurry SLit . second LString <$> lowerCase) (char '.') | 370 | PrecProj -> level PrecAtom $ \t -> try "projection" $ mkProjection t <$ char '.' <*> sepBy1 (uncurry SLit . second LString <$> lowerCase) (char '.') |
371 | PrecAtom -> | 371 | PrecAtom -> |
372 | mkLit <$> try "literal" parseLit | 372 | mkLit <$> try "literal" parseLit |
373 | <|> Wildcard (Wildcard SType) <$ reserved "_" | 373 | <|> Wildcard (Wildcard SType) <$ reserved "_" |
374 | <|> char '\'' *> switchNS (parseTerm PrecAtom) | ||
375 | <|> SGlobal <$> try "identifier" upperLower | ||
376 | <|> brackets ( (parseTerm PrecLam >>= \e -> | ||
377 | mkDotDot e <$ reservedOp ".." <*> parseTerm PrecLam | ||
378 | <|> foldr ($) (SBuiltin "Cons" `SAppV` e `SAppV` SBuiltin "Nil") <$ reservedOp "|" <*> commaSep (generator <|> letdecl <|> boolExpression) | ||
379 | <|> mkList <$> namespace <*> ((e:) <$> option [] (symbol "," *> commaSep1 (parseTerm PrecLam))) | ||
380 | ) <|> mkList <$> namespace <*> pure []) | ||
381 | <|> mkTuple <$> namespace <*> parens (commaSep $ parseTerm PrecLam) | ||
382 | <|> mkRecord <$> braces (commaSep $ (,) <$> lowerCase <* symbol ":" <*> parseTerm PrecLam) | ||
383 | <|> mkLets <$ reserved "let" <*> dsInfo <*> parseDefs <* reserved "in" <*> parseTerm PrecLam | 374 | <|> mkLets <$ reserved "let" <*> dsInfo <*> parseDefs <* reserved "in" <*> parseTerm PrecLam |
375 | <|> SGlobal <$> lowerCase | ||
376 | <|> SGlobal <$> upperCase -- todo: move under ppa? | ||
377 | <|> braces (mkRecord <$> commaSep ((,) <$> lowerCase <* symbol ":" <*> parseTerm PrecLam)) | ||
378 | <|> char '\'' *> ppa (fmap switchNamespace) | ||
379 | <|> ppa id | ||
384 | where | 380 | where |
385 | level pr f = parseTerm_ pr >>= \t -> option t $ f t | 381 | level pr f = parseTerm_ pr >>= \t -> option t $ f t |
386 | 382 | ||
383 | ppa tick = | ||
384 | brackets ( (parseTerm PrecLam >>= \e -> | ||
385 | mkDotDot e <$ reservedOp ".." <*> parseTerm PrecLam | ||
386 | <|> foldr ($) (SBuiltin "Cons" `SAppV` e `SAppV` SBuiltin "Nil") <$ reservedOp "|" <*> commaSep (generator <|> letdecl <|> boolExpression) | ||
387 | <|> mkList . tick <$> namespace' <*> ((e:) <$> option [] (symbol "," *> commaSep1 (parseTerm PrecLam))) | ||
388 | ) <|> mkList . tick <$> namespace' <*> pure []) | ||
389 | <|> parens (SGlobal <$> try "opname" (symbols <* lookAhead (symbol ")")) <|> mkTuple . tick <$> namespace' <*> commaSep (parseTerm PrecLam)) | ||
390 | |||
387 | mkSwizzling term = swizzcall | 391 | mkSwizzling term = swizzcall |
388 | where | 392 | where |
389 | sc c = SBuiltin ['S',c] | 393 | sc c = SBuiltin ['S',c] |
@@ -415,14 +419,14 @@ parseTerm_ prec = case prec of | |||
415 | (SBuiltin "HNil") | 419 | (SBuiltin "HNil") |
416 | 420 | ||
417 | mkTuple _ [Section e] = e | 421 | mkTuple _ [Section e] = e |
418 | mkTuple (Namespace (Just TypeLevel) _) [Parens e] = SBuiltin "'HList" `SAppV` (SBuiltin "Cons" `SAppV` e `SAppV` SBuiltin "Nil") | 422 | mkTuple (Just TypeLevel) [Parens e] = SBuiltin "'HList" `SAppV` (SBuiltin "Cons" `SAppV` e `SAppV` SBuiltin "Nil") |
419 | mkTuple _ [Parens e] = SBuiltin "HCons" `SAppV` e `SAppV` SBuiltin "HNil" | 423 | mkTuple _ [Parens e] = SBuiltin "HCons" `SAppV` e `SAppV` SBuiltin "HNil" |
420 | mkTuple _ [x] = Parens x | 424 | mkTuple _ [x] = Parens x |
421 | mkTuple (Namespace (Just TypeLevel) _) xs = SBuiltin "'HList" `SAppV` foldr (\x y -> SBuiltin "Cons" `SAppV` x `SAppV` y) (SBuiltin "Nil") xs | 425 | mkTuple (Just TypeLevel) xs = SBuiltin "'HList" `SAppV` foldr (\x y -> SBuiltin "Cons" `SAppV` x `SAppV` y) (SBuiltin "Nil") xs |
422 | mkTuple _ xs = foldr (\x y -> SBuiltin "HCons" `SAppV` x `SAppV` y) (SBuiltin "HNil") xs | 426 | mkTuple _ xs = foldr (\x y -> SBuiltin "HCons" `SAppV` x `SAppV` y) (SBuiltin "HNil") xs |
423 | 427 | ||
424 | mkList (Namespace (Just TypeLevel) _) [x] = SBuiltin "'List" `SAppV` x | 428 | mkList (Just TypeLevel) [x] = SBuiltin "'List" `SAppV` x |
425 | mkList (Namespace (Just ExpLevel) _) xs = foldr (\x l -> SBuiltin "Cons" `SAppV` x `SAppV` l) (SBuiltin "Nil") xs | 429 | mkList (Just ExpLevel) xs = foldr (\x l -> SBuiltin "Cons" `SAppV` x `SAppV` l) (SBuiltin "Nil") xs |
426 | mkList _ xs = error "mkList" | 430 | mkList _ xs = error "mkList" |
427 | 431 | ||
428 | mkLit n@LInt{} = SBuiltin "fromInt" `SAppV` sLit n | 432 | mkLit n@LInt{} = SBuiltin "fromInt" `SAppV` sLit n |