content: {-# language CPP #-}
  {-# language PatternSynonyms #-}
  {-# language OverloadedStrings #-}
  {-# language MagicHash #-}
  {-# language TypeFamilies #-}
  {-# language UnboxedSums #-}
  {-# language StandaloneDeriving #-}
  {-# language UnboxedTuples #-}
  {-# language ImplicitParams #-}
  {-# language ConstraintKinds #-}
  {-# language LambdaCase #-}
  {-# language ScopedTypeVariables #-}
  {-# language RankNTypes #-}
  {-# language BangPatterns #-}
  {-# language ForeignFunctionInterface #-}
  {-# language KindSignatures #-}
  {-# language UnliftedFFITypes #-}
  {-# language TypeApplications #-}
  {-# language AllowAmbiguousTypes #-}
  {-# language BlockArguments #-}
  {-# language ViewPatterns #-}
  {-# language UnboxedTuples #-}
  {-# language MagicHash #-}
  {-# language PatternSynonyms #-}
  {-# language UnliftedNewtypes #-}
  {-# options_ghc -O2 #-}
  
  module Text.Parsnip.Internal.Parser
  (
  -- * Parser
    Parser(..)
  , Option(Option#,Some,None)
  , mapOption, setOption
  , Result, pattern OK, pattern Fail
  , mapResult, setResult
  , try
  -- * Unsafe literals
  , lit, litN, word8
  -- * Guts
  , Base(..), bytes, start, end
  , KnownBase(..)
  , parse
  ) where
  
  import Control.Applicative
  import Control.Monad
  import Control.Monad.Primitive
  import qualified Data.ByteString as B
  import Data.ByteString.Internal (ByteString(..))
  import qualified Data.ByteString.Internal as B
  import Data.Primitive.ByteArray
  import Data.String
  import Foreign.C.Types
  import Foreign.ForeignPtr
  import GHC.ForeignPtr
  import GHC.Prim
  import GHC.Ptr
  import GHC.Types
  import GHC.Word
  import System.IO.Unsafe
  
  import Text.Parsnip.Location
  import Text.Parsnip.Internal.Private
  
  --------------------------------------------------------------------------------
  -- * Option
  --------------------------------------------------------------------------------
  
  -- | Unlifted 'Maybe'
  newtype Option a = Option# (# a | (##) #)
  
  pattern Some :: a -> Option a
  pattern Some a = Option# (# a | #)
  
  pattern None :: Option a
  pattern None = Option# (# | (##) #)
  
  {-# complete Some, None #-} -- these don't work outside this module =(
  
  mapOption :: (a -> b) -> Option a -> Option b
  mapOption f (Some a) = Some $! f a
  mapOption _ None = None
  {-# inline mapOption #-}
  
  setOption :: b -> Option a -> Option b
  setOption b (Some _) = Some b
  setOption _ None = None
  {-# inline setOption #-}
  
  --------------------------------------------------------------------------------
  -- * Result
  --------------------------------------------------------------------------------
  
  type Result s a = (# Option a, Addr#, State# s #)
  
  pattern OK :: a -> Addr# -> State# s -> Result s a
  pattern OK a p s = (# Some a, p, s #)
  
  pattern Fail :: Addr# -> State# s -> Result s a
  pattern Fail p s = (# None, p, s #)
  
  {-# complete OK, Fail #-}
  
  mapResult :: (a -> b) -> Result s a -> Result s b
  mapResult f (# o, p, s #) = (# mapOption f o, p, s #)
  {-# inline mapResult #-}
  
  setResult :: b -> Result s a -> Result s b
  setResult b (# o, p, s #) = (# setOption b o, p, s #)
  {-# inline setResult #-}
  
  --------------------------------------------------------------------------------
  -- * Result
  --------------------------------------------------------------------------------
  
  newtype Parser s a = Parser
   { runParser :: Addr# -> State# s -> Result s a
   }
  
  instance Functor (Parser s) where
    fmap f (Parser m) = Parser \ p s -> mapResult f (m p s)
    {-# inline fmap #-}
    b <$ Parser m = Parser \ p s -> case m p s of
      OK _ q t -> OK b q t
      Fail q t -> Fail q t
    {-# inline (<$) #-}
  
  instance Applicative (Parser s) where
    pure a = Parser \ p s -> OK a p s
    {-# inline pure #-}
    Parser m <*> Parser n = Parser \p s -> case m p s of
      Fail q t -> Fail q t
      OK f q t -> mapResult f (n q t)
    {-# inline (<*>) #-}
    Parser m *> Parser n = Parser \p s -> case m p s of
      Fail q t -> Fail q t
      OK _ q t -> n q t
    {-# inline (*>) #-}
    Parser m <* Parser n = Parser \p s -> case m p s of
      OK a q t -> setResult a (n q t)
      x -> x
    {-# inline (<*) #-}
  
  instance Monad (Parser s) where
    Parser m >>= f = Parser \p s -> case m p s of
      Fail q t -> Fail q t
      OK a q t -> runParser (f a) q t
    {-# inline (>>=) #-}
    (>>) = (*>)
    {-# inline (>>) #-}
  #if !MIN_VERSION_base(4,13,0)
    fail _ = Parser Fail
    {-# inline fail #-}
  #endif
  
  instance Alternative (Parser s) where
    Parser m <|> Parser n = Parser \ p s -> case m p s of
      Fail _ t -> n p t
      OK a q t -> OK a q t
    {-# inline (<|>) #-}
    empty = Parser Fail
    {-# inline empty #-}
  
  instance MonadPlus (Parser s) where
    mplus = (<|>)
    {-# inline mplus #-}
    mzero = empty
    {-# inline mzero #-}
  
  instance PrimMonad (Parser s) where
    type PrimState (Parser s) = s
    primitive f = Parser \p s -> case f s of
      (# t, a #) -> OK a p t
    {-# inline primitive #-}
  
  -- perhaps this interface is a little low level. hrmm
  instance a ~ ByteString => IsString (Parser s a) where
    fromString "" = pure B.empty
    fromString xs = Parser \p s -> case sizeofMutableByteArray# ba of
      n -> case io (c_strncmp (mutableByteArrayContents# ba) p (fromIntegral $ I# n)) s of
        (# t, i #)
          | i /= 0    -> Fail p t
          | otherwise -> OK bs (plusAddr# p n) t
      where !(MutableByteArray ba) = pinnedByteArrayFromString0 xs
            bs = B.PS (ForeignPtr (mutableByteArrayContents# ba) (PlainPtr ba)) 0 (I# (sizeofMutableByteArray# ba))
  
  try :: Parser s a -> Parser s a
  try (Parser m) = Parser $ \p s -> case m p s of
    OK a q t -> OK a q t
    Fail _ t -> Fail p t
  
  word8 :: Word8 -> Parser s Word8
  word8 0 = empty
  word8 r@(W8# c) = Parser \p s -> case readWord8OffAddr# p 0# s of
    (# t, c' #) -> if isTrue# (c `eqWord#` c')
      then OK r (plusAddr# p 1#) t
      else Fail p t
  {-# inline word8 #-}
  
  ---------------------------------------------------------------------------------------
  -- * Super-unsafe literal parsers
  ---------------------------------------------------------------------------------------
  
  -- | super-duper unsafe. Fabricates bytestrings that directly reference constant memory
  litN :: Addr# -> CSize -> Parser s ByteString
  litN q n = Parser \p s -> case io (c_strncmp p q n) s of
      (# t, 0 #) -> OK bs (p `plusAddr#` csize n) t
      (# t, _ #) -> Fail p t
    where bs = unsafeLiteralByteStringN q n
  
  -- | Super unsafe. Fabricates a bytestring that directly reference constant memory.
  --
  -- Usage:
  --
  -- @
  -- hello = lit "hello"#
  -- @
  lit :: Addr# -> Parser s ByteString
  lit q = litN q (pure_strlen q)
  
  literalForeignPtrContents :: ForeignPtrContents
  literalForeignPtrContents = unsafeDupablePerformIO $ primitive \s -> case newByteArray# 0# s of
    (# t, a #) -> (# t, PlainPtr a #)
  -- {-# noinline literalForeignPtrContents #-}
  
  unsafeLiteralForeignPtr :: Addr# -> ForeignPtr Word8
  unsafeLiteralForeignPtr addr = ForeignPtr addr literalForeignPtrContents
  
  unsafeLiteralByteStringN :: Addr# -> CSize -> ByteString
  unsafeLiteralByteStringN p n = PS (unsafeLiteralForeignPtr p) 0 (fromIntegral n)
  {-# noinline unsafeLiteralByteStringN #-}
  
  --unsafeLiteralByteString :: Addr# -> ByteString
  --unsafeLiteralByteString p = unsafeLiteralByteStringN p (pure_strlen p)
  
  -- Given a 'Base' you can do two things with it. While in a Parser, you're allowed to
  -- access the memory between the start and end addresses, as they'll be alive.
  --
  -- However, you can always reconstruct a bytestring from the oriignal (non-0 terminated
  -- data using 'bytes', and that will remain valid forever or until appropriately
  -- garbage collected.
  --
  -- In general, in a Parser you should try to access the memory in the null-terminated
  -- region for cache locality.
  --
  -- Afterwards, or to report bytestrings, you should trim them off the original, this
  -- way, no additional memory needs to be copied, and the garbage collector will just
  -- manage the storage of the bytestrings you cut off of the parent for you.
  
  data Base s = Base
    { baseOriginal  :: Addr# -- the start of a valid bytestring
    , baseContents  :: ForeignPtrContents -- memory management for that bytestring
    , baseStart :: Addr# -- the start of our null terminated copy of the bytestring
    , baseEnd :: Addr# -- the end of our null terminated copy (points to the '\0')
    }
  
  bytes :: forall s. KnownBase s => ByteString
  bytes = case reflectBase @s of
    !(Base b g p q) -> mkBS b g (minusAddr# q p)
  {-# inline bytes #-}
  
  start :: forall s. KnownBase s => Addr#
  start = baseStart (reflectBase @s)
  {-# inline start #-}
  
  end :: forall s. KnownBase s => Addr#
  end = baseEnd (reflectBase @s)
  {-# inline end #-}
  
  class KnownBase (s :: Type) where
    reflectBase :: Base s
  
  --------------------------------------------------------------------------------
  -- * Parsing
  --------------------------------------------------------------------------------
  
  parse :: (forall s. KnownBase s => Parser s a) -> ByteString -> Either Location a
  parse m bs@(B.PS (ForeignPtr b g) (I# o) (I# len)) = unsafeDupablePerformIO $
    B.useAsCString bs \(Ptr p) -> -- now it is null terminated
      IO \s -> let base = Base (plusAddr# b o) g p (plusAddr# p len) in
        case runParser (withBase (\_ -> m) base proxy#) p s of
          (# n, q, t #) -> (# t, finish base q n #)
  
  finish :: Base s -> Addr# -> Option a -> Either Location a
  finish (Base b g q r) p = \case
    Some a -> Right a
    None -> Left (location (mkBS b g (minusAddr# r q)) (I# (minusAddr# p q)))
  {-# inline finish #-}
  
  data Wrap s a = Wrap (KnownBase s => Proxy# s -> Parser s a)
  
  withBase :: (KnownBase s => Proxy# s -> Parser s a) -> Base s -> Proxy# s -> Parser s a
  withBase f x y = magicDict (Wrap f) x y
  {-# inline withBase #-}
  