parser of alternating current to direct current converter

ac2dc.hs

module AC2DC () where

import Control.Monad (guard)
import Control.Applicative ((<$>), (<*>), (<*), (*>))
import Text.ParserCombinators.Parsec

type Id = String

data ASTree = Prog ASTree ASTree
            | Dcls [ASTree] | FloatDcl Id | IntDcl Id
            | Stmts [ASTree]
            | Assign Id ASTree
            | Print Id
            | Plus ASTree ASTree  | Minus ASTree ASTree
            | Times ASTree ASTree | Over ASTree ASTree
            | ValRef Id
            | INum String
            | FNum String
            deriving (Show)

parseProgram :: String -> Either ParseError ASTree
parseProgram = parse (spaces *> pprog <* eof) "AC2DC"

pprog :: GenParser Char st ASTree
pprog = Prog <$> pdcls <*> pstmts

pdcls = Dcls <$> many (FloatDcl <$> try (char 'f' *> skipMany1 space *> pid)
                   <|> IntDcl <$> try (char 'i' *> skipMany1 space *> pid))
             <* spaces

pstmts = Stmts <$> many (Print <$> try (char 'p' *> spaces *> pid)
                     <|> Assign <$> pid <*> (char '=' *> spaces *> pexpr))
               <* spaces

operators = [('+', Plus), ('-', Minus), ('*', Times), ('/', Over)]

makeExpr :: ASTree -> (Char, ASTree) -> ASTree
makeExpr ast0 (op, ast1) =
  case lookup op operators of
    Just ctor -> ctor ast0 ast1
    Nothing -> error "expecting operator +, -, *, or /" -- throw an exception

pexpr = foldl makeExpr <$> pterm <*> many ((,) <$> (oneOf "+-" <* spaces) <*> pterm)
pterm = foldl makeExpr <$> pval <*> many ((,) <$> (oneOf "*/" <* spaces) <*> pval)

pval = (pnum <|> (ValRef <$> pid)) <* spaces

pnum = do
  integer <- pdigits
  fractional <- (char '.' *> pdigits) <|> return []
  spaces
  return $ if null fractional
           then INum integer
           else FNum (integer ++ "." ++ fractional)

pid = try $ do
  name <- many1 (oneOf ['a'..'z'])
  guard $ not (name `elem` ["f", "i", "p"])
  spaces
  return name

pdigits = many1 (oneOf ['0'..'9']) <* spaces