module PM(PM,tokenP,manyP,runPM) where
import Monad(liftM,MonadPlus(..),ap)
import Pretty

{-+
An implementation of fairly conventional monadic parsing combinators
--------------------------------------------------------------------

This is fairly simple. There is a complication in the error to case get
descent error messages.

On success, a parser function returns the result and the remaining input.
On error, the parser function returns the list of acceptable tokens
at the high water mark, and the remaining input.
-}
newtype PM res =
   PM {unPM ::[String] -> Either ([String],[String]) (res,[String])}

runPM p args =
  case unPM p args of
    Right (r,[]) -> r
    Right (_,args) -> fail $ "Unrecognized arguments: "++unwords args
    Left (args,errs) ->
        fail $ ('\n':) $ render $
               text "Expected one of:"<+>fsep (map text errs)
               $$ (if null args then empty else text "Found: "<+>fsep (map text args))
               $$ text ""

instance Functor PM where fmap = liftM

instance Monad PM where
  fail s = PM $ \ args->Left (args,[s])
  return x = PM $ \args->Right (x,args)
  PM p1>>=xp2 = PM $ \ args->case p1 args of
			       Left err -> Left err
			       Right (x,args') -> unPM (xp2 x) args'

instance MonadPlus PM where
  mzero = fail "no parse" -- Hmm. Error message should say what was expected
  mplus (PM p1) (PM p2) =
    PM $ \ args -> case (p1 args,p2 args) of
		     (Right res,_) -> Right res
		     (r1@(Left (a1,errs1)),r2@(Left (a2,errs2))) ->
			 case compare (length a1) (length a2) of
                           LT -> r1
			   EQ -> Left (a1,errs1++errs2)
			   GT -> r2
		     (_,r2) -> r2

get = PM $ \ args -> Right (args,args)
set args = PM $ \ _ -> Right ((),args)

tokenP check errmsg =
    do args <- get
       case args of
	 a:as -> maybe (fail errmsg)
		       (\a->set as>>return a)
		       (check a)
	 [] -> fail errmsg

manyP p = ((:) `fmap` p `ap` manyP p) `mplus` return []