{-# 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.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.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 :: Int -> Int
offset = \Int
inp -> Int
inp
  compareOffset :: CodeQ (Int -> Int -> Ordering)
compareOffset = [|| compare @Int ||]
  lowerOffset :: CodeQ (Int -> Int -> Bool)
lowerOffset = [|| (<) @Int ||]
  sameOffset :: CodeQ (Int -> Int -> Bool)
sameOffset = [|| (==) @Int ||]
  shiftRight :: CodeQ (Int -> Int -> Int)
shiftRight = [|| (+) @Int ||]
instance Cursorable Text where
  offset :: Text -> Int
offset = \(Text Array
_ Int
i Int
_) -> Int
i
  lowerOffset :: CodeQ (Text -> Text -> Bool)
lowerOffset = [|| \(Text _ i _) (Text _ j _) -> i < j ||]
  sameOffset :: CodeQ (Text -> Text -> Bool)
sameOffset = [|| \(Text _ i _) (Text _ j _) -> i == j ||]
  shiftRight :: CodeQ (Int -> Text -> Text)
shiftRight = [||shiftRightText||]

shiftRightText :: Int -> Text -> Text
shiftRightText :: Int -> Text -> Text
shiftRightText Int
i (Text Array
arr Int
off Int
unconsumed) = Int -> Int -> Int -> Text
go Int
i Int
off Int
unconsumed
  where
  go :: Int -> Int -> Int -> Text
go Int
0 Int
off' Int
unconsumed' = Array -> Int -> Int -> Text
Text Array
arr Int
off' Int
unconsumed'
  go Int
n Int
off' Int
unconsumed'
    | Int
unconsumed' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    , !Int
d <- Text -> Int -> Int
iter_ (Array -> Int -> Int -> Text
Text Array
arr Int
off' Int
unconsumed') Int
0
    = Int -> Int -> Int -> Text
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
off'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) (Int
unconsumed'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
d)
    | Bool
otherwise = Array -> Int -> Int -> Text
Text Array
arr Int
off' Int
unconsumed'

shiftLeftText :: Int -> Text -> Text
shiftLeftText :: Int -> Text -> Text
shiftLeftText Int
i (Text Array
arr Int
off Int
unconsumed) = Int -> Int -> Int -> Text
go Int
i Int
off Int
unconsumed
  where
  go :: Int -> Int -> Int -> Text
go Int
0 Int
off' Int
unconsumed' = Array -> Int -> Int -> Text
Text Array
arr Int
off' Int
unconsumed'
  go Int
n Int
off' Int
unconsumed'
    | Int
off' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    , !Int
d <- Text -> Int -> Int
reverseIter_ (Array -> Int -> Int -> Text
Text Array
arr Int
off' Int
unconsumed') Int
0
    = Int -> Int -> Int -> Text
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
off'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) (Int
unconsumed'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
d)
    | Bool
otherwise = Array -> Int -> Int -> Text
Text Array
arr Int
off' Int
unconsumed'

instance Cursorable UnpackedLazyByteString where
  offset :: UnpackedLazyByteString -> Int
offset = \(UnpackedLazyByteString Int
i Addr#
_ ForeignPtrContents
_ Int
_ Int
_ ByteString
_) -> Int
i
  lowerOffset :: CodeQ (UnpackedLazyByteString -> UnpackedLazyByteString -> Bool)
lowerOffset = [||\(UnpackedLazyByteString i _ _ _ _ _) (UnpackedLazyByteString j _ _ _ _ _) -> i <= j||]
  sameOffset :: CodeQ (UnpackedLazyByteString -> UnpackedLazyByteString -> Bool)
sameOffset = [||\(UnpackedLazyByteString i _ _ _ _ _) (UnpackedLazyByteString j _ _ _ _ _) -> i == j||]
  shiftRight :: CodeQ (Int -> UnpackedLazyByteString -> UnpackedLazyByteString)
shiftRight = [||shiftRightByteString||]

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

shiftLeftByteString :: Int -> UnpackedLazyByteString -> UnpackedLazyByteString
shiftLeftByteString :: Int -> UnpackedLazyByteString -> UnpackedLazyByteString
shiftLeftByteString Int
j (UnpackedLazyByteString Int
i Addr#
addr# ForeignPtrContents
final Int
off Int
size ByteString
cs) =
  Int
-> Addr#
-> ForeignPtrContents
-> Int
-> Int
-> ByteString
-> UnpackedLazyByteString
UnpackedLazyByteString (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
d) Addr#
addr# ForeignPtrContents
final (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
d) (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) ByteString
cs
  where d :: Int
d = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
off Int
j

offWith :: CodeQ (ts -> OffWith ts)
offWith :: forall ts. 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 :: Stream
nomore = Char
'\0' Char -> Stream -> Stream
:> Stream
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 (Int -> OffWith ts -> ShowS
[OffWith ts] -> ShowS
OffWith ts -> String
(Int -> OffWith ts -> ShowS)
-> (OffWith ts -> String)
-> ([OffWith ts] -> ShowS)
-> Show (OffWith ts)
forall ts. Show ts => Int -> OffWith ts -> ShowS
forall ts. Show ts => [OffWith ts] -> ShowS
forall ts. Show ts => OffWith ts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OffWith ts] -> ShowS
$cshowList :: forall ts. Show ts => [OffWith ts] -> ShowS
show :: OffWith ts -> String
$cshow :: forall ts. Show ts => OffWith ts -> String
showsPrec :: Int -> OffWith ts -> ShowS
$cshowsPrec :: forall ts. Show ts => Int -> OffWith ts -> ShowS
Show)

