----------------------------------------
-- 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
             deriving (Read,Show)

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"
                            where [(n,r)] = readDec s

--------------------
-- 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)
                deriving (Read,Show)

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
--------------------