-- fp-parser.hs
-- Christopher League, April 2001

import Monad

-- Parser type, with Functor and Monad instances.

data Parser a = P (String -> [(a, String)])
unP (P f) = f

instance Functor Parser where
  fmap f (P g) = P (map adjust . g)
      where adjust (v,s) = (f v, s)

instance Monad Parser where
  P f >>= g  = P (\s -> concat [unP (g v) s' | (v, s') <- f s])
  return v   = P (\s -> [(v,s)])

instance MonadPlus Parser where
  mzero = P (\s -> [])
  (P f) `mplus` (P g) = P (\s -> (f s) ++ (g s))

-- Parse a string and return a single result.
-- We allow trailing whitespace to remain unmatched.
run :: Parser a -> String -> a
run (P f) s = first $ filter complete $ f s
    where complete (_,s) = all isSpace s
          first [] = error "Parse error"
          first ((v,_):_) = v

-- Parser iterators  (Kleene star and plus)

kstar :: Parser a -> Parser [a]
kstar p = do x <- p
             xs <- kstar p
             return (x:xs)
          `mplus` return []

kplus :: Parser a -> Parser [a]
kplus p = do x <- p
             xs <- kstar p
             return (x:xs)

-- Primitive parsers

getC :: Parser Char
getC = P g
  where g [] = []
        g (c:cs) = [(c,cs)]

ifC :: (Char -> Bool) -> Parser Char
ifC p = do c <- getC
           if p c then return c else mzero

match :: String -> Parser String
match [] = return []
match (c:cs) = do c <- ifC (c==)
                  cs <- match cs
                  return (c:cs)


-- Aggregate parsers
-- Invariant: leading whitespace is automatically discarded.

ws :: Parser String
ws = kstar (ifC isSpace)

nat :: Parser Int
nat = do ws; s <- kstar (ifC isDigit)
         return (read s)

var :: Parser String
var = do ws; c <- ifC isAlpha
         cs <- kstar (ifC isAlphaNum)
         return (c:cs)

-- Matches a keyword, with optional leading whitespace.
-- note: if s already has leading whitespace, it will not match.
kw :: String -> Parser String
kw s = ws >> match s

-- Representation of the language we are parsing
type Var = String

-- Value Representation
data Val = Nil
         | Number Int
         | Cons Prog Prog
         | Lambda Var Prog
     deriving Show

-- Program Representation
data Prog = Value Val
          | Variable Var
          | Apply Prog Prog
          | Add Prog Prog  
          | IfZero Prog Prog Prog
          | Head Prog
          | Tail Prog
          | Case Prog Prog Var Var Prog
          | FixPoint Var Prog
     deriving Show

val :: Parser Val
val = msum [num, nil, cons, lam] 

 where num  = do fmap Number nat

       nil  = do kw "[]"; return Nil

       cons = do kw "cons"
                 p1 <- prog; p2 <- prog
                 return (Cons p1 p2)

       lam  = do kw "\\"; x <- var
                 kw "->"; p <- prog
                 return (Lambda x p)
                 
prog :: Parser Prog
prog = msum [vl, vr, app, add, ifz, hd, tl, cas, fix]

  where vl  = do fmap Value val

        vr  = do fmap Variable var

        app = do kw "app"
                 p1 <- prog; p2 <- prog
                 return (Apply p1 p2)

        add = do kw "plus"
                 p1 <- prog; p2 <- prog
                 return (Add p1 p2)

        ifz = do kw "ifzero"; p0 <- prog
                 kw "then";   p1 <- prog
                 kw "else";   p2 <- prog
                 return (IfZero p0 p1 p2)

        hd  = do kw "head"; p <- prog; return (Head p)
        tl  = do kw "tail"; p <- prog; return (Tail p)

        cas = do kw "case"; p0 <- prog
                 kw "of"; kw "[]"; kw "=>"; p1 <- prog
                 kw "|"; h <- var; kw ":"; t <- var
                 kw "=>"; p2 <- prog
                 return (Case p0 p1 h t p2)

        fix = do kw "mu"; x <- var 
                 kw "->"; p <- prog
                 return (FixPoint x p)

parse :: String -> Prog
parse = run prog