module Parsec (Parser, (<|>), skipMany, space, string) where

import Data.Char

type CharParser st a    = GenParser Char st a

space :: CharParser st Char
space = satisfy (isSpace)

satisfy :: (Char -> Bool) -> CharParser st Char
satisfy f           = tokenPrim (\c -> show [c])
                                (\pos c _cs -> updatePosChar pos c)
                                (\c -> if f c then Just c else Nothing)

string :: String -> CharParser st String
string s            = tokens show updatePosString s

{-# INLINE parsecReturn #-}
{-# INLINE parsecBind   #-}
{-# INLINE parsecPlus   #-}
{-# INLINE tokenPrim    #-}

infixr 1 <|>

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

type Parser a           = GenParser Char () a

newtype GenParser tok st a = Parser { runP :: State tok st -> Consumed (Reply tok st a) }

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
                                }

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 :: ParseError -> Reply tok st a -> Reply tok st a
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))))

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
      )

tokenPrim :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
tokenPrim show' nextpos test
    = tokenPrimEx show' nextpos Nothing test

tokenPrimEx :: (tok -> String) ->
               (SourcePos -> tok -> [tok] -> SourcePos) ->
               Maybe (SourcePos -> tok -> [tok] -> st -> st) ->
               (tok -> Maybe a) ->
               GenParser tok st a
tokenPrimEx show' nextpos mbNextState test
    = case mbNextState of
        Nothing
          -> Parser (\(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)
             )
        Just nextState
          -> Parser (\(State input pos user) ->
              case input of
                (c:cs) -> case test c of
                            Just x  -> let newpos   = nextpos pos c cs
                                           newuser  = nextState pos c cs user
                                           newstate = State cs newpos newuser
                                       in seq newpos $ seq newstate $
                                          Consumed (Ok x newstate (newErrorUnknown newpos))
                            Nothing -> Empty (sysUnExpectError (show' c) pos)
                []     -> Empty (sysUnExpectError "" pos)
             )

sysUnExpectError :: String -> SourcePos -> Reply tok st a
sysUnExpectError msg pos  = Error (newErrorMessage (SysUnExpect msg) pos)

unknownError :: State tok st -> ParseError
unknownError state        = newErrorUnknown (statePos state)

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

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

tokens :: Eq tok => ([tok] -> String) -> (SourcePos -> [tok] -> SourcePos) -> [tok] -> GenParser tok st [tok]
tokens shows' nextposs s
    = Parser (\(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 _  []        = errEof
        walk (x:xs) (c:cs)| x == c        = walk xs cs
                          | otherwise     = errExpect c

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

       in walk1 s input)

data Message        = SysUnExpect !String
                    | UnExpect    !String
                    | Expect      !String
                    | Message     !String

messageToEnum :: Message -> Int
messageToEnum msg
    = case msg of SysUnExpect _ -> 0
                  UnExpect _    -> 1
                  Expect _      -> 2
                  Message _     -> 3

messageCompare :: Message -> Message -> Ordering
messageCompare msg1 msg2
    = compare (messageToEnum msg1) (messageToEnum msg2)

messageEq :: Message -> Message -> Bool
messageEq msg1 msg2
    = (messageCompare msg1 msg2 == EQ)

data ParseError     = ParseError !SourcePos [Message]

newErrorUnknown :: SourcePos -> ParseError
newErrorUnknown pos
    = ParseError pos []

newErrorMessage :: Message -> SourcePos -> ParseError
newErrorMessage msg pos
    = ParseError pos [msg]

setErrorMessage :: Message -> ParseError -> ParseError
setErrorMessage msg (ParseError pos msgs)
    = ParseError pos (msg:filter (not . messageEq msg) msgs)

mergeError :: ParseError -> ParseError -> ParseError
mergeError (ParseError pos msgs1) (ParseError _ msgs2)
    = ParseError pos (msgs1 ++ msgs2)

type SourceName     = String
type Line           = Int
type Column         = Int

data SourcePos      = SourcePos SourceName !Line !Column

updatePosString :: SourcePos -> String -> SourcePos
updatePosString pos str = forcePos (foldl updatePosChar pos str)

updatePosChar   :: SourcePos -> Char -> SourcePos
updatePosChar (SourcePos name line column) c
    = forcePos $
      case c of
        '\n' -> SourcePos name (line+1) 1
        '\t' -> SourcePos name line (column + 8 - ((column-1) `mod` 8))
        _    -> SourcePos name line (column + 1)


forcePos :: SourcePos -> SourcePos
forcePos pos@(SourcePos _name line column)
    = seq line (seq column (pos))