instance Cursorable (OffWith String) where
  offset :: OffWith String -> Int
offset = \(OffWith Int
i String
_) -> Int
i
  lowerOffset :: CodeQ (OffWith String -> OffWith String -> Bool)
lowerOffset = [|| \(OffWith i _) (OffWith j _) -> i < j ||]
  sameOffset :: CodeQ (OffWith String -> OffWith String -> Bool)
sameOffset = [|| \(OffWith i _) (OffWith j _) -> i == j ||]
  shiftRight :: CodeQ (Int -> OffWith String -> OffWith String)
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 -> String
show (UnpackedLazyByteString Int
_i Addr#
_addr ForeignPtrContents
_p Int
_off Int
_size ByteString
_cs) = String
"UnpackedLazyByteString" -- FIXME

{-# INLINE emptyUnpackedLazyByteString #-}
emptyUnpackedLazyByteString :: Int -> UnpackedLazyByteString
emptyUnpackedLazyByteString :: Int -> UnpackedLazyByteString
emptyUnpackedLazyByteString Int
i =
  Int
-> Addr#
-> ForeignPtrContents
-> Int
-> Int
-> ByteString
-> UnpackedLazyByteString
UnpackedLazyByteString Int
i Addr#
nullAddr#
    (String -> ForeignPtrContents
forall a. HasCallStack => String -> a
error String
"nullForeignPtr") Int
0 Int
0 ByteString
BSL.Empty

-- * Class 'Input'
class Cursorable (Cursor inp) => Input 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 Input String where
  type Cursor String = Int
  type InputToken String = Char
  cursorOf :: CodeQ String
-> CodeQ
     (# Cursor String, Cursor String -> Bool,
        Cursor String -> (# InputToken String, Cursor String #) #)
cursorOf CodeQ String
input = forall inp.
Input inp =>
CodeQ inp
-> CodeQ
     (# Cursor inp, Cursor inp -> Bool,
        Cursor inp -> (# InputToken inp, Cursor inp #) #)
cursorOf @(UArray Int Char)
    [|| listArray (0, List.length $$input-1) $$input ||]
instance Input (UArray Int Char) where
  type Cursor (UArray Int Char) = Int
  type InputToken (UArray Int Char) = Char
  cursorOf :: CodeQ (UArray Int Char)
-> CodeQ
     (# Cursor (UArray Int Char), Cursor (UArray Int Char) -> Bool,
        Cursor (UArray Int Char)
        -> (# InputToken (UArray Int Char), Cursor (UArray Int Char) #) #)
cursorOf CodeQ (UArray Int Char)
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
  type InputToken Text = Char
  cursorOf :: CodeQ Text
-> CodeQ
     (# Cursor Text, Cursor Text -> Bool,
        Cursor Text -> (# InputToken Text, Cursor Text #) #)
cursorOf CodeQ Text
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 Input ByteString where
  type Cursor ByteString = Int
  type InputToken ByteString = Char
  cursorOf :: CodeQ ByteString
-> CodeQ
     (# Cursor ByteString, Cursor ByteString -> Bool,
        Cursor ByteString
        -> (# InputToken ByteString, Cursor ByteString #) #)
cursorOf CodeQ ByteString
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
  type InputToken BSL.ByteString = Char
  cursorOf :: CodeQ ByteString
-> CodeQ
     (# Cursor ByteString, Cursor ByteString -> Bool,
        Cursor ByteString
        -> (# InputToken ByteString, Cursor ByteString #) #)
cursorOf CodeQ ByteString
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
-}