Input.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
module Symantic.Parser.Machine.Input where

import Data.Array.Base (UArray(..), listArray)
-- import Data.Array.Unboxed (UArray)
import Data.Bool
import Data.ByteString.Internal (ByteString(..))
import Data.Char (Char)
import Data.Word (Word8)
import Data.Eq (Eq(..))
import Data.Function (on)
import Data.Int (Int)
import Data.Kind (Type)
import Data.Ord (Ord(..), Ordering)
import Data.String (String)
import Data.Text ()
import Data.Text.Array ({-aBA, empty-})
import Data.Text.Internal (Text(..))
import Data.Text.Unsafe (iter, Iter(..), iter_, reverseIter_)
import Text.Show (Show(..))
import GHC.Exts (Int(..), Char(..), {-, RuntimeRep(..)-})
import GHC.Word (Word8(..))
import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents)
import GHC.Prim ({-Int#,-} Addr#, nullAddr#, indexWideCharArray#, {-indexWord16Array#,-} readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#))
import Language.Haskell.TH (CodeQ)
import Prelude ((+), (-), error)
import qualified Data.ByteString.Lazy.Internal as BSL
import qualified Data.List as List

-- * Class 'Cursorable'
class Show cur => Cursorable cur where
  offset :: cur -> Int
  compareOffset :: CodeQ (cur -> cur -> Ordering)
  compareOffset = [|| compare `on` offset ||]
  lowerOffset :: CodeQ (cur -> cur -> Bool)
  sameOffset :: CodeQ (cur -> cur -> Bool)
  shiftRight :: CodeQ (Int -> cur -> cur)
instance Cursorable Int where
  offset = \inp -> inp
  compareOffset = [|| compare @Int ||]
  lowerOffset = [|| (<) @Int ||]
  sameOffset = [|| (==) @Int ||]
  shiftRight = [|| (+) @Int ||]
instance Cursorable Text where
  offset = \(Text _ i _) -> i
  lowerOffset = [|| \(Text _ i _) (Text _ j _) -> i < j ||]
  sameOffset = [|| \(Text _ i _) (Text _ j _) -> i == j ||]
  shiftRight = [||shiftRightText||]

shiftRightText :: Int -> Text -> Text
shiftRightText i (Text arr off unconsumed) = go i off unconsumed
  where
  go 0 off' unconsumed' = Text arr off' unconsumed'
  go n off' unconsumed'
    | unconsumed' > 0
    , !d <- iter_ (Text arr off' unconsumed') 0
    = go (n-1) (off'+d) (unconsumed'-d)
    | otherwise = Text arr off' unconsumed'

shiftLeftText :: Int -> Text -> Text
shiftLeftText i (Text arr off unconsumed) = go i off unconsumed
  where
  go 0 off' unconsumed' = Text arr off' unconsumed'
  go n off' unconsumed'
    | off' > 0
    , !d <- reverseIter_ (Text arr off' unconsumed') 0
    = go (n-1) (off'+d) (unconsumed'-d)
    | otherwise = Text arr off' unconsumed'

instance Cursorable UnpackedLazyByteString where
  offset = \(UnpackedLazyByteString i _ _ _ _ _) -> i
  lowerOffset = [||\(UnpackedLazyByteString i _ _ _ _ _) (UnpackedLazyByteString j _ _ _ _ _) -> i <= j||]
  sameOffset = [||\(UnpackedLazyByteString i _ _ _ _ _) (UnpackedLazyByteString j _ _ _ _ _) -> i == j||]
  shiftRight = [||shiftRightByteString||]

shiftRightByteString :: Int -> UnpackedLazyByteString -> UnpackedLazyByteString
shiftRightByteString j !(UnpackedLazyByteString i addr# final off size cs)
  | j < size  = UnpackedLazyByteString (i + j) addr# final (off + j) (size - j) cs
  | otherwise = case cs of
    BSL.Chunk (PS (ForeignPtr addr'# final') off' size') cs' ->
      shiftRightByteString (j - size)
        (UnpackedLazyByteString (i + size) addr'# final' off' size' cs')
    BSL.Empty -> emptyUnpackedLazyByteString (i + size)

shiftLeftByteString :: Int -> UnpackedLazyByteString -> UnpackedLazyByteString
shiftLeftByteString j !(UnpackedLazyByteString i addr# final off size cs) =
  UnpackedLazyByteString (i - d) addr# final (off - d) (size + d) cs
  where d = min off j

offWith :: CodeQ (ts -> OffWith ts)
offWith = [|| OffWith 0 ||]

-- ** Type 'Text16'
newtype Text16 = Text16 Text
--newtype CacheText = CacheText Text
-- ** Type 'CharList'
newtype CharList = CharList String
-- ** Type 'Stream'
data Stream = {-# UNPACK #-} !Char :> Stream
nomore :: Stream
nomore = '\0' :> nomore
{-
instance Cursorable (OffWith Stream) where
  lowerOffset = [|| \(OffWith i _) (OffWith j _) -> i < j ||]
  sameOffset = [|| \(OffWith i _) (OffWith j _) -> i == j ||]
  shiftRight = [|| \i (OffWith o ts) -> OffWith (o + i) (dropStream i ts) ||]
  where
    dropStream :: Int -> Stream -> Stream
    dropStream 0 cs = cs
    dropStream n (_ :> cs) = dropStream (n-1) cs
-}

-- ** Type 'OffWith'
data OffWith ts = OffWith {-# UNPACK #-} !Int ts
  deriving (Show)

instance Cursorable (OffWith String) where
  offset = \(OffWith i _) -> i
  lowerOffset = [|| \(OffWith i _) (OffWith j _) -> i < j ||]
  sameOffset = [|| \(OffWith i _) (OffWith j _) -> i == j ||]
  shiftRight = [|| \i (OffWith o ts) -> OffWith (o + i) (List.drop i ts) ||]

-- ** Type 'OffWithStreamAnd'
data OffWithStreamAnd ts = OffWithStreamAnd {-# UNPACK #-} !Int !Stream ts
-- ** Type 'UnpackedLazyByteString'
data UnpackedLazyByteString = UnpackedLazyByteString
  {-# UNPACK #-} !Int
  !Addr#
  ForeignPtrContents
  {-# UNPACK #-} !Int
  {-# UNPACK #-} !Int
  BSL.ByteString
instance Show UnpackedLazyByteString where
  show (UnpackedLazyByteString _i _addr _p _off _size _cs) = "UnpackedLazyByteString" -- FIXME

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

-- * Class 'Inputable'
class Cursorable (Cursor inp) => Inputable inp where
  type Cursor inp :: Type
  type InputToken inp :: Type
  cursorOf :: CodeQ inp -> CodeQ
    (# {-init-} Cursor inp
    ,  {-more-} Cursor inp -> Bool
    ,  {-next-} Cursor inp -> (# InputToken inp, Cursor inp #)
    #)

instance Inputable String where
  type Cursor String = Int
  type InputToken String = Char
  cursorOf input = cursorOf @(UArray Int Char)
    [|| listArray (0, List.length $$input-1) $$input ||]
instance Inputable (UArray Int Char) where
  type Cursor (UArray Int Char) = Int
  type InputToken (UArray Int Char) = Char
  cursorOf qinput = [||
      -- Pattern bindings containing unlifted types should use an outermost bang pattern.
      let !(UArray _ _ size input#) = $$qinput
          next (I# i#) =
            (# C# (indexWideCharArray# input# i#)
            ,  I# (i# +# 1#)
            #)
      in (# 0, (< size), next #)
    ||]
instance Inputable Text where
  type Cursor Text = Text
  type InputToken Text = Char
  cursorOf inp = [||
      let _ = "cursorOf" in
      let next t@(Text arr off unconsumed) =
            let !(Iter c d) = iter t 0 in
            (# c, Text arr (off+d) (unconsumed-d) #)
          more (Text _ _ unconsumed) = unconsumed > 0
      in (# $$inp, more, next #)
    ||]
instance Inputable ByteString where
  type Cursor ByteString = Int
  type InputToken ByteString = Word8
  cursorOf qinput = [||
      -- Pattern bindings containing unlifted types should use an outermost bang pattern.
      let !(PS (ForeignPtr addr# final) off size) = $$qinput
          next i@(I# i#) =
            case readWord8OffAddr# (addr# `plusAddr#` i#) 0# realWorld# of
              (# s', x #) -> case touch# final s' of
                _ -> (# W8# (x), i + 1 #)
      in (# off, (< size), next #)
    ||]
instance Inputable BSL.ByteString where
  type Cursor BSL.ByteString = UnpackedLazyByteString
  type InputToken BSL.ByteString = Char
  cursorOf qinput = [||
      let next (UnpackedLazyByteString i addr# final off@(I# off#) size cs) =
            case readWord8OffAddr# addr# off# realWorld# of
              (# s', x #) -> case touch# final s' of
                _ ->
                  (# C# (chr# (word2Int# x))
                  , if size /= 1 then UnpackedLazyByteString (i+1) addr# final (off+1) (size-1) cs
                    else case cs of
                      BSL.Chunk (PS (ForeignPtr addr'# final') off' size') cs' ->
                        UnpackedLazyByteString (i+1) addr'# final' off' size' cs'
                      BSL.Empty -> emptyUnpackedLazyByteString (i+1)
                  #)
          more (UnpackedLazyByteString _ _ _ _ 0 _) = False
          more _ = True
          init = case $$qinput of
            BSL.Chunk (PS (ForeignPtr addr# final) off size) cs ->
              UnpackedLazyByteString 0 addr# final off size cs
            BSL.Empty -> emptyUnpackedLazyByteString 0
      in (# init, more, next #)
    ||]
{-
instance Inputable Text16 where
  type Cursor Text16 = Int
  cursorOf qinput = [||
    let Text16 (Text arr off size) = $$qinput
        arr# = aBA arr
        next (I# i#) =
          (# C# (chr# (word2Int# (indexWord16Array# arr# i#)))
          , I# (i# +# 1#) #)
    in (# off, (< size), next #)
  ||]
instance Inputable CharList where
  type Cursor CharList = OffWith String
  cursorOf qinput = [||
    let CharList input = $$qinput
        next (OffWith i (c:cs)) = (# c, OffWith (i+1) cs #)
        size = List.length input
        more (OffWith i _) = i < size
        --more (OffWith _ []) = False
        --more _              = True
    in (# $$offWith input, more, next #)
  ||]
instance Inputable Stream where
  type Cursor Stream = OffWith Stream
  cursorOf qinput = [||
    let next (OffWith o (c :> cs)) = (# c, OffWith (o + 1) cs #)
    in (# $$offWith $$qinput, const True, next #)
  ||]
-}
{-
-- type instance Cursor CacheText = (Text, Stream)
-- type instance Cursor BSL.ByteString = OffWith BSL.ByteString
-}