{-----------------------------------------------------------------------------

                 A LIBRARY OF MONADIC PARSER COMBINATORS

                              29th July 1996

                 Graham Hutton               Erik Meijer
            University of Nottingham    University of Utrecht

This Haskell 1.3 script defines a library of parser combinators, and is taken
from sections 1-6 of our article "Monadic Parser Combinators".  Some changes
to the library have been made in the move from Gofer to Haskell:

   * Do notation is used in place of monad comprehension notation;

   * The parser datatype is defined using "newtype", to avoid the overhead
     of tagging and untagging parsers with the P constructor.

-----------------------------------------------------------------------------}

module ParseLib
   (Parser(..), item, papply, (+++), {-sat,-} tok, many, many1, sepby, sepby1, chainl,
    chainl1, chainr, chainr1, ops, bracket, elserror, cut {-, char, digit, lower, upper,
    letter, alphanum, string, ident, nat, int, spaces, comment, junk,
    parse, token, natural, integer, symbol, identifier-}) where

import Char
import HandLex (Token(..), TokenT, Posn)
import Monad

infixr 5 +++

#if defined (__HASKELL98__)
#define MPLUS `mplus`
#else
#define fmap map
#define mzero zero
#define MPLUS ++
#endif

--- The parser monad ---------------------------------------------------------

newtype Parser a   = P ([Token] -> [(a,[Token])])

instance Functor Parser where
   -- fmap         :: (a -> b) -> (Parser a -> Parser b)
   fmap f (P p)     = P (\inp -> [(f v, out) | (v,out) <- p inp])

instance Monad Parser where
   -- return      :: a -> Parser a
   return v        = P (\inp -> [(v,inp)])

   -- >>=         :: Parser a -> (a -> Parser b) -> Parser b
   (P p) >>= f     = P (\inp -> concat [papply (f v) out | (v,out) <- p inp])

#if defined(__HASKELL98__)
   fail s          = P (\inp -> [])
#endif

#if defined(__HASKELL98__)
instance MonadPlus Parser where
#else
instance MonadZero Parser where
#endif
   -- mzero            :: Parser a
   mzero                = P (\inp -> [])
#if !defined(__HASKELL98__)
instance MonadPlus Parser where
#endif
   -- mplus            :: Parser a -> Parser a -> Parser a
   (P p) MPLUS (P q)    = P (\inp -> (p inp ++ q inp))

--- Other primitive parser combinators ---------------------------------------

--item              :: Parser Char
--item               = P (\inp -> case inp of
--                                   []     -> []
--                                   (x:xs) -> [(x,xs)])

item               :: Parser Token
item                = P (\inp -> case inp of
                                   []     -> []
                                   (x:xs) -> [(x,xs)])

force             :: Parser a -> Parser a
force (P p)        = P (\inp -> let x = p inp in
                                (fst (head x), snd (head x)) : tail x)

first             :: Parser a -> Parser a
first (P p)        = P (\inp -> case p inp of
                                   []     -> []
                                   (x:xs) -> [x])

papply            :: Parser a -> [Token] -> [(a,[Token])]
papply (P p) inp   = p inp

cut               :: Parser a -> Parser b -> Parser b
(P p) `cut` q      = P (\inp -> case p inp of
                                   []         -> []
                                   ((x,ss):_) -> papply q ss)

--- Derived combinators ------------------------------------------------------

(+++)             :: Parser a -> Parser a -> Parser a
p +++ q            = first (p MPLUS q)

--sat               :: (Char -> Bool) -> Parser Char
--sat p              = do {x <- item; if p x then return x else mzero}

tok               :: TokenT -> Parser TokenT
tok t              = do {x <- item; if t==snd x then return t else mzero}

many              :: Parser a -> Parser [a]
many p             = many1 p +++ return []
--many p           = force (many1 p +++ return [])

many1             :: Parser a -> Parser [a]
many1 p            = do {x <- p; xs <- many p; return (x:xs)}

sepby             :: Parser a -> Parser b -> Parser [a]
p `sepby` sep      = (p `sepby1` sep) +++ return []

sepby1            :: Parser a -> Parser b -> Parser [a]
p `sepby1` sep     = do {x <- p; xs <- many (do {sep; p}); return (x:xs)}

chainl            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainl p op v      = (p `chainl1` op) +++ return v

chainl1           :: Parser a -> Parser (a -> a -> a) -> Parser a
p `chainl1` op     = do {x <- p; rest x}
                     where
                        rest x = do {f <- op; y <- p; rest (f x y)}
                                 +++ return x

chainr            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainr p op v      = (p `chainr1` op) +++ return v

chainr1           :: Parser a -> Parser (a -> a -> a) -> Parser a
p `chainr1` op     = do {x <- p; rest x}
                     where
                        rest x = do {f <- op; y <- p `chainr1` op; return (f x y)}
                                 +++ return x

ops               :: [(Parser a, b)] -> Parser b
ops xs             = foldr1 (+++) [do {p; return op} | (p,op) <- xs]

bracket           :: Parser a -> Parser b -> Parser c -> Parser b
bracket open p close = do {open;
                           x <- p;
                           close;
                           return x}

elserror          :: Parser a -> String -> Parser a
p `elserror` s     = p +++
                     (P (\inp->
                         case inp of
                           [] -> error "Parse error: unexpected EOF\n"
                           ((p,t):_) ->
                                 error ("Parse error at "++show p++": "++s++"\n"++
                                        "    next token: "++show t)))


{-- Useful parsers -----------------------------------------------------------

char              :: Char -> Parser Char
char x             = sat (\y -> x == y)

digit             :: Parser Char
digit              = sat isDigit

lower             :: Parser Char
lower              = sat isLower

upper             :: Parser Char
upper              = sat isUpper

letter            :: Parser Char
letter             = sat isAlpha

alphanum          :: Parser Char
alphanum           = sat isAlphaNum

string            :: String -> Parser String
string ""          = return ""
string (x:xs)      = do {char x; string xs; return (x:xs)}

ident             :: Parser String
ident              = do {x <- lower; xs <- many alphanum; return (x:xs)}

nat               :: Parser Int
nat                = do {x <- digit; return (fromEnum x - fromEnum '0')} `chainl1` return op
                     where
                        m `op` n = 10*m + n

int               :: Parser Int
int                = do {char '-'; n <- nat; return (-n)} +++ nat

--- Lexical combinators ------------------------------------------------------

spaces            :: Parser ()
spaces             = do {many1 (sat isSpace); return ()}

comment           :: Parser ()
--comment            = do {string "--"; many (sat (\x -> x /= '\n')); return ()}
comment            = do 
                       _ <- string "--"
                       _ <- many (sat (\x -> x /= '\n'))
                       return ()

junk              :: Parser ()
junk               = do {many (spaces +++ comment); return ()}

parse             :: Parser a -> Parser a
parse p            = do {junk; p}

token             :: Parser a -> Parser a
token p            = do {v <- p; junk; return v}

--- Token parsers ------------------------------------------------------------

natural           :: Parser Int
natural            = token nat

integer           :: Parser Int
integer            = token int

symbol            :: String -> Parser String
symbol xs          = token (string xs)

identifier        :: [String] -> Parser String
identifier ks      = token (do {x <- ident;
                                if not (elem x ks) then return x
                                else return mzero})

-----------------------------------------------------------------------------}