import Text.Read import Data.Char import qualified Data.Map import PTree {- This is a recursive-descent parser for the grammar: expr -> term | term + expr | term - expr term -> factor | factor * term | factor / term factor -> const | ( expr ) Here const is a String that can be interpreted as an integer value (e.g., "8", "72"). -} -- Code from -- Chapter 12 of Programming in Haskell, -- Graham Hutton, Cambridge University Press, 2016. -- Tree relabelling example -- The state monad (Note: State data type defined below) newtype ST a = S (State -> (a,State)) app :: ST a -> State -> (a,State) app (S st) x = st x instance Functor ST where -- fmap :: (a -> b) -> ST a -> ST b fmap g st = S (\s -> let (x,s') = app st s in (g x, s')) instance Applicative ST where -- pure :: a -> ST a pure x = S (\s -> (x,s)) -- (<*>) :: ST (a -> b) -> ST a -> ST b stf <*> stx = S (\s -> let (f,s') = app stf s (x,s'') = app stx s' in (f x, s'')) instance Monad ST where -- (>>=) :: ST a -> (a -> ST b) -> ST b st >>= f = S (\s -> let (x,s') = app st s in app (f x) s') -- my own data types and functions -- State is either a token stream (list of Strings) indicated by Tkn -- or an error indicated by Err. State transformers should do -- nothing if they encounter an error state data VarType = BoolType | IntType deriving Show data State = Tkn [String] Int (Data.Map.Map String (Int, VarType)) -- good token stream + counter + symtab | Err [String] String -- syntax error with error msg deriving Show -- helper functions isName :: String -> Bool isName [] = False isName (c:cs) = isAlpha c && all isAlphaNum cs hasQuote :: String -> Bool hasQuote [] = False hasQuote (c:cs) = c == '"' fixLiteral :: String -> String fixLiteral [] = [] fixLiteral (c:cs) = fixL cs -- drop first char fixL [c] = [] -- drop last char fixL (c:cs) = case c of '_' -> ' ' : fixL cs _ -> c : fixL cs addOnlyNew symT key tp = Data.Map.insertWith f key ((Data.Map.size symT),tp) symT where f new old = old -- produce next token in stream, update State -- nextToken :: ST String nextToken = S g where g (Tkn (tk:tks) n symT) = (tk, Tkn tks n symT) g (Tkn [] n symT) = ("", Tkn [] n symT) g (Err tks msg) = ("", Err tks msg) -- produce next token in stream, keep State unchanged -- lookAhead :: ST String lookAhead = S g where g (Tkn (tk:tks) n symT) = (tk, Tkn (tk:tks) n symT) g (Tkn [] n symT) = ("", Tkn [] n symT) g (Err tks msg) = ("", Err tks msg) -- actually identical to nextToken, but intended to be used -- without binding to indicate that the next token is skipped -- over. Likely used in conjunction with lookAhead. -- eatToken :: ST () eatToken = S g where g (Tkn (tk:tks) n symT) = ((), Tkn tks n symT) g (Tkn [] n symT) = ((), Tkn [] n symT) g (Err tks msg) = ((), Err tks msg) -- Enter error state -- badState :: String -> ST () badState str = S g where g (Tkn tks n symT) = ((), Err tks str) g (Err tks msg) = ((), Err tks msg) badString :: String -> ST String badString str = S g where g (Tkn tks n symT) = ("", Err tks str) g (Err tks msg) = ("", Err tks msg) -- the next token must be the indicated string value. -- if not, enter error State -- expect :: String -> ST () expect str = do tk <- nextToken if tk == str then return () else if tk == "" then badState ("EOF encountered while expecting a " ++ str) else badState ("expecting a " ++ str) -- the next token must match a variable name -- varName :: ST String varName = do str <- nextToken if isName str then return str else badString"variable name expected" -- report counter and increment -- inc :: ST Int inc = S g where g (Tkn tks n symT) = (n, Tkn tks (n+1) symT) g (Err tks msg) = (-1, Err tks msg) -- add variable to symbol table -- addVar :: String -> VarType -> ST () addVar nm tp = S g where g (Tkn tks n symT) = ( (), Tkn tks n (addOnlyNew symT nm tp) ) g (Err tks msg) = ((), Err tks msg) -- lookup variable in symbol table -- getVar :: String -> ST (Int, VarType) getVar nm = S g where g (Tkn tks n symT) = let result = Data.Map.lookup nm symT in case result of Nothing -> ( (-1, IntType), Err tks ("undeclared variable " ++ nm)) Just (ofs, tp) -> ( (ofs, tp), Tkn tks n symT) g (Err tks msg) = ((-1, IntType), Err tks msg) -- enter error State with given error message -- badETree :: String -> ST ETree badETree str = S g where g (Tkn tks n symT) = (Nada, Err tks str) g (Err tks msg) = (Nada, Err tks msg) -- parse: factor -> const | ( expr ) -- factor :: ST ETree factor = do tk <- nextToken if tk == "(" then do tree <- expr expect ")" return tree else if isName tk then do (ofs, tp) <- getVar tk case tp of IntType -> return (RVALUE ofs tk) BoolType -> badETree "Boolean variable in numeric expression." else case (readMaybe tk :: Maybe Int) of Nothing -> badETree ("'"++ tk ++ "' is not a number") Just n -> return (VALUE n) -- parse: term -> factor | factor * term | factor / term -- term :: ST ETree term = do tree1 <- factor tk <- lookAhead case tk of "*" -> do eatToken tree2 <- term return (TIMES tree1 tree2) "/" -> do eatToken tree2 <- term return (DIVIDE tree1 tree2) otherwise -> return tree1 -- parse: expr -> term | term + expr | term - expr -- expr :: ST ETree expr = do tree1 <- term tk <- lookAhead case tk of "+" -> do eatToken tree2 <- expr return (PLUS tree1 tree2) "-" -> do eatToken tree2 <- expr return (MINUS tree1 tree2) otherwise -> return tree1 -- parse: boolFactor -> expr < expr | expr <= expr -- | expr == expr | expr != expr -- | expr >= expr | expr > expr -- | true | false -- boolFactor :: ST ETree boolFactor = do tk <- lookAhead case tk of "true" -> do eatToken return TrueV "false" -> do eatToken return FalseV _ -> do tr1 <- expr cmp <- nextToken tr2 <- expr case cmp of "<" -> return (LTH tr1 tr2) "<=" -> return (LEQ tr1 tr2) "==" -> return (EQU tr1 tr2) "!=" -> return (NEQ tr1 tr2) ">=" -> return (GEQ tr1 tr2) ">" -> return (GTH tr1 tr2) _ -> badETree ("Unknown comparison: " ++ cmp) -- parse: boolExpr -> boolFactor -- Too lazy to implement AND, OR, NOT for now -- boolExpr :: ST ETree boolExpr = boolFactor -- Enter error state -- badStmt :: String -> ST Statements badStmt str = S g where g (Tkn tks n symT) = (NullStmt, Err tks str) g (Err tks msg) = (NullStmt, Err tks msg) -- parse : declare -> var { type } name -- declare :: ST () declare = do expect "var" expect "{" tk <- nextToken expect "}" str <- varName case tk of "int" -> do addVar str IntType return () "bool" -> do addVar str BoolType return () _ -> do badState ("Unknown type: " ++ tk) -- parse: assign -> name := expr -- assign :: ST Statements assign = do str <- varName (ofs, tp) <- getVar str expect (":=") case tp of IntType -> do tr <- expr return (ASSIGN (LVALUE ofs str) tr) BoolType -> do tr <- boolExpr return (ASSIGN (LVALUE ofs str) tr) -- parse: ifstmt -> if ( boolExpr ) then { stmts } else { stmts } -- | if ( boolExpr ) then { stmts } -- ifstmt :: ST Statements ifstmt = do expect "if" label <- inc expect "(" tr1 <- boolExpr expect ")" expect "then" expect "{" tr2 <- stmts expect "}" tk <- lookAhead if (tk == "else") then do eatToken expect "{" tr3 <- stmts expect "}" return (IFTHENELSE label tr1 tr2 tr3) else return (IFTHEN label tr1 tr2) -- parse: whileloop -> while ( boolExpr ) { stmts } -- whileloop :: ST Statements whileloop = do expect "while" label <- inc expect "(" tr1 <- boolExpr expect ")" expect "{" tr2 <- stmts expect "}" return (WHILE label tr1 tr2) -- parse: forloop -> for ( assign ; boolexpr ; assign ) { stmts } -- forloop :: ST Statements forloop = do expect "for" label <- inc expect "(" tr1 <- assign expect ";" tr2 <- boolExpr expect ";" tr3 <- assign expect ")" expect "{" tr4 <- stmts expect "}" return (FOR label tr1 tr2 tr3 tr4) -- parse: stmt -> var declare ; | let assign ; | print literal | print expr -- | ifstmt | whileloop | forloop -- stmts :: ST Statements stmts = do tk <- lookAhead case tk of "" -> return NullStmt "var" -> do declare expect ";" t2 <- stmts return t2 "let" -> do eatToken t1 <- assign expect ";" t2 <- stmts return (STMTLIST t1 t2) "print" -> do eatToken tk2 <- lookAhead if hasQuote tk2 then do label <- inc eatToken expect ";" tr2 <- stmts return (STMTLIST (PRINTSTR label (fixLiteral tk2)) tr2) else do tr1 <- expr expect ";" tr2 <- stmts return (STMTLIST (PRINTINT tr1) tr2) "println" -> do eatToken tk2 <- lookAhead if hasQuote tk2 then do label <- inc eatToken expect ";" tr2 <- stmts return (STMTLIST (PRINTLNSTR label (fixLiteral tk2)) tr2) else do tr1 <- expr expect ";" tr2 <- stmts return (STMTLIST (PRINTLNINT tr1) tr2) "if" -> do t1 <- ifstmt t2 <- stmts return (STMTLIST t1 t2) "while" -> do t1 <- whileloop t2 <- stmts return (STMTLIST t1 t2) "for" -> do t1 <- forloop t2 <- stmts return (STMTLIST t1 t2) _ -> return NullStmt -- Main program does the I/O -- main = do input <- getContents let (tree, state) = app stmts (Tkn (words input) 0 Data.Map.empty) in case state of Tkn [] n symT -> do -- putStrLn "Syntactically correct expression:" -- putStrLn (show tree) putStrLn "VARIABLE _LV 1000 CELLS ALLOT\n\n" putStrLn ": _Main" putStr $ compile tree putStrLn ";\n" putStrLn "_Main bye" Tkn tks n symT -> do putStrLn "Parsed a prefix:" putStrLn (show tree) putStr "Remaining input: " putStrLn (unwords tks) Err tks msg -> do putStrLn ("Error encontered:" ++ msg) putStr "Remaining input: " putStrLn (unwords tks) putStr "Parsed input: " putStrLn (show tree)