content: {-# OPTIONS_HADDOCK show-extensions #-}
  {-# OPTIONS_GHC -Wno-deprecations #-} --FIXME: remove when Text16 is removed
  {-# LANGUAGE AllowAmbiguousTypes,
               CPP,
               ConstraintKinds,
               FunctionalDependencies,
               ImplicitParams,
               MagicHash,
               RecordWildCards,
               TypeApplications,
               UnboxedTuples #-}
  {-# LANGUAGE InstanceSigs #-}
  {-|
  Module      : Parsley.Internal.Backend.Machine.InputOps
  Description : Primitive operations for working with input.
  License     : BSD-3-Clause
  Maintainer  : Jamie Willis
  Stability   : experimental
  
  This module contains the primitive operations required by the
  parsing machinery to work with input.
  
  @since 1.0.0.0
  -}
  module Parsley.Internal.Backend.Machine.InputOps (
      InputPrep, PositionOps(..), LogOps(..), DynOps, asDyn, asSta,
      InputOps, next, check, uncons,
  #if __GLASGOW_HASKELL__ <= 900
      word8ToWord#,
  #endif
      prepare
    ) where
  
  import Data.Array.Base                             (UArray(..){-, listArray-})
  import Data.ByteString.Internal                    (ByteString(..))
  import Data.Text.Internal                          (Text(..))
  import Data.Text.Unsafe                            (iter, Iter(..))
  import GHC.Exts                                    (Int(..), Char(..), TYPE, Int#)
  import GHC.ForeignPtr                              (ForeignPtr(..))
  import GHC.Prim                                    (indexWideCharArray#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (-#))
  #if __GLASGOW_HASKELL__ > 900
  import GHC.Prim                                    (word8ToWord#)
  #else
  import GHC.Prim                                    (Word#)
  #endif
  import Parsley.Internal.Backend.Machine.InputRep   (Stream(..), CharList(..), Text16(..), DynRep, StaRep, UnpackedLazyByteString,
                                                      StaText(..), PartialStaText(..), staText, PartialStaOffWith(..), staOffWith,
                                                      PartialStaOffset(..), dynOffset,
                                                      emptyUnpackedLazyByteString, intSame, intLess, intAdd, intSubNonNeg,
                                                      offWithShiftRight, dropStream,
                                                      textShiftRight, textShiftLeft, byteStringShiftRight, offsetText,
                                                      byteStringShiftLeft, byteStringNext)
  import Parsley.Internal.Common.Utils               (Code)
  
  import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..))
  
  #if __GLASGOW_HASKELL__ <= 900
  {-# INLINE word8ToWord# #-}
  word8ToWord# :: Word# -> Word#
  word8ToWord# x = x
  #endif
  
  prepare :: InputPrep input => Code input -> ((?ops :: InputOps (StaRep input)) => StaRep input -> Code r) -> Code r
  prepare qinput k = _prepare qinput (\_ops -> let ?ops = _ops in k)
  
  {- Typeclasses -}
  {-|
  This class is responsible for converting the user's input into a form that
  parsley can work with efficiently.
  
  @since 1.0.0.0
  -}
  class InputPrep input where
    {-|
    Given the user's input to the parser, in its original form, this function
    distils it first into @`Rep` input@, which is parsley's internal representation,
    and then produces an `InputDependant` containing the core operations.
  
    @since 1.0.0.0
    -}
    _prepare :: starep ~ StaRep input => Code input -> (InputOps starep -> starep -> Code r) -> Code r
  
  {-|
  Defines operations for manipulating offsets for regular use. These are not
  tied to the original captured input but instead to the representation of its
  offset.
  
  @since 1.0.0.0
  -}
  class PositionOps rep where
    {-|
    Compares two "input"s for equality. In reality this usually means an offset
    present in the @rep@.
  
    @since 1.0.0.0
    -}
    same :: rep -> rep -> Code Bool
  
  type DynOps o = DynOps_ (DynRep o) (StaRep o)
  
  asDyn :: forall input. DynOps input => StaRep input -> Code (DynRep input)
  asDyn = _asDyn
  
  asSta :: forall input. DynOps input => Code (DynRep input) -> StaRep input
  asSta = _asSta
  
  class DynOps_ (dynrep :: TYPE r) starep | dynrep -> starep, starep -> dynrep where
    _asDyn :: starep -> Code dynrep
    _asSta :: Code dynrep -> starep
  
  {-|
  Defines operation used for debugging operations.
  
  @since 1.0.0.0
  -}
  class LogOps rep where
    {-|
    If possible, shifts the input back several characters.
    This is used to provide the previous input characters for the debugging combinator.
  
    @since 1.0.0.0
    -}
    shiftLeft :: rep -> Int -> (rep -> Code a) -> Code a
  
    {-|
    Advances the input by several characters at a time (existence not included).
    This can be used to check if characters exist at a future point in the input
    in conjunction with `more`.
  
    @since 2.3.0.0
    -}
    shiftRight :: rep -> Int -> (rep -> Code a) -> Code a
  
    {-|
    Converts the represention of the input into an @Int@.
  
    @since 1.0.0.0
    -}
    offToInt  :: rep -> Code Int
  
  {-|
  This is a psuedo-typeclass, which depends directly on the values obtained from
  `prepare`. Because this instance may depend on local information, it is
  synthesised and passed around using @ImplicitParams@.
  
  @since 1.0.0.0
  -}
  data InputOps rep = InputOps { _next :: !(forall a. rep -> (Code Char -> rep -> Code a) -> Code a)              -- ^ Read the next character (without checking existence)
                               , _uncons :: !(forall a. rep -> (Code Char -> rep -> Code a) -> Code a -> Code a)  -- ^ Read the next character, may check existence
                               , _ensureN :: !(forall a. Int -> rep -> (rep -> Code a) -> Code a -> Code a)      -- ^ Ensure that n characters exist
                               , _ensureNIsFast :: !Bool                                                                    -- ^ _ensureN is O(1) and not O(n)
                               }
  
  checkImpl :: forall rep a. Bool                                        -- ^ is the ensureN argument O(1)?
            -> (Int -> rep -> (rep -> Code a) -> Code a -> Code a)       -- ^ ensures there are n characters available
            -> (rep -> (Code Char -> rep -> Code a) -> Code a -> Code a) -- ^ reads the next character if available
            -> (Int -> Int -> rep -> Maybe (Code Char -> Code a -> Code a) -> (rep -> [(Code Char, rep)] -> Code a) -> Code a -> Code a)
  checkImpl fastEnsureN ensureN uncons n m qi headCheck good bad
    | fastEnsureN, n /= 0 = ensureN n qi (go n m qi id headCheck . Just) bad
    | otherwise           = go n m qi id headCheck Nothing
    where
      go :: Int -> Int -> rep -> ([(Code Char, rep)] -> [(Code Char, rep)]) -> Maybe (Code Char -> Code a -> Code a) -> Maybe rep -> Code a
      go 0 _ qi dcs _ _ = good qi (dcs [])
      -- Here, we want no more cached characters, so just verify the remaining with shiftRight
      go n 0 qi dcs _ Nothing = ensureN n qi (\qi' -> good qi' (dcs [])) bad
      -- We've already fastEnsured all the characters, so just feed forward the furthest to fill non-cached
      go _ 0 _ dcs _ (Just furthest) = good furthest (dcs [])
      -- Cached character wanted, so read it
      go n m qi dcs headCheck furthest = flip (uncons qi) bad $ \c qi' ->
        maybe id ($ c) headCheck $ -- if there is a headCheck available, perform it here DON'T pass it on
        go (n - 1) (m - 1) qi' (dcs . ((c, qi') :)) Nothing furthest
  
  {-|
  Wraps around `InputOps` and `_next`.
  
  Given some input and a continuation that accepts new input and a character, it will read
  a character off (without checking that it exists!) and feeds it and the remaining input
  to the continuation.
  
  @since 1.0.0.0
  -}
  next :: forall rep a. (?ops :: InputOps rep) => rep -> (Code Char -> rep -> Code a) -> Code a
  next = _next ?ops
  
  uncons :: forall rep a. (?ops :: InputOps rep) => rep -> (Code Char -> rep -> Code a) -> Code a -> Code a
  uncons = _uncons ?ops
  
  check :: forall rep a. (?ops :: InputOps rep) => Int -> Int -> rep -> Maybe (Code Char -> Code a -> Code a) -> (rep -> [(Code Char, rep)] -> Code a) -> Code a -> Code a
  check = checkImpl (_ensureNIsFast ?ops)
                    (_ensureN ?ops)
                    uncons
  
  {- INSTANCES -}
  -- InputPrep Instances
  instance InputPrep String where
    _prepare qinput k =
      k (InputOps (\pocs k -> staOffWith pocs $ \po qcs -> [|| let c:cs' = $$qcs in $$(k [||c||] (StaOW (intAdd po 1) [||cs'||])) ||])
                  (\pocs good bad -> staOffWith pocs $ \po qcs -> [||
                        case $$qcs of
                          c : cs' -> $$(good [||c||] (StaOW (intAdd po 1) [||cs'||]))
                          []     -> $$bad
                      ||])
                  (\n pocs good bad -> staOffWith pocs $ \qo qcs -> let (qo', qcs') = offWithShiftRight [||drop||] qo qcs (n - 1) in [||
                        case $$qcs' of
                          [] -> $$bad
                          cs -> $$(good (StaOW qo' [||cs||]))
                      ||])
                  False)
        (StaOW (_asSta [||0#||]) qinput)
  
  instance InputPrep ByteString where
    _prepare qinput k = [||
        let PS (ForeignPtr addr# final) (I# off#) (I# size#) = $$qinput
            next i# =
              case readWord8OffAddr# (addr# `plusAddr#` i#) 0# realWorld# of
                (# s', x #) -> case touch# final s' of
                  !_ -> chr# (word2Int# (word8ToWord# x))
        in $$(k (InputOps (\qi k -> [|| let !c# = next $$(dynOffset qi) in $$(k [||C# c#||] (intAdd qi 1)) ||])
                          (\qi k _ -> [|| let !c# = next $$(dynOffset qi) in $$(k [||C# c#||] (intAdd qi 1)) ||]) -- always guarded by fastEnsureN
                          (\n qi k -> intLess (dynOffset (intAdd qi (n - 1))) [||size#||] (k qi))
                          True)
                (_asSta [||off#||]))
      ||]
  
  instance InputPrep Text where
    _prepare qinput k =
      k (InputOps (\pt k -> staText pt $ \t@StaText{..} -> [||
                      let !(Iter c d) = iter $$origText 0
                          !unconsumed' = $$unconsumedText - d
                          !off'        = $$offText + d
                      in $$(k [||c||] (StaT $ t {origText = [||Text $$arrText off' unconsumed'||],
                                                 offText = [||off'||],
                                                 unconsumedText = [||unconsumed'||]})) ||])
                  (\pt good bad -> staText pt $ \t@StaText{..} -> [||
                      if $$unconsumedText > 0 then
                        let !(Iter c d) = iter $$origText 0
                            !unconsumed' = $$unconsumedText - d
                            !off'        = $$offText + d
                        in $$(good [||c||] (StaT $ t {origText = [||Text $$arrText off' unconsumed'||],
                                                      offText = [||off'||],
                                                      unconsumedText = [||unconsumed'||]}))
                      else $$bad
                    ||])
                  (\(I# n) pt good bad -> staText pt $ \StaText{..} -> [|| -- could be improved, I guess?
                      case $$(textShiftRight origText (n -# 1#)) of
                        Text _ _ 0                -> $$bad
                        t@(Text _ off unconsumed) -> $$(good (StaT $ StaText [||t||] arrText [||off||] [||unconsumed||]))
                    ||])
                  False)
        (DynT qinput)
  
  --instance InputPrep String where _prepare input = _prepare @(UArray Int Char) [||listArray (0, length $$input-1) $$input||]
  instance InputPrep (UArray Int Char) where
    _prepare qinput k = [||
        let !(UArray _ _ (I# size#) input#) = $$qinput
        in $$(k (InputOps (\qi k -> k [||C# (indexWideCharArray# input# $$(dynOffset qi))||] (intAdd qi 1))
                          (\qi k _ -> k [||C# (indexWideCharArray# input# $$(dynOffset qi))||] (intAdd qi 1)) -- always guarded by fastEnsureN
                          (\n qi k -> intLess (dynOffset (intAdd qi (n - 1))) [||size#||] (k qi))
                          True)
                (_asSta [||0#||]))
      ||]
  
  instance InputPrep Lazy.ByteString where
    _prepare qinput k = [||
        let initial :: UnpackedLazyByteString
            initial = case $$qinput of
              Lazy.Chunk (PS (ForeignPtr addr# final) (I# off#) (I# size#)) cs -> (# 0#, addr#, final, off#, size#, cs #)
              Lazy.Empty -> $$(emptyUnpackedLazyByteString [||0#||])
        in $$(k (InputOps (\qi k -> [|| let !(# c, qi' #) = byteStringNext $$qi in $$(k [||c||] [||qi'||]) ||])
                          (\qi good bad -> [||
                              case $$qi of
                                (# _, _, _, _, 0#, _ #) -> $$bad
                                bs                      ->
                                  let !(# c, qi' #) = byteStringNext bs in $$(good [||c||] [||qi'||])
                            ||])
                          (\(I# n) qi good bad -> [||
                              case $$(byteStringShiftRight qi (n -# 1#)) of
                                (# _, _, _, _, 0#, _ #) -> $$bad
                                bs                      -> $$(good [||bs||])
                            ||])
                          False)
                [||initial||])
      ||]
  
  instance InputPrep Stream where
    _prepare qinput k =
      k (InputOps (\pocs k -> staOffWith pocs $ \po qcs -> [|| let c :> cs' = $$qcs in $$(k [||c||] (StaOW (intAdd po 1) [||cs'||])) ||])
                  (\pocs k _ -> staOffWith pocs $ \po qcs -> [|| let c :> cs' = $$qcs in $$(k [||c||] (StaOW (intAdd po 1) [||cs'||])) ||])
                  (\n pocs good _ -> staOffWith pocs $ \qo qcs -> good (uncurry StaOW $ offWithShiftRight [||dropStream||] qo qcs (n - 1)))
                  True)
        (StaOW (_asSta [||0#||]) qinput)
  
  
  instance InputPrep Text16 where _prepare qinput = _prepare @Text [|| let Text16 t = $$qinput in t ||]
  instance InputPrep CharList where _prepare qinput = _prepare @String [|| let CharList cs = $$qinput in cs ||]
  
  -- PositionOps Instances
  instance PositionOps PartialStaOffset where same po (StaO qo' n) = intSame (dynOffset (intAdd po (negate n))) qo'
  instance PositionOps (PartialStaOffWith ts) where
    same pocs1 pocs2 = staOffWith pocs1 $ \po _ -> staOffWith pocs2 $ \po' _ -> same po po'
  --instance PositionOps (Code Int#, Code Stream) where same = offWithSame
  instance PositionOps PartialStaText where
    same pt1 pt2 = staText pt1 $ \qt1 -> staText pt2 $ \qt2 -> [||$$(offText qt1) == $$(offText qt2)||]
  instance PositionOps (Code UnpackedLazyByteString) where
    same qx# qy# = [||
        case $$(qx#) of
          (# i#, _, _, _, _, _ #) -> case $$(qy#) of
            (# j#, _, _, _, _, _ #) -> $$(intSame [||i#||] [||j#||])
      ||]
  
  -- DynOps Instances
  instance DynOps_ Int# PartialStaOffset where
    _asDyn = dynOffset
    _asSta = flip StaO 0
  
  instance DynOps_ (# Int#, ts #) (PartialStaOffWith ts) where
    _asDyn (StaOW qo qcs) = [||(# $$(dynOffset qo), $$qcs #)||]
    _asDyn (DynOW qocs) = qocs
    _asSta = DynOW
  
  instance DynOps_ Text PartialStaText where
    _asDyn (StaT t) = origText t
    _asDyn (DynT t) = t
    _asSta = DynT
  
  instance DynOps_ UnpackedLazyByteString (Code UnpackedLazyByteString) where
    _asDyn = id
    _asSta = id
  
  -- LogOps Instances
  instance LogOps PartialStaOffset where
    shiftLeft po n k = k (intSubNonNeg po n)
    shiftRight po n k = k (intAdd po n)
    offToInt pi = [||I# $$(dynOffset pi)||]
  
  instance LogOps (PartialStaOffWith String) where
    shiftLeft pocs _ k = k pocs
    shiftRight pocs n k = staOffWith pocs $ \qo qcs -> k (uncurry StaOW $ offWithShiftRight [||drop||] qo qcs n)
    offToInt pocs = staOffWith pocs $ \qo _ -> [||I# $$(dynOffset qo)||]
  
  instance LogOps (PartialStaOffWith Stream) where
    shiftLeft pocs _ k = k pocs
    shiftRight pocs n k = staOffWith pocs $ \qo qcs -> k (uncurry StaOW $ offWithShiftRight [||dropStream||] qo qcs n)
    offToInt pocs = staOffWith pocs $ \qo _ -> [||I# $$(dynOffset qo)||]
  
  instance LogOps PartialStaText where
    shiftLeft pt (I# qi#) k = staText pt $ \StaText{..} -> k (DynT (textShiftLeft origText qi#))
    shiftRight pt (I# n#) k = staText pt $ \StaText{..} -> k (DynT (textShiftRight origText n#))
    offToInt = offsetText
  
  instance LogOps (Code UnpackedLazyByteString) where
    shiftLeft qo# (I# qi#) k = k (byteStringShiftLeft qo# qi#)
    shiftRight qo# (I# qi#) k = k (byteStringShiftRight qo# qi#)
    offToInt qo# = [||case $$(qo#) of (# i#, _, _, _, _, _ #) -> I# i# ||]
  