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