aboutsummaryrefslogtreecommitdiff
path: root/parser/CC
diff options
context:
space:
mode:
Diffstat (limited to 'parser/CC')
-rw-r--r--parser/CC/Parser.hs97
1 files changed, 76 insertions, 21 deletions
diff --git a/parser/CC/Parser.hs b/parser/CC/Parser.hs
index 2d2c4b7..66bc6cf 100644
--- a/parser/CC/Parser.hs
+++ b/parser/CC/Parser.hs
@@ -1,6 +1,7 @@
module CC.Parser(runPass, parseProgram) where
import Control.Monad
+import qualified Data.Set as Set
import Text.Parsec hiding (SourcePos, getPosition, token)
import qualified Text.Parsec
@@ -12,7 +13,10 @@ import CC.Pretty
type Parser a = Parsec String () a
runPass :: Context -> RawString -> Either (PrettyShow ParseError) Program
-runPass (Context path _) (RawString src) = fmapLeft PrettyShow (parseProgram path src)
+runPass (Context path (Builtins _ prelude)) (RawString src) = do
+ prog1 <- fmapLeft PrettyShow (parseProgram "<prelude>" prelude)
+ prog2 <- fmapLeft PrettyShow (parseProgram path src)
+ return (prog1 <> prog2)
where fmapLeft f (Left x) = Left (f x)
fmapLeft _ (Right x) = Right x
@@ -27,32 +31,63 @@ pProgram = do
return prog
pDecl :: Parser Decl
-pDecl = Def <$> pDef
+pDecl = choice
+ [ DeclType <$> pDeclType
+ , DeclAlias <$> pDeclAlias
+ , DeclFunc <$> pDeclFunc ]
-pDef :: Parser Def
-pDef = do
+pDeclFunc :: Parser FuncDef
+pDeclFunc = do
func <- try $ do
emptyLines
- name <- pName0 <?> "declaration head name"
+ name <- pName0 LowerCase <?> "declaration head name"
return name
mtyp <- optionMaybe $ do
symbol "::"
typ <- pType
whitespace >> void newline
emptyLines
- func' <- fst <$> pName0
+ (func', _) <- pName0 LowerCase
guard (fst func == func')
return typ
- args <- many pName
+ args <- many (pName LowerCase)
symbol "="
expr <- pExpr
- return (Function mtyp func args expr)
+ return (FuncDef mtyp func args expr)
+
+pDeclType :: Parser TypeDef
+pDeclType = (\(n, a, t) -> TypeDef n a t) <$> pTypedefLike "type"
+
+pDeclAlias :: Parser AliasDef
+pDeclAlias = (\(n, a, t) -> AliasDef n a t) <$> pTypedefLike "alias"
+
+pTypedefLike :: String -> Parser ((Name, SourceRange), [(Name, SourceRange)], Type)
+pTypedefLike keyword = do
+ try (emptyLines >> string keyword >> whitespace1)
+ name <- pName0 UpperCase
+ args <- many (pName LowerCase)
+ symbol "="
+ ty <- pType
+ return (name, args, ty)
pType :: Parser Type
-pType = chainr1 pTypeAtom (symbol "->" >> return TFun)
+pType = chainr1 pTypeTerm (symbol "->" >> return TFun)
+
+pTypeTerm :: Parser Type
+pTypeTerm = pTypeAtom <|> pTypeCall
pTypeAtom :: Parser Type
-pTypeAtom = (wordToken "Int" >> return TInt) <|> pParenType
+pTypeAtom = choice
+ [ wordToken "Int" >> return TInt
+ , TyVar . fst <$> pName LowerCase
+ , pParenType
+ , pUnionType ]
+
+pTypeCall :: Parser Type
+pTypeCall = do
+ (constr, _) <- pName UpperCase
+ args <- many pTypeAtom
+ return (TNamed constr args)
pParenType :: Parser Type
pParenType = do
@@ -63,6 +98,19 @@ pParenType = do
[ty] -> return ty
_ -> return (TTup tys)
+pUnionType :: Parser Type
+pUnionType = do
+ token "{"
+ tys <- pType `sepBy` token "|"
+ token "}"
+ case tys of
+ [] -> unexpected "empty union type"
+ [ty] -> return ty
+ _ -> let tyset = Set.fromList tys
+ in if Set.size tyset == length tys
+ then return (TUnion tyset)
+ else unexpected "duplicate types in union"
+
pExpr :: Parser Expr
pExpr = label (pLam <|> pLet <|> pCall) "expression"
where
@@ -84,7 +132,7 @@ pExpr = label (pLam <|> pLet <|> pCall) "expression"
p <- getPosition
void (char '\\')
return p
- names <- many1 pName
+ names <- many1 (pName LowerCase)
symbol "->"
body <- pExpr
p2 <- getPosition
@@ -100,7 +148,7 @@ pExpr = label (pLam <|> pLet <|> pCall) "expression"
where
afterKeyword p1 = do
whitespace1
- lhs <- pName0
+ lhs <- pName0 LowerCase
symbol "="
rhs <- pExpr
let fullRange rest = mergeRange (SourceRange p1 p1) (range rest)
@@ -118,7 +166,8 @@ pExpr = label (pLam <|> pLet <|> pCall) "expression"
pExprAtom :: Parser Expr
pExprAtom =
choice [ uncurry (flip Int) <$> pInt
- , uncurry (flip Var) <$> pName
+ , uncurry (flip Var) <$> pName LowerCase
+ , uncurry (flip Constr) <$> pName UpperCase
, pParenExpr ]
pParenExpr :: Parser Expr
@@ -141,11 +190,13 @@ pInt = try (whitespace >> pInt0)
p2 <- getPosition
return (num, SourceRange p1 p2)
-pName0 :: Parser (Name, SourceRange)
-pName0 = do
+data Case = LowerCase | UpperCase
+
+pName0 :: Case -> Parser (Name, SourceRange)
+pName0 vcase = do
p1 <- getPosition
s <- try $ do
- c <- pWordFirstChar
+ c <- pWordFirstChar vcase
cs <- many pWordMidChar
let s = c : cs
guard (s `notElem` ["let", "in"])
@@ -154,14 +205,18 @@ pName0 = do
notFollowedBy pWordMidChar
return (s, SourceRange p1 p2)
-pWordFirstChar :: Parser Char
-pWordFirstChar = letter <|> oneOf "_$#!"
+pWordFirstChar :: Case -> Parser Char
+pWordFirstChar LowerCase = lower <|> oneOf wordSymbols
+pWordFirstChar UpperCase = upper <|> oneOf wordSymbols
pWordMidChar :: Parser Char
-pWordMidChar = alphaNum <|> oneOf "_$#!"
+pWordMidChar = alphaNum <|> oneOf wordSymbols
+
+wordSymbols :: [Char]
+wordSymbols = "_$#!"
-pName :: Parser (Name, SourceRange)
-pName = try (whitespace >> pName0)
+pName :: Case -> Parser (Name, SourceRange)
+pName vcase = try (whitespace >> pName0 vcase)
symbol :: String -> Parser ()
symbol s = token s >> (eof <|> void space <|> void (oneOf "(){}[]"))