content: {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MagicHash #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE MultiWayIf #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE PatternSynonyms #-}
  {-# LANGUAGE Rank2Types #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE UnboxedTuples #-}
  module Text.PariPari.Internal.Acceptor (
    Acceptor(..)
    , Env(..)
    , get
    , local
    , runAcceptor
  ) where
  
  import Control.Monad (void)
  import Data.Semigroup as Sem
  import Data.String (IsString(..))
  import GHC.Base hiding (State#)
  import GHC.Word
  import Text.PariPari.Internal.Chunk
  import Text.PariPari.Internal.Class
  import qualified Control.Monad.Fail as Fail
  
  data Env k = Env
    { _envBuf     :: !(Buffer k)
    , _envFile    :: !FilePath
    , _envRefLine :: Int#
    , _envRefCol  :: Int#
    }
  
  type State# = (# Int#, Int#, Int# #)
  
  type Result# a = (# Int# | (# State#, a #) #)
  
  pattern Ok# :: State# -> a -> Result# a
  pattern Ok# s a = (# | (# s, a #) #)
  pattern Err# :: Int# -> Result# a
  pattern Err# o = (# o | #)
  {-# COMPLETE Ok#, Err# #-}
  
  _stLine :: State# -> Int#
  _stLine (# _, x, _ #) = x
  {-# INLINE _stLine #-}
  
  _stCol :: State# -> Int#
  _stCol (# _, _, x #) = x
  {-# INLINE _stCol #-}
  
  _stOff :: State# -> Int#
  _stOff (# x, _, _ #) = x
  {-# INLINE _stOff #-}
  
  -- | Parser which is optimised for fast parsing. Error reporting
  -- is minimal.
  newtype Acceptor k a = Acceptor
    { unAcceptor :: Env k -> State# -> Result# a }
  
  instance (Chunk k, Semigroup a) => Sem.Semigroup (Acceptor k a) where
    p1 <> p2 = (<>) <$> p1 <*> p2
    {-# INLINE (<>) #-}
  
  instance (Chunk k, Semigroup a, Monoid a) => Monoid (Acceptor k a) where
    mempty = pure mempty
    {-# INLINE mempty #-}
  
    mappend = (<>)
    {-# INLINE mappend #-}
  
  instance Functor (Acceptor k) where
    fmap f p = Acceptor $ \env st -> case unAcceptor p env st of
      Err# o -> Err# o
      Ok# st' x -> Ok# st' (f x)
    {-# INLINE fmap #-}
  
  instance Chunk k => Applicative (Acceptor k) where
    pure x = Acceptor $ \_ st -> Ok# st x
    {-# INLINE pure #-}
  
    f <*> a = Acceptor $ \env st -> case unAcceptor f env st of
      Err# o -> Err# o
      Ok# s f' -> case unAcceptor a env s of
        Err# o -> Err# o
        Ok# s' a' -> Ok# s' (f' a')
    {-# INLINE (<*>) #-}
  
    p1 *> p2 = do
      void p1
      p2
    {-# INLINE (*>) #-}
  
    p1 <* p2 = do
      x <- p1
      void p2
      pure x
    {-# INLINE (<*) #-}
  
  instance Chunk k => Alternative (Acceptor k) where
    empty = Acceptor $ \_ st -> Err# (_stOff st)
    {-# INLINE empty #-}
  
    p1 <|> p2 = Acceptor $ \env st ->
      case unAcceptor p1 env st of
        Ok# st' x -> Ok# st' x
        Err# _ -> unAcceptor p2 env st
    {-# INLINE (<|>) #-}
  
  instance Chunk k => MonadPlus (Acceptor k)
  
  instance Chunk k => Monad (Acceptor k) where
    p >>= f = Acceptor $ \env st ->
      case unAcceptor p env st of
        Err# o -> Err# o
        Ok# s x -> unAcceptor (f x) env s
    {-# INLINE (>>=) #-}
  
  #if !MIN_VERSION_base(4,11,0)
    fail = Fail.fail
    {-# INLINE fail #-}
  #endif
  
  instance Chunk k => Fail.MonadFail (Acceptor k) where
    fail msg = failWith $ EFail msg
    {-# INLINE fail #-}
  
  instance Chunk k => Parser k (Acceptor k) where
    getPos = get $ \_ st -> Pos (I# (_stLine st)) (I# (_stCol st))
    {-# INLINE getPos #-}
  
    getFile = get $ \env _ -> _envFile env
    {-# INLINE getFile #-}
  
    getRefPos = get $ \env _ -> Pos (I# (_envRefLine env)) (I# (_envRefCol env))
    {-# INLINE getRefPos #-}
  
    withRefPos p = local (\st env -> env { _envRefLine = _stLine st, _envRefCol = _stCol st }) p
    {-# INLINE withRefPos #-}
  
    notFollowedBy p = Acceptor $ \env st ->
      case unAcceptor p env st of
        Err# _ -> Ok# st ()
        Ok# _ _ -> Err# (_stOff st)
    {-# INLINE notFollowedBy #-}
  
    lookAhead p = Acceptor $ \env st -> do
      case unAcceptor p env st of
        Err# _ -> Err# (_stOff st)
        Ok# _ x -> Ok# st x
    {-# INLINE lookAhead #-}
  
    failWith _ = Acceptor $ \_ st -> Err# (_stOff st)
    {-# INLINE failWith #-}
  
    eof = Acceptor $ \env st ->
      case indexByte @k (_envBuf env) (_stOff st) `eqWord#` int2Word# 0# of
        1# -> Ok# st ()
        _ -> Err# (_stOff st)
    {-# INLINE eof #-}
  
    label _ p = p
    {-# INLINE label #-}
  
    hidden p = p
    {-# INLINE hidden #-}
  
    recover p _ = p
    {-# INLINE recover #-}
  
    try p = Acceptor $ \env st ->
      case unAcceptor p env st of
        Ok# st' x -> Ok# st' x
        Err# _ -> Err# (_stOff st)
    {-# INLINE try #-}
  
    p1 <!> p2 = Acceptor $ \env st ->
      case unAcceptor p1 env st of
        Ok# st' x -> Ok# st' x
        Err# o | 1# <- o ==# _stOff st -> unAcceptor p2 env st
               | otherwise -> Err# o
    {-# INLINE (<!>) #-}
  
    chunk k = Acceptor $ \env (# stOff, stLine, stCol #) ->
      case matchChunk @k (_envBuf env) stOff k of
        -1# -> Err# stOff
        n -> Ok# (# stOff +# n, stLine, stCol +# n #) k
    {-# INLINE chunk #-}
  
    asChunk p = do
      I# begin' <- get (const (\s -> I# (_stOff s)))
      p
      I# end' <- get (const (\s -> I# (_stOff s)))
      src <- get (\env _ -> _envBuf env)
      pure $ packChunk src begin' (end' -# begin')
    {-# INLINE asChunk #-}
  
    scan f = Acceptor $ \env (# stOff, stLine, stCol #) ->
      case indexChar @k (_envBuf env) stOff of
        (# c, w #)
          | 1# <- c `neChar#` '\0'#, Just r <- f (C# c) ->
            Ok# (# stOff +# w,
                  case c `eqChar#` '\n'# of 1# -> stLine +# 1#; _ -> stLine,
                  case c `eqChar#` '\n'# of 1# -> 1#; _ -> stCol +# 1# #) r
        _ -> Err# stOff
    {-# INLINE scan #-}
  
    -- By inling this combinator, GHC should figure out the `charWidth`
    -- of the character resulting in an optimised decoder.
    char '\0' = error "Character '\\0' cannot be parsed because it is used as sentinel"
    char c@(C# c') =
      Acceptor $ \env (# stOff, stLine, stCol #) ->
      case matchChar @k (_envBuf env) stOff c' of
        -1# -> Err# stOff
        w -> Ok# (# stOff +# w,
                  if c == '\n' then stLine +# 1# else stLine,
                  if c == '\n' then 1# else stCol +# 1# #) c
    {-# INLINE char #-}
  
    asciiScan f = Acceptor $ \env (# stOff, stLine, stCol #) ->
      if | b <- W8# (indexByte @k (_envBuf env) stOff),
           b /= 0,
           b < 128,
           Just x <- f b ->
             Ok# (# stOff +# 1#
                 , if b == asc_newline then stLine +# 1# else stLine
                 , if b == asc_newline then 1# else stCol +# 1# #) x
         | otherwise ->
             Err# stOff
    {-# INLINE asciiScan #-}
  
    asciiByte 0 = error "Character '\\0' cannot be parsed because it is used as sentinel"
    asciiByte b
      | b >= 128 = error "Not an ASCII character"
      | otherwise = Acceptor $ \env (# stOff, stLine, stCol #) ->
          if W8# (indexByte @k (_envBuf env) stOff) == b then
            Ok# (# stOff +# 1#
                , if b == asc_newline then stLine +# 1# else stLine
                , if b == asc_newline then 1# else stCol +# 1# #) b
          else
            Err# stOff
    {-# INLINE asciiByte #-}
  
  instance Chunk k => IsString (Acceptor k k) where
    fromString = string
    {-# INLINE fromString #-}
  
  -- | Reader monad, get something from the environment
  get :: (Env k -> State# -> a) -> Acceptor k a
  get f = Acceptor $ \env st -> Ok# st (f env st)
  {-# INLINE get #-}
  
  -- | Reader monad, modify environment locally
  local :: (State# -> Env k -> Env k) -> Acceptor k a -> Acceptor k a
  local f p = Acceptor $ \env st ->
    unAcceptor p (f st env) st
  {-# INLINE local #-}
  
  -- | Run 'Acceptor' on the given chunk, returning either
  -- a simple 'Error' or, if successful, the result.
  runAcceptor :: Chunk k => Acceptor k a -> FilePath -> k -> Maybe a
  runAcceptor p f k =
    let !(# b, off #) = unpackChunk k
    in case unAcceptor p (initialEnv f b) (# off, 1#, 1# #) of
         Err# _ -> Nothing
         Ok# _ x -> Just x
  
  initialEnv :: FilePath -> Buffer k -> Env k
  initialEnv _envFile _envBuf = Env
    { _envBuf
    , _envFile
    , _envRefLine = 1#
    , _envRefCol = 1#
    }
  