A Flexible Expression Parser in Haskell

```----------------------------------------
-- A Flexible Expression Parser in Haskell
-- Fritz Ruehr, Willamette University, October 2001
-- For the 3rd Annual CCSC Northwest Conference
----------------------------------------
```

```--------------------
-- Scanning

data Token = Lit Integer | Op Char

scan [] = []
scan s@(c:cs) | isSpace c = scan cs
| isOp    c = Op c  : scan cs
| isDigit c = Lit n : scan r
| otherwise = error "bad symbol"
```

```--------------------
-- Parsing

parse f g ts =
case foldl shred [] ts of
[t] -> t
s   -> error "too few ops"
where shred      s  (Lit n) = f n : s
shred (a:b:s)  (Op c) = g c b a : s
shred      s   _ = error "too few args"
```

```--------------------
-- Operators

isOp = (`elem` "+*-")

getOp '+' = (+)
getOp '*' = (*)
getOp '-' = (-)
getOp  _  = error "bad symbol"
```

```--------------------
-- Trees

data Tree a b = Leaf a | Node b (Tree a b) (Tree a b)

fold f g (Leaf n)     = f n
fold f g (Node o l r) = g o (fold f g l) (fold f g r)

parsetree = parse Leaf Node
evaltree  = fold  id  getOp
parsenum  = parse id  getOp
```

```--------------------
-- Printing

inord   = ( paren.unwords, \o l r -> [l,o,r] )
preord  = (       unwords, \o l r -> [o,l,r] )
postord = (       unwords, \o l r -> [l,r,o] )

paren s = "(" ++ s ++ ")"

prtree :: (Show a, Show b) =>
([String] -> String, [b] -> String -> String -> [String]) -> Tree a b -> String

prtree    = format fold
parseexpr = format parse

format handler (wrap,ord) =
handler show (\o l r -> wrap (ord [o] l r))
```

```--------------------
-- Pairing

pairparse = pair (parse id getOp) (parse Leaf Node)
parsepair = parse (pair id Leaf) (pair3 getOp Node)

prtpair disp (n,t) = prtree disp t ++ " = " ++ show n

pair f g x = (f x, g x)

pair3 f g o (l,l') (r,r') = (f o l r, g o l' r')
```

```--------------------
-- Calculation

trace     = fold  (\n->[Leaf n]) step . parsetree
parsecalc = parse (\n->[Leaf n]) step

step o l@(Leaf n:_) r@(Leaf m:_) =
Leaf (getOp o n m)
:  map (Node o (head l)) r
++ map (flip (Node o) (last r)) (tail l)

prtcalc disp = eqline . map (prtree disp) . reverse

eqline = foldr1 (\x y -> x ++ "\n\n  = " ++ y)
```

```--------------------
-- User interaction

run greet done close disp
= do putStr greet
str <- getLine
if done str then do println close
else do println (disp str)
run greet done close disp

demo = run "\nEnter expressions (blank to stop):\n--> "
(=="") "Bye!"

println = putStrLn . ('\n':)
```

```--------------------
-- Test data and sample applications

test  = " 2 3 +  4 - 5  2 *  * "
tokes = scan test
tree  = parsetree tokes

-- scan test
-- parsetree \$\$
-- evaltree  \$\$

-- parsenum tokes

-- prtree inord (parsetree tokes)
-- parseexpr inord tokes

-- pairparse tokes
-- parsepair tokes
-- prtpair inord \$\$

-- trace tokes
-- parsecalc tokes
-- prtcalc inord \$\$
-- putStr \$\$

-- demo (prtree preord . parsetree . scan)
-- demo (prtcalc inord . trace     . scan)
-- demo (show          . parsenum  . scan)

--------------------
-- End of file
--------------------

```