yapb 0.1.0 → 0.1.1
raw patch · 29 files changed
+375/−4440 lines, 29 filesdep −aesondep −aeson-prettydep −containersdep ~bytestringdep ~regex-tdfa
Dependencies removed: aeson, aeson-pretty, containers, json, pretty, prettyprinter
Dependency ranges changed: bytestring, regex-tdfa
Files
- README.md +8/−139
- app/polyrpc/Compile.hs +0/−442
- app/polyrpc/Execute.hs +0/−699
- app/polyrpc/Lexer.hs +0/−66
- app/polyrpc/Main.hs +0/−192
- app/polyrpc/Parser.hs +0/−414
- app/polyrpc/Token.hs +0/−126
- app/polyrpc/TypeCheck.hs +0/−537
- app/polyrpc/Verify.hs +0/−358
- app/polyrpc/ast/BasicLib.hs +0/−144
- app/polyrpc/ast/Expr.hs +0/−349
- app/polyrpc/ast/Literal.hs +0/−25
- app/polyrpc/ast/Location.hs +0/−64
- app/polyrpc/ast/Prim.hs +0/−45
- app/polyrpc/ast/Type.hs +0/−189
- app/polyrpc/cs/CSExpr.hs +0/−258
- app/polyrpc/cs/CSType.hs +0/−115
- app/syntaxcompletion/EmacsServer.hs +0/−59
- app/syntaxcompletion/Main.hs +13/−59
- app/syntaxcompletion/Parser.hs +12/−12
- app/syntaxcompletion/ast/Expr.hs +3/−0
- doc/TIPS-TO-WRITE-LALR1-GRAMMAR.txt +0/−45
- doc/parserinaction.png binary
- doc/parsertoolarchitecture.png binary
- src/parserlib/CommonParserUtil.hs +253/−60
- src/parserlib/SaveProdRules.hs +3/−1
- src/syncomplib/EmacsServer.hs +66/−0
- src/syncomplib/SynCompInterface.hs +8/−0
- yapb.cabal +9/−42
README.md view
@@ -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- * <img src="https://github.com/kwanghoon/genlrparser/blob/master/doc/parsertoolarchitecture.png"/>+### Reference+- [References](https://github.com/kwanghoon/yapb/blob/master/doc/Reference.md)
− app/polyrpc/Compile.hs
@@ -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--
− app/polyrpc/Execute.hs
@@ -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 -- <E[M];Delta_c Mem_c | Delta_s Mem_s- | ServerConfig Stack Mem [EvalContext] Expr Stack Mem -- <Delta_c Mem_c | E[M];Delta_s Mem_s>--- 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 (x<y)--calc' LePrimOp [loc] [] [IntLit x, IntLit y] = BoolLit (x<=y)--calc' GtPrimOp [loc] [] [IntLit x, IntLit y] = BoolLit (x>y)--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----
− app/polyrpc/Lexer.hs
@@ -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)- ]- }
− app/polyrpc/Main.hs
@@ -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 ()
− app/polyrpc/Parser.hs
@@ -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"- }
− app/polyrpc/Token.hs
@@ -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-
− app/polyrpc/TypeCheck.hs
@@ -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
− app/polyrpc/Verify.hs
@@ -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
− app/polyrpc/ast/BasicLib.hs
@@ -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]))))- )- ]
− app/polyrpc/ast/Expr.hs
@@ -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)-
− app/polyrpc/ast/Literal.hs
@@ -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 = "()"-
− app/polyrpc/ast/Location.hs
@@ -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)-
− app/polyrpc/ast/Prim.hs
@@ -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"--
− app/polyrpc/ast/Type.hs
@@ -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)-
− app/polyrpc/cs/CSExpr.hs
@@ -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))
− app/polyrpc/cs/CSType.hs
@@ -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
− app/syntaxcompletion/EmacsServer.hs
@@ -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-
app/syntaxcompletion/Main.hs view
@@ -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
app/syntaxcompletion/Parser.hs view
@@ -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 = "./",
+ app/syntaxcompletion/ast/Expr.hs view
@@ -0,0 +1,3 @@+module Expr where++type AST = ()
− doc/TIPS-TO-WRITE-LALR1-GRAMMAR.txt
@@ -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을 중복해서 작성하는 문제를 해결---
− doc/parserinaction.png
binary file changed (66892 → absent bytes)
− doc/parsertoolarchitecture.png
binary file changed (141365 → absent bytes)
src/parserlib/CommonParserUtil.hs view
@@ -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)
src/parserlib/SaveProdRules.hs view
@@ -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
+ src/syncomplib/EmacsServer.hs view
@@ -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
+ src/syncomplib/SynCompInterface.hs view
@@ -0,0 +1,8 @@+module SynCompInterface where++data EmacsDataItem =+ LexError+ | ParseError [String]+ | SuccessfullyParsed+ | Candidate String+ deriving Show
yapb.cabal view
@@ -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 <https://github.com/kwanghoon/yapb#readme> 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