yapb (empty) → 0.1.0
raw patch · 50 files changed
+7166/−0 lines, 50 filesdep +aesondep +aeson-prettydep +basesetup-changedbinary-added
Dependencies added: aeson, aeson-pretty, base, bytestring, containers, directory, hashable, json, network, pretty, prettyprinter, process, regex-tdfa, yapb
Files
- ChangeLog.md +21/−0
- LICENSE +30/−0
- README.md +162/−0
- Setup.hs +2/−0
- app/conv/Main.hs +10/−0
- app/parser/Lexer.hs +30/−0
- app/parser/Main.hs +42/−0
- app/parser/Parser.hs +64/−0
- app/parser/Token.hs +43/−0
- app/parser/ast/Expr.hs +48/−0
- app/polyrpc/Compile.hs +442/−0
- app/polyrpc/Execute.hs +699/−0
- app/polyrpc/Lexer.hs +66/−0
- app/polyrpc/Main.hs +192/−0
- app/polyrpc/Parser.hs +414/−0
- app/polyrpc/Token.hs +126/−0
- app/polyrpc/TypeCheck.hs +537/−0
- app/polyrpc/Verify.hs +358/−0
- app/polyrpc/ast/BasicLib.hs +144/−0
- app/polyrpc/ast/Expr.hs +349/−0
- app/polyrpc/ast/Literal.hs +25/−0
- app/polyrpc/ast/Location.hs +64/−0
- app/polyrpc/ast/Prim.hs +45/−0
- app/polyrpc/ast/Type.hs +189/−0
- app/polyrpc/cs/CSExpr.hs +258/−0
- app/polyrpc/cs/CSType.hs +115/−0
- app/syntaxcompletion/EmacsServer.hs +59/−0
- app/syntaxcompletion/Lexer.hs +30/−0
- app/syntaxcompletion/Main.hs +75/−0
- app/syntaxcompletion/Parser.hs +43/−0
- app/syntaxcompletion/Token.hs +39/−0
- app/yapb/Main.hs +8/−0
- doc/TIPS-TO-WRITE-LALR1-GRAMMAR.txt +45/−0
- doc/parserinaction.png binary
- doc/parsertoolarchitecture.png binary
- src/gentable/CFG.hs +64/−0
- src/gentable/CmdArgs.hs +43/−0
- src/gentable/CodeGenC.hs +296/−0
- src/gentable/GenLRParserTable.hs +781/−0
- src/gentable/ParserTable.hs +87/−0
- src/gentable/SampleGrammar.hs +174/−0
- src/parserlib/AutomatonType.hs +8/−0
- src/parserlib/CommonParserUtil.hs +388/−0
- src/parserlib/LoadAutomaton.hs +132/−0
- src/parserlib/SaveProdRules.hs +88/−0
- src/parserlib/Terminal.hs +14/−0
- src/parserlib/TokenInterface.hs +10/−0
- src/util/ReadGrammar.hs +137/−0
- test/Spec.hs +2/−0
- yapb.cabal +168/−0
+ ChangeLog.md view
@@ -0,0 +1,21 @@+# Changelog+All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).++## [0.1.0] - 2020-06-25+### Added+- Readme.md++### Changed+- Rename genlrparser into yapb+- Write packages.yaml (generating yapb.cabal automatically) for making yapb available as a Hackage library++### Fixed+- Fixed hard-coded usage of genlrparser-exe in GenLRParserTable.hs++### Removed+- n/a++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Kwanghoon Choi (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,162 @@++## YAPB: Yet Another Parser Builder++### A programmable parser builder system+- Allows to write LALR(1) parser specifications in Haskell+- Provides an automatic syntax completion method++### Library, tools, and examples+- 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.++### Download and build+~~~+ $ git clone https://github.com/kwanghoon/yapb+ $ cd yapb+ $ 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))+~~~++### 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"/>+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/conv/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import ReadGrammar++-- How to run:+-- $ stack exec conv-exe grm/polyrpc.lgrm++main = test conversion++
+ app/parser/Lexer.hs view
@@ -0,0 +1,30 @@+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)+ ]+ }
+ app/parser/Main.hs view
@@ -0,0 +1,42 @@+module Main where++import CommonParserUtil++import Lexer+import Terminal+import Parser+import Expr++import System.IO++main :: IO ()+main = do+ fileName <- readline "Enter your file: "+ case fileName of+ "exit" -> return ()+ line -> doProcess line++doProcess line = do+ text <- readFile line + putStrLn "Lexing..."+ terminalList <- lexing lexerSpec text+ putStrLn "Parsing..."+ exprSeqAst <- parsing parserSpec terminalList+ putStrLn "Pretty Printing..."+ putStrLn (pprintAst 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)++
+ app/parser/Parser.hs view
@@ -0,0 +1,64 @@+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"+ }++
+ app/parser/Token.hs view
@@ -0,0 +1,43 @@+module Token(Token(..)) where++import Prelude hiding(EQ)+import TokenInterface++data Token =+ END_OF_TOKEN+ | OPEN_PAREN | CLOSE_PAREN+ | IDENTIFIER | INTEGER_NUMBER+ | ADD | SUB | MUL | DIV+ | EQ | SEMICOLON+ deriving (Eq, Show)++tokenStrList :: [(Token,String)]+tokenStrList =+ [ (END_OF_TOKEN, "$"),+ (OPEN_PAREN, "("), (CLOSE_PAREN, ")"),+ (IDENTIFIER, "identifier"), (INTEGER_NUMBER, "integer_number"),+ (ADD, "+"), (SUB, "-"), (MUL, "*"), (DIV, "/"),+ (EQ, "="), (SEMICOLON, ";") + ]++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/parser/ast/Expr.hs view
@@ -0,0 +1,48 @@+module Expr where++data AST =+ ASTSeq { fromAstSeq :: [Expr] } -- Expr Sequence: Expr1; ... ; Exprn+ | ASTExpr { fromAstExpr :: Expr }++instance Show AST where+ showsPrec p _ = (++) "AST ..."++toAstSeq :: [Expr] -> AST+toAstSeq exprs = ASTSeq exprs++toAstExpr :: Expr -> AST+toAstExpr expr = ASTExpr expr++data Expr =+ Lit { fromLit :: Int }+ | Var { fromVar :: String }+ | BinOp { kindFromBinOp :: BinOpKind,+ leftOpFromBinOp :: Expr,+ rightOpFromBinOp :: Expr }+ | Assign { lhsFromAssign :: String,+ rhsFromAssign :: Expr }++data BinOpKind = ADD | SUB | MUL | DIV++pprintAst :: AST -> String+pprintAst (ASTSeq exprs) =+ let insSemicolon [] = ""+ insSemicolon [str] = str+ insSemicolon (str:strs) = str ++ "; " ++ insSemicolon strs+ in insSemicolon (map pprint exprs)+ +pprintAst (ASTExpr expr) = pprint expr++pprint :: Expr -> String+pprint (Lit i) = show i+pprint (Var v) = v+pprint (BinOp Expr.ADD left right) =+ "(" ++ pprint left ++ " + " ++ pprint right ++ ")"+pprint (BinOp Expr.SUB left right) =+ "(" ++ pprint left ++ " - " ++ pprint right ++ ")"+pprint (BinOp Expr.MUL left right) =+ "(" ++ pprint left ++ " * " ++ pprint right ++ ")"+pprint (BinOp Expr.DIV left right) =+ "(" ++ pprint left ++ " / " ++ pprint right ++ ")"+pprint (Assign x expr) = + "(" ++ x ++ " = " ++ pprint expr ++ ")"
+ app/polyrpc/Compile.hs view
@@ -0,0 +1,442 @@+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 view
@@ -0,0 +1,699 @@+{-# 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 view
@@ -0,0 +1,66 @@+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 view
@@ -0,0 +1,192 @@+{-# 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 view
@@ -0,0 +1,414 @@+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 view
@@ -0,0 +1,126 @@+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 view
@@ -0,0 +1,537 @@+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 view
@@ -0,0 +1,358 @@+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 view
@@ -0,0 +1,144 @@+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 view
@@ -0,0 +1,349 @@+{-# 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 view
@@ -0,0 +1,25 @@+{-# 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 view
@@ -0,0 +1,64 @@+{-# 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 view
@@ -0,0 +1,45 @@+{-# 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 view
@@ -0,0 +1,189 @@+{-# 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 view
@@ -0,0 +1,258 @@+{-# 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 view
@@ -0,0 +1,115 @@+{-# 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 view
@@ -0,0 +1,59 @@+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/Lexer.hs view
@@ -0,0 +1,30 @@+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),+ ("\\(" , mkFn OPEN_PAREN),+ ("\\)" , mkFn CLOSE_PAREN),+ ("fn" , mkFn FN),+ ("let" , mkFn LET),+ ("in" , mkFn IN),+ ("end" , mkFn END),+ ("val" , mkFn VAL),+ ("=>" , mkFn ARROW),+ ("=" , mkFn EQ),+ ("[a-zA-Z][a-zA-Z0-9]*" , mkFn IDENTIFIER)+ ]+ }
+ app/syntaxcompletion/Main.hs view
@@ -0,0 +1,75 @@+module Main where++import CommonParserUtil++import Token+import Lexer+import Terminal+import Parser+import EmacsServer+import System.IO++import Data.Typeable+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)++
+ app/syntaxcompletion/Parser.hs view
@@ -0,0 +1,43 @@+module Parser where++import CommonParserUtil+import Token++data AST = AST -- We do not build any ASTs!!+ deriving (Show)++parserSpec :: ParserSpec Token AST+parserSpec = ParserSpec+ {+ startSymbol = "Start'",+ + parserSpecList =+ [+ ("Start' -> Start", \rhs -> get rhs 1),++ ("Start -> Exp", \rhs -> get rhs 1),++ ("Exp -> AppExp", \rhs -> get rhs 1),++ ("Exp -> fn identifier => Exp", \rhs -> AST),++ ("AppExp -> AtExp", \rhs -> get rhs 1),++ ("AppExp -> AppExp AtExp", \rhs -> AST),++ ("AtExp -> identifier", \rhs -> AST),++ ("AtExp -> ( Exp )", \rhs -> AST),++ ("AtExp -> let Dec in Exp end", \rhs -> AST),++ ("Dec -> val identifier = Exp", \rhs -> AST)+ ],+ + baseDir = "./",+ actionTblFile = "action_table.txt", + gotoTblFile = "goto_table.txt",+ grammarFile = "prod_rules.txt",+ parserSpecFile = "mygrammar.grm",+ genparserexe = "yapb-exe"+ }
+ app/syntaxcompletion/Token.hs view
@@ -0,0 +1,39 @@+module Token(Token(..)) where++import Prelude hiding(EQ)+import TokenInterface++data Token =+ END_OF_TOKEN+ | OPEN_PAREN | CLOSE_PAREN+ | IDENTIFIER | FN | ARROW+ | EQ | LET | IN | END | VAL+ deriving (Eq, Show)++tokenStrList :: [(Token,String)]+tokenStrList =+ [ (END_OF_TOKEN, "$"),+ (OPEN_PAREN, "("), (CLOSE_PAREN, ")"),+ (IDENTIFIER, "identifier"), (FN, "fn"), (ARROW, "=>"),+ (EQ, "="), (LET, "let"), (IN, "in"), (END, "end"), (VAL, "val")+ ]++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/yapb/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import GenLRParserTable++main :: IO ()+main = do _ <- _main+ return ()+
+ doc/TIPS-TO-WRITE-LALR1-GRAMMAR.txt view
@@ -0,0 +1,45 @@++++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 view
binary file changed (absent → 66892 bytes)
+ doc/parsertoolarchitecture.png view
binary file changed (absent → 141365 bytes)
+ src/gentable/CFG.hs view
@@ -0,0 +1,64 @@+module CFG where++import Data.List(nub,intersperse)++--------------------------------------------------------------------------------+-- Context Free Grammar+--------------------------------------------------------------------------------+data Symbol = Nonterminal String | Terminal String + deriving (Eq, Read)+ +instance Show Symbol where+ showsPrec p (Nonterminal x) = (++) x+ showsPrec p (Terminal x) = (++) x+ +isTerminal (Terminal x) = True +isTerminal _ = False+ +data ExtendedSymbol = Symbol Symbol | Epsilon | EndOfSymbol+ deriving Eq+ +instance Show ExtendedSymbol where+ showsPrec p (Symbol sym) = (++) (show sym)+ showsPrec p (Epsilon) = (++) "epsilon"+ showsPrec p (EndOfSymbol) = (++) "$"+ +isExtendedTerminal (Symbol (Terminal x)) = True +isExtendedTerminal (EndOfSymbol) = True +isExtendedTerminal _ = False++isExtendedNonterminal (Symbol (Nonterminal x)) = True +isExtendedNonterminal _ = False++data ProductionRule = ProductionRule String [Symbol] + deriving (Eq, Read)+ +instance Show ProductionRule where+ showsPrec p (ProductionRule x ys) = (++) x . (++) " -> " . show_ys ys+ +type ProductionRules = [ProductionRule] + +show_ys [] = (++) "" +show_ys [y] = (++) (show y) +show_ys (y:ys) = (++) (show y) . (++) " " . show_ys ys++data CFG = CFG String [ProductionRule] + deriving (Show, Read)++type AUGCFG = CFG++startNonterminal (CFG s prules) = s ++nonterminals augCfg = nub $ [s] ++ [x | ProductionRule x _ <- prules]+ where+ CFG s prules = augCfg++prodRuleToStr (ProductionRule s syms) =+ "ProductionRule " ++ show s+ ++ " [" ++ concat (intersperse ", " (map symbolToStr syms)) ++ "]"++symbolToStr (Nonterminal x) = "Nonterminal " ++ show x+symbolToStr (Terminal x) = "Terminal " ++ show x+++
+ src/gentable/CmdArgs.hs view
@@ -0,0 +1,43 @@+module CmdArgs(getCmd, Cmd(..)) where+ +data Cmd = + CmdGrmFiles [String] -- a.grm b.grm c.grm ...+ | CmdGrmWithOption (Maybe String) String String String + -- a.grm prod_rules.txt action_table.txt goto_table.txt+ | CmdError String -- error message++getCmd :: [String] -> Cmd+getCmd args = + let cmd = collectInfo args + in case cmd of+ CmdGrmWithOption Nothing _ _ _ -> + CmdError $ "No grammar file is given for -output"+ _ -> cmd++collectInfo :: [String] -> Cmd+collectInfo ("-output":ss) = + if length ss < 3 then+ CmdError $ "Specify three file names after -output: " ++ show ss+ else + let prod_rules : action_table : goto_table : ss' = ss+ cmd = collectInfo ss' + in case cmd of+ CmdGrmFiles [] ->+ CmdGrmWithOption Nothing prod_rules action_table goto_table+ CmdGrmFiles [fileName] -> + CmdGrmWithOption (Just fileName) prod_rules action_table goto_table+ CmdGrmFiles _ -> + CmdError $ "Only one grammar file can be applied with -output"+ CmdGrmWithOption _ _ _ _ -> + CmdError $ "Only one use of -output is allowed"+ CmdError msg -> cmd+collectInfo (s:ss) = + let cmd = collectInfo ss+ in case cmd of+ CmdGrmFiles fileNames -> CmdGrmFiles (s:fileNames)+ CmdGrmWithOption Nothing f1 f2 f3 -> + CmdGrmWithOption (Just s) f1 f2 f3+ CmdGrmWithOption (Just _) _ _ _ -> + CmdError $ "Only one grammar file can be applied with -output"+ CmdError msg -> cmd+collectInfo [] = CmdGrmFiles []
+ src/gentable/CodeGenC.hs view
@@ -0,0 +1,296 @@+module CodeGenC where++import Data.List(groupBy)++import CFG+import ParserTable +import GenLRParserTable+import SampleGrammar++--------------------------------------------------------------------------------+-- C Code Generation for Parser+--------------------------------------------------------------------------------++-- cgStates iss+-- cgNonterminals augCfg+-- cgGotoTable augCfg++-- C enum type declaration for states+cgStates iss = cgEnum "STATE" (cgStates' iss)+ +cgStates' [] = return () +cgStates' [is] = + do putStr "\t"+ cgState is++cgStates' [is1,is2] = + do putStr "\t"+ cgState is1+ putStr ", "+ cgState is2+ putStrLn ""++cgStates' [is1,is2,is3] = + do putStr "\t"+ cgState is1+ putStr ", "+ cgState is2+ putStr ", "+ cgState is3+ putStrLn ""++cgStates' [is1,is2,is3,is4] = + do putStr "\t"+ cgState is1+ putStr ", "+ cgState is2+ putStr ", "+ cgState is3+ putStr ", "+ cgState is4+ putStrLn ""+ +cgStates' [is1,is2,is3,is4,is5] = + do putStr "\t"+ cgState is1+ putStr ", "+ cgState is2+ putStr ", "+ cgState is3+ putStr ", "+ cgState is4+ putStr ", "+ cgState is5+ putStrLn ""+ +cgStates' (is1:is2:is3:is4:is5:iss) =+ do putStr "\t"+ cgState is1+ putStr ", "+ cgState is2+ putStr ", "+ cgState is3+ putStr ", "+ cgState is4+ putStr ", "+ cgState is5+ putStrLn ","+ cgStates' iss+ +cgState is = putStr (cgToState is) + +cgToState is = "S" ++ cgToState' is++cgToState' [] = ""+cgToState' [i] = show i+cgToState' (i:is) = show i ++ "_" ++ cgToState' is++-- C enum type declaration for nonterminals++cgNonterminals augCfg = + cgEnum "Nonterminal" (cgNonterminals' (cgCNames (nonterminals augCfg)))+ +cgNonterminals' [] = return () +cgNonterminals' [x] = + do putStr "\t"+ putStr x+ putStrLn ""+cgNonterminals' [x1,x2] = + do putStr "\t"+ putStr x1+ putStr ", "+ putStr x2+ putStrLn ""+cgNonterminals' (x1:x2:xs) = + do putStr "\t"+ putStr x1+ putStr ", "+ putStr x2+ putStr ", "+ putStrLn ""+ cgNonterminals' xs+ +cgCNames nts = map cgToCName nts++cgToCName x = "NONTERMINAL_" ++ cgToCName' x++cgToCName' [] = [] -- CAUTION: Don't use S' with S_ for nonterminals.+cgToCName' (c:cs) = + (if c == '\'' then '_' else c) : cgToCName' cs ++cgEnum name action =+ do putStrLn ("enum " ++ name ++ " {")+ action+ putStrLn "};"++-- C array for goto_table+cgGotoTable augCfg =+ do prGotoTableDim (length iss) (length nts)+ prGotoTableArr iss nts gotoTbl+ where+ (_,_,iss,_,gotoTbl) = calcLALRParseTable augCfg+ nts = nonterminals augCfg+ +cg_noofstates = "NOOFSTATES"+cg_noofnonterms = "NOOFNONTERMINALS"+ +prGotoTableDim no_states no_nonterms = + do putStrLn $ "#define " ++ cg_noofstates ++ " " ++ show no_states+ putStrLn $ "#define " ++ cg_noofnonterms ++ " " ++ show no_nonterms+ putStrLn ""+ +prGotoTableArr :: [[Int]] -> [String] -> LALRGotoTable -> IO ()+prGotoTableArr states nonterms gotoTbl = + do putStrLn $ "int goto_table[" ++ cg_noofstates ++ + "][" ++ cg_noofnonterms ++ "] = {"+ prGotoTableArr' states nonterms gotoTbl+ putStrLn $ "};"++prGotoTableArr' [i] nonterms gotoTbl = + do putStr "\t"+ putStr "{"+ prGotoTableArr'' i nonterms gotoTbl+ putStrLn "}"+prGotoTableArr' (i:states) nonterms gotoTbl = + do putStr "\t"+ putStr "{"+ prGotoTableArr'' i nonterms gotoTbl+ putStrLn "},"+ prGotoTableArr' states nonterms gotoTbl+ +prGotoTableArr'' i [x] gotoTbl =+ case lookupTable i (Nonterminal x) gotoTbl of+ Nothing -> do putStr $ show (-1)+ Just k -> do putStr $ cgToState k+prGotoTableArr'' i (x:nonterms) gotoTbl =+ case lookupTable i (Nonterminal x) gotoTbl of+ Nothing -> do putStr $ show (-1) ++ ","+ prGotoTableArr'' i nonterms gotoTbl+ Just k -> do putStr $ cgToState k ++ ","+ prGotoTableArr'' i nonterms gotoTbl+ +-- Generate C code for an LALR action table+cgActionsInStates augCfg =+ do let nTabs = 1+ prTab nTabs+ putStrLn "switch( top() )"+ prTab nTabs+ putStrLn "{"+ mapM_ (\t -> cgInStates nTabs t iprules) (groupBy eqState lalrActTbl)+ prTab nTabs+ putStrLn "} /* switch ( top() ) */ "+ + where+ CFG start prules = augCfg+ iprules = zip [0..] prules + (_,_,_,lalrActTbl,_) = calcLALRParseTable augCfg+ + eqState (x1,_,_) (x2,_,_) = x1 == x2+ +cgInStates n ((state,extSym,acts):lalrActTbl) iprules =+ do prTab n+ putStrLn $ "case " ++ cgToState state ++ ":"+ cgActions (n+1) ((state,extSym,acts):lalrActTbl) iprules+ prTab (n+1)+ putStrLn "break;"+ putStrLn ""+cgInStates n [] iprules+ = return ()+ +cgActions n lalrActTbl iprules =+ do prTab n+ putStrLn "switch ( toks[current_tok] )"+ prTab n+ putStrLn "{"+ + cgActions' n lalrActTbl iprules+ + prTab n+ putStrLn "default:"+ prTab (n+1)+ putStrLn "error = REJECT;"+ prTab (n+1)+ putStrLn "break;"+ putStrLn ""+ + prTab n+ putStrLn "}"+ +cgActions' n [] iprules = return ()+cgActions' n ((_,extsym,action):extSymActs) iprules =+ do cgAction n extsym action iprules+ cgActions' n extSymActs iprules++cgAction n extsym (LALRShift state) iprules =+ do prTab n+ cgActionCase extsym+ prTab (n+1)+ putStrLn $ "push (" ++ cgTerminalName extsym ++ ");"+ prTab (n+1)+ putStrLn $ "push (" ++ cgToState state ++ ");"+ prTab (n+1)+ putStrLn $ "current_tok += " ++ show (offset extsym) ++ ";"+ prTab (n+1)+ putStrLn "break;"+ putStrLn ""+ +cgAction n extsym (LALRAccept) iprules =+ do prTab n + cgActionCase extsym+ prTab (n+1)+ putStrLn "error = ACCEPT;"+ prTab (n+1)+ putStrLn "break;"+ +cgAction n extsym (LALRReduce i) iprules =+ case maybeprule of+ Nothing -> error $ "cgActionsInState: Cannot find " ++ show i ++ " prule"+ Just (ProductionRule y ys) -> cgAction' n extsym y ys i + where+ maybeprule = lookup i iprules+ +cgAction n extsym (LALRReject) iprules = + error "cgActionsInState: LALRReject unexpected"+ +cgAction' n extsym y ys i =+ do prTab n+ cgActionCase extsym+ mapM_ (\i -> do { prTab (n+1); putStrLn "pop();" }) [1..length ys * 2]+ putStrLn ""+ prTab (n+1)+ putStrLn "next = top();"+ prTab (n+1)+ putStrLn $ "push (" ++ cgToCName y ++ ");"+ prTab (n+1)+ putStrLn $ "next = goto_table[next][" ++ cgToCName y ++ "];"+ prTab (n+1)+ putStrLn "if (0 <= next) push (next); else error = next;"+ prTab (n+1)+ putStrLn "break;"+ +-- Attribute of tokens specific to g3+offset (Symbol (Terminal "var")) = 3+offset _ = 1+ +cgActionCase extsym =+ putStrLn $ "case " ++ cgTerminalName extsym ++ ":"++ +cgTerminalName extsym = + case extsym of+ Symbol (Terminal t) -> cgTerminalName' t+ EndOfSymbol -> cgNameEndOfSymbol+ _ -> error "cgTerminalName: not a terminal symbol"+ +cgTerminalName' t = + case lookup t g3_attrib_terminals of+ Nothing -> error $ "cgTerminalName: not found " ++ t+ Just y -> y+ +-- The attribute of $+cgNameEndOfSymbol = "ENDOFSYMBOL"+ +prTab 0 = return () +prTab n = + do putStr "\t"+ prTab (n-1)
+ src/gentable/GenLRParserTable.hs view
@@ -0,0 +1,781 @@+--------------------------------------------------------------------------------+-- An LR Parser Table Generator+-- +-- Copyright(c) 2013 Kwanghoon Choi. All rights reserved.+--+-- Usage:+-- $ ghci GenLRParserTable+-- *Main> prParseTable (calcLR1ParseTable g1)+-- *Main> prLALRParseTable (calcLALRParseTable g1)+--+-- * let (items,_,lkhtbl,gotos) = calcLR0ParseTable g1 +-- in do { prItems items; prGtTbl gotos; prLkhTable lkhtbl }+--+-- * closure g4 [Item (ProductionRule "S'" [Nonterminal "S"]) 0 [Symbol (Terminal "")]]+--------------------------------------------------------------------------------++module GenLRParserTable where++import Data.List+import Data.Maybe+import System.Environment (getArgs)++import CFG+import ParserTable+import CmdArgs ++import System.IO++{-++가능한 명령 인자 형식+$ main.exe rpc.grm +$ main.exe rpc.grm smallbasic.grm (grm 파일이 둘 이상이면 -output 옵션을 사용 불가)+$ main.exe rpc.grm -output prod_rules.txt action_table.txt goto_table.txt +$ main.exe -output prod_rules.txt action_table.txt goto_table.txt rpc.grm++-}+_main = do+ args <- getArgs+ -- mapM_ putStrLn args+ let cmd = getCmd args + case cmd of + CmdError msg -> putStrLn msg+ CmdGrmFiles fileNames -> mapM_ (f stdout) fileNames + CmdGrmWithOption (Just fileName) prod_rule action_tbl goto_tbl -> do+ writeParseTable fileName prod_rule action_tbl goto_tbl+ putStrLn "Done"++ where+ f h file = do+ grammar <- readFile file+ -- putStrLn grammar+ let cfg = read grammar :: CFG++ prParseTable stdout $ (\(a1,a2,a3,a4,a5)->(a1,a2,a3,a4)) (calcEfficientLALRParseTable cfg)++ writeParseTable file prod_rule action_tbl goto_tbl =+ do+ grammar <- readFile file+ let cfg = read grammar :: CFG+ let (items, prules, actTbl, gtTbl) =+ (\(a1,a2,a3,a4,a5)->(a1,a2,a3,a4))+ (calcEfficientLALRParseTable cfg) ++ h_pr <- openFile prod_rule WriteMode+ h_acttbl <- openFile action_tbl WriteMode + h_gototbl <- openFile goto_tbl WriteMode++ prPrules h_pr prules+ prActTbl h_acttbl actTbl+ prGtTbl h_gototbl gtTbl++ hClose h_pr+ hClose h_acttbl + hClose h_gototbl++__main g = do+ prParseTable stdout $ (\(a1,a2,a3,a4,a5)->(a1,a2,a3,a4)) (calcEfficientLALRParseTable g)++-- __mainDebug g = do+-- let (_,_,_,_,(items,lkhtbl1,splk',lkhtbl2,gotos)) = calcEfficientLALRParseTable g+-- let kernelitems = map (filter (isKernel (startNonterminal g))) items+-- prItems items+-- prGtTbl gotos+-- prItems kernelitems+-- putStrLn "closure with #"+-- let f (i, x,y) = do { putStrLn (show i ++ " : " ++ show x); prItem y; putStrLn "" }+-- mapM_ f $ [ (index, item, closure g [Item prule dot [sharpSymbol]])+-- | (index,items) <- zip [0..] kernelitems+-- , item@(Item prule dot _) <- items ]+-- putStrLn "Splk'"+-- prSplk' splk'+-- putStrLn "Splk:"+-- prSpontaneous lkhtbl1+-- putStrLn "Prop:"+-- prPropagate lkhtbl2 +-- putStrLn ""+-- prItems (computeLookaheads lkhtbl1 lkhtbl2 kernelitems)++prSplk' [] = return ()+prSplk' ((index0,index2,item0,item0closure,item1,item2):splk') = do+ putStrLn "item0:"+ putStrLn (show index0)+ putStrLn (show item0)+ putStrLn "closure(item0,#):"+ prItem stdout item0closure+ putStrLn "item1:"+ putStrLn (show item1)+ putStrLn (show index2)+ putStrLn "item2:"+ putStrLn (show item2)+ ch <- getChar+ prSplk' splk'++__mainLr1 g = do+ prParseTable stdout (calcLR1ParseTable g)++__mainLalr1 g = do + prLALRParseTable stdout (calcLALRParseTable g)++--+indexPrule :: AUGCFG -> ProductionRule -> Int+indexPrule augCfg prule = indexPrule' prules prule 0+ where+ CFG _ prules = augCfg+ +indexPrule' [] prule n = error ("indexPrule: not found " ++ show prule)+indexPrule' (r:rs) prule n = + if r == prule then n else indexPrule' rs prule (n+1)+ +prPrules h ps = prPrules' h ps 0++prPrules' h [] n = return ()+prPrules' h (prule:prules) n = + do hPutStrLn h (show n ++ ": " ++ show prule)+ prPrules' h prules (n+1)+ +--------------------------------------------------------------------------------+-- Utility+--------------------------------------------------------------------------------+symbols :: CFG -> [Symbol]+symbols (CFG start prules) + = [Nonterminal x | Nonterminal x <- syms] +++ [Terminal x | Terminal x <- syms]+ where+ f (ProductionRule x syms) = Nonterminal x:syms+ syms = nub (Nonterminal start : concat (map f prules))++--+first :: [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]+first tbl x = case (lookup x tbl) of+ Nothing -> [Symbol x]+ -- Nothing -> if x == Terminal "#" + -- then [Symbol x] + -- else error (show x ++ " not in " ++ show tbl)+ Just y -> y++first_ :: [(Symbol, [ExtendedSymbol])] -> [Symbol] -> [ExtendedSymbol]+first_ tbl [] = []+first_ tbl (z:zs) = let zRng = first tbl z in+ if elem Epsilon zRng + then union ((\\) zRng [Epsilon]) (first_ tbl zs)+ else zRng+ +extFirst :: [(Symbol, [ExtendedSymbol])] -> ExtendedSymbol -> [ExtendedSymbol]+extFirst tbl (Symbol x) = first tbl x+extFirst tbl (EndOfSymbol) = [EndOfSymbol]+extFirst tbl (Epsilon) = error "extFirst_ : Epsilon"++extFirst_ :: [(Symbol, [ExtendedSymbol])] -> [ExtendedSymbol] -> [ExtendedSymbol]+extFirst_ tbl [] = []+extFirst_ tbl (z:zs) = let zRng = extFirst tbl z in+ if elem Epsilon zRng + then union ((\\) zRng [Epsilon]) (extFirst_ tbl zs)+ else zRng+ +--+calcFirst :: CFG -> [(Symbol, [ExtendedSymbol])]+calcFirst cfg = calcFirst' cfg (initFirst cfg) (symbols cfg)+ +initFirst cfg =+ let syms = symbols cfg+ CFG _ prules = cfg+ in [(Terminal x, [Symbol (Terminal x)]) + | Terminal x <- syms]+ ++ + [(Nonterminal x, [Epsilon | ProductionRule y [] <- prules, x == y])+ | Nonterminal x <- syms]++calcFirst' cfg currTbl syms =+ let (isChanged, nextFst) = calcFirst'' cfg currTbl syms in+ if isChanged then calcFirst' cfg nextFst syms else currTbl+ ++calcFirst'' cfg tbl [] + = (False, [])+calcFirst'' cfg tbl (Terminal x:therest)+ = calcFirst''' cfg tbl (False, (Terminal x, first tbl (Terminal x))) therest+calcFirst'' cfg tbl (Nonterminal x:therest) + = calcFirst''' cfg tbl (ischanged, (Nonterminal x, rng)) therest+ where+ CFG start prules = cfg+ + addendum = f [zs | ProductionRule y zs <- prules, x == y]+ currRng = first tbl (Nonterminal x)+ ischanged = (\\) addendum currRng /= []+ rng = union addendum currRng+ + f [] = []+ f (zs:zss) = union (first_ tbl zs) (f zss)+ +calcFirst''' cfg tbl (bool1, oneupdated) therest =+ let (bool2, therestupdated) = calcFirst'' cfg tbl therest in+ (bool1 || bool2, oneupdated:therestupdated)+++--+follow :: [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]+follow tbl x = case lookup x tbl of+ Nothing -> error (show x ++ " : " ++ show tbl)+ Just z -> z++--+calcFollow :: CFG -> [(Symbol, [ExtendedSymbol])]+calcFollow cfg = calcFollow' (calcFirst cfg) prules (initFollow cfg) + where CFG _ prules = cfg++initFollow cfg = + let CFG start prules = cfg+ in [(Nonterminal x, [EndOfSymbol | x == start])+ | Nonterminal x <- symbols cfg]+ +calcFollow' fstTbl prules currTbl = + let (isChanged, nextFlw) = calcFollow'' fstTbl currTbl prules False in+ if isChanged then calcFollow' fstTbl prules nextFlw else currTbl+ +calcFollow'' fstTbl flwTbl [] b = (b, flwTbl)+calcFollow'' fstTbl flwTbl (ProductionRule y zs:therest) b =+ calcFollow'' fstTbl tbl' therest b'+ where+ (b',tbl') = f zs flwTbl b+ + _y = Nonterminal y+ + f [] tbl b = (b, tbl)+ f [Terminal z] tbl b = (b, tbl)+ f [Nonterminal z] tbl b =+ let flwZ = follow flwTbl (Nonterminal z)+ zRng = union flwZ (follow flwTbl _y)+ isChanged = (\\) zRng flwZ /= []+ in (isChanged, upd (Nonterminal z) zRng tbl)+ f (Terminal z:zs) tbl b = f zs tbl b+ f (Nonterminal z:zs) tbl b =+ let fstZS = first_ fstTbl zs+ flwZ = follow flwTbl (Nonterminal z)+ zRng = union (follow flwTbl (Nonterminal z))+ (union ((\\) fstZS [Epsilon])+ (if elem Epsilon fstZS + then follow flwTbl _y+ else []))+ isChanged = (\\) zRng flwZ /= []+ in f zs (upd (Nonterminal z) zRng tbl) isChanged+ + upd z zRng tbl = [if z == x then (x, zRng) else (x,xRng) | (x,xRng) <- tbl]+ +-- +closure :: AUGCFG -> Items -> Items+closure augCfg items = + if isChanged + then closure augCfg itemsUpdated -- loop over items+ else items+ where+ CFG s prules = augCfg+ (isChanged, itemsUpdated) + = closure' (calcFirst augCfg) prules items items False+ + +closure' fstTbl prules cls [] b = (b, cls)+closure' fstTbl prules cls (Item (ProductionRule x alphaBbeta) d lookahead:items) b = + if _Bbeta /= []+ then f cls b prules+ else closure' fstTbl prules cls items b+ where+ _Bbeta = drop d alphaBbeta+ _B = head _Bbeta+ beta = tail _Bbeta+ + -- loop over production rules+ f cls b [] = closure' fstTbl prules cls items b+ f cls b (r@(ProductionRule y gamma):rs) = + if _B == Nonterminal y+ then (if lookahead == [] + then flrzero cls b r rs -- closure for LR(0)+ else g cls b r rs (extFirst_ fstTbl (map Symbol beta ++ lookahead))) -- closure for LR(1)+ else f cls b rs++ flrzero cls b r rs = + let item = Item r 0 []+ in if elem item cls then f cls b rs + else f (cls ++ [item]) True rs++ -- loop over terminal symbols+ g cls b r rs [] = f cls b rs+ g cls b r rs (Symbol (Terminal t) : fstSyms) =+ let item = Item r 0 [Symbol (Terminal t)]+ in if elem item cls + then g cls b r rs fstSyms + else g (cls++[item]) True r rs fstSyms+ g cls b r rs (Symbol (Nonterminal t) : fstSyms) = g cls b r rs fstSyms+ g cls b r rs (EndOfSymbol : fstSyms) = + let item = Item r 0 [EndOfSymbol]+ in if elem item cls + then g cls b r rs fstSyms + else g (cls++[item]) True r rs fstSyms+ g cls b r rs (Epsilon : fstSyms) = error "closure: Epsilon"+ +-- +calcLR0Items :: AUGCFG -> Itemss+calcLR0Items augCfg = calcItems' augCfg syms iss0+ where + CFG _S prules = augCfg+ i0 = Item (head prules) 0 [] -- The 1st rule : S' -> S.+ is0 = closure augCfg [i0]+ iss0 = [ is0 ]++ syms = (\\) (symbols augCfg) [Nonterminal _S]+ -- syms = [ sym | sym <- symbols augCfg, sym /= Nonterminal _S]++calcLR1Items :: AUGCFG -> Itemss+calcLR1Items augCfg = calcItems' augCfg syms iss0+ where + CFG _S prules = augCfg+ i0 = Item (head prules) 0 [EndOfSymbol] -- The 1st rule : S' -> S.+ is0 = closure augCfg [i0]+ iss0 = [ is0 ]++ syms = (\\) (symbols augCfg) [Nonterminal _S]+ -- syms = [ sym | sym <- symbols augCfg, sym /= Nonterminal _S]+ +calcItems' augCfg syms currIss =+ if isUpdated+ then calcItems' augCfg syms nextIss+ else currIss+ where+ (isUpdated, nextIss) = f currIss False currIss+ + -- loop over sets of items+ f [] b currIss = (b, currIss)+ f (is:iss) b currIss = g is iss b currIss syms+ + -- loop over symbols+ g is iss b currIss [] = f iss b currIss+ g is iss b currIss (x:xs) = + let is' = goto augCfg is x+ in if is' == [] || elemItems is' currIss + then g is iss b currIss xs + else g is iss True (currIss ++ [is']) xs++elemItems :: Items -> Itemss -> Bool +elemItems is0 [] = False+elemItems is0 (is:iss) = eqItems is0 is || elemItems is0 iss+ +eqItems :: Items -> Items -> Bool +eqItems is1 is2 = (\\) is1 is2 == [] && (\\) is2 is1 == []++indexItem :: String -> Itemss -> Items -> Int+indexItem loc items item = indexItem' loc items item 0++indexItem' loc (item1:items) item2 n+ = if eqItems item1 item2 then n else indexItem' loc items item2 (n+1)+indexItem' loc [] item n = error ("indexItem: not found " ++ show item ++ " at " ++ loc)++goto :: AUGCFG -> Items -> Symbol -> Items+goto augCfg items x = closure augCfg itemsOverX+ where+ itemsOverX = [ Item (ProductionRule z alphaXbeta) (j+1) y+ | Item (ProductionRule z alphaXbeta) j y <- items+ , let _Xbeta = drop j alphaXbeta+ , _Xbeta /= []+ , x == head _Xbeta ]+ +++--------------------------------------------------------------------------------+-- Canonical LR Parser+--------------------------------------------------------------------------------+sharp = Terminal "#" -- a special terminal symbol+sharpSymbol = Symbol sharp++-- calcEfficientLALRParseTable :: AUGCFG -> (Itemss, ProductionRules, ActionTable, GotoTable)+calcEfficientLALRParseTable augCfg = + (lr1items, prules, actionTable, gotoTable, ()) -- (lr0items, splk, splk'', prop, lr0GotoTable))+ where+ CFG _S' prules = augCfg + lr0items = calcLR0Items augCfg + lr0kernelitems = map (filter (isKernel (startNonterminal augCfg))) lr0items+ syms = (\\) (symbols augCfg) [Nonterminal _S']++ terminalSyms = [Terminal x | Terminal x <- syms]+ nonterminalSyms = [Nonterminal x | Nonterminal x <- syms]++ lr0GotoTable = calcLr0GotoTable augCfg lr0items++ splk = (Item (head prules) 0 [], 0, [EndOfSymbol]) : (map (\(a1,a2,a3,a4)->(a1,a2,a3)) splk')+ splk' = calcSplk augCfg lr0kernelitems lr0GotoTable+ splk'' = map (\(a1,a2,a3,a4)->a4) splk'+ prop = calcProp augCfg lr0kernelitems lr0GotoTable++ lr1kernelitems = computeLookaheads splk prop lr0kernelitems++ lr1items = map (closure augCfg) lr1kernelitems++ (actionTable, gotoTable) = calcEfficientLALRActionGotoTable augCfg lr1items++calcLr0GotoTable augCfg lr0items =+ nub [ (from, h, to)+ | item1 <- lr0items+ , Item (ProductionRule y ys) j lookahead <- item1+ , let from = indexItem "lr0GotoTable(from)" lr0items item1+ , let ri = indexPrule augCfg (ProductionRule y ys)+ , let ys' = drop j ys+ , let h = head ys'+ , let to = indexItem "lr0GotoTable(to)" lr0items (goto augCfg item1 h)+ , ys' /= []+ ] + +calcSplk augCfg lr0kernelitems lr0GotoTable = + [ (Item prule2 dot2 [], toIndex, lookahead1, (fromIndex, toIndex, item0, lr1items, item1, item2)) + | (fromIndex, lr0kernelitem) <- zip [0..] lr0kernelitems -- take item for each LR(0) kernels+ , item0@(Item prule0 dot0 _) <- lr0kernelitem + + , let lr1items = closure augCfg [Item prule0 dot0 [sharpSymbol]] -- Take its LR(1) closure with #+ , item1@(Item prule1@(ProductionRule lhs rhs) dot1 lookahead1) <- lr1items+ , lookahead1 /= [sharpSymbol]++ , let therestrhs = drop dot1 rhs + , therestrhs /= []+ , let symbolx = head therestrhs+ , let toIndexes = [t | (f,x,t) <- lr0GotoTable, f==fromIndex, x==symbolx ]+ , toIndexes /= []+ , let toIndex = head toIndexes++ , let gotoIX = lr0kernelitems !! toIndex -- for each item in GoTo(I,X)+ , item2@(Item prule2 dot2 lookahead2) <- gotoIX+ , prule1 == prule2+ ] ++calcProp augCfg lr0kernelitems lr0GotoTable = + [ (Item prule0 dot0 [], fromIndex, Item prule2 dot2 [], toIndex) + | (fromIndex, lr0kernelitem) <- zip [0..] lr0kernelitems -- take item for each LR(0) kernels+ , Item prule0 dot0 _ <- lr0kernelitem + + , let lr1items = closure augCfg [Item prule0 dot0 [sharpSymbol]] -- Take its LR(1) closure with #+ , Item prule1@(ProductionRule lhs rhs) dot1 lookahead1 <- lr1items+ , lookahead1 == [sharpSymbol]++ , let therestrhs = drop dot1 rhs + , therestrhs /= []+ , let symbolx = head therestrhs+ , let toIndexes = [t | (f,x,t) <- lr0GotoTable, f==fromIndex, x==symbolx ]+ , toIndexes /= []+ , let toIndex = head toIndexes++ , let gotoIX = lr0kernelitems !! toIndex -- for each item in GoTo(I,X)+ , Item prule2 dot2 lookahead2 <- gotoIX+ , prule1 == prule2+ ] ++calcEfficientLALRActionGotoTable augCfg items = (actionTable, gotoTable)+ where+ CFG _S' prules = augCfg+ -- items = calcLR1Items augCfg+ -- syms = (\\) (symbols augCfg) [Nonterminal _S']+ + -- terminalSyms = [Terminal x | Terminal x <- syms]+ -- nonterminalSyms = [Nonterminal x | Nonterminal x <- syms]+ + f :: [(ActionTable,GotoTable)] -> (ActionTable, GotoTable)+ f l = case unzip l of (fst,snd) -> (g [] (concat fst), h [] (concat snd))+ + g actTbl [] = actTbl+ g actTbl ((i,x,a):triples) = + let bs = [a' == a | (i',x',a') <- actTbl, i' == i && x' == x ] in+ if length bs == 0+ then g (actTbl ++ [(i,x,a)]) triples+ else if and bs + then g actTbl triples + else error ("Conflict: " + ++ show (i,x,a) + ++ " " + ++ show actTbl)+ + h :: GotoTable -> GotoTable -> GotoTable+ h gtTbl [] = gtTbl+ h gtTbl ((i,x,j):triples) =+ let bs = [j' == j | (i',x',j') <- gtTbl, i' == i && x' == x ] in+ if length bs == 0+ then h (gtTbl ++ [(i,x,j)]) triples+ else if and bs+ then h gtTbl triples+ else error ("Conflict: "+ ++ show (i,x,j)+ ++ " "+ ++ show gtTbl)+ + mkLr0 (Item prule dot _) = Item prule dot [] ++ itemsInLr0 = map (nub . map mkLr0) items ++ (actionTable, gotoTable) = f+ [ if ys' == []+ then if y == _S' && a == EndOfSymbol+ then ([(from, a, Accept) ], []) + else ([(from, a, Reduce ri)], [])+ else if isTerminal h + then ([(from, Symbol h, Shift to) ], [])+ else ([] , [(from, h, to)])+ | (from,item1) <- zip [0..] items -- Optimization: (from,item1) <- zip [0..] items+ , Item (ProductionRule y ys) j [a] <- item1+ -- , let from = indexItem "lr1ActionGotoTable(from)" items item1+ , let ri = indexPrule augCfg (ProductionRule y ys)+ , let ys' = drop j ys+ , let h = head ys'+ , let to = indexItem "lr1ActionGotoTable(to)" itemsInLr0 (goto augCfg (nub $ map mkLr0 item1) h)+ ]++type Lookahead = [ExtendedSymbol] +type SpontaneousLookahead = [(Item, Int, Lookahead)]+type PropagateLookahead = [(Item, Int, Item, Int)]++computeLookaheads :: SpontaneousLookahead -> PropagateLookahead -> Itemss -> Itemss+computeLookaheads splk prlk lr0kernelitemss = lr1kernelitemss+ where+ lr1kernelitemss = + [ concat [ if lookaheads == [] then [Item prule dot []]+ else [ Item prule dot lookahead | lookahead <- lookaheads ] + | (Item prule dot _, lookaheads) <- itemlks ]+ | itemlks <- lr1kernelitemlkss ]++ initLr1kernelitemlkss = init (zip [0..] lr0kernelitemss)+ lr1kernelitemlkss = snd (unzip (prop initLr1kernelitemlkss))++ init [] = []+ init ((index,items):iitemss) = (index, init' index items) : init iitemss + + init' index [] = []+ init' index (item:items) = (item, init'' index item [] splk ) : init' index items++ init'' index itembase lookaheads [] = lookaheads + init'' index itembase lookaheads ((splkitem,loc,lookahead):splkitems) = + if index == loc && itembase == splkitem + then init'' index itembase (lookaheads ++ [lookahead]) splkitems + else init'' index itembase lookaheads splkitems ++ prop ilr1kernelitemlkss = + let itemToLks = collect ilr1kernelitemlkss prlk + (changed, ilr1kernelitemlkss') = + copy ilr1kernelitemlkss itemToLks+ in if changed then prop ilr1kernelitemlkss'+ else ilr1kernelitemlkss++ collect ilr1kernelitemlkss [] = []+ collect ilr1kernelitemlkss (itemFromTo:itemFromTos) = + let (itemFrom, fromIndex, itemTo, toIndex) = itemFromTo + lookaheads = collect' itemFrom fromIndex [] ilr1kernelitemlkss + in (itemTo, toIndex, lookaheads) : collect ilr1kernelitemlkss itemFromTos++ collect' itemFrom fromIndex lookaheads [] = lookaheads+ collect' itemFrom fromIndex lookaheads ((index, iitemlks):iitemlkss) = + if fromIndex == index + then collect' itemFrom fromIndex + (collect'' itemFrom lookaheads iitemlks) iitemlkss+ else collect' itemFrom fromIndex lookaheads iitemlkss++ collect'' itemFrom lookaheads [] = lookaheads+ collect'' itemFrom lookaheads ((Item prule dot _, lks):itemlks) = + let Item pruleFrom dotFrom _ = itemFrom+ lookaheads' = if pruleFrom == prule && dotFrom == dot + then lks else []+ in collect'' itemFrom (lookaheads ++ lookaheads') itemlks+ + copy iitemlkss [] = (False, iitemlkss)+ copy iitemlkss (itemToLookahead:itemToLookaheads) = + let (changed1, iitemlkss1) = copy' iitemlkss itemToLookahead+ (changed2, iitemlkss2) = copy iitemlkss1 itemToLookaheads + in (changed1 || changed2, iitemlkss2) ++ copy' [] itemToLookahead = (False, [])+ copy' ((index,itemlks):iitemlkss) itemToLookahead = + let (changed1, itemlks1) = copy'' index itemlks itemToLookahead + (changed2, itemlkss2) = copy' iitemlkss itemToLookahead+ in (changed1 || changed2, (index,itemlks1):itemlkss2)++ copy'' index [] itemToLookahead = (False, [])+ copy'' index (itemlk:itemlks) itemToLookahead = + let (Item prule1 dot1 _, toIndex, lookahead1) = itemToLookahead+ (Item prule2 dot2 l2, lookahead2) = itemlk + lookahead2' = + if prule1 == prule2 && dot1 == dot2 + && index == toIndex+ && lookahead1 \\ lookahead2 /= []+ then nub (lookahead1 ++ lookahead2) else lookahead2+ changed1 = lookahead2' /= lookahead2+ itemlk1 = (Item prule2 dot2 l2, lookahead2')+ (changed2, itemlks2) = copy'' index itemlks itemToLookahead+ in (changed1 || changed2, itemlk1:itemlks2) +++prLkhTable [] = return ()+prLkhTable ((spontaneous, propagate):lkhTable) = do + prSpontaneous spontaneous+ prPropagate propagate+ prLkhTable lkhTable++prSpontaneous [] = return ()+prSpontaneous ((item, loc, [lookahead]):spontaneous) = do + putStr (show item ++ " at " ++ show loc)+ putStr ", "+ putStrLn (show lookahead)+ prSpontaneous spontaneous++prPropagate [] = return ()+prPropagate ((from, fromIndex, to, toIndex):propagate) = do + putStr (show from ++ " at " ++ show fromIndex)+ putStr " -prop-> "+ putStr (show to ++ " at " ++ show toIndex) + putStrLn ""+ prPropagate propagate++-----+calcLR1ParseTable :: AUGCFG -> (Itemss, ProductionRules, ActionTable, GotoTable)+calcLR1ParseTable augCfg = (items, prules, actionTable, gotoTable)+ where+ CFG _S' prules = augCfg+ items = calcLR1Items augCfg+ (actionTable, gotoTable) = calcLR1ActionGotoTable augCfg items ++calcLR1ActionGotoTable augCfg items = (actionTable, gotoTable)+ where+ CFG _S' prules = augCfg+ -- items = calcLR1Items augCfg+ -- syms = (\\) (symbols augCfg) [Nonterminal _S']+ + -- terminalSyms = [Terminal x | Terminal x <- syms]+ -- nonterminalSyms = [Nonterminal x | Nonterminal x <- syms]+ + f :: [(ActionTable,GotoTable)] -> (ActionTable, GotoTable)+ f l = case unzip l of (fst,snd) -> (g [] (concat fst), h [] (concat snd))+ + g actTbl [] = actTbl+ g actTbl ((i,x,a):triples) = + let bs = [a' == a | (i',x',a') <- actTbl, i' == i && x' == x ] in+ if length bs == 0+ then g (actTbl ++ [(i,x,a)]) triples+ else if and bs + then g actTbl triples + else error ("Conflict: " + ++ show (i,x,a) + ++ " " + ++ show actTbl)+ + h :: GotoTable -> GotoTable -> GotoTable+ h gtTbl [] = gtTbl+ h gtTbl ((i,x,j):triples) =+ let bs = [j' == j | (i',x',j') <- gtTbl, i' == i && x' == x ] in+ if length bs == 0+ then h (gtTbl ++ [(i,x,j)]) triples+ else if and bs+ then h gtTbl triples+ else error ("Conflict: "+ ++ show (i,x,j)+ ++ " "+ ++ show gtTbl)++ (actionTable, gotoTable) = f+ [ if ys' == []+ then if y == _S' + then ([(from, a, Accept) ], []) + else ([(from, a, Reduce ri)], [])+ else if isTerminal h + then ([(from, Symbol h, Shift to) ], [])+ else ([] , [(from, h, to)])+ | item1 <- items -- Optimization: (from,item1) <- zip [0..] items+ , Item (ProductionRule y ys) j [a] <- item1+ , let from = indexItem "lr1ActionGotoTable(from)" items item1+ , let ri = indexPrule augCfg (ProductionRule y ys) -- Can be optimzied?+ , let ys' = drop j ys+ , let h = head ys'+ , let to = indexItem "lr1ActionGotoTable(to)" items (goto augCfg item1 h)+ ]+ +prParseTable h (items, prules, actTbl, gtTbl) =+ do hPutStrLn h (show (length items) ++ " states")+ prItems h items+ hPutStrLn h ""+ prPrules h prules+ hPutStrLn h ""+ prActTbl h actTbl+ hPutStrLn h ""+ prGtTbl h gtTbl+ +prLALRParseTable h (items, prules, iss, lalrActTbl, lalrGtTbl) =+ do hPutStrLn h (show (length items) ++ " states")+ prItems h items+ hPutStrLn h ""+ prPrules h prules+ hPutStrLn h ""+ hPutStrLn h (show (length iss) ++ " states")+ prStates h iss+ hPutStrLn h ""+ prActTbl h lalrActTbl+ hPutStrLn h ""+ prGtTbl h lalrGtTbl+ +prStates h [] = return () +prStates h (is:iss) =+ do hPutStrLn h (show is)+ prStates h iss+ +--------------------------------------------------------------------------------+-- LALR Parser +--------------------------------------------------------------------------------++calcLALRParseTable :: AUGCFG -> + (Itemss, ProductionRules, [[Int]], LALRActionTable+ , LALRGotoTable)+calcLALRParseTable augCfg = (itemss, prules, iss, lalrActTbl, lalrGtTbl)+ where+ (itemss, prules, actTbl, gtTbl) = calcLR1ParseTable augCfg+ itemss' = nubBy eqCore itemss+ iss = [ [i | (i, items) <- zip [0..] itemss, eqCore items items']+ | items' <- itemss'] + + lalrActTbl = [ (is, x, lalrAct)+ | is <- iss+ , let syms = nub [ y | i <- is, (j, y, a) <- actTbl, i == j ]+ , x <- syms+ , let lalrAct = actionCheck $+ nub [ toLalrAction iss a+ | i <- is+ , let r = lookupTable i x actTbl+ , isJust r+ , let Just a = r ] ]++ lalrGtTbl = [ (is, x, js) + | is <- iss+ , let syms = nub [ y | i <- is, (j, y, k) <- gtTbl, i == j]+ , x <- syms+ , let js = stateCheck $ + nub [ toIs iss j'+ | i <- is+ , (i', x', j') <- gtTbl+ , i==i' && x==x' ] ]+ +eqCore :: Items -> Items -> Bool +eqCore items1 items2 = subsetCore items1 items2 && subsetCore items2 items1++subsetCore [] items2 = True+subsetCore (item1:items1) items2 = elemCore item1 items2 && subsetCore items1 items2+ +elemCore (Item prule1 i1 a) [] = False+elemCore (Item prule1 i1 a) (Item prule2 i2 _:items) = + if prule1 == prule2 && i1 == i2 + then True else elemCore (Item prule1 i1 a) items+ +toLalrAction :: [[Int]] -> Action -> LALRAction+toLalrAction iss (Shift i) = LALRShift (toIs iss i)+toLalrAction iss (Reduce i) = LALRReduce i+toLalrAction iss (Accept) = LALRAccept+toLalrAction iss (Reject) = LALRReject++toIs [] i = error ("toIs: not found" ++ show i)+toIs (is:iss) i = if elem i is then is else toIs iss i++actionCheck :: [LALRAction] -> LALRAction+actionCheck [a] = a+actionCheck as = error ("LALR Action Conflict: " ++ show as)++stateCheck :: [[Int]] -> [Int]+stateCheck [is] = is+stateCheck iss = error ("LALR State Conflict: " ++ show iss)
+ src/gentable/ParserTable.hs view
@@ -0,0 +1,87 @@+module ParserTable where++import CFG++import System.IO++-- LR(1) item+data Item = Item ProductionRule Int [ExtendedSymbol] {- except Epsilon -}+ deriving Eq+ +type Items = [Item]+type Itemss = [Items]++instance Show Item where+ showsPrec p (Item (ProductionRule x syms) j [])+ = (++) "[" + . (++) x+ . (++) " -> "+ . show_ys (take j syms)+ . (++) "." + . show_ys (drop j syms)+ . (++) "]"+ showsPrec p (Item (ProductionRule x syms) j [esym])+ = (++) "[" + . (++) x+ . (++) " -> "+ . show_ys (take j syms)+ . (++) "." + . show_ys (drop j syms)+ . (++) ", "+ . (++) (show esym)+ . (++) "]"+ +prItem :: Handle -> Items -> IO ()+prItem h xs = do prItem' h xs+ hPutStrLn h ""+ where+ prItem' h [] = return ()+ prItem' h (x:xs) = do hPutStrLn h (show x)+ prItem' h xs+ + +prItems :: Handle -> Itemss -> IO ()+prItems h xs = prItems' h 0 xs++prItems' h n [] = return ()+prItems' h n (is:iss) =+ do hPutStrLn h ("I" ++ show n ++ ":")+ prItem h is+ prItems' h (n+1) iss+++isKernel :: String -> Item -> Bool+isKernel startnonterminal (Item (ProductionRule lhs rhs) dot lookahead) =+ dot /= 0 || startnonterminal == lhs++-- LR(1) Table +data Action = Shift Int | Reduce Int | Accept | Reject+ deriving (Show, Eq)+ +type ActionTable = [(Int, ExtendedSymbol, Action)] -- state, terminal, action+type GotoTable = [(Int, Symbol, Int)] -- state, nonterminal, state++lookupTable :: (Eq a, Eq b) => a -> b -> [(a,b,c)] -> Maybe c+lookupTable i x [] + = Nothing +lookupTable i x ((j,y,a):tbl)+ = if i == j && x == y then Just a + else lookupTable i x tbl+ +prActTbl h [] = return ()+prActTbl h ((i,x,a):actTbl) = + do hPutStrLn h (show i ++ "\t" ++ show x ++ "\t" ++ show a)+ prActTbl h actTbl+ +prGtTbl h [] = return () +prGtTbl h ((i,x,j):gtTbl) =+ do hPutStrLn h (show i ++ "\t" ++ show x ++ "\t" ++ show j)+ prActTbl h gtTbl+++-- LALR(1) Table+data LALRAction = LALRShift [Int] | LALRReduce Int | LALRAccept | LALRReject+ deriving (Show, Eq)+ +type LALRActionTable = [([Int], ExtendedSymbol, LALRAction)]+type LALRGotoTable = [([Int], Symbol, [Int])]
+ src/gentable/SampleGrammar.hs view
@@ -0,0 +1,174 @@+module SampleGrammar where++import CFG++--------------------------------------------------------------------------------+-- [Sample CFG Grammar] : g1 from Example 4.33 in the Dragon book (2nd Ed.)+--------------------------------------------------------------------------------+g1 = CFG "E'" [p0,p1,p2,p3,p4,p5,p6]++-- E' -> E+p0 = ProductionRule "E'" [Nonterminal "E"]++-- E -> E + T+p1 = ProductionRule "E" [Nonterminal "E", Terminal "+", Nonterminal "T"] ++-- E -> T+p2 = ProductionRule "E" [Nonterminal "T"]++-- T -> T * F+p3 = ProductionRule "T" [Nonterminal "T", Terminal "*", Nonterminal "F"]++-- T -> F+p4 = ProductionRule "T" [Nonterminal "F"]++-- F -> ( E )+p5 = ProductionRule "F" [Terminal "(", Nonterminal "E", Terminal ")"]++-- F -> id+p6 = ProductionRule "F" [Terminal "id"]++--------------------------------------------------------------------------------+-- [Sample CFG Grammar] : g2 from Example 4.2 in the Dragon book (2nd Ed.)+--------------------------------------------------------------------------------+g2 = CFG "S'" [q1,q2,q3,q4]++q1 = ProductionRule "S'" [Nonterminal "S"]+q2 = ProductionRule "S" [Nonterminal "C", Nonterminal "C"]+q3 = ProductionRule "C" [Terminal "c", Nonterminal "C"]+q4 = ProductionRule "C" [Terminal "d"]++--------------------------------------------------------------------------------+-- [Sample CFG Grammar] : g3 from the LF calculus+--------------------------------------------------------------------------------+g3 = CFG "S'" [lfp0,lfp1,lfp2,lfp5,lfp6,lfp7,lfp8,lfp9,lfp10,lfp11+ ,lfp12,lfp13,lfp14,lfp15,lfp16,lfp17,lfp18,lfp19,lfp20,lfp21+ ,lfp22,lfp23,lfp24,lfp25,lfp26,lfp27,lfp28,lfp29,lfp30,lfp31]++lfp0 = ProductionRule "S'" [Nonterminal "Program"]+lfp1 = ProductionRule "Program" [Nonterminal "Decl"]++lfp2 = ProductionRule "Decl" [Nonterminal "TypeDeclaration", + Nonterminal "TermDeclaration", + Nonterminal "DefDeclaration"]++lfp5 = ProductionRule "TypeDeclaration" + [Terminal "atType", Nonterminal "TyDecls"]+lfp6 = ProductionRule "TermDeclaration"+ [Terminal "atTerm", Nonterminal "TmDecls"]+lfp7 = ProductionRule "DefDeclaration" []+lfp8 = ProductionRule "DefDeclaration"+ [Terminal "atDef", Nonterminal "DefDecls"]+ +lfp9 = ProductionRule "TyDecls"+ [Terminal "var", Terminal ":", Nonterminal "K", Terminal "." ]+lfp10 = ProductionRule "TyDecls"+ [Terminal "var", Terminal ":", Nonterminal "K", Terminal "."+ , Nonterminal "TyDecls" ]+ +lfp11 = ProductionRule "TmDecls"+ [Terminal "var", Terminal ":", Nonterminal "A", Terminal "." ]+lfp12 = ProductionRule "TmDecls"+ [Terminal "var", Terminal ":", Nonterminal "A", Terminal "."+ , Nonterminal "TmDecls" ]+ +lfp13 = ProductionRule "DefDecls"+ [Terminal "var", Terminal "=", Nonterminal "M", Terminal "." ]+lfp14 = ProductionRule "DefDecls"+ [Terminal "var", Terminal "=", Nonterminal "M", Terminal "."+ , Nonterminal "DefDecls" ]+ +lfp15 = ProductionRule "K" [Terminal "Type"]+lfp16 = ProductionRule "K" [Terminal "Pi", Terminal "var", Terminal ":"+ , Nonterminal "A", Terminal ".", Nonterminal "K"]+lfp17 = ProductionRule "K" [Terminal "(", Nonterminal "K", Terminal ")"] +lfp18 = ProductionRule "K" [Nonterminal "A1", Terminal "arrow", Nonterminal "K"]++lfp19 = ProductionRule "A" [Terminal "Pi", Terminal "var", Terminal ":"+ , Nonterminal "A", Terminal ".", Nonterminal "A"]+lfp20 = ProductionRule "A" [Nonterminal "A1"] +lfp21 = ProductionRule "A" [Nonterminal "A1", Terminal "arrow", Nonterminal "A"]++lfp22 = ProductionRule "A1" [Terminal "var"]+lfp23 = ProductionRule "A1" [Terminal "(", Nonterminal "A", Terminal ")"]+lfp24 = ProductionRule "A1" [Nonterminal "A1", Terminal "var"]+lfp25 = ProductionRule "A1" [Nonterminal "A1", Terminal "(", Nonterminal "M"+ , Terminal ")"]+ +lfp26 = ProductionRule "M" [Terminal "Lam", Terminal "var", Terminal ":", + Nonterminal "A", Terminal ".", Nonterminal "M"]+lfp27 = ProductionRule "M" [Nonterminal "M1"]++lfp28 = ProductionRule "M1" [Terminal "var"]+lfp29 = ProductionRule "M1" [Terminal "(", Nonterminal "M", Terminal ")"]+lfp30 = ProductionRule "M1" [Nonterminal "M1", Terminal "var"]+lfp31 = ProductionRule "M1" [Nonterminal "M1", Terminal "(", Nonterminal "M",+ Terminal ")"]+ +type SemRuleName = String+data SemanticRule = SemanticRule SemRuleName [Int]+ +lfs0 = SemanticRule "DoNothing" []+lfs1 = SemanticRule "DoNothing" []+lfs2 = SemanticRule "DoNothing" []+lfs5 = SemanticRule "DoNothing" []+lfs6 = SemanticRule "DoNothing" []+lfs7 = SemanticRule "DoNothing" []+lfs8 = SemanticRule "DoNothing" []++lfs9 = SemanticRule "DeclK" [1,3]+lfs10 = SemanticRule "DeclK" [1,3]+lfs11 = SemanticRule "DeclA" [1,3]+lfs12 = SemanticRule "DeclA" [1,3]+lfs13 = SemanticRule "DeclM" [1,3]+lfs14 = SemanticRule "DeclM" [1,3]++lfs15 = SemanticRule "MkType" []+lfs16 = SemanticRule "MkPiK" [2,4,6]+lfs17 = SemanticRule "ReturnK" [2]+lfs18 = SemanticRule "MkArrowK" [1,3]+lfs19 = SemanticRule "MkPiA" [2,4,6]+lfs20 = SemanticRule "ReturnA" [1]+lfs21 = SemanticRule "MkArrowA" [1,3]+lfs22 = SemanticRule "MkName" [1]+lfs23 = SemanticRule "ReturnA" [2]+lfs24 = SemanticRule "MkAppA" [1,2]+lfs25 = SemanticRule "MkAppA" [1,3]+lfs26 = SemanticRule "MkLamM" [2,4,6]+lfs27 = SemanticRule "ReturnM" [1]+lfs28 = SemanticRule "MkName" [1]+lfs29 = SemanticRule "ReturnM" [2]+lfs30 = SemanticRule "MkAppM" [1,2]+lfs31 = SemanticRule "MkAppM" [1,3]++-- The attributes of terminals in g3+g3_attrib_terminals =+ [ ("Type", "TYPE")+ , ("Pi", "PI")+ , ("Lam", "LAM")+ , (":", "COLON")+ , (".", "DOT")+ + , ("(", "OPEN")+ , (")", "CLOSE")+ , ("=", "EQ")+ , ("arrow", "ARROW")+ , ("atType", "ATTYPE")+ + , ("atTerm", "ATTERM")+ , ("atDef", "ATDEF") + , ("var", "VAR")+ , ("num", "NUM")+ ]++++g4 :: CFG+g4 = CFG "S'" [ g4_0, g4_s1, g4_s2, g4_l1, g4_l2, g4_r ]+ where+ g4_0 = ProductionRule "S'" [Nonterminal "S"]+ g4_s1 = ProductionRule "S" [ Nonterminal "L", Terminal "=", Nonterminal "R" ]+ g4_s2 = ProductionRule "S" [ Nonterminal "R" ]+ g4_l1 = ProductionRule "L" [ Terminal "*", Nonterminal "R" ]+ g4_l2 = ProductionRule "L" [ Terminal "id" ]+ g4_r = ProductionRule "R" [ Nonterminal "L" ]
+ src/parserlib/AutomatonType.hs view
@@ -0,0 +1,8 @@+module AutomatonType where++data Action = Shift Int | Reduce Int | Accept deriving Eq++type ActionTable = [((Int, String), Action)] -- key: (Int,String), value: Action+type GotoTable = [((Int, String), Int)] -- key: (Int,String), value: Int+type ProdRules = [(String, [String])] -- key: Int, value: (String, [String])+
+ src/parserlib/CommonParserUtil.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE GADTs #-}+module CommonParserUtil where++import Terminal+import TokenInterface++import Text.Regex.TDFA+import System.Exit+import System.Process+import Control.Monad++import Data.Typeable+import Control.Exception++import SaveProdRules+import AutomatonType+import LoadAutomaton++-- Lexer Specification+type RegExpStr = String+type LexFun token = String -> Maybe token ++type LexerSpecList token = [(RegExpStr, LexFun token)]+data LexerSpec token =+ LexerSpec { endOfToken :: token,+ lexerSpecList :: LexerSpecList token+ }++-- Parser Specification+type ProdRuleStr = String+type ParseFun token ast = Stack token ast -> ast++type ParserSpecList token ast = [(ProdRuleStr, ParseFun token ast)]+data ParserSpec token ast =+ ParserSpec { startSymbol :: String,+ parserSpecList :: ParserSpecList token ast,+ baseDir :: String, -- ex) ./+ actionTblFile :: String, -- ex) actiontable.txt+ gotoTblFile :: String, -- ex) gototable.txt+ grammarFile :: String, -- ex) grammar.txt+ parserSpecFile :: String, -- ex) mygrammar.grm+ genparserexe :: String -- ex) yapb-exe+ }++-- Specification+data Spec token ast =+ Spec (LexerSpec token) (ParserSpec token ast)++-------------------------------------------------------------------------------- +-- The lexing machine+-------------------------------------------------------------------------------- +type Line = Int+type Column = Int++--+data LexError = LexError Int Int String -- Line, Col, Text+ deriving (Typeable, Show)++instance Exception LexError++prLexError (LexError line col text) = do+ putStr $ "No matching lexer spec at "+ putStr $ "Line " ++ show line+ putStr $ "Column " ++ show col+ putStr $ " : "+ putStr $ take 10 text++--+lexing :: TokenInterface token =>+ LexerSpec token -> String -> IO [Terminal token]+lexing lexerspec text = lexing_ lexerspec 1 1 text++lexing_ :: TokenInterface token =>+ LexerSpec token -> Line -> Column -> String -> IO [Terminal token]+lexing_ lexerspec line col [] = do+ let eot = endOfToken lexerspec + return [Terminal (fromToken eot) line col eot]+ +lexing_ lexerspec line col text = do+ (matchedText, theRestText, maybeTok) <-+ matchLexSpec line col (lexerSpecList lexerspec) text+ let (line_, col_) = moveLineCol line col matchedText+ terminalList <- lexing_ lexerspec line_ col_ theRestText+ case maybeTok of+ Nothing -> return terminalList+ Just tok -> do+ let terminal = Terminal matchedText line col tok+ return (terminal:terminalList)++matchLexSpec :: TokenInterface token =>+ Line -> Column -> LexerSpecList token -> String+ -> IO (String, String, Maybe token)+matchLexSpec line col [] text = do+ throw (LexError line col text)+ -- putStr $ "No matching lexer spec at "+ -- putStr $ "Line " ++ show line+ -- putStr $ "Column " ++ show col+ -- putStr $ " : "+ -- putStr $ take 10 text+ -- exitWith (ExitFailure (-1))++matchLexSpec line col ((aSpec,tokenBuilder):lexerspec) text = do+ let (pre, matched, post) = text =~ aSpec :: (String,String,String)+ case pre of+ "" -> return (matched, post, tokenBuilder matched)+ _ -> matchLexSpec line col lexerspec text+++moveLineCol :: Line -> Column -> String -> (Line, Column)+moveLineCol line col "" = (line, col)+moveLineCol line col ('\n':text) = moveLineCol (line+1) 1 text+moveLineCol line col (ch:text) = moveLineCol line (col+1) text+ +-------------------------------------------------------------------------------- +-- The parsing machine+--------------------------------------------------------------------------------++--+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+ + -- 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++ deriving (Typeable)++instance (Show token, Show ast) => Show (ParseError token ast) where+ showsPrec p (NotFoundAction terminal state stack _ _) =+ (++) "NotFoundAction" . (++) (terminalToString terminal) . (++) (show state) -- . (++) (show 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+ putStrLn $+ ("Not found in the action table: "+ ++ terminalToString terminal)+ ++ " : "+ ++ show (state, tokenTextFromTerminal terminal)+ ++ "\n" ++ prStack stack ++ "\n"+ +prParseError (NotFoundGoto topState lhs stack actiontbl gototbl) = do+ putStrLn $+ ("Not found in the goto table: ")+ ++ " : "+ ++ show (topState,lhs) ++ "\n"+ ++ prStack stack ++ "\n"++--+parsing :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ ParserSpec token ast -> [Terminal token] -> IO ast+parsing parserSpec terminalList = do+ -- 1. Save the production rules in the parser spec (Parser.hs).+ writtenBool <- saveProdRules specFileName sSym pSpecList++ -- 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+ when writtenBool generateAutomaton++ -- 3. Load automaton files (prod_rules/action_table/goto_table.txt)+ (actionTbl, gotoTbl, prodRules) <-+ 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++ where+ specFileName = parserSpecFile parserSpec+ grammarFileName = grammarFile parserSpec+ actionTblFileName = actionTblFile parserSpec+ gotoTblFileName = gotoTblFile parserSpec+ executable = genparserexe parserSpec+ + sSym = startSymbol parserSpec+ pSpecList = map fst (parserSpecList parserSpec)+ pFunList = map snd (parserSpecList parserSpec)++ generateAutomaton = do+ exitCode <- rawSystem "stack"+ [ "exec", "--",+ executable, specFileName, "-output",+ grammarFileName, actionTblFileName, gotoTblFileName+ ]+ case exitCode of+ ExitFailure code -> exitWith exitCode+ ExitSuccess -> putStrLn ("Successfully generated: " +++ actionTblFileName ++ ", " +++ gotoTblFileName ++ ", " +++ grammarFileName);++-- Stack++data StkElem token ast =+ StkState Int+ | StkTerminal (Terminal token)+ | StkNonterminal ast String -- String for printing Nonterminal instead of ast++type Stack token ast = [StkElem token ast]++emptyStack = []++get :: Stack token ast -> Int -> ast+get stack i =+ case stack !! (i-1) of+ StkNonterminal ast _ -> ast+ _ -> error $ "get: out of bound: " ++ show i++getText :: Stack token ast -> Int -> String+getText stack i = + case stack !! (i-1) of+ StkTerminal (Terminal text _ _ _) -> text+ _ -> error $ "getText: out of bound: " ++ show i++push :: a -> [a] -> [a]+push elem stack = elem:stack++pop :: [a] -> (a, [a])+pop (elem:stack) = (elem, stack)+pop [] = error "Attempt to pop from the empty stack"++prStack :: TokenInterface token => Stack token ast -> String+prStack [] = "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++-- Utility for Automation+currentState :: Stack token ast -> Int+currentState (StkState i : stack) = i+currentState _ = error "No state found in the stack top"++tokenTextFromTerminal :: TokenInterface token => Terminal token -> String+tokenTextFromTerminal (Terminal _ _ _ token) = fromToken token++lookupActionTable :: TokenInterface token => ActionTable -> Int -> (Terminal token) -> Maybe Action+lookupActionTable actionTbl state terminal =+ lookupTable actionTbl (state,tokenTextFromTerminal terminal)+ ("Not found in the action table: " ++ terminalToString terminal) ++lookupGotoTable :: GotoTable -> Int -> String -> Maybe Int+lookupGotoTable gotoTbl state nonterminalStr =+ lookupTable gotoTbl (state,nonterminalStr)+ ("Not found in the goto table: ")++lookupTable :: (Eq a, Show a) => [(a,b)] -> a -> String -> Maybe b+lookupTable tbl key msg = + case [ val | (key', val) <- tbl, key==key' ] of+ [] -> Nothing -- error $ msg ++ " : " ++ show key+ (h:_) -> Just h+++-- Note: take 1th, 3rd, 5th, ... of 2*len elements from stack and reverse it!+-- example) revTakeRhs 2 [a1,a2,a3,a4,a5,a6,...]+-- = [a4, a2]+revTakeRhs :: Int -> [a] -> [a]+revTakeRhs 0 stack = []+revTakeRhs n (_:nt:stack) = revTakeRhs (n-1) stack ++ [nt]++-- Automaton++runAutomaton :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ {- static part -}+ ActionTable -> GotoTable -> ProdRules -> [ParseFun token ast] -> + {- dynamic part -}+ [Terminal token] ->+ {- AST -}+ IO ast+runAutomaton actionTbl gotoTbl prodRules pFunList terminalList = do+ let initStack = push (StkState 0) emptyStack+ run terminalList initStack+ + where+ {- run :: TokenInterface token => [Terminal token] -> Stack token ast -> IO ast -}+ run terminalList stack = do+ let state = currentState stack+ let terminal = head terminalList+ let text = tokenTextFromTerminal terminal+ let action =+ case lookupActionTable actionTbl state terminal of+ Just action -> action+ Nothing -> throw (NotFoundAction terminal state stack actionTbl gotoTbl)+ -- error $ ("Not found in the action table: "+ -- ++ terminalToString terminal)+ -- ++ " : "+ -- ++ show (state, tokenTextFromTerminal terminal)+ -- ++ "\n" ++ prStack stack ++ "\n"+ + debug ("\nState " ++ show state)+ debug ("Token " ++ text)+ debug ("Stack " ++ prStack stack)+ + case action of+ Accept -> do+ debug "Accept"+ + case stack !! 1 of+ StkNonterminal ast _ -> return ast+ _ -> fail "Not Stknontermianl on Accept"+ + Shift toState -> do+ debug ("Shift " ++ show toState)+ + let stack1 = push (StkTerminal (head terminalList)) stack+ let stack2 = push (StkState toState) stack1+ run (tail terminalList) stack2+ + Reduce n -> do+ debug ("Reduce " ++ show n)+ + let prodrule = prodRules !! n+ + debug ("\t" ++ show prodrule)+ + let builderFun = pFunList !! n+ let lhs = fst prodrule+ let rhsLength = length (snd prodrule)+ let rhsAst = revTakeRhs rhsLength stack+ let ast = builderFun rhsAst+ let stack1 = drop (rhsLength*2) stack+ let topState = currentState stack1+ let toState =+ case lookupGotoTable gotoTbl topState lhs of+ Just state -> state+ Nothing -> throw (NotFoundGoto topState lhs stack actionTbl gotoTbl)+ -- error $ ("Not found in the goto table: ")+ -- ++ " : "+ -- ++ show (topState,lhs) ++ "\n"+ -- ++ prStack stack ++ "\n"+ + let stack2 = push (StkNonterminal ast lhs) stack1+ let stack3 = push (StkState toState) stack2+ run terminalList stack3++flag = False++debug :: String -> IO ()+debug msg = if flag then putStrLn msg else return ()++--+data Candidate =+ TerminalSymbol String+ | NonterminalSymbol String+ deriving Show++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+ + compCandidates+ (symbols++[NonterminalSymbol nonterminal]) snext actTbl gotoTbl) cand1+ 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]+
+ src/parserlib/LoadAutomaton.hs view
@@ -0,0 +1,132 @@+module LoadAutomaton where++import AutomatonType+import SaveProdRules(tokenizeLhs)+import System.IO++loadAutomaton :: String -> String -> String+ -> IO (ActionTable, GotoTable, ProdRules)+loadAutomaton grammarFileName actionTblFileName gotoTblFileName = do+ grammarStr <- readFile grammarFileName+ actionTblStr <- readFile actionTblFileName+ gotoTblStr <- readFile gotoTblFileName++ actionTbl <- loadActionTbl actionTblStr+ gotoTbl <- loadGotoTbl gotoTblStr+ prodRules <- loadProdRules grammarStr++ return (actionTbl, gotoTbl, prodRules)++-- Load action table+loadActionTbl :: String -> IO ActionTable+loadActionTbl str = tokenizeStateNumInAction str++tokenizeStateNumInAction :: String -> IO ActionTable+tokenizeStateNumInAction str = + case lex str of+ [] -> return []+ [("", therest)] -> return []+ [(stateNum, therest)] -> do+ (terminal, action, actTbl) <- tokenizeTerminalInAction therest+ return $ ((read stateNum :: Int, terminal), action) : actTbl++tokenizeTerminalInAction :: String -> IO (String, Action, ActionTable)+tokenizeTerminalInAction str =+ case lex str of+ [] -> fail "No terminal found (1)"+ [("", therest)] -> fail "No terminal found (2)"+ [(terminal, therest)] -> do+ (action, actTbl) <- tokenizeActioninAction therest+ return (terminal, action, actTbl)++tokenizeActioninAction :: String -> IO (Action, ActionTable)+tokenizeActioninAction str =+ case lex str of+ [] -> fail "No action found (1)"+ [("", therest)] -> fail "No action found (2)"+ [(action, therest)] -> do+ case action of+ "Shift" -> do+ tokenizeShiftReduceStateNumInAction therest Shift+ "Reduce" -> do+ tokenizeShiftReduceStateNumInAction therest Reduce+ "Accept" -> do+ actTbl <- tokenizeStateNumInAction therest+ return (Accept, actTbl)++tokenizeShiftReduceStateNumInAction :: String -> (Int -> Action)+ -> IO (Action, ActionTable)+tokenizeShiftReduceStateNumInAction str fn =+ case lex str of+ [] -> fail "No shift/reduce state number found (1)"+ [("", therest)] -> fail "No shift/reduce state number found (2)"+ [(stateNum, therest)] -> do+ actTbl <- tokenizeStateNumInAction therest+ return (fn (read stateNum :: Int), actTbl)+ ++-- Load goto table+loadGotoTbl :: String -> IO GotoTable+loadGotoTbl str = tokenizeStateNumInGoto str++tokenizeStateNumInGoto :: String -> IO GotoTable+tokenizeStateNumInGoto str =+ case lex str of+ [] -> return []+ [("", therest)] -> return []+ [(stateNum, therest)] -> do+ (nonterminal, toStateNum, actTbl) <- tokenizeNonterminalInGoto therest+ return $ ((read stateNum :: Int, nonterminal), read toStateNum :: Int) : actTbl++tokenizeNonterminalInGoto :: String -> IO (String, String, GotoTable)+tokenizeNonterminalInGoto str =+ case lex str of+ [] -> fail "No nonterminal found (1)"+ [("", therest)] -> fail "No nonterminal found (2)"+ [(nonterminal,therest)] -> do+ (toStateNum, actTbl) <- tokenizeToStateNumInGoto therest+ return (nonterminal, toStateNum, actTbl)++tokenizeToStateNumInGoto :: String -> IO (String, GotoTable)+tokenizeToStateNumInGoto str =+ case lex str of+ [] -> fail "No to-state found (1)"+ [("", therest)] -> fail "No to-state found (2)"+ [(toStateNum,therest)] -> do+ actTbl <- tokenizeStateNumInGoto therest+ return (toStateNum, actTbl)++-- Load production rules+loadProdRules :: String -> IO ProdRules+loadProdRules str = do+ numLhsRhsList <- mapM tokenizeNumInProdRules (splitWithCR str)+ return [ (lhs, rhs) | (i, lhs, rhs) <- numLhsRhsList ]++tokenizeNumInProdRules :: String -> IO (Int, String, [String])+tokenizeNumInProdRules str =+ case lex str of + [] -> fail "No rule number found (1)"+ [("", therest)] -> fail "No rule number found (2)"+ [(ruleNumStr, therest)] -> do+ (lhs, rhs) <- tokenizeColonInProdRules therest+ return (read ruleNumStr :: Int, lhs, rhs)++tokenizeColonInProdRules :: String -> IO (String, [String])+tokenizeColonInProdRules str =+ case lex str of+ [] -> fail "No colon found (1)"+ [("", therest)] -> fail "No colon found (2)"+ [(colon, therest)] -> do+ let lhsRhs = tokenizeLhs therest+ return (head lhsRhs, tail lhsRhs)+ ++splitWithCR :: String -> [String]+splitWithCR str =+ [ line | line <- splitWithCR' "" str, line /= "" ]++splitWithCR' :: String -> String -> [String]+splitWithCR' app [] = (reverse app) : []+splitWithCR' app ('\n':therest) = (reverse app) : splitWithCR' "" therest+splitWithCR' app (ch:therest) = splitWithCR' (ch : app) therest+
+ src/parserlib/SaveProdRules.hs view
@@ -0,0 +1,88 @@+module SaveProdRules where++import Data.Hashable+import System.IO+import System.Directory+import CFG++saveProdRules :: String -> String -> [String] -> IO Bool+saveProdRules fileName startSymbol prodRuleStrs = do+ writeOnceWithHash fileName grmStrLn+ where+ grmStr = toCFG startSymbol prodRuleStrs+ grmStrLn = grmStr ++ "\n"++toCFG :: String -> [String] -> String {- CFG -}+toCFG startSymbol prodRuleStrs =+ "CFG " ++ show startSymbol +++ " [\n" ++ concatWith (toProdRules prodRuleStrs) ",\n" ++ "\n ]"++toProdRules :: [String] -> [String] {- [ProductionRule] -}+toProdRules productionRuleStrs = map (toProdRule lhsStrs) lhsRhsStrss+ where+ lhsStrs = map head lhsRhsStrss+ lhsRhsStrss = map tokenizeLhs productionRuleStrs+ +toProdRule :: [String] -> [String] -> String {- ProductionRule -}+toProdRule lhsStrs (lhs:rhsStrs) =+ " ProductionRule " ++ show lhs +++ " [" ++ concatWith (map (toSymbol lhsStrs) rhsStrs) ", " ++ "]"++toSymbol :: [String] -> String -> String {- Symbol -}+toSymbol lhsStrs sym+ | sym `elem` lhsStrs = "Nonterminal " ++ show sym+ | otherwise = "Terminal " ++ show sym++-- Parse production rules+tokenizeLhs :: String -> [String]+tokenizeLhs str =+ case lex str of+ [] -> error "No lhs found (1)"+ [("",therest)] -> error "No lhs found (2)" + [(lhs,therest)] -> lhs : tokenizeArrow therest++tokenizeArrow :: String -> [String]+tokenizeArrow str =+ case lex str of+ [] -> error "No arrow found (1)"+ [("",therest)] -> error "No arrow found (2)" + [(arrow@"->",therest)] -> tokenizeRhs therest+ [(token,therest)] -> error ("No arrow found: " ++ token)+ +tokenizeRhs :: String -> [String]+tokenizeRhs str = + case lex str of+ [] -> []+ [("",therest)] -> []+ [(token,therest)] -> token : tokenizeRhs therest++-- Utility+concatWith :: [String] -> String -> String+concatWith [] sep = ""+concatWith [a] sep = a+concatWith (a:b:theRest) sep = a ++ sep ++ concatWith (b:theRest) sep++writeOnceWithHash :: String -> String -> IO Bool+writeOnceWithHash fileName text = do+ let hashFileName = fileName ++ ".hash"+ let newHash = hash text+ + fileExists <- doesFileExist fileName+ hashExists <- doesFileExist hashFileName++ case fileExists && hashExists of+ False -> do+ writeFile fileName text+ writeFile hashFileName (show newHash)+ return True++ True -> do+ existingHashStr <- readFile hashFileName+ + case newHash == (read existingHashStr :: Int) of+ True -> return False+ False -> do+ writeFile fileName text+ writeFile hashFileName (show newHash)+ return True+
+ src/parserlib/Terminal.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE GADTs #-}+module Terminal(Terminal(..), terminalToString) where++import TokenInterface++type Line = Int+type Column = Int++data Terminal token where+ Terminal :: TokenInterface token => String -> Line -> Column -> token -> Terminal token++terminalToString :: TokenInterface token => Terminal token -> String+terminalToString (Terminal text line col tok) =+ text ++ " at (" ++ show line ++ ", " ++ show col ++ "): " ++ fromToken tok
+ src/parserlib/TokenInterface.hs view
@@ -0,0 +1,10 @@+module TokenInterface where++class TokenInterface token where+ toToken :: String -> token+ fromToken :: token -> String+++ ++
+ src/util/ReadGrammar.hs view
@@ -0,0 +1,137 @@+module ReadGrammar where++import CFG++import Data.List(intersperse)+import System.IO+import System.Environment (getArgs)++data LitGrm = LitGrm { start :: Maybe String, rules :: [(String, [[String]])], rhss :: [[String]] }++readGrammar :: Monad m => [String] -> m (Maybe String, [ProductionRule])+readGrammar lines = do+ startLhsRhssPairList <- rep NoState lines+ let startsymbol = start startLhsRhssPairList+ let lhsRhssPairList = rules startLhsRhssPairList+ let nonterminals = map fst lhsRhssPairList+ return (startsymbol, concat (map (convert nonterminals) lhsRhssPairList))++-- Checking+convert :: [String] -> (String, [[String]]) -> [ProductionRule]+convert nonterminals (lhs, rhss) =+ map (\rhs -> ProductionRule lhs+ (map (\s -> if s `elem` nonterminals+ then Nonterminal s+ else Terminal s) rhs)) rhss++-- Parsing+data State =+ NoState+ | StartSymbol String+ | Lhs String+ | Rhs [[String]]+ deriving Eq++-- Note+-- * take the first word. After that, it may be regarded as a comment.+begin :: Monad m => [Char] -> m State+begin [] = return NoState+begin ('@':'s':'t':'a':'r':'t':' ':cs) = return (StartSymbol (takeWord cs))+begin (';':cs) = return NoState+begin (' ':' ':'=':[]) = return (Rhs [[]])+begin (' ':' ':'=':' ':cs) = return (Rhs [words cs])+begin (' ':' ':'|':' ':cs) = return (Rhs [words cs])+begin cs =+ let w = takeWord cs in+ case w of+ [] -> return NoState+ _ -> return (Lhs w)++takeWord :: String -> String+takeWord [] = []+takeWord (' ':cs) = []+takeWord ('\t':cs) = []+takeWord (c:cs) = c : takeWord cs++rep :: Monad m => State -> [String] -> m LitGrm+rep (Lhs lhs) [] = error "rep: Can't end with Lhs"+rep (_) [] = return $ LitGrm {start=Nothing, rules=[], rhss=[]}+rep prestate (s:ss) = do+ state <- begin s+ startLhsRhsPairList <- rep state ss+ case (prestate, state) of+ (NoState, NoState) -> return startLhsRhsPairList+ (NoState, StartSymbol s) -> + case start startLhsRhsPairList of+ Just s' -> error $ "rep: StartSymbol duplicated: " ++ s ++ ", " ++ s'+ Nothing -> return startLhsRhsPairList {start = Just s}+ (NoState, Lhs lhs) ->+ let rules_ = rules startLhsRhsPairList+ rhss_ = rhss startLhsRhsPairList+ in return startLhsRhsPairList { rules=(lhs,rhss_):rules_, rhss=[] }+ (NoState, Rhs rhss) -> error "rep: Nostate can't change to Rule lhs rhss."+ + (Lhs lhs, NoState) -> error $ "rep: Lhs " ++ lhs ++ " can't change to Nostate."+ (Lhs lhs, StartSymbol s) -> error $ "rep: Lhs " ++ lhs ++ " can't change to StartSymbol " ++ s+ (Lhs lhs, Lhs lhs') -> error $ "rep: Lhs " ++ lhs ++ " can't change to " ++ lhs'+ (Lhs lhs, Rhs rhss_) ->+ let rhss__ = rhss startLhsRhsPairList+ in return startLhsRhsPairList {rhss = rhss_ ++ rhss__}+ + (Rhs rhss, NoState) -> return startLhsRhsPairList+ (Rhs rhss, StartSymbol s) -> error $ "rep: Rhs can't change to StartSymbol " ++ s+ (Rhs _, Lhs _) -> error "rep: Rhs can't change to Lhs lhs."+ (Rhs _, Rhs rhss_) ->+ let rhss__ = rhss startLhsRhsPairList+ in return startLhsRhsPairList {rhss = rhss_ ++ rhss__}+ + (StartSymbol s, NoState) -> return startLhsRhsPairList+ (StartSymbol s, StartSymbol s') -> error $ "rep: StartSymbol duplicated(4): " ++ s ++ ", " ++ s'+ (StartSymbol s, Lhs lhs) ->+ let rules_ = rules startLhsRhsPairList+ rhss_ = rhss startLhsRhsPairList+ in return startLhsRhsPairList { rules=(lhs,rhss_):rules_, rhss=[] }+ (StartSymbol s, Rhs rhss) -> error $ "rep: StartSymbol " ++ s ++ " can't change to Rule"++----+-- For testing with grm/polyrpc.lgrm+-- ++test fun = do+ args <- getArgs+ repTest fun args++repTest fun [] = return ()+repTest fun (arg:args) = do+ text <- readFile arg+ fun text+ repTest fun args++parsing text = do+ startLhsRhssPairList <- rep NoState (lines text)+ let startsymbol = start startLhsRhssPairList+ let lhsRhssPairList = rules startLhsRhssPairList+ mapM_ (\(lhs,rhss) -> prLhsRhss lhs rhss) lhsRhssPairList++prLhsRhss :: String -> [[String]] -> IO ()+prLhsRhss lhs rhss = do+ putStrLn lhs+ mapM_ (\rhs ->+ do { putStr "\t"+ ; mapM_ (\s -> do {putStr s; putStr " "}) rhs+ ; putStrLn ""} ) rhss++conversion text = do+ (startsymbol_, prodrules_) <- readGrammar (lines text)+ case startsymbol_ of+ Nothing -> error "conversion: No start symbol"+ Just startsymbol ->+ do+ let startsymbol' = startsymbol ++ "'"+ let startprod = ProductionRule startsymbol' [ Nonterminal startsymbol ]+ let prodrules = startprod : prodrules_+ putStr $ "CFG " ++ show startsymbol' ++ " [\n "+ -- May replace prodRuleToStr with show+ putStrLn $ concat (intersperse ",\n " (map prodRuleToStr prodrules)) + putStrLn $ "]"+
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented. Refer to app/parser and app/polyrpc for your testing"
+ yapb.cabal view
@@ -0,0 +1,168 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: e881da2ea178ebd7058733e4799dcb71397d62fbd02354126f43a5f2eda11afc++name: yapb+version: 0.1.0+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+homepage: https://github.com/kwanghoon/yapb#readme+bug-reports: https://github.com/kwanghoon/yapb/issues+author: Kwanghoon Choi+maintainer: lazyswamp@gmail.com+copyright: 2020 Kwanghoon Choi+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/kwanghoon/yapb++library+ exposed-modules:+ CFG+ CmdArgs+ ParserTable+ GenLRParserTable+ SampleGrammar+ CodeGenC+ TokenInterface+ Terminal+ CommonParserUtil+ SaveProdRules+ AutomatonType+ LoadAutomaton+ ReadGrammar+ other-modules:+ Paths_yapb+ hs-source-dirs:+ src/gentable/+ src/parserlib/+ src/util/+ build-depends:+ base >=4.7 && <5+ , directory >=1.3.3 && <1.4+ , hashable >=1.3.0 && <1.4+ , process >=1.6.5 && <1.7+ , regex-tdfa >=1.3.1 && <1.4+ default-language: Haskell2010++executable conv-exe+ main-is: Main.hs+ other-modules:+ Paths_yapb+ hs-source-dirs:+ app/conv+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , yapb+ default-language: Haskell2010++executable parser-exe+ main-is: Main.hs+ other-modules:+ Lexer+ Parser+ Token+ Expr+ Paths_yapb+ hs-source-dirs:+ app/parser+ app/parser/ast+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , regex-tdfa+ , 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+ Paths_yapb+ hs-source-dirs:+ app/syntaxcompletion+ 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++executable yapb-exe+ main-is: Main.hs+ other-modules:+ Paths_yapb+ hs-source-dirs:+ app/yapb+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , yapb+ default-language: Haskell2010++test-suite yapb-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_yapb+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , yapb+ default-language: Haskell2010