@@ -5,11 +5,12 @@ module Parse.Primitives
55 , fromByteString
66 , Parser(..)
77 , State(..)
8− , Context(..)
9− , oneOf
10− , pushContext, popContext, inContext
11− , getPosition, getCol, addLocation
12− , getIndent, setIndent
8+ , Row
9+ , Col
10+ , oneOf, oneOfWithFallback
11+ , inContext, specialize
12+ , getPosition, getCol, addLocation, addEnd
13+ , getIndent, setIndent, withIndent, withBacksetIndent
1314 , word1, word2
1415 , unsafeIndex, isWord, getCharWidth
1516 )
@@ -32,39 +33,37 @@ import qualified Reporting.Annotation as A
3233-- PARSER
3334
3435
35−newtype Parser c x a =
36+newtype Parser x a =
3637 Parser (
3738 forall b.
38− State c
39− -> (a -> State c -> b) -- consumed ok
40− -> (a -> State c -> b) -- empty ok
41− -> (Word16 -> Word16 -> Context c -> x -> b) -- consumed err
42− -> (Word16 -> Word16 -> Context c -> x -> b) -- empty err
39+ State
40+ -> (a -> State -> b) -- consumed ok
41+ -> (a -> State -> b) -- empty ok
42+ -> (Row -> Col -> (Row -> Col -> x) -> b) -- consumed err
43+ -> (Row -> Col -> (Row -> Col -> x) -> b) -- empty err
4344 -> b
4445 )
4546
4647
47−data State c =
48+data State = -- TODO try adding UNPACK to everything
4849 State
4950 { _pos :: !(Ptr Word8)
5051 , _end :: !(Ptr Word8)
5152 , _indent :: !Word16
52− , _row :: !Word16
53− , _col :: !Word16
54− , _context :: Context c
53+ , _row :: !Row
54+ , _col :: !Col
5555 }
5656
5757
58−data Context c
59− = NoContext
60− | Frame {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16 c (Context c)
58+type Row = Word16
59+type Col = Word16
6160
6261
6362
6463-- FUNCTOR
6564
6665
67−instance Functor (Parser c x) where
66+instance Functor (Parser x) where
6867 {-# INLINE fmap #-}
6968 fmap f (Parser parser) =
7069 Parser $ \state cok eok cerr eerr ->
@@ -79,7 +78,7 @@ instance Functor (Parser c x) where
7978-- APPLICATIVE
8079
8180
82−instance Applicative.Applicative (Parser c x) where
81+instance Applicative.Applicative (Parser x) where
8382 {-# INLINE pure #-}
8483 pure = return
8584
@@ -92,42 +91,74 @@ instance Applicative.Applicative (Parser c x) where
9291
9392
9493{-# INLINE oneOf #-}
95−oneOf :: x -> [Parser c x a] -> Parser c x a
96−oneOf x parsers =
94+oneOf :: (Row -> Col -> x) -> [Parser x a] -> Parser x a
95+oneOf toError parsers =
9796 Parser $ \state cok eok cerr eerr ->
98− oneOfHelp state cok eok cerr eerr x parsers
97+ oneOfHelp state cok eok cerr eerr toError parsers
9998
10099
101100oneOfHelp
102− :: State c
103− -> (a -> State c -> b)
104− -> (a -> State c -> b)
105− -> (Word16 -> Word16 -> Context c -> x -> b)
106− -> (Word16 -> Word16 -> Context c -> x -> b)
107− -> x
108− -> [Parser c x a]
101+ :: State
102+ -> (a -> State -> b)
103+ -> (a -> State -> b)
104+ -> (Row -> Col -> (Row -> Col -> x) -> b)
105+ -> (Row -> Col -> (Row -> Col -> x) -> b)
106+ -> (Row -> Col -> x)
107+ -> [Parser x a]
109108 -> b
110−oneOfHelp state cok eok cerr eerr x parsers =
109+oneOfHelp state cok eok cerr eerr toError parsers =
111110 case parsers of
112111 Parser parser : parsers ->
113112 let
114− eerr' _ _ _ _ =
115− oneOfHelp state cok eok cerr eerr x parsers
113+ eerr' _ _ _ =
114+ oneOfHelp state cok eok cerr eerr toError parsers
116115 in
117116 parser state cok eok cerr eerr'
118117
119118 [] ->
120119 let
121− (State _ _ _ row col ctx) = state
120+ (State _ _ _ row col) = state
122121 in
123− eerr row col ctx x
122+ eerr row col toError
123+
124+
125+
126+-- ONE OF WITH FALLBACK
127+
128+
129+{-# INLINE oneOfWithFallback #-}
130+oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- TODO is this function okay? Worried about allocation/laziness with fallback values.
131+oneOfWithFallback parsers fallback =
132+ Parser $ \state cok eok cerr _ ->
133+ oowfHelp state cok eok cerr parsers fallback
134+
135+
136+oowfHelp
137+ :: State
138+ -> (a -> State -> b)
139+ -> (a -> State -> b)
140+ -> (Row -> Col -> (Row -> Col -> x) -> b)
141+ -> [Parser x a]
142+ -> a
143+ -> b
144+oowfHelp state cok eok cerr parsers fallback =
145+ case parsers of
146+ [] ->
147+ eok fallback state
148+
149+ Parser parser : parsers ->
150+ let
151+ eerr' _ _ _ =
152+ oowfHelp state cok eok cerr parsers fallback
153+ in
154+ parser state cok eok cerr eerr'
124155
125156
126157
127158-- MONAD
128159
129160
130−instance Monad (Parser c x) where
161+instance Monad (Parser x) where
131162 {-# INLINE return #-}
132163 return value =
133164 Parser $ \state _ eok _ _ ->
@@ -152,148 +183,152 @@ instance Monad (Parser c x) where
152183-- FROM BYTESTRING
153184
154185
155−data Result c x a
156− = Ok !a (State c)
157− | Err Word16 Word16 (Context c) x
186+data Result x a
187+ = Ok !a State
188+ | Err x
158189
159190
160−fromByteString :: Parser c x a -> B.ByteString -> Result c x a
191+fromByteString :: Parser x a -> B.ByteString -> Result x a
161192fromByteString (Parser parser) (B.PS fp offset length) =
162193 B.accursedUnutterablePerformIO $
163194 let
164195 !pos = plusPtr (unsafeForeignPtrToPtr fp) offset
165196 !end = plusPtr pos length
166− !result = parser (State pos end 0 1 1 NoContext) Ok Ok Err Err
197+ !result = parser (State pos end 0 1 1) Ok Ok toErr toErr
167198 in
168199 do touchForeignPtr fp
169200 return result
170201
171202
203+toErr :: Row -> Col -> (Row -> Col -> x) -> Result x a
204+toErr row col toError =
205+ Err (toError row col)
206+
207+
172208
173209-- POSITION
174210
175211
176−getCol :: Parser c x Word16
212+getCol :: Parser x Word16
177213getCol =
178− Parser $ \state@(State _ _ _ _ col _) _ eok _ _ ->
214+ Parser $ \state@(State _ _ _ _ col) _ eok _ _ ->
179215 eok col state
180216
181217
182218{-# INLINE getPosition #-}
183−getPosition :: Parser c x A.Position
219+getPosition :: Parser x A.Position
184220getPosition =
185− Parser $ \state@(State _ _ _ row col _) _ eok _ _ ->
221+ Parser $ \state@(State _ _ _ row col) _ eok _ _ ->
186222 eok (A.Position row col) state
187223
188224
189−addLocation :: Parser c x a -> Parser c x (A.Located a)
225+addLocation :: Parser x a -> Parser x (A.Located a)
190226addLocation (Parser parser) =
191− Parser $ \state@(State _ _ _ srow scol _) cok eok cerr eerr ->
227+ Parser $ \state@(State _ _ _ sr sc) cok eok cerr eerr ->
192228 let
193− cok' a s@(State _ _ _ erow ecol _) = cok (A.At (A.Region (A.Position srow scol) (A.Position erow ecol)) a) s
194− eok' a s@(State _ _ _ erow ecol _) = eok (A.At (A.Region (A.Position srow scol) (A.Position erow ecol)) a) s
229+ cok' a s@(State _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
230+ eok' a s@(State _ _ _ er ec) = eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
195231 in
196232 parser state cok' eok' cerr eerr
197233
198234
235+addEnd :: A.Position -> a -> Parser x (A.Located a)
236+addEnd start value =
237+ Parser $ \state@(State _ _ _ row col) _ eok _ _ ->
238+ eok (A.at start (A.Position row col) value) state
239+
240+
199241
200242-- INDENT
201243
202244
203−getIndent :: Parser c x Word16
245+getIndent :: Parser x Word16
204246getIndent =
205− Parser $ \state@(State _ _ indent _ _ _) _ eok _ _ ->
247+ Parser $ \state@(State _ _ indent _ _) _ eok _ _ ->
206248 eok indent state
207249
208250
209−setIndent :: Word16 -> Parser c x ()
251+setIndent :: Word16 -> Parser x ()
210252setIndent indent =
211− Parser $ \(State pos end _ row col context) _ eok _ _ ->
253+ Parser $ \(State pos end _ row col) _ eok _ _ ->
212254 let
213− !newState =
214− State pos end indent row col context
255+ !newState = State pos end indent row col
215256 in
216257 eok () newState
217258
218259
219−
220−-- CONTEXT
260+withIndent :: Parser x a -> Parser x a
261+withIndent (Parser parser) =
262+ Parser $ \(State pos end oldIndent row col) cok eok cerr eerr ->
263+ let
264+ cok' a (State p e _ r c) = cok a (State p e oldIndent r c)
265+ eok' a (State p e _ r c) = eok a (State p e oldIndent r c)
266+ in
267+ parser (State pos end col row col) cok' eok' cerr eerr
221268
222269
223−pushContext :: A.Position -> c -> Parser c x ()
224−pushContext (A.Position r c) ctx =
225− Parser $ \(State pos end indent row col context) _ eok _ _ ->
270+withBacksetIndent :: Word16 -> Parser x a -> Parser x a
271+withBacksetIndent backset (Parser parser) =
272+ Parser $ \(State pos end oldIndent row col) cok eok cerr eerr ->
226273 let
227− !newContext = Frame r c ctx context
228− !newState = State pos end indent row col newContext
274+ cok' a (State p e _ r c) = cok a (State p e oldIndent r c)
275+ eok' a (State p e _ r c) = eok a (State p e oldIndent r c)
229276 in
230− eok () newState
277+ parser (State pos end (col - backset) row col) cok' eok' cerr eerr
231278
232279
233−popContext :: a -> Parser c x a
234−popContext value =
235− Parser $ \(State pos end indent row col context) _ eok _ _ ->
236− case context of
237− Frame _ _ _ context ->
238− let
239− !newState =
240− State pos end indent row col context
241− in
242− eok value newState
243280
244− NoContext ->
245− error "compiler error, trying to popContext on NoContext"
281+-- CONTEXT
246282
247283
248−inContext :: c -> Parser c x start -> Parser c x a -> Parser c x a
249−inContext tag (Parser parserStart) (Parser parserA) =
250− Parser $ \state@(State _ _ _ frow fcol _) cok eok cerr eerr ->
284+inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a
285+inContext addContext (Parser parserStart) (Parser parserA) =
286+ Parser $ \state@(State _ _ _ row col) cok eok cerr eerr ->
251287 let
252− cokS _ (State pos end indent row col ctx) =
253− let
254− !newContext = Frame frow fcol tag ctx
255− !newState = State pos end indent row col newContext
256− cokA a s = cok a (s { _context = ctx })
257− in
258− parserA newState cokA cokA cerr cerr
259−
260− eokS _ (State pos end indent row col ctx) =
261− let
262− !newContext = Frame frow fcol tag ctx
263− !newState = State pos end indent row col newContext
264− cokA a s = cok a (s { _context = ctx })
265− eokA a s = eok a (s { _context = ctx })
266− in
267− parserA newState cokA eokA cerr eerr
288+ cerrA r c tx = cerr row col (addContext (tx r c))
289+ eerrA r c tx = eerr row col (addContext (tx r c))
290+
291+ cokS _ s = parserA s cok cok cerrA cerrA
292+ eokS _ s = parserA s cok eok cerrA eerrA
268293 in
269294 parserStart state cokS eokS cerr eerr
270295
271296
297+specialize :: (x -> Row -> Col -> y) -> Parser x a -> Parser y a
298+specialize addContext (Parser parser) =
299+ Parser $ \state@(State _ _ _ row col) cok eok cerr eerr ->
300+ let
301+ cerr' r c tx = cerr row col (addContext (tx r c))
302+ eerr' r c tx = eerr row col (addContext (tx r c))
303+ in
304+ parser state cok eok cerr' eerr'
305+
306+
272307
273308-- SYMBOLS
274309
275310
276−word1 :: Word8 -> x -> Parser c x ()
277−word1 word x =
278− Parser $ \(State pos end indent row col ctx) cok _ _ eerr ->
311+word1 :: Word8 -> (Row -> Col -> x) -> Parser x ()
312+word1 word toError =
313+ Parser $ \(State pos end indent row col) cok _ _ eerr ->
279314 if pos < end && unsafeIndex pos == word then
280− let !newState = State (plusPtr pos 1) end indent row (col + 1) ctx in
315+ let !newState = State (plusPtr pos 1) end indent row (col + 1) in
281316 cok () newState
282317 else
283− eerr row col ctx x
318+ eerr row col toError
284319
285320
286−word2 :: Word8 -> Word8 -> x -> Parser c x ()
287−word2 w1 w2 x =
288− Parser $ \(State pos end indent row col ctx) cok _ _ eerr ->
321+word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
322+word2 w1 w2 toError =
323+ Parser $ \(State pos end indent row col) cok _ _ eerr ->
289324 let
290325 !pos1 = plusPtr pos 1
291326 in
292327 if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then
293− let !newState = State (plusPtr pos 2) end indent row (col + 2) ctx in
328+ let !newState = State (plusPtr pos 2) end indent row (col + 2) in
294329 cok () newState
295330 else
296− eerr row col ctx x
331+ eerr row col toError
297332
298333
299334