diff --git a/bsrc/Data/List.bs b/bsrc/Data/List.bs index f90d697..5f83039 100644 --- a/bsrc/Data/List.bs +++ b/bsrc/Data/List.bs @@ -24,7 +24,7 @@ export length(ls :: [a]) :: Int { case ls of [] -> 0 - _:rest -> length rest + _:rest -> length(rest) }; export reverse(ls :: [a]) :: [a] @@ -32,10 +32,10 @@ export reverse(ls :: [a]) :: [a] helper(xs,acc) = { case xs of [] -> acc - (a:rest) -> helper rest (a:acc) + (a:rest) -> helper(rest, (a:acc)) } - helper ls []; + helper(ls, []); }; export restrict(Eq a) find(f :: a -> Bool, ls :: [a]) :: Maybe a diff --git a/hsrc/Syntax/AST.hs b/hsrc/Syntax/AST.hs index b7be42c..8c616ff 100644 --- a/hsrc/Syntax/AST.hs +++ b/hsrc/Syntax/AST.hs @@ -1,5 +1,7 @@ module Syntax.AST where +import Syntax.ParserCore + data Show a => Module a = Module { modName :: QualifiedName , modImports :: [Import] @@ -13,6 +15,11 @@ data QualifiedName = QualifiedName { } deriving (Show) +gensym :: Parser QualifiedName +gensym = do + name <- genstr + return (QualifiedName [] name) + data Import = Import { imName :: QualifiedName , imQualified :: Bool @@ -31,7 +38,7 @@ data Show a => Decl a = | DeclNewtype a [Type] | DeclClass a [Type] | DeclInstance a [Type] - | DeclValue a [Type] Type QualifiedName [Stmt a] + | DeclValue a [Type] Type (Expr a) | DeclExport a (Decl a) deriving (Show) @@ -41,7 +48,7 @@ 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 c) = DeclValue s rs a b c +addTypeRestrictions rs (DeclValue s _ a b) = DeclValue s rs a b addTypeRestrictions rs (DeclExport s d) = DeclExport s (addTypeRestrictions rs d) @@ -51,16 +58,32 @@ data DataClause a = DataClause a QualifiedName [Maybe QualifiedName] [Type] data Show a => Expr a = Const a ConstVal | VarRef a QualifiedName - | Cond a (Expr a) (Expr a) - | App a (Expr a) (Expr a) - | Block a [Expr a] + | Cond a (Expr a) (Expr a) (Expr a) + | App a (Expr a) [Expr a] + | Block a [Stmt a] | Lambda a [QualifiedName] (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 + data Show a => Stmt a = SExpr a (Expr a) | SBind a QualifiedName (Stmt a) - | SCase a + | SCase a (Expr a) [(Pattern,Maybe (Expr a),Expr a)] + deriving (Show) + +data Pattern = + ListNull + | PConst ConstVal + | PVar QualifiedName + | PNamed QualifiedName Pattern + | PAp Pattern Pattern deriving (Show) data Kind = Star | KFun Kind Kind diff --git a/hsrc/Syntax/Lexer.x b/hsrc/Syntax/Lexer.x index 1b1e399..1e09c97 100644 --- a/hsrc/Syntax/Lexer.x +++ b/hsrc/Syntax/Lexer.x @@ -58,6 +58,7 @@ $escape_char = [abfnrtv'\"\\] "|" { emitT Bar } ";" { emitT Semi } "," { emitT Comma } + "`" { emitT BTick } { diff --git a/hsrc/Syntax/Parser.y b/hsrc/Syntax/Parser.y index 48cff1c..2cd323b 100644 --- a/hsrc/Syntax/Parser.y +++ b/hsrc/Syntax/Parser.y @@ -27,36 +27,37 @@ import qualified Codec.Binary.UTF8.Generic as UTF8 'instance' { Lexeme $$ (TokValIdent "instance") } 'qualified' { Lexeme $$ (TokValIdent "qualified") } 'as' { Lexeme $$ (TokValIdent "as") } --- 'case' { Lexeme $$ (TokValIdent "case") } --- 'of' { Lexeme $$ (TokValIdent "of") } + 'case' { Lexeme $$ (TokValIdent "case") } + 'of' { Lexeme $$ (TokValIdent "of") } 'restrict' { Lexeme $$ (TokValIdent "restrict") } -- symbols '=' { Lexeme $$ (TokOpIdent "=") } '->' { Lexeme $$ (TokOpIdent "->") } --- '=>' { Lexeme $$ (TokOpIdent "=>") } + '@' { Lexeme $$ (TokOpIdent "@") } '::' { Lexeme $$ (TokOpIdent "::") } --- '\\' { Lexeme $$ (TokOpIdent "\\") } + '\\' { Lexeme $$ (TokOpIdent "\\") } '(' { Lexeme $$ LParen } ')' { Lexeme $$ RParen } '[' { Lexeme $$ LSquare } ']' { Lexeme $$ RSquare } --- '{' { Lexeme $$ LBrace } --- '}' { Lexeme $$ RBrace } + '{' { Lexeme $$ LBrace } + '}' { Lexeme $$ RBrace } '|' { Lexeme $$ Bar } ';' { Lexeme $$ Semi } ',' { Lexeme $$ Comma } + '`' { Lexeme $$ BTick } -- identifiers - TYPE_IDENT { Lexeme _ (TokTypeIdent $$) } - VAL_IDENT { Lexeme _ (TokValIdent $$) } - OP_IDENT { Lexeme _ (TokOpIdent $$) } + TYPE_IDENT { Lexeme _ (TokTypeIdent _) } + VAL_IDENT { Lexeme _ (TokValIdent _) } + OP_IDENT { Lexeme _ (TokOpIdent _) } -- values --- INTVAL { Lexeme _ (TokInt $$) } --- FLOATVAL { Lexeme _ (TokFloat $$) } --- CHARVAL { Lexeme _ (TokChar $$) } --- STRVAL { Lexeme _ (TokString $$) } + INTVAL { Lexeme _ (TokInt _) } + FLOATVAL { Lexeme _ (TokFloat _) } + CHARVAL { Lexeme _ (TokChar _) } + STRVAL { Lexeme _ (TokString _) } %monad { Parser } { (>>=) } { return } %name parseModule top_module @@ -204,7 +205,9 @@ instance_decl :: { Decl Position } -- Value Declaration -------------------------------------------------------- value_decl :: { Decl Position } - : value_ident optional_args optional_type { undefined } + : value_ident optional_args optional_type value_body + {% postProcessDeclVal $1 $2 $3 $4 } + optional_args :: { Maybe [(QualifiedName, Maybe Type)] } : '(' optional_args2 ')' { Just $2 } @@ -225,6 +228,10 @@ value_ident :: { QualifiedName } : VAL_IDENT { makeQualified $1 } | '(' OP_IDENT ')' { makeQualified $2 } +value_body :: { (Position, Expr Position) } + : '=' expression { ($1, $2) } + | '{' statements '}' { ($1, Block $1 $2) } + -- Types in Bang ------------------------------------------------------------ primary_type :: { Type } @@ -253,142 +260,124 @@ list_type :: { Type } bang_type :: { Type } : list_type { $1 } --- --- data_decl :: { Decl Position } --- : 'datatype' mqualifiers TYPE_IDENT data_args dataclauses --- { DeclData $2 (makeQualified $3) $4 $5 } --- --- mqualifiers :: { [Type] } --- : { [] } --- | '(' tqualifiers ')' '=>' { $2 } --- --- tqualifiers :: { [Type] } --- : tqualifier { [$1] } --- | tqualifiers ',' tqualifier { $1 ++ [$3] } --- --- tqualifier :: { Type } --- : TYPE_IDENT VAL_IDENT --- { TAp (TCon (makeQualified $1) Star) (TVar (makeQualified $2) Star) } --- | tqualifier VAL_IDENT --- { TAp $1 (TVar (makeQualified $2) Star) } --- --- data_args :: { [QualifiedName] } --- : { [] } --- | data_args VAL_IDENT { $1 ++ [makeQualified $2] } --- --- dataclauses :: { [DataClause] } --- : '=' dataclause { [$2] } --- | dataclauses '|' dataclause { $1 ++ [$3] } --- --- dataclause :: { DataClause } --- : constructor_id { DataClause $1 [] } --- | dataclause bangtype3 { let DataClause name items = $1 --- in DataClause name (items ++ [$2]) } --- --- constructor_id :: { QualifiedName } --- : TYPE_IDENT { makeQualified $1 } --- | '(' OP_IDENT ')' { makeQualified $2 } --- --- -- Type alias Declarations -------------------------------------------------- --- --- type_decl :: { Decl Position } --- : 'type' { DeclType } --- --- -- Newtype Declarations ----------------------------------------------------- --- --- newtype_decl :: { Decl Position } --- : 'newtype' { DeclNewtype } --- --- -- Type class Declarations -------------------------------------------------- --- --- class_decl :: { Decl Position } --- : 'class' { DeclClass } --- --- -- Instance Declarations ---------------------------------------------------- --- --- instance_decl :: { Decl Position } --- : 'instance' { DeclInstance } --- --- -- Data value Declarations -------------------------------------------------- --- --- value_decl :: { Decl Position } --- : value_name '=' expr { DeclValue Nothing $1 (Just $3) } --- --- value_name :: { QualifiedName } --- : VAL_IDENT { makeQualified $1 } --- | '(' OP_IDENT ')' { makeQualified $2 } --- --- -- Data value type Declarations --------------------------------------------- --- --- vtype_decl :: {Decl Position } --- : value_name '::' bangtype { DeclValue (Just $3) $1 Nothing } --- --- -- Types -------------------------------------------------------------------- --- --- bangtype :: { Type } --- : bangtype1 { $1 } --- --- bangtype1 :: { Type } --- : bangtype1 VAL_IDENT { TAp $1 (TVar (makeQualified $2) Star) } --- | bangtype2 { $1 } --- --- bangtype2 :: { Type } --- : bangtype2 '->' bangtype3 --- { TAp (TAp (TCon (QualifiedName [] "->") Star) $1) $3 } --- | bangtype3 { $1 } --- --- bangtype3 :: { Type } --- : '[' bangtype3 ']' --- { TAp (TVar (QualifiedName ["Data","List"] "List") Star) $2 } --- | bangtype4 { $1 } --- --- bangtype4 :: { Type } --- : TYPE_IDENT { TVar (makeQualified $1) Star } --- | '(' bangtype ')' { $2 } --- --- -- Statements --------------------------------------------------------------- --- --- statement :: { Statement } --- : expr ';' { } --- | 'case' expr 'of' { } --- --- -- Expressions -------------------------------------------------------------- --- --- expr :: { Expr Position } --- : '\\' arglist '->' expr1 { Lambda Position $2 $4 } --- | expr1 { $1 } --- --- arglist :: { [QualifiedName] } --- : VAL_IDENT { [makeQualified $1] } --- | arglist VAL_IDENT { $1 ++ [makeQualified $2] } --- --- expr1 :: { Expr Position } --- : '{' exprs '}' { Block Position $2 } --- | expr2 { $1 } --- --- exprs :: { [Expr Position] } --- : expr ';' { [$1] } --- | exprs expr ';' { $1 ++ [$2] } --- --- expr2 :: { Expr Position } --- : '[' list_exprs ']' { unwindList $2 } --- | expr3 { $1 } --- --- list_exprs :: { [Expr Position] } --- : { [] } --- | list_exprs ',' expr3 { $1 ++ [$3] } --- --- expr3 :: { Expr Position } --- : bottom_expr { $1 } --- --- bottom_expr :: { Expr Position } --- : INTVAL { let (b,v) = $1 in Const () (ConstInteger b v) } --- | FLOATVAL { Const Position (ConstFloat $1) } --- | CHARVAL { Const Position (ConstChar $1) } --- | STRVAL { Const Position (ConstString $1) } --- | VAL_IDENT { VarRef Position (makeQualified $1) } --- | '[' ']' { VarRef () (QualifiedName ["Data","List"] "Null") } --- | '(' expr ')' { $2 } +-- Statements in bang + +statements :: { [Stmt Position] } + : { [] } + | statements statement { $1 ++ [$2] } + +statement :: { Stmt Position } + : assignment_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) } + +case_statement :: { Stmt Position } + : 'case' expression 'of' case_items + { SCase $1 $2 $4 } + +case_items :: { [(Pattern,Maybe (Expr Position),(Expr Position))] } + : case_item { [$1] } + | case_items case_item { $1 ++ [$2] } + +case_item :: { (Pattern, Maybe (Expr Position), (Expr Position)) } + : pattern mguard '->' expression { ($1, $2, $4) } + +mguard :: { Maybe (Expr Position) } + : { Nothing } + | '|' expression { Just $2 } + +-- Patterns for pattern matching + +infix_operator :: { QualifiedName } + : OP_IDENT { makeQualified $1 } + | '`' VAL_IDENT '`' { makeQualified $2 } + +pattern_primary :: { Pattern } + : 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) } + | FLOATVAL { let (Lexeme _ (TokFloat val)) = $1 + in PConst (ConstFloat val) } + | CHARVAL { let (Lexeme _ (TokChar val)) = $1 + in PConst (ConstChar val) } + | STRVAL { let (Lexeme _ (TokString val)) = $1 + in PConst (ConstString val) } + | '(' pattern ')' { $2 } + +pattern_infix :: { Pattern } + : pattern_infix infix_operator pattern_primary { PAp (PAp $1 (PVar $2)) $3 } + | pattern_primary { $1 } + +pattern_ap :: { Pattern } + : pattern_ap pattern_infix { PAp $1 $2 } + | pattern_infix { $1 } + +pattern_name :: { Pattern } + : value_ident '@' pattern_name { PNamed $1 $3 } + | pattern_ap { $1 } + +pattern :: { Pattern } + : pattern_name { $1 } + +-- Expressions in bang + +primary_expression :: { Expr Position } + : '(' expression ')' { $2 } + | '[' ']' { VarRef $1 (QualifiedName ["Data","List"] "NULL") } + | INTVAL { let (Lexeme src (TokInt (base, val))) = $1 + in Const src (ConstInteger base val) } + | FLOATVAL { let (Lexeme src (TokFloat val)) = $1 + in Const src (ConstFloat val) } + | CHARVAL { let (Lexeme src (TokChar val)) = $1 + in Const src (ConstChar val) } + | STRVAL { let (Lexeme src (TokString val)) = $1 + in Const src (ConstString val) } + | VAL_IDENT { let l@(Lexeme src (TokValIdent name)) = $1 + in VarRef src (makeQualified l) } + +conditional_expression :: { Expr Position } + : primary_expression { $1 } + +infix_expression :: { Expr Position } + : infix_expression infix_operator conditional_expression + { App (getSpecial $1) (VarRef (getSpecial $1) $2) [$1, $3] } + | conditional_expression + { $1 } + +lambda_expression :: { Expr Position } + : '\\' arguments '->' infix_expression + { Lambda $1 $2 $4 } + | infix_expression + { $1 } + +arguments :: { [QualifiedName] } + : value_ident { [$1] } + | arguments ',' value_ident { $1 ++ [$3] } + +application_expression :: { Expr Position } + : application_expression '(' app_args ')' + { App $2 $1 $3 } + | application_expression '(' ')' + { App $2 $1 [] } + | lambda_expression + { $1 } + +app_args :: { [Expr Position] } + : expression { [$1] } + | app_args ',' expression { $1 ++ [$3] } + +block_expression :: { Expr Position } + : '{' statements '}' { Block $1 $2 } + | application_expression { $1 } + +expression :: { Expr Position } + : block_expression { $1 } { lexer :: (Lexeme -> Parser a) -> Parser a @@ -400,8 +389,14 @@ happyError = raiseP "Parse Error" pappend :: ([a],[b]) -> ([a],[b]) -> ([a],[b]) pappend (a,b) (c,d) = (a++c,b++d) -makeQualified :: String -> QualifiedName -makeQualified str = QualifiedName prefixes name +makeQualified :: Lexeme -> QualifiedName +makeQualified (Lexeme _ (TokTypeIdent str)) = makeQualified' str +makeQualified (Lexeme _ (TokValIdent str)) = makeQualified' str +makeQualified (Lexeme _ (TokOpIdent str)) = makeQualified' str +makeQualified _ = error "makeQualified bad arg" + +makeQualified' :: String -> QualifiedName +makeQualified' str = QualifiedName prefixes name where (prefixes,name) = loop str loop val = @@ -410,5 +405,26 @@ makeQualified str = QualifiedName prefixes name then ([], pre) else let (pres, name) = loop 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 + final_type <- case mrettype of + Nothing -> do + name <- gensym + return (TVar name Star) + Just x -> + return x + case margs of + Nothing -> + return (DeclValue src [] final_type body) + Just [] -> + fail "Need to figure out empty arg items." + Just args -> + fail "Need to figure out non-empty arg items." + } diff --git a/hsrc/Syntax/ParserCore.hs b/hsrc/Syntax/ParserCore.hs index 6f6bccd..15060f1 100644 --- a/hsrc/Syntax/ParserCore.hs +++ b/hsrc/Syntax/ParserCore.hs @@ -37,7 +37,7 @@ pprtPosition p = posFile p ++ ":" ++ show (posLine p) ++ ":" ++ show (posCol p) data Token = LParen | RParen | LSquare | RSquare | LBrace | RBrace - | Bar | Semi | Comma + | Bar | Semi | Comma | BTick | TokTypeIdent String | TokValIdent String | TokOpIdent String @@ -90,6 +90,7 @@ data ParserState = ParserState { , psChar :: !Char , psPos :: !Position , psLexCode :: !Int + , psGenNum :: !Int } deriving (Show) @@ -99,6 +100,7 @@ initParserState path bs = ParserState { , psChar = '\n' , psPos = initPosition path , psLexCode = 0 + , psGenNum = 0 } -- -------------------------------------------------------------------------- @@ -138,3 +140,9 @@ runParser path bs (Parser m) = Right (a,_) -> Right a Left err -> Left err +genstr :: Parser String +genstr = do + st <- get + set st{ psGenNum = psGenNum st + 1 } + return $ "--gen" ++ show (psGenNum st) +