ExpParser-chainl1.hs

{-# LANGUAGE TupleSections #-}
import Data.Char
import Control.Monad
import Control.Applicative hiding (many)
import Text.ParserCombinators.ReadP

import Test.QuickCheck

data Exp = Add Exp Exp
         | Sub Exp Exp
         | Mul Exp Exp
         | Div Exp Exp
         | Num Int
         deriving (Show, Eq)

instance Arbitrary Exp where
  arbitrary = frequency $ (40, Num <$> posInt) :
              map (10,) [ Add <$> arbitrary <*> arbitrary
                        , Sub <$> arbitrary <*> arbitrary
                        , Mul <$> arbitrary <*> arbitrary
                        , Div <$> arbitrary <*> arbitrary ]
    where posInt = fmap abs arbitrary

prettyPrint :: Exp -> String
prettyPrint = pp
  where pp :: Exp -> String
        pp (Add e1 e2) = binop "+" e1 e2
        pp (Sub e1 e2) = binop "-" e1 e2
        pp (Mul e1 e2) = binop "*" e1 e2
        pp (Div e1 e2) = binop "/" e1 e2
        pp (Num i)     = show i

        binop :: String -> Exp -> Exp -> String
        binop op e1 e2 = concat ["(", pp e1, " ", op, " ", pp e2, ")"]

pppTest :: IO ()
pppTest = quickCheck $ \exp -> case parse (prettyPrint exp) of
                         Right exp' -> exp == exp'
                         otherwise  -> False

space :: ReadP Char
space = char ' '

spaces :: ReadP String
spaces = many space

token :: ReadP a -> ReadP a
token p = do
  res <- p
  spaces
  return res

symbol :: String -> ReadP String
symbol = token . string

num :: ReadP Int
num = token $ liftM read (many1 $ satisfy isDigit)

-- Start production
exp' :: ReadP Exp
exp' = do
  e <- exp1
  eof
  return e

exp1 :: ReadP Exp
exp1 = chainl1 exp2 plus
  where
    plus :: ReadP (Exp -> Exp -> Exp)
    plus = do symbol "+"
              return Add

exp2 :: ReadP Exp
exp2 = chainl1 exp3 minus
  where
    minus :: ReadP (Exp -> Exp -> Exp)
    minus = do symbol "-"
               return Sub

exp3 :: ReadP Exp
exp3 = chainl1 exp4 times
  where
    times = do symbol "*"
               return Mul

exp4 :: ReadP Exp
exp4 = chainl1 exp5 divide
  where
    divide = do symbol "/"
                return Div

exp5 :: ReadP Exp
exp5 = do n <- num
          return (Num n)
       +++
       do symbol "("
          e <- exp1
          symbol ")"
          return e

parse :: String -> Either String Exp
parse s =
  case readP_to_S exp' s of
    [(exp, "")] -> Right exp
    []          -> Left "Invalid"
    _           -> Left "Ambiguous"