----------------------------------------------------------------
-- Daan Leijen (c) 1999-2001, daan@cs.uu.nl
-- 
-- the primitive parser combinators
--
-- $Revision: 1.1 $
-- $Author: sof $
-- $Date: 2001/12/08 17:58:35 $
----------------------------------------------------------------
module ParsecPrim( -- operators: label a parser, alternative
                     (<?>), (<|>)

                   -- basic types
                   , Parser, GenParser
                   , runParser, parse, parseFromFile, parseTest
                   
                   -- primitive parsers:
                   -- instance Functor Parser     : fmap
                   -- instance Monad Parser       : return, >>=, fail
                   -- instance MonadPlus Parser   : mzero (pzero), mplus (<|>)
                   , token, tokens, tokenPrim
                   , try, label, unexpected, pzero

                   -- primitive because of space behaviour
                   , many, skipMany
                                
                   -- user state manipulation
                   , getState, setState, updateState

                   -- state manipulation
                   , getPosition, setPosition
                   , getInput, setInput                   
                   , getParserState, setParserState 
                 ) where

import ParsecPos
import ParsecError
import Monad

{-# INLINE parsecMap    #-}
{-# INLINE parsecReturn #-}
{-# INLINE parsecBind   #-}
{-# INLINE parsecZero   #-}
{-# INLINE parsecPlus   #-}
{-# INLINE token        #-}
{-# INLINE tokenPrim    #-}

-----------------------------------------------------------
-- Operators:
-- <?>  gives a name to a parser (which is used in error messages)
-- <|>  is the choice operator
-----------------------------------------------------------
infix  0 <?>
infixr 1 <|>

(<?>) :: GenParser tok st a -> String -> GenParser tok st a
p <?> msg           = label p msg

(<|>) :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
p1 <|> p2           = mplus p1 p2


-----------------------------------------------------------
-- User state combinators
-----------------------------------------------------------
getState :: GenParser tok st st
getState        = do{ state <- getParserState
                    ; return (stateUser state)
                    }

setState :: st -> GenParser tok st ()
setState st     = do{ updateParserState (\(State input pos _) -> State input pos st)
                    ; return ()
                    }

updateState :: (st -> st) -> GenParser tok st ()
updateState f   = do{ updateParserState (\(State input pos user) -> State input pos (f user))
                    ; return ()
                    }


-----------------------------------------------------------
-- Parser state combinators
-----------------------------------------------------------
getPosition :: GenParser tok st SourcePos
getPosition         = do{ state <- getParserState; return (statePos state) }

getInput :: GenParser tok st [tok]
getInput            = do{ state <- getParserState; return (stateInput state) }


setPosition :: SourcePos -> GenParser tok st ()
setPosition pos     = do{ updateParserState (\(State input _ user) -> State input pos user)
                        ; return ()
                        }
                        
setInput :: [tok] -> GenParser tok st ()
setInput input      = do{ updateParserState (\(State _ pos user) -> State input pos user)
                        ; return ()
                        }

getParserState      = updateParserState id    
setParserState st   = updateParserState (const st)




-----------------------------------------------------------
-- Parser definition.
-- GenParser tok st a:
--  General parser for tokens of type "tok", 
--  a user state "st" and a result type "a"
-----------------------------------------------------------
type Parser a           = GenParser Char () a

data GenParser tok st a = Parser (State tok st -> Consumed (Reply tok st a))
runP (Parser p)         = p

data Consumed a         = Consumed a                --input is consumed
                        | Empty !a                  --no input is consumed
                    
data Reply tok st a     = Ok !a !(State tok st) ParseError    --parsing succeeded with "a"
                        | Error ParseError                    --parsing failed

data State tok st       = State { stateInput :: ![tok]
                                , statePos   :: !SourcePos
                                , stateUser  :: st
                                }


-----------------------------------------------------------
-- run a parser
-----------------------------------------------------------
parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a)
parseFromFile p fname
    = do{ input <- readFile fname
        ; return (parse p fname input)
        }

parseTest :: Show a => GenParser tok () a -> [tok] -> IO ()
parseTest p input
    = case (runParser p () "" input) of
        Left err -> do{ putStr "parse error at "
                      ; print err
                      }
        Right x  -> print x


parse p name input
    = runParser p () name input


runParser :: GenParser tok st a -> st -> SourceName -> [tok] -> Either ParseError a
runParser p st name input
    = case parserReply (runP p (State input (initialPos name) st)) of
        Ok x _ _    -> Right x
        Error err   -> Left err

parserReply result     
    = case result of
        Consumed reply -> reply
        Empty reply    -> reply


-----------------------------------------------------------
-- Functor: fmap
-----------------------------------------------------------
instance Functor (GenParser tok st) where
  fmap f p  = parsecMap f p

parsecMap :: (a -> b) -> GenParser tok st a -> GenParser tok st b
parsecMap f (Parser p)
    = Parser (\state -> 
        case (p state) of
          Consumed reply -> Consumed (mapReply reply)
          Empty    reply -> Empty    (mapReply reply)
      )
    where
      mapReply reply
        = case reply of
            Ok x state err -> let fx = f x 
                              in seq fx (Ok fx state err)
            Error err      -> Error err
           

-----------------------------------------------------------
-- Monad: return, sequence (>>=) and fail
-----------------------------------------------------------    
instance Monad (GenParser tok st) where
  return x   = parsecReturn x  
  p >>= f    = parsecBind p f
  fail msg   = parsecFail msg

parsecReturn :: a -> GenParser tok st a
parsecReturn x
  = Parser (\state -> Empty (Ok x state (unknownError state)))   

parsecBind :: GenParser tok st a -> (a -> GenParser tok st b) -> GenParser tok st b
parsecBind (Parser p) f
    = Parser (\state ->
        case (p state) of                 
          Consumed reply1 
            -> Consumed $
               case (reply1) of
                 Ok x state1 err1 -> case runP (f x) state1 of
                                       Empty reply2    -> mergeErrorReply err1 reply2
                                       Consumed reply2 -> reply2
                 Error err1       -> Error err1

          Empty reply1    
            -> case (reply1) of
                 Ok x state1 err1 -> case runP (f x) state1 of
                                       Empty reply2 -> Empty (mergeErrorReply err1 reply2)
                                       other        -> other                                                    
                 Error err1       -> Empty (Error err1)
      )                                                              

mergeErrorReply err1 reply
  = case reply of
      Ok x state err2 -> Ok x state (mergeError err1 err2)
      Error err2      -> Error (mergeError err1 err2)


parsecFail :: String -> GenParser tok st a
parsecFail msg
  = Parser (\state -> 
      Empty (Error (newErrorMessage (Message msg) (statePos state))))


-----------------------------------------------------------
-- MonadPlus: alternative (mplus) and mzero
-----------------------------------------------------------
instance MonadPlus (GenParser tok st) where
  mzero         = parsecZero
  mplus p1 p2   = parsecPlus p1 p2
      

pzero :: GenParser tok st a
pzero = parsecZero

parsecZero :: GenParser tok st a
parsecZero
    = Parser (\state -> Empty (Error (unknownError state)))

parsecPlus :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
parsecPlus (Parser p1) (Parser p2)
    = Parser (\state ->
        case (p1 state) of        
          Empty (Error err) -> case (p2 state) of
                                 Empty reply -> Empty (mergeErrorReply err reply)
                                 consumed    -> consumed
          other             -> other
      )


{- 
-- variant that favors a consumed reply over an empty one, even it is not the first alternative.
          empty@(Empty reply) -> case reply of
                                   Error err ->
                                     case (p2 state) of
                                       Empty reply -> Empty (mergeErrorReply err reply)
                                       consumed    -> consumed
                                   ok ->
                                     case (p2 state) of
                                       Empty reply -> empty
                                       consumed    -> consumed
          consumed  -> consumed
-}


-----------------------------------------------------------
-- Primitive Parsers: 
--  try, onFail, unexpected and updateState
-----------------------------------------------------------
try :: GenParser tok st a -> GenParser tok st a
try (Parser p)
    = Parser (\state@(State input pos user) ->     
        case (p state) of
          Consumed (Error err)  -> Empty (Error (setErrorPos pos err))
          Consumed ok           -> Consumed ok    -- was: Empty ok
          empty                 -> empty
      )

     
token :: (tok -> String) -> (tok -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a    
token show tokpos test
  = tokenPrim show nextpos test
  where
    nextpos _ _   (tok:toks)  = tokpos tok
    nextpos _ tok []          = tokpos tok

tokenPrim :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
tokenPrim show nextpos test
    = Parser (\state@(State input pos user) -> 
        case input of
          (c:cs) -> case test c of
                      Just x  -> let newpos   = nextpos pos c cs
                                     newstate = State cs newpos user
                                 in seq newpos $ seq newstate $ 
                                    Consumed (Ok x newstate (newErrorUnknown newpos))
                      Nothing -> Empty (sysUnExpectError (show c) pos)
          []     -> Empty (sysUnExpectError "" pos)
      )


label :: GenParser tok st a -> String -> GenParser tok st a    
label (Parser p) msg
    = Parser (\state -> 
        case (p state) of
          Empty reply 
            -> Empty $ 
               case (reply) of
                 Error err        -> Error (setExpectError msg err)
                 Ok x state1 err  | errorIsUnknown err -> reply
                                  | otherwise -> Ok x state1 (setExpectError msg err)
          other       -> other
      )


updateParserState :: (State tok st -> State tok st) -> GenParser tok st (State tok st)
updateParserState f 
    = Parser (\state -> Empty (Ok state (f state) (unknownError state)))
    
    
unexpected :: String -> GenParser tok st a
unexpected msg
    = Parser (\state -> Empty (Error (newErrorMessage (UnExpect msg) (statePos state))))
    

setExpectError msg err    = setErrorMessage (Expect msg) err
sysUnExpectError msg pos  = Error (newErrorMessage (SysUnExpect msg) pos)
unknownError state        = newErrorUnknown (statePos state)

-----------------------------------------------------------
-- Parsers unfolded for space:
-- if many and skipMany are not defined as primitives,
-- they will overflow the stack on large inputs
-----------------------------------------------------------    
many :: GenParser tok st a -> GenParser tok st [a]
many p
  = do{ xs <- manyAccum (:) p
      ; return (reverse xs)
      }

skipMany :: GenParser tok st a -> GenParser tok st ()
skipMany p
  = do{ manyAccum (\x xs -> []) p
      ; return ()
      }

manyAccum :: (a -> [a] -> [a]) -> GenParser tok st a -> GenParser tok st [a]
manyAccum accum (Parser p)
  = Parser (\state -> 
    let walk xs state          = walkReply xs state (parserReply (p state))
        walkReply xs state r   = case r of
                                   Ok x state' err  -> let ys = accum x xs
                                                       in seq ys (walk (accum x xs) state')
                                   Error err        -> Ok xs state err
    in case (p state) of
         Empty reply    -> case reply of
                             Ok x state' err -> error "ParsecPrim.many: combinator 'many' is applied to a parser that accepts an empty string."
                             Error err       -> Empty (Ok [] state err)
         Consumed reply -> Consumed $ walkReply [] state reply)


-----------------------------------------------------------
-- Parsers unfolded for speed: 
--  tokens
-----------------------------------------------------------    

{- specification of @tokens@:
tokens showss nextposs s
  = scan s
  where
    scan []       = return s
    scan (c:cs)   = do{ token show nextpos c <?> shows s; scan cs }                      

    show c        = shows [c]
    nextpos pos c = nextposs pos [c]
-}

tokens :: Eq tok => ([tok] -> String) -> (SourcePos -> [tok] -> SourcePos) -> [tok] -> GenParser tok st [tok]
tokens shows nextposs s
    = Parser (\state@(State input pos user) -> 
       let
        ok cs             = let newpos   = nextposs pos s
                                newstate = State cs newpos user
                            in seq newpos $ seq newstate $ 
                               (Ok s newstate (newErrorUnknown newpos))
                               
        errEof            = Error (setErrorMessage (Expect (shows s))
                                     (newErrorMessage (SysUnExpect "") pos))
        errExpect c       = Error (setErrorMessage (Expect (shows s))
                                     (newErrorMessage (SysUnExpect (shows [c])) pos))

        walk [] cs        = ok cs
        walk xs []        = errEof
        walk (x:xs) (c:cs)| x == c        = walk xs cs
                          | otherwise     = errExpect c

        walk1 [] cs        = Empty (ok cs)
        walk1 xs []        = Empty (errEof)
        walk1 (x:xs) (c:cs)| x == c        = Consumed (walk xs cs)
                           | otherwise     = Empty (errExpect c)

       in walk1 s input)


