{-# 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 (Bool)
import Data.ByteString.Internal (ByteString(..))
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Int (Int)
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 'InputPosition'
-- | TODO
class InputPosition inp where
  same :: CodeQ (inp -> inp -> Bool)
  shiftRight :: CodeQ (inp -> Int -> inp)
instance InputPosition ()
instance InputPosition Int where
  same = [|| (==) @Int ||]
  shiftRight = [|| (+) @Int ||]
instance InputPosition (OffWith String) where
  same = offWithSame
  shiftRight = offWithShiftRight [||List.drop||]
{-
instance InputPosition (OffWith Stream) where
  same = offWithSame
  shiftRight = offWithShiftRight [||dropStream||]
instance InputPosition Text where
  same = [||\(Text _ i _) (Text _ j _) -> i == j||]
  shiftRight = [||textShiftRight||]
instance InputPosition 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) ||]

-- * Class 'InputPrep'
class InputPrep input where
  prepare :: CodeQ input -> CodeQ (InputDependant (Rep input))
instance InputPrep [Char] where
  prepare input = prepare @(UArray Int Char)
    [|| listArray (0, List.length $$input-1) $$input ||]
instance InputPrep (UArray Int Char) where
  prepare qinput = [||
      let UArray _ _ size input# = $$qinput
          next (I# i#) =
            (# C# (indexWideCharArray# input# i#)
            ,  I# (i# +# 1#)
            #)
      in (# next, (< size), 0 #)
    ||]
{-
instance InputPrep Text16 where
  prepare qinput = [||
    let Text16 (Text arr off size) = $$qinput
        arr# = aBA arr
        next (I# i#) =
          (# C# (chr# (word2Int# (indexWord16Array# arr# i#)))
          , I# (i# +# 1#) #)
    in (# next, (< size), off #)
  ||]
instance InputPrep ByteString where
  prepare 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 (# next, (< size), off #)
  ||]
instance InputPrep CharList where
  prepare 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 (# next, more, $$offWith input #)
  ||]
instance InputPrep Text where
  prepare qinput = [||
    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 (# next, more, $$qinput #)
  ||]
instance InputPrep BSL.ByteString where
  prepare 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
        initial = case $$qinput of
          BSL.Chunk (PS (ForeignPtr addr# final) off size) cs -> UnpackedLazyByteString 0 addr# final off size cs
          BSL.Empty -> emptyUnpackedLazyByteString 0
    in (# next, more, initial #)
  ||]
instance InputPrep Stream where
  prepare qinput = [||
    let next (OffWith o (c :> cs)) = (# c, OffWith (o + 1) cs #)
    in (# next, const True, $$offWith $$qinput #)
  ||]
-}

{- Input Types -}
newtype Text16 = Text16 Text
--newtype CacheText = CacheText Text
newtype CharList = CharList String
data Stream = {-# UNPACK #-} !Char :> Stream

nomore :: Stream
nomore = '\0' :> nomore

data OffWith ts = OffWith {-# UNPACK #-} !Int ts
data OffWithStreamAnd ts = OffWithStreamAnd {-# UNPACK #-} !Int !Stream ts
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

{-
type family Rep input
type instance Rep [Char] = Int
-}

type family Rep input where
  Rep [Char] = Int
  Rep (UArray Int Char) = Int
  {-
  Rep Text16 = Int
  Rep ByteString = Int
  Rep CharList = OffWith String
  Rep Text = Text
  --Rep CacheText = (Text, Stream)
  Rep BSL.ByteString = UnpackedLazyByteString
  --Rep BSL.ByteString = OffWith BSL.ByteString
  Rep Stream = OffWith Stream
  -}

-- * Type 'InputDependant'
type InputDependant rep =
  (# {-next-} rep -> (# Char, rep #)
  ,  {-more-} rep -> Bool
  ,  {-init-} rep
  #)

data InputOps rep = InputOps
  { _more :: CodeQ (rep -> Bool)
  , _next :: CodeQ (rep -> (# Char, rep #))
  }
more :: InputOps rep -> CodeQ (rep -> Bool)
more = _more
next :: InputOps rep -> CodeQ rep -> (CodeQ Char -> CodeQ rep -> CodeQ r) -> CodeQ r
next ops ts k = [||
    let !(# t, ts' #) = $$(_next ops) $$ts in
    $$(k [||t||] [||ts'||])
  ||]