From 342c213f3caddd64db0eac5ae146912e00378371 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Sun, 26 Jul 2020 23:02:09 +0200
Subject: WIP refactor and union types, type variables

---
 parser/CC/Parser.hs | 97 +++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 76 insertions(+), 21 deletions(-)

(limited to 'parser/CC')

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 "(){}[]"))
-- 
cgit v1.2.3-54-g00ecf