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 (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.Ord (Ord(..))
  14 import Data.String (String)
  15 import Data.Text.Array (aBA{-, empty-})
  16 import Data.Text.Internal (Text(..))
  17 import Data.Text.Unsafe (iter, Iter(..), iter_, reverseIter_)
  18 import GHC.Exts (Int(..), Char(..), RuntimeRep(..))
  19 import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents)
  20 import GHC.Prim (Int#, Addr#, nullAddr#, indexWideCharArray#, indexWord16Array#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#))
  21 import Language.Haskell.TH (CodeQ)
  22 import Prelude ((+), (-), error)
  23 import qualified Data.ByteString.Lazy.Internal as BSL
  24 import qualified Data.List as List
  25 import qualified Language.Haskell.TH as TH
  26
  27 import Symantic.Parser.Staging
  28
  29 -- * Class 'InputPosition'
  30 -- | TODO
  31 class InputPosition inp where
  32   same :: CodeQ (inp -> inp -> Bool)
  33   shiftRight :: CodeQ (inp -> Int -> inp)
  34 instance InputPosition ()
  35 instance InputPosition Int where
  36   same = [|| (==) @Int ||]
  37   shiftRight = [|| (+) @Int ||]
  38 instance InputPosition (OffWith String) where
  39   same = offWithSame
  40   shiftRight = offWithShiftRight [||List.drop||]
  41 {-
  42 instance InputPosition (OffWith Stream) where
  43   same = offWithSame
  44   shiftRight = offWithShiftRight [||dropStream||]
  45 instance InputPosition Text where
  46   same = [||\(Text _ i _) (Text _ j _) -> i == j||]
  47   shiftRight = [||textShiftRight||]
  48 instance InputPosition UnpackedLazyByteString where
  49   same = [||\(UnpackedLazyByteString i _ _ _ _ _) (UnpackedLazyByteString j _ _ _ _ _) -> i == j||]
  50   shiftRight = [||byteStringShiftRight||]
  51 -}
  52 offWith :: CodeQ (ts -> OffWith ts)
  53 offWith = [|| OffWith 0 ||]
  54
  55 offWithSame :: CodeQ (OffWith ts -> OffWith ts -> Bool)
  56 offWithSame = [|| \(OffWith i _) (OffWith j _) -> i == j ||]
  57
  58 offWithShiftRight ::
  59   CodeQ (Int -> ts -> ts) ->
  60   CodeQ (OffWith ts -> Int -> OffWith ts)
  61 offWithShiftRight drop = [|| \(OffWith o ts) i -> OffWith (o + i) ($$drop i ts) ||]
  62
  63 -- * Class 'InputPrep'
  64 class InputPrep input where
  65   prepare :: CodeQ input -> CodeQ (InputDependant (Rep input))
  66 instance InputPrep [Char] where
  67   prepare input = prepare @(UArray Int Char)
  68     [|| listArray (0, List.length $$input-1) $$input ||]
  69 instance InputPrep (UArray Int Char) where
  70   prepare qinput = [||
  71       let UArray _ _ size input# = $$qinput
  72           next (I# i#) =
  73             (# C# (indexWideCharArray# input# i#)
  74             ,  I# (i# +# 1#)
  75             #)
  76       in (# next, (< size), 0 #)
  77     ||]
  78 {-
  79 instance InputPrep Text16 where
  80   prepare qinput = [||
  81     let Text16 (Text arr off size) = $$qinput
  82         arr# = aBA arr
  83         next (I# i#) =
  84           (# C# (chr# (word2Int# (indexWord16Array# arr# i#)))
  85           , I# (i# +# 1#) #)
  86     in (# next, (< size), off #)
  87   ||]
  88 instance InputPrep ByteString where
  89   prepare qinput = [||
  90     let PS (ForeignPtr addr# final) off size = $$qinput
  91         next i@(I# i#) =
  92           case readWord8OffAddr# (addr# `plusAddr#` i#) 0# realWorld# of
  93             (# s', x #) -> case touch# final s' of
  94               _ -> (# C# (chr# (word2Int# x)), i + 1 #)
  95     in (# next, (< size), off #)
  96   ||]
  97 instance InputPrep CharList where
  98   prepare qinput = [||
  99     let CharList input = $$qinput
 100         next (OffWith i (c:cs)) = (# c, OffWith (i+1) cs #)
 101         size = List.length input
 102         more (OffWith i _) = i < size
 103         --more (OffWith _ []) = False
 104         --more _              = True
 105     in (# next, more, $$offWith input #)
 106   ||]
 107 instance InputPrep Text where
 108   prepare qinput = [||
 109     let next t@(Text arr off unconsumed) =
 110           let !(Iter c d) = iter t 0 in
 111           (# c, Text arr (off+d) (unconsumed-d) #)
 112         more (Text _ _ unconsumed) = unconsumed > 0
 113     in (# next, more, $$qinput #)
 114   ||]
 115 instance InputPrep BSL.ByteString where
 116   prepare qinput = [||
 117     let next (UnpackedLazyByteString i addr# final off@(I# off#) size cs) =
 118           case readWord8OffAddr# addr# off# realWorld# of
 119             (# s', x #) -> case touch# final s' of
 120               _ -> (# C# (chr# (word2Int# x)),
 121                   if size /= 1 then UnpackedLazyByteString (i+1) addr# final (off+1) (size-1) cs
 122                   else case cs of
 123                     BSL.Chunk (PS (ForeignPtr addr'# final') off' size') cs' -> UnpackedLazyByteString (i+1) addr'# final' off' size' cs'
 124                     BSL.Empty -> emptyUnpackedLazyByteString (i+1)
 125                 #)
 126         more (UnpackedLazyByteString _ _ _ _ 0 _) = False
 127         more _ = True
 128         initial = case $$qinput of
 129           BSL.Chunk (PS (ForeignPtr addr# final) off size) cs -> UnpackedLazyByteString 0 addr# final off size cs
 130           BSL.Empty -> emptyUnpackedLazyByteString 0
 131     in (# next, more, initial #)
 132   ||]
 133 instance InputPrep Stream where
 134   prepare qinput = [||
 135     let next (OffWith o (c :> cs)) = (# c, OffWith (o + 1) cs #)
 136     in (# next, const True, $$offWith $$qinput #)
 137   ||]
 138 -}
 139
 140 {- Input Types -}
 141 newtype Text16 = Text16 Text
 142 --newtype CacheText = CacheText Text
 143 newtype CharList = CharList String
 144 data Stream = {-# UNPACK #-} !Char :> Stream
 145
 146 nomore :: Stream
 147 nomore = '\0' :> nomore
 148
 149 data OffWith ts = OffWith {-# UNPACK #-} !Int ts
 150 data OffWithStreamAnd ts = OffWithStreamAnd {-# UNPACK #-} !Int !Stream ts
 151 data UnpackedLazyByteString = UnpackedLazyByteString
 152   {-# UNPACK #-} !Int
 153   !Addr#
 154   ForeignPtrContents
 155   {-# UNPACK #-} !Int
 156   {-# UNPACK #-} !Int
 157   BSL.ByteString
 158
 159
 160 {-# INLINE emptyUnpackedLazyByteString #-}
 161 emptyUnpackedLazyByteString :: Int -> UnpackedLazyByteString
 162 emptyUnpackedLazyByteString i =
 163   UnpackedLazyByteString i nullAddr#
 164     (error "nullForeignPtr") 0 0 BSL.Empty
 165
 166 {-
 167 type family Rep input
 168 type instance Rep [Char] = Int
 169 -}
 170
 171 type family Rep input where
 172   Rep [Char] = Int
 173   Rep (UArray Int Char) = Int
 174   {-
 175   Rep Text16 = Int
 176   Rep ByteString = Int
 177   Rep CharList = OffWith String
 178   Rep Text = Text
 179   --Rep CacheText = (Text, Stream)
 180   Rep BSL.ByteString = UnpackedLazyByteString
 181   --Rep BSL.ByteString = OffWith BSL.ByteString
 182   Rep Stream = OffWith Stream
 183   -}
 184
 185 -- * Type 'InputDependant'
 186 type InputDependant rep =
 187   (# {-next-} rep -> (# Char, rep #)
 188   ,  {-more-} rep -> Bool
 189   ,  {-init-} rep
 190   #)
 191
 192 data InputOps rep = InputOps
 193   { _more :: CodeQ (rep -> Bool)
 194   , _next :: CodeQ (rep -> (# Char, rep #))
 195   }
 196 more :: InputOps rep -> CodeQ (rep -> Bool)
 197 more = _more
 198 next :: InputOps rep -> CodeQ rep -> (CodeQ Char -> CodeQ rep -> CodeQ r) -> CodeQ r
 199 next ops ts k = [||
 200     let !(# t, ts' #) = $$(_next ops) $$ts in
 201     $$(k [||t||] [||ts'||])
 202   ||]