diff --git a/hsrc/Main.hs b/hsrc/Main.hs index f26fdcf..a6df63e 100644 --- a/hsrc/Main.hs +++ b/hsrc/Main.hs @@ -28,14 +28,15 @@ main = do Right ress -> do mapM_ putStrLn ress putStrLn "Successful lex." + _ -> fail "Unacceptable arguments." pullTokens :: Parser [String] pullTokens = do tok <- scan case tok of - Lexeme pos tok -> do - let res = show pos ++ " " ++ show tok - if tok == TokEOF + Lexeme pos tok' -> do + let res = show pos ++ " " ++ show tok' + if tok' == TokEOF then return [res] else return (res :) `ap` pullTokens diff --git a/hsrc/Syntax/AST.hs b/hsrc/Syntax/AST.hs index 8c616ff..74621b7 100644 --- a/hsrc/Syntax/AST.hs +++ b/hsrc/Syntax/AST.hs @@ -38,18 +38,18 @@ data Show a => Decl a = | DeclNewtype a [Type] | DeclClass a [Type] | DeclInstance a [Type] - | DeclValue a [Type] Type (Expr a) + | DeclValue a [Type] Type QualifiedName (Expr a) | DeclExport a (Decl a) deriving (Show) addTypeRestrictions :: Show a => [Type] -> Decl a -> Decl a -addTypeRestrictions rs (DeclData s _ a b c) = DeclData s rs a b c -addTypeRestrictions rs (DeclType s _) = DeclType s rs -addTypeRestrictions rs (DeclNewtype s _) = DeclNewtype s rs -addTypeRestrictions rs (DeclClass s _) = DeclClass s rs -addTypeRestrictions rs (DeclInstance s _) = DeclInstance s rs -addTypeRestrictions rs (DeclValue s _ a b) = DeclValue s rs a b -addTypeRestrictions rs (DeclExport s d) = +addTypeRestrictions rs (DeclData s _ a b c) = DeclData s rs a b c +addTypeRestrictions rs (DeclType s _) = DeclType s rs +addTypeRestrictions rs (DeclNewtype s _) = DeclNewtype s rs +addTypeRestrictions rs (DeclClass s _) = DeclClass s rs +addTypeRestrictions rs (DeclInstance s _) = DeclInstance s rs +addTypeRestrictions rs (DeclValue s _ n a b) = DeclValue s rs n a b +addTypeRestrictions rs (DeclExport s d) = DeclExport s (addTypeRestrictions rs d) data DataClause a = DataClause a QualifiedName [Maybe QualifiedName] [Type] @@ -62,20 +62,23 @@ data Show a => Expr a = | App a (Expr a) [Expr a] | Block a [Stmt a] | Lambda a [QualifiedName] (Expr a) + | Let a Type QualifiedName (Expr a) (Expr a) deriving (Show) getSpecial :: Show a => Expr a -> a -getSpecial (Const a _) = a -getSpecial (VarRef a _) = a -getSpecial (Cond a _ _ _) = a -getSpecial (App a _ _) = a -getSpecial (Block a _) = a -getSpecial (Lambda a _ _) = a +getSpecial (Const a _) = a +getSpecial (VarRef a _) = a +getSpecial (Cond a _ _ _) = a +getSpecial (App a _ _) = a +getSpecial (Block a _) = a +getSpecial (Lambda a _ _) = a +getSpecial (Let a _ _ _ _) = a data Show a => Stmt a = SExpr a (Expr a) | SBind a QualifiedName (Stmt a) - | SCase a (Expr a) [(Pattern,Maybe (Expr a),Expr a)] + | SLet a Type QualifiedName (Expr a) + | SCase a (Expr a) [(Pattern,Maybe (Expr a),Stmt a)] deriving (Show) data Pattern = diff --git a/hsrc/Syntax/Lexer.x b/hsrc/Syntax/Lexer.x index d2ee5ff..640c0ea 100644 --- a/hsrc/Syntax/Lexer.x +++ b/hsrc/Syntax/Lexer.x @@ -21,7 +21,7 @@ $bindigit = [01] $typestart = [A-Z\_] $valstart = [a-z\_] $identrest = [a-zA-Z0-9\_\.] -$opident = [\~\!\@\#\$\%\^\&\*\+\-\=\.\:\<\>\?\_] +$opident = [\~\!\@\#\$\%\^\&\*\+\-\=\.\<\>\?\_] $escape_char = [abfnrtv'\"\\] :- @@ -42,6 +42,7 @@ $escape_char = [abfnrtv'\"\\] $typestart $identrest* { emitS TokTypeIdent } $valstart $identrest* { emitS TokValIdent } $opident+ { emitS TokOpIdent } + ":"+ { emitS TokOpIdent } -- Characters and Strings ['].['] { emitS TokChar } diff --git a/hsrc/Syntax/Parser.y b/hsrc/Syntax/Parser.y index 2cd323b..f76767c 100644 --- a/hsrc/Syntax/Parser.y +++ b/hsrc/Syntax/Parser.y @@ -27,6 +27,8 @@ import qualified Codec.Binary.UTF8.Generic as UTF8 'instance' { Lexeme $$ (TokValIdent "instance") } 'qualified' { Lexeme $$ (TokValIdent "qualified") } 'as' { Lexeme $$ (TokValIdent "as") } + 'let' { Lexeme $$ (TokValIdent "let") } + 'in' { Lexeme $$ (TokValIdent "in") } 'case' { Lexeme $$ (TokValIdent "case") } 'of' { Lexeme $$ (TokValIdent "of") } 'restrict' { Lexeme $$ (TokValIdent "restrict") } @@ -206,7 +208,7 @@ instance_decl :: { Decl Position } value_decl :: { Decl Position } : value_ident optional_args optional_type value_body - {% postProcessDeclVal $1 $2 $3 $4 } + {% postProcessDeclVal DeclValue $1 $2 $3 $4 } optional_args :: { Maybe [(QualifiedName, Maybe Type)] } @@ -268,23 +270,25 @@ statements :: { [Stmt Position] } statement :: { Stmt Position } : assignment_statement ';' { $1 } - | case_statement ';' { $1 } + | case_statement { $1 } | expression ';' { SExpr $2 $1 } assignment_statement :: { Stmt Position } : value_ident '=' expression -- FIXME: Too restrictive! { SBind $2 $1 (SExpr $2 $3) } + | 'let' value_ident optional_args optional_type value_body + {% postProcessDeclVal (\ s _ t n e -> SLet s t n e) $2 $3 $4 $5 } case_statement :: { Stmt Position } - : 'case' expression 'of' case_items + : 'case' expression '{' case_items '}' { SCase $1 $2 $4 } -case_items :: { [(Pattern,Maybe (Expr Position),(Expr Position))] } +case_items :: { [(Pattern,Maybe (Expr Position),(Stmt Position))] } : case_item { [$1] } | case_items case_item { $1 ++ [$2] } -case_item :: { (Pattern, Maybe (Expr Position), (Expr Position)) } - : pattern mguard '->' expression { ($1, $2, $4) } +case_item :: { (Pattern, Maybe (Expr Position), (Stmt Position)) } + : pattern mguard '->' statement { ($1, $2, $4) } mguard :: { Maybe (Expr Position) } : { Nothing } @@ -297,8 +301,8 @@ infix_operator :: { QualifiedName } | '`' VAL_IDENT '`' { makeQualified $2 } pattern_primary :: { Pattern } - : TYPE_IDENT { PVar (makeQualified $1) } - | VAL_IDENT { PVar (makeQualified $1) } + : TYPE_IDENT { PVar (makeQualified $1) } + | VAL_IDENT { PVar (makeQualified $1) } | '[' ']' { PVar (QualifiedName ["Data","List"] "NULL") } | INTVAL { let (Lexeme _ (TokInt (base, val))) = $1 in PConst (ConstInteger base val) } @@ -338,11 +342,18 @@ primary_expression :: { Expr Position } in Const src (ConstChar val) } | STRVAL { let (Lexeme src (TokString val)) = $1 in Const src (ConstString val) } + | TYPE_IDENT { let l@(Lexeme src (TokTypeIdent name)) = $1 + in VarRef src (makeQualified l) } | VAL_IDENT { let l@(Lexeme src (TokValIdent name)) = $1 in VarRef src (makeQualified l) } +let_expression :: {Expr Position} + : 'let' value_ident optional_args optional_type value_body 'in' let_expression + {% postProcessDeclVal (\ s _ t n b -> Let s t n b $7) $2 $3 $4 $5 } + | primary_expression { $1 } + conditional_expression :: { Expr Position } - : primary_expression { $1 } + : let_expression { $1 } infix_expression :: { Expr Position } : infix_expression infix_operator conditional_expression @@ -403,15 +414,17 @@ makeQualified' str = QualifiedName prefixes name let (pre,rest) = span (/= '.') val in if rest == "" then ([], pre) - else let (pres, name) = loop rest + else let (pres, name) = loop (tail rest) in (pre:pres, name) -postProcessDeclVal :: QualifiedName -> - Maybe [(QualifiedName, Maybe Type)] -> - Maybe Type -> - (Position, Expr Position) -> - Parser (Decl Position) -postProcessDeclVal name margs mrettype (src, body) = do +postProcessDeclVal :: + (Position -> [Type] -> Type -> QualifiedName -> Expr Position -> a) -> + QualifiedName -> + Maybe [(QualifiedName, Maybe Type)] -> + Maybe Type -> + (Position, Expr Position) -> + Parser a +postProcessDeclVal builder name margs mrettype (src, body) = do final_type <- case mrettype of Nothing -> do name <- gensym @@ -420,11 +433,19 @@ postProcessDeclVal name margs mrettype (src, body) = do return x case margs of Nothing -> - return (DeclValue src [] final_type body) + return (builder src [] final_type name body) Just [] -> fail "Need to figure out empty arg items." - Just args -> - fail "Need to figure out non-empty arg items." - + Just args -> do + let anames = map fst args + atypes <- forM (map snd args) $ \ x -> + case x of + Nothing -> do + name <- gensym + return (TVar name Star) + Just x -> + return x + let ftype = foldr TAp final_type atypes + return (builder src [] ftype name (Lambda src anames body)) }