{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE PolyKinds #-}
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 qualified Data.Text.Unsafe as Text.Unsafe
import Text.Show (Show(..))
import GHC.Exts (Int(..), Char(..) {-, RuntimeRep(..)-}, TYPE)
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
import qualified Data.Text as Text
import qualified Symantic.Parser.Machine.Input.Text.Buffer as Text.Buffer

-- * Class 'Inputable'
class Positionable (InputPosition inp) => Inputable inp where
  type InputBuffer inp :: Type
  type InputPosition inp :: Type
  type InputToken inp :: Type
  cursorOf :: CodeQ inp -> CodeQ (Cursor inp)
  nullInput :: inp -> Bool

-- ** Type 'Cursor'
type Cursor (inp :: TYPE r) = -- FIXME: what is that TYPE doing here?
    (# {-initBuf-} InputBuffer inp
    ,  {-initPos-} InputPosition inp
    ,  {-more-} InputBuffer inp -> InputPosition inp -> Bool
    ,  {-next-} InputBuffer inp -> InputPosition inp -> (# InputToken inp, InputPosition inp #)
    ,  {-append-} InputBuffer inp -> inp -> InputBuffer inp #)
instance Inputable Text where
  type InputBuffer Text = Text.Buffer.Buffer
  type InputPosition Text = Int
  type InputToken Text = Char
  nullInput = Text.null
  cursorOf inp = [||
      let next buf pos =
            let !(Text.Unsafe.Iter c d) = Text.Buffer.iter buf pos in
            (# c, pos+d #)
          more buf pos = pos < Text.Buffer.length buf
          append = Text.Buffer.pappend
      in (# Text.Buffer.buffer $$inp, 0, more, next, append #)
    ||]
{-
instance Inputable Text where
  type InputBuffer Text = Text
  type InputPosition Text = Text
  type InputToken Text = Char
  nullInput = Text.null
  cursorOf inp = [||
      let next _buf t@(Text arr off unconsumed) =
            let !(Text.Unsafe.Iter c d) = Text.Unsafe.iter t 0 in
            (# c, Text arr (off+d) (unconsumed-d) #)
          more _buf (Text _ _ unconsumed) = unconsumed > 0
      in (# $$inp, $$inp, more, next, Text.append #)
    ||]
-}

-- ** Class 'Positionable'
class Show pos => Positionable pos where
  position :: pos -> Int
  comparePosition :: CodeQ (pos -> pos -> Ordering)
  comparePosition = [|| compare `on` position ||]
  lowerPosition :: CodeQ (pos -> pos -> Bool)
  samePosition :: CodeQ (pos -> pos -> Bool)
  shiftRight :: CodeQ (Int -> pos -> pos)
instance Positionable Int where
  position = \inp -> inp
  comparePosition = [|| compare @Int ||]
  lowerPosition = [|| (<) @Int ||]
  samePosition = [|| (==) @Int ||]
  shiftRight = [|| (+) @Int ||]
instance Positionable Text where
  position = \(Text _ i _) -> i
  comparePosition = [|| \(Text _ i _) (Text _ j _) -> i `compare` j ||]
  lowerPosition = [|| \(Text _ i _) (Text _ j _) -> i < j ||]
  samePosition = [|| \(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 <- Text.Unsafe.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 <- Text.Unsafe.reverseIter_ (Text arr off' unconsumed') 0
    = go (n-1) (off'+d) (unconsumed'-d)
    | otherwise = Text arr off' unconsumed'

instance Positionable UnpackedLazyByteString where
  position = \(UnpackedLazyByteString i _ _ _ _ _) -> i
  lowerPosition = [||\(UnpackedLazyByteString i _ _ _ _ _) (UnpackedLazyByteString j _ _ _ _ _) -> i <= j||]
  samePosition = [||\(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
-}
-- ** 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 Positionable (OffWith Stream) where
  lowerPosition = [|| \(OffWith i _) (OffWith j _) -> i < j ||]
  samePosition = [|| \(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 Positionable (OffWith String) where
  position = \(OffWith i _) -> i
  lowerPosition = [|| \(OffWith i _) (OffWith j _) -> i < j ||]
  samePosition = [|| \(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
-}

{-
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 !(Text.Unsafe.Iter c d) = Text.Unsafe.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 #) ->
                -- TODO: use keepAlive# ?
                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 #) ->
                -- TODO: use keepAlive# ?
                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 #)
  ||]

offWith :: CodeQ (ts -> OffWith ts)
offWith = [|| OffWith 0 ||]
-}
{-
-- type instance Cursor CacheText = (Text, Stream)
-- type instance Cursor BSL.ByteString = OffWith BSL.ByteString
-}