-- ***************************************************************************
--  Parsing library in Haskell
-- ***************************************************************************

module Parselib where

infixl 8 `apP`, `doP`, `bindP`
infixr 6 `consP`
infix  4 `as`
infixr 2 `orelse`

-- ***************************************************************************
-- the parsing monad is backtracking + state
-- we make it a new type so that type errors give comprehensible messages.
-- ***************************************************************************
data Parser t a = Parser ([t] -> [(a,[t])])
unParser (Parser p) = p

unitP x = Parser (\ts -> [(x,ts)])
Parser p `bindP` f = 
   Parser (\ts -> [(v,ts'') | (u,ts') <- p ts, (v,ts'') <- unParser (f u) ts'])

-- ***************************************************************************
-- primitives that depend on the monad
-- ***************************************************************************
failure = Parser (\_ -> [])
Parser p `orelse` Parser q = Parser (\ts -> p ts++q ts)
cut (Parser p) = Parser (\ts -> [head (p ts)])
token = Parser (\ts -> case ts of
                          t:ts' -> [(t,ts')]
                          [] -> [])
eof = Parser (\ts -> case ts of
                        t:ts' -> []
                        [] -> [((),[])])

-- ***************************************************************************
-- operations useful in any monad
-- ***************************************************************************
mapP f x = x `bindP` \v -> unitP (f v)
binP op x y = x `bindP` \v ->
              y `bindP` \w ->
              unitP (v `op` w)
apP = binP (\f x -> f x)
doP = binP const
consP = binP (:)
pairP = binP (\x y->(x,y))

-- ***************************************************************************
-- low-level parsing primitives
-- ***************************************************************************
satisfy p = token `bindP` \tok -> if p tok then unitP tok else failure
literal t = satisfy (==t)

-- ***************************************************************************
-- combinators for repetition
-- ***************************************************************************
many p = cut (some p `orelse` unitP [])
some p = p `consP` many p

-- ***************************************************************
-- combinators for expression parsing
-- ***************************************************************
lassoc op e = unitP (foldl f) `apP` e `apP` many (op `pairP` e)
              where f e (o,e') = o e e'

-- ***************************************************************************
-- combinators for lexical analysis
-- ***************************************************************************
string :: Eq a => [a] -> Parser a [a]
string = foldr consP (unitP []) . map literal
anyOf f = foldr orelse failure . map f
word = satisfy isAlpha `consP` many (satisfy isAlphaNum)
number = some (satisfy isDigit)

-- ***************************************************************************
-- combinators for creating and parsing tagged tokens
-- ***************************************************************************
x `as` t = x `bindP` \v -> unitP (v,t)
kind t = token `bindP` \(v,t') -> if t==t' then unitP v else failure
strip t xs = [(v,t') | (v,t')<-xs, t/=t']

-- ***************************************************************************
-- invoking a parser
-- ***************************************************************************
parse p ts = case unParser (p `doP` eof) ts of
                         [] -> error "No parse!\n"
                         (v,_):_ -> v