AST.hs

   1 module AST where
   2
   3 import Data.Char
   4 import Text.Read
   5 import Text.ParserCombinators.ReadP hiding ((+++), (<++), choice)
   6
   7 newtype Program = Program [AST]
   8   deriving Show
   9
  10 instance Read Program where
  11   readPrec = fmap Program $ lift $ do
  12     asts <- sepBy1 (readS_to_P reads) $ do
  13       skipSpaces
  14       char ';'
  15       skipSpaces
  16     optional $ char ';'
  17     skipSpaces
  18     return asts
  19
  20 data AST = Function String [String] Expr
  21          | Extern String [String]
  22          | Eval Expr
  23   deriving Show
  24 data Expr = Num Double
  25           | BinOp BinOpType Expr Expr
  26           | Var String
  27           | Call String [Expr]
  28           | If Expr Expr Expr
  29           | For String Expr Expr (Maybe Expr) Expr
  30   deriving Show
  31 data BinOpType = Add | Sub | Mul | Cmp Ordering
  32   deriving Show
  33
  34 instance Read AST where
  35   readPrec = parseFunction +++ parseExtern +++ (Eval <$> readPrec)
  36     where parseFunction = do
  37             lift $ string "def" >> skipSpaces
  38             (name, params) <- parsePrototype
  39             lift skipSpaces
  40             Function name params <$> readPrec
  41           parseExtern = do
  42             lift $ string "extern" >> skipSpaces
  43             uncurry Extern <$> parsePrototype
  44           parsePrototype = lift $ do
  45             name <- munch1 isAlpha
  46             params <- between (char '(') (char ')') $
  47                       sepBy (munch1 isAlpha) skipSpaces
  48             return (name, params)
  49
  50 instance Read Expr where
  51   readPrec = choice [ parseParens
  52                     , parseNum
  53                     , parseVar
  54                     , parseCall
  55                     , parseIf
  56                     , parseFor
  57                     , parseBinOp "+" Add
  58                     , parseBinOp "-" Sub
  59                     , parseBinOp "*" Mul
  60                     , parseBinOp ">" (Cmp GT)
  61                     , parseBinOp "<" (Cmp LT)
  62                     , parseBinOp "==" (Cmp EQ)
  63                     ]
  64     where parseParens = step $ lift $
  65             between (char '(') (char ')') (readS_to_P reads)
  66           parseNum = Num <$> readPrec
  67           parseVar = Var <$> lift (munch1 isAlpha)
  68           parseCall = do
  69             func <- lift (munch1 isAlpha)
  70             params <- lift $ between (char '(') (char ')') $
  71                         sepBy (readS_to_P reads)
  72                               (skipSpaces >> char ',' >> skipSpaces)
  73             return (Call func params)
  74           parseBinOp s typ = step $ do
  75             a <- prec 11 readPrec -- set recursion limit of 11
  76             lift $ do
  77               skipSpaces
  78               string s
  79               skipSpaces
  80             BinOp typ a <$> readPrec
  81           parseIf = do
  82             lift $ do
  83               string "if"
  84               skipSpaces
  85             cond <- step readPrec
  86             lift $ do
  87               skipSpaces
  88               string "then"
  89               skipSpaces
  90             thenE <- step readPrec
  91             lift $ do
  92               skipSpaces
  93               string "else"
  94               skipSpaces
  95             elseE <- step readPrec
  96             return (If cond thenE elseE)
  97           parseFor = do
  98             lift $ do
  99               string "for"
 100               skipSpaces
 101             identifier <- lift (munch1 isAlpha)
 102             lift $ skipSpaces >> char '=' >> skipSpaces
 103             start <- step readPrec
 104             lift $ skipSpaces >> char ',' >> skipSpaces
 105             cond <- step readPrec
 106             step' <- (do
 107               lift $ skipSpaces >> char ',' >> skipSpaces
 108               Just <$> step readPrec) <++ pure Nothing
 109             lift $ skipSpaces >> string "in" >> skipSpaces
 110             body <- step readPrec
 111             return (For identifier start cond step' body)