----------------------------------------------------------------------

               A LIBRARY OF MONADIC PARSER COMBINATORS

            Graham Hutton and Erik Meijer, December 1995

This literate Gofer script defines a library of parser combinators, and
is taken from sections 1-6 of our article "Monadic Parser Combinators".
For reasons of efficiency or specific details of Gofer, some combinators
are defined slightly differently from the article.  Their functionality,
however, remains the same as those given in the article.

NOTE: This library requires Gofer version 2.30b or greater.  You will
also need to set the standard prelude to be the constructor classes
prelude "cc.prelude"; see the Gofer documentation for further details.


--- Operator precedences ---------------------------------------------

> infixr 5 +++

--- Primitive parser combinators -------------------------------------

> type Parser a  = String -> [(a,String)]
>                  in mapP, resultP, bindP, zeroP,
>                     plusP, item, force, first, parse
>
> mapP          :: (a -> b) -> (Parser a -> Parser b)
> mapP f p       = \inp -> [(f v, out) | (v,out) <- p inp]
>
> resultP       :: a -> Parser a
> resultP v      = \inp -> [(v,inp)]
>
> bindP         :: Parser a -> (a -> Parser b) -> Parser b
> p `bindP` f    = \inp -> concat [f v out | (v,out) <- p inp]
>
> zeroP         :: Parser a
> zeroP          = \inp -> []
>
> plusP         :: Parser a -> Parser a -> Parser a
> p `plusP` q    = \inp -> (p inp ++ q inp)
>
> item          :: Parser Char
> item           = \inp -> case inp of
>                             []     -> []
>                             (x:xs) -> [(x,xs)]
>
> force         :: Parser a -> Parser a
> force p        = \inp -> let x = p inp in
>                          (fst (head x), snd (head x)) : tail x
>
> first         :: Parser a -> Parser a
> first p        = \inp -> case p inp of
>                             []     -> []
>                             (x:xs) -> [x]
>    
> parse         :: Parser a -> String -> [(a,String)]
> parse p inp    = strip p inp
>
> instance Functor Parser where
>    map    = mapP
>
> instance Monad Parser where
>    result = resultP
>    bind   = bindP
>
> instance Monad0 Parser where
>    zero   = zeroP
>
> instance MonadPlus Parser where
>    (++)   = plusP

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

> (+++)         :: Parser a -> Parser a -> Parser a
> p +++ q        = first (p ++ q)
>
> sat           :: (Char -> Bool) -> Parser Char
> sat p          = [x | x <- item, p x]
>
> many          :: Parser a -> Parser [a]
> many p         = force (many1 p +++ [[]])
>
> many1         :: Parser a -> Parser [a]
> many1 p        = [x:xs | x <- p, xs <- many p]
>
> sepby         :: Parser a -> Parser b -> Parser [a]
> p `sepby` sep  = (p `sepby1` sep) +++ [[]]
>
> sepby1        :: Parser a -> Parser b -> Parser [a]
> p `sepby1` sep = [x:xs | x  <- p
>                        , xs <- many [y | _ <- sep, y <- p]]
>
> chainl        :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
> chainl p op v  = (p `chainl1` op) +++ [v]
>
> chainl1       :: Parser a -> Parser (a -> a -> a) -> Parser a
> p `chainl1` op = p `bind` rest
>                  where
>                     rest x = (op `bind` \f ->
>                               p  `bind` \y ->
>                               rest (f x y)) +++ [x]
>
> chainr        :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
> chainr p op v  = (p `chainr1` op) +++ [v]
>
> chainr1       :: Parser a -> Parser (a -> a -> a) -> Parser a
> p `chainr1` op = p `bind` \x ->
>                  [f x y | f <- op, y <- p `chainr1` op] +++ [x]
>
> ops           :: [(Parser a, b)] -> Parser b
> ops xs         = foldr1 (+++) [[op | _ <- p] | (p,op) <- xs]
>
> bracket       :: Parser a -> Parser b -> Parser c -> Parser b
> bracket open p close = [x | _ <- open, x <- p, _ <- close]

--- 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 ""      = [""]
> string (x:xs)  = [x:xs | _ <- char x, _ <- string xs]
>
> ident         :: Parser String
> ident          = [x:xs | x <- lower, xs <- many alphanum]
>
> nat           :: Parser Int
> nat            = [ord x - ord '0' | x <- digit] `chainl1` [op]
>                  where
>                     m `op` n = 10*m + n
>
> int           :: Parser Int
> int            = [-n | _ <- char '-', n <- nat] +++ nat

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

> spaces        :: Parser ()
> spaces         = [() | _ <- many1 (sat isSpace)]
>
> comment       :: Parser ()
> comment        = [() | _ <- string "--"
>                      , _ <- many (sat (\x -> x /= '\n'))]
>
> junk          :: Parser ()
> junk           = [() | _ <- many (spaces +++ comment)]
>
> strip         :: Parser a -> Parser a
> strip p        = [v | _ <- junk, v <- p]
>
> token         :: Parser a -> Parser a
> token p        = [v | v <- p, _ <- junk]

--- 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 [x | x <- ident, not (elem x ks)]

----------------------------------------------------------------------