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   deriving Show
  30 data BinOpType = Add | Sub | Mul | Cmp Ordering
  31   deriving Show
  32
  33 instance Read AST where
  34   readPrec = parseFunction +++ parseExtern +++ (Eval <$> readPrec)
  35     where parseFunction = do
  36             lift $ string "def" >> skipSpaces
  37             (name, params) <- parsePrototype
  38             lift skipSpaces
  39             Function name params <$> readPrec
  40           parseExtern = do
  41             lift $ string "extern" >> skipSpaces
  42             uncurry Extern <$> parsePrototype
  43           parsePrototype = lift $ do
  44             name <- munch1 isAlpha
  45             params <- between (char '(') (char ')') $
  46                       sepBy (munch1 isAlpha) skipSpaces
  47             return (name, params)
  48
  49 instance Read Expr where
  50   readPrec = choice [ parseParens
  51                     , parseNum
  52                     , parseVar
  53                     , parseCall
  54                     , parseIf
  55                     , parseBinOp "+" Add
  56                     , parseBinOp "-" Sub
  57                     , parseBinOp "*" Mul
  58                     , parseBinOp ">" (Cmp GT)
  59                     , parseBinOp "<" (Cmp LT)
  60                     , parseBinOp "==" (Cmp EQ)
  61                     ]
  62     where parseParens = step $ lift $
  63             between (char '(') (char ')') (readS_to_P reads)
  64           parseNum = Num <$> readPrec
  65           parseVar = Var <$> lift (munch1 isAlpha)
  66           parseCall = do
  67             func <- lift (munch1 isAlpha)
  68             params <- lift $ between (char '(') (char ')') $
  69                         sepBy (readS_to_P reads)
  70                               (skipSpaces >> char ',' >> skipSpaces)
  71             return (Call func params)
  72           parseBinOp s typ = step $ do
  73             a <- prec 11 readPrec -- set recursion limit of 11
  74             lift $ do
  75               skipSpaces
  76               string s
  77               skipSpaces
  78             BinOp typ a <$> readPrec
  79           parseIf = do
  80             lift $ do
  81               string "if"
  82               skipSpaces
  83             cond <- step readPrec
  84             lift $ do
  85               skipSpaces
  86               string "then"
  87               skipSpaces
  88             thenE <- step readPrec
  89             lift $ do
  90               skipSpaces
  91               string "else"
  92               skipSpaces
  93             elseE <- step readPrec
  94             return (If cond thenE elseE)