--------------------
-- A (short) parser combinator library
-- by Graham Hutton and Erik Meijer (mod. Fritz Ruehr)

module ShortParse where

				{- (Parser, parse, (+++), sat, chainl1, token, lit,
                   bracket, char, digit, string, int) -}

import Monad
import Char
infixr 5 +++

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

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

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

instance Monad Parser where
   return v        = P (\inp -> [(v,inp)])
   (P p) >>= f     = P (\inp -> concat [papply (f v) out | (v,out) <- p inp])

instance MonadPlus Parser where
   mzero                = P (\inp -> [])
   (P p) `mplus` (P q)  = P (\inp -> (p inp ++ q inp))

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

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

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

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

papply (P p) inp   = p inp

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

p +++ q            = first (p `mplus` q)

sat p              = do {x <- item; if p x then return x else mzero}

many1 p            = do {x <- p; xs <- many p; return (x:xs)}

many p             = force (many1 p +++ return [])

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

bracket open p close = do {open; x <- p; close; return x}

--- Useful parsers -----------------------------------------------------------

char x             = sat (\y -> x == y)

digit              = sat isDigit

string ""          = return ""
string (x:xs)      = do {char x; string xs; return (x:xs)}

int                = do {x <- digit; return (toInteger (digitToInt x))} `chainl1` return op
                     where m `op` n = 10 * m + n :: Integer

token p            = do { v <- p; spaces; return v }

spaces             = do { many (sat isSpace); return () }

lit                = token . char

symbol xs          = token (string xs)

parse p str = case papply (spaces >> token p) str of
                [(r, "")] -> r
                [(r, eh)] -> error ("parse failed at: " ++ eh)
                otherwise -> error "no unique parse"