InputRep.hs

{-# OPTIONS_HADDOCK show-extensions #-}
{-# OPTIONS_GHC -Wno-deprecations #-} --FIXME: remove when Text16 is removed
{-# LANGUAGE CPP,
             MagicHash,
             TypeFamilies,
             UnboxedTuples,
             StandaloneKindSignatures #-}
{-|
Module      : Parsley.Internal.Backend.Machine.InputRep
Description : Internal representations of input and miscellaneous operations.
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : experimental

This module contains the translation from user input type to the
underlying parsley representation of it, as well as some miscellaneous
functions for working with specific types of input (these do not appear
in the rest of the machinery, but in "Parsley.Internal.Backend.Machine.InputOps"
and potentially the generated code).

@since 1.0.0.0
-}
module Parsley.Internal.Backend.Machine.InputRep (
    -- * Representation Type-Families
    DynRep, StaRep, RepKind,
    -- * @Int#@ Operations
    PartialStaOffset(..), dynOffset,
    intSame, intLess, intAdd, intSubNonNeg, min#, max#,
    -- * @Offwith@ Operations
    OffWith, offWithShiftRight,
    PartialStaOffWith(..), staOffWith,
    -- * @LazyByteString@ Operations
    UnpackedLazyByteString, emptyUnpackedLazyByteString,
    byteStringShiftRight, byteStringShiftLeft,
    -- * @Stream@ Operations
    dropStream,
    -- * @Text@ Operations
    StaText(..), PartialStaText(..), staText, offsetText, textShiftRight, textShiftLeft,
    -- * Crucial Exposed Functions
    {- |
    These functions must be exposed, since they can appear
    in the generated code.
    -}
    byteStringNext,
    textShiftRight#,  textShiftLeft#, byteStringShiftRight#, byteStringShiftLeft#,
    -- * Re-exports
    module Parsley.Internal.Core.InputTypes
  ) where

import Data.Array.Unboxed                (UArray)
import Data.ByteString.Internal          (ByteString(..))
import Data.Kind                         (Type)
import Data.Text.Internal                (Text(..))
import Data.Text.Unsafe                  (iter_, reverseIter_)
import GHC.Exts                          (Int(..), Char(..), TYPE, RuntimeRep(..), (==#), (<#), (+#), (-#), isTrue#)
#if __GLASGOW_HASKELL__ > 900
import GHC.Exts                          (LiftedRep)
#endif
import GHC.ForeignPtr                    (ForeignPtr(..), ForeignPtrContents)
import GHC.Prim                          (Int#, Addr#, nullAddr#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#)
#if __GLASGOW_HASKELL__ > 900
import GHC.Prim                          (word8ToWord#)
#else
import GHC.Prim                          (Word#)
#endif
import Parsley.Internal.Common.Utils     (Code)
import Parsley.Internal.Core.InputTypes  (Text16(..), CharList(..), Stream(..))

import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..))
import qualified Data.Text.Array               as Text (Array)

#if __GLASGOW_HASKELL__ <= 900
{-# INLINE word8ToWord# #-}
word8ToWord# :: Word# -> Word#
word8ToWord# x = x
#endif

{- Representation Types -}
{-|
This allows types like @String@ and @Stream@ to be manipulated
more efficiently by packaging them along with an offset which can
be used for quicker comparisons.

@since 1.0.0.0
-}
type OffWith ts = (# Int#, ts #)

data PartialStaOffWith ts = StaOW !PartialStaOffset !(Code ts) | DynOW !(Code (OffWith ts))

staOffWith :: PartialStaOffWith ts -> (PartialStaOffset -> Code ts -> Code a) -> Code a
staOffWith (StaOW po qts) k = k po qts
staOffWith (DynOW qots) k = [|| let !(# o, cs #) = $$qots in $$(k (StaO [||o||] 0) [||cs||]) ||]

{-|
This type unpacks /lazy/ `Lazy.ByteString`s for efficiency.

@since 1.0.0.0
-}
type UnpackedLazyByteString = (#
    Int#,
    Addr#,
    ForeignPtrContents,
    Int#,
    Int#,
    Lazy.ByteString
  #)

data PartialStaText = StaT {-# UNPACK #-} !StaText | DynT !(Code Text)

staText :: PartialStaText -> (StaText -> Code a) -> Code a
staText (StaT t) k = k t
staText (DynT qt) k = [||
    let !t@(Text arr off unconsumed) = $$qt
    in $$(k (StaText [||t||] [||arr||] [||off||] [||unconsumed||]))
  ||]

data StaText = StaText {
  origText       :: !(Code Text),
  arrText        :: !(Code Text.Array),
  offText        :: !(Code Int),
  unconsumedText :: !(Code Int)
}

data PartialStaOffset = StaO !(Code Int#) {-# UNPACK #-} !Int

dynOffset :: PartialStaOffset -> Code Int#
dynOffset (StaO qi 0) = qi
dynOffset (StaO qi n)
 | n > 0 = let !(I# n#) = n in [||$$qi +# n#||]
 | otherwise = let !(I# m#) = negate n in [||$$qi -# m#||]

{-|
Initialises an `UnpackedLazyByteString` with a specified offset.
This offset varies as each lazy chunk is consumed.

@since 1.0.0.0
-}
emptyUnpackedLazyByteString :: Code Int# -> Code UnpackedLazyByteString
emptyUnpackedLazyByteString qi# = [|| (# $$(qi#), nullAddr#, error "nullForeignPtr", 0#, 0#, Lazy.Empty #) ||]

{- Representation Mappings -}
-- NOTE: When a new input type is added here, it needs an Input instance in Parsley.Backend.Machine
{-|
The representation type of an input `Rep`, does not have to be a lifted type. To match a
representation of an input with the correct kind, this type family must be used.

@since 1.0.0.0
-}
type RepKind :: Type -> RuntimeRep
type family RepKind input where
  RepKind String = 'TupleRep '[IntRep, LiftedRep]
  RepKind (UArray Int Char) = IntRep
  RepKind Text16 = LiftedRep
  RepKind ByteString = IntRep
  RepKind Text = LiftedRep
  RepKind Lazy.ByteString = 'TupleRep '[IntRep, AddrRep, LiftedRep, IntRep, IntRep, LiftedRep]
  RepKind CharList = 'TupleRep '[IntRep, LiftedRep]
  RepKind Stream = 'TupleRep '[IntRep, LiftedRep]

{-|
This type family relates a user input type with the underlying parsley
representation, which is significantly more efficient to work with.
Most parts of the machine work with `Rep`.

@since 1.0.0.0
-}
type DynRep :: forall (rep :: Type) -> TYPE (RepKind rep)
type family DynRep input where
  DynRep String = (# Int#, String #)
  DynRep (UArray Int Char) = Int#
  DynRep Text16 = Text
  DynRep ByteString = Int#
  DynRep Text = Text
  DynRep Lazy.ByteString = UnpackedLazyByteString
  DynRep CharList = (# Int#, String #)
  DynRep Stream = (# Int#, Stream #)

type family StaRep input where
  StaRep String = PartialStaOffWith String
  StaRep (UArray Int Char) = PartialStaOffset
  StaRep Text16 = PartialStaText
  StaRep ByteString = PartialStaOffset
  StaRep Text = PartialStaText
  StaRep Lazy.ByteString = Code UnpackedLazyByteString --TODO: could refine
  StaRep CharList = PartialStaOffWith String
  StaRep Stream = PartialStaOffWith Stream

{- Generic Representation Operations -}
{-|
Verifies that two `Int#`s are equal.

@since 1.0.0.0
-}
intSame :: Code Int# -> Code Int# -> Code Bool
intSame qi# qj# = [||isTrue# ($$(qi#) ==# $$(qj#))||]

{-|
Is the first argument is less than the second?

@since 2.3.0.0
-}
intLess :: Code Int# -> Code Int# -> Code a -> Code a -> Code a
intLess qi# qj# yes no = [||
    case $$(qi#) <# $$(qj#) of
      1# -> $$yes
      0# -> $$no
  ||]

intAdd ::  PartialStaOffset -> Int -> PartialStaOffset
intAdd (StaO qo n) i = StaO qo (n + i)

intSubNonNeg ::  PartialStaOffset -> Int -> PartialStaOffset
intSubNonNeg (StaO qo n) i
  | n >= i = StaO qo (n - i)
  | otherwise = let !(I# m#) = negate (n - i) in StaO [||max# ($$qo -# m#) 0#||] 0

{-|
Extracts the offset from `Text`.

@since 1.0.0.0
-}
-- FIXME: not accurate? this can be slow without consequence
offsetText :: PartialStaText -> Code Int
offsetText pt = staText pt offText

{-|
Shifts an `OffWith` to the right, taking care to also drop tokens from the
companion input.

@since 1.0.0.0
-}
offWithShiftRight :: Code (Int -> ts -> ts)        -- ^ A @drop@ function for underlying input.
                  -> PartialStaOffset -> Code ts   -- ^ The `OffWith` to shift.
                  -> Int                           -- ^ How much to shift by.
                  -> (PartialStaOffset, Code ts)
offWithShiftRight _ po qts 0 = (intAdd po 0, qts)
offWithShiftRight drop po qts n = (intAdd po n, [|| $$drop n $$qts ||])

{-|
Drops tokens off of a `Stream`.

@since 1.0.0.0
-}
dropStream :: Int -> Stream -> Stream
dropStream 0 cs = cs
dropStream n (_ :> cs) = dropStream (n-1) cs

{-|
Drops tokens off of `Text`.

@since 2.3.0.0
-}
textShiftRight :: Code Text -> Int# -> Code Text
textShiftRight t 0# = t
textShiftRight t n = [||textShiftRight# $$t n||]

{-# INLINABLE textShiftRight# #-}
textShiftRight# :: Text -> Int# -> Text
textShiftRight# (Text arr off unconsumed) i = go i arr off unconsumed
  where
    go 0# !arr !off !unconsumed = Text arr off unconsumed
    go n !arr !off !unconsumed
      | unconsumed > 0 = let !d = iter_ (Text arr off unconsumed) 0
                         in go (n -# 1#) arr (off + d) (unconsumed - d)
      | otherwise = Text arr off 0

{-|
Rewinds input consumption on `Text` where the input is still available (i.e. in the same chunk).

@since 2.3.0.0
-}
textShiftLeft :: Code Text -> Int# -> Code Text
textShiftLeft t 0# = t
textShiftLeft t n = [||textShiftLeft# $$t n||]

textShiftLeft# :: Text -> Int# -> Text
textShiftLeft# (Text arr off unconsumed) i = go i off unconsumed
  where
    go 0# off' unconsumed' = Text arr off' unconsumed'
    go n off' unconsumed'
      | off' > 0 = let !d = reverseIter_ (Text arr off' unconsumed') 0 in go (n -# 1#) (off' + d) (unconsumed' - d)
      | otherwise = Text arr 0 unconsumed'

{-# INLINE emptyUnpackedLazyByteString' #-}
emptyUnpackedLazyByteString' :: Int# -> UnpackedLazyByteString
emptyUnpackedLazyByteString' i# = (# i#, nullAddr#, error "nullForeignPtr", 0#, 0#, Lazy.Empty #)

{-# INLINABLE byteStringNext #-}
byteStringNext :: UnpackedLazyByteString -> (# Char, UnpackedLazyByteString #)
byteStringNext (# i#, addr#, final, off#, size#, cs #) =
  case readWord8OffAddr# addr# off# realWorld# of
    (# s', x #) -> case touch# final s' of
      _ -> (# C# (chr# (word2Int# (word8ToWord# x))),
          if I# size# /= 1 then (# i# +# 1#, addr#, final, off# +# 1#, size# -# 1#, cs #)
          else case cs of
            Lazy.Chunk (PS (ForeignPtr addr'# final') (I# off'#) (I# size'#)) cs' ->
              (# i# +# 1#, addr'#, final', off'#, size'#, cs' #)
            Lazy.Empty -> emptyUnpackedLazyByteString' (i# +# 1#)
        #)

{-|
Drops tokens off of a lazy `Lazy.ByteString`.

@since 2.3.0.0
-}
byteStringShiftRight :: Code UnpackedLazyByteString -> Int# -> Code UnpackedLazyByteString
byteStringShiftRight t 0# = t
byteStringShiftRight t n = [||byteStringShiftRight# $$t n||]

{-# INLINABLE byteStringShiftRight# #-}
byteStringShiftRight# :: UnpackedLazyByteString -> Int# -> UnpackedLazyByteString
byteStringShiftRight# (# i#, addr#, final, off#, size#, cs #) j#
  | isTrue# (j# <# size#)  = (# i# +# j#, addr#, final, off# +# j#, size# -# j#, cs #)
  | otherwise = case cs of
    Lazy.Chunk (PS (ForeignPtr addr'# final') (I# off'#) (I# size'#)) cs' -> byteStringShiftRight# (# i# +# size#, addr'#, final', off'#, size'#, cs' #) (j# -# size#)
    Lazy.Empty -> emptyUnpackedLazyByteString' (i# +# size#)

{-|
Rewinds input consumption on a lazy `Lazy.ByteString` if input is still available (within the same chunk).

@since 2.3.0.0
-}
byteStringShiftLeft :: Code UnpackedLazyByteString -> Int# -> Code UnpackedLazyByteString
byteStringShiftLeft t 0# = t
byteStringShiftLeft t n = [||byteStringShiftLeft# $$t n||]

{-# INLINABLE byteStringShiftLeft# #-}
byteStringShiftLeft# :: UnpackedLazyByteString -> Int# -> UnpackedLazyByteString
byteStringShiftLeft# (# i#, addr#, final, off#, size#, cs #) j# =
  let d# = min# off# j#
  in (# i# -# d#, addr#, final, off# -# d#, size# +# d#, cs #)

{-|
Finds the minimum of two `Int#` values.

@since 1.0.0.0
-}
{-# INLINABLE min# #-}
min# :: Int# -> Int# -> Int#
min# i# j# = case i# <# j# of
  0# -> j#
  _  -> i#

{-|
Finds the maximum of two `Int#` values.

@since 1.0.0.0
-}
{-# INLINABLE max# #-}
max# :: Int# -> Int# -> Int#
max# i# j# = case i# <# j# of
  0# -> i#
  _  -> j#