diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,10 +9,10 @@ - yapb: a library for a programmable parser builder system - yapb-exe: a wrapper interface to YAPB - conv-exe: a grammar format utility for conversion of a readable grammar (.lgrm) format into the Haskell data format (.grm) -- syncomp-exe: a syntax completion server for Emacs - Examples: - parser-exe: an arithmetic parser - - polyrpc-exe: a polyrpc programming language system including a parser, a poly rpc type checker, a slicing compiler, a poly cs type checker, and a poly cs interpter. + - syncomp-exe: a syntax completion server for Emacs + - (polyrpc)[https://github.com/kwanghoon/polyrpc]: a polyrpc programming language system including a parser, a poly rpc type checker, a slicing compiler, a poly cs type checker, and a poly cs interpter. ### Download and build ~~~ @@ -21,142 +21,11 @@ $ stack build ~~~ -### How to write and run a parser -~~~ - $ ls app/parser/*.hs - app/parser/Lexer.hs app/parser/Main.hs app/parser/Parser.hs app/parser/Token.hs - - $ cat app/parser/Lexer.hs - module Lexer(lexerSpec) where - - import Prelude hiding (EQ) - import CommonParserUtil - import Token - - mkFn :: Token -> (String -> Maybe Token) - mkFn tok = \text -> Just tok - - skip :: String -> Maybe Token - skip = \text -> Nothing - - lexerSpec :: LexerSpec Token - lexerSpec = LexerSpec - { - endOfToken = END_OF_TOKEN, - lexerSpecList = - [ ("[ \t\n]", skip), - ("[0-9]+" , mkFn INTEGER_NUMBER), - ("\\(" , mkFn OPEN_PAREN), - ("\\)" , mkFn CLOSE_PAREN), - ("\\+" , mkFn ADD), - ("\\-" , mkFn SUB), - ("\\*" , mkFn MUL), - ("\\/" , mkFn DIV), - ("\\=" , mkFn EQ), - ("\\;" , mkFn SEMICOLON), - ("[a-zA-Z][a-zA-Z0-9]*" , mkFn IDENTIFIER) - ] - } - - - $ cat app/parser/Parser.hs - module Parser where - - import CommonParserUtil - import Token - import Expr - - - parserSpec :: ParserSpec Token AST - parserSpec = ParserSpec - { - startSymbol = "SeqExpr'", - - parserSpecList = - [ - ("SeqExpr' -> SeqExpr", \rhs -> get rhs 1), - - ("SeqExpr -> SeqExpr ; AssignExpr", - \rhs -> toAstSeq ( - fromAstSeq (get rhs 1) ++ [fromAstExpr (get rhs 3)]) ), - - ("SeqExpr -> AssignExpr", \rhs -> toAstSeq [fromAstExpr (get rhs 1)]), - - ("AssignExpr -> identifier = AssignExpr", - \rhs -> toAstExpr (Assign (getText rhs 1) (fromAstExpr (get rhs 3))) ), - - ("AssignExpr -> AdditiveExpr", \rhs -> get rhs 1), - - ("AdditiveExpr -> AdditiveExpr + MultiplicativeExpr", - \rhs -> toAstExpr ( - BinOp Expr.ADD (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ), - - ("AdditiveExpr -> AdditiveExpr - MultiplicativeExpr", - \rhs -> toAstExpr ( - BinOp Expr.SUB (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ), - - ("AdditiveExpr -> MultiplicativeExpr", \rhs -> get rhs 1), - - ("MultiplicativeExpr -> MultiplicativeExpr * PrimaryExpr", - \rhs -> toAstExpr ( - BinOp Expr.MUL (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ), - - ("MultiplicativeExpr -> MultiplicativeExpr / PrimaryExpr", - \rhs -> toAstExpr ( - BinOp Expr.DIV (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ), - - ("MultiplicativeExpr -> PrimaryExpr", \rhs -> get rhs 1), - - ("PrimaryExpr -> identifier", \rhs -> toAstExpr (Var (getText rhs 1)) ), - - ("PrimaryExpr -> integer_number", - \rhs -> toAstExpr (Lit (read (getText rhs 1))) ), - - ("PrimaryExpr -> ( AssignExpr )", \rhs -> get rhs 2) - ], - - baseDir = "./", - actionTblFile = "action_table.txt", - gotoTblFile = "goto_table.txt", - grammarFile = "prod_rules.txt", - parserSpecFile = "mygrammar.grm", - genparserexe = "yapb-exe" - } - - $ cat app/parser/example/oneline.arith - 1 + 2 - 3 * 4 / 5 - - $ cat app/parser/example/multiline.arith - x = 123; - x = x + 1; - y = x; - y = y - 1 * 2 / 3; - z = y = x - - $ stack exec parser-exe - Enter your file: app/parser/example/oneline.arith - Lexing... - Parsing... - done. - Pretty Printing... - ((1 + 2) - ((3 * 4) / 5)) - - $ stack exec parser-exe - Enter your file: app/parser/example/multiline.arith - Lexing... - Parsing... - done. - Pretty Printing... - (x = 123); (x = (x + 1)); (y = x); (y = (y - ((1 * 2) / 3))); (z = (y = x)) -~~~ +### Tutorial +- [How to write and run a parser](https://github.com/kwanghoon/yapb/blob/master/doc/Tutorial-parser.md) +- [How to write and run a syntax completion server for Emacs](https://github.com/kwanghoon/yapb/blob/master/doc/Tutorial-syntax-completion.md) +- [A top-down approach to writing a compiler for arithmetic expressions](https://github.com/kwanghoon/swlab_parser_builder/blob/master/doc/tutorial_swlab_parser_builder.txt) Written in Korean. -### Documents -- [Parser generators sharing LR automaton generators and accepting general-purpose programming language-based specifications, J. of KIISE, 47(1), January 2020](http://swlab.jnu.ac.kr/paper/kiise202001.pdf) Written in Korean. -- [A topdown approach to writing a compiler](https://github.com/kwanghoon/swlab_parser_builder/blob/master/doc/tutorial_swlab_parser_builder.txt) Written in Korean. -- C++/Java/Python parser builder systems using YAPB - - [Java parser](https://github.com/kwanghoon/swlab_parser_builder) - - [C++ parser](https://github.com/tlsdorye/swlab-parser-lib) - - [Python parser](https://github.com/limjintack/swlab_parser_python). - - Architecture - * +### Reference +- [References](https://github.com/kwanghoon/yapb/blob/master/doc/Reference.md) diff --git a/app/polyrpc/Compile.hs b/app/polyrpc/Compile.hs deleted file mode 100644 --- a/app/polyrpc/Compile.hs +++ /dev/null @@ -1,442 +0,0 @@ -module Compile where - -import qualified Data.Set as Set -import qualified Data.List as List -import qualified Data.Maybe as Maybe - -import Location - -import qualified Type as ST -import qualified Expr as SE -import Literal -import Prim -import BasicLib - -import qualified CSType as TT -import qualified CSExpr as TE - -import Control.Monad - -compile :: Monad m => - SE.GlobalTypeInfo -> [SE.TopLevelDecl] -> m (TE.GlobalTypeInfo, TE.FunctionStore, TE.Expr) - -compile s_gti s_topleveldecls = do - let s_topleveldecls_with_basiclib = - [SE.BindingTopLevel (SE.Binding x ty expr) | (x,ty,expr) <- basicLib] ++ s_topleveldecls - let basicLibTypeInfo = [(x,ty) | (x,ty,expr)<-basicLib] - - let s_gti1 = s_gti {SE._bindingTypeInfo = basicLibTypeInfo} - (funStore, t_libs, t_bindingDecls, s_gti2) <- - compTopLevels s_gti1 TE.initFunctionStore s_topleveldecls_with_basiclib - t_gti <- compileGTI s_gti t_libs - let main = TE.ValExpr (TE.UnitM (TE.Lit UnitLit)) - return (t_gti, funStore, TE.singleBindM $ TE.BindM t_bindingDecls main) - - ------ - --------------- --- Compile GTI --------------- -compileGTI :: Monad m => SE.GlobalTypeInfo -> TE.LibInfo -> m TE.GlobalTypeInfo -compileGTI (SE.GlobalTypeInfo - { SE._typeInfo = typeInfo, - SE._conTypeInfo = conTypeInfo, - SE._dataTypeInfo = dataTypeInfo, - SE._bindingTypeInfo = bindingTypeInfo }) t_libs = do - target_typeInfo <- compTypeInfo typeInfo - target_conTypeInfo <- compConTypeInfo conTypeInfo - target_dataTypeInfo <- compDataTypeInfo dataTypeInfo - return (TE.GlobalTypeInfo - { TE._typeInfo = target_typeInfo, - TE._conTypeInfo = target_conTypeInfo, - TE._dataTypeInfo = target_dataTypeInfo, - TE._libInfo = t_libs }) - -compTypeInfo :: Monad m => SE.TypeInfo -> m TE.TypeInfo -compTypeInfo typeInfo = return typeInfo - -compConTypeInfo :: Monad m => SE.ConTypeInfo -> m TE.ConTypeInfo -compConTypeInfo conTypeInfo = mapM compConTypeInfo' conTypeInfo - where - compConTypeInfo' (cname, (argtys, dtname, locvars, tyvars)) = do - target_argtys <- mapM compValType argtys - return (cname, (target_argtys, dtname, locvars, tyvars)) - -compDataTypeInfo :: Monad m => SE.DataTypeInfo -> m TE.DataTypeInfo -compDataTypeInfo dataTypeInfo = mapM compDataTypeInfo' dataTypeInfo - -compDataTypeInfo' (dtname, (locvars, tyvars, cnameArgtysList)) = do - target_cnameArgtysList <- - mapM (\ (cname,argtys)-> do target_argtys <- mapM compValType argtys - return (cname,target_argtys)) cnameArgtysList - return (dtname, (locvars, tyvars, target_cnameArgtysList)) - -compBindingTypeInfo :: Monad m => SE.BindingTypeInfo -> m TE.BindingTypeInfo -compBindingTypeInfo bindingTypeInfo = mapM compBindingTypeInfo' bindingTypeInfo - where - compBindingTypeInfo' (x,ty) = do - target_ty <- compValType ty - return (x,target_ty) - ----------------------- --- Compile value types ----------------------- -compValType :: Monad m => ST.Type -> m TT.Type -compValType (ST.TypeVarType s) = return (TT.TypeVarType s) - -compValType (ST.TupleType tys) = do - t_tys <- mapM compValType tys - return (TT.TupleType t_tys) - -compValType (ST.FunType ty1 loc ty2) = do - t_ty1 <- compValType ty1 - t_ty2 <- compType ty2 - return (TT.CloType (TT.FunType t_ty1 loc t_ty2)) - -compValType (ST.TypeAbsType alphas ty) = do - t_ty <- compType ty - return (TT.CloType (TT.TypeAbsType alphas t_ty)) - -compValType (ST.LocAbsType ls ty) = do - t_ty <- compType ty - return (TT.CloType (TT.LocAbsType ls t_ty)) - -compValType (ST.ConType s locs tys) = do - t_tys <- mapM compValType tys - return (TT.ConType s locs t_tys) - ----------------------------- --- Compile computation types ----------------------------- -compType :: Monad m => ST.Type -> m TT.Type -compType ty = do - t_ty <- compValType ty - return (TT.MonType t_ty) - --------------------- --- Compile toplevels --------------------- - -compTopLevels :: Monad m => - SE.GlobalTypeInfo -> TE.FunctionStore -> - [SE.TopLevelDecl] -> m (TE.FunctionStore, TE.LibInfo, [TE.BindingDecl], SE.GlobalTypeInfo) -compTopLevels s_gti funStore [] = return (funStore, [], [], s_gti) -compTopLevels s_gti funStore (toplevel:toplevels) = do - (funStore1, t_toplevels1, bindingDecls1, s_gti1) <- compTopLevel s_gti funStore toplevel - (funStore2, t_toplevels2, bindingDecls2, s_gti2) <- compTopLevels s_gti1 funStore1 toplevels - return (funStore2, t_toplevels1++t_toplevels2, bindingDecls1++bindingDecls2, s_gti2) - -compTopLevel :: Monad m => - SE.GlobalTypeInfo -> TE.FunctionStore -> - SE.TopLevelDecl -> m (TE.FunctionStore, TE.LibInfo, [TE.BindingDecl], SE.GlobalTypeInfo) - -compTopLevel s_gti funStore (SE.LibDeclTopLevel x ty) = do - target_ty <- compValType ty - return (funStore, [(x, target_ty)], [], s_gti) - -compTopLevel s_gti funStore (SE.DataTypeTopLevel - (SE.DataType dtname locvars tyvars tycondecls)) = return (funStore, [], [], s_gti) - -compTopLevel s_gti funStore (SE.BindingTopLevel bindingDecl@(SE.Binding x ty expr)) = do - let env = SE.initEnv {SE._varEnv = (x,ty):SE._bindingTypeInfo s_gti} --- let env1 = env {SE._varEnv = SE._bindingTypeInfo s_gti ++ SE._varEnv env} -- TODO: Need to be optimized!! - (funStore1, t_bindingDecl) <- compBindingDecl s_gti env clientLoc funStore bindingDecl - let s_gti1 = s_gti{SE._bindingTypeInfo=(x,ty):SE._bindingTypeInfo s_gti} - return ( funStore1, [], [t_bindingDecl], s_gti1 ) - -------------------------------- --- Compile binding declarations -------------------------------- --- --- Note: InterTE.Binding x ty expr as do x:ty <- expr --- -compBindingDecl :: Monad m => - SE.GlobalTypeInfo -> SE.Env -> Location -> - TE.FunctionStore -> SE.BindingDecl -> m (TE.FunctionStore, TE.BindingDecl) - -compBindingDecl s_gti env loc funStore (SE.Binding x ty expr) = do - target_ty <- compValType ty - (funStore1, target_expr) <- compExpr s_gti env loc ty funStore expr - let recursion = Set.member x (TE.fvExpr target_expr) - if recursion then - do let (y, funStore2) = TE.newVar funStore1 - let (z, funStore3) = TE.newVar funStore2 - return (funStore3, - TE.Binding x target_ty - (TE.ValExpr - (TE.BindM [TE.Binding y target_ty target_expr] - (TE.Let [TE.Binding z target_ty - (TE.Prim MkRecOp [] [] [TE.Var y, TE.Lit (StrLit x)])] - (TE.ValExpr (TE.UnitM (TE.Var z))))))) - else - return (funStore1, TE.Binding x target_ty target_expr) - --- compExpr -compExpr :: Monad m => - SE.GlobalTypeInfo -> SE.Env -> Location -> ST.Type -> - TE.FunctionStore -> SE.Expr -> m (TE.FunctionStore, TE.Expr) -- Ending with 'ValExpr Expr'?? - -compExpr s_gti env loc s_ty funStore (SE.Var x) = - return (funStore, TE.ValExpr $ TE.UnitM (TE.Var x)) - -compExpr s_gti env loc (ST.TypeAbsType tyvars0 s_ty) funStore (SE.TypeAbs tyvars1 expr) = do - -- Assume tyvars0 == tyvars1 - t_ty <- compType s_ty - let target_ty = TT.TypeAbsType tyvars0 t_ty - let env1 = env {SE._typeVarEnv = noDupAppend tyvars1 (SE._typeVarEnv env)} - (funStore1, target_expr) <- compExpr s_gti env1 loc s_ty funStore expr - let opencode = TE.CodeTypeAbs tyvars1 target_expr - - (funStore2, closure) <- mkClosure env loc funStore1 target_ty opencode - return (funStore2, TE.ValExpr $ TE.UnitM closure) - -compExpr s_gti env loc s_ty funStore (SE.TypeAbs tyvars expr) = do - error $ "[compVal] Not type-abstraction type: " ++ show s_ty - - -compExpr s_gti env loc (ST.LocAbsType locvars0 s_ty) funStore (SE.LocAbs locvars1 expr) = do - -- Assume tyvars0 == tyvars1 - t_ty <- compType s_ty - let target_ty = TT.LocAbsType locvars0 t_ty - let env1 = env {SE._locVarEnv = noDupAppend locvars1 (SE._locVarEnv env)} - (funStore1, target_expr) <- compExpr s_gti env1 loc s_ty funStore expr - let opencode = TE.CodeLocAbs locvars1 target_expr - - (funStore2, closure) <- mkClosure env loc funStore1 target_ty opencode - return (funStore2, TE.ValExpr $ TE.UnitM closure) - -compExpr s_gti env loc s_ty funStore (SE.LocAbs locvars1 expr) = do - error $ "[compExpr] Not location-abstraction type: " ++ show s_ty - - -compExpr s_gti env loc (ST.FunType s_argty s_loc s_resty) funStore (SE.Abs xtylocs expr) = do - -- Assume tyvars0 == tyvars1 - t_argty <- compValType s_argty - t_resty <- compType s_resty - let target_ty = TT.FunType t_argty s_loc t_resty - let s_xtys = [(x,ty) | (x,ty,_) <- xtylocs] - t_xtys <- mapM (\(x,ty) -> do { t_ty <- compValType ty; return (x,t_ty) }) s_xtys - let env1 = env {SE._varEnv = (s_xtys ++ SE._varEnv env)} - (funStore1, target_expr) <- compExpr s_gti env1 s_loc s_resty funStore expr - let opencode = TE.CodeAbs t_xtys target_expr - - (funStore2, closure) <- mkClosure env s_loc funStore1 target_ty opencode - return (funStore2, TE.ValExpr $ TE.UnitM closure) - -compExpr s_gti env loc s_ty funStore (SE.Abs xtylocs expr) = do - error $ "[compExpr] Not abstraction type: " ++ show s_ty ++ ", " ++ show (SE.Abs xtylocs expr) - - -compExpr s_gti env loc (ST.TupleType tys) funStore (SE.Tuple exprs) = do - let (xs, funStore1) = TE.newVars (length exprs) funStore - (funStore2, h) <- - foldM (\ (funStore0, f) -> \ (x, s_ty, expr) -> do - (funStore1, target_expr) <- compExpr s_gti env loc s_ty funStore0 expr - t_ty <- compValType s_ty - let g = TE.BindM [TE.Binding x t_ty target_expr] . TE.ValExpr . f - return (funStore1, g)) (funStore1, \x->x) (reverse (zip3 xs tys exprs)) - return (funStore2, TE.ValExpr $ h (TE.UnitM (TE.Tuple (map TE.Var xs)))) - - -compExpr s_gti env loc s_ty funStore (SE.Tuple exprs) = do - error $ "[compExpr]: Not tuple type: " ++ show s_ty - -compExpr s_gti env loc s_ty funStore (SE.Lit lit) = - return (funStore, TE.ValExpr $ TE.UnitM (TE.Lit lit)) - -compExpr s_gti env loc s_ty funStore (SE.Constr cname locs argtys exprs tys) = do - let (xs, funStore1) = TE.newVars (length exprs) funStore - t_tys <- mapM compValType tys - t_argtys <- mapM compValType argtys - (funStore2, h) <- - foldM (\ (funStore0, f) -> \ (x, s_ty, expr) -> do - (funStore1, target_expr) <- compExpr s_gti env loc s_ty funStore0 expr - t_ty <- compValType s_ty - let g = TE.BindM [TE.Binding x t_ty target_expr] . TE.ValExpr . f - return (funStore1, g)) (funStore1, \x->x) (reverse (zip3 xs tys exprs)) - return (funStore2, TE.ValExpr $ h $ TE.UnitM $ TE.Constr cname locs t_argtys (map TE.Var xs) t_tys) - -compExpr s_gti env loc s_ty funStore (SE.Let bindingDecls expr) = do - let bindingTypeInfo = [(x,ty) | SE.Binding x ty expr <- bindingDecls] - let bindingTypeInfo1 = (bindingTypeInfo ++ SE._varEnv env) - let env1 = env { SE._varEnv=bindingTypeInfo1 } - (funStore2, t_bindingDecls) <- - foldM (\(funStore0, bindingDecls0) -> \bindingDecl0 -> do - (funStore1,bindingDecl1) - <- compBindingDecl s_gti env1 loc funStore0 bindingDecl0 - return (funStore1, bindingDecl1:bindingDecls0)) - (funStore, []) - (reverse bindingDecls) - (funStore3, t_expr) <- compExpr s_gti env loc s_ty funStore2 expr - return (funStore3, TE.singleBindM $ TE.BindM t_bindingDecls t_expr) - -compExpr s_gti env loc s_ty funStore (SE.Case expr (Just case_ty) alts) = do - let (x, funStore0) = TE.newVar funStore - target_case_ty <- compValType case_ty - (funStore1, target_expr) <- compExpr s_gti env loc case_ty funStore0 expr - case case_ty of - ST.ConType tyconName locs tys -> - case SE.lookupDataTypeName s_gti tyconName of - ((locvars, tyvars, tycondecls):_) -> do - (funStore2, target_alts) <- - compAlts s_gti env loc locs locvars tys tyvars tycondecls s_ty funStore1 alts - return (funStore2, TE.ValExpr $ - TE.BindM [ TE.Binding x target_case_ty target_expr ] - (TE.Case (TE.Var x) target_case_ty target_alts)) - [] -> error $ "[compExpr] invalid constructor type: " ++ tyconName - - ST.TupleType tys -> do - (funStore3, target_alts) <- compAlts s_gti env loc [] [] tys [] [] s_ty funStore1 alts - return (funStore3, TE.ValExpr $ - TE.BindM [ TE.Binding x target_case_ty target_expr ] - (TE.Case (TE.Var x) target_case_ty target_alts)) - -compExpr s_gti env loc s_ty funStore (SE.Case expr maybe alternatives) = do - error $ "[compExpr] No case expression type: " ++ show (SE.Case expr maybe alternatives) - -compExpr s_gti env loc s_ty funStore (SE.App left (Just (ST.FunType argty locfun resty)) right maybeLoc) = do - let ([f,x], funStore1) = TE.newVars 2 funStore - (funStore2, target_left) <- compExpr s_gti env loc (ST.FunType argty locfun resty) funStore1 left - (funStore3, target_right) <- compExpr s_gti env loc argty funStore2 right - target_funty <- compValType (ST.FunType argty locfun resty) - target_argty <- compValType argty - let app = if loc==locfun then - TE.App (TE.Var f) target_funty (TE.Var x) - else if loc==clientLoc && locfun==serverLoc then - TE.ValExpr $ TE.Req (TE.Var f) target_funty (TE.Var x) - else if loc==serverLoc && locfun==clientLoc then - TE.ValExpr $ TE.Call (TE.Var f) target_funty (TE.Var x) - else - TE.ValExpr $ TE.GenApp locfun (TE.Var f) target_funty (TE.Var x) - return (funStore3, - TE.ValExpr $ TE.BindM [TE.Binding f target_funty target_left] - (TE.ValExpr - (TE.BindM [TE.Binding x target_argty target_right] - app))) - -compExpr s_gti env loc s_ty funStore (SE.App left Nothing right maybeLoc) = do - error $ "[compExpr] App" - - -compExpr s_gti env loc s_ty funStore (SE.TypeApp expr (Just left_s_ty) tys) = do - let (f, funStore1) = TE.newVar funStore - (funStore2, target_expr) <- compExpr s_gti env loc left_s_ty funStore1 expr - target_left_s_ty <- compValType left_s_ty - target_tys <- mapM compValType tys - return (funStore2, - TE.ValExpr $ TE.BindM [TE.Binding f target_left_s_ty target_expr] - (TE.TypeApp (TE.Var f) target_left_s_ty target_tys)) - -compExpr s_gti env loc s_ty funStore (SE.TypeApp expr Nothing tys) = - error $ "[compExpr] TypeApp" - -compExpr s_gti env loc s_ty funStore (SE.LocApp expr (Just left_s_ty) locs) = do - let (f, funStore1) = TE.newVar funStore - (funStore2, target_expr) <- compExpr s_gti env loc left_s_ty funStore1 expr - target_left_s_ty <- compValType left_s_ty - return (funStore2, - TE.ValExpr $ TE.BindM [TE.Binding f target_left_s_ty target_expr] - (TE.LocApp (TE.Var f) target_left_s_ty locs)) - -compExpr s_gti env loc s_ty funStore (SE.LocApp expr Nothing locs) = - error $ "[compExpr] LocApp" - -compExpr s_gti env loc s_ty funStore (SE.Prim primop op_locs op_tys exprs) = do - let (y, funStore0) = TE.newVar funStore - let (xs, funStore1) = TE.newVars (length exprs) funStore0 - case SE.lookupPrimOpType primop of - ((locvars, tyvars, argtys, retty):_) -> do - target_op_tys <- mapM compValType op_tys - (funStore2, h) <- - foldM (\ (funStore0, f) -> \ (x, s_ty, expr) -> do - (funStore1, target_expr) <- compExpr s_gti env loc s_ty funStore0 expr - t_ty <- compValType s_ty - let g = TE.ValExpr . TE.BindM [TE.Binding x t_ty target_expr] . f - return (funStore1, g)) (funStore1, \x->x) (reverse (zip3 xs argtys exprs)) - target_retty <- compValType retty - return (funStore2, - h (TE.Let [TE.Binding y target_retty - (TE.Prim primop op_locs target_op_tys (map TE.Var xs))] - (TE.ValExpr (TE.UnitM (TE.Var y))))) - - [] -> error $ "[compExpr] Not found Prim " ++ show primop - - ------------ --- compAlts ------------ -compAlts s_gti env loc locs locvars tys tyvars tycondecls s_ty funStore [alt] = do - let substLoc = zip locvars locs - let substTy = zip tyvars tys - (funStore1, target_alt) <- compAlt s_gti env loc substLoc substTy tycondecls [] s_ty funStore alt - return (funStore1, [target_alt]) - -compAlts s_gti env loc locs locvars tys tyvars tycondecls s_ty funStore (alt:alts) = do - let substLoc = zip locvars locs - let substTy = zip tyvars tys - (funStore1, target_alt) <- compAlt s_gti env loc substLoc substTy tycondecls [] s_ty funStore alt - (funStore2, target_alts) <- compAlts s_gti env loc locs locvars tys tyvars tycondecls s_ty funStore1 alts - return (funStore2, target_alt:target_alts) - - -compAlt s_gti env loc substLoc substTy tycondecls externTys s_ty funStore (SE.Alternative con args expr) = do --- externTys only for TupleAlternative - case SE.lookupCon tycondecls con of - (tys:_) -> - if length tys==length args - then do let tys' = map (ST.doSubst substTy) (map (ST.doSubstLoc substLoc) tys) - let varEnv = SE._varEnv env - let varEnv' = zip args tys' ++ varEnv - let env1 = env {SE._varEnv=varEnv'} - (funStore1, target_expr) <- compExpr s_gti env1 loc s_ty funStore expr - return (funStore1, TE.Alternative con args target_expr) - else error $ "[compAlt]: invalid arg length: " ++ con ++ show args - -compAlt s_gti env loc substLoc substTy tycondecls externTys s_ty funStore (SE.TupleAlternative args expr) = do --- substTy==[], tycondecls==[] - let varEnv = SE._varEnv env - let varEnv' = zip args externTys ++ varEnv - let env1 = env {SE._varEnv=varEnv'} - (funStore1, target_expr) <- compExpr s_gti env loc s_ty funStore expr - return (funStore1, TE.TupleAlternative args target_expr) - --- --- Utility shared by compExpr(SE.TypeAbs), compExpr(SE.LocAbs), compExpr(SE.Abs) --- -mkClosure env loc funStore target_ty opencode = do - let (fname,funStore1) = TE.newName funStore - let locvars = SE._locVarEnv env - let tyvars = SE._typeVarEnv env - - -- let (_freevars, _freetys) = unzip $ SE._varEnv env - - let freevars = Set.toList (TE.fvOpenCode opencode) - let freetys = [ty | x <- freevars - , let ty = case List.lookup x (SE._varEnv env) of - Just ty -> ty - Nothing -> error $ "[mkClosure] freetys: not found " - ++ x ++ " in " ++ fname ++ "\n" - ++ show opencode ++ "\n" - ++ show freevars ++ "\n" - ++ show (SE._varEnv env)] - - let target_freevars = map TE.Var freevars - - - target_freetys <- mapM compValType freetys - let codename = TE.CodeName fname (map LocVar locvars) (map TT.TypeVarType tyvars) - let codety = TT.CodeType locvars tyvars target_freetys target_ty - let code = TE.Code locvars tyvars freevars opencode - - let funStore2 = TE.addFun loc funStore1 fname codety code - return (funStore2, TE.Closure target_freevars target_freetys codename []) - --- -noDupAppend xs [] = xs -noDupAppend xs (y:ys) = - case List.find (y==) xs of - Just _ -> noDupAppend xs ys - Nothing -> noDupAppend (xs ++ [y]) ys - - diff --git a/app/polyrpc/Execute.hs b/app/polyrpc/Execute.hs deleted file mode 100644 --- a/app/polyrpc/Execute.hs +++ /dev/null @@ -1,699 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} - -module Execute where - -import Location -import Prim -import Literal -import CSType -import CSExpr hiding (Env(..), _new) - -import qualified Data.Map as Map ---import Text.JSON.Generic - -data Mem = Mem { _new :: Integer, _map :: Map.Map Addr Value } - --- data Addr = Addr String Integer -- (loc,addr) -type Addr = Integer - -initMem = Mem { _new=1, _map=Map.empty } - -allocMem :: Value -> Mem -> (Addr, Mem) -allocMem v mem = - let next = _new mem - addrVals = _map mem - in (next, mem { _new=next+1, _map=Map.insert next v addrVals }) - -readMem :: Addr -> Mem -> Value -readMem addr mem = - case Map.lookup addr (_map mem) of - Just v -> v - Nothing -> error $ "[readMem] Not found: " ++ show addr - -writeMem :: Addr -> Value -> Mem -> Mem -writeMem addr v mem = mem { _map= Map.insert addr v (_map mem) } - - --- Configuration - -type EvalContext = Expr -> Expr - -type Stack = [EvalContext] - -data Config = - ClientConfig [EvalContext] Expr Stack Mem Stack Mem -- --- deriving (Show, Typeable, Data) - - --- -execute :: Bool -> GlobalTypeInfo -> FunctionStore -> Expr -> IO Value -execute debug gti funStore mainExpr = do - v <- run debug funStore (initConfig mainExpr) - return v - -assert b action = if b then action else return () - --- -run :: Bool -> FunctionStore -> Config -> IO Value - -run debug funStore (ClientConfig [] (ValExpr (UnitM v)) [] mem_c [] mem_s) = do - assert debug (putStrLn $ "[DONE]: [Client] " ++ show (ValExpr (UnitM v)) ++ "\n") - - return v - -run debug funStore (ClientConfig evctx expr client_stack mem_c server_stack mem_s) = do - assert debug (putStrLn $ "[STEP] [Client] " ++ show expr ++ "\n") - assert debug (putStrLn $ " EvCtx " ++ showEvCxt evctx ++ "\n") - assert debug (putStrLn $ " c stk " ++ showStack client_stack ++ "\n") - assert debug (putStrLn $ " mem " ++ show (Map.toList $ _map mem_c) ++ "\n") - assert debug (putStrLn $ " s stk " ++ showStack server_stack ++ "\n") - assert debug (putStrLn $ " mem " ++ show (Map.toList $ _map mem_s) ++ "\n") - - config <- clientExpr funStore [] (applyEvCxt evctx expr) client_stack mem_c server_stack mem_s - run debug funStore config - -run debug funStore (ServerConfig client_stack mem_c evctx expr server_stack mem_s) = do - assert debug (putStrLn $ "[STEP] [Server] " ++ show expr ++ "\n") - assert debug (putStrLn $ " EvCtx " ++ showEvCxt evctx ++ "\n") - assert debug (putStrLn $ " c stk " ++ showStack client_stack ++ "\n") - assert debug (putStrLn $ " mem " ++ show (Map.toList $ _map mem_c) ++ "\n") - assert debug (putStrLn $ " s stk " ++ showStack server_stack ++ "\n") - assert debug (putStrLn $ " mem " ++ show (Map.toList $ _map mem_s) ++ "\n") - - config <- serverExpr funStore client_stack mem_c [] (applyEvCxt evctx expr) server_stack mem_s - run debug funStore config - --- -initConfig main_expr = ClientConfig [] main_expr [] initMem [] initMem - --- -applyEvCxt [] expr = expr -applyEvCxt (evcxt:evcxts) expr = applyEvCxt evcxts (evcxt expr) - -toFun [] = \x->x -toFun (evcxt:evcxts) = toFun evcxts . evcxt - -showEvCxt cxt = show $ applyEvCxt cxt (ValExpr (Var "HOLE")) - -showStack stk = show $ map showEvCxt [[cxt] | cxt <- stk] - ------------------------------------------------------------ --- < EvCtx[ Value]; Client stack | Server stack> ==> Config ------------------------------------------------------------ - -clientExpr :: FunctionStore -> [EvalContext] -> Expr -> Stack -> Mem -> Stack -> Mem -> IO Config - -clientExpr fun_store evctx (ValExpr v) client_stack mem_c server_stack mem_s = - clientValue fun_store evctx v client_stack mem_c server_stack mem_s - --- (E-Let) -clientExpr fun_store evctx (Let [Binding x ty b@(ValExpr v)] expr) client_stack mem_c server_stack mem_s = do - let subst = [(x,v)] - return $ ClientConfig evctx (doSubstExpr subst expr) client_stack mem_c server_stack mem_s - --- (let x = Elet[] in M) -clientExpr fun_store evctx (Let [Binding x ty b@(_)] expr) client_stack mem_c server_stack mem_s = do - clientExpr fun_store ((\bexpr->Let [Binding x ty bexpr] expr):evctx) b client_stack mem_c server_stack mem_s - --- (E-Proj-i) or (E-Tuple) -clientExpr fun_store evctx (Case (Tuple vs) casety [TupleAlternative xs expr]) client_stack mem_c server_stack mem_s = do - let subst = zip xs vs - return $ ClientConfig evctx (doSubstExpr subst expr) client_stack mem_c server_stack mem_s - --- (E-Proj-i) or (E-Data constructor) or (E-if) -clientExpr fun_store evctx (Case (Constr cname locs tys vs argtys) casety alts) client_stack mem_c server_stack mem_s = do - case [(dname,xs,expr) | Alternative dname xs expr <- alts, cname==dname] of - ((_,xs,expr):_) -> do - let subst = zip xs vs - return $ ClientConfig evctx (doSubstExpr subst expr) client_stack mem_c server_stack mem_s - - [] -> error $ "[clientExpr] Case alternative not found: " ++ cname - --- (E-Proj-i) or (E-Data constructor) or (E-if) -clientExpr fun_store evctx (Case (Lit (BoolLit b)) casety alts) client_stack mem_c server_stack mem_s = do - let [Alternative b1 _ expr1,Alternative b2 _ expr2] = alts - let text_b = show b - if text_b==b1 then return $ ClientConfig evctx expr1 client_stack mem_c server_stack mem_s - else if text_b==b2 then return $ ClientConfig evctx expr2 client_stack mem_c server_stack mem_s - else error $ "[cilentExpr] Case unexpected: " ++ show b ++ "? " ++ b1 ++ " " ++ b2 - --- (E-App) -clientExpr fun_store evctx (App clo@(Closure vs vstys codename recf) funty arg) client_stack mem_c server_stack mem_s = do - let CodeName fname locs tys = codename - case [code | (gname,(codetype,code))<-_clientstore fun_store, fname==gname] of - ((Code locvars tyvars fvvars (CodeAbs [(x,_)] expr)):_) -> do - let subst = [(x,arg)] ++ zip fvvars vs - let substLoc = zip locvars locs - let substTy = zip tyvars tys - let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) - return $ ClientConfig evctx substed_expr client_stack mem_c server_stack mem_s - - [] -> error $ "[clientExpr] Client abs code not found: " ++ fname - --- (E-TApp) -clientExpr fun_store evctx (TypeApp clo@(Closure vs vstys codename recf) funty [argty]) client_stack mem_c server_stack mem_s = do - let CodeName fname locs tys = codename - case [code | (gname, (codetype,code))<-_clientstore fun_store, fname==gname] of - ((Code locvars tyvars fvvars (CodeTypeAbs [a] expr)):_) -> do - let subst = zip fvvars vs - let substLoc = zip locvars locs - let substTy = [(a,argty)] ++ zip tyvars tys - let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) - return $ ClientConfig evctx substed_expr client_stack mem_c server_stack mem_s - - [] -> error $ "[clientExpr] Client tyabs code not found: " ++ fname - --- (E-LApp) -clientExpr fun_store evctx (LocApp clo@(Closure vs vstys codename recf) funty [argloc]) client_stack mem_c server_stack mem_s = do - let CodeName fname locs tys = codename - case [code | (gname, (codetype,code))<-_clientstore fun_store, fname==gname] of - ((Code locvars tyvars fvvars (CodeLocAbs [l] expr)):_) -> do - let subst = zip fvvars vs - let substLoc = [(l,argloc)] ++ zip locvars locs - let substTy = zip tyvars tys - let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) - return $ ClientConfig evctx substed_expr client_stack mem_c server_stack mem_s - - [] -> error $ "[clientExpr] Client locabs code not found: " ++ fname - -clientExpr fun_store evctx (Prim primop locs tys vs) client_stack mem_c server_stack mem_s = do - (v, mem_c1) <- calc primop locs tys vs mem_c - return $ ClientConfig evctx (ValExpr v) client_stack mem_c1 server_stack mem_s - -clientExpr fun_store evctx expr client_stack mem_c server_stack mem_s = - error $ "[clientExpr] Unexpected: " ++ show expr ++ "\n" ++ show (applyEvCxt evctx expr) ++ "\n" - --- -clientValue :: FunctionStore -> [EvalContext] -> Value -> Stack -> Mem -> Stack -> Mem -> IO Config - --- (E-Unit-C) -clientValue fun_store [] (UnitM v) client_stack mem_c (top_evctx:server_stack) mem_s = - return $ ServerConfig client_stack mem_c [] (top_evctx (ValExpr (UnitM v))) server_stack mem_s - --- (E-Req) -clientValue fun_store evctx (Req f funty arg) client_stack mem_c server_stack mem_s = do - let client_stack1 = if null evctx then client_stack else (toFun evctx):client_stack - return $ ServerConfig client_stack1 mem_c [] (App f funty arg) server_stack mem_s - --- (E-Gen-C-C) and (E-Gen-C-S) -clientValue fun_store evctx (GenApp loc f funty arg) client_stack mem_c server_stack mem_s = do - if loc==clientLoc then - return $ ClientConfig evctx (App f funty arg) client_stack mem_c server_stack mem_s - else if loc==serverLoc then - return $ ClientConfig evctx (ValExpr (Req f funty arg)) client_stack mem_c server_stack mem_s - else - error $ "[clientValue] GenApp: Unexpected location : " ++ show loc - --- (E-Do) -clientValue fun_store evctx (BindM [Binding x ty b@(ValExpr (UnitM v))] expr) client_stack mem_c server_stack mem_s = do - let subst = [(x,v)] - return $ ClientConfig evctx (doSubstExpr subst expr) client_stack mem_c server_stack mem_s - --- ( do x<-E[] in M ) -clientValue fun_store evctx (BindM [Binding x ty b@(_)] expr) client_stack mem_c server_stack mem_s = do - clientExpr fun_store ((\bexpr->ValExpr (BindM [Binding x ty bexpr] expr)):evctx) b client_stack mem_c server_stack mem_s - -clientValue fun_store evctx v client_stack mem_c server_stack mem_s = - error $ "[clientValue] Unexpected: " ++ show v ++ "\n" ++ show (applyEvCxt evctx (ValExpr v)) ++ "\n" - - ------------------------------------------------------------- --- < Client stack | EvCtx[ Value ]; Server stack> ==> Config ------------------------------------------------------------- - -serverExpr :: FunctionStore -> Stack -> Mem -> [EvalContext] -> Expr -> Stack -> Mem -> IO Config - -serverExpr fun_store client_stack mem_c evctx (ValExpr v) server_stack mem_s = - serverValue fun_store client_stack mem_c evctx v server_stack mem_s - --- (E-Let) -serverExpr fun_store client_stack mem_c evctx (Let [Binding x ty b@(ValExpr v)] expr) server_stack mem_s = do - let subst = [(x,v)] - return $ ServerConfig client_stack mem_c evctx (doSubstExpr subst expr) server_stack mem_s - --- (let x = Elet[] in M) -serverExpr fun_store client_stack mem_c evctx (Let [Binding x ty b@(_)] expr) server_stack mem_s = do - serverExpr fun_store client_stack mem_c ((\bexpr->Let [Binding x ty bexpr] expr):evctx) b server_stack mem_s - --- (E-Proj-i) or (E-Tuple) or (E-if) -serverExpr fun_store client_stack mem_c evctx (Case (Tuple vs) casety [TupleAlternative xs expr]) server_stack mem_s = do - let subst = zip xs vs - return $ ServerConfig client_stack mem_c evctx (doSubstExpr subst expr) server_stack mem_s - --- (E-Proj-i) or (E-Data constructor) or (E-if) -serverExpr fun_store client_stack mem_c evctx (Case (Constr cname locs tys vs argtys) casety alts) server_stack mem_s = do - case [(dname,xs,expr) | Alternative dname xs expr <- alts, cname==dname] of - ((_,xs,expr):_) -> do - let subst = zip xs vs - return $ ServerConfig client_stack mem_c evctx (doSubstExpr subst expr) server_stack mem_s - - [] -> error $ "[serverExpr] Case alternative not found: " ++ cname - -serverExpr fun_store client_stack mem_c evctx (Case (Lit (BoolLit b)) casety alts) server_stack mem_s = do - let [Alternative b1 _ expr1,Alternative b2 _ expr2] = alts - let text_b = show b - if text_b==b1 then return $ ServerConfig client_stack mem_c evctx expr1 server_stack mem_s - else if text_b==b2 then return $ ServerConfig client_stack mem_c evctx expr2 server_stack mem_s - else error $ "[cilentExpr] Case unexpected: " ++ show b ++ "? " ++ b1 ++ " " ++ b2 - --- (E-App) -serverExpr fun_store client_stack mem_c evctx (App clo@(Closure vs vstys codename recf) funty arg) server_stack mem_s = do - let CodeName fname locs tys = codename - case [code | (gname,(codetyps,code))<-_serverstore fun_store, fname==gname] of - ((Code locvars tyvars fvvars (CodeAbs [(x,_)] expr)):_) -> do - let subst = [(x,arg)] ++ zip fvvars vs - let substLoc = zip locvars locs - let substTy = zip tyvars tys - let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) - return $ ServerConfig client_stack mem_c evctx substed_expr server_stack mem_s - - [] -> error $ "[serverExpr] Server abs code not found: " ++ fname - --- (E-TApp) -serverExpr fun_store client_stack mem_c evctx (TypeApp clo@(Closure vs vstys codename recf) funty [argty]) server_stack mem_s = do - let CodeName fname locs tys = codename - case [code | (gname, (codetype,code))<-_serverstore fun_store, fname==gname] of - ((Code locvars tyvars fvvars (CodeTypeAbs [a] expr)):_) -> do - let subst = zip fvvars vs - let substLoc = zip locvars locs - let substTy = [(a,argty)] ++ zip tyvars tys - let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) - return $ ServerConfig client_stack mem_c evctx substed_expr server_stack mem_s - - [] -> error $ "[serverExpr] Server tyabs code not found: " ++ fname ++ "\n" - ++ ", " ++ show [gname | (gname,_)<-_serverstore fun_store] ++ "\n" - ++ ", " ++ show [gname | (gname,_)<-_clientstore fun_store] ++ "\n" - --- (E-LApp) -serverExpr fun_store client_stack mem_c evctx (LocApp clo@(Closure vs vstys codename recf) funty [argloc]) server_stack mem_s = do - let CodeName fname locs tys = codename - case [code | (gname, (codetype,code))<-_serverstore fun_store, fname==gname] of - ((Code locvars tyvars fvvars (CodeLocAbs [l] expr)):_) -> do - let subst = zip fvvars vs - let substLoc = [(l,argloc)] ++ zip locvars locs - let substTy = zip tyvars tys - let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) - return $ ServerConfig client_stack mem_c evctx substed_expr server_stack mem_s - - [] -> error $ "[serverExpr] Server locabs code not found: " ++ fname - -serverExpr fun_store client_stack mem_c evctx (Prim primop locs tys vs) server_stack mem_s = do - (v, mem_s1) <- calc primop locs tys vs mem_s - return $ ServerConfig client_stack mem_c evctx (ValExpr v) server_stack mem_s1 - - --- -serverValue :: FunctionStore -> Stack -> Mem -> [EvalContext] -> Value -> Stack -> Mem -> IO Config - --- (E-Unit-S-E) -serverValue fun_store [] mem_c [] (UnitM v) [] mem_s = - return $ ClientConfig [] (ValExpr (UnitM v)) [] mem_c [] mem_s - --- (E-Unit-S) -serverValue fun_store (top_evctx:client_stack) mem_c [] (UnitM v) server_stack mem_s = - return $ ClientConfig [] (top_evctx (ValExpr (UnitM v))) client_stack mem_c server_stack mem_s - --- (E-Call) -serverValue fun_store client_stack mem_c evctx (Call f funty arg) server_stack mem_s = do - let server_stack1 = if null evctx then server_stack else (toFun evctx):server_stack - return $ ClientConfig [] (App f funty arg) client_stack mem_c server_stack1 mem_s - --- (E-Gen-C-C) and (E-Gen-S-C) -serverValue fun_store client_stack mem_c evctx (GenApp loc f funty arg) server_stack mem_s = do - if loc==serverLoc then - return $ ServerConfig client_stack mem_c evctx (App f funty arg) server_stack mem_s - else if loc==clientLoc then - return $ ServerConfig client_stack mem_c evctx (ValExpr (Call f funty arg)) server_stack mem_s - else - error $ "[serverValue] GenApp: Unexpected location : " ++ show loc - --- (E-Do) -serverValue fun_store client_stack mem_c evctx (BindM [Binding x ty b@(ValExpr (UnitM v))] expr) server_stack mem_s = do - let subst = [(x,v)] - return $ ServerConfig client_stack mem_c evctx (doSubstExpr subst expr) server_stack mem_s - --- ( do x<-E[] in M ) : b is one of BindM, Call, and GenApp. -serverValue fun_store client_stack mem_c evctx (BindM [Binding x ty b@(_)] expr) server_stack mem_s = do - serverExpr fun_store client_stack mem_c ((\bexpr->ValExpr (BindM [Binding x ty bexpr] expr)):evctx) b server_stack mem_s - -serverValue fun_store client_stack mem_c evctx v server_stack mem_s = do - error $ "[serverValue]: Unexpected: " ++ show v ++ "\n" - ++ show [f | (f,_)<-_clientstore fun_store] ++ "\n" - ++ show [f | (f,_)<-_serverstore fun_store] ++ "\n" - ------------------------ --- Primitive operations ------------------------ - -calc :: PrimOp -> [Location] -> [Type] -> [Value] -> Mem -> IO (Value, Mem) - -calc MkRecOp locs tys [Closure vs fvtys codename [], Lit (StrLit f)] mem = - return (Closure vs fvtys codename [f], mem) - - -calc PrimRefCreateOp [loc1] [ty] [v] mem = - let (addr, mem1) = allocMem v mem in return (Addr addr, mem1) - -calc PrimRefCreateOp locs tys vs mem = - error $ "[PrimOp] PrimRefCreateOp: Unexpected: " - ++ show locs ++ " " ++ show tys ++ " " ++ show vs - -calc PrimRefReadOp [loc1] [ty] [Addr addr] mem = return (readMem addr mem, mem) - -calc PrimRefReadOp locs tys vs mem = - error $ "[PrimOp] PrimRefReadOp: Unexpected: " - ++ show locs ++ " " ++ show tys ++ " " ++ show vs - -calc PrimRefWriteOp [loc1] [ty] [Addr addr,v] mem = - return (Lit UnitLit, writeMem addr v mem) - -calc PrimRefWriteOp locs tys vs mem = - error $ "[PrimOp] PrimRefWriteOp: Unexpected: " - ++ show locs ++ " " ++ show tys ++ " " ++ show vs - -calc PrimReadOp [loc] [] [Lit (UnitLit)] mem = do - line <- getLine - return (Lit (StrLit line), mem) - -calc PrimPrintOp [loc] [] [Lit (StrLit s)] mem = do - putStr s - return (Lit UnitLit, mem) - - -calc primop locs tys vs mem = - return (Lit $ calc' primop locs tys (map (\ (Lit lit)-> lit) vs), mem) - - --- Primitives -calc' :: PrimOp -> [Location] -> [Type] -> [Literal] -> Literal - -calc' NotPrimOp [loc] [] [BoolLit b] = BoolLit (not b) -- loc is the current location - -calc' OrPrimOp [loc] [] [BoolLit x, BoolLit y] = BoolLit (x || y) - -calc' AndPrimOp [loc] [] [BoolLit x, BoolLit y] = BoolLit (x && y) - -calc' EqPrimOp [loc] [] [IntLit x, IntLit y] = BoolLit (x==y) - -calc' NeqPrimOp [loc] [] [IntLit x, IntLit y] = BoolLit (x/=y) - -calc' LtPrimOp [loc] [] [IntLit x, IntLit y] = BoolLit (xy) - -calc' GePrimOp [loc] [] [IntLit x, IntLit y] = BoolLit (x>=y) - -calc' AddPrimOp [loc] [] [IntLit x, IntLit y] = IntLit (x+y) - -calc' SubPrimOp [loc] [] [IntLit x, IntLit y] = IntLit (x-y) - -calc' MulPrimOp [loc] [] [IntLit x, IntLit y] = IntLit (x*y) - -calc' DivPrimOp [loc] [] [IntLit x, IntLit y] = IntLit (x `div` y) - -calc' NegPrimOp [loc] [] [IntLit x] = IntLit (-x) - --- Libraries -calc' PrimIntToStringOp [loc] [] [IntLit i] = StrLit (show i) - -calc' PrimConcatOp [loc] [] [StrLit s1, StrLit s2] = StrLit (s1++s2) - -calc' operator locs tys operands = - error $ "[PrimOp] Unexpected: " - ++ show operator ++ " " ++ show locs ++ " " ++ show tys ++ " " ++ show operands - - --- -doRec clo [] expr = expr -doRec (Closure vs tys codename recf) [f] expr = doSubstExpr [(f, Closure vs tys codename [f])] expr -doRec clo recf expr = error $ "[doRec] Unexpected" ++ show clo ++ ", " ++ show recf ++ ", " ++ show expr - - ----------------- --- Substitutions ----------------- - --- -elim x subst = [(y,e) | (y,e)<-subst, y/=x] - -elims xs subst = foldl (\subst0 x0 -> elim x0 subst0) subst xs - - --- -doSubstExpr :: [(String,Value)] -> Expr -> Expr - -doSubstExpr subst (ValExpr v) = ValExpr (doSubstValue subst v) - -doSubstExpr subst (Let bindingDecls expr) = - let bindingDecls1 = - map (\(Binding x ty expr) -> - Binding x ty (doSubstExpr (elim x subst) expr)) bindingDecls - - elimed_subst = elims (map (\(Binding x _ _) -> x) bindingDecls) subst - - expr1 = doSubstExpr elimed_subst expr - in Let bindingDecls1 expr1 - -doSubstExpr subst (Case v casety [TupleAlternative xs expr]) = - let subst1 = elims xs subst - in Case (doSubstValue subst v) casety - [TupleAlternative xs (doSubstExpr subst1 expr)] - -doSubstExpr subst (Case v casety alts) = - Case (doSubstValue subst v) casety - (map (\(Alternative cname xs expr) -> - let subst1 = elims xs subst - in Alternative cname xs (doSubstExpr subst1 expr)) alts) - -doSubstExpr subst (App v funty arg) = - App (doSubstValue subst v) funty (doSubstValue subst arg) - -doSubstExpr subst (TypeApp v funty tyargs) = - TypeApp (doSubstValue subst v) funty tyargs - -doSubstExpr subst (LocApp v funty locargs) = - LocApp (doSubstValue subst v) funty locargs - -doSubstExpr subst (Prim op locs tys vs) = Prim op locs tys (map (doSubstValue subst) vs) - - - --- -doSubstValue :: [(String,Value)] -> Value -> Value - -doSubstValue subst (Var x) = - case [v | (y,v) <- subst, x==y] of - (v:_) -> v - [] -> (Var x) - -doSubstValue subst (Lit lit) = (Lit lit) - -doSubstValue subst (Tuple vs) = Tuple (map (doSubstValue subst) vs) - -doSubstValue subst (Constr cname locs tys vs argtys) = - Constr cname locs tys (map (doSubstValue subst) vs) argtys - -doSubstValue subst (Closure vs fvtys (CodeName fname locs tys) recf) = - Closure (map (doSubstValue subst) vs) fvtys (CodeName fname locs tys) recf - -doSubstValue subst (UnitM v) = UnitM (doSubstValue subst v) - -doSubstValue subst (BindM bindingDecls expr) = - let bindingDecls1 = - (map (\(Binding x ty bexpr) -> - let subst1 = elim x subst - in Binding x ty (doSubstExpr subst1 bexpr))) bindingDecls - - elimed_subst = elims (map (\(Binding x _ _) -> x) bindingDecls) subst - - expr1 = doSubstExpr elimed_subst expr - in BindM bindingDecls1 expr1 - -doSubstValue subst (Req f funty arg) = - Req (doSubstValue subst f) funty (doSubstValue subst arg) - -doSubstValue subst (Call f funty arg) = - Call (doSubstValue subst f) funty (doSubstValue subst arg) - -doSubstValue subst (GenApp loc f funty arg) = - GenApp loc (doSubstValue subst f) funty (doSubstValue subst arg) - -doSubstValue subst (Addr i) = Addr i - ---doSubstValue subst v = error $ "[doSubstValue] Unexpected: " ++ show v - - --- -doSubstLocExpr :: [(String,Location)] -> Expr -> Expr - -doSubstLocExpr substLoc (ValExpr v) = ValExpr (doSubstLocValue substLoc v) - -doSubstLocExpr substLoc (Let bindingDecls expr) = - let bindingDecls1 = - map (\(Binding x ty bexpr) -> - Binding x - (doSubstLoc substLoc ty) - (doSubstLocExpr substLoc bexpr)) bindingDecls - - in Let bindingDecls1 (doSubstLocExpr substLoc expr) - -doSubstLocExpr substLoc (Case v casety [TupleAlternative xs expr]) = - Case (doSubstLocValue substLoc v) (doSubstLoc substLoc casety) - [TupleAlternative xs (doSubstLocExpr substLoc expr)] - -doSubstLocExpr substLoc (Case v casety alts) = - Case (doSubstLocValue substLoc v) (doSubstLoc substLoc casety) - (map (\(Alternative cname xs expr) -> - Alternative cname xs (doSubstLocExpr substLoc expr)) alts) - -doSubstLocExpr substLoc (App v funty arg) = - App (doSubstLocValue substLoc v) - (doSubstLoc substLoc funty) - (doSubstLocValue substLoc arg) - -doSubstLocExpr substLoc (TypeApp v funty tyargs) = - TypeApp (doSubstLocValue substLoc v) - (doSubstLoc substLoc funty) - (map (doSubstLoc substLoc) tyargs) - -doSubstLocExpr substLoc (LocApp v funty locargs) = - LocApp (doSubstLocValue substLoc v) - (doSubstLoc substLoc funty) - (map (doSubstLocOverLocs substLoc) locargs) - -doSubstLocExpr substLoc (Prim op locs tys vs) = - Prim op - (map (doSubstLocOverLocs substLoc) locs) - (map (doSubstLoc substLoc) tys) - (map (doSubstLocValue substLoc) vs) - - --- -doSubstLocValue :: [(String,Location)] -> Value -> Value - -doSubstLocValue substLoc (Var x) = Var x - -doSubstLocValue substLoc (Lit lit) = Lit lit - -doSubstLocValue substLoc (Tuple vs) = Tuple (map (doSubstLocValue substLoc) vs) - -doSubstLocValue substLoc (Constr cname locs tys vs argtys) = - Constr cname - (map (doSubstLocOverLocs substLoc) locs) - (map (doSubstLoc substLoc) tys) - (map (doSubstLocValue substLoc) vs) - (map (doSubstLoc substLoc) argtys) - -doSubstLocValue substLoc (Closure vs fvtys (CodeName f locs tys) recf) = - Closure (map (doSubstLocValue substLoc) vs) - (map (doSubstLoc substLoc) fvtys ) - (CodeName f (map (doSubstLocOverLocs substLoc) locs) (map (doSubstLoc substLoc) tys)) - recf - -doSubstLocValue substLoc (UnitM v) = UnitM (doSubstLocValue substLoc v) - -doSubstLocValue substLoc (BindM bindingDecls expr) = - let bindingDecls1 = - (map (\(Binding x ty bexpr) -> - Binding x - (doSubstLoc substLoc ty) - (doSubstLocExpr substLoc bexpr))) bindingDecls - in BindM bindingDecls1 (doSubstLocExpr substLoc expr) - -doSubstLocValue substLoc (Req f funty arg) = - Req (doSubstLocValue substLoc f) - (doSubstLoc substLoc funty) - (doSubstLocValue substLoc arg) - -doSubstLocValue substLoc (Call f funty arg) = - Call (doSubstLocValue substLoc f) - (doSubstLoc substLoc funty) - (doSubstLocValue substLoc arg) - -doSubstLocValue substLoc (GenApp loc f funty arg) = - GenApp (doSubstLocOverLocs substLoc loc) - (doSubstLocValue substLoc f) - (doSubstLoc substLoc funty) - (doSubstLocValue substLoc arg) - -doSubstLocValue substLoc (Addr i) = Addr i - --- -doSubstTyExpr :: [(String,Type)] -> Expr -> Expr - -doSubstTyExpr substTy (ValExpr v) = ValExpr (doSubstTyValue substTy v) - -doSubstTyExpr substTy (Let bindingDecls expr) = - let bindingDecls1 = - map (\(Binding x ty expr) -> - Binding x (doSubst substTy ty) (doSubstTyExpr substTy expr)) bindingDecls - - in Let bindingDecls1 (doSubstTyExpr substTy expr) - -doSubstTyExpr substTy (Case v casety [TupleAlternative xs expr]) = - Case (doSubstTyValue substTy v) (doSubst substTy casety) - [TupleAlternative xs (doSubstTyExpr substTy expr)] - -doSubstTyExpr substTy (Case v casety alts) = - Case (doSubstTyValue substTy v) (doSubst substTy casety) - (map (\ (Alternative cname xs expr) -> - Alternative cname xs (doSubstTyExpr substTy expr)) alts) - -doSubstTyExpr substTy (App v funty arg) = - App (doSubstTyValue substTy v) (doSubst substTy funty) (doSubstTyValue substTy arg) - -doSubstTyExpr substTy (TypeApp v funty tyargs) = - TypeApp (doSubstTyValue substTy v) (doSubst substTy funty) (map (doSubst substTy) tyargs) - -doSubstTyExpr substTy (LocApp v funty locargs) = - LocApp (doSubstTyValue substTy v) (doSubst substTy funty) locargs - -doSubstTyExpr substTy (Prim op locs tys vs) = - Prim op locs (map (doSubst substTy) tys) (map (doSubstTyValue substTy) vs) - --- -doSubstTyValue :: [(String,Type)] -> Value -> Value - - -doSubstTyValue substTy (Var x) = (Var x) - -doSubstTyValue substTy (Lit lit) = Lit lit - -doSubstTyValue substTy (Tuple vs) = Tuple (map (doSubstTyValue substTy) vs) - -doSubstTyValue substTy (Constr cname locs tys vs argtys) = - Constr cname locs - (map (doSubst substTy) tys) - (map (doSubstTyValue substTy) vs) - (map (doSubst substTy) argtys) - -doSubstTyValue substTy (UnitM v) = UnitM (doSubstTyValue substTy v) - -doSubstTyValue substTy (Closure vs fvtys (CodeName fname locs tys) recf) = - Closure (map (doSubstTyValue substTy) vs) - (map (doSubst substTy) fvtys) - (CodeName fname locs (map (doSubst substTy) tys)) - recf - -doSubstTyValue substTy (BindM bindingDecls expr) = - let bindingDecls1 = - map (\ (Binding x ty bexpr) -> - Binding x (doSubst substTy ty) (doSubstTyExpr substTy bexpr)) bindingDecls - in BindM bindingDecls1 (doSubstTyExpr substTy expr) - - -doSubstTyValue substTy (Req f funty arg) = - Req (doSubstTyValue substTy f) (doSubst substTy funty) (doSubstTyValue substTy arg) - -doSubstTyValue substTy (Call f funty arg) = - Call (doSubstTyValue substTy f) (doSubst substTy funty) (doSubstTyValue substTy arg) - -doSubstTyValue substTy (GenApp loc f funty arg) = - GenApp loc (doSubstTyValue substTy f) (doSubst substTy funty) (doSubstTyValue substTy arg) - -doSubstTyValue substTy (Addr i) = Addr i - --- diff --git a/app/polyrpc/Lexer.hs b/app/polyrpc/Lexer.hs deleted file mode 100644 --- a/app/polyrpc/Lexer.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Lexer(lexerSpec) where - -import Prelude hiding (EQ) -import CommonParserUtil -import Token - -mkFn :: Token -> (String -> Maybe Token) -mkFn tok = \text -> Just tok - -skip :: String -> Maybe Token -skip = \text -> Nothing - -lexerSpec :: LexerSpec Token -lexerSpec = LexerSpec - { - endOfToken = END_OF_TOKEN, - lexerSpecList = - [ ("[ \t\n]", skip), - ("\\/\\/[^\n]*\n" , skip), - ("\\(" , mkFn OPEN_PAREN_TOKEN), - ("\\)" , mkFn CLOSE_PAREN_TOKEN), - ("\\{" , mkFn OPEN_BRACE_TOKEN), - ("\\}" , mkFn CLOSE_BRACE_TOKEN), - ("\\[" , mkFn OPEN_BRACKET_TOKEN), - ("\\]" , mkFn CLOSE_BRACKET_TOKEN), - ("-[a-zA-Z][a-zA-Z0-9]*->", mkFn LOCFUN_TOKEN), - ("\\." , mkFn DOT_TOKEN), - ("\\," , mkFn COMMA_TOKEN), - ("\\;" , mkFn SEMICOLON_TOKEN), - ("\\:=" , mkFn ASSIGN_TOKEN), - ("\\:" , mkFn COLON_TOKEN), - ("==" , mkFn EQUAL_TOKEN), - ("=>" , mkFn ALT_ARROW_TOKEN), - ("=" , mkFn DEF_TOKEN), - ("\\|" , mkFn BAR_TOKEN), - ("\\\\" , mkFn BACKSLASH_TOKEN), - ("\\@" , mkFn AT_TOKEN), - ("!=" , mkFn NOTEQUAL_TOKEN), - ("!" , mkFn NOT_TOKEN), - ("<=" , mkFn LESSEQUAL_TOKEN), - ("<" , mkFn LESSTHAN_TOKEN), - (">=" , mkFn GREATEREQUAL_TOKEN), - (">" , mkFn GREATERTHAN_TOKEN), - ("\\+" , mkFn ADD_TOKEN), - ("-" , mkFn SUB_TOKEN), - ("\\*" , mkFn MUL_TOKEN), - ("\\/" , mkFn DIV_TOKEN), - ("[0-9]+" , mkFn INTEGER_TOKEN), - -- ("Unit" , mkFn UNIT_TYPE_TOKEN), - -- ("Int" , mkFn INTEGER_TYPE_TOKEN), - -- ("Bool" , mkFn BOOLEAN_TYPE_TOKEN), - -- ("String" , mkFn STRING_TYPE_TOKEN), - ("(True|False)" , mkFn BOOLEAN_TOKEN), - ("\"[^\"]*\"" , mkFn STRING_TOKEN), - ("data" , mkFn KEYWORD_DATA_TOKEN), - ("let" , mkFn KEYWORD_LET_TOKEN), - ("end" , mkFn KEYWORD_END_TOKEN), - ("if" , mkFn KEYWORD_IF_TOKEN), - ("then" , mkFn KEYWORD_THEN_TOKEN), - ("else" , mkFn KEYWORD_ELSE_TOKEN), - ("case" , mkFn KEYWORD_CASE_TOKEN), - ("or" , mkFn KEYWORD_OR_TOKEN), - ("and" , mkFn KEYWORD_AND_TOKEN), - ("[a-zA-Z_][a-zA-Z0-9_]*" , mkFn IDENTIFIER_TOKEN) - ] - } diff --git a/app/polyrpc/Main.hs b/app/polyrpc/Main.hs deleted file mode 100644 --- a/app/polyrpc/Main.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Main where - -import CommonParserUtil - -import Token -import Lexer -import Terminal -import Parser -import Type -import Expr -import qualified CSType as TT -import qualified CSExpr as TE -import TypeCheck -import Compile -import Verify -import Execute - -import Text.JSON.Generic -import Text.JSON.Pretty -import Text.PrettyPrint --- For aeson ---import qualified Data.ByteString.Lazy.Char8 as B ---import Data.Aeson.Encode.Pretty -import Data.Maybe -import System.IO -import System.Environment (getArgs) - -main :: IO () -main = do - args <- getArgs - cmd <- getCmd args - - let files = _files cmd - - mapM_ (doProcess cmd) files -- [ ((build cmd file), file) | file <- files ] - -doProcess cmd file = do - putStrLn $ "[Reading] " ++ file - text <- readFile file - - putStrLn "[Lexing]" - terminalList <- lexing lexerSpec text - verbose (_flag_debug_lex cmd) $ mapM_ (putStrLn) (map terminalToString terminalList) - - - putStrLn "[Parsing]" - exprSeqAst <- parsing parserSpec terminalList - - verbose (_flag_debug_parse cmd) $ putStrLn "Dumping..." - verbose (_flag_debug_parse cmd) $ putStrLn $ show $ fromASTTopLevelDeclSeq exprSeqAst - - let toplevelDecls = fromASTTopLevelDeclSeq exprSeqAst - - - putStrLn "[Type checking]" - (gti, elab_toplevelDecls) <- typeCheck toplevelDecls - verbose (_flag_debug_typecheck cmd) $ putStrLn "Dumping..." - verbose (_flag_debug_typecheck cmd) $ putStrLn $ show $ elab_toplevelDecls - - print_rpc cmd file elab_toplevelDecls - - - putStrLn "[Compiling]" - (t_gti, funStore, t_expr) <- compile gti elab_toplevelDecls - verbose (_flag_debug_compile cmd) $ putStrLn "Dumping...\nGlobal type information:\n" - verbose (_flag_debug_compile cmd) $ putStrLn $ (show t_gti ++ "\n\nFunction stores:") - verbose (_flag_debug_compile cmd) $ putStrLn $ (show funStore ++ "\n\nMain expression:") - verbose (_flag_debug_compile cmd) $ putStrLn $ (show t_expr ++ "\n") - - print_cs cmd file funStore t_expr - - putStrLn "[Verifying generated codes]" - verify t_gti funStore t_expr - verbose (_flag_debug_verify cmd) $ putStrLn "[Well-typed]" - - putStrLn "[Executing codes]" - v <- execute (_flag_debug_run cmd) t_gti funStore t_expr - verbose (_flag_debug_run cmd) $ putStrLn $ "[Result]\n" ++ show v - - putStrLn "[Success]" - - --- -print_rpc cmd file elab_toplevelDecls = do - let jsonfile = prefixOf file ++ ".json" - if _flag_print_rpc_json cmd - then do putStrLn $ "Writing to " ++ jsonfile - writeFile jsonfile $ render - $ pp_value $ toJSON (elab_toplevelDecls :: [TopLevelDecl]) - else return () - -print_cs cmd file funStore t_expr = do - let jsonfile = prefixOf file ++ "_cs.json" - if _flag_print_cs_json cmd - then do putStrLn $ "Writing to " ++ jsonfile - writeFile jsonfile $ render - $ pp_value $ toJSON (funStore :: TE.FunctionStore, t_expr :: TE.Expr) - else return () - -prefixOf str = reverse (removeDot (dropWhile (/='.') (reverse str))) - where removeDot [] = [] - removeDot (x:xs) = xs -- x must be '.' - --- -readline msg = do - putStr msg - hFlush stdout - readline' - -readline' = do - ch <- getChar - if ch == '\n' then - return "" - else - do line <- readline' - return (ch:line) - --- -data Cmd = - Cmd { _flag_print_rpc_json :: Bool - , _flag_print_cs_json :: Bool - , _flag_debug_lex :: Bool - , _flag_debug_parse :: Bool - , _flag_debug_typecheck :: Bool - , _flag_debug_compile :: Bool - , _flag_debug_verify :: Bool - , _flag_debug_run :: Bool - , _files :: [String] - } - -initCmd = - Cmd { _flag_print_rpc_json = False - , _flag_print_cs_json = False - , _flag_debug_lex = False - , _flag_debug_parse = False - , _flag_debug_typecheck = False - , _flag_debug_compile = False - , _flag_debug_verify = False - , _flag_debug_run = False - , _files = [] - } - -getCmd :: Monad m => [String] -> m Cmd -getCmd args = collect initCmd args - -collect :: Monad m => Cmd -> [String] -> m Cmd -collect cmd [] = return cmd -collect cmd ("--output-json":args) = do - let new_cmd = cmd { _flag_print_rpc_json = True } - collect new_cmd args - -collect cmd ("--output-rpc-json":args) = do - let new_cmd = cmd { _flag_print_rpc_json = True } - collect new_cmd args - -collect cmd ("--output-cs-json":args) = do - let new_cmd = cmd { _flag_print_cs_json = True } - collect new_cmd args - -collect cmd ("--debug-lex":args) = do - let new_cmd = cmd { _flag_debug_lex = True } - collect new_cmd args - -collect cmd ("--debug-parse":args) = do - let new_cmd = cmd { _flag_debug_parse = True } - collect new_cmd args - -collect cmd ("--debug-typecheck":args) = do - let new_cmd = cmd { _flag_debug_typecheck = True } - collect new_cmd args - -collect cmd ("--debug-compile":args) = do - let new_cmd = cmd { _flag_debug_compile = True } - collect new_cmd args - -collect cmd ("--debug-verify":args) = do - let new_cmd = cmd { _flag_debug_verify = True } - collect new_cmd args - -collect cmd ("--debug-run":args) = do - let new_cmd = cmd { _flag_debug_run = True } - collect new_cmd args - -collect cmd (arg:args) = do - let old_files = _files cmd - let new_cmd = cmd { _files = old_files ++ [arg] } - collect new_cmd args - - -verbose b action = if b then action else return () diff --git a/app/polyrpc/Parser.hs b/app/polyrpc/Parser.hs deleted file mode 100644 --- a/app/polyrpc/Parser.hs +++ /dev/null @@ -1,414 +0,0 @@ -module Parser where - -import CommonParserUtil -import Location -import Token -import Type -import Prim -import Literal -import Expr - - -parserSpec :: ParserSpec Token AST -parserSpec = ParserSpec - { - startSymbol = "TopLevel'", - - parserSpecList = - [ - ("TopLevel' -> TopLevel", \rhs -> get rhs 1), - - {- Identifiers -} - ("Identifiers -> identifier", \rhs -> toASTIdSeq [getText rhs 1] ), - - ("Identifiers -> identifier Identifiers", - \rhs -> toASTIdSeq (getText rhs 1 : fromASTIdSeq (get rhs 2)) ), - - - {- OptIdentifiers -} - ("OptIdentifiers -> ", \rhs -> toASTIdSeq [] ), - - ("OptIdentifiers -> Identifiers", \rhs -> get rhs 1 ), - - - {- IdentifierCommas -} - ("IdentifierCommas -> identifier", \rhs -> toASTIdSeq [getText rhs 1] ), - - ("IdentifierCommas -> identifier , IdentifierCommas", - \rhs -> toASTIdSeq (getText rhs 1 : fromASTIdSeq (get rhs 3)) ), - - - {- OptIdentifierCommas -} - ("OptIdentifierCommas -> ", \rhs -> toASTIdSeq [] ), - - ("OptIdentifierCommas -> IdentifierCommas", \rhs -> get rhs 1 ), - - - {- Location -} - ("Location -> identifier", \rhs -> toASTLocation (Location (getText rhs 1)) ), - - - {- Locations -} - ("Locations -> Identifiers", \rhs -> - toASTLocationSeq (map Location (fromASTIdSeq (get rhs 1))) ), - - - {- Type -} - ("Type -> LocFunType", \rhs -> get rhs 1 ), - - ("Type -> { Identifiers } . Type", \rhs -> - toASTType (singleLocAbsType - (LocAbsType (fromASTIdSeq (get rhs 2)) - (fromASTType (get rhs 5)))) ), - - ("Type -> [ Identifiers ] . Type", \rhs -> - toASTType (singleTypeAbsType (TypeAbsType - (fromASTIdSeq (get rhs 2)) - (fromASTType (get rhs 5)))) ), - - - {- LocFunType -} - ("LocFunType -> AppType", \rhs -> get rhs 1), - - ("LocFunType -> AppType LocFun LocFunType", \rhs -> - let locfun = getText rhs 2 - loc = init (init (tail locfun)) -- extract Loc from -Loc-> ( a bit hard-coded!!) - in toASTType (FunType - (fromASTType (get rhs 1)) - (Location loc) - (fromASTType (get rhs 3))) ), - - - {- AppType -} - ("AppType -> AtomicType", \rhs -> get rhs 1), - - ("AppType -> AppType { Locations }", \rhs -> - let locs = fromASTLocationSeq (get rhs 3) in - case fromASTType (get rhs 1) of - ConType name [] [] -> toASTType (ConType name locs []) - ConType name [] tys -> - error $ "[Parser] Not supported: types and then locations: " ++ show locs ++ " " ++ show tys - ConType name locs' tys -> - error $ "[Parser] Not supported: multiple locations" ++ name ++ " " ++ show locs' ++ " " ++ show locs - TypeVarType name -> toASTType (ConType name locs []) - ty -> - error $ "[Parser] Not supported yet: " ++ show ty ++ " not ConType: " ++ show locs), - - ("AppType -> AppType [ LocFunTypes ]", \rhs -> - let tys = fromASTTypeSeq (get rhs 3) in - case fromASTType (get rhs 1) of - ConType name locs [] -> toASTType (ConType name locs tys) - ConType name locs tys' -> - error $ "[Parser] Not supported: multiple types: " ++ name ++ " " ++ show tys' ++ " " ++ show tys - TypeVarType name -> toASTType (ConType name [] tys) - ty -> - error $ "[Parser] Not supported yet: " ++ show ty ++ " not ConType: " ++ show tys), - - - {- AtomicType -} - ("AtomicType -> TupleType", \rhs -> get rhs 1 ), - - ("AtomicType -> ( Type )", \rhs -> get rhs 2 ), - - ("AtomicType -> identifier", \rhs -> toASTType (TypeVarType (getText rhs 1)) ), - - - {- TupleType -} - ("TupleType -> ( Type , TypeSeq )", - \rhs -> toASTType (TupleType $ - (fromASTType (get rhs 2)) : (fromASTTypeSeq (get rhs 4))) ), - - - {- TypeSeq -} - ("TypeSeq -> Type", \rhs -> toASTTypeSeq [fromASTType (get rhs 1)] ), - - ("TypeSeq -> Type , TypeSeq", - \rhs -> toASTTypeSeq $ fromASTType (get rhs 1) : (fromASTTypeSeq (get rhs 3)) ), - - - {- LocFunTypes -} - ("LocFunTypes -> LocFunType", \rhs -> toASTTypeSeq [fromASTType (get rhs 1)] ), - - ("LocFunTypes -> LocFunType LocFunTypes", - \rhs -> toASTTypeSeq $ fromASTType (get rhs 1) : fromASTTypeSeq (get rhs 2) ), - - - {- OptLocFunTypes -} - ("OptLocFunTypes -> ", \rhs -> toASTTypeSeq [] ), - - ("OptLocFunTypes -> LocFunTypes", \rhs -> get rhs 1 ), - - - {- TopLevel -} - ("TopLevel -> Binding", - \rhs -> toASTTopLevelDeclSeq [BindingTopLevel (fromASTBindingDecl (get rhs 1 ))] ), - - ("TopLevel -> Binding ; TopLevel", - \rhs -> toASTTopLevelDeclSeq - $ BindingTopLevel (fromASTBindingDecl (get rhs 1)) : fromASTTopLevelDeclSeq (get rhs 3) ), - - ("TopLevel -> DataTypeDecl", - \rhs -> toASTTopLevelDeclSeq [DataTypeTopLevel (fromASTDataTypeDecl (get rhs 1))] ), - - ("TopLevel -> DataTypeDecl ; TopLevel", - \rhs -> toASTTopLevelDeclSeq - $ DataTypeTopLevel (fromASTDataTypeDecl (get rhs 1)) : (fromASTTopLevelDeclSeq (get rhs 3)) ), - - - {- DataTypeDecl -} - ("DataTypeDecl -> data identifier = DataTypeDeclRHS", \rhs -> - let name = getText rhs 2 - (locvars,tyvars,tycondecls) = fromASTTriple (get rhs 4) - in toASTDataTypeDecl (DataType name locvars tyvars tycondecls)), - - - {- DataTypeDeclRHS -} - ("DataTypeDeclRHS -> TypeConDecls", \rhs -> - toASTTriple ([], [], fromASTTypeConDeclSeq (get rhs 1)) ), - - ("DataTypeDeclRHS -> { Identifiers } . DataTypeDeclRHS", \rhs -> - let locvars = fromASTIdSeq (get rhs 2) in - case fromASTTriple (get rhs 5) of - ([], tyvars, tycondecls) -> toASTTriple (locvars, tyvars, tycondecls) - (locvars', tyvars, tycondecls) -> - error $ "[Parser] Not supported yet: multiple location abstractions: " - ++ show locvars' ++ " " ++ show locvars ), - - ("DataTypeDeclRHS -> [ Identifiers ] . DataTypeDeclRHS", \rhs -> - let tyvars = fromASTIdSeq (get rhs 2) in - case fromASTTriple (get rhs 5) of - ([], [], tycondecls) -> toASTTriple ([], tyvars, tycondecls) - (locvars, [], tycondecls) -> - error $ "Not supported yet: types and then locations abstractions: " - ++ show tyvars ++ " " ++ show locvars - (locvars, tyvars', tycondecls) -> - error $ "Not supported yet: multiple type abstractions: " - ++ show tyvars' ++ " " ++ show tyvars ), - - - {- TypeConDecl -} - ("TypeConDecl -> identifier OptLocFunTypes", - \rhs -> toASTTypeConDecl (TypeCon (getText rhs 1) (fromASTTypeSeq (get rhs 2))) ), - - - {- TypeConDecls -} - ("TypeConDecls -> TypeConDecl", - \rhs -> toASTTypeConDeclSeq [ fromASTTypeConDecl (get rhs 1) ] ), - - ("TypeConDecls -> TypeConDecl | TypeConDecls", - \rhs -> toASTTypeConDeclSeq $ - fromASTTypeConDecl (get rhs 1) : fromASTTypeConDeclSeq (get rhs 3) ), - - - {- Binding -} - ("Binding -> identifier : Type = LExpr", - \rhs -> toASTBindingDecl ( - Binding (getText rhs 1) (fromASTType (get rhs 3)) (fromASTExpr (get rhs 5))) ), - - - {- Bindings -} - ("Bindings -> Binding", - \rhs -> toASTBindingDeclSeq [ fromASTBindingDecl (get rhs 1) ] ), - - ("Bindings -> Binding ; Bindings", - \rhs -> toASTBindingDeclSeq $ fromASTBindingDecl (get rhs 1) : fromASTBindingDeclSeq (get rhs 3) ), - - - {- LExpr -} - ("LExpr -> { Identifiers } . LExpr", - \rhs -> toASTExpr (singleLocAbs (LocAbs (fromASTIdSeq (get rhs 2)) (fromASTExpr (get rhs 5)))) ), - - ("LExpr -> [ Identifiers ] . LExpr", - \rhs -> toASTExpr (singleTypeAbs (TypeAbs (fromASTIdSeq (get rhs 2)) (fromASTExpr (get rhs 5)))) ), - - ("LExpr -> \\ IdTypeLocSeq . LExpr", - \rhs -> toASTExpr (singleAbs (Abs (fromASTIdTypeLocSeq (get rhs 2)) (fromASTExpr (get rhs 4)))) ), - - ("LExpr -> let { Bindings } LExpr end", - \rhs -> toASTExpr (Let (fromASTBindingDeclSeq (get rhs 3)) (fromASTExpr (get rhs 5))) ), - - ("LExpr -> if Expr then LExpr else LExpr", - \rhs -> toASTExpr (Case (fromASTExpr (get rhs 2)) Nothing - [ Alternative trueLit [] (fromASTExpr (get rhs 4)) - , Alternative falseLit [] (fromASTExpr (get rhs 6)) ]) ), - - ("LExpr -> case Expr { Alternatives }", - \rhs -> toASTExpr (Case (fromASTExpr (get rhs 2)) Nothing (fromASTAlternativeSeq (get rhs 4))) ), - - ("LExpr -> Expr", \rhs -> get rhs 1 ), - - - {- IdTypeLocSeq -} - ("IdTypeLocSeq -> IdTypeLoc", \rhs -> toASTIdTypeLocSeq [fromASTIdTypeLoc (get rhs 1)] ), - - ("IdTypeLocSeq -> IdTypeLoc IdTypeLocSeq", - \rhs -> toASTIdTypeLocSeq $ fromASTIdTypeLoc (get rhs 1) : fromASTIdTypeLocSeq (get rhs 2) ), - - - {- IdTypeLoc -} - ("IdTypeLoc -> identifier : Type @ Location", - \rhs -> toASTIdTypeLoc (getText rhs 1, fromASTType (get rhs 3), fromASTLocation (get rhs 5)) ), - - - {- Alternatives -} - ("Alternatives -> Alternative", \rhs -> toASTAlternativeSeq [fromASTAlternative (get rhs 1)] ), - - ("Alternatives -> Alternative ; Alternatives", - \rhs -> toASTAlternativeSeq $ fromASTAlternative (get rhs 1) : fromASTAlternativeSeq (get rhs 3) ), - - - {- Alternative -} - ("Alternative -> identifier OptIdentifiers => LExpr", - \rhs -> toASTAlternative $ - (Alternative (getText rhs 1) (fromASTIdSeq (get rhs 2)) (fromASTExpr (get rhs 4))) ), - - ("Alternative -> ( OptIdentifierCommas ) => LExpr", - \rhs -> toASTAlternative $ - (TupleAlternative (fromASTIdSeq (get rhs 2)) (fromASTExpr (get rhs 5))) ), - - - {- Expr -} - ("Expr -> Expr Term", - \rhs -> toASTExpr (App (fromASTExpr (get rhs 1)) Nothing (fromASTExpr (get rhs 2)) Nothing) ), - - ("Expr -> Expr [ LocFunTypes ]", - \rhs -> toASTExpr (singleTypeApp (TypeApp (fromASTExpr (get rhs 1)) Nothing (fromASTTypeSeq (get rhs 3)))) ), - - ("Expr -> Expr { Identifiers }", - \rhs -> toASTExpr (singleLocApp (LocApp (fromASTExpr (get rhs 1)) Nothing (map Location (fromASTIdSeq (get rhs 3))))) ), - - ("Expr -> Tuple", \rhs -> get rhs 1 ), - - ("Expr -> AssignExpr", \rhs -> get rhs 1 ), - - - {- Tuple -} - ("Tuple -> ( LExpr , LExprSeq )", - \rhs -> toASTExpr (Tuple $ fromASTExpr (get rhs 2) : fromASTExprSeq (get rhs 4)) ), - - - {- LExprSeq -} - ("LExprSeq -> LExpr", \rhs -> toASTExprSeq [ fromASTExpr (get rhs 1) ] ), - - ("LExprSeq -> LExpr , LExprSeq", - \rhs -> toASTExprSeq ( fromASTExpr (get rhs 1) : fromASTExprSeq (get rhs 3)) ), - - - {- AssignExpr -} - ("AssignExpr -> DerefExpr", \rhs -> get rhs 1 ), - - ("AssignExpr -> DerefExpr := { Identifiers } [ LocFunTypes ] AssignExpr", - \rhs -> - toASTExpr - (App - (App - (singleTypeApp (TypeApp - (singleLocApp ( LocApp (Var ":=") - Nothing - (map Location (fromASTIdSeq (get rhs 4))) ) ) - Nothing - (fromASTTypeSeq (get rhs 7)) ) ) - Nothing - (fromASTExpr (get rhs 1)) - Nothing ) - Nothing - (fromASTExpr (get rhs 9)) - Nothing) ), - - - {- DerefExpr -} - ("DerefExpr -> LogicNot", \rhs -> get rhs 1 ), - - ("DerefExpr -> ! { Identifiers } [ LocFunTypes ] DerefExpr", - \rhs -> - toASTExpr - (App - (singleTypeApp (TypeApp - (singleLocApp (LocApp (Var "!") - Nothing - (map Location (fromASTIdSeq (get rhs 3))))) - Nothing - (fromASTTypeSeq (get rhs 6)) )) - Nothing - (fromASTExpr (get rhs 8)) Nothing) ), - - ("DerefExpr -> LogicOr", \rhs -> get rhs 1 ), - - - {- Expression operations -} - ("LogicOr -> LogicOr or LogicAnd", - \rhs -> toASTExpr (Prim OrPrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("LogicOr -> LogicAnd", \rhs -> get rhs 1), - - ("LogicAnd -> LogicAnd and CompEqNeq", - \rhs -> toASTExpr (Prim AndPrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("LogicAnd -> CompEqNeq", \rhs -> get rhs 1), - - ("CompEqNeq -> CompEqNeq == Comp", - \rhs -> toASTExpr (Prim EqPrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("CompEqNeq -> CompEqNeq != Comp", - \rhs -> toASTExpr (Prim NeqPrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("CompEqNeq -> Comp", \rhs -> get rhs 1 ), - - ("Comp -> Comp < ArithAddSub", - \rhs -> toASTExpr (Prim LtPrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("Comp -> Comp <= ArithAddSub", - \rhs -> toASTExpr (Prim LePrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("Comp -> Comp > ArithAddSub", - \rhs -> toASTExpr (Prim GtPrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("Comp -> Comp >= ArithAddSub", - \rhs -> toASTExpr (Prim GePrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("Comp -> ArithAddSub", \rhs -> get rhs 1 ), - - ("ArithAddSub -> ArithAddSub + ArithMulDiv", - \rhs -> toASTExpr (Prim AddPrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("ArithAddSub -> ArithAddSub - ArithMulDiv", - \rhs -> toASTExpr (Prim SubPrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("ArithAddSub -> ArithMulDiv", \rhs -> get rhs 1 ), - - ("ArithMulDiv -> ArithMulDiv * ArithUnary", - \rhs -> toASTExpr (Prim MulPrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("ArithMulDiv -> ArithMulDiv / ArithUnary", - \rhs -> toASTExpr (Prim DivPrimOp [] [] [fromASTExpr (get rhs 1), fromASTExpr (get rhs 3)]) ), - - ("ArithMulDiv -> ArithUnary", \rhs -> get rhs 1 ), - - ("ArithUnary -> - Term", \rhs -> toASTExpr (Prim NegPrimOp [] [] [fromASTExpr (get rhs 2)]) ), - - ("ArithUnary -> Term", \rhs -> get rhs 1 ), - - - {- Term -} - ("Term -> identifier", \rhs -> toASTExpr (Var (getText rhs 1)) ), - - ("Term -> integer", \rhs -> toASTExpr (Lit (IntLit (read (getText rhs 1)))) ), - - ("Term -> string", \rhs -> - let str = read (getText rhs 1) :: String - in toASTExpr (Lit (StrLit str)) ), - - ("Term -> boolean", \rhs -> toASTExpr (Lit (BoolLit (read (getText rhs 1)))) ), - - ("Term -> ( )", \rhs -> toASTExpr (Lit UnitLit) ), - - ("Term -> ( LExpr )", \rhs -> get rhs 2 ) - ], - - baseDir = "./", - actionTblFile = "action_table.txt", - gotoTblFile = "goto_table.txt", - grammarFile = "prod_rules.txt", - parserSpecFile = "mygrammar.grm", - genparserexe = "yapb-exe" - } diff --git a/app/polyrpc/Token.hs b/app/polyrpc/Token.hs deleted file mode 100644 --- a/app/polyrpc/Token.hs +++ /dev/null @@ -1,126 +0,0 @@ -module Token where - -import Prelude hiding(EQ) -import TokenInterface - -data Token = - END_OF_TOKEN - | OPEN_PAREN_TOKEN - | CLOSE_PAREN_TOKEN - | OPEN_BRACE_TOKEN - | CLOSE_BRACE_TOKEN - | OPEN_BRACKET_TOKEN - | CLOSE_BRACKET_TOKEN - | IDENTIFIER_TOKEN - | LOCFUN_TOKEN - | DOT_TOKEN - | COMMA_TOKEN - | SEMICOLON_TOKEN - | COLON_TOKEN - | DEF_TOKEN -- = - | BAR_TOKEN - | BACKSLASH_TOKEN - | KEYWORD_DATA_TOKEN - | KEYWORD_LET_TOKEN - | KEYWORD_END_TOKEN - | KEYWORD_IF_TOKEN - | KEYWORD_THEN_TOKEN - | KEYWORD_ELSE_TOKEN - | KEYWORD_CASE_TOKEN - | KEYWORD_OR_TOKEN - | KEYWORD_AND_TOKEN - | AT_TOKEN - | ALT_ARROW_TOKEN - | NOT_TOKEN - | NOTEQUAL_TOKEN - | EQUAL_TOKEN -- == - | LESSTHAN_TOKEN - | LESSEQUAL_TOKEN - | GREATERTHAN_TOKEN - | GREATEREQUAL_TOKEN - | ADD_TOKEN - | SUB_TOKEN - | MUL_TOKEN - | DIV_TOKEN - | ASSIGN_TOKEN - - | INTEGER_TOKEN - | BOOLEAN_TOKEN - | STRING_TOKEN - - -- | UNIT_TYPE_TOKEN - -- | INTEGER_TYPE_TOKEN - -- | BOOLEAN_TYPE_TOKEN - -- | STRING_TYPE_TOKEN - deriving (Eq, Show) - -tokenStrList :: [(Token,String)] -tokenStrList = - [ (END_OF_TOKEN, "$"), - (OPEN_PAREN_TOKEN, "("), - (CLOSE_PAREN_TOKEN, ")"), - (OPEN_BRACE_TOKEN, "{"), - (CLOSE_BRACE_TOKEN, "}"), - (OPEN_BRACKET_TOKEN, "["), - (CLOSE_BRACKET_TOKEN, "]"), - (IDENTIFIER_TOKEN, "identifier"), - (LOCFUN_TOKEN, "LocFun"), - (DOT_TOKEN, "."), - (COMMA_TOKEN, ","), - (SEMICOLON_TOKEN, ";"), - (COLON_TOKEN, ":"), - (DEF_TOKEN, "="), - (BAR_TOKEN, "|"), - (BACKSLASH_TOKEN, "\\"), - (KEYWORD_DATA_TOKEN, "data"), - (KEYWORD_LET_TOKEN, "let"), - (KEYWORD_END_TOKEN, "end"), - (KEYWORD_IF_TOKEN, "if"), - (KEYWORD_THEN_TOKEN, "then"), - (KEYWORD_ELSE_TOKEN, "else"), - (KEYWORD_CASE_TOKEN, "case"), - (KEYWORD_OR_TOKEN, "or"), - (KEYWORD_AND_TOKEN, "and"), - (AT_TOKEN, "@"), - (ALT_ARROW_TOKEN, "=>"), - (NOT_TOKEN, "!"), - (NOTEQUAL_TOKEN, "!="), - (EQUAL_TOKEN, "=="), - (LESSTHAN_TOKEN, "<"), - (LESSEQUAL_TOKEN, "<="), - (GREATERTHAN_TOKEN, ">"), - (GREATEREQUAL_TOKEN, ">="), - (ADD_TOKEN, "+"), - (SUB_TOKEN, "-"), - (MUL_TOKEN, "*"), - (DIV_TOKEN, "/"), - (ASSIGN_TOKEN, ":="), - (INTEGER_TOKEN, "integer"), - (BOOLEAN_TOKEN, "boolean"), - (STRING_TOKEN, "string") - -- (UNIT_TYPE_TOKEN, "Unit"), - -- (INTEGER_TYPE_TOKEN, "Int"), - -- (BOOLEAN_TYPE_TOKEN, "Bool"), - -- (STRING_TYPE_TOKEN, "String") - ] - -findTok tok [] = Nothing -findTok tok ((tok_,str):list) - | tok == tok_ = Just str - | otherwise = findTok tok list - -findStr str [] = Nothing -findStr str ((tok,str_):list) - | str == str_ = Just tok - | otherwise = findStr str list - -instance TokenInterface Token where - toToken str = - case findStr str tokenStrList of - Nothing -> error ("toToken: " ++ str) - Just tok -> tok - fromToken tok = - case findTok tok tokenStrList of - Nothing -> error ("fromToken: " ++ show tok) - Just str -> str - diff --git a/app/polyrpc/TypeCheck.hs b/app/polyrpc/TypeCheck.hs deleted file mode 100644 --- a/app/polyrpc/TypeCheck.hs +++ /dev/null @@ -1,537 +0,0 @@ -module TypeCheck(typeCheck, lookupCon) where - -import Location -import Type -import Literal -import Prim -import Expr -import BasicLib - -typeCheck :: Monad m => [TopLevelDecl] -> m (GlobalTypeInfo, [TopLevelDecl]) -typeCheck toplevelDecls = do - -- 1. split - (bindingDecls, userDatatypes) <- splitTopLevelDecls toplevelDecls - - let datatypeDecls = builtinDatatypes ++ userDatatypes - - -- 2. collect all types, builtin or user-defined ones - typeInfo <- collectDataTypeDecls datatypeDecls - - -- 3. elaborate data types - elab_datatypeDecls <- elabDataTypeDecls typeInfo datatypeDecls - dataTypeInfo <- collectDataTypeInfo elab_datatypeDecls - - -- 4. elaborate constructor types - conTypeInfo <- elabConTypeDecls elab_datatypeDecls - - -- 5. elaborate types declared in the bindings - partial_elab_bindingDecls <- elabBindingTypes typeInfo bindingDecls - --------------------------------- --- for fully recursive bindings: --------------------------------- - bindingTypeInfo <- bindingTypes partial_elab_bindingDecls - - -- 6. elaborate bindings - let basicLibTypeInfo = [(x,ty) | (x,ty,expr)<-basicLib] - - let gti = GlobalTypeInfo - { _typeInfo=typeInfo - , _conTypeInfo=conTypeInfo - , _dataTypeInfo=dataTypeInfo -------------------------------- --- for fully recursive bindings -------------------------------- --- , _bindingTypeInfo=basicLibTypeInfo ++ bindingTypeInfo } - , _bindingTypeInfo=basicLibTypeInfo } - - elab_bindingDecls <- elaborate gti partial_elab_bindingDecls - - -- 7. return elaborated data types and bindings - let elab_toplevels = [ LibDeclTopLevel x ty | (x,ty) <- basicLibTypeInfo] - ++ [ DataTypeTopLevel dt | dt <- elab_datatypeDecls] - ++ [ BindingTopLevel bd | bd <- elab_bindingDecls] - - let gti1 = gti {_bindingTypeInfo=basicLibTypeInfo ++ bindingTypeInfo} - - return (gti1, elab_toplevels) - ----------------------------------------------------------------------------- --- 1. Split toplevel declarations into datatypes and bindings ----------------------------------------------------------------------------- - -splitTopLevelDecls :: Monad m => - [TopLevelDecl] -> m ([BindingDecl], [DataTypeDecl]) -splitTopLevelDecls toplevelDecls = do - bindingsDatatypeList <- mapM splitTopLevelDecl toplevelDecls - let (bindings,datatypes) = unzip bindingsDatatypeList - return (concat bindings, concat datatypes) - -splitTopLevelDecl :: Monad m => - TopLevelDecl -> m ([BindingDecl], [DataTypeDecl]) -splitTopLevelDecl (BindingTopLevel bindingDecl) = return ([bindingDecl], []) -splitTopLevelDecl (DataTypeTopLevel datatypeDecl) = return ([], [datatypeDecl]) - - ----------------------------------------------------------------------------- --- 2. Collect bultin types and user-defined datatyps ----------------------------------------------------------------------------- - --- type TypeInfo = [(String, [String], [String])] - -lookupTypeCon :: Monad m => TypeInfo -> String -> m ([String], [String]) -lookupTypeCon typeInfo x = do - let found = [(locvars,tyvars) | (name, locvars, tyvars) <- typeInfo, x==name] - if found /= [] - then return (head found) - else error $ "lookupConstr: Not found construct : " ++ x - -builtinDatatypes :: [DataTypeDecl] -builtinDatatypes = [ - (DataType unitType [] [] []), -- data Unit - (DataType intType [] [] []), -- data Int - (DataType boolType [] [] -- data Bool = { True | False } - [ TypeCon trueLit [] - , TypeCon falseLit [] ]), - (DataType stringType [] [] []), -- data String - (DataType refType ["l"] ["a"] []) -- data Ref - ] - - -collectDataTypeDecls :: Monad m => [DataTypeDecl] -> m TypeInfo -collectDataTypeDecls datatypeDecls = do - let nameTyvarsPairList = map collectDataTypeDecl datatypeDecls - return nameTyvarsPairList - -collectDataTypeDecl (DataType name locvars tyvars typeConDecls) = - if isTypeName name - && and (map isLocationVarName locvars) - && allUnique locvars == [] - && and (map isTypeVarName tyvars) - && allUnique tyvars == [] - then (name, locvars, tyvars) - else error $ "[TypeCheck] collectDataTypeDecls: Invalid datatype: " - ++ name ++ " " ++ show locvars++ " " ++ show tyvars - ----------------------------------------------------------------------------- --- 3. Elaboration of datatype declarations --- by elaborating Int as an identifier into ConType Int [], --- checking duplicate type variables in each datatype declaration, and --- checking duplicate constructor names in all datatype declarations. ----------------------------------------------------------------------------- - -elabDataTypeDecls :: Monad m => TypeInfo -> [DataTypeDecl] -> m [DataTypeDecl] -elabDataTypeDecls typeInfo datatypeDecls = - mapM (elabDataTypeDecl typeInfo) datatypeDecls - -elabDataTypeDecl :: Monad m => TypeInfo -> DataTypeDecl -> m DataTypeDecl -elabDataTypeDecl typeInfo (DataType name locvars tyvars typeConDecls) = do - elab_typeConDecls <- mapM (elabTypeConDecl typeInfo locvars tyvars) typeConDecls - return (DataType name locvars tyvars elab_typeConDecls) - -elabTypeConDecl :: Monad m => TypeInfo -> [String] -> [String] -> TypeConDecl -> m TypeConDecl -elabTypeConDecl typeInfo locvars tyvars (TypeCon con tys) = do - elab_tys <- mapM (elabType typeInfo tyvars locvars ) tys - return (TypeCon con elab_tys) - ----------------------------------------------------------------------------- --- 4. Elaboration of constructor types ----------------------------------------------------------------------------- - --- type ConTypeInfo = [(String, ([Type], String, [String], [String]))] - --- lookupConstr :: GlobalTypeInfo -> String -> [([Type], String, [String], [String])] --- lookupConstr gti x = [z | (con, z) <- _conTypeInfo gti, x==con] - -elabConTypeDecls :: Monad m => [DataTypeDecl] -> m ConTypeInfo -elabConTypeDecls elab_datatypeDecls = do - conTypeInfoList <- mapM elabConTypeDecl elab_datatypeDecls - let conTypeInfo = concat conTypeInfoList - case allUnique [con | (con,_) <- conTypeInfo] of - [] -> return conTypeInfo - (con:_) -> error $ "allConTypeDecls: duplicate constructor: " ++ con - -elabConTypeDecl :: Monad m => DataTypeDecl -> m ConTypeInfo -elabConTypeDecl (DataType name locvars tyvars typeConDecls) = do - return [ (con, (argtys, name, locvars, tyvars)) | TypeCon con argtys <- typeConDecls ] - ----------------------------------------------------------------------------- --- 5. Elaboration of types declared in bindings ----------------------------------------------------------------------------- - --- type BindingTypeInfo = [(String, Type)] - -elabBindingTypes :: Monad m => TypeInfo -> [BindingDecl] -> m [BindingDecl] -elabBindingTypes typeInfo bindingDecls = - mapM (\(Binding f ty expr)-> do - elab_ty <- elabType typeInfo [] [] ty - return (Binding f elab_ty expr)) bindingDecls - -bindingTypes :: Monad m => [BindingDecl] -> m [(String,Type)] -bindingTypes partial_elab_bindingDecls = - mapM (\(Binding f ty _) -> return (f,ty)) partial_elab_bindingDecls - ----------------------------------------------------------------------------- --- 6. Elaboration of bindings ----------------------------------------------------------------------------- - --- data GlobalTypeInfo = GlobalTypeInfo --- { _typeInfo :: TypeInfo --- , _conTypeInfo :: ConTypeInfo --- , _dataTypeInfo :: DataTypeInfo --- , _bindingTypeInfo :: BindingTypeInfo } - -elaborate :: Monad m => GlobalTypeInfo -> [BindingDecl] -> m [BindingDecl] -elaborate gti [] = return [] -elaborate gti (bindingDecl@(Binding f ty _):bindingDecls) = do - let gti1 = gti {_bindingTypeInfo = (f,ty):_bindingTypeInfo gti} -- for self-recursion - elab_bindingDecl <- elabBindingDecl gti1 bindingDecl - elab_bindingDecls <- elaborate gti1 bindingDecls - return (elab_bindingDecl:elab_bindingDecls) - -elabBindingDecl :: Monad m => GlobalTypeInfo -> BindingDecl -> m BindingDecl -elabBindingDecl gti (Binding name ty expr) = do - let env = emptyEnv{_varEnv=_bindingTypeInfo gti} - (elab_expr,elab_ty) <- elabExpr gti env clientLoc expr - if equalType elab_ty ty - then return (Binding name ty elab_expr) - else error $ "[TypeCheck] elabBindingDecl: Incorrect types: " ++ name ++ "\n" ++ show elab_ty ++ "\n" ++ show ty - ----------------------------------------------------------------------------- --- [Common] Elaboration of types ----------------------------------------------------------------------------- -elabType :: Monad m => TypeInfo -> [String] -> [String] -> Type -> m Type -elabType typeInfo tyvars locvars (TypeVarType x) = do - if elem x tyvars then return (TypeVarType x) - else if isConstructorName x then - do (_locvars, _tyvars) <- lookupTypeCon typeInfo x - if _locvars ==[] && _tyvars == [] - then return (ConType x [] []) - else error $ "[TypeCheck]: elabType: Invalid type constructor: " ++ x - else - error $ "[TypeCheck] elabType: Not found: " ++ x ++ " in " ++ show tyvars - -elabType typeInfo tyvars locvars (TupleType tys) = do - elab_tys <- mapM (elabType typeInfo tyvars locvars) tys - return (TupleType elab_tys) - -elabType typeInfo tyvars locvars (FunType ty1 (Location loc) ty2) = do - elab_ty1 <- elabType typeInfo tyvars locvars ty1 - elab_ty2 <- elabType typeInfo tyvars locvars ty2 - let loc0 = if loc `elem` locvars - then LocVar loc else Location loc - return (FunType elab_ty1 loc0 elab_ty2) - -elabType typeInfo tyvars locvars (FunType ty1 (LocVar _) ty2) = - error $ "[TypeCheck] elabType: FunType: LocVar" - -elabType typeInfo tyvars locvars (TypeAbsType abs_tyvars ty) = do - elab_ty <- elabType typeInfo (abs_tyvars ++ tyvars) locvars ty - return (TypeAbsType abs_tyvars elab_ty) - -elabType typeInfo tyvars locvars (LocAbsType abs_locvars ty) = do - elab_ty <- elabType typeInfo tyvars (abs_locvars ++ locvars) ty - return (LocAbsType abs_locvars elab_ty) - -elabType typeInfo tyvars locvars (ConType name locs tys) = do - (_locvars, _tyvars) <- lookupTypeCon typeInfo name - if length _locvars == length locs && length _tyvars == length tys - then do elab_locs <- mapM (elabLocation locvars) locs - elab_tys <- mapM (elabType typeInfo tyvars locvars) tys - return (ConType name elab_locs elab_tys) - else error $ "[TypeCheck]: elabType: Invalud args for ConType: " ++ name - - -elabLocation :: Monad m => [String] -> Location -> m Location -elabLocation locvars (Location loc) - | loc `elem` locvars = return (LocVar loc) - | otherwise = return (Location loc) -elabLocation locvars (LocVar x) - | x `elem` locvars = return (LocVar x) - | otherwise = error $ "[TypeCheck] elabLocation: Not found LocVar " ++ x - ----------------------------------------------------------------------------- --- [Common] Elaboration of expressions ----------------------------------------------------------------------------- - --- data Env = Env --- { _locVarEnv :: [String] --- , _typeVarEnv :: [String] --- , _varEnv :: BindingTypeInfo } - -emptyEnv = Env {_varEnv=[], _locVarEnv=[], _typeVarEnv=[]} - -lookupVar :: Env -> String -> [Type] -lookupVar env x = [ty | (y,ty) <- _varEnv env, x==y] - -lookupLocVar :: Env -> String -> Bool -lookupLocVar env x = elem x (_locVarEnv env) - -lookupTypeVar :: Env -> String -> Bool -lookupTypeVar env x = elem x (_typeVarEnv env) - --- --- type DataTypeInfo = [(String, ([String], [(String,[Type])]))] - --- lookupDataTypeName gti x = [info | (y,info) <- _dataTypeInfo gti, x==y] - -collectDataTypeInfo :: Monad m => [DataTypeDecl] -> m DataTypeInfo -collectDataTypeInfo datatypeDecls = do - mapM get datatypeDecls - where get (DataType name locvars tyvars tycondecls) = - return (name, (locvars, tyvars,map f tycondecls)) - f (TypeCon s tys) = (s,tys) - --- - --- For making constructor location/type/value functions -mkLocAbs loc cname tyname [] tyvars argtys = mkTypeAbs loc cname tyname [] tyvars argtys -mkLocAbs loc cname tyname locvars tyvars argtys = - let (tyabs, tyabsTy) = mkTypeAbs loc cname tyname locvars tyvars argtys - in (singleLocAbs (LocAbs locvars tyabs) - , singleLocAbsType (LocAbsType locvars tyabsTy)) - -mkTypeAbs loc cname tyname locvars [] argtys = mkAbs loc cname tyname locvars [] argtys -mkTypeAbs loc cname tyname locvars tyvars argtys = - let (abs, absTy) = mkAbs loc cname tyname locvars tyvars argtys - in (singleTypeAbs (TypeAbs tyvars abs) - , singleTypeAbsType (TypeAbsType tyvars absTy)) - -mkAbs loc cname tyname locvars tyvars [] = - let locs = map LocVar locvars - tys = map TypeVarType tyvars - in (Constr cname locs tys [] [], ConType tyname locs tys) - -mkAbs loc cname tyname locvars tyvars argtys = - let locs = map LocVar locvars - tys = map TypeVarType tyvars - varNames = take (length argtys) ["arg"++show i | i<- [1..]] - vars = map Var varNames - abslocs = loc : abslocs - varTypeLocList = zip3 varNames argtys abslocs - in (singleAbs (Abs varTypeLocList (Constr cname locs tys vars argtys)) - , foldr ( \ ty ty0 -> FunType ty loc ty0) (ConType tyname locs tys) argtys) - -elabExpr :: Monad m => - GlobalTypeInfo -> Env -> Location -> Expr -> m (Expr, Type) -elabExpr gti env loc (Var x) - | isConstructorName x = -- if it is a constructor - case lookupConstr gti x of - ((argtys, tyname, locvars, tyvars):_) -> return $ mkLocAbs loc x tyname locvars tyvars argtys - - [] -> error $ "[TypeCheck] elabExpr: Not found constructor " ++ x - - | otherwise = -- isBindingName x = -- if it is a term variable - case lookupVar env x of -- try to find it in the local var env or - (x_ty:_) -> return (Var x, x_ty) - [] -> error $ "[TypeCheck] Not found constructor " ++ x - -elabExpr gti env loc (TypeAbs tyvars expr) = do - let typeVarEnv = _typeVarEnv env - let typeVarEnv' = reverse tyvars ++ typeVarEnv - (elab_expr, elab_ty) <- elabExpr gti (env{_typeVarEnv=typeVarEnv'}) loc expr - return (singleTypeAbs (TypeAbs tyvars elab_expr), singleTypeAbsType (TypeAbsType tyvars elab_ty)) - -elabExpr gti env loc (LocAbs locvars expr) = do - let locVarEnv = _locVarEnv env - let locVarEnv' = reverse locvars ++ locVarEnv - (elab_expr, elab_ty) <- elabExpr gti (env{_locVarEnv=locVarEnv'}) loc expr - return (singleLocAbs (LocAbs locvars elab_expr), singleLocAbsType (LocAbsType locvars elab_ty)) - -elabExpr gti env loc_0 (Abs [(var,argty,loc)] expr) = do - elab_argty <- elabType (_typeInfo gti) (_typeVarEnv env) (_locVarEnv env) argty - elab_loc <- elabLocation (_locVarEnv env) loc - let varEnv = _varEnv env - let varEnv' = (var,elab_argty):varEnv - (elab_expr, ret_ty) <- elabExpr gti (env{_varEnv=varEnv'}) elab_loc expr - return (Abs [(var,elab_argty,elab_loc)] elab_expr, FunType elab_argty elab_loc ret_ty) - -elabExpr gti env loc_0 (Abs ((var,argty,loc):varTypeLocList) expr) = do - elab_argty <- elabType (_typeInfo gti) (_typeVarEnv env) (_locVarEnv env) argty - elab_loc <- elabLocation (_locVarEnv env) loc - let varEnv = _varEnv env - let varEnv' = (var,elab_argty):varEnv - (elab_expr, ret_ty) <- - elabExpr gti (env{_varEnv=varEnv'}) elab_loc (singleAbs (Abs varTypeLocList expr)) - return (Abs [(var,elab_argty,elab_loc)] elab_expr, FunType elab_argty elab_loc ret_ty) - -elabExpr gti env loc_0 (Abs [] expr) = - error $ "[TypeCheck] elabExpr: empty argument Abs" - -elabExpr gti env loc (Let letBindingDecls expr) = do - let typeInfo = _typeInfo gti - partial_elab_letBindingDecls <- elabBindingTypes typeInfo letBindingDecls - --------------------------------- --- for fully recursive bindings: --------------------------------- --- letBindingTypeInfo <- bindingTypes partial_elab_letBindingDecls - --- let letBindingTypeInfo' = letBindingTypeInfo ++ _bindingTypeInfo gti --- let gti1 = gti {_bindingTypeInfo=letBindingTypeInfo'} - let gti1 = gti - elab_letBindingDecls <- elaborate gti1 partial_elab_letBindingDecls - - letBindingTypeInfo <- bindingTypes partial_elab_letBindingDecls -- for let body - - let varEnv = letBindingTypeInfo ++ _varEnv env - (elab_expr, elab_ty) <- elabExpr gti (env {_varEnv=varEnv}) loc expr - return (Let elab_letBindingDecls elab_expr, elab_ty) - -elabExpr gti env loc (Case expr _ []) = - error $ "[TypeCheck] empty alternatives" - -elabExpr gti env loc (Case expr _ alts) = do - (elab_caseexpr, casety) <- elabExpr gti env loc expr - case casety of - ConType tyconName locs tys -> - case lookupDataTypeName gti tyconName of - ((locvars, tyvars, tycondecls):_) -> do - (elab_alts, altty) <- elabAlts gti env loc locs locvars tys tyvars tycondecls alts - return (Case elab_caseexpr (Just casety) elab_alts, altty) - [] -> error $ "[TypeCheck] elabExpr: invalid constructor type: " ++ tyconName - - TupleType tys -> do - (elab_alts, altty) <- elabAlts gti env loc [] [] tys [] [] alts - return (Case elab_caseexpr (Just casety) elab_alts, altty) - - _ -> error $ "[TypeCheck] elabExpr: case expr not constructor type" - -elabExpr gti env loc (App left_expr maybe right_expr l) = do - (elab_left_expr, left_ty) <- elabExpr gti env loc left_expr - (elab_right_expr, right_ty) <- elabExpr gti env loc right_expr - case left_ty of - FunType argty loc0 retty -> - if equalType argty right_ty - then return (App elab_left_expr (Just left_ty) elab_right_expr (Just loc0), retty) - else error $ "[TypeCheck] elabExpr: not equal arg type in app:\n" - ++ show (App left_expr maybe right_expr l) ++ "\n" ++ show argty ++ "\n" ++ show right_ty - _ -> error $ "[TypeCheck] elabExpr: not function type in app:\n" - ++ show (App left_expr maybe right_expr l) ++ "\n" ++ show left_ty ++ "\n" ++ show right_ty - -elabExpr gti env loc (TypeApp expr maybe tys) = do - elab_tys <- mapM (elabType (_typeInfo gti) (_typeVarEnv env) (_locVarEnv env)) tys - (elab_expr, elab_ty) <- elabExpr gti env loc expr - case elab_ty of - TypeAbsType tyvars ty0 -> - if length tyvars == length elab_tys - then return (singleTypeApp (TypeApp elab_expr (Just elab_ty) elab_tys), doSubst (zip tyvars elab_tys) ty0) - else error $ "[TypeCheck] elabExpr: not equal length of arg types in type app: " - _ -> error $ "[TypeCheck] elabExpr: not type-abstraction type in type app: " ++ "\n" - ++ show elab_ty ++ "\n" - ++ show (TypeApp expr maybe tys) ++ "\n" - -elabExpr gti env loc (LocApp expr maybe locs) = - let f (Location loc0) = if loc0 `elem` (_locVarEnv env) then LocVar loc0 else Location loc0 - f (LocVar x) = error $ "[TypeCheck] elabExpr: LocApp: LocVar: " ++ x - in do - let locs0 = map f locs - (elab_expr, elab_ty) <- elabExpr gti env loc expr - case elab_ty of - LocAbsType locvars ty0 -> - if length locvars == length locs - then return (singleLocApp (LocApp elab_expr (Just elab_ty) locs0), doSubstLoc (zip locvars locs0) ty0) - else error $ "[TypeCheck] elabExpr: not equal length of arg locations in location app: " ++ show locvars ++ " " ++ show locs - _ -> error $ "[TypeCheck] elabExpr: not location-abstraction type in type app: " - -elabExpr gti env loc (Tuple exprs) = do - elabExprTyList <- mapM (elabExpr gti env loc) exprs - let (elab_exprs, tys) = unzip elabExprTyList - return (Tuple elab_exprs, TupleType tys) - -elabExpr gti env loc (Prim op op_locs@[] op_tys@[] exprs) = -- A hack for the primitives with the current loc! - elabExpr gti env loc (Prim op [loc] op_tys exprs) - -elabExpr gti env loc (Prim op op_locs op_tys exprs) = do - elab_op_locs <- mapM (elabLocation (_locVarEnv env)) op_locs - elab_op_tys <- mapM (elabType (_typeInfo gti) (_typeVarEnv env) (_locVarEnv env)) op_tys - elabExprTyList <- mapM (elabExpr gti env loc) exprs - let (elab_exprs, tys) = unzip elabExprTyList - case lookupPrimOpType op of - ((locvars, tyvars, argtys, retty):_) -> do - let substTy = zip tyvars op_tys - let substLoc = zip locvars op_locs - let substed_argtys = map (doSubstLoc substLoc . doSubst substTy) argtys - - if length tys==length argtys - && and (map (uncurry equalType) (zip substed_argtys tys)) - && length locvars==length op_locs - && length tyvars==length op_tys - - then return (Prim op elab_op_locs elab_op_tys elab_exprs, retty) - - else error $ "[TypeCheck] elabExpr: incorrect arg types in Prim op: " - ++ show tys ++ " != " ++ show substed_argtys - - [] -> error $ "[TypeCheck] elabExpr: type not found type in Prim op: " - -elabExpr gti env loc (Lit literal) = return (Lit literal, typeOfLiteral literal) - -elabExpr gti env loc (Constr conname locs contys exprs _argtys) = do - elab_locs <- mapM (elabLocation (_locVarEnv env)) locs - elab_contys <- mapM (elabType (_typeInfo gti) (_typeVarEnv env) (_locVarEnv env)) contys - elabExprTyList <- mapM (elabExpr gti env loc) exprs - let (elab_exprs, elab_tys) = unzip elabExprTyList - case lookupConstr gti conname of - ((argtys,tyname,locvars,tyvars):_) -> - case (unifyTypes argtys elab_tys) of - (Just subst) -> - return (Constr conname elab_locs elab_contys elab_exprs -- BUG: subt0??? - (map (doSubst subst) elab_tys) - , doSubst subst (ConType tyname (map LocVar locvars) (map TypeVarType tyvars))) - (Nothing) -> error $ "[TypeCheck] elabExpr: constructor arg types incorrect: " ++ conname - - [] -> error $ "[TypeCheck] elabExpr: constructor not found: " ++ conname - --- elabExpr gti env loc expr = error $ "[TypeCheck] elabExpr: " ++ show expr - --- -elabAlts gti env loc locs locvars tys tyvars tycondecls [alt] = do - let substLoc = zip locvars locs - let substTy = zip tyvars tys - (elab_alt, elab_ty) <- elabAlt gti env loc substLoc substTy tycondecls tys alt - return ([elab_alt], elab_ty) - -elabAlts gti env loc locs locvars tys tyvars tycondecls (alt:alts) = do - let substLoc = zip locvars locs - let substTy = zip tyvars tys - (elab_alt, elab_ty1) <- elabAlt gti env loc substLoc substTy tycondecls tys alt - (elab_alts, elab_ty2) <- elabAlts gti env loc locs locvars tys tyvars tycondecls alts - if equalType elab_ty1 elab_ty2 - then return (elab_alt:elab_alts, elab_ty1) - else error $ "[TypeCheck] elabAlts: not equal alt type: " ++ - (case alt of { - Alternative con args _ -> con ++ show args; - TupleAlternative args _ -> show args }) - --- lookupCon tycondecls con = --- [tys | (conname, tys) <- tycondecls, con==conname] - -elabAlt gti env loc substLoc substTy tycondecls externTys (Alternative con args expr) = do --- externTys only for TupleAlternative - case lookupCon tycondecls con of - (tys:_) -> - if length tys==length args - then do let tys' = map (doSubst substTy) (map (doSubstLoc substLoc) tys) - let varEnv = _varEnv env - let varEnv' = zip args tys' ++ varEnv - (elab_expr, elab_ty) <- elabExpr gti (env {_varEnv=varEnv'}) loc expr - return (Alternative con args elab_expr, elab_ty) - else error $ "[TypeCheck] elabAlt: invalid arg length: " ++ con ++ show args - - [] -> error $ "[TypeCheck] elabAlt: constructor not found" - -elabAlt gti env loc substLoc substTy tycondecls externTys (TupleAlternative args expr) = do --- substTy==[], tycondecls==[] - let varEnv = _varEnv env - let varEnv' = zip args externTys ++ varEnv - (elab_expr, elab_ty) <- elabExpr gti (env {_varEnv=varEnv'}) loc expr - return (TupleAlternative args elab_expr, elab_ty) - - ----------------------------------------------------------------------------- --- Common Utils ----------------------------------------------------------------------------- -allUnique [] = [] -allUnique (x:xs) = - if elem x xs then [x] else allUnique xs diff --git a/app/polyrpc/Verify.hs b/app/polyrpc/Verify.hs deleted file mode 100644 --- a/app/polyrpc/Verify.hs +++ /dev/null @@ -1,358 +0,0 @@ -module Verify where - -import Location -import Prim -import Literal -import qualified Expr as SE -import CSType -import CSExpr - - ---------------------- --- Verify CS programs ---------------------- - -verify :: Monad m => GlobalTypeInfo -> FunctionStore -> Expr -> m () -verify gti funStore mainexpr = do - verifyFunStore gti funStore - let clientFunStore = _clientstore funStore - verifyExpr (gti,funStore) clientLoc initEnv (MonType unit_type) mainexpr - -------------------------- --- Verify function stores -------------------------- - -type GlobalInfo = (GlobalTypeInfo, FunctionStore) - -verifyFunStore :: Monad m => GlobalTypeInfo -> FunctionStore -> m() - -verifyFunStore gti funStore = do - verifyFunStoreAt gti clientLoc funStore - verifyFunStoreAt gti serverLoc funStore - -verifyFunStoreAt :: Monad m => GlobalTypeInfo -> Location -> FunctionStore -> m() - -verifyFunStoreAt gti loc funStore = - let gci = if loc==clientLoc then _clientstore funStore else _serverstore funStore in - mapM_ (\(f, (codety, code)) -> verifyCode (gti,funStore) loc codety code) gci - - ---------------- --- Verify codes ---------------- - -verifyCode gtigci loc (CodeType _freeLocVars _freeTyVars freeVarTys ty) - (Code freeLocVars freeTyVars freeVars openCode) = do - - assert (_freeLocVars == freeLocVars) -- (1) _freeLocVars==freeLocVars - ("[verifyCode] Not equal free loc vars: " - ++ show _freeLocVars ++ " != " ++ show freeLocVars) - - assert ( _freeTyVars == freeTyVars) -- (2) _freeTyVars==freeTyVars - ("[verifyCode] Not equal free ty vars: " - ++ show _freeTyVars ++ " != " ++ show freeTyVars) - - assert (length freeVars == length freeVarTys) -- (3) length freeVars==length freeVarTys - ("[verifyCode] Not equal free variables and types: " - ++ show freeVars ++ " !: " ++ show freeVarTys) - - -- (4) All loc vars occurring in freeVarTys must be in freeLocVars - -- (5) All ty vars occurring in freeVarTys must be in freeTyVars - - let env = Env { _locVarEnv=freeLocVars - , _typeVarEnv=freeTyVars - , _varEnv=zip freeVars freeVarTys} - - -- TODO: free locvars, free tyvars, free vars are closed. - - verifyOpenCode gtigci loc env ty openCode - --------------------- --- Verify open codes --------------------- - -verifyOpenCode gtigci loc env (FunType argty locfun resty) (CodeAbs ((x,ty):xTys) expr) = do - assert (null xTys) -- (1) xTys == [] - ("[verifyOpenCode] CodeAbs has more than two args? " ++ show xTys) - - assert (equalType argty ty) -- (2) argty == ty - ("[verifyOpenCode] not equal types: " ++ show argty ++ " != " ++ show ty) - - let env1 = env {_varEnv = (x,ty) : _varEnv env} - - verifyExpr gtigci locfun env1 resty expr - -verifyOpenCode gtigci loc env (TypeAbsType (tyvar1:tyvars1) ty) (CodeTypeAbs (tyvar2:tyvars2) expr) = do - -- (1) tyvar1 == tyvar2 - let _ty = if tyvar1 == tyvar2 then ty - else doSubst [(tyvar1, TypeVarType tyvar2)] ty - - assert (tyvars1 == []) -- (2) tyvars1 == [] - ("[verifyOpenCode] CodeTypeAbs has more than two ty args? " ++ show tyvars1) - assert (tyvars2 == []) -- (3) tyvars2 == [] - ("[verifyOpenCode] CodeTypeAbs has more than two ty args? " ++ show tyvars2) - - let env1 = env {_typeVarEnv = tyvar2 : _typeVarEnv env} - - verifyExpr gtigci loc env1 _ty expr - - -verifyOpenCode gtigci loc env (LocAbsType (locvar1:locvars1) ty) (CodeLocAbs (locvar2:locvars2) expr) = do - -- (1) locvar1 == locvar2 - let _ty = if locvar1 == locvar2 then ty - else doSubstLoc [(locvar1, LocVar locvar2)] ty - - assert (locvars1 == []) -- (2) locvars1 == [] - ("[verifyOpenCode] CodeTypeAbs has more than two loc args? " ++ show locvars1) - assert (locvars2 == [] ) -- (3) locvars2 == [] - ("[verifyOpenCode] CodeTypeAbs has more than two loc args? " ++ show locvars2) - - let env1 = env {_locVarEnv = locvar2 : _locVarEnv env} - - verifyExpr gtigci loc env1 _ty expr - -verifyOpenCode gtigci loc env ty openCode = - error $ "[verifyOpenCode] Not well-typed: " ++ show ty ++ "," ++ show openCode - - --------------------- --- Verify code names --------------------- - -verifyCodeName :: Monad m => GlobalInfo -> Location -> Type -> [Type] -> CodeName -> m () - -verifyCodeName (gti, funStore) loc someAbsTy freeVarTys (CodeName f locs tys) = - let locLookFor = getLoc loc someAbsTy funStore in - let gci = if locLookFor==clientLoc then _clientstore funStore else _serverstore funStore in - - case [(codeType, code) | (g, (codeType, code)) <- gci, f==g] of - [] -> error $ "[verifyCodeName] Code not found: " ++ f - ((CodeType locvars0 tyvars0 freeVarTys0 ty, Code locvars1 tyvars1 freeVars1 _):_) -> do - - assert (locvars0 == locvars1) -- (1) locvars0 == locvars1 - ("[verifyCodeName] No equal loc var names: " - ++ show locvars0 ++ " != " ++ show locvars1) - - assert (tyvars0 == tyvars1) -- (2) tyvars0 == tyvars1 - ("[verifyCodeName] No equal type var names: " - ++ show tyvars0 ++ " != " ++ show tyvars1) - - -- assert (and $ map (uncurry equalType) (zip freeVarTys0 freeVarTys)) -- (3) freeVarTys0 == freeVarTys - -- ("[verifyCodeName] Not equal free var types: " - -- ++ show freeVarTys0 ++ " != " ++ show freeVarTys1) - - -- freeVarTys0 {locs/locvars0} [tys/tyvars0] == freeVarTys - -- ty {locs/locvars0} [tys/tyvars0] == someAbsTy - - let substTy = zip tyvars0 tys - let substLoc = zip locvars0 locs - - let substed_freeVarTys0 = map (doSubstLoc substLoc . doSubst substTy) freeVarTys0 - let substed_ty = doSubstLoc substLoc (doSubst substTy ty) - - let equal (ty1, ty2) = - assert (equalType ty1 ty2) - ("[verifyCodeName] Not equal type: " - ++ show ty1 ++ " != " ++ show ty2 ++ " in " ++ f) - - equal (substed_ty, someAbsTy) - mapM_ equal $ zip substed_freeVarTys0 freeVarTys - - -getLoc loc0 (FunType _ (Location loc) _) funStore = Location loc -getLoc loc0 (FunType _ (LocVar _) _) funStore = loc0 -getLoc loc0 (TypeAbsType _ _) funStore = loc0 -getLoc loc0 (LocAbsType _ _) funStore = loc0 -getLoc loc0 ty funStore = error $ "[getLoc] unexpected type: " ++ show ty - ---------------------- --- Verify expressions ---------------------- - -verifyExpr :: Monad m => GlobalInfo -> Location -> Env -> Type -> Expr -> m () - -verifyExpr gtigci loc env ty (ValExpr v) = verifyValue gtigci loc env ty v - -verifyExpr gtigci loc env ty (Let bindingDecls expr) = do - let (xtys, exprs) = unzip [((x,ty), expr) | Binding x ty expr <- bindingDecls] - let (xs, tys) = unzip xtys - let env1 = env {_varEnv = xtys ++ _varEnv env} - mapM_ (\ (vty, expr) -> verifyExpr gtigci loc env1 vty expr) $ zip tys exprs - verifyExpr gtigci loc env1 ty expr - -verifyExpr gtigci loc env ty (Case caseval casety alts) = do - verifyValue gtigci loc env casety caseval - mapM_ (verifyAlt gtigci loc env casety ty) alts - -verifyExpr gtigci loc env ty (App left (CloType (FunType argty funloc resty)) right) = do - assert (equalLoc loc funloc) -- (1) loc == funloc - ("[verifyExpr] Not equal locations: " ++ show loc ++ " != " ++ show funloc) - assert (equalType ty resty) -- (2) ty == resty - ("[verifyExpr] Not equal types: " ++ show ty ++ " != " ++ show resty) - - verifyValue gtigci loc env (CloType (FunType argty funloc resty)) left - verifyValue gtigci loc env argty right - -verifyExpr gtigci loc env ty (TypeApp left (CloType (TypeAbsType tyvars bodyty)) tys) = do - assert (length tyvars == length tys) -- (1) length tyvars == length tys - ("[verifyExpr] Not equal arities: " ++ show tyvars ++ " != " ++ show tys) - - verifyValue gtigci loc env (CloType (TypeAbsType tyvars bodyty)) left - let subst = zip tyvars tys - let substed_bodyty = doSubst subst bodyty - - assert (equalType substed_bodyty ty) - ("[verifyExpr] Not equal type: " ++ show substed_bodyty ++ " != " ++ show ty) - -verifyExpr gtigci loc env ty (LocApp left (CloType (LocAbsType locvars bodyty)) locs) = do - assert (length locvars == length locs) -- (1) length locvars == length locs - ("[verifyExpr] Not equal arities: " ++ show locvars ++ " != " ++ show locs) - - verifyValue gtigci loc env (CloType (LocAbsType locvars bodyty)) left - let substLoc = zip locvars locs - let substed_bodyty = doSubstLoc substLoc bodyty - - assert (equalType substed_bodyty ty) - ("[verifyExpr] Not equal type: " ++ show substed_bodyty ++ " != " ++ show ty) - -verifyExpr gtigci loc env ty (Prim MkRecOp locs tys vs) = do -- locs=[], tys=[] - return () - -verifyExpr gtigci loc env ty (Prim prim op_locs op_tys vs) = do - case lookupPrimOpType prim of - [] -> error $ "[verifyExpr] Not found prim: " ++ show prim - ((locvars, tyvars, argtys,resty):_) -> do - let substTy = zip tyvars op_tys - let substLoc = zip locvars op_locs - let substed_argtys = map (doSubstLoc substLoc . doSubst substTy) argtys - - assert (length vs==length argtys - && length locvars==length op_locs - && length tyvars==length op_tys) - ("[verifyExpr] unexpected: " - ++ show prim ++ " " ++ show op_locs ++ " " ++ show op_tys ++ " " ++ show vs - ++ "\n " ++ show locvars ++ " " ++ show tyvars) - - mapM_ (\ (argty, v) -> verifyValue gtigci loc env argty v) (zip argtys vs) - assert (equalType ty resty) -- (1) ty == resty - ("[verifyExpr] Not equal types: " ++ show ty ++ " != " ++ show resty) - -verifyExpr gtigci loc env ty expr = - error $ "[verifyExpr]: not well-typed: " ++ show expr ++ " : " ++ show ty - - -verifyAlt :: Monad m => GlobalInfo -> Location -> Env -> Type -> Type -> Alternative -> m () - -verifyAlt gtigci loc env (ConType tyconname locs tys) retty (Alternative cname args expr) = - case lookupConstr (fst gtigci) cname of - ((bare_argtys, tyconname1, locvars, tyvars):_) -> do - assert (tyconname==tyconname1) - ("[verifyAlt] Not equal type con name: " - ++ tyconname ++ " != " ++ tyconname1 ++ " for " ++ cname) - assert (length bare_argtys==length args) - ("[verifyAlt] Not equal arg length: " - ++ tyconname ++ " != " ++ tyconname1 ++ " for " ++ cname) - let substLoc = zip locvars locs - let substTy = zip tyvars tys - let argstys = map (doSubst substTy . doSubstLoc substLoc) bare_argtys - let env1 = env {_varEnv = zip args argstys ++ _varEnv env} - verifyExpr gtigci loc env1 retty expr - - [] -> error $ "[verifyAlt] Constructor not found " ++ cname - -verifyAlt gtigci loc env (TupleType argtys) retty (TupleAlternative args expr) = do - let env1 = env {_varEnv = zip args argtys ++ _varEnv env} - verifyExpr gtigci loc env1 retty expr - ----------------- --- Verify values ----------------- - -verifyValue :: Monad m => GlobalInfo -> Location -> Env -> Type -> Value -> m () - -verifyValue gtigci loc env ty (Var x) = do - case [ty | (y,ty) <- _varEnv env, x==y] of - (yty:_) -> assert (equalType yty ty) - ("[verifyValue] Not equal type: " ++ show yty ++ " != " ++ show ty) - [] -> - case [ty | (z,ty) <- _libInfo $ fst $ gtigci, x==z] of - (zty:_) -> assert (equalType zty ty) - ("[verifyValue] Not equal type: " ++ show zty ++ " != " ++ show ty) - [] -> error $ "[verifyExpr] Variable not found: " ++ x ++ " in " ++ show (_varEnv env) - -verifyValue gtigci loc env ty (Lit lit) = - case lit of - IntLit i -> assert (equalType ty int_type) "[verifyValue] Not Int type" - StrLit s -> assert (equalType ty string_type) "[verifyValue] Not String type" - BoolLit b -> assert (equalType ty bool_type) "[verifyValue] Not Bool type" - UnitLit -> assert (equalType ty unit_type) "[verifyValue] Not Unit type" - -verifyValue gtigci loc env (TupleType tys) (Tuple vs) = - mapM_ ( \ (ty,v) -> verifyValue gtigci loc env ty v ) (zip tys vs) - -verifyValue gtigci loc env ty (Constr cname locs tys args argtys) = do - mapM_ ( \ (ty,v) -> verifyValue gtigci loc env ty v ) (zip argtys args) - case lookupConstr (fst gtigci) cname of - ((bare_argtys, tyconname, locvars, tyvars):_) -> do - let substLoc = zip locvars locs - let substTy = zip tyvars tys - let argtys1 = map (doSubst substTy . doSubstLoc substLoc) bare_argtys - assert (and (map (uncurry equalType) (zip argtys1 argtys))) -- argstys1 == argtys - ("[verifyValue] Not equal constructor arg types: " ++ cname ++ " " - ++ show argtys1 ++ " != " ++ show argtys) - assert (equalType (ConType tyconname locs tys) ty) -- ConType tyconname locs tys == ty - ("[verifyValue] Not equal constructor type: " ++ cname - ++ show ty ++ " != " ++ show (ConType tyconname locs tys)) - [] -> error $ "[verifyValue] Constructor not found: " ++ cname - -verifyValue gtigci loc env (CloType ty) (Closure vs tys codeName recf) = do - -- let env0 = env {_varEnv = [] } - mapM_ ( \ (ty,v) -> verifyValue gtigci loc env ty v) (zip tys vs) - verifyCodeName gtigci loc ty tys codeName - -verifyValue gtigci loc env (MonType ty) (UnitM v) = verifyValue gtigci loc env ty v - -verifyValue gtigci loc env (MonType ty) (BindM bindingDecls expr) = do - let (xtys, exprs) = unzip [((x,ty), expr) | Binding x ty expr <- bindingDecls] - let (xs, tys) = unzip xtys - let env1 = env {_varEnv = xtys ++ _varEnv env} - let monadic_tys = map MonType tys - mapM_ (\ (mty, expr) -> verifyExpr gtigci loc env1 mty expr) $ zip monadic_tys exprs - verifyExpr gtigci loc env1 (MonType ty) expr - -verifyValue gtigci loc env ty (Req left (CloType (FunType argty funloc resty)) right) = do - assert (equalLoc loc clientLoc) -- (1) loc == client - ("[verifyValue] Not client location: " ++ show loc) - assert (equalLoc funloc serverLoc) -- (2) funloc == server - ("[verifyValue] Not server location: " ++ show funloc) - assert (equalType ty resty) -- (3) ty == resty - ("[verifyExpr] Not equal types: " ++ show ty ++ " != " ++ show resty) - - verifyValue gtigci loc env (CloType (FunType argty funloc resty)) left - verifyValue gtigci loc env argty right - -verifyValue gtigci loc env ty (Call left (CloType (FunType argty funloc resty)) right) = do - assert (equalLoc loc serverLoc) -- (1) loc == server - ("[verifyValue] Not server location: " ++ show loc) - assert (equalLoc funloc clientLoc) -- (2) funloc == client - ("[verifyValue] Not client location: " ++ show funloc) - assert (equalType ty resty) -- (3) ty == resty - ("[verifyValue] Not equal types: " ++ show ty ++ " != " ++ show resty) - - verifyValue gtigci loc env (CloType (FunType argty funloc resty)) left - verifyValue gtigci loc env argty right - -verifyValue gtigci loc env ty (GenApp funloc0 left (CloType (FunType argty funloc resty)) right) = do - assert (equalType ty resty) -- (1) ty == resty - ("[verifyValue] Not equal types: " ++ show ty ++ " != " ++ show resty) - assert (equalLoc funloc0 funloc) -- (2) funloc0 == funloc - ("[verifyValue] Not equal locations: " ++ show funloc0 ++ " != " ++ show funloc) - - verifyValue gtigci loc env (CloType (FunType argty funloc resty)) left - verifyValue gtigci loc env argty right - -verifyValue gtigci loc env ty value = - error $ "[verifyValue]: not well-typed: " ++ show value ++ " : " ++ show ty - ---- -assert cond msg = if cond then return () else error msg diff --git a/app/polyrpc/ast/BasicLib.hs b/app/polyrpc/ast/BasicLib.hs deleted file mode 100644 --- a/app/polyrpc/ast/BasicLib.hs +++ /dev/null @@ -1,144 +0,0 @@ -module BasicLib where - -import Location -import Type -import Prim -import Expr - - -basicLib :: [(String, Type, Expr)] -basicLib = - [ - --- read : {l}. Unit -l-> String --- = {l}. \x:Unit @l. primRead [l] x - let l = "l" - x = "x" - in - ( "read" - , LocAbsType [l] - (FunType unit_type (LocVar l) string_type) - , LocAbs [l] - (Abs [(x,unit_type,LocVar l)] - (Prim PrimReadOp [LocVar l] [] [Var x])) - ), - - --- print : {l}. String -l->unit --- = {l}. \x:String @l. primPrint [l] x - - let l = "l" - x = "x" - in - ( "print" - , LocAbsType [l] - (FunType string_type (LocVar l) unit_type) - , LocAbs [l] - (Abs [(x,string_type,LocVar l)] - (Prim PrimPrintOp [LocVar l] [] [Var x])) - ), - - --- intToString --- : {l}. Int -l-> String --- = {l}. \x:Int @l. primIntToString [l] x - let l = "l" - x = "x" - in - ( "intToString" - , LocAbsType [l] - (FunType int_type (LocVar l) string_type) - , LocAbs [l] - (Abs [(x,int_type,LocVar l)] - (Prim PrimIntToStringOp [LocVar l] [] [Var x])) - ), - --- concat --- : {l}. String -l-> String -l-> String --- = {l}. \x:String @l y:String @l. primConcat {l} (x,y) - - let l = "l" - x = "x" - y = "y" - in - ( "concat" - , LocAbsType [l] - (FunType string_type (LocVar l) - (FunType string_type (LocVar l) string_type)) - , LocAbs [l] - (Abs [(x,string_type,LocVar l)] - (Abs [(y,string_type,LocVar l)] - (Prim PrimConcatOp [LocVar l] [] [Var x, Var y]))) - ), - - -- ("not", let l = "l" in - -- LocAbsType [l] (FunType bool_type (LocVar l) bool_type)), - - --- ref : {l1}. [a]. a -l1-> Ref {l1} [a] --- = {l1}. [a]. --- \v : a @ l1. primRef {l1} [a] v - - let l1 = "l1" - a = "a" - tyvar_a = TypeVarType a - x = "x" - in - ("ref" - , LocAbsType [l1] - (TypeAbsType [a] - (FunType tyvar_a (LocVar l1) - (ConType refType [LocVar l1] [tyvar_a]))) - , LocAbs [l1] - (TypeAbs [a] - (Abs [(x,tyvar_a,LocVar l1)] - (Prim PrimRefCreateOp [LocVar l1] [tyvar_a] [Var x]))) - ), - - --- (!) : {l1}. [a]. Ref {l1} [a] -l1-> a --- = {l1}. [a]. --- \addr:Ref {l1} [a] @l1. primRefRead {l1} [a] addr - - let l1 = "l1" - a = "a" - tyvar_a = TypeVarType a - x = "x" - in - ( "!" - , LocAbsType [l1] - (TypeAbsType [a] - (FunType (ConType refType [LocVar l1] [tyvar_a]) - (LocVar l1) tyvar_a)) - , LocAbs [l1] - (TypeAbs [a] - (Abs [(x,ConType refType [LocVar l1] [tyvar_a],LocVar l1)] - (Prim PrimRefReadOp [LocVar l1] [tyvar_a] [Var x]))) - ), - - --- (:=) : {l1}. [a]. Ref {l1} [a] -l1-> a -l1-> Unit --- = {l1}. [a]. --- \addr: Ref {l1} [a] @l1. newv: a @l1. primWrite {l1} [a] addr newv - - - let l1 = "l1" - a = "a" - tyvar_a = TypeVarType a - x = "x" - y = "y" - in - ( ":=" - , LocAbsType [l1] - (TypeAbsType [a] - (FunType - (ConType refType [LocVar l1] [tyvar_a]) - (LocVar l1) - (FunType tyvar_a (LocVar l1) unit_type))) - , LocAbs [l1] - (TypeAbs [a] - (Abs [(x,ConType refType [LocVar l1] [tyvar_a],LocVar l1)] - (Abs [(y,tyvar_a,LocVar l1)] - (Prim PrimRefWriteOp [LocVar l1] [tyvar_a] [Var x, Var y])))) - ) - ] diff --git a/app/polyrpc/ast/Expr.hs b/app/polyrpc/ast/Expr.hs deleted file mode 100644 --- a/app/polyrpc/ast/Expr.hs +++ /dev/null @@ -1,349 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} - -module Expr(Expr(..), AST(..), BindingDecl(..), DataTypeDecl(..) - , initEnv - , TopLevelDecl(..), TypeConDecl(..), Alternative(..) - , TypeInfo, ConTypeInfo, BindingTypeInfo, DataTypeInfo - , GlobalTypeInfo(..), Env(..) - , lookupConstr, lookupCon, lookupDataTypeName, lookupPrimOpType - , mainName, primOpTypes - , singleTypeAbs, singleLocAbs, singleAbs - , singleTypeApp, singleLocApp - , toASTExprSeq, toASTExpr - , toASTIdSeq, toASTId - , toASTTypeSeq, toASTType - , toASTLocationSeq, toASTLocation - , toASTBindingDeclSeq, toASTBindingDecl - , toASTDataTypeDecl, toASTTopLevelDeclSeq - , toASTTypeConDeclSeq, toASTTypeConDecl - , toASTIdTypeLocSeq, toASTIdTypeLoc - , toASTAlternativeSeq, toASTAlternative - , toASTTriple, toASTLit - ) where - -import Location -import Prim -import Literal -import Type --- For aeson --- import GHC.Generics --- import Data.Aeson -import Text.JSON.Generic - --- -data Expr = - Var String - | TypeAbs [String] Expr - | LocAbs [String] Expr - | Abs [(String, Type, Location)] Expr - | Let [BindingDecl] Expr - | Case Expr (Maybe Type) [Alternative] - | App Expr (Maybe Type) Expr (Maybe Location) - | TypeApp Expr (Maybe Type) [Type] - | LocApp Expr (Maybe Type) [Location] - | Tuple [Expr] - | Prim PrimOp [Location] [Type] [Expr] - | Lit Literal - | Constr String [Location] [Type] [Expr] [Type] --- For aeson --- deriving (Show, Generic) - deriving (Show, Typeable, Data) - --- -lookupDataTypeName gti x = [info | (y,info) <- _dataTypeInfo gti, x==y] - -lookupCon tycondecls con = - [tys | (conname, tys) <- tycondecls, con==conname] - - --- -singleTypeAbs (TypeAbs [] expr) = expr -singleTypeAbs (TypeAbs [a] expr) = TypeAbs [a] expr -singleTypeAbs (TypeAbs (a:as) expr) = TypeAbs [a] (singleTypeAbs (TypeAbs as expr)) -singleTypeAbs other = other - -singleLocAbs (LocAbs [] expr) = expr -singleLocAbs (LocAbs [l] expr) = LocAbs [l] expr -singleLocAbs (LocAbs (l:ls) expr) = LocAbs [l] (singleLocAbs (LocAbs ls expr)) -singleLocAbs other = other - -singleAbs (Abs [] expr) = expr -singleAbs (Abs [t] expr) = Abs [t] expr -singleAbs (Abs (t:ts) expr) = Abs [t] (singleAbs (Abs ts expr)) -singleAbs other = other - -singleTypeApp (TypeApp expr maybe []) = expr -singleTypeApp (TypeApp expr maybe [ty]) = TypeApp expr maybe [ty] -singleTypeApp (TypeApp expr maybe (ty:tys)) = - singleTypeApp - (TypeApp - (TypeApp expr maybe [ty]) (skimTypeAbsType maybe) tys) -singleTypeApp other = other - -skimTypeAbsType Nothing = Nothing -skimTypeAbsType (Just (TypeAbsType (tyvar:tyvars) ty)) = Just (TypeAbsType tyvars ty) -skimTypeAbsType maybe = error $ "[skimTypeAbsType]: " ++ show maybe - -singleLocApp (LocApp expr maybe []) = expr -singleLocApp (LocApp expr maybe [l]) = LocApp expr maybe [l] -singleLocApp (LocApp expr maybe (l:ls)) = - singleLocApp - (LocApp (LocApp expr maybe [l]) (skimLocAbsType maybe) ls) -singleLocApp other = other - -skimLocAbsType Nothing = Nothing -skimLocAbsType (Just (LocAbsType (locvar:locvars) ty)) = Just (LocAbsType locvars ty) -skimLocAbsType maybe = error $ "[skimLocAbsType]: " ++ show maybe - -data BindingDecl = - Binding String Type Expr --- For aeson --- deriving (Show, Generic) - deriving (Show, Typeable, Data) - --- --- The four forms of data type declarations supported now. --- --- data D = C1 | ... | Cn --- data D = [a1 ... ak] . C1 | ... | Cn --- data D = {l1 ... li} . C1 | ... | Cn --- data D = {l1 ... li} . [a1 ... ak] . C1 | ... | Cn --- -data DataTypeDecl = - DataType String [LocationVar] [TypeVar] [TypeConDecl] -- - deriving (Show, Typeable, Data) - -data TopLevelDecl = - BindingTopLevel BindingDecl - | DataTypeTopLevel DataTypeDecl - | LibDeclTopLevel String Type - deriving (Show, Typeable, Data) - -data TypeConDecl = - TypeCon String [Type] - deriving (Show, Typeable, Data) - -data Alternative = - Alternative String [String] Expr - | TupleAlternative [String] Expr - deriving (Show, Typeable, Data) - --- --- For aeson --- instance ToJSON Expr where --- instance ToJSON Literal where --- instance ToJSON PrimOp where --- instance ToJSON BindingDecl where --- instance ToJSON DataTypeDecl where --- instance ToJSON TopLevelDecl where --- instance ToJSON TypeConDecl where --- instance ToJSON Alternative where - --- --- For type-checker - --- [(Name, Location Vars, Type Vars)] -type TypeInfo = [(String, [String], [String])] - --- [(ConName, (ConArgTypes, DTName, LocationVars, TypeVars))] -type ConTypeInfo = [(String, ([Type], String, [String], [String]))] - -lookupConstr :: GlobalTypeInfo -> String -> [([Type], String, [String], [String])] -lookupConstr gti x = [z | (con, z) <- _conTypeInfo gti, x==con] - - -type BindingTypeInfo = [(String, Type)] - --- [ (DTName, LocationVars, TypeVars, [(ConName, ArgTypes)]) ] -type DataTypeInfo = [(String, ([String], [String], [(String,[Type])]))] - -data GlobalTypeInfo = GlobalTypeInfo - { _typeInfo :: TypeInfo - , _conTypeInfo :: ConTypeInfo - , _dataTypeInfo :: DataTypeInfo - , _bindingTypeInfo :: BindingTypeInfo } - deriving (Show, Typeable, Data) - -data Env = Env - { _locVarEnv :: [String] - , _typeVarEnv :: [String] - , _varEnv :: BindingTypeInfo } - -initEnv = Env { _locVarEnv=[], _typeVarEnv=[], _varEnv=[] } - --- -data AST = - ASTExprSeq { fromASTExprSeq :: [Expr] } - | ASTExpr { fromASTExpr :: Expr } - | ASTIdSeq { fromASTIdSeq :: [String] } - | ASTId { fromASTId :: String } - | ASTTypeSeq { fromASTTypeSeq :: [Type] } - | ASTType { fromASTType :: Type } - | ASTLocationSeq { fromASTLocationSeq :: [Location] } - | ASTLocation { fromASTLocation :: Location } - - | ASTBindingDeclSeq { fromASTBindingDeclSeq :: [BindingDecl] } - | ASTBindingDecl { fromASTBindingDecl :: BindingDecl } - - | ASTDataTypeDecl { fromASTDataTypeDecl :: DataTypeDecl } - - | ASTTopLevelDeclSeq { fromASTTopLevelDeclSeq :: [TopLevelDecl] } - - | ASTTypeConDeclSeq { fromASTTypeConDeclSeq :: [TypeConDecl] } - | ASTTypeConDecl { fromASTTypeConDecl :: TypeConDecl } - - | ASTIdTypeLocSeq { fromASTIdTypeLocSeq :: [(String,Type,Location)] } - | ASTIdTypeLoc { fromASTIdTypeLoc :: (String,Type,Location) } - - | ASTAlternativeSeq { fromASTAlternativeSeq :: [Alternative] } - | ASTAlternative { fromASTAlternative :: Alternative } - - | ASTLit { fromASTLit :: Literal } - - | ASTTriple { fromASTTriple :: ([String], [String], [TypeConDecl]) } - -instance Show AST where - showsPrec p _ = (++) "AST ..." - -toASTExprSeq exprs = ASTExprSeq exprs -toASTExpr expr = ASTExpr expr -toASTIdSeq ids = ASTIdSeq ids -toASTId id = ASTId id -toASTTypeSeq types = ASTTypeSeq types -toASTType ty = ASTType ty -toASTLocationSeq locations = ASTLocationSeq locations -toASTLocation location = ASTLocation location - -toASTBindingDeclSeq bindings = ASTBindingDeclSeq bindings -toASTBindingDecl binding = ASTBindingDecl binding - -toASTDataTypeDecl datatype = ASTDataTypeDecl datatype - -toASTTopLevelDeclSeq toplevel = ASTTopLevelDeclSeq toplevel - -toASTTypeConDeclSeq typecondecls = ASTTypeConDeclSeq typecondecls -toASTTypeConDecl typecondecl = ASTTypeConDecl typecondecl - -toASTIdTypeLocSeq idtypelocs = ASTIdTypeLocSeq idtypelocs -toASTIdTypeLoc idtypeloc = ASTIdTypeLoc idtypeloc - -toASTAlternativeSeq alts = ASTAlternativeSeq alts -toASTAlternative alt = ASTAlternative alt - -toASTTriple triple = ASTTriple triple - -toASTLit lit = ASTLit lit - --- -mainName = "main" - --- -primOpTypes :: [(PrimOp, ([String], [String], [Type], Type))] -- (locvars, tyvars, argtys, retty) -primOpTypes = - [ - - ----------------------------------------------------------------------------------- - -- [Note] Primitives that the typechecker provide locations as the current location - ----------------------------------------------------------------------------------- - - (NotPrimOp, (["l"], [], [bool_type], bool_type)) - , (OrPrimOp, (["l"], [], [bool_type, bool_type], bool_type)) - , (AndPrimOp, (["l"], [], [bool_type, bool_type], bool_type)) - , (EqPrimOp, (["l"], [], [bool_type, bool_type], bool_type)) - , (NeqPrimOp, (["l"], [], [bool_type, bool_type], bool_type)) - , (LtPrimOp, (["l"], [], [int_type, int_type], bool_type)) - , (LePrimOp, (["l"], [], [int_type, int_type], bool_type)) - , (GtPrimOp, (["l"], [], [int_type, int_type], bool_type)) - , (GePrimOp, (["l"], [], [int_type, int_type], bool_type)) - , (AddPrimOp, (["l"], [], [int_type, int_type], int_type)) - , (SubPrimOp, (["l"], [], [int_type, int_type], int_type)) - , (MulPrimOp, (["l"], [], [int_type, int_type], int_type)) - , (DivPrimOp, (["l"], [], [int_type, int_type], int_type)) - , (NegPrimOp, (["l"], [], [int_type], int_type)) - - , (PrimReadOp, (["l"], [], [unit_type], string_type)) - , (PrimPrintOp, (["l"], [], [string_type], unit_type)) - , (PrimIntToStringOp, (["l"], [], [int_type], string_type)) - , (PrimConcatOp, (["l"], [], [string_type,string_type], string_type)) - - ----------------------------------------------------------------------------------- - -- [Note] Primitives that programmers provide locations - ----------------------------------------------------------------------------------- - - , (PrimRefCreateOp, - let l1 = "l1" in - let a = "a" in - let tyvar_a = TypeVarType a in - let locvar_l1 = LocVar l1 in - ([l1], [a], [tyvar_a], ConType refType [locvar_l1] [tyvar_a])) - - , (PrimRefReadOp, - let l1 = "l1" in - let a = "a" in - let tyvar_a = TypeVarType a in - let locvar_l1 = LocVar l1 in - ([l1], [a], [ConType refType [locvar_l1] [tyvar_a]], tyvar_a)) - - , (PrimRefWriteOp, - let l1 = "l1" in - let a = "a" in - let tyvar_a = TypeVarType a in - let locvar_l1 = LocVar l1 in - ([l1], [a], [ConType refType [locvar_l1] [tyvar_a], tyvar_a], unit_type)) - ] - -lookupPrimOpType primop = - [ (locvars, tyvars, tys,ty) - | (primop1,(locvars, tyvars, tys,ty)) <- primOpTypes, primop==primop1] - --- -recursive = "$rec" - - -isRecName :: String -> Bool - -isRecName name = reverse (take 4 (reverse name)) == recursive - - -isRec :: String -> Expr -> Bool - -isRec name (Var x) = name==x - -isRec name (TypeAbs tyvars expr) = isRec name expr - -isRec name (LocAbs locvars expr) = isRec name expr - -isRec name (Abs xTyLocs expr) = - let (xs,tys,locs) = unzip3 xTyLocs in - if name `elem` xs then False - else isRec name expr - -isRec name (Let bindingDecls expr) = - let xTyExprs = [(x,ty,expr) | Binding x ty expr<-bindingDecls] - (xs,tys, exprs) = unzip3 xTyExprs - in - if name `elem` xs then False - else or (isRec name expr : map (isRec name) exprs) - -isRec name (Case expr casety [TupleAlternative xs alt_expr]) = - isRec name expr || if name `elem` xs then False else isRec name alt_expr - -isRec name (Case expr casety alts) = - isRec name expr - || or (map (\(Alternative cname xs alt_expr) -> - if name `elem` xs then False else isRec name alt_expr) alts) - -isRec name (App expr maybefunty arg maybloc) = isRec name expr || isRec name arg - -isRec name (TypeApp expr maybefunty tys) = isRec name expr - -isRec name (LocApp expr maybefunty locs) = isRec name expr - -isRec name (Tuple exprs) = or (map (isRec name) exprs) - -isRec name (Prim op locs tys exprs) = or (map (isRec name) exprs) - -isRec name (Lit lit) = False - -isRec name (Constr cname locs tys exprs argtys) = or (map (isRec name) exprs) - diff --git a/app/polyrpc/ast/Literal.hs b/app/polyrpc/ast/Literal.hs deleted file mode 100644 --- a/app/polyrpc/ast/Literal.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} - -module Literal where - -import Type -import Text.JSON.Generic - -data Literal = - IntLit Int - | StrLit String - | BoolLit Bool - | UnitLit --- For aeson --- deriving (Show, Generic) - deriving (Eq, Show, Typeable, Data) - -typeOfLiteral (IntLit _) = int_type -typeOfLiteral (StrLit _) = string_type -typeOfLiteral (BoolLit _) = bool_type -typeOfLiteral (UnitLit) = unit_type - -trueLit = "True" -falseLit = "False" -unitLit = "()" - diff --git a/app/polyrpc/ast/Location.hs b/app/polyrpc/ast/Location.hs deleted file mode 100644 --- a/app/polyrpc/ast/Location.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} - -module Location where - -import Text.JSON.Generic - -data Location = - Location String - | LocVar LocationVar - deriving (Eq, Show, Typeable, Data) - -equalLoc (Location x) (Location y) = x==y -equalLoc (LocVar x) (LocVar y) = x==y -equalLoc _ _ = False - -equalLocs [] [] = True -equalLocs (l1:locs1) (l2:locs2) = equalLoc l1 l2 && equalLocs locs1 locs2 -equalLocs _ _ = False - -type LocationVar = String - --- unifyLocations [] [] = Just [] --- unifyLocations (loc1:locs1) (loc2:locs2) = --- case unifyLocation loc1 loc2 of --- Nothing -> Nothing --- Just subst1 -> --- case unifyLocations (map (doSubst subst1) locs1) (map (doSubst subst1) locs2) of --- Nothing -> Nothing --- Just subst2 -> Just (subst1 ++ subst2) - --- unifyLocation (Location s1) (Location s2) = --- if s1==s2 then Just [] else Nothing --- unifyLocation (Location s) (LocVar x) = Just [(x, Location s)] --- unifyLocation (LocVar x) (Location s) = Just [(x, Location s)] --- unifyLocation (LocVar x) (LocVar y) = --- if ==y then Just [] else Just [(x, LocVary)] - --- Predefined location names -clientLoc = Location clientLocName -serverLoc = Location serverLocName - -clientLocName = "client" -serverLocName = "server" - -isClient (Location str) = str == clientLocName -isClient _ = False - -isServer (Location str) = str == serverLocName -isServer _ = False - - --- -doSubstLocOverLoc :: String -> Location -> Location -> Location - -doSubstLocOverLoc x loc (Location name) = Location name -doSubstLocOverLoc x loc (LocVar y) - | x == y = loc - | otherwise = LocVar y - - -doSubstLocOverLocs [] loc0 = loc0 -doSubstLocOverLocs ((x,loc):substLoc) loc0 = - doSubstLocOverLocs substLoc (doSubstLocOverLoc x loc loc0) - diff --git a/app/polyrpc/ast/Prim.hs b/app/polyrpc/ast/Prim.hs deleted file mode 100644 --- a/app/polyrpc/ast/Prim.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} - -module Prim where - -import Text.JSON.Generic - -data PrimOp = - NotPrimOp --{l}. Bool -l-> Bool - | OrPrimOp --{l}. (Bool, Bool) -l-> Bool - | AndPrimOp --{l}. (Bool, Bool) -l-> Bool - | EqPrimOp --{l}. (Int, Int) -l-> Bool - | NeqPrimOp --{l}. (Int, Int) -l-> Bool - | LtPrimOp --{l}. (Int, Int) -l-> Bool - | LePrimOp --{l}. (Int, Int) -l-> Bool - | GtPrimOp --{l}. (Int, Int) -l-> Bool - | GePrimOp --{l}. (Int, Int) -l-> Bool - | AddPrimOp --{l}. (Int, Int) -l-> Int - | SubPrimOp --{l}. (Int, Int) -l-> Int - | MulPrimOp --{l}. (Int, Int) -l-> Int - | DivPrimOp --{l}. (Int, Int) -l-> Int - | NegPrimOp --{l}. Int -l-> Int - - -- For basic libraries - | PrimReadOp - | PrimPrintOp - | PrimIntToStringOp - | PrimConcatOp - | PrimRefCreateOp - | PrimRefReadOp - | PrimRefWriteOp - - -- For creating recursive closures - | MkRecOp -- MkRecOp closure f --- For aeson --- deriving (Show, Eq, Generic) - deriving (Show, Eq, Typeable, Data) - --- Predefined type names -unitType = "Unit" -intType = "Int" -boolType = "Bool" -stringType = "String" -refType = "Ref" - - diff --git a/app/polyrpc/ast/Type.hs b/app/polyrpc/ast/Type.hs deleted file mode 100644 --- a/app/polyrpc/ast/Type.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} - -module Type where - -import Prim -import Data.Char --- For aeson --- import GHC.Generics --- import Data.Aeson -import Text.JSON.Generic - -import Location - -data Type = - TypeVarType TypeVar - | TupleType [Type] - | FunType Type Location Type - | TypeAbsType [TypeVar] Type - | LocAbsType [LocationVar] Type - | ConType String [Location] [Type] - deriving (Show, Typeable, Data) - -type TypeVar = String - -singleTypeAbsType (TypeAbsType [] expr) = expr -singleTypeAbsType (TypeAbsType [a] expr) = TypeAbsType [a] expr -singleTypeAbsType (TypeAbsType (a:as) expr) = TypeAbsType [a] (singleTypeAbsType (TypeAbsType as expr)) -singleTypeAbsType other = other - -singleLocAbsType (LocAbsType [] expr) = expr -singleLocAbsType (LocAbsType [a] expr) = LocAbsType [a] expr -singleLocAbsType (LocAbsType (a:as) expr) = LocAbsType [a] (singleLocAbsType (LocAbsType as expr)) -singleLocAbsType other = other - - --- --- For aeson --- instance ToJSON Location where --- instance ToJSON Type where - --- Names -isTypeName (c:s) = isUpper c -isTypeName _ = False - -isTypeVarName (c:s) = isLower c -isTypeVarName _ = False - -isLocationVarName (c:s) = isLower c -isLocationVarName _ = False - -isBindingName (c:s) = isLower c -isBindingName _ = False - -isConstructorName (c:s) = isUpper c -isConstructorName _ = False - - --- -primType tyname = ConType tyname [] [] - -bool_type = primType boolType -int_type = primType intType -unit_type = primType unitType -string_type = primType stringType - - --- -doSubstOne :: String -> Type -> Type -> Type -doSubstOne x ty (TypeVarType y) - | x==y = ty - | otherwise = (TypeVarType y) -doSubstOne x ty (TupleType tys) = - TupleType (map (doSubstOne x ty) tys) -doSubstOne x ty (FunType argty loc retty) = - FunType (doSubstOne x ty argty) loc (doSubstOne x ty retty) -doSubstOne x ty (TypeAbsType tyvars bodyty) - | elem x tyvars = (TypeAbsType tyvars bodyty) - | otherwise = (TypeAbsType tyvars (doSubstOne x ty bodyty)) -doSubstOne x ty (LocAbsType locvars bodyty) = - LocAbsType locvars (doSubstOne x ty bodyty) -doSubstOne x ty (ConType name locs tys) = - ConType name locs (map (doSubstOne x ty) tys) - -doSubst :: [(String,Type)] -> Type -> Type -doSubst [] ty0 = ty0 -doSubst ((x,ty):subst) ty0 = - doSubst subst (doSubstOne x ty ty0) - --- -doSubstLocOne :: String -> Location -> Type -> Type -doSubstLocOne x loc (TypeVarType y) = (TypeVarType y) -doSubstLocOne x loc (TupleType tys) = - TupleType (map (doSubstLocOne x loc) tys) -doSubstLocOne x loc (FunType argty loc0 retty) = - FunType (doSubstLocOne x loc argty) - (doSubstLocOverLoc x loc loc0) (doSubstLocOne x loc retty) -doSubstLocOne x loc (TypeAbsType tyvars bodyty) = - TypeAbsType tyvars (doSubstLocOne x loc bodyty) -doSubstLocOne x loc (LocAbsType locvars bodyty) - | elem x locvars = LocAbsType locvars bodyty - | otherwise = LocAbsType locvars (doSubstLocOne x loc bodyty) -doSubstLocOne x loc (ConType name locs tys) = - ConType name (map (doSubstLocOverLoc x loc) locs) (map (doSubstLocOne x loc) tys) - - -doSubstLoc :: [(String, Location)] -> Type -> Type -doSubstLoc [] ty = ty -doSubstLoc ((x,loc):substLoc) ty = - doSubstLoc substLoc (doSubstLocOne x loc ty) - --- -equalType :: Type -> Type -> Bool -equalType ty1 ty2 = equalTypeWithFreshness [1..] ty1 ty2 - -equalTypeWithFreshness ns (TypeVarType x) (TypeVarType y) = x==y - -equalTypeWithFreshness ns (TupleType tys1) (TupleType tys2) = - and (map (uncurry (equalTypeWithFreshness ns)) (zip tys1 tys2)) - -equalTypeWithFreshness ns (FunType argty1 loc1 retty1) (FunType argty2 loc2 retty2) = - equalTypeWithFreshness ns argty1 argty2 && equalLoc loc1 loc2 && equalTypeWithFreshness ns retty1 retty2 - -equalTypeWithFreshness ns (TypeAbsType tyvars1 ty1) (TypeAbsType tyvars2 ty2) = - let len1 = length tyvars1 - len2 = length tyvars2 - newvars = map (TypeVarType . show) (take len1 ns) - ns' = drop len1 ns - in len1==len2 && equalTypeWithFreshness ns' (doSubst (zip tyvars1 newvars) ty1) (doSubst (zip tyvars2 newvars) ty2) - -equalTypeWithFreshness ns (LocAbsType locvars1 ty1) (LocAbsType locvars2 ty2) = - let len1 = length locvars1 - len2 = length locvars2 - newvars = map (LocVar . show) (take len1 ns) - ns' = drop len1 ns - in len1==len2 && equalTypeWithFreshness ns' (doSubstLoc (zip locvars1 newvars) ty1) (doSubstLoc (zip locvars2 newvars) ty2) - -equalTypeWithFreshness ns (ConType name1 locs1 tys1) (ConType name2 locs2 tys2) = - name1==name2 && equalLocs locs1 locs2 && and (map (uncurry (equalTypeWithFreshness ns)) (zip tys1 tys2)) - -equalTypeWithFreshness ns ty1 ty2 = False - --- -occur :: String -> Type -> Bool -occur x (TypeVarType y) = x==y -occur x (TupleType tys) = and (map (occur x) tys) -occur x (FunType argty loc retty) = occur x argty && occur x retty -occur x (ConType c locs tys) = and (map (occur x) tys) -occur x (TypeAbsType _ _) = False -- ??? -occur x (LocAbsType _ _) = False -- ??? - -unifyTypeOne :: Type -> Type -> Maybe [(String,Type)] -unifyTypeOne (TypeVarType x) (TypeVarType y) - | x==y = Just [] - | otherwise = Just [(x, TypeVarType y)] - -unifyTypeOne (TypeVarType x) ty - | occur x ty = Nothing - | otherwise = Just [(x,ty)] - -unifyTypeOne ty (TypeVarType x) - | occur x ty = Nothing - | otherwise = Just [(x,ty)] - -unifyTypeOne (TupleType tys1) (TupleType tys2) = unifyTypes tys1 tys2 - -unifyTypeOne (FunType argty1 loc1 retty1) (FunType argty2 loc2 retty2) = -- loc1 and loc2 ?? - case unifyTypeOne argty1 argty2 of - Nothing -> Nothing - Just subst1 -> - case unifyTypeOne (doSubst subst1 retty1) (doSubst subst1 retty2) of - Nothing -> Nothing - Just subst2 -> Just (subst1 ++ subst2) - -unifyTypeOne (ConType c1 locs1 tys1) (ConType c2 locs2 tys2) -- locs1, locs2 ??? - | c1==c2 = unifyTypes tys1 tys2 - | otherwise = Nothing - -unifyTypeOne _ _ = Nothing -- universal types and locations ??? - -unifyTypes :: [Type] -> [Type] -> Maybe [(String,Type)] -unifyTypes [] [] = Just [] -unifyTypes (ty1:tys1) (ty2:tys2) = - case unifyTypeOne ty1 ty2 of - Nothing -> Nothing - Just subst1 -> - case unifyTypes (map (doSubst subst1) tys1) (map (doSubst subst1) tys2) of - Nothing -> Nothing - Just subst2 -> Just (subst1 ++ subst2) - diff --git a/app/polyrpc/cs/CSExpr.hs b/app/polyrpc/cs/CSExpr.hs deleted file mode 100644 --- a/app/polyrpc/cs/CSExpr.hs +++ /dev/null @@ -1,258 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} - -module CSExpr where - -import qualified Data.Set as Set - -import Location -import Prim -import Literal -import CSType -import qualified Expr as SE -import Text.JSON.Generic - -data Expr = - ValExpr Value - | Let [BindingDecl] Expr - | Case Value Type [Alternative] -- including pi_i (V) - | App Value Type Value - | TypeApp Value Type [Type] - | LocApp Value Type [Location] - | Prim PrimOp [Location] [Type] [Value] - deriving (Show, Typeable, Data) - -data Value = - Var String - | Lit Literal - | Tuple [Value] - | Constr String [Location] [Type] [Value] [Type] - | Closure [Value] [Type] CodeName [String] -- [] or [rec_f] for now, [rec_f1, ...,, rec_fk] in future - | UnitM Value - | BindM [BindingDecl] Expr - | Req Value Type Value - | Call Value Type Value - | GenApp Location Value Type Value - - -- Runtime values - | Addr Integer - deriving (Show, Typeable, Data) - -data BindingDecl = - Binding String Type Expr - deriving (Show, Typeable, Data) - -data DataTypeDecl = - DataType String [String] [TypeConDecl] --- For aeson --- deriving (Show, Generic) - deriving (Show, Typeable, Data) - -data TopLevelDecl = - BindingTopLevel BindingDecl - | DataTypeTopLevel DataTypeDecl - | LibDeclTopLevel String Type --- For aeson --- deriving (Show, Generic) - deriving (Show, Typeable, Data) - -data TypeConDecl = - TypeCon String [Type] --- For aeson --- deriving (Show, Generic) - deriving (Show, Typeable, Data) - -data Alternative = - Alternative String [String] Expr - | TupleAlternative [String] Expr - deriving (Show, Typeable, Data) - -data Code = - Code [String] [String] [String] OpenCode -- [loc]. [alpha]. [x]. OpenCode - deriving (Show, Typeable, Data) - -data OpenCode = - CodeAbs [(String, Type)] Expr - | CodeTypeAbs [String] Expr - | CodeLocAbs [String] Expr - deriving (Show, Typeable, Data) - - -data CodeName = - CodeName String [Location] [Type] - deriving (Show, Typeable, Data) - --- --- [(Name, Location Vars, Type Vars)] -type TypeInfo = [(String, [String], [String])] - --- [(ConName, (ConArgTypes, DTName, LocationVars, TypeVars))] -type ConTypeInfo = [(String, ([Type], String, [String], [String]))] - -type BindingTypeInfo = [(String, Type)] - --- [ (DTName, LocationVars, TypeVars, [(ConName, ArgTypes)]) ] -type DataTypeInfo = [(String, ([String], [String], [(String,[Type])]))] - -type LibInfo = [(String, Type)] - -data GlobalTypeInfo = GlobalTypeInfo - { _typeInfo :: TypeInfo - , _conTypeInfo :: ConTypeInfo - , _dataTypeInfo :: DataTypeInfo - , _libInfo :: LibInfo } -- library types - deriving (Show, Typeable, Data) - -data Env = Env - { _locVarEnv :: [String] - , _typeVarEnv :: [String] - , _varEnv :: BindingTypeInfo } - -initEnv = Env { _locVarEnv=[], _typeVarEnv=[], _varEnv=[] } - --- -data FunctionStore = FunctionStore - { _clientstore :: [(String, (CodeType, Code))] - , _serverstore :: [(String, (CodeType, Code))] - , _new :: Int - } - deriving (Show, Typeable, Data) - -addClientFun :: FunctionStore -> String -> CodeType -> Code -> FunctionStore -addClientFun fnstore name ty code = - fnstore {_clientstore = _clientstore fnstore ++ [(name,(ty,code))] } - -addServerFun :: FunctionStore -> String -> CodeType -> Code -> FunctionStore -addServerFun fnstore name ty code = - fnstore {_serverstore = (_serverstore fnstore) ++ [(name,(ty,code))] } - -addFun :: Location -> FunctionStore -> String -> CodeType -> Code -> FunctionStore -addFun loc funstore name ty@(CodeType [] [] fvtys (FunType _ funloc _)) code = - if isClient funloc then addClientFun funstore name ty code - else if isServer funloc then addServerFun funstore name ty code - else addServerFun (addClientFun funstore name ty code) name ty code -addFun loc funstore name ty@(CodeType [] [] fvtys somety) code = - addServerFun (addClientFun funstore name ty code) name ty code -addFun loc funstore name ty@(CodeType locvars tyvars fvtys somety) code = - addServerFun (addClientFun funstore name ty code) name ty code - -newName :: FunctionStore -> (String, FunctionStore) -newName fnstore = let n = _new fnstore in ("f" ++ show n, fnstore{_new =n+1}) - -newVar :: FunctionStore -> (String, FunctionStore) -newVar fnstore = let n = _new fnstore in ("x" ++ show n, fnstore{_new =n+1}) - -newVars :: Int -> FunctionStore -> ([String], FunctionStore) -newVars 0 funStore = ([], funStore) -newVars n funStore = - let (x, funStore1) = newVar funStore - (xs, funStore2) = newVars (n-1) funStore1 - in (x:xs, funStore2) - -initFunctionStore = FunctionStore - { _clientstore=[] - , _serverstore=[] - , _new = 1 - } - --- --- -primOpTypes :: [(PrimOp, ([String], [String], [Type], Type))] -- (locvars, tyvars, argtys, retty) -primOpTypes = - [ (NotPrimOp, (["l"], [], [bool_type], bool_type)) - , (OrPrimOp, (["l"], [], [bool_type, bool_type], bool_type)) - , (AndPrimOp, (["l"], [], [bool_type, bool_type], bool_type)) - , (EqPrimOp, (["l"], [], [bool_type, bool_type], bool_type)) - , (NeqPrimOp, (["l"], [], [bool_type, bool_type], bool_type)) - , (LtPrimOp, (["l"], [], [int_type, int_type], bool_type)) - , (LePrimOp, (["l"], [], [int_type, int_type], bool_type)) - , (GtPrimOp, (["l"], [], [int_type, int_type], bool_type)) - , (GePrimOp, (["l"], [], [int_type, int_type], bool_type)) - , (AddPrimOp, (["l"], [], [int_type, int_type], int_type)) - , (SubPrimOp, (["l"], [], [int_type, int_type], int_type)) - , (MulPrimOp, (["l"], [], [int_type, int_type], int_type)) - , (DivPrimOp, (["l"], [], [int_type, int_type], int_type)) - , (NegPrimOp, (["l"], [], [int_type], int_type)) - - , (PrimReadOp, (["l"], [], [unit_type], string_type)) - , (PrimPrintOp, (["l"], [], [string_type], unit_type)) - , (PrimIntToStringOp, (["l"], [], [int_type], string_type)) - , (PrimConcatOp, (["l"], [], [string_type,string_type], string_type)) - - , (PrimRefCreateOp, - let l1 = "l1" in - let a = "a" in - let tyvar_a = TypeVarType a in - let locvar_l1 = LocVar l1 in - ([l1], [a], [tyvar_a], ConType refType [locvar_l1] [tyvar_a])) - - , (PrimRefReadOp, - let l1 = "l1" in - let a = "a" in - let tyvar_a = TypeVarType a in - let locvar_l1 = LocVar l1 in - ([l1], [a], [ConType refType [locvar_l1] [tyvar_a]], tyvar_a)) - - , (PrimRefWriteOp, - let l1 = "l1" in - let a = "a" in - let tyvar_a = TypeVarType a in - let locvar_l1 = LocVar l1 in - ([l1], [a], [ConType refType [locvar_l1] [tyvar_a], tyvar_a], unit_type)) - - ] - -lookupPrimOpType primop = - [ (locvars,tyvars,tys,ty) - | (primop1,(locvars, tyvars, tys,ty)) <- primOpTypes, primop==primop1] - -lookupConstr :: GlobalTypeInfo -> String -> [([Type], String, [String], [String])] -lookupConstr gti x = [z | (con, z) <- _conTypeInfo gti, x==con] - ------------------ --- free variables ------------------ - -fvOpenCode :: OpenCode -> Set.Set String - -fvOpenCode (CodeAbs xTys expr) = fvExpr expr `Set.difference` Set.fromList (map fst xTys) -fvOpenCode (CodeTypeAbs tyvars expr) = fvExpr expr -fvOpenCode (CodeLocAbs locvars expr) = fvExpr expr - - -fvExpr :: Expr -> Set.Set String - -fvExpr (ValExpr val) = fvValue val -fvExpr (Let bindingDcl expr) = Set.empty -fvExpr (Case val _ alts) = fvValue val `Set.union` Set.unions (map fvAlt alts) -fvExpr (App left _ right) = fvValue left `Set.union` fvValue right -fvExpr (TypeApp left _ _) = fvValue left -fvExpr (LocApp left _ _) = fvValue left -fvExpr (Prim primop locs tys vs) = Set.unions (map fvValue vs) - - -fvAlt :: Alternative -> Set.Set String - -fvAlt (Alternative cname xs expr) = fvExpr expr `Set.difference` Set.fromList xs -fvAlt (TupleAlternative xs expr) = fvExpr expr `Set.difference` Set.fromList xs - - -fvValue :: Value -> Set.Set String - -fvValue (Var x) = Set.singleton x -fvValue (Lit lit) = Set.empty -fvValue (Tuple vs) = Set.unions (map fvValue vs) -fvValue (Constr cname _ _ vs _) = Set.unions (map fvValue vs) -fvValue (Closure vs _ codename _) = Set.unions (map fvValue vs) -fvValue (UnitM v) = fvValue v -fvValue (BindM bindingDecls expr) = - (Set.unions (map (\(Binding _ _ expr) -> fvExpr expr) bindingDecls) `Set.union` fvExpr expr) - `Set.difference` (Set.fromList (map (\(Binding x _ _) -> x) bindingDecls)) -fvValue (Req left _ right) = fvValue left `Set.union` fvValue right -fvValue (Call left _ right) = fvValue left `Set.union` fvValue right -fvValue (GenApp _ left _ right) = fvValue left `Set.union` fvValue right - - --- -singleBindM (BindM [] expr) = expr -singleBindM (BindM (bind:binds) expr) = - ValExpr $ BindM [bind] (singleBindM (BindM binds expr)) diff --git a/app/polyrpc/cs/CSType.hs b/app/polyrpc/cs/CSType.hs deleted file mode 100644 --- a/app/polyrpc/cs/CSType.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} - -module CSType where - -import Text.JSON.Generic - -import Location -import Prim - -data Type = - TypeVarType String - | TupleType [Type] - | FunType Type Location Type - | TypeAbsType [String] Type - | LocAbsType [String] Type - | ConType String [Location] [Type] - | CloType Type -- Clo A - | MonType Type -- T A - deriving (Show, Typeable, Data) - -data CodeType = - CodeType [String] [String] [Type] Type -- [alpha] [loc]. [type]. Type - deriving (Show, Typeable, Data) - --- -doSubstOne :: String -> Type -> Type -> Type - -doSubstOne x ty (TypeVarType y) - | x==y = ty - | otherwise = (TypeVarType y) -doSubstOne x ty (TupleType tys) = TupleType (map (doSubstOne x ty) tys) -doSubstOne x ty (FunType argty loc retty) = - FunType (doSubstOne x ty argty) loc (doSubstOne x ty retty) -doSubstOne x ty (TypeAbsType tyvars bodyty) - | elem x tyvars = (TypeAbsType tyvars bodyty) - | otherwise = (TypeAbsType tyvars (doSubstOne x ty bodyty)) -doSubstOne x ty (LocAbsType locvars bodyty) = - LocAbsType locvars (doSubstOne x ty bodyty) -doSubstOne x ty (ConType name locs tys) = - ConType name locs (map (doSubstOne x ty) tys) -doSubstOne x ty (CloType innerty) = CloType (doSubstOne x ty innerty) -doSubstOne x ty (MonType valty) = MonType (doSubstOne x ty valty) - -doSubst :: [(String,Type)] -> Type -> Type -doSubst [] ty0 = ty0 -doSubst ((x,ty):subst) ty0 = - doSubst subst (doSubstOne x ty ty0) - --- -doSubstLocOne :: String -> Location -> Type -> Type - -doSubstLocOne x loc (TypeVarType y) = (TypeVarType y) -doSubstLocOne x loc (TupleType tys) = TupleType (map (doSubstLocOne x loc) tys) -doSubstLocOne x loc (FunType argty loc0 retty) = - FunType (doSubstLocOne x loc argty) - (doSubstLocOverLoc x loc loc0) (doSubstLocOne x loc retty) -doSubstLocOne x loc (TypeAbsType tyvars bodyty) = - TypeAbsType tyvars (doSubstLocOne x loc bodyty) -doSubstLocOne x loc (LocAbsType locvars bodyty) - | elem x locvars = LocAbsType locvars bodyty - | otherwise = LocAbsType locvars (doSubstLocOne x loc bodyty) -doSubstLocOne x loc (ConType name locs tys) = - ConType name (map (doSubstLocOverLoc x loc) locs) (map (doSubstLocOne x loc) tys) -doSubstLocOne x loc (CloType innerTy) = CloType (doSubstLocOne x loc innerTy) -doSubstLocOne x loc (MonType valTy) = MonType (doSubstLocOne x loc valTy) - -doSubstLoc :: [(String, Location)] -> Type -> Type -doSubstLoc [] ty = ty -doSubstLoc ((x,loc):substLoc) ty = - doSubstLoc substLoc (doSubstLocOne x loc ty) - --- -equalType :: Type -> Type -> Bool -equalType ty1 ty2 = equalTypeWithFreshness [1..] ty1 ty2 - -equalTypeWithFreshness ns (TypeVarType x) (TypeVarType y) = x==y - -equalTypeWithFreshness ns (TupleType tys1) (TupleType tys2) = - and (map (uncurry (equalTypeWithFreshness ns)) (zip tys1 tys2)) - -equalTypeWithFreshness ns (FunType argty1 loc1 retty1) (FunType argty2 loc2 retty2) = - equalTypeWithFreshness ns argty1 argty2 && equalLoc loc1 loc2 && equalTypeWithFreshness ns retty1 retty2 - -equalTypeWithFreshness ns (TypeAbsType tyvars1 ty1) (TypeAbsType tyvars2 ty2) = - let len1 = length tyvars1 - len2 = length tyvars2 - newvars = map (TypeVarType . show) (take len1 ns) - ns' = drop len1 ns - in len1==len2 && equalTypeWithFreshness ns' (doSubst (zip tyvars1 newvars) ty1) (doSubst (zip tyvars2 newvars) ty2) - -equalTypeWithFreshness ns (LocAbsType locvars1 ty1) (LocAbsType locvars2 ty2) = - let len1 = length locvars1 - len2 = length locvars2 - newvars = map (LocVar . show) (take len1 ns) - ns' = drop len1 ns - in len1==len2 && equalTypeWithFreshness ns' (doSubstLoc (zip locvars1 newvars) ty1) (doSubstLoc (zip locvars2 newvars) ty2) - -equalTypeWithFreshness ns (ConType name1 locs1 tys1) (ConType name2 locs2 tys2) = - name1==name2 && equalLocs locs1 locs2 && and (map (uncurry (equalTypeWithFreshness ns)) (zip tys1 tys2)) - -equalTypeWithFreshness ns (CloType innerTy1) (CloType innerTy2) = - equalTypeWithFreshness ns innerTy1 innerTy2 - -equalTypeWithFreshness ns (MonType valTy1) (MonType valTy2) = - equalTypeWithFreshness ns valTy1 valTy2 - -equalTypeWithFreshness ns ty1 ty2 = False - --- -primType tyname = ConType tyname [] [] - -bool_type = primType boolType -int_type = primType intType -unit_type = primType unitType -string_type = primType stringType diff --git a/app/syntaxcompletion/EmacsServer.hs b/app/syntaxcompletion/EmacsServer.hs deleted file mode 100644 --- a/app/syntaxcompletion/EmacsServer.hs +++ /dev/null @@ -1,59 +0,0 @@ -module EmacsServer where - -import Network.Socket hiding (recv,send) -import Network.Socket.ByteString -import Data.ByteString.Char8 -import Control.Monad -import Control.Exception - -type ComputeCandidate = String -> Int -> IO [String] - -emacsServer :: ComputeCandidate -> IO () -emacsServer f = do - sock <- socket AF_INET Stream defaultProtocol - setSocketOption sock ReuseAddr 1 - bind sock (SockAddrInet 50000 0) - listen sock 5 - acceptLoop f sock `finally` close sock - -acceptLoop :: ComputeCandidate -> Socket -> IO () -acceptLoop computeCand sock = forever $ do - (conn, _) <- accept sock - cursorPos <- getCursorPos conn - print cursorPos - (conn, _) <- accept sock - str <- getSource conn - print str - candidateList <- computeCand str cursorPos - print candidateList - (conn, _) <- accept sock - sendCandidateList conn candidateList - -str2int :: String -> Int -str2int str = read str :: Int - -getCursorPos :: Socket -> IO Int -getCursorPos conn = do - str <- recv conn 64 - return (str2int (unpack str)) - -getSource :: Socket -> IO String -getSource conn = do - str <- recv conn 64 - if Data.ByteString.Char8.length str == 0 then - return (unpack str) - else do - aaa <- getSource conn - return ((unpack str) ++ aaa) - --- computeCand :: String -> Int -> IO [String] --- computeCand str cursorPos = do --- return ["test"] - -sendCandidateList :: Socket -> [String] -> IO () -sendCandidateList conn [] = close conn -sendCandidateList conn (x:xs) = do - _ <- send conn (pack ("\n" ++ x)) - print x - sendCandidateList conn xs - diff --git a/app/syntaxcompletion/Main.hs b/app/syntaxcompletion/Main.hs --- a/app/syntaxcompletion/Main.hs +++ b/app/syntaxcompletion/Main.hs @@ -1,75 +1,29 @@ module Main where -import CommonParserUtil +import CommonParserUtil -import Token import Lexer import Terminal import Parser -import EmacsServer import System.IO -import Data.Typeable +-- for syntax completion +import Token +import Expr +import EmacsServer +import SynCompInterface import Control.Exception main :: IO () main = do emacsServer computeCand - -- text <- readline "Enter text to parse: " - -- doProcess text - --- Computing candidates for syntax completion - -computeCand :: String -> Int -> IO [String] -computeCand str cursorPos = ((do - terminalList <- lexing lexerSpec str - ast <- parsing parserSpec terminalList - putStrLn "successfully parsed" - return ["SuccessfullyParsed"]) - `catch` \e -> - case e :: LexError of - _ -> do - putStrLn "lex error" - return ["LexError"]) - `catch` \e -> - case e :: ParseError Token AST of - NotFoundAction _ state _ actTbl gotoTbl -> do - candidates <- compCandidates [] state actTbl gotoTbl -- return ["candidates"] - putStrLn (show candidates) - return (map candidateToStr candidates) - NotFoundGoto state _ _ actTbl gotoTbl -> do - candidates <- compCandidates [] state actTbl gotoTbl - putStrLn (show candidates) - return (map candidateToStr candidates) - -candidateToStr [] = "" -candidateToStr (TerminalSymbol s:cands) = s ++ candidateToStr cands -candidateToStr (NonterminalSymbol _:cands) = "..." ++ candidateToStr cands - - --- The normal parser -doProcess text = do - putStrLn "Lexing..." - terminalList <- lexing lexerSpec text - mapM_ (putStrLn . terminalToString) terminalList - putStrLn "Parsing..." - exprSeqAst <- parsing parserSpec terminalList - putStrLn "Pretty Printing..." - putStrLn (show exprSeqAst) - - -readline msg = do - putStr msg - hFlush stdout - readline' - -readline' = do - ch <- getChar - if ch == '\n' then - return "" - else - do line <- readline' - return (ch:line) +computeCand :: String -> Bool -> IO [EmacsDataItem] +computeCand programTextUptoCursor isSimpleMode = ((do + terminalList <- lexing lexerSpec programTextUptoCursor + ast <- parsing parserSpec terminalList + successfullyParsed) + `catch` \e -> case e :: LexError of _ -> handleLexError) + `catch` \e -> case e :: ParseError Token AST of _ -> handleParseError isSimpleMode e diff --git a/app/syntaxcompletion/Parser.hs b/app/syntaxcompletion/Parser.hs --- a/app/syntaxcompletion/Parser.hs +++ b/app/syntaxcompletion/Parser.hs @@ -2,9 +2,9 @@ import CommonParserUtil import Token +import Expr -data AST = AST -- We do not build any ASTs!! - deriving (Show) +noAction = \rhs -> () parserSpec :: ParserSpec Token AST parserSpec = ParserSpec @@ -13,25 +13,25 @@ parserSpecList = [ - ("Start' -> Start", \rhs -> get rhs 1), + ("Start' -> Start", noAction), - ("Start -> Exp", \rhs -> get rhs 1), + ("Start -> Exp", noAction), - ("Exp -> AppExp", \rhs -> get rhs 1), + ("Exp -> AppExp", noAction), - ("Exp -> fn identifier => Exp", \rhs -> AST), + ("Exp -> fn identifier => Exp", noAction), - ("AppExp -> AtExp", \rhs -> get rhs 1), + ("AppExp -> AtExp", noAction), - ("AppExp -> AppExp AtExp", \rhs -> AST), + ("AppExp -> AppExp AtExp", noAction), - ("AtExp -> identifier", \rhs -> AST), + ("AtExp -> identifier", noAction), - ("AtExp -> ( Exp )", \rhs -> AST), + ("AtExp -> ( Exp )", noAction), - ("AtExp -> let Dec in Exp end", \rhs -> AST), + ("AtExp -> let Dec in Exp end", noAction), - ("Dec -> val identifier = Exp", \rhs -> AST) + ("Dec -> val identifier = Exp", noAction) ], baseDir = "./", diff --git a/app/syntaxcompletion/ast/Expr.hs b/app/syntaxcompletion/ast/Expr.hs new file mode 100644 --- /dev/null +++ b/app/syntaxcompletion/ast/Expr.hs @@ -0,0 +1,3 @@ +module Expr where + +type AST = () diff --git a/doc/TIPS-TO-WRITE-LALR1-GRAMMAR.txt b/doc/TIPS-TO-WRITE-LALR1-GRAMMAR.txt deleted file mode 100644 --- a/doc/TIPS-TO-WRITE-LALR1-GRAMMAR.txt +++ /dev/null @@ -1,45 +0,0 @@ - - - -LR/LALR 문법 작성하는 요령 - -1. 연산자 우선순위에 따른 생산규칙 작성 방법 - - a) +는 *보다 우선순위가 낮다. - b) +, *는 왼쪽결합을 적용 - - E = E + T - E = T - T = T * F - T = F - F = id - F = num - - -2. 인라이닝으로 reduce/shift conflit 해결 - - a) OptLhs를 inline - - (before) - - Statement -> OptLhs identifier . OptIdentifier ( Exprs ) { Properties } ; - - OptLhs -> - OptLhs -> identifier = - - - (after) - - Statement -> identifier . OptIdentifier ( Exprs ) { Properties } ; - Statement -> identifier = identifier . OptIdentifier ( Exprs ) { Properties } ; - - - - => - - action rule을 중복해서 작성하는 문제가 발생 - 따라서 parser 작성은 위와 같이 하되, inline 옵션을 적용해서 shift/reduce conflict를 - 해결하면서도 action rule을 중복해서 작성하는 문제를 해결 - - - diff --git a/doc/parserinaction.png b/doc/parserinaction.png deleted file mode 100644 Binary files a/doc/parserinaction.png and /dev/null differ diff --git a/doc/parsertoolarchitecture.png b/doc/parsertoolarchitecture.png deleted file mode 100644 Binary files a/doc/parsertoolarchitecture.png and /dev/null differ diff --git a/src/parserlib/CommonParserUtil.hs b/src/parserlib/CommonParserUtil.hs --- a/src/parserlib/CommonParserUtil.hs +++ b/src/parserlib/CommonParserUtil.hs @@ -16,6 +16,15 @@ import AutomatonType import LoadAutomaton +import Data.List (nub) + +import SynCompInterface + +import Prelude hiding (catch) +import System.Directory +import Control.Exception +import System.IO.Error hiding (catch) + -- Lexer Specification type RegExpStr = String type LexFun token = String -> Maybe token @@ -39,7 +48,7 @@ gotoTblFile :: String, -- ex) gototable.txt grammarFile :: String, -- ex) grammar.txt parserSpecFile :: String, -- ex) mygrammar.grm - genparserexe :: String -- ex) yapb-exe + genparserexe :: String -- ex) genlrparse-exe } -- Specification @@ -58,7 +67,7 @@ instance Exception LexError -prLexError (LexError line col text) = do +prLexError (CommonParserUtil.LexError line col text) = do putStr $ "No matching lexer spec at " putStr $ "Line " ++ show line putStr $ "Column " ++ show col @@ -91,7 +100,7 @@ Line -> Column -> LexerSpecList token -> String -> IO (String, String, Maybe token) matchLexSpec line col [] text = do - throw (LexError line col text) + throw (CommonParserUtil.LexError line col text) -- putStr $ "No matching lexer spec at " -- putStr $ "Line " ++ show line -- putStr $ "Column " ++ show col @@ -119,36 +128,38 @@ data ParseError token ast where -- teminal, state, stack actiontbl, gototbl NotFoundAction :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => - (Terminal token) -> Int -> (Stack token ast) -> ActionTable -> GotoTable -> ParseError token ast + (Terminal token) -> Int -> (Stack token ast) -> ActionTable -> GotoTable -> ProdRules -> [Terminal token] -> ParseError token ast -- topState, lhs, stack, actiontbl, gototbl, NotFoundGoto :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => - Int -> String -> (Stack token ast) -> ActionTable -> GotoTable -> ParseError token ast + Int -> String -> (Stack token ast) -> ActionTable -> GotoTable -> ProdRules -> [Terminal token] -> ParseError token ast deriving (Typeable) instance (Show token, Show ast) => Show (ParseError token ast) where - showsPrec p (NotFoundAction terminal state stack _ _) = + showsPrec p (NotFoundAction terminal state stack _ _ _ _) = (++) "NotFoundAction" . (++) (terminalToString terminal) . (++) (show state) -- . (++) (show stack) - showsPrec p (NotFoundGoto topstate lhs stack _ _) = + showsPrec p (NotFoundGoto topstate lhs stack _ _ _ _) = (++) "NotFoundGoto" . (++) (show topstate) . (++) lhs -- . (++) (show stack) instance (TokenInterface token, Typeable token, Show token, Typeable ast, Show ast) => Exception (ParseError token ast) -prParseError (NotFoundAction terminal state stack actiontbl gototbl) = do +prParseError (NotFoundAction terminal state stack actiontbl gototbl prodRules terminalList) = do putStrLn $ ("Not found in the action table: " ++ terminalToString terminal) ++ " : " ++ show (state, tokenTextFromTerminal terminal) + ++ " (" ++ show (length terminalList) ++ ")" ++ "\n" ++ prStack stack ++ "\n" -prParseError (NotFoundGoto topState lhs stack actiontbl gototbl) = do +prParseError (NotFoundGoto topState lhs stack actiontbl gototbl prodRules terminalList) = do putStrLn $ ("Not found in the goto table: ") ++ " : " ++ show (topState,lhs) ++ "\n" + ++ " (" ++ show (length terminalList) ++ ")" ++ prStack stack ++ "\n" -- @@ -160,7 +171,7 @@ -- 2. If the grammar file is written, -- run the following command to generate prod_rules/action_table/goto_table files. - -- stack exec -- genlrparser-exe mygrammar.grm -output prod_rules.txt action_table.txt goto_table.txt + -- stack exec -- yapb-exe mygrammar.grm -output prod_rules.txt action_table.txt goto_table.txt when writtenBool generateAutomaton -- 3. Load automaton files (prod_rules/action_table/goto_table.txt) @@ -168,18 +179,20 @@ loadAutomaton grammarFileName actionTblFileName gotoTblFileName -- 4. Run the automaton - ast <- runAutomaton actionTbl gotoTbl prodRules pFunList terminalList - - -- putStrLn "done." -- It was for the interafce with Java-version RPC calculus interpreter. - - return ast + if null actionTbl || null gotoTbl || null prodRules + then do let hashFile = getHashFileName specFileName + putStrLn $ "Delete " ++ hashFile + removeIfExists hashFile + error $ "Error: Empty automation: please rerun" + else do ast <- runAutomaton actionTbl gotoTbl prodRules pFunList terminalList + -- putStrLn "done." -- It was for the interafce with Java-version RPC calculus interpreter. + return ast where specFileName = parserSpecFile parserSpec grammarFileName = grammarFile parserSpec actionTblFileName = actionTblFile parserSpec gotoTblFileName = gotoTblFile parserSpec - executable = genparserexe parserSpec sSym = startSymbol parserSpec pSpecList = map fst (parserSpecList parserSpec) @@ -188,7 +201,7 @@ generateAutomaton = do exitCode <- rawSystem "stack" [ "exec", "--", - executable, specFileName, "-output", + "yapb-exe", specFileName, "-output", grammarFileName, actionTblFileName, gotoTblFileName ] case exitCode of @@ -197,14 +210,26 @@ actionTblFileName ++ ", " ++ gotoTblFileName ++ ", " ++ grammarFileName); +-- +removeIfExists :: FilePath -> IO () +removeIfExists fileName = removeFile fileName `catch` handleExists + where handleExists e + | isDoesNotExistError e = return () + | otherwise = throwIO e + -- Stack data StkElem token ast = StkState Int | StkTerminal (Terminal token) - | StkNonterminal ast String -- String for printing Nonterminal instead of ast + | StkNonterminal (Maybe ast) String -- String for printing Nonterminal instead of ast +instance TokenInterface token => Eq (StkElem token ast) where + (StkState i) == (StkState j) = i == j + (StkTerminal termi) == (StkTerminal termj) = tokenTextFromTerminal termi == tokenTextFromTerminal termj + (StkNonterminal _ si) == (StkNonterminal _ sj) = si == sj + type Stack token ast = [StkElem token ast] emptyStack = [] @@ -212,7 +237,8 @@ get :: Stack token ast -> Int -> ast get stack i = case stack !! (i-1) of - StkNonterminal ast _ -> ast + StkNonterminal (Just ast) _ -> ast + StkNonterminal Nothing _ -> error $ "get: empty ast in the nonterminal at stack" _ -> error $ "get: out of bound: " ++ show i getText :: Stack token ast -> Int -> String @@ -229,11 +255,13 @@ pop [] = error "Attempt to pop from the empty stack" prStack :: TokenInterface token => Stack token ast -> String -prStack [] = "end" +prStack [] = "STACK END" prStack (StkState i : stack) = "S" ++ show i ++ " : " ++ prStack stack prStack (StkTerminal (Terminal text _ _ token) : stack) = - fromToken token ++ "(" ++ text ++ ")" ++ " : " ++ prStack stack -prStack (StkNonterminal ast str : stack) = str ++ " : " ++ prStack stack + let str_token = fromToken token in + (if str_token == text then str_token else (fromToken token ++ " i.e. " ++ text)) + ++ " : " ++ prStack stack +prStack (StkNonterminal _ str : stack) = str ++ " : " ++ prStack stack -- Utility for Automation currentState :: Stack token ast -> Int @@ -269,15 +297,19 @@ -- Automaton +initState = 0 + +type ParseFunList token ast = [ParseFun token ast] + runAutomaton :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => {- static part -} - ActionTable -> GotoTable -> ProdRules -> [ParseFun token ast] -> + ActionTable -> GotoTable -> ProdRules -> ParseFunList token ast -> {- dynamic part -} [Terminal token] -> {- AST -} IO ast runAutomaton actionTbl gotoTbl prodRules pFunList terminalList = do - let initStack = push (StkState 0) emptyStack + let initStack = push (StkState initState) emptyStack run terminalList initStack where @@ -289,7 +321,7 @@ let action = case lookupActionTable actionTbl state terminal of Just action -> action - Nothing -> throw (NotFoundAction terminal state stack actionTbl gotoTbl) + Nothing -> throw (NotFoundAction terminal state stack actionTbl gotoTbl prodRules terminalList) -- error $ ("Not found in the action table: " -- ++ terminalToString terminal) -- ++ " : " @@ -305,7 +337,8 @@ debug "Accept" case stack !! 1 of - StkNonterminal ast _ -> return ast + StkNonterminal (Just ast) _ -> return ast + StkNonterminal Nothing _ -> fail "Empty ast in the stack nonterminal" _ -> fail "Not Stknontermianl on Accept" Shift toState -> do @@ -332,57 +365,217 @@ let toState = case lookupGotoTable gotoTbl topState lhs of Just state -> state - Nothing -> throw (NotFoundGoto topState lhs stack actionTbl gotoTbl) + Nothing -> throw (NotFoundGoto topState lhs stack actionTbl gotoTbl prodRules terminalList) -- error $ ("Not found in the goto table: ") -- ++ " : " -- ++ show (topState,lhs) ++ "\n" -- ++ prStack stack ++ "\n" - let stack2 = push (StkNonterminal ast lhs) stack1 + let stack2 = push (StkNonterminal (Just ast) lhs) stack1 let stack3 = push (StkState toState) stack2 run terminalList stack3 -flag = False +flag = True debug :: String -> IO () debug msg = if flag then putStrLn msg else return () +prlevel n = take n (let spaces = ' ' : spaces in spaces) + -- data Candidate = TerminalSymbol String | NonterminalSymbol String - deriving Show + deriving (Show,Eq) -compCandidates :: [Candidate] -> Int -> ActionTable -> GotoTable -> IO [[Candidate]] -compCandidates symbols state actTbl gotoTbl = do - putStrLn (show symbols) - case [(lookahead,prnum) | ((s,lookahead),Reduce prnum) <- actTbl, state==s] of - [] -> do let cand1 = [(nonterminal,snext) | ((s,nonterminal),snext) <- gotoTbl, state==s] - let cand2 = [(terminal,snext) | ((s,terminal),Shift snext) <- actTbl, state==s] - if null cand1 - then - do listOfList <- - mapM (\(terminal,snext)-> do - putStrLn $ "state " ++ show state ++ - ": shift to " ++ show snext ++ - " on " ++ terminal - compCandidates - (symbols++[TerminalSymbol terminal]) snext actTbl gotoTbl) cand2 - return $ concat listOfList - else - do listOfList <- - mapM (\(nonterminal,snext)-> do - putStrLn $ "state " ++ show state ++ - ": go to " ++ show snext ++ - " on " ++ nonterminal +data Automaton token ast = + Automaton { + actTbl :: ActionTable, + gotoTbl :: GotoTable, + prodRules :: ProdRules + } + +compCandidates isSimple level symbols state automaton stk = do + compGammas isSimple level symbols state automaton stk [] +-- gammas <- compGammas isSimple level symbols state automaton stk [] +-- if isSimple +-- then return gammas +-- else return $ tail $ scanl (++) [] (filter (not . null) gammas) + +compGammas :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => + Bool -> Int -> [Candidate] -> Int -> Automaton token ast -> Stack token ast -> [(Int, Stack token ast, String)]-> IO [[Candidate]] + +checkCycle flag level state stk action history cont = + if flag && (state,stk,action) `elem` history + then do debug $ prlevel level ++ "CYCLE is detected !!" + debug $ prlevel level ++ show state ++ " " ++ action + debug $ prlevel level ++ prStack stk + debug $ "" + return [] + else cont ( (state,stk,action) : history ) + +compGammas isSimple level symbols state automaton stk history = + checkCycle False level state stk "" history + (\history -> + case nub [prnum | ((s,lookahead),Reduce prnum) <- actTbl automaton, state==s] of + [] -> + case nub [(nonterminal,toState) | ((fromState,nonterminal),toState) <- gotoTbl automaton, state==fromState] of + [] -> + if length [True | ((s,lookahead),Accept) <- actTbl automaton, state==s] >= 1 + then do + return [] + else let cand2 = nub [(terminal,snext) | ((s,terminal),Shift snext) <- actTbl automaton, state==s] in + let len = length cand2 in + case cand2 of + [] -> return [] + + _ -> do listOfList <- + mapM (\ ((terminal,snext),i)-> + let stk1 = push (StkTerminal (Terminal terminal 0 0 (toToken terminal))) stk + stk2 = push (StkState snext) stk1 + in + -- checkCycle False level snext stk2 ("SHIFT " ++ show snext ++ " " ++ terminal) history + -- checkCycle True level state stk terminal history + checkCycle True level snext stk2 terminal history + + (\history1 -> do + debug $ prlevel level ++ "SHIFT [" ++ show i ++ "/" ++ show len ++ "]: " + ++ show state ++ " -> " ++ terminal ++ " -> " ++ show snext + debug $ prlevel level ++ "Goto/Shift symbols: " ++ show (symbols++[TerminalSymbol terminal]) + debug $ prlevel level ++ "Stack " ++ prStack stk2 + debug $ "" + compGammas isSimple (level+1) (symbols++[TerminalSymbol terminal]) snext automaton stk2 history1) ) + (zip cand2 [1..]) + return $ concat listOfList + nontermStateList -> do + let len = length nontermStateList - compCandidates - (symbols++[NonterminalSymbol nonterminal]) snext actTbl gotoTbl) cand1 - return $ concat listOfList + listOfList <- + mapM (\ ((nonterminal,snext),i) -> + let stk1 = push (StkNonterminal Nothing nonterminal) stk + stk2 = push (StkState snext) stk1 + in + -- checkCycle False level snext stk2 ("GOTO " ++ show snext ++ " " ++ nonterminal) history + -- checkCycle True level state stk nonterminal history + checkCycle True level snext stk2 nonterminal history + + (\history1 -> do + debug $ prlevel level ++ "GOTO [" ++ show i ++ "/" ++ show len ++ "] at " + ++ show state ++ " -> " ++ show nonterminal ++ " -> " ++ show snext + debug $ prlevel level ++ "Goto/Shift symbols:" ++ show (symbols++[NonterminalSymbol nonterminal]) + debug $ prlevel level ++ "Stack " ++ prStack stk2 + debug $ "" + + compGammas isSimple (level+1) (symbols++[NonterminalSymbol nonterminal]) snext automaton stk2 history1) ) + (zip nontermStateList [1..]) + return $ concat listOfList - l -> do putStrLn $ "state " ++ show state ++ - ": found reduce prodrule #" ++ show (snd (head l)) ++ - " on " ++ fst (head l) - putStrLn $ "CANDIDATE: " ++ show [symbols] - return [symbols] + prnumList -> do + let len = length prnumList + + debug $ prlevel level ++ "# of prNumList to reduce: " ++ show len ++ " at State " ++ show state + debug $ prlevel (level+1) ++ show [ (prodRules automaton) !! prnum | prnum <- prnumList ] + + -- let aCandidate = if null symbols then [] else [symbols] + -- if isSimple + -- then return aCandidate + -- else do listOfList <- + do listOfList <- + mapM (\ (prnum,i) -> ( + -- checkCycle False level state stk ("REDUCE " ++ show prnum) history + checkCycle True level state stk (show prnum) history + (\history1 -> do + debug $ prlevel level ++ "State " ++ show state ++ "[" ++ show i ++ "/" ++ show len ++ "]" + debug $ prlevel level ++ "REDUCE" ++ " prod #" ++ show prnum + debug $ prlevel level ++ show ((prodRules automaton) !! prnum) + debug $ prlevel level ++ "Goto/Shift symbols: " ++ show symbols + debug $ prlevel level ++ "Stack " ++ prStack stk + debug $ "" + compGammasForReduce level isSimple symbols state automaton stk history1 prnum)) ) + (zip prnumList [1..]) + return $ concat listOfList ) + +noCycleCheck :: Bool +noCycleCheck = True +compGammasForReduce level isSimple symbols state automaton stk history prnum = + let prodrule = (prodRules automaton) !! prnum + lhs = fst prodrule + rhs = snd prodrule + + rhsLength = length rhs + in + if ( {- rhsLength == 0 || -} (rhsLength > length symbols) ) == False + then do + debug $ prlevel level ++ "[LEN COND: False] length rhs > length symbols: NOT " ++ show rhsLength ++ ">" ++ show (length symbols) + debug $ prlevel (level+1) ++ show symbols + debug $ prlevel level + return [] + else do + let stk1 = drop (rhsLength*2) stk + let topState = currentState stk1 + let toState = + case lookupGotoTable (gotoTbl automaton) topState lhs of + Just state -> state + Nothing -> error $ "[compGammasForReduce] Must not happen: lhs: " ++ lhs ++ " state: " ++ show topState + let stk2 = push (StkNonterminal Nothing lhs) stk1 -- ast + let stk3 = push (StkState toState) stk2 + debug $ prlevel level ++ "GOTO after REDUCE: " ++ show topState ++ " " ++ lhs ++ " " ++ show toState + debug $ prlevel level ++ "Goto/Shift symbols: " ++ "[]" + debug $ prlevel level ++ "Stack " ++ prStack stk3 + debug $ "" + + debug $ prlevel level ++ "Found a gamma: " ++ show symbols + debug $ "" + + if isSimple + then return (if null symbols then [] else [symbols]) + else do listOfList <- compGammas isSimple (level+1) [] toState automaton stk3 history + return (if null symbols then listOfList else (symbols : map (symbols ++) listOfList)) + +-- +successfullyParsed :: IO [EmacsDataItem] +successfullyParsed = return [SynCompInterface.SuccessfullyParsed] + +handleLexError :: IO [EmacsDataItem] +handleLexError = return [SynCompInterface.LexError] + +handleParseError isSimple (NotFoundAction _ state stk actTbl gotoTbl prodRules terminalList) = + _handleParseError isSimple state stk actTbl gotoTbl prodRules terminalList +handleParseError isSimple (NotFoundGoto state _ stk actTbl gotoTbl prodRules terminalList) = + _handleParseError isSimple state stk actTbl gotoTbl prodRules terminalList + + +_handleParseError isSimple state stk _actTbl _gotoTbl _prodRules terminalList = + if length terminalList == 1 then do -- [$] + let automaton = Automaton {actTbl=_actTbl, gotoTbl=_gotoTbl, prodRules=_prodRules} + candidates <- compCandidates isSimple 0 [] state automaton stk + let cands = candidates + let strs = nub [ concatStrList strList | strList <- map (map showSymbol) cands ] + let rawStrs = nub [ strList | strList <- map (map showRawSymbol) cands ] + mapM_ (putStrLn . show) rawStrs + return $ map Candidate strs + else + return [SynCompInterface.ParseError (map terminalToString terminalList)] + +showSymbol (TerminalSymbol s) = s +showSymbol (NonterminalSymbol _) = "..." + +showRawSymbol (TerminalSymbol s) = s +showRawSymbol (NonterminalSymbol s) = s + +concatStrList [] = "" -- error "The empty candidate?" +concatStrList [str] = str +concatStrList (str:strs) = str ++ " " ++ concatStrList strs + +-- Q. Can we make it be typed??? +-- +-- computeCandWith :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) +-- => LexerSpec token -> ParserSpec token ast +-- -> String -> Bool -> Int -> IO [EmacsDataItem] +-- computeCandWith lexerSpec parserSpec str isSimple cursorPos = ((do +-- terminalList <- lexing lexerSpec str +-- ast <- parsing parserSpec terminalList +-- successfullyParsed) +-- `catch` \e -> case e :: LexError of _ -> handleLexError +-- `catch` \e -> case e :: ParseError token ast of _ -> handleParseError isSimple e) diff --git a/src/parserlib/SaveProdRules.hs b/src/parserlib/SaveProdRules.hs --- a/src/parserlib/SaveProdRules.hs +++ b/src/parserlib/SaveProdRules.hs @@ -62,9 +62,11 @@ concatWith [a] sep = a concatWith (a:b:theRest) sep = a ++ sep ++ concatWith (b:theRest) sep +getHashFileName fileName = fileName ++ ".hash" + writeOnceWithHash :: String -> String -> IO Bool writeOnceWithHash fileName text = do - let hashFileName = fileName ++ ".hash" + let hashFileName = getHashFileName fileName let newHash = hash text fileExists <- doesFileExist fileName diff --git a/src/syncomplib/EmacsServer.hs b/src/syncomplib/EmacsServer.hs new file mode 100644 --- /dev/null +++ b/src/syncomplib/EmacsServer.hs @@ -0,0 +1,66 @@ +module EmacsServer where + +import SynCompInterface + +import Network.Socket hiding (recv,send) +import Network.Socket.ByteString +import Data.ByteString.Char8 +import Control.Monad +import Control.Exception + +type ComputeCandidate = String -> Bool -> {- Int -> -} IO [EmacsDataItem] + +emacsServer :: ComputeCandidate -> IO () +emacsServer computeCand = do + sock <- socket AF_INET Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bind sock (SockAddrInet 50000 0) + listen sock 5 + acceptLoop computeCand sock `finally` close sock + +acceptLoop :: ComputeCandidate -> Socket -> IO () +acceptLoop computeCand sock = forever $ do + (conn, _) <- accept sock + (cursorPos, isSimple) <- getCursorPos_and_isSimple conn + print (cursorPos, isSimple) + (conn, _) <- accept sock + str <- getSource conn + print str + candidateList <- computeCand str isSimple {- cursorPos -} -- What is cursorPos useful for? + print (Prelude.map show candidateList) + (conn, _) <- accept sock + sendCandidateList conn candidateList + close conn + +str2cursorPos_and_isSimple :: String -> (Int,Bool) +str2cursorPos_and_isSimple str = + let [s1,s2] = Prelude.words str + in (read s1 :: Int, read s2 :: Bool) + +getCursorPos_and_isSimple :: Socket -> IO (Int, Bool) +getCursorPos_and_isSimple conn = do + str <- recv conn 64 + return (str2cursorPos_and_isSimple (unpack str)) + +getSource :: Socket -> IO String +getSource conn = do + str <- recv conn 64 + if Data.ByteString.Char8.length str == 0 then + return (unpack str) + else do + aaa <- getSource conn + return ((unpack str) ++ aaa) + +sendCandidateList :: Socket -> [EmacsDataItem] -> IO () +sendCandidateList conn xs = do + let + f [] = "" + f ((Candidate x) : xs) = "\n" ++ x ++ f xs + f (LexError : xs) = "LexError" ++ f xs + f ((ParseError _) : xs) = "ParseError" ++ f xs + f (SuccessfullyParsed : xs) = "SuccessfullyParsed" ++ f xs + let + s = f xs + do + _ <- send conn (pack s) + print s diff --git a/src/syncomplib/SynCompInterface.hs b/src/syncomplib/SynCompInterface.hs new file mode 100644 --- /dev/null +++ b/src/syncomplib/SynCompInterface.hs @@ -0,0 +1,8 @@ +module SynCompInterface where + +data EmacsDataItem = + LexError + | ParseError [String] + | SuccessfullyParsed + | Candidate String + deriving Show diff --git a/yapb.cabal b/yapb.cabal --- a/yapb.cabal +++ b/yapb.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: e881da2ea178ebd7058733e4799dcb71397d62fbd02354126f43a5f2eda11afc +-- hash: f28a1347c7ddd84cdcba33d0d1afcd5bbea2d63c57749607f36a45874e4aeb3f name: yapb -version: 0.1.0 +version: 0.1.1 synopsis: Yet Another Parser Builder (YAPB) description: A programmable LALR(1) parser builder system. Please see the README on GitHub at category: parser builder @@ -42,16 +42,21 @@ AutomatonType LoadAutomaton ReadGrammar + EmacsServer + SynCompInterface other-modules: Paths_yapb hs-source-dirs: src/gentable/ src/parserlib/ + src/syncomplib src/util/ build-depends: base >=4.7 && <5 + , bytestring >=0.10.8 && <0.11 , directory >=1.3.3 && <1.4 , hashable >=1.3.0 && <1.4 + , network >=3.1.1 && <3.2 , process >=1.6.5 && <1.7 , regex-tdfa >=1.3.1 && <1.4 default-language: Haskell2010 @@ -86,58 +91,20 @@ , yapb default-language: Haskell2010 -executable polyrpc-exe - main-is: Main.hs - other-modules: - Compile - Execute - Lexer - Parser - Token - TypeCheck - Verify - BasicLib - Expr - Literal - Location - Prim - Type - CSExpr - CSType - Paths_yapb - hs-source-dirs: - app/polyrpc - app/polyrpc/ast - app/polyrpc/cs - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - aeson >=1.4.7 && <1.5 - , aeson-pretty >=0.8.8 && <0.9 - , base >=4.7 && <5 - , bytestring - , containers >=0.6.0 && <0.7 - , json >=0.10 && <0.11 - , pretty >=1.1.3 && <1.2 - , prettyprinter >=1.6.1 && <1.7 - , regex-tdfa - , yapb - default-language: Haskell2010 - executable syncomp-exe main-is: Main.hs other-modules: - EmacsServer Lexer Parser Token + Expr Paths_yapb hs-source-dirs: app/syntaxcompletion + app/syntaxcompletion/ast ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 - , bytestring >=0.10.8 && <0.11 - , network >=3.1.1 && <3.2 , regex-tdfa , yapb default-language: Haskell2010