AST.hs

   1 module AST where
   2
   3 import Data.Char
   4 import Text.Read
   5 import Text.ParserCombinators.ReadP hiding ((+++), choice)
   6
   7 data Expr = Num Double
   8           | Var String
   9           | BinOp BinOp Expr Expr
  10           | Call String [Expr]
  11           | If Expr Expr Expr
  12   deriving Show
  13
  14 data BinOp = Add | Sub | Mul | Cmp Ordering
  15   deriving Show
  16
  17 instance Read Expr where
  18   readPrec = parens $ choice [ parseNum
  19                              , parseVar
  20                              , parseCall
  21                              , parseIf
  22                              , parseBinOp "<" 10 (Cmp LT)
  23                              , parseBinOp ">" 10 (Cmp GT)
  24                              , parseBinOp "==" 10 (Cmp EQ)
  25                              , parseBinOp "+" 20 Add
  26                              , parseBinOp "-" 20 Sub
  27                              , parseBinOp "*" 40 Mul
  28                              ]
  29     where parseNum = Num <$> readPrec
  30           parseVar = Var <$> lift (munch1 isAlpha)
  31           parseBinOp s prc op = prec prc $ do
  32             a <- step readPrec
  33             spaced $ string s
  34             b <- readPrec
  35             return (BinOp op a b)
  36           parseCall = do
  37             func <- lift (munch1 isAlpha)
  38             params <- lift $ between (char '(') (char ')') $
  39                         sepBy (readS_to_P reads)
  40                               (skipSpaces >> char ',' >> skipSpaces)
  41             return (Call func params)
  42           parseIf = do
  43             spaced $ string "if"
  44             cond <- readPrec
  45             spaced $ string "then"
  46             thenE <- readPrec
  47             spaced $ string "else"
  48             elseE <- readPrec
  49             return (If cond thenE elseE)
  50           spaced f = lift $ skipSpaces >> f >> skipSpaces
  51
  52 data Prototype = Prototype String [String]
  53   deriving Show
  54
  55 instance Read Prototype where
  56   readPrec = lift $ do
  57     name <- munch1 isAlpha
  58     params <- between (char '(') (char ')') $
  59                 sepBy (munch1 isAlpha) skipSpaces
  60     return (Prototype name params)
  61
  62 data AST = Function Prototype Expr
  63          | Extern Prototype
  64          | TopLevelExpr Expr
  65   deriving Show
  66
  67 instance Read AST where
  68   readPrec = parseFunction +++ parseExtern +++ parseTopLevel
  69     where parseFunction = do
  70             lift $ string "def" >> skipSpaces
  71             Function <$> readPrec <*> readPrec
  72           parseExtern = do
  73             lift $ string "extern" >> skipSpaces
  74             Extern <$> readPrec
  75           parseTopLevel = TopLevelExpr <$> readPrec