Parsing a simple Expr type with the Earley library

earleyexpr.hs

{-# LANGUAGE LambdaCase, DeriveFunctor, RecursiveDo #-}

-- parsing
import Text.Earley (Grammar, Prod,
                    parser, fullParses, rule, satisfy, token, list)
import Control.Applicative ((<|>), some)
import Data.Char (isDigit)

-- recursion schemes
import Data.Functor.Foldable (Fix(..), cata)

-- IO stuff for main
import System.Environment (getArgs)
import Data.Foldable (for_)


data ExprF a r = LitF a
               | AddF r r
               | SubF r r
               | MulF r r
               | DivF r r
    deriving (Eq, Show, Functor)

type Expr a = Fix (ExprF a)

evalAlg :: Num a => (a -> a -> a) -> ExprF a a -> a
evalAlg (/\) = \case
    LitF x   -> x
    AddF x y -> x + y
    SubF x y -> x - y
    MulF x y -> x * y
    DivF x y -> x /\ y

evalI :: Integral a => Expr a -> a
evalI = cata $ evalAlg div

evalF :: Fractional a => Expr a -> a
evalF = cata $ evalAlg (/)

ppr :: Show a => Expr a -> String
ppr = ($ "") . pprS

pprS :: Show a => Expr a -> ShowS
pprS expr = cata alg expr False
  where
    alg (LitF x)   p = let s = show x in showParen (p && elem ' ' s) (s ++)
    alg (AddF f g) p = showParen p $ f True . ('+' :) . g True
    alg (SubF f g) p = showParen p $ f True . ('-' :) . g True
    alg (MulF f g) p = showParen p $ f True . ('*' :) . g True
    alg (DivF f g) p = showParen p $ f True . ('/' :) . g True

exprGrammar :: Read a => Grammar r (Prod r e Char (Expr a))
exprGrammar = mdo
    let fixB f x y = Fix (f x y)
    digits <- rule $ some (satisfy isDigit)
    dotted <- rule $ digits <> list "." <> digits
    expr   <- rule $ Fix . LitF . read <$> (digits <|> dotted)
              <|> token '(' *> expr <* token ')'
              <|> fixB AddF <$> expr <* token '+' <*> expr
              <|> fixB SubF <$> expr <* token '-' <*> expr
              <|> fixB MulF <$> expr <* token '*' <*> expr
              <|> fixB DivF <$> expr <* token '/' <*> expr
    return expr

main :: IO ()
main = do
    let p = parser exprGrammar
    args <- getArgs
    for_ args $ \arg -> do
        let parses = fst $ fullParses p arg
        putStrLn $ arg ++ " has " ++ show (length parses) ++ " total parses:"
        for_ parses $ \expr -> do
            putStrLn $ "  " ++ ppr expr ++ " evaluates to " ++ show (evalI expr)
        putStrLn ""