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