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 [ parseParens
  43                     , parseNum
  44                     , parseVar
  45                     , parseCall
  46                     , parseIf
  47                     , parseBinOp "+" Add
  48                     , parseBinOp "-" Sub
  49                     , parseBinOp "*" Mul
  50                     , parseBinOp ">" (Cmp GT)
  51                     , parseBinOp "<" (Cmp LT)
  52                     , parseBinOp "==" (Cmp EQ)
  53                     ]
  54     where parseParens = step $ lift $
  55             between (char '(') (char ')') (readS_to_P reads)
  56           parseNum = Num <$> readPrec
  57           parseVar = Var <$> lift (munch1 isAlpha)
  58           parseCall = do
  59             func <- lift (munch1 isAlpha)
  60             params <- lift $ between (char '(') (char ')') $
  61                         sepBy (readS_to_P reads)
  62                               (skipSpaces >> char ',' >> skipSpaces)
  63             return (Call func params)
  64           parseBinOp s typ = step $ do
  65             a <- prec 11 readPrec
  66             lift $ do
  67               skipSpaces
  68               string s
  69               skipSpaces
  70             b <- readPrec
  71             return (BinOp typ a b)
  72           parseIf = do
  73             lift $ do
  74               string "if"
  75               skipSpaces
  76             cond <- step readPrec
  77             lift $ do
  78               skipSpaces
  79               string "then"
  80               skipSpaces
  81             thenE <- step readPrec
  82             lift $ do
  83               skipSpaces
  84               string "else"
  85               skipSpaces
  86             elseE <- step readPrec
  87             return (If cond thenE elseE)