src/Symantic/Parser/Automaton/Input.hs

   1 {-# LANGUAGE MagicHash #-}
   2 {-# LANGUAGE TemplateHaskell #-}
   3 {-# LANGUAGE UnboxedTuples #-}
   4 module Symantic.Parser.Automaton.Input where
   5
   6 import Data.Array.Base (UArray(..), listArray)
   7 -- import Data.Array.Unboxed (UArray)
   8 import Data.Bool
   9 import Data.ByteString.Internal (ByteString(..))
  10 import Data.Char (Char)
  11 import Data.Eq (Eq(..))
  12 import Data.Int (Int)
  13 import Data.Kind (Type)
  14 import Data.Ord (Ord(..))
  15 import Data.String (String)
  16 import Data.Text.Array ({-aBA, empty-})
  17 import Data.Text.Internal (Text(..))
  18 import Data.Text.Unsafe (iter, Iter(..), iter_, reverseIter_)
  19 import GHC.Exts (Int(..), Char(..){-, RuntimeRep(..)-})
  20 import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents)
  21 import GHC.Prim ({-Int#,-} Addr#, nullAddr#, indexWideCharArray#, {-indexWord16Array#,-} readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#))
  22 import Language.Haskell.TH (CodeQ)
  23 import Prelude ((+), (-), error)
  24 import qualified Data.ByteString.Lazy.Internal as BSL
  25 import qualified Data.List as List
  26 -- import qualified Language.Haskell.TH as TH
  27
  28 -- import Symantic.Parser.Staging
  29
  30 -- * Class 'Cursorable'
  31 class Cursorable cur where
  32   same :: CodeQ (cur -> cur -> Bool)
  33   shiftRight :: CodeQ (cur -> Int -> cur)
  34 instance Cursorable Int where
  35   same = [|| (==) @Int ||]
  36   shiftRight = [|| (+) @Int ||]
  37 instance Cursorable (OffWith String) where
  38   same = offWithSame
  39   shiftRight = offWithShiftRight [||List.drop||]
  40 instance Cursorable Text where
  41   same = [|| \(Text _ i _) (Text _ j _) -> i == j ||]
  42   shiftRight = [||textShiftRight||]
  43 {-
  44 instance Cursorable (OffWith Stream) where
  45   same = offWithSame
  46   shiftRight = offWithShiftRight [||dropStream||]
  47 -}
  48 instance Cursorable UnpackedLazyByteString where
  49   same = [||\(UnpackedLazyByteString i _ _ _ _ _) (UnpackedLazyByteString j _ _ _ _ _) -> i == j||]
  50   shiftRight = [||byteStringShiftRight||]
  51 offWith :: CodeQ (ts -> OffWith ts)
  52 offWith = [|| OffWith 0 ||]
  53
  54 offWithSame :: CodeQ (OffWith ts -> OffWith ts -> Bool)
  55 offWithSame = [|| \(OffWith i _) (OffWith j _) -> i == j ||]
  56
  57 offWithShiftRight ::
  58   CodeQ (Int -> ts -> ts) ->
  59   CodeQ (OffWith ts -> Int -> OffWith ts)
  60 offWithShiftRight drop = [|| \(OffWith o ts) i -> OffWith (o + i) ($$drop i ts) ||]
  61
  62 -- ** Type 'Text16'
  63 newtype Text16 = Text16 Text
  64 --newtype CacheText = CacheText Text
  65 -- ** Type 'CharList'
  66 newtype CharList = CharList String
  67 -- ** Type 'Stream'
  68 data Stream = {-# UNPACK #-} !Char :> Stream
  69 nomore :: Stream
  70 nomore = '\0' :> nomore
  71 -- ** Type 'OffWith'
  72 data OffWith ts = OffWith {-# UNPACK #-} !Int ts
  73 -- ** Type 'OffWithStreamAnd'
  74 data OffWithStreamAnd ts = OffWithStreamAnd {-# UNPACK #-} !Int !Stream ts
  75 -- ** Type 'UnpackedLazyByteString'
  76 data UnpackedLazyByteString = UnpackedLazyByteString
  77   {-# UNPACK #-} !Int
  78   !Addr#
  79   ForeignPtrContents
  80   {-# UNPACK #-} !Int
  81   {-# UNPACK #-} !Int
  82   BSL.ByteString
  83
  84 {-# INLINE emptyUnpackedLazyByteString #-}
  85 emptyUnpackedLazyByteString :: Int -> UnpackedLazyByteString
  86 emptyUnpackedLazyByteString i =
  87   UnpackedLazyByteString i nullAddr#
  88     (error "nullForeignPtr") 0 0 BSL.Empty
  89
  90 -- * Class 'Input'
  91 class Cursorable (Cursor inp) => Input inp where
  92   type Cursor inp :: Type
  93   cursorOf :: CodeQ inp -> CodeQ
  94     (# {-init-} Cursor inp
  95     ,  {-more-} Cursor inp -> Bool
  96     ,  {-next-} Cursor inp -> (# Char, Cursor inp #)
  97     #)
  98
  99 -- | This must be here in a module separated from Eval,
 100 -- to be used there as a stage-1 TemplateHaskell.
 101 nextInputCont ::
 102   CodeQ (inp -> (# Char, inp #)) ->
 103   CodeQ inp ->
 104   (CodeQ Char -> CodeQ inp -> CodeQ r) ->
 105   CodeQ r
 106 nextInputCont _next inp k = [||
 107     let _ = "nextInputCont" in
 108     let !(# c, cs #) = $$_next $$inp in
 109     $$(k [||c||] [||cs||])
 110   ||]
 111
 112 instance Input [Char] where
 113   type Cursor [Char] = Int
 114   cursorOf input = cursorOf @(UArray Int Char)
 115     [|| listArray (0, List.length $$input-1) $$input ||]
 116 instance Input (UArray Int Char) where
 117   type Cursor (UArray Int Char) = Int
 118   cursorOf qinput = [||
 119       let UArray _ _ size input# = $$qinput
 120           next (I# i#) =
 121             (# C# (indexWideCharArray# input# i#)
 122             ,  I# (i# +# 1#)
 123             #)
 124       in (# 0, (< size), next #)
 125     ||]
 126 instance Input Text where
 127   type Cursor Text = Text
 128   cursorOf qinput = [||
 129       let _ = "cursorOf" in
 130       let next t@(Text arr off unconsumed) =
 131             let !(Iter c d) = iter t 0 in
 132             (# c, Text arr (off+d) (unconsumed-d) #)
 133           more (Text _ _ unconsumed) = unconsumed > 0
 134       in (# $$qinput, more, next #)
 135     ||]
 136 instance Input ByteString where
 137   type Cursor ByteString = Int
 138   cursorOf qinput = [||
 139       let PS (ForeignPtr addr# final) off size = $$qinput
 140           next i@(I# i#) =
 141             case readWord8OffAddr# (addr# `plusAddr#` i#) 0# realWorld# of
 142               (# s', x #) -> case touch# final s' of
 143                 _ -> (# C# (chr# (word2Int# x)), i + 1 #)
 144       in (# off, (< size), next #)
 145     ||]
 146 instance Input BSL.ByteString where
 147   type Cursor BSL.ByteString = UnpackedLazyByteString
 148   cursorOf qinput = [||
 149       let next (UnpackedLazyByteString i addr# final off@(I# off#) size cs) =
 150             case readWord8OffAddr# addr# off# realWorld# of
 151               (# s', x #) -> case touch# final s' of
 152                 _ ->
 153                   (# C# (chr# (word2Int# x))
 154                   , if size /= 1 then UnpackedLazyByteString (i+1) addr# final (off+1) (size-1) cs
 155                     else case cs of
 156                       BSL.Chunk (PS (ForeignPtr addr'# final') off' size') cs' -> UnpackedLazyByteString (i+1) addr'# final' off' size' cs'
 157                       BSL.Empty -> emptyUnpackedLazyByteString (i+1)
 158                   #)
 159           more (UnpackedLazyByteString _ _ _ _ 0 _) = False
 160           more _ = True
 161           init = case $$qinput of
 162             BSL.Chunk (PS (ForeignPtr addr# final) off size) cs -> UnpackedLazyByteString 0 addr# final off size cs
 163             BSL.Empty -> emptyUnpackedLazyByteString 0
 164       in (# init, more, next #)
 165     ||]
 166 {-
 167 instance Input Text16 where
 168   type Cursor Text16 = Int
 169   cursorOf qinput = [||
 170     let Text16 (Text arr off size) = $$qinput
 171         arr# = aBA arr
 172         next (I# i#) =
 173           (# C# (chr# (word2Int# (indexWord16Array# arr# i#)))
 174           , I# (i# +# 1#) #)
 175     in (# off, (< size), next #)
 176   ||]
 177 instance Input CharList where
 178   type Cursor CharList = OffWith String
 179   cursorOf qinput = [||
 180     let CharList input = $$qinput
 181         next (OffWith i (c:cs)) = (# c, OffWith (i+1) cs #)
 182         size = List.length input
 183         more (OffWith i _) = i < size
 184         --more (OffWith _ []) = False
 185         --more _              = True
 186     in (# $$offWith input, more, next #)
 187   ||]
 188 instance Input Stream where
 189   type Cursor Stream = OffWith Stream
 190   cursorOf qinput = [||
 191     let next (OffWith o (c :> cs)) = (# c, OffWith (o + 1) cs #)
 192     in (# $$offWith $$qinput, const True, next #)
 193   ||]
 194 -}
 195 {-
 196 -- type instance Cursor CacheText = (Text, Stream)
 197 -- type instance Cursor BSL.ByteString = OffWith BSL.ByteString
 198 -}
 199
 200 dropStream :: Int -> Stream -> Stream
 201 dropStream 0 cs = cs
 202 dropStream n (_ :> cs) = dropStream (n-1) cs
 203
 204 textShiftRight :: Text -> Int -> Text
 205 textShiftRight (Text arr off unconsumed) i = go i off unconsumed
 206   where
 207     go 0 off' unconsumed' = Text arr off' unconsumed'
 208     go n off' unconsumed'
 209       | unconsumed' > 0 = let !d = iter_ (Text arr off' unconsumed') 0
 210                           in go (n-1) (off'+d) (unconsumed'-d)
 211       | otherwise = Text arr off' unconsumed'
 212
 213 textShiftLeft :: Text -> Int -> Text
 214 textShiftLeft (Text arr off unconsumed) i = go i off unconsumed
 215   where
 216     go 0 off' unconsumed' = Text arr off' unconsumed'
 217     go n off' unconsumed'
 218       | off' > 0 = let !d = reverseIter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)
 219       | otherwise = Text arr off' unconsumed'
 220
 221 byteStringShiftRight :: UnpackedLazyByteString -> Int -> UnpackedLazyByteString
 222 byteStringShiftRight !(UnpackedLazyByteString i addr# final off size cs) j
 223   | j < size  = UnpackedLazyByteString (i + j) addr# final (off + j) (size - j) cs
 224   | otherwise = case cs of
 225     BSL.Chunk (PS (ForeignPtr addr'# final') off' size') cs' -> byteStringShiftRight (UnpackedLazyByteString (i + size) addr'# final' off' size' cs') (j - size)
 226     BSL.Empty -> emptyUnpackedLazyByteString (i + size)
 227
 228 byteStringShiftLeft :: UnpackedLazyByteString -> Int -> UnpackedLazyByteString
 229 byteStringShiftLeft (UnpackedLazyByteString i addr# final off size cs) j =
 230   let d = min off j
 231   in UnpackedLazyByteString (i - d) addr# final (off - d) (size + d) cs