aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ast/CC/AST/Source.hs2
-rw-r--r--ast/CC/AST/Typed.hs8
-rw-r--r--parser/CC/Parser.hs42
-rw-r--r--typecheck/CC/Typecheck.hs8
4 files changed, 54 insertions, 6 deletions
diff --git a/ast/CC/AST/Source.hs b/ast/CC/AST/Source.hs
index 11b7bc6..e648759 100644
--- a/ast/CC/AST/Source.hs
+++ b/ast/CC/AST/Source.hs
@@ -27,6 +27,7 @@ data Type = TFun Type Type
deriving (Show, Read)
data Expr = Lam SourceRange [(Name, SourceRange)] Expr
+ | Let SourceRange (Name, SourceRange) Expr Expr
| Call SourceRange Expr Expr
| Int SourceRange Int
| Tup SourceRange [Expr]
@@ -43,6 +44,7 @@ instance Pretty Type where
instance HasRange Expr where
range (Lam sr _ _) = sr
+ range (Let sr _ _ _) = sr
range (Call sr _ _) = sr
range (Int sr _) = sr
range (Tup sr _) = sr
diff --git a/ast/CC/AST/Typed.hs b/ast/CC/AST/Typed.hs
index 26f7b5c..b12b30a 100644
--- a/ast/CC/AST/Typed.hs
+++ b/ast/CC/AST/Typed.hs
@@ -25,6 +25,7 @@ data TypeScheme = TypeScheme [Int] Type
deriving (Show, Read)
data Expr = Lam Type Occ Expr
+ | Let Occ Expr Expr
| Call Type Expr Expr
| Int Int
| Tup [Expr]
@@ -36,6 +37,7 @@ data Occ = Occ Name Type
exprType :: Expr -> Type
exprType (Lam typ _ _) = typ
+exprType (Let _ _ body) = exprType body
exprType (Call typ _ _) = typ
exprType (Int _) = TInt
exprType (Tup es) = TTup (map exprType es)
@@ -60,6 +62,12 @@ instance Pretty Expr where
precParens p 2 $
"(\\(" ++ n ++ " :: " ++ pretty t ++ ") -> "
++ prettyPrec 2 e ++ ") :: " ++ pretty ty
+ prettyPrec p (Let (Occ n t) rhs e) =
+ precParens p 2 $
+ "let (" ++ n ++ " :: " ++ pretty t ++ ") = " ++ pretty rhs ++ " " ++
+ (case e of
+ Let _ _ _ -> pretty e
+ _ -> "in " ++ pretty e)
prettyPrec p (Call ty e1 e2) =
precParens p 2 $
prettyPrec 3 e1 ++ " " ++ prettyPrec 3 e2 ++ " :: " ++ pretty ty
diff --git a/parser/CC/Parser.hs b/parser/CC/Parser.hs
index bbabe3c..2d2c4b7 100644
--- a/parser/CC/Parser.hs
+++ b/parser/CC/Parser.hs
@@ -64,7 +64,7 @@ pParenType = do
_ -> return (TTup tys)
pExpr :: Parser Expr
-pExpr = label (pCall <|> pLam) "expression"
+pExpr = label (pLam <|> pLet <|> pCall) "expression"
where
pCall = do
atoms <- many1 pExprAtom
@@ -90,6 +90,31 @@ pExpr = label (pCall <|> pLam) "expression"
p2 <- getPosition
return (Lam (SourceRange p1 p2) names body)
+ pLet = do
+ p1 <- try $ do
+ whitespace
+ p <- getPosition
+ void (string "let")
+ return p
+ afterKeyword p1
+ where
+ afterKeyword p1 = do
+ whitespace1
+ lhs <- pName0
+ symbol "="
+ rhs <- pExpr
+ let fullRange rest = mergeRange (SourceRange p1 p1) (range rest)
+ choice [ do p1' <- try $ do
+ whitespace
+ p1' <- getPosition
+ void (string "let")
+ return p1'
+ rest <- afterKeyword p1'
+ return (Let (fullRange rest) lhs rhs rest)
+ , do symbol "in"
+ body <- pExpr
+ return (Let (fullRange body) lhs rhs body) ]
+
pExprAtom :: Parser Expr
pExprAtom =
choice [ uncurry (flip Int) <$> pInt
@@ -119,11 +144,15 @@ pInt = try (whitespace >> pInt0)
pName0 :: Parser (Name, SourceRange)
pName0 = do
p1 <- getPosition
- c <- pWordFirstChar
- cs <- many pWordMidChar
+ s <- try $ do
+ c <- pWordFirstChar
+ cs <- many pWordMidChar
+ let s = c : cs
+ guard (s `notElem` ["let", "in"])
+ return s
p2 <- getPosition
notFollowedBy pWordMidChar
- return (c : cs, SourceRange p1 p2)
+ return (s, SourceRange p1 p2)
pWordFirstChar :: Parser Char
pWordFirstChar = letter <|> oneOf "_$#!"
@@ -146,8 +175,9 @@ token s = try (whitespace >> void (string s))
emptyLines :: Parser ()
emptyLines = (try (whitespace >> newline) >> emptyLines) <|> try (whitespace >> eof) <|> return ()
-whitespace :: Parser ()
-whitespace = void (many (void (char ' ') <|> void (try (string "\n "))))
+whitespace, whitespace1 :: Parser ()
+whitespace = void (many (void (char ' ') <|> void (try (string "\n "))))
+whitespace1 = void (many1 (void (char ' ') <|> void (try (string "\n "))))
getPosition :: Parser SourcePos
getPosition = do
diff --git a/typecheck/CC/Typecheck.hs b/typecheck/CC/Typecheck.hs
index 8678771..8803a62 100644
--- a/typecheck/CC/Typecheck.hs
+++ b/typecheck/CC/Typecheck.hs
@@ -87,6 +87,8 @@ instance Substitute Env where
instance Substitute T.Expr where
theta >>! T.Lam ty (T.Occ name ty2) body =
T.Lam (theta >>! ty) (T.Occ name (theta >>! ty2)) (theta >>! body)
+ theta >>! T.Let (T.Occ name ty) rhs body =
+ T.Let (T.Occ name (theta >>! ty)) (theta >>! rhs) (theta >>! body)
theta >>! T.Call ty e1 e2 =
T.Call (theta >>! ty) (theta >>! e1) (theta >>! e2)
_ >>! expr@(T.Int _) = expr
@@ -152,6 +154,12 @@ infer env expr = case expr of
let argType = theta >>! argVar
return (theta, T.Lam (T.TFun argType (T.exprType body'))
(T.Occ arg argType) body')
+ S.Let _ (name, _) rhs body -> do
+ (theta1, rhs') <- infer env rhs
+ let varType = T.exprType rhs'
+ let augEnv = envAdd name (T.TypeScheme [] varType) env
+ (theta2, body') <- infer augEnv body
+ return (theta2 <> theta1, T.Let (T.Occ name varType) rhs' body')
S.Call sr func arg -> do
(theta1, func') <- infer env func
(theta2, arg') <- infer (theta1 >>! env) arg