{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
module Symantic.Parser.Automaton.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.Eq (Eq(..))
import Data.Int (Int)
import Data.Kind (Type)
import Data.Ord (Ord(..))
import Data.String (String)
import Data.Text.Array ({-aBA, empty-})
import Data.Text.Internal (Text(..))
import Data.Text.Unsafe (iter, Iter(..), iter_, reverseIter_)
import GHC.Exts (Int(..), Char(..){-, RuntimeRep(..)-})
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 Language.Haskell.TH as TH

-- import Symantic.Parser.Staging

-- * Class 'Cursorable'
class Cursorable cur where
  same :: CodeQ (cur -> cur -> Bool)
  shiftRight :: CodeQ (cur -> Int -> cur)
instance Cursorable Int where
  same = [|| (==) @Int ||]
  shiftRight = [|| (+) @Int ||]
instance Cursorable (OffWith String) where
  same = offWithSame
  shiftRight = offWithShiftRight [||List.drop||]
instance Cursorable Text where
  same = [|| \(Text _ i _) (Text _ j _) -> i == j ||]
  shiftRight = [||textShiftRight||]
{-
instance Cursorable (OffWith Stream) where
  same = offWithSame
  shiftRight = offWithShiftRight [||dropStream||]
-}
instance Cursorable UnpackedLazyByteString where
  same = [||\(UnpackedLazyByteString i _ _ _ _ _) (UnpackedLazyByteString j _ _ _ _ _) -> i == j||]
  shiftRight = [||byteStringShiftRight||]
offWith :: CodeQ (ts -> OffWith ts)
offWith = [|| OffWith 0 ||]

offWithSame :: CodeQ (OffWith ts -> OffWith ts -> Bool)
offWithSame = [|| \(OffWith i _) (OffWith j _) -> i == j ||]

offWithShiftRight ::
  CodeQ (Int -> ts -> ts) ->
  CodeQ (OffWith ts -> Int -> OffWith ts)
offWithShiftRight drop = [|| \(OffWith o ts) i -> OffWith (o + i) ($$drop i ts) ||]

-- ** 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
-- ** Type 'OffWith'
data OffWith ts = OffWith {-# UNPACK #-} !Int 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

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

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

-- | This must be here in a module separated from Eval,
-- to be used there as a stage-1 TemplateHaskell.
nextInputCont ::
  CodeQ (inp -> (# Char, inp #)) ->
  CodeQ inp ->
  (CodeQ Char -> CodeQ inp -> CodeQ r) ->
  CodeQ r
nextInputCont _next inp k = [||
    let _ = "nextInputCont" in
    let !(# c, cs #) = $$_next $$inp in
    $$(k [||c||] [||cs||])
  ||]

instance Input [Char] where
  type Cursor [Char] = Int
  cursorOf input = cursorOf @(UArray Int Char)
    [|| listArray (0, List.length $$input-1) $$input ||]
instance Input (UArray Int Char) where
  type Cursor (UArray Int Char) = Int
  cursorOf qinput = [||
      let UArray _ _ size input# = $$qinput
          next (I# i#) =
            (# C# (indexWideCharArray# input# i#)
            ,  I# (i# +# 1#)
            #)
      in (# 0, (< size), next #)
    ||]
instance Input Text where
  type Cursor Text = Text
  cursorOf qinput = [||
      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 (# $$qinput, more, next #)
    ||]
instance Input ByteString where
  type Cursor ByteString = Int
  cursorOf qinput = [||
      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
                _ -> (# C# (chr# (word2Int# x)), i + 1 #)
      in (# off, (< size), next #)
    ||]
instance Input BSL.ByteString where
  type Cursor BSL.ByteString = UnpackedLazyByteString
  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 Input 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 Input 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 Input 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
-}

dropStream :: Int -> Stream -> Stream
dropStream 0 cs = cs
dropStream n (_ :> cs) = dropStream (n-1) cs

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

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 off' unconsumed'

byteStringShiftRight :: UnpackedLazyByteString -> Int -> UnpackedLazyByteString
byteStringShiftRight !(UnpackedLazyByteString i addr# final off size cs) j
  | 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' -> byteStringShiftRight (UnpackedLazyByteString (i + size) addr'# final' off' size' cs') (j - size)
    BSL.Empty -> emptyUnpackedLazyByteString (i + size)

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