module AST where import Data.Char import Text.Read import Text.ParserCombinators.ReadP hiding ((+++), choice) newtype Program = Program [AST] deriving Show instance Read Program where readPrec = fmap Program $ lift $ do asts <- sepBy1 (readS_to_P reads) $ do skipSpaces char ';' skipSpaces optional $ char ';' skipSpaces return asts data AST = Function String [String] Expr | Extern String [String] | Eval Expr deriving Show data Expr = Num Double | BinOp BinOpType Expr Expr | Var String | Call String [Expr] | If Expr Expr Expr deriving Show data BinOpType = Add | Sub | Mul | Cmp Ordering deriving Show instance Read AST where readPrec = parseFunction +++ parseExtern +++ (Eval <$> readPrec) where parseFunction = do lift $ string "def" >> skipSpaces (name, params) <- parsePrototype lift skipSpaces Function name params <$> readPrec parseExtern = do lift $ string "extern" >> skipSpaces uncurry Extern <$> parsePrototype parsePrototype = lift $ do name <- munch1 isAlpha params <- between (char '(') (char ')') $ sepBy (munch1 isAlpha) skipSpaces return (name, params) instance Read Expr where readPrec = choice [ parseParens , parseNum , parseVar , parseCall , parseIf , parseBinOp "+" Add , parseBinOp "-" Sub , parseBinOp "*" Mul , parseBinOp ">" (Cmp GT) , parseBinOp "<" (Cmp LT) , parseBinOp "==" (Cmp EQ) ] where parseParens = step $ lift $ between (char '(') (char ')') (readS_to_P reads) parseNum = Num <$> readPrec parseVar = Var <$> lift (munch1 isAlpha) parseCall = do func <- lift (munch1 isAlpha) params <- lift $ between (char '(') (char ')') $ sepBy (readS_to_P reads) (skipSpaces >> char ',' >> skipSpaces) return (Call func params) parseBinOp s typ = step $ do a <- prec 11 readPrec -- set recursion limit of 11 lift $ do skipSpaces string s skipSpaces BinOp typ a <$> readPrec parseIf = do lift $ do string "if" skipSpaces cond <- step readPrec lift $ do skipSpaces string "then" skipSpaces thenE <- step readPrec lift $ do skipSpaces string "else" skipSpaces elseE <- step readPrec return (If cond thenE elseE)