doc: registers are now available

[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / Input.hs

diff --git a/src/Symantic/Parser/Machine/Input.hs b/src/Symantic/Parser/Machine/Input.hs
index eea5e05523424d92cb97e49b1fa11140be88dc02..4bc94e5c34dacbe5e1fa4d3e9afeca2c713203c2 100644 (file)
--- a/src/Symantic/Parser/Machine/Input.hs
+++ b/src/Symantic/Parser/Machine/Input.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE PolyKinds #-}
 module Symantic.Parser.Machine.Input where
 
 import Data.Array.Base (UArray(..), listArray)
@@ -9,6 +10,7 @@ import Data.Array.Base (UArray(..), listArray)
 import Data.Bool
 import Data.ByteString.Internal (ByteString(..))
 import Data.Char (Char)
+import Data.Word (Word8)
 import Data.Eq (Eq(..))
 import Data.Function (on)
 import Data.Int (Int)
@@ -20,7 +22,8 @@ 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.Exts (Int(..), Char(..) {-, RuntimeRep(..)-}, TYPE)
+import GHC.Word (Word8(..))
 import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents)
 import GHC.Prim ({-Int#,-} Addr#, nullAddr#, indexWideCharArray#, {-indexWord16Array#,-} readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#))
 import Language.Haskell.TH (CodeQ)
@@ -84,7 +87,7 @@ shiftRightByteString j !(UnpackedLazyByteString i addr# final off size cs)
     BSL.Empty -> emptyUnpackedLazyByteString (i + size)
 
 shiftLeftByteString :: Int -> UnpackedLazyByteString -> UnpackedLazyByteString
-shiftLeftByteString j (UnpackedLazyByteString i addr# final off size cs) =
+shiftLeftByteString j !(UnpackedLazyByteString i addr# final off size cs) =
   UnpackedLazyByteString (i - d) addr# final (off - d) (size + d) cs
   where d = min off j
 
@@ -140,33 +143,36 @@ emptyUnpackedLazyByteString i =
   UnpackedLazyByteString i nullAddr#
     (error "nullForeignPtr") 0 0 BSL.Empty
 
--- * Class 'Input'
-class Cursorable (Cursor inp) => Input inp where
+-- * Class 'Inputable'
+class Cursorable (Cursor inp) => Inputable inp where
   type Cursor inp :: Type
   type InputToken inp :: Type
-  cursorOf :: CodeQ inp -> CodeQ
+  cursorOf :: CodeQ inp -> CodeQ (CursorOps inp)
+
+type CursorOps (inp :: TYPE r) =
     (# {-init-} Cursor inp
     ,  {-more-} Cursor inp -> Bool
     ,  {-next-} Cursor inp -> (# InputToken inp, Cursor inp #)
     #)
 
-instance Input String where
+instance Inputable String where
   type Cursor String = Int
   type InputToken String = Char
   cursorOf input = cursorOf @(UArray Int Char)
     [|| listArray (0, List.length $$input-1) $$input ||]
-instance Input (UArray Int Char) where
+instance Inputable (UArray Int Char) where
   type Cursor (UArray Int Char) = Int
   type InputToken (UArray Int Char) = Char
   cursorOf qinput = [||
-      let UArray _ _ size input# = $$qinput
+      -- Pattern bindings containing unlifted types should use an outermost bang pattern.
+      let !(UArray _ _ size input#) = $$qinput
           next (I# i#) =
             (# C# (indexWideCharArray# input# i#)
             ,  I# (i# +# 1#)
             #)
       in (# 0, (< size), next #)
     ||]
-instance Input Text where
+instance Inputable Text where
   type Cursor Text = Text
   type InputToken Text = Char
   cursorOf inp = [||
@@ -177,18 +183,19 @@ instance Input Text where
           more (Text _ _ unconsumed) = unconsumed > 0
       in (# $$inp, more, next #)
     ||]
-instance Input ByteString where
+instance Inputable ByteString where
   type Cursor ByteString = Int
-  type InputToken ByteString = Char
+  type InputToken ByteString = Word8
   cursorOf qinput = [||
-      let PS (ForeignPtr addr# final) off size = $$qinput
+      -- Pattern bindings containing unlifted types should use an outermost bang pattern.
+      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 #)
+                _ -> (# W8# (x), i + 1 #)
       in (# off, (< size), next #)
     ||]
-instance Input BSL.ByteString where
+instance Inputable BSL.ByteString where
   type Cursor BSL.ByteString = UnpackedLazyByteString
   type InputToken BSL.ByteString = Char
   cursorOf qinput = [||
@@ -212,7 +219,7 @@ instance Input BSL.ByteString where
       in (# init, more, next #)
     ||]
 {-
-instance Input Text16 where
+instance Inputable Text16 where
   type Cursor Text16 = Int
   cursorOf qinput = [||
     let Text16 (Text arr off size) = $$qinput
@@ -222,7 +229,7 @@ instance Input Text16 where
           , I# (i# +# 1#) #)
     in (# off, (< size), next #)
   ||]
-instance Input CharList where
+instance Inputable CharList where
   type Cursor CharList = OffWith String
   cursorOf qinput = [||
     let CharList input = $$qinput
@@ -233,7 +240,7 @@ instance Input CharList where
         --more _              = True
     in (# $$offWith input, more, next #)
   ||]
-instance Input Stream where
+instance Inputable Stream where
   type Cursor Stream = OffWith Stream
   cursorOf qinput = [||
     let next (OffWith o (c :> cs)) = (# c, OffWith (o + 1) cs #)
@@ -244,3 +251,4 @@ instance Input Stream where
 -- type instance Cursor CacheText = (Text, Stream)
 -- type instance Cursor BSL.ByteString = OffWith BSL.ByteString
 -}
+