-- | Minimal parser definition.

{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-} -- needed for manual ZeroBitType def (unsure why)
{-# LANGUAGE FlexibleInstances #-}

module FlatParse.Basic.Parser
  (
  -- * Parser
    ParserT(..)
  , Parser, ParserIO, ParserST

  -- * Result
  , type Res#
  , pattern OK#, pattern Err#, pattern Fail#

  -- ** Internal
  , type ResI#

  -- * Choice operator (defined with right associativity)
  , (<|>)
  ) where

import FlatParse.Common.GHCExts ( Addr#, unsafeCoerce#, ZeroBitType )
import FlatParse.Common.Parser

import GHC.ForeignPtr ( ForeignPtrContents )

import qualified Control.Applicative
import Control.Monad ( MonadPlus(..) )
import Control.Monad.IO.Class ( MonadIO(..) )
import GHC.IO ( IO(IO) )

-- | @ParserT st e a@ is a parser with a state token type @st@, an error type
--   @e@ and a return type @a@. The different state token types support
--   different embedded effects; see `Parser`, `ParserIO` and `ParserST` below.
newtype ParserT (st :: ZeroBitType) e a =
    ParserT { forall (st :: ZeroBitType) e a.
ParserT st e a
-> ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
runParserT# :: ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a }

-- | The type of pure parsers.
type Parser     = ParserT PureMode

-- | The type of parsers which can embed `IO` actions.
type ParserIO   = ParserT IOMode

-- | The type of parsers which can embed `ST` actions.
type ParserST s = ParserT (STMode s)

-- | You may lift IO actions into a 'ParserIO' using `liftIO`.
instance MonadIO (ParserIO e) where
  liftIO :: forall a. IO a -> ParserIO e a
liftIO (IO State# RealWorld -> (# State# RealWorld, a #)
a) = forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s State# RealWorld
rw ->
    case State# RealWorld -> (# State# RealWorld, a #)
a State# RealWorld
rw of (# State# RealWorld
rw', a
a #) -> forall (st :: ZeroBitType) a e. st -> a -> Addr# -> Res# st e a
OK# State# RealWorld
rw' a
a Addr#
s
  {-# inline liftIO #-}

instance Functor (ParserT st e) where
  fmap :: forall a b. (a -> b) -> ParserT st e a -> ParserT st e b
fmap a -> b
f (ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
g) = forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s st
st -> case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
g ForeignPtrContents
fp Addr#
eob Addr#
s st
st of
    OK# st
st' a
a Addr#
s -> forall (st :: ZeroBitType) a e. st -> a -> Addr# -> Res# st e a
OK# st
st' (a -> b
f forall a b. (a -> b) -> a -> b
$! a
a) Addr#
s
    Res# st e a
x           -> unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# Res# st e a
x
  {-# inline fmap #-}

  <$ :: forall a b. a -> ParserT st e b -> ParserT st e a
(<$) a
a' (ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e b
g) = forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s st
st -> case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e b
g ForeignPtrContents
fp Addr#
eob Addr#
s st
st of
    OK# st
st' b
_a Addr#
s -> forall (st :: ZeroBitType) a e. st -> a -> Addr# -> Res# st e a
OK# st
st' a
a' Addr#
s
    Res# st e b
x           -> unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# Res# st e b
x
  {-# inline (<$) #-}

instance Applicative (ParserT st e) where
  pure :: forall a. a -> ParserT st e a
pure a
a = forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s st
st -> forall (st :: ZeroBitType) a e. st -> a -> Addr# -> Res# st e a
OK# st
st a
a Addr#
s
  {-# inline pure #-}
  ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e (a -> b)
ff <*> :: forall a b.
ParserT st e (a -> b) -> ParserT st e a -> ParserT st e b
<*> ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
fa = forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s st
st -> case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e (a -> b)
ff ForeignPtrContents
fp Addr#
eob Addr#
s st
st of
    OK# st
st' a -> b
f Addr#
s -> case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
fa ForeignPtrContents
fp Addr#
eob Addr#
s st
st' of
      OK# st
st'' a
a Addr#
s -> forall (st :: ZeroBitType) a e. st -> a -> Addr# -> Res# st e a
OK# st
st'' (a -> b
f forall a b. (a -> b) -> a -> b
$! a
a) Addr#
s
      Res# st e a
x            -> unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# Res# st e a
x
    Res# st e (a -> b)
x           -> unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# Res# st e (a -> b)
x
  {-# inline (<*>) #-}
  ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
fa <* :: forall a b. ParserT st e a -> ParserT st e b -> ParserT st e a
<* ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e b
fb = forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s st
st -> case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
fa ForeignPtrContents
fp Addr#
eob Addr#
s st
st of
    OK# st
st' a
a Addr#
s -> case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e b
fb ForeignPtrContents
fp Addr#
eob Addr#
s st
st' of
      OK# st
st'' b
_b Addr#
s -> forall (st :: ZeroBitType) a e. st -> a -> Addr# -> Res# st e a
OK# st
st'' a
a Addr#
s
      Res# st e b
x             -> unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# Res# st e b
x
    Res# st e a
x           -> unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# Res# st e a
x
  {-# inline (<*) #-}
  ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
fa *> :: forall a b. ParserT st e a -> ParserT st e b -> ParserT st e b
*> ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e b
fb = forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s st
st -> case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
fa ForeignPtrContents
fp Addr#
eob Addr#
s st
st of
    OK# st
st' a
_a Addr#
s -> ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e b
fb ForeignPtrContents
fp Addr#
eob Addr#
s st
st'
    Res# st e a
x            -> unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# Res# st e a
x
  {-# inline (*>) #-}

instance Monad (ParserT st e) where
  return :: forall a. a -> ParserT st e a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# inline return #-}
  ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
fa >>= :: forall a b.
ParserT st e a -> (a -> ParserT st e b) -> ParserT st e b
>>= a -> ParserT st e b
f = forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s st
st -> case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
fa ForeignPtrContents
fp Addr#
eob Addr#
s st
st of
    OK# st
st' a
a Addr#
s -> forall (st :: ZeroBitType) e a.
ParserT st e a
-> ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
runParserT# (a -> ParserT st e b
f a
a) ForeignPtrContents
fp Addr#
eob Addr#
s st
st'
    Res# st e a
x           -> unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# Res# st e a
x
  {-# inline (>>=) #-}
  >> :: forall a b. ParserT st e a -> ParserT st e b -> ParserT st e b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
  {-# inline (>>) #-}

-- | By default, parser choice `(<|>)` arbitrarily backtracks on parser failure.
instance Control.Applicative.Alternative (ParserT st e) where
  empty :: forall a. ParserT st e a
empty = forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s st
st -> forall (st :: ZeroBitType) e a. st -> Res# st e a
Fail# st
st
  {-# inline empty #-}

  <|> :: forall a. ParserT st e a -> ParserT st e a -> ParserT st e a
(<|>) = forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
(<|>)
  {-# inline (Control.Applicative.<|>) #-}

  many :: forall a. ParserT st e a -> ParserT st e [a]
many (ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
f) = forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e [a]
go where
    go :: ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e [a]
go ForeignPtrContents
fp Addr#
eob Addr#
s st
st = case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
f ForeignPtrContents
fp Addr#
eob Addr#
s st
st of
      OK# st
st a
a Addr#
s -> case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e [a]
go ForeignPtrContents
fp Addr#
eob Addr#
s st
st of
                      OK# st
st [a]
as Addr#
s -> forall (st :: ZeroBitType) a e. st -> a -> Addr# -> Res# st e a
OK# st
st (a
aforall a. a -> [a] -> [a]
:[a]
as) Addr#
s
                      Res# st e [a]
x           -> Res# st e [a]
x
      Fail# st
st  -> forall (st :: ZeroBitType) a e. st -> a -> Addr# -> Res# st e a
OK# st
st [] Addr#
s
      Err# st
st e
e -> forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
Err# st
st e
e
  {-# inline many #-}

  some :: forall a. ParserT st e a -> ParserT st e [a]
some ParserT st e a
p = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT st e a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many ParserT st e a
p
  {-# inline some #-}

infixr 6 <|>
-- | Choose between two parsers. If the first parser fails, try the second one,
--   but if the first one throws an error, propagate the error. This operation
--   can arbitrarily backtrack.
--
-- Note: this exported operator has different fixity than the same operator in
-- `Control.Applicative`. Hide this operator if you want to use the
-- `Alternative` version.
(<|>) :: ParserT st e a -> ParserT st e a -> ParserT st e a
<|> :: forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
(<|>) (ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
f) (ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
g) = forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s st
st ->
  case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
f ForeignPtrContents
fp Addr#
eob Addr#
s st
st of
    Fail# st
st' -> ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
g ForeignPtrContents
fp Addr#
eob Addr#
s st
st'
    Res# st e a
x         -> Res# st e a
x
{-# inline[1] (<|>) #-}

{-# RULES

"flatparse/reassoc-alt" forall l m r. (l <|> m) <|> r = l <|> (m <|> r)

#-}

instance MonadPlus (ParserT st e) where
  mzero :: forall a. ParserT st e a
mzero = forall (f :: * -> *) a. Alternative f => f a
Control.Applicative.empty
  {-# inline mzero #-}
  mplus :: forall a. ParserT st e a -> ParserT st e a -> ParserT st e a
mplus = forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
(<|>)
  {-# inline mplus #-}

--------------------------------------------------------------------------------

-- | Primitive parser result wrapped with a state token.
--
-- You should rarely need to manipulate values of this type directly. Use the
-- provided bidirectional pattern synonyms 'OK#', 'Fail#' and 'Err#'.
type Res# (st :: ZeroBitType) e a =
  (# st, ResI# e a #)

-- | Primitive parser result.
type ResI# e a =
  (#
    (# a, Addr# #)
  | (# #)
  | (# e #)
  #)

-- | 'Res#' constructor for a successful parse.
--   Contains the return value and a pointer to the rest of the input buffer,
--   plus a state token.
pattern OK# :: (st :: ZeroBitType) -> a -> Addr# -> Res# st e a
pattern $bOK# :: forall (st :: ZeroBitType) a e. st -> a -> Addr# -> Res# st e a
$mOK# :: forall {r} {st :: ZeroBitType} {a} {e}.
Res# st e a -> (st -> a -> Addr# -> r) -> ((# #) -> r) -> r
OK# st a s = (# st, (# (# a, s #) | | #) #)

-- | 'Res#' constructor for recoverable failure.
--   Contains only a state token.
pattern Fail# :: (st :: ZeroBitType) -> Res# st e a
pattern $bFail# :: forall (st :: ZeroBitType) e a. st -> Res# st e a
$mFail# :: forall {r} {st :: ZeroBitType} {e} {a}.
Res# st e a -> (st -> r) -> ((# #) -> r) -> r
Fail# st = (# st, (# | (# #) | #) #)

-- | 'Res#' constructor for errors which are by default non-recoverable.
--    Contains the error, plus a state token.
pattern Err# :: (st :: ZeroBitType) -> e -> Res# st e a
pattern $bErr# :: forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
$mErr# :: forall {r} {st :: ZeroBitType} {e} {a}.
Res# st e a -> (st -> e -> r) -> ((# #) -> r) -> r
Err# st e = (# st, (# | | (# e #) #) #)
{-# complete OK#, Fail#, Err# #-}