diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + * + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/conv/Main.hs b/app/conv/Main.hs new file mode 100644 --- /dev/null +++ b/app/conv/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import ReadGrammar + +-- How to run: +-- $ stack exec conv-exe grm/polyrpc.lgrm + +main = test conversion + + diff --git a/app/parser/Lexer.hs b/app/parser/Lexer.hs new file mode 100644 --- /dev/null +++ b/app/parser/Lexer.hs @@ -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) + ] + } diff --git a/app/parser/Main.hs b/app/parser/Main.hs new file mode 100644 --- /dev/null +++ b/app/parser/Main.hs @@ -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) + + diff --git a/app/parser/Parser.hs b/app/parser/Parser.hs new file mode 100644 --- /dev/null +++ b/app/parser/Parser.hs @@ -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" + } + + diff --git a/app/parser/Token.hs b/app/parser/Token.hs new file mode 100644 --- /dev/null +++ b/app/parser/Token.hs @@ -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 + + diff --git a/app/parser/ast/Expr.hs b/app/parser/ast/Expr.hs new file mode 100644 --- /dev/null +++ b/app/parser/ast/Expr.hs @@ -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 ++ ")" diff --git a/app/polyrpc/Compile.hs b/app/polyrpc/Compile.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/Compile.hs @@ -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 + + diff --git a/app/polyrpc/Execute.hs b/app/polyrpc/Execute.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/Execute.hs @@ -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 -- +-- deriving (Show, Typeable, Data) + + +-- +execute :: Bool -> GlobalTypeInfo -> FunctionStore -> Expr -> IO Value +execute debug gti funStore mainExpr = do + v <- run debug funStore (initConfig mainExpr) + return v + +assert b action = if b then action else return () + +-- +run :: Bool -> FunctionStore -> Config -> IO Value + +run debug funStore (ClientConfig [] (ValExpr (UnitM v)) [] mem_c [] mem_s) = do + assert debug (putStrLn $ "[DONE]: [Client] " ++ show (ValExpr (UnitM v)) ++ "\n") + + return v + +run debug funStore (ClientConfig evctx expr client_stack mem_c server_stack mem_s) = do + assert debug (putStrLn $ "[STEP] [Client] " ++ show expr ++ "\n") + assert debug (putStrLn $ " EvCtx " ++ showEvCxt evctx ++ "\n") + assert debug (putStrLn $ " c stk " ++ showStack client_stack ++ "\n") + assert debug (putStrLn $ " mem " ++ show (Map.toList $ _map mem_c) ++ "\n") + assert debug (putStrLn $ " s stk " ++ showStack server_stack ++ "\n") + assert debug (putStrLn $ " mem " ++ show (Map.toList $ _map mem_s) ++ "\n") + + config <- clientExpr funStore [] (applyEvCxt evctx expr) client_stack mem_c server_stack mem_s + run debug funStore config + +run debug funStore (ServerConfig client_stack mem_c evctx expr server_stack mem_s) = do + assert debug (putStrLn $ "[STEP] [Server] " ++ show expr ++ "\n") + assert debug (putStrLn $ " EvCtx " ++ showEvCxt evctx ++ "\n") + assert debug (putStrLn $ " c stk " ++ showStack client_stack ++ "\n") + assert debug (putStrLn $ " mem " ++ show (Map.toList $ _map mem_c) ++ "\n") + assert debug (putStrLn $ " s stk " ++ showStack server_stack ++ "\n") + assert debug (putStrLn $ " mem " ++ show (Map.toList $ _map mem_s) ++ "\n") + + config <- serverExpr funStore client_stack mem_c [] (applyEvCxt evctx expr) server_stack mem_s + run debug funStore config + +-- +initConfig main_expr = ClientConfig [] main_expr [] initMem [] initMem + +-- +applyEvCxt [] expr = expr +applyEvCxt (evcxt:evcxts) expr = applyEvCxt evcxts (evcxt expr) + +toFun [] = \x->x +toFun (evcxt:evcxts) = toFun evcxts . evcxt + +showEvCxt cxt = show $ applyEvCxt cxt (ValExpr (Var "HOLE")) + +showStack stk = show $ map showEvCxt [[cxt] | cxt <- stk] + +----------------------------------------------------------- +-- < EvCtx[ Value]; Client stack | Server stack> ==> Config +----------------------------------------------------------- + +clientExpr :: FunctionStore -> [EvalContext] -> Expr -> Stack -> Mem -> Stack -> Mem -> IO Config + +clientExpr fun_store evctx (ValExpr v) client_stack mem_c server_stack mem_s = + clientValue fun_store evctx v client_stack mem_c server_stack mem_s + +-- (E-Let) +clientExpr fun_store evctx (Let [Binding x ty b@(ValExpr v)] expr) client_stack mem_c server_stack mem_s = do + let subst = [(x,v)] + return $ ClientConfig evctx (doSubstExpr subst expr) client_stack mem_c server_stack mem_s + +-- (let x = Elet[] in M) +clientExpr fun_store evctx (Let [Binding x ty b@(_)] expr) client_stack mem_c server_stack mem_s = do + clientExpr fun_store ((\bexpr->Let [Binding x ty bexpr] expr):evctx) b client_stack mem_c server_stack mem_s + +-- (E-Proj-i) or (E-Tuple) +clientExpr fun_store evctx (Case (Tuple vs) casety [TupleAlternative xs expr]) client_stack mem_c server_stack mem_s = do + let subst = zip xs vs + return $ ClientConfig evctx (doSubstExpr subst expr) client_stack mem_c server_stack mem_s + +-- (E-Proj-i) or (E-Data constructor) or (E-if) +clientExpr fun_store evctx (Case (Constr cname locs tys vs argtys) casety alts) client_stack mem_c server_stack mem_s = do + case [(dname,xs,expr) | Alternative dname xs expr <- alts, cname==dname] of + ((_,xs,expr):_) -> do + let subst = zip xs vs + return $ ClientConfig evctx (doSubstExpr subst expr) client_stack mem_c server_stack mem_s + + [] -> error $ "[clientExpr] Case alternative not found: " ++ cname + +-- (E-Proj-i) or (E-Data constructor) or (E-if) +clientExpr fun_store evctx (Case (Lit (BoolLit b)) casety alts) client_stack mem_c server_stack mem_s = do + let [Alternative b1 _ expr1,Alternative b2 _ expr2] = alts + let text_b = show b + if text_b==b1 then return $ ClientConfig evctx expr1 client_stack mem_c server_stack mem_s + else if text_b==b2 then return $ ClientConfig evctx expr2 client_stack mem_c server_stack mem_s + else error $ "[cilentExpr] Case unexpected: " ++ show b ++ "? " ++ b1 ++ " " ++ b2 + +-- (E-App) +clientExpr fun_store evctx (App clo@(Closure vs vstys codename recf) funty arg) client_stack mem_c server_stack mem_s = do + let CodeName fname locs tys = codename + case [code | (gname,(codetype,code))<-_clientstore fun_store, fname==gname] of + ((Code locvars tyvars fvvars (CodeAbs [(x,_)] expr)):_) -> do + let subst = [(x,arg)] ++ zip fvvars vs + let substLoc = zip locvars locs + let substTy = zip tyvars tys + let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) + return $ ClientConfig evctx substed_expr client_stack mem_c server_stack mem_s + + [] -> error $ "[clientExpr] Client abs code not found: " ++ fname + +-- (E-TApp) +clientExpr fun_store evctx (TypeApp clo@(Closure vs vstys codename recf) funty [argty]) client_stack mem_c server_stack mem_s = do + let CodeName fname locs tys = codename + case [code | (gname, (codetype,code))<-_clientstore fun_store, fname==gname] of + ((Code locvars tyvars fvvars (CodeTypeAbs [a] expr)):_) -> do + let subst = zip fvvars vs + let substLoc = zip locvars locs + let substTy = [(a,argty)] ++ zip tyvars tys + let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) + return $ ClientConfig evctx substed_expr client_stack mem_c server_stack mem_s + + [] -> error $ "[clientExpr] Client tyabs code not found: " ++ fname + +-- (E-LApp) +clientExpr fun_store evctx (LocApp clo@(Closure vs vstys codename recf) funty [argloc]) client_stack mem_c server_stack mem_s = do + let CodeName fname locs tys = codename + case [code | (gname, (codetype,code))<-_clientstore fun_store, fname==gname] of + ((Code locvars tyvars fvvars (CodeLocAbs [l] expr)):_) -> do + let subst = zip fvvars vs + let substLoc = [(l,argloc)] ++ zip locvars locs + let substTy = zip tyvars tys + let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) + return $ ClientConfig evctx substed_expr client_stack mem_c server_stack mem_s + + [] -> error $ "[clientExpr] Client locabs code not found: " ++ fname + +clientExpr fun_store evctx (Prim primop locs tys vs) client_stack mem_c server_stack mem_s = do + (v, mem_c1) <- calc primop locs tys vs mem_c + return $ ClientConfig evctx (ValExpr v) client_stack mem_c1 server_stack mem_s + +clientExpr fun_store evctx expr client_stack mem_c server_stack mem_s = + error $ "[clientExpr] Unexpected: " ++ show expr ++ "\n" ++ show (applyEvCxt evctx expr) ++ "\n" + +-- +clientValue :: FunctionStore -> [EvalContext] -> Value -> Stack -> Mem -> Stack -> Mem -> IO Config + +-- (E-Unit-C) +clientValue fun_store [] (UnitM v) client_stack mem_c (top_evctx:server_stack) mem_s = + return $ ServerConfig client_stack mem_c [] (top_evctx (ValExpr (UnitM v))) server_stack mem_s + +-- (E-Req) +clientValue fun_store evctx (Req f funty arg) client_stack mem_c server_stack mem_s = do + let client_stack1 = if null evctx then client_stack else (toFun evctx):client_stack + return $ ServerConfig client_stack1 mem_c [] (App f funty arg) server_stack mem_s + +-- (E-Gen-C-C) and (E-Gen-C-S) +clientValue fun_store evctx (GenApp loc f funty arg) client_stack mem_c server_stack mem_s = do + if loc==clientLoc then + return $ ClientConfig evctx (App f funty arg) client_stack mem_c server_stack mem_s + else if loc==serverLoc then + return $ ClientConfig evctx (ValExpr (Req f funty arg)) client_stack mem_c server_stack mem_s + else + error $ "[clientValue] GenApp: Unexpected location : " ++ show loc + +-- (E-Do) +clientValue fun_store evctx (BindM [Binding x ty b@(ValExpr (UnitM v))] expr) client_stack mem_c server_stack mem_s = do + let subst = [(x,v)] + return $ ClientConfig evctx (doSubstExpr subst expr) client_stack mem_c server_stack mem_s + +-- ( do x<-E[] in M ) +clientValue fun_store evctx (BindM [Binding x ty b@(_)] expr) client_stack mem_c server_stack mem_s = do + clientExpr fun_store ((\bexpr->ValExpr (BindM [Binding x ty bexpr] expr)):evctx) b client_stack mem_c server_stack mem_s + +clientValue fun_store evctx v client_stack mem_c server_stack mem_s = + error $ "[clientValue] Unexpected: " ++ show v ++ "\n" ++ show (applyEvCxt evctx (ValExpr v)) ++ "\n" + + +------------------------------------------------------------ +-- < Client stack | EvCtx[ Value ]; Server stack> ==> Config +------------------------------------------------------------ + +serverExpr :: FunctionStore -> Stack -> Mem -> [EvalContext] -> Expr -> Stack -> Mem -> IO Config + +serverExpr fun_store client_stack mem_c evctx (ValExpr v) server_stack mem_s = + serverValue fun_store client_stack mem_c evctx v server_stack mem_s + +-- (E-Let) +serverExpr fun_store client_stack mem_c evctx (Let [Binding x ty b@(ValExpr v)] expr) server_stack mem_s = do + let subst = [(x,v)] + return $ ServerConfig client_stack mem_c evctx (doSubstExpr subst expr) server_stack mem_s + +-- (let x = Elet[] in M) +serverExpr fun_store client_stack mem_c evctx (Let [Binding x ty b@(_)] expr) server_stack mem_s = do + serverExpr fun_store client_stack mem_c ((\bexpr->Let [Binding x ty bexpr] expr):evctx) b server_stack mem_s + +-- (E-Proj-i) or (E-Tuple) or (E-if) +serverExpr fun_store client_stack mem_c evctx (Case (Tuple vs) casety [TupleAlternative xs expr]) server_stack mem_s = do + let subst = zip xs vs + return $ ServerConfig client_stack mem_c evctx (doSubstExpr subst expr) server_stack mem_s + +-- (E-Proj-i) or (E-Data constructor) or (E-if) +serverExpr fun_store client_stack mem_c evctx (Case (Constr cname locs tys vs argtys) casety alts) server_stack mem_s = do + case [(dname,xs,expr) | Alternative dname xs expr <- alts, cname==dname] of + ((_,xs,expr):_) -> do + let subst = zip xs vs + return $ ServerConfig client_stack mem_c evctx (doSubstExpr subst expr) server_stack mem_s + + [] -> error $ "[serverExpr] Case alternative not found: " ++ cname + +serverExpr fun_store client_stack mem_c evctx (Case (Lit (BoolLit b)) casety alts) server_stack mem_s = do + let [Alternative b1 _ expr1,Alternative b2 _ expr2] = alts + let text_b = show b + if text_b==b1 then return $ ServerConfig client_stack mem_c evctx expr1 server_stack mem_s + else if text_b==b2 then return $ ServerConfig client_stack mem_c evctx expr2 server_stack mem_s + else error $ "[cilentExpr] Case unexpected: " ++ show b ++ "? " ++ b1 ++ " " ++ b2 + +-- (E-App) +serverExpr fun_store client_stack mem_c evctx (App clo@(Closure vs vstys codename recf) funty arg) server_stack mem_s = do + let CodeName fname locs tys = codename + case [code | (gname,(codetyps,code))<-_serverstore fun_store, fname==gname] of + ((Code locvars tyvars fvvars (CodeAbs [(x,_)] expr)):_) -> do + let subst = [(x,arg)] ++ zip fvvars vs + let substLoc = zip locvars locs + let substTy = zip tyvars tys + let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) + return $ ServerConfig client_stack mem_c evctx substed_expr server_stack mem_s + + [] -> error $ "[serverExpr] Server abs code not found: " ++ fname + +-- (E-TApp) +serverExpr fun_store client_stack mem_c evctx (TypeApp clo@(Closure vs vstys codename recf) funty [argty]) server_stack mem_s = do + let CodeName fname locs tys = codename + case [code | (gname, (codetype,code))<-_serverstore fun_store, fname==gname] of + ((Code locvars tyvars fvvars (CodeTypeAbs [a] expr)):_) -> do + let subst = zip fvvars vs + let substLoc = zip locvars locs + let substTy = [(a,argty)] ++ zip tyvars tys + let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) + return $ ServerConfig client_stack mem_c evctx substed_expr server_stack mem_s + + [] -> error $ "[serverExpr] Server tyabs code not found: " ++ fname ++ "\n" + ++ ", " ++ show [gname | (gname,_)<-_serverstore fun_store] ++ "\n" + ++ ", " ++ show [gname | (gname,_)<-_clientstore fun_store] ++ "\n" + +-- (E-LApp) +serverExpr fun_store client_stack mem_c evctx (LocApp clo@(Closure vs vstys codename recf) funty [argloc]) server_stack mem_s = do + let CodeName fname locs tys = codename + case [code | (gname, (codetype,code))<-_serverstore fun_store, fname==gname] of + ((Code locvars tyvars fvvars (CodeLocAbs [l] expr)):_) -> do + let subst = zip fvvars vs + let substLoc = [(l,argloc)] ++ zip locvars locs + let substTy = zip tyvars tys + let substed_expr = doRec clo recf $ doSubstExpr subst (doSubstTyExpr substTy (doSubstLocExpr substLoc expr)) + return $ ServerConfig client_stack mem_c evctx substed_expr server_stack mem_s + + [] -> error $ "[serverExpr] Server locabs code not found: " ++ fname + +serverExpr fun_store client_stack mem_c evctx (Prim primop locs tys vs) server_stack mem_s = do + (v, mem_s1) <- calc primop locs tys vs mem_s + return $ ServerConfig client_stack mem_c evctx (ValExpr v) server_stack mem_s1 + + +-- +serverValue :: FunctionStore -> Stack -> Mem -> [EvalContext] -> Value -> Stack -> Mem -> IO Config + +-- (E-Unit-S-E) +serverValue fun_store [] mem_c [] (UnitM v) [] mem_s = + return $ ClientConfig [] (ValExpr (UnitM v)) [] mem_c [] mem_s + +-- (E-Unit-S) +serverValue fun_store (top_evctx:client_stack) mem_c [] (UnitM v) server_stack mem_s = + return $ ClientConfig [] (top_evctx (ValExpr (UnitM v))) client_stack mem_c server_stack mem_s + +-- (E-Call) +serverValue fun_store client_stack mem_c evctx (Call f funty arg) server_stack mem_s = do + let server_stack1 = if null evctx then server_stack else (toFun evctx):server_stack + return $ ClientConfig [] (App f funty arg) client_stack mem_c server_stack1 mem_s + +-- (E-Gen-C-C) and (E-Gen-S-C) +serverValue fun_store client_stack mem_c evctx (GenApp loc f funty arg) server_stack mem_s = do + if loc==serverLoc then + return $ ServerConfig client_stack mem_c evctx (App f funty arg) server_stack mem_s + else if loc==clientLoc then + return $ ServerConfig client_stack mem_c evctx (ValExpr (Call f funty arg)) server_stack mem_s + else + error $ "[serverValue] GenApp: Unexpected location : " ++ show loc + +-- (E-Do) +serverValue fun_store client_stack mem_c evctx (BindM [Binding x ty b@(ValExpr (UnitM v))] expr) server_stack mem_s = do + let subst = [(x,v)] + return $ ServerConfig client_stack mem_c evctx (doSubstExpr subst expr) server_stack mem_s + +-- ( do x<-E[] in M ) : b is one of BindM, Call, and GenApp. +serverValue fun_store client_stack mem_c evctx (BindM [Binding x ty b@(_)] expr) server_stack mem_s = do + serverExpr fun_store client_stack mem_c ((\bexpr->ValExpr (BindM [Binding x ty bexpr] expr)):evctx) b server_stack mem_s + +serverValue fun_store client_stack mem_c evctx v server_stack mem_s = do + error $ "[serverValue]: Unexpected: " ++ show v ++ "\n" + ++ show [f | (f,_)<-_clientstore fun_store] ++ "\n" + ++ show [f | (f,_)<-_serverstore fun_store] ++ "\n" + +----------------------- +-- Primitive operations +----------------------- + +calc :: PrimOp -> [Location] -> [Type] -> [Value] -> Mem -> IO (Value, Mem) + +calc MkRecOp locs tys [Closure vs fvtys codename [], Lit (StrLit f)] mem = + return (Closure vs fvtys codename [f], mem) + + +calc PrimRefCreateOp [loc1] [ty] [v] mem = + let (addr, mem1) = allocMem v mem in return (Addr addr, mem1) + +calc PrimRefCreateOp locs tys vs mem = + error $ "[PrimOp] PrimRefCreateOp: Unexpected: " + ++ show locs ++ " " ++ show tys ++ " " ++ show vs + +calc PrimRefReadOp [loc1] [ty] [Addr addr] mem = return (readMem addr mem, mem) + +calc PrimRefReadOp locs tys vs mem = + error $ "[PrimOp] PrimRefReadOp: Unexpected: " + ++ show locs ++ " " ++ show tys ++ " " ++ show vs + +calc PrimRefWriteOp [loc1] [ty] [Addr addr,v] mem = + return (Lit UnitLit, writeMem addr v mem) + +calc PrimRefWriteOp locs tys vs mem = + error $ "[PrimOp] PrimRefWriteOp: Unexpected: " + ++ show locs ++ " " ++ show tys ++ " " ++ show vs + +calc PrimReadOp [loc] [] [Lit (UnitLit)] mem = do + line <- getLine + return (Lit (StrLit line), mem) + +calc PrimPrintOp [loc] [] [Lit (StrLit s)] mem = do + putStr s + return (Lit UnitLit, mem) + + +calc primop locs tys vs mem = + return (Lit $ calc' primop locs tys (map (\ (Lit lit)-> lit) vs), mem) + + +-- Primitives +calc' :: PrimOp -> [Location] -> [Type] -> [Literal] -> Literal + +calc' NotPrimOp [loc] [] [BoolLit b] = BoolLit (not b) -- loc is the current location + +calc' OrPrimOp [loc] [] [BoolLit x, BoolLit y] = BoolLit (x || y) + +calc' AndPrimOp [loc] [] [BoolLit x, BoolLit y] = BoolLit (x && y) + +calc' EqPrimOp [loc] [] [IntLit x, IntLit y] = BoolLit (x==y) + +calc' NeqPrimOp [loc] [] [IntLit x, IntLit y] = BoolLit (x/=y) + +calc' LtPrimOp [loc] [] [IntLit x, IntLit y] = BoolLit (xy) + +calc' GePrimOp [loc] [] [IntLit x, IntLit y] = BoolLit (x>=y) + +calc' AddPrimOp [loc] [] [IntLit x, IntLit y] = IntLit (x+y) + +calc' SubPrimOp [loc] [] [IntLit x, IntLit y] = IntLit (x-y) + +calc' MulPrimOp [loc] [] [IntLit x, IntLit y] = IntLit (x*y) + +calc' DivPrimOp [loc] [] [IntLit x, IntLit y] = IntLit (x `div` y) + +calc' NegPrimOp [loc] [] [IntLit x] = IntLit (-x) + +-- Libraries +calc' PrimIntToStringOp [loc] [] [IntLit i] = StrLit (show i) + +calc' PrimConcatOp [loc] [] [StrLit s1, StrLit s2] = StrLit (s1++s2) + +calc' operator locs tys operands = + error $ "[PrimOp] Unexpected: " + ++ show operator ++ " " ++ show locs ++ " " ++ show tys ++ " " ++ show operands + + +-- +doRec clo [] expr = expr +doRec (Closure vs tys codename recf) [f] expr = doSubstExpr [(f, Closure vs tys codename [f])] expr +doRec clo recf expr = error $ "[doRec] Unexpected" ++ show clo ++ ", " ++ show recf ++ ", " ++ show expr + + +---------------- +-- Substitutions +---------------- + +-- +elim x subst = [(y,e) | (y,e)<-subst, y/=x] + +elims xs subst = foldl (\subst0 x0 -> elim x0 subst0) subst xs + + +-- +doSubstExpr :: [(String,Value)] -> Expr -> Expr + +doSubstExpr subst (ValExpr v) = ValExpr (doSubstValue subst v) + +doSubstExpr subst (Let bindingDecls expr) = + let bindingDecls1 = + map (\(Binding x ty expr) -> + Binding x ty (doSubstExpr (elim x subst) expr)) bindingDecls + + elimed_subst = elims (map (\(Binding x _ _) -> x) bindingDecls) subst + + expr1 = doSubstExpr elimed_subst expr + in Let bindingDecls1 expr1 + +doSubstExpr subst (Case v casety [TupleAlternative xs expr]) = + let subst1 = elims xs subst + in Case (doSubstValue subst v) casety + [TupleAlternative xs (doSubstExpr subst1 expr)] + +doSubstExpr subst (Case v casety alts) = + Case (doSubstValue subst v) casety + (map (\(Alternative cname xs expr) -> + let subst1 = elims xs subst + in Alternative cname xs (doSubstExpr subst1 expr)) alts) + +doSubstExpr subst (App v funty arg) = + App (doSubstValue subst v) funty (doSubstValue subst arg) + +doSubstExpr subst (TypeApp v funty tyargs) = + TypeApp (doSubstValue subst v) funty tyargs + +doSubstExpr subst (LocApp v funty locargs) = + LocApp (doSubstValue subst v) funty locargs + +doSubstExpr subst (Prim op locs tys vs) = Prim op locs tys (map (doSubstValue subst) vs) + + + +-- +doSubstValue :: [(String,Value)] -> Value -> Value + +doSubstValue subst (Var x) = + case [v | (y,v) <- subst, x==y] of + (v:_) -> v + [] -> (Var x) + +doSubstValue subst (Lit lit) = (Lit lit) + +doSubstValue subst (Tuple vs) = Tuple (map (doSubstValue subst) vs) + +doSubstValue subst (Constr cname locs tys vs argtys) = + Constr cname locs tys (map (doSubstValue subst) vs) argtys + +doSubstValue subst (Closure vs fvtys (CodeName fname locs tys) recf) = + Closure (map (doSubstValue subst) vs) fvtys (CodeName fname locs tys) recf + +doSubstValue subst (UnitM v) = UnitM (doSubstValue subst v) + +doSubstValue subst (BindM bindingDecls expr) = + let bindingDecls1 = + (map (\(Binding x ty bexpr) -> + let subst1 = elim x subst + in Binding x ty (doSubstExpr subst1 bexpr))) bindingDecls + + elimed_subst = elims (map (\(Binding x _ _) -> x) bindingDecls) subst + + expr1 = doSubstExpr elimed_subst expr + in BindM bindingDecls1 expr1 + +doSubstValue subst (Req f funty arg) = + Req (doSubstValue subst f) funty (doSubstValue subst arg) + +doSubstValue subst (Call f funty arg) = + Call (doSubstValue subst f) funty (doSubstValue subst arg) + +doSubstValue subst (GenApp loc f funty arg) = + GenApp loc (doSubstValue subst f) funty (doSubstValue subst arg) + +doSubstValue subst (Addr i) = Addr i + +--doSubstValue subst v = error $ "[doSubstValue] Unexpected: " ++ show v + + +-- +doSubstLocExpr :: [(String,Location)] -> Expr -> Expr + +doSubstLocExpr substLoc (ValExpr v) = ValExpr (doSubstLocValue substLoc v) + +doSubstLocExpr substLoc (Let bindingDecls expr) = + let bindingDecls1 = + map (\(Binding x ty bexpr) -> + Binding x + (doSubstLoc substLoc ty) + (doSubstLocExpr substLoc bexpr)) bindingDecls + + in Let bindingDecls1 (doSubstLocExpr substLoc expr) + +doSubstLocExpr substLoc (Case v casety [TupleAlternative xs expr]) = + Case (doSubstLocValue substLoc v) (doSubstLoc substLoc casety) + [TupleAlternative xs (doSubstLocExpr substLoc expr)] + +doSubstLocExpr substLoc (Case v casety alts) = + Case (doSubstLocValue substLoc v) (doSubstLoc substLoc casety) + (map (\(Alternative cname xs expr) -> + Alternative cname xs (doSubstLocExpr substLoc expr)) alts) + +doSubstLocExpr substLoc (App v funty arg) = + App (doSubstLocValue substLoc v) + (doSubstLoc substLoc funty) + (doSubstLocValue substLoc arg) + +doSubstLocExpr substLoc (TypeApp v funty tyargs) = + TypeApp (doSubstLocValue substLoc v) + (doSubstLoc substLoc funty) + (map (doSubstLoc substLoc) tyargs) + +doSubstLocExpr substLoc (LocApp v funty locargs) = + LocApp (doSubstLocValue substLoc v) + (doSubstLoc substLoc funty) + (map (doSubstLocOverLocs substLoc) locargs) + +doSubstLocExpr substLoc (Prim op locs tys vs) = + Prim op + (map (doSubstLocOverLocs substLoc) locs) + (map (doSubstLoc substLoc) tys) + (map (doSubstLocValue substLoc) vs) + + +-- +doSubstLocValue :: [(String,Location)] -> Value -> Value + +doSubstLocValue substLoc (Var x) = Var x + +doSubstLocValue substLoc (Lit lit) = Lit lit + +doSubstLocValue substLoc (Tuple vs) = Tuple (map (doSubstLocValue substLoc) vs) + +doSubstLocValue substLoc (Constr cname locs tys vs argtys) = + Constr cname + (map (doSubstLocOverLocs substLoc) locs) + (map (doSubstLoc substLoc) tys) + (map (doSubstLocValue substLoc) vs) + (map (doSubstLoc substLoc) argtys) + +doSubstLocValue substLoc (Closure vs fvtys (CodeName f locs tys) recf) = + Closure (map (doSubstLocValue substLoc) vs) + (map (doSubstLoc substLoc) fvtys ) + (CodeName f (map (doSubstLocOverLocs substLoc) locs) (map (doSubstLoc substLoc) tys)) + recf + +doSubstLocValue substLoc (UnitM v) = UnitM (doSubstLocValue substLoc v) + +doSubstLocValue substLoc (BindM bindingDecls expr) = + let bindingDecls1 = + (map (\(Binding x ty bexpr) -> + Binding x + (doSubstLoc substLoc ty) + (doSubstLocExpr substLoc bexpr))) bindingDecls + in BindM bindingDecls1 (doSubstLocExpr substLoc expr) + +doSubstLocValue substLoc (Req f funty arg) = + Req (doSubstLocValue substLoc f) + (doSubstLoc substLoc funty) + (doSubstLocValue substLoc arg) + +doSubstLocValue substLoc (Call f funty arg) = + Call (doSubstLocValue substLoc f) + (doSubstLoc substLoc funty) + (doSubstLocValue substLoc arg) + +doSubstLocValue substLoc (GenApp loc f funty arg) = + GenApp (doSubstLocOverLocs substLoc loc) + (doSubstLocValue substLoc f) + (doSubstLoc substLoc funty) + (doSubstLocValue substLoc arg) + +doSubstLocValue substLoc (Addr i) = Addr i + +-- +doSubstTyExpr :: [(String,Type)] -> Expr -> Expr + +doSubstTyExpr substTy (ValExpr v) = ValExpr (doSubstTyValue substTy v) + +doSubstTyExpr substTy (Let bindingDecls expr) = + let bindingDecls1 = + map (\(Binding x ty expr) -> + Binding x (doSubst substTy ty) (doSubstTyExpr substTy expr)) bindingDecls + + in Let bindingDecls1 (doSubstTyExpr substTy expr) + +doSubstTyExpr substTy (Case v casety [TupleAlternative xs expr]) = + Case (doSubstTyValue substTy v) (doSubst substTy casety) + [TupleAlternative xs (doSubstTyExpr substTy expr)] + +doSubstTyExpr substTy (Case v casety alts) = + Case (doSubstTyValue substTy v) (doSubst substTy casety) + (map (\ (Alternative cname xs expr) -> + Alternative cname xs (doSubstTyExpr substTy expr)) alts) + +doSubstTyExpr substTy (App v funty arg) = + App (doSubstTyValue substTy v) (doSubst substTy funty) (doSubstTyValue substTy arg) + +doSubstTyExpr substTy (TypeApp v funty tyargs) = + TypeApp (doSubstTyValue substTy v) (doSubst substTy funty) (map (doSubst substTy) tyargs) + +doSubstTyExpr substTy (LocApp v funty locargs) = + LocApp (doSubstTyValue substTy v) (doSubst substTy funty) locargs + +doSubstTyExpr substTy (Prim op locs tys vs) = + Prim op locs (map (doSubst substTy) tys) (map (doSubstTyValue substTy) vs) + +-- +doSubstTyValue :: [(String,Type)] -> Value -> Value + + +doSubstTyValue substTy (Var x) = (Var x) + +doSubstTyValue substTy (Lit lit) = Lit lit + +doSubstTyValue substTy (Tuple vs) = Tuple (map (doSubstTyValue substTy) vs) + +doSubstTyValue substTy (Constr cname locs tys vs argtys) = + Constr cname locs + (map (doSubst substTy) tys) + (map (doSubstTyValue substTy) vs) + (map (doSubst substTy) argtys) + +doSubstTyValue substTy (UnitM v) = UnitM (doSubstTyValue substTy v) + +doSubstTyValue substTy (Closure vs fvtys (CodeName fname locs tys) recf) = + Closure (map (doSubstTyValue substTy) vs) + (map (doSubst substTy) fvtys) + (CodeName fname locs (map (doSubst substTy) tys)) + recf + +doSubstTyValue substTy (BindM bindingDecls expr) = + let bindingDecls1 = + map (\ (Binding x ty bexpr) -> + Binding x (doSubst substTy ty) (doSubstTyExpr substTy bexpr)) bindingDecls + in BindM bindingDecls1 (doSubstTyExpr substTy expr) + + +doSubstTyValue substTy (Req f funty arg) = + Req (doSubstTyValue substTy f) (doSubst substTy funty) (doSubstTyValue substTy arg) + +doSubstTyValue substTy (Call f funty arg) = + Call (doSubstTyValue substTy f) (doSubst substTy funty) (doSubstTyValue substTy arg) + +doSubstTyValue substTy (GenApp loc f funty arg) = + GenApp loc (doSubstTyValue substTy f) (doSubst substTy funty) (doSubstTyValue substTy arg) + +doSubstTyValue substTy (Addr i) = Addr i + +-- diff --git a/app/polyrpc/Lexer.hs b/app/polyrpc/Lexer.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/Lexer.hs @@ -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) + ] + } diff --git a/app/polyrpc/Main.hs b/app/polyrpc/Main.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/Main.hs @@ -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 () diff --git a/app/polyrpc/Parser.hs b/app/polyrpc/Parser.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/Parser.hs @@ -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" + } diff --git a/app/polyrpc/Token.hs b/app/polyrpc/Token.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/Token.hs @@ -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 + diff --git a/app/polyrpc/TypeCheck.hs b/app/polyrpc/TypeCheck.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/TypeCheck.hs @@ -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 diff --git a/app/polyrpc/Verify.hs b/app/polyrpc/Verify.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/Verify.hs @@ -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 diff --git a/app/polyrpc/ast/BasicLib.hs b/app/polyrpc/ast/BasicLib.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/ast/BasicLib.hs @@ -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])))) + ) + ] diff --git a/app/polyrpc/ast/Expr.hs b/app/polyrpc/ast/Expr.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/ast/Expr.hs @@ -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) + diff --git a/app/polyrpc/ast/Literal.hs b/app/polyrpc/ast/Literal.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/ast/Literal.hs @@ -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 = "()" + diff --git a/app/polyrpc/ast/Location.hs b/app/polyrpc/ast/Location.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/ast/Location.hs @@ -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) + diff --git a/app/polyrpc/ast/Prim.hs b/app/polyrpc/ast/Prim.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/ast/Prim.hs @@ -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" + + diff --git a/app/polyrpc/ast/Type.hs b/app/polyrpc/ast/Type.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/ast/Type.hs @@ -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) + diff --git a/app/polyrpc/cs/CSExpr.hs b/app/polyrpc/cs/CSExpr.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/cs/CSExpr.hs @@ -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)) diff --git a/app/polyrpc/cs/CSType.hs b/app/polyrpc/cs/CSType.hs new file mode 100644 --- /dev/null +++ b/app/polyrpc/cs/CSType.hs @@ -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 diff --git a/app/syntaxcompletion/EmacsServer.hs b/app/syntaxcompletion/EmacsServer.hs new file mode 100644 --- /dev/null +++ b/app/syntaxcompletion/EmacsServer.hs @@ -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 + diff --git a/app/syntaxcompletion/Lexer.hs b/app/syntaxcompletion/Lexer.hs new file mode 100644 --- /dev/null +++ b/app/syntaxcompletion/Lexer.hs @@ -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) + ] + } diff --git a/app/syntaxcompletion/Main.hs b/app/syntaxcompletion/Main.hs new file mode 100644 --- /dev/null +++ b/app/syntaxcompletion/Main.hs @@ -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) + + diff --git a/app/syntaxcompletion/Parser.hs b/app/syntaxcompletion/Parser.hs new file mode 100644 --- /dev/null +++ b/app/syntaxcompletion/Parser.hs @@ -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" + } diff --git a/app/syntaxcompletion/Token.hs b/app/syntaxcompletion/Token.hs new file mode 100644 --- /dev/null +++ b/app/syntaxcompletion/Token.hs @@ -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 diff --git a/app/yapb/Main.hs b/app/yapb/Main.hs new file mode 100644 --- /dev/null +++ b/app/yapb/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import GenLRParserTable + +main :: IO () +main = do _ <- _main + return () + diff --git a/doc/TIPS-TO-WRITE-LALR1-GRAMMAR.txt b/doc/TIPS-TO-WRITE-LALR1-GRAMMAR.txt new file mode 100644 --- /dev/null +++ b/doc/TIPS-TO-WRITE-LALR1-GRAMMAR.txt @@ -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을 중복해서 작성하는 문제를 해결 + + + diff --git a/doc/parserinaction.png b/doc/parserinaction.png new file mode 100644 Binary files /dev/null and b/doc/parserinaction.png differ diff --git a/doc/parsertoolarchitecture.png b/doc/parsertoolarchitecture.png new file mode 100644 Binary files /dev/null and b/doc/parsertoolarchitecture.png differ diff --git a/src/gentable/CFG.hs b/src/gentable/CFG.hs new file mode 100644 --- /dev/null +++ b/src/gentable/CFG.hs @@ -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 + + + diff --git a/src/gentable/CmdArgs.hs b/src/gentable/CmdArgs.hs new file mode 100644 --- /dev/null +++ b/src/gentable/CmdArgs.hs @@ -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 [] diff --git a/src/gentable/CodeGenC.hs b/src/gentable/CodeGenC.hs new file mode 100644 --- /dev/null +++ b/src/gentable/CodeGenC.hs @@ -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) diff --git a/src/gentable/GenLRParserTable.hs b/src/gentable/GenLRParserTable.hs new file mode 100644 --- /dev/null +++ b/src/gentable/GenLRParserTable.hs @@ -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) diff --git a/src/gentable/ParserTable.hs b/src/gentable/ParserTable.hs new file mode 100644 --- /dev/null +++ b/src/gentable/ParserTable.hs @@ -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])] diff --git a/src/gentable/SampleGrammar.hs b/src/gentable/SampleGrammar.hs new file mode 100644 --- /dev/null +++ b/src/gentable/SampleGrammar.hs @@ -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" ] diff --git a/src/parserlib/AutomatonType.hs b/src/parserlib/AutomatonType.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/AutomatonType.hs @@ -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]) + diff --git a/src/parserlib/CommonParserUtil.hs b/src/parserlib/CommonParserUtil.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/CommonParserUtil.hs @@ -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] + diff --git a/src/parserlib/LoadAutomaton.hs b/src/parserlib/LoadAutomaton.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/LoadAutomaton.hs @@ -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 + diff --git a/src/parserlib/SaveProdRules.hs b/src/parserlib/SaveProdRules.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/SaveProdRules.hs @@ -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 + diff --git a/src/parserlib/Terminal.hs b/src/parserlib/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/Terminal.hs @@ -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 diff --git a/src/parserlib/TokenInterface.hs b/src/parserlib/TokenInterface.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/TokenInterface.hs @@ -0,0 +1,10 @@ +module TokenInterface where + +class TokenInterface token where + toToken :: String -> token + fromToken :: token -> String + + + + + diff --git a/src/util/ReadGrammar.hs b/src/util/ReadGrammar.hs new file mode 100644 --- /dev/null +++ b/src/util/ReadGrammar.hs @@ -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 $ "]" + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented. Refer to app/parser and app/polyrpc for your testing" diff --git a/yapb.cabal b/yapb.cabal new file mode 100644 --- /dev/null +++ b/yapb.cabal @@ -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 +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