{-# LANGUAGE ImplicitParams,
MagicHash,
TypeApplications,
UnboxedTuples #-}
module Parsley.Internal.Backend.Machine.InputOps (
InputPrep(..), PositionOps(..), LogOps(..),
InputOps(..), more, next,
InputDependant,
) where
import Data.Array.Base (UArray(..), listArray)
import Data.ByteString.Internal (ByteString(..))
import Data.Text.Array (aBA)
import Data.Text.Internal (Text(..))
import Data.Text.Unsafe (iter, Iter(..))
import Data.Proxy (Proxy)
import GHC.Exts (Int(..), Char(..), TYPE, Int#)
import GHC.ForeignPtr (ForeignPtr(..))
import GHC.Prim (indexWideCharArray#, indexWord16Array#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#), (-#))
import Parsley.Internal.Backend.Machine.InputRep
import Parsley.Internal.Common.Utils (Code)
import Parsley.Internal.Core.InputTypes
import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..))
type InputDependant (rep :: TYPE r) = (# rep -> (# Char, rep #)
, rep -> Bool
, rep
#)
class InputPrep input where
prepare :: rep ~ Rep input => Code input -> Code (InputDependant rep)
class PositionOps input where
same :: rep ~ Rep input => Proxy input -> Code rep -> Code rep -> Code Bool
shiftRight :: rep ~ Rep input => Proxy input -> Code rep -> Code Int# -> Code rep
class LogOps (rep :: TYPE r) where
shiftLeft :: Code rep -> Code Int# -> Code rep
offToInt :: Code rep -> Code Int
data InputOps (rep :: TYPE r) = InputOps { InputOps rep -> Code (rep -> Bool)
_more :: Code (rep -> Bool)
, InputOps rep -> Code (rep -> (# Char, rep #))
_next :: Code (rep -> (# Char, rep #))
}
more :: forall r (rep :: TYPE r). (?ops :: InputOps rep) => Code (rep -> Bool)
more :: Code (rep -> Bool)
more = InputOps rep -> Code (rep -> Bool)
forall rep. InputOps rep -> Code (rep -> Bool)
_more ?ops::InputOps rep
InputOps rep
?ops
next :: forall r (rep :: TYPE r) a. (?ops :: InputOps rep) => Code rep -> (Code Char -> Code rep -> Code a) -> Code a
next :: Code rep -> (Code Char -> Code rep -> Code a) -> Code a
next Code rep
ts Code Char -> Code rep -> Code a
k = [|| let !(# t, ts' #) = $$(_next ?ops) $$ts in $$(k [||t||] [||ts'||]) ||]
instance InputPrep [Char] where
prepare :: Code [Char] -> Code (InputDependant rep)
prepare Code [Char]
input = Code (UArray Int Char) -> Code (InputDependant Int#)
forall input (rep :: TYPE (RepKind input)).
(InputPrep input, rep ~ Rep input) =>
Code input -> Code (InputDependant rep)
prepare @(UArray Int Char) [||listArray (0, length $$input-1) $$input||]
instance InputPrep (UArray Int Char) where
prepare :: Code (UArray Int Char) -> Code (InputDependant rep)
prepare Code (UArray Int Char)
qinput = [||
let UArray _ _ (I# size#) input# = $$qinput
next i# = (# C# (indexWideCharArray# input# i#), i# +# 1# #)
in (# next, \qi -> $$(intLess [||qi||] [||size#||]), 0# #)
||]
instance InputPrep Text16 where
prepare :: Code Text16 -> Code (InputDependant rep)
prepare Code Text16
qinput = [||
let Text16 (Text arr (I# off#) (I# size#)) = $$qinput
arr# = aBA arr
next i# = (# C# (chr# (word2Int# (indexWord16Array# arr# i#))), i# +# 1# #)
in (# next, \qi -> $$(intLess [||qi||] [||size#||]), off# #)
||]
instance InputPrep ByteString where
prepare :: Code ByteString -> Code (InputDependant rep)
prepare Code ByteString
qinput = [||
let PS (ForeignPtr addr# final) (I# off#) (I# size#) = $$qinput
next i# =
case readWord8OffAddr# (addr# `plusAddr#` i#) 0# realWorld# of
(# s', x #) -> case touch# final s' of
_ -> (# C# (chr# (word2Int# x)), i# +# 1# #)
in (# next, \qi -> $$(intLess [||qi||] [||size#||]), off# #)
||]
instance InputPrep CharList where
prepare :: Code CharList -> Code (InputDependant rep)
prepare Code CharList
qinput = [||
let CharList input = $$qinput
next (# i#, c:cs #) = (# c, (# i# +# 1#, cs #) #)
I# size# = length input
more (# i#, _ #) = $$(intLess [||i#||] [||size#||])
in (# next, more, $$(offWith [||input||]) #)
||]
instance InputPrep Text where
prepare :: Code Text -> Code (InputDependant rep)
prepare Code Text
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 Lazy.ByteString where
prepare :: Code ByteString -> Code (InputDependant rep)
prepare Code ByteString
qinput = [||
let next (# i#, addr#, final, off#, size#, cs #) =
case readWord8OffAddr# addr# off# realWorld# of
(# s', x #) -> case touch# final s' of
_ -> (# C# (chr# (word2Int# x)),
if I# size# /= 1 then (# i# +# 1#, addr#, final, off# +# 1#, size# -# 1#, cs #)
else case cs of
Lazy.Chunk (PS (ForeignPtr addr'# final') (I# off'#) (I# size'#)) cs' ->
(# i# +# 1#, addr'#, final', off'#, size'#, cs' #)
Lazy.Empty -> $$(emptyUnpackedLazyByteString [||i# +# 1#||])
#)
more :: UnpackedLazyByteString -> Bool
more (# _, _, _, _, 0#, _ #) = False
more (# _, _, _, _, _, _ #) = True
initial :: UnpackedLazyByteString
initial = case $$qinput of
Lazy.Chunk (PS (ForeignPtr addr# final) (I# off#) (I# size#)) cs -> (# 0#, addr#, final, off#, size#, cs #)
Lazy.Empty -> $$(emptyUnpackedLazyByteString [||0#||])
in (# next, more, initial #)
||]
instance InputPrep Stream where
prepare :: Code Stream -> Code (InputDependant rep)
prepare Code Stream
qinput = [||
let next (# o#, c :> cs #) = (# c, (# o# +# 1#, cs #) #)
in (# next, \_ -> True, $$(offWith qinput) #)
||]
shiftRightInt :: Code Int# -> Code Int# -> Code Int#
shiftRightInt :: Code Int# -> Code Int# -> Code Int#
shiftRightInt Code Int#
qo# Code Int#
qi# = [||$$(qo#) +# $$(qi#)||]
instance PositionOps [Char] where
same :: Proxy [Char] -> Code rep -> Code rep -> Code Bool
same Proxy [Char]
_ = Code Int# -> Code Int# -> Code Bool
Code rep -> Code rep -> Code Bool
intSame
shiftRight :: Proxy [Char] -> Code rep -> Code Int# -> Code rep
shiftRight Proxy [Char]
_ = Code Int# -> Code Int# -> Code Int#
Code rep -> Code Int# -> Code rep
shiftRightInt
instance PositionOps (UArray Int Char) where
same :: Proxy (UArray Int Char) -> Code rep -> Code rep -> Code Bool
same Proxy (UArray Int Char)
_ = Code Int# -> Code Int# -> Code Bool
Code rep -> Code rep -> Code Bool
intSame
shiftRight :: Proxy (UArray Int Char) -> Code rep -> Code Int# -> Code rep
shiftRight Proxy (UArray Int Char)
_ = Code Int# -> Code Int# -> Code Int#
Code rep -> Code Int# -> Code rep
shiftRightInt
instance PositionOps Text16 where
same :: Proxy Text16 -> Code rep -> Code rep -> Code Bool
same Proxy Text16
_ = Code Int# -> Code Int# -> Code Bool
Code rep -> Code rep -> Code Bool
intSame
shiftRight :: Proxy Text16 -> Code rep -> Code Int# -> Code rep
shiftRight Proxy Text16
_ = Code Int# -> Code Int# -> Code Int#
Code rep -> Code Int# -> Code rep
shiftRightInt
instance PositionOps ByteString where
same :: Proxy ByteString -> Code rep -> Code rep -> Code Bool
same Proxy ByteString
_ = Code Int# -> Code Int# -> Code Bool
Code rep -> Code rep -> Code Bool
intSame
shiftRight :: Proxy ByteString -> Code rep -> Code Int# -> Code rep
shiftRight Proxy ByteString
_ = Code Int# -> Code Int# -> Code Int#
Code rep -> Code Int# -> Code rep
shiftRightInt
instance PositionOps CharList where
same :: Proxy CharList -> Code rep -> Code rep -> Code Bool
same Proxy CharList
_ = Code rep -> Code rep -> Code Bool
forall ts. Code (# Int#, ts #) -> Code (# Int#, ts #) -> Code Bool
offWithSame
shiftRight :: Proxy CharList -> Code rep -> Code Int# -> Code rep
shiftRight Proxy CharList
_ Code rep
qo# Code Int#
qi# = Code (Int -> [Char] -> [Char])
-> Code (# Int#, [Char] #) -> Code Int# -> Code (# Int#, [Char] #)
forall ts.
Code (Int -> ts -> ts)
-> Code (# Int#, ts #) -> Code Int# -> Code (# Int#, ts #)
offWithShiftRight [||drop||] Code (# Int#, [Char] #)
Code rep
qo# Code Int#
qi#
instance PositionOps Stream where
same :: Proxy Stream -> Code rep -> Code rep -> Code Bool
same Proxy Stream
_ = Code rep -> Code rep -> Code Bool
forall ts. Code (# Int#, ts #) -> Code (# Int#, ts #) -> Code Bool
offWithSame
shiftRight :: Proxy Stream -> Code rep -> Code Int# -> Code rep
shiftRight Proxy Stream
_ Code rep
qo# Code Int#
qi# = Code (Int -> Stream -> Stream)
-> Code (# Int#, Stream #) -> Code Int# -> Code (# Int#, Stream #)
forall ts.
Code (Int -> ts -> ts)
-> Code (# Int#, ts #) -> Code Int# -> Code (# Int#, ts #)
offWithShiftRight [||dropStream||] Code (# Int#, Stream #)
Code rep
qo# Code Int#
qi#
instance PositionOps Text where
same :: Proxy Text -> Code rep -> Code rep -> Code Bool
same Proxy Text
_ Code rep
qt1 Code rep
qt2 = [||$$(offsetText qt1) == $$(offsetText qt2)||]
shiftRight :: Proxy Text -> Code rep -> Code Int# -> Code rep
shiftRight Proxy Text
_ Code rep
qo# Code Int#
qi# = [||textShiftRight $$(qo#) (I# $$(qi#))||]
instance PositionOps Lazy.ByteString where
same :: Proxy ByteString -> Code rep -> Code rep -> Code Bool
same Proxy ByteString
_ Code rep
qx# Code rep
qy# = [||
case $$(qx#) of
(# i#, _, _, _, _, _ #) -> case $$(qy#) of
(# j#, _, _, _, _, _ #) -> $$(intSame [||i#||] [||j#||])
||]
shiftRight :: Proxy ByteString -> Code rep -> Code Int# -> Code rep
shiftRight Proxy ByteString
_ Code rep
qo# Code Int#
qi# = [||byteStringShiftRight $$(qo#) $$(qi#)||]
instance LogOps Int# where
shiftLeft :: Code Int# -> Code Int# -> Code Int#
shiftLeft Code Int#
qo# Code Int#
qi# = [||max# ($$(qo#) -# $$(qi#)) 0#||]
offToInt :: Code Int# -> Code Int
offToInt Code Int#
qi# = [||I# $$(qi#)||]
instance LogOps (# Int#, ts #) where
shiftLeft :: Code (# Int#, ts #) -> Code Int# -> Code (# Int#, ts #)
shiftLeft Code (# Int#, ts #)
qo# Code Int#
_ = Code (# Int#, ts #)
qo#
offToInt :: Code (# Int#, ts #) -> Code Int
offToInt Code (# Int#, ts #)
qo# = [||case $$(qo#) of (# i#, _ #) -> I# i#||]
instance LogOps Text where
shiftLeft :: Code Text -> Code Int# -> Code Text
shiftLeft Code Text
qo Code Int#
qi# = [||textShiftLeft $$qo (I# $$(qi#))||]
offToInt :: Code Text -> Code Int
offToInt Code Text
qo = [||case $$qo of Text _ off _ -> div off 2||]
instance LogOps UnpackedLazyByteString where
shiftLeft :: Code UnpackedLazyByteString
-> Code Int# -> Code UnpackedLazyByteString
shiftLeft Code UnpackedLazyByteString
qo# Code Int#
qi# = [||byteStringShiftLeft $$(qo#) $$(qi#)||]
offToInt :: Code UnpackedLazyByteString -> Code Int
offToInt Code UnpackedLazyByteString
qo# = [||case $$(qo#) of (# i#, _, _, _, _, _ #) -> I# i# ||]