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 $ sepBy1 (readS_to_P reads) $ do
  12     skipSpaces
  13     char ';'
  14     skipSpaces
  15
  16 data AST = Function String [String] Expr
  17          | Eval Expr
  18   deriving Show
  19 data Expr = Num Float
  20           | BinOp BinOpType Expr Expr
  21           | Var String
  22           | Call String [Expr]
  23           | If Expr Expr Expr
  24   deriving Show
  25 data BinOpType = Add | Sub | Mul | Cmp Ordering
  26   deriving Show
  27
  28 instance Read AST where
  29   readPrec = parseFunction +++ (Eval <$> readPrec)
  30     where parseFunction = lift $ do
  31             skipSpaces
  32             string "def"
  33             skipSpaces
  34             name <- munch1 isAlpha
  35             params <- between (char '(') (char ')') $
  36                       sepBy (munch1 isAlpha) skipSpaces
  37             skipSpaces
  38             body <- readS_to_P reads
  39             return (Function name params body)
  40
  41 instance Read Expr where
  42   readPrec = choice [ parseNum
  43                     , parseVar
  44                     , parseCall
  45                     , parseIf
  46                     , parseBinOp "+" Add
  47                     , parseBinOp "-" Sub
  48                     , parseBinOp "*" Mul
  49                     , parseBinOp ">" (Cmp GT)
  50                     , parseBinOp "<" (Cmp LT)
  51                     , parseBinOp "==" (Cmp EQ)
  52                     ]
  53     where parseNum = Num <$> readPrec
  54           parseVar = Var <$> lift (munch1 isAlpha)
  55           parseCall = do
  56             func <- lift (munch1 isAlpha)
  57             params <- lift $ between (char '(') (char ')') $
  58                         sepBy (readS_to_P reads)
  59                               (skipSpaces >> char ',' >> skipSpaces)
  60             return (Call func params)
  61           parseBinOp s typ = step $ do
  62             a <- prec 11 readPrec
  63             lift $ do
  64               skipSpaces
  65               string s
  66               skipSpaces
  67             b <- readPrec
  68             return (BinOp typ a b)
  69           parseIf = do
  70             lift $ do
  71               string "if"
  72               skipSpaces
  73             cond <- step readPrec
  74             lift $ do
  75               skipSpaces
  76               string "then"
  77               skipSpaces
  78             thenE <- step readPrec
  79             lift $ do
  80               skipSpaces
  81               string "else"
  82               skipSpaces
  83             elseE <- step readPrec
  84             return (If cond thenE elseE)