git.iko.soy/elk
on master help sign in
update Json.Decode to incorporate parse snippets and Json.String
42972a3Evan Czaplicki
compiler/src/Json/Decode.hs+306−159
compare with master
unifiedsplit
@@ -4,68 +4,108 @@ module Json.Decode
4 ( fromByteString
4 ( fromByteString
5 , Decoder
5 , Decoder
6 , string
6 , string
7+ , customString
7 , bool
8 , bool
8 , int
9 , int
9− , list, pair
10+ , list
11+ , nonEmptyList
12+ , pair
13+ --
14+ , KeyDecoder(..)
15+ , dict
10− , dict, pairs, field
16+ , pairs
17+ , field
18+ --
11 , oneOf
19 , oneOf
12 , failure
20 , failure
13 , mapError
21 , mapError
22+ --
23+ , Error(..)
24+ , Problem(..)
25+ , DecodeExpectation(..)
26+ , ParseError(..)
14 )
27 )
15 where
28 where
16
29
17
30
18−import qualified Data.ByteString as B
31+import qualified Data.ByteString.Internal as B
19−import qualified Data.List as List
20import qualified Data.Map as Map
32import qualified Data.Map as Map
21−import qualified Data.Utf8 as Utf8
33+import qualified Data.NonEmptyList as NE
22import Data.Word (Word8, Word16)
34import Data.Word (Word8, Word16)
23import Foreign.Ptr (Ptr, plusPtr, minusPtr)
35import Foreign.Ptr (Ptr, plusPtr, minusPtr)
36+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
24
37
38+import qualified Json.String as Json
25import qualified Parse.Keyword as K
39import qualified Parse.Keyword as K
26import qualified Parse.Primitives as P
40import qualified Parse.Primitives as P
27−import qualified Reporting.Error.Json as E
41+import Parse.Primitives (Row, Col)
28
42
29
43
30
44
31-- RUNNERS
45-- RUNNERS
32
46
33
47
34−fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a
48+fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
35−fromByteString decoder src =
49+fromByteString (Decoder decode) src =
36− fromAST decoder (P.fromByteString pFile src)
50+ case P.fromByteString pFile BadEnd src of
51+ Right ast ->
52+ decode ast Right (Left . DecodeProblem)
37
53
38−
54+ Left problem ->
39−fromAST :: Decoder e a -> P.Result E.ParseError AST -> Either (E.Error e) a
40−fromAST (Decoder decode) parserResult =
41− case parserResult of
42− P.Ok ast _ ->
43− decode ast Right (Left . E.DecodeProblem)
44−
45− P.Err err ->
46− Left (E.ParseProblem err)
55+ Left (ParseProblem problem)
47
56
48
57
49
58
50-- DECODERS
59-- DECODERS
51
60
52
61
53−newtype Decoder e a =
62+newtype Decoder x a =
54 Decoder
63 Decoder
55 (
64 (
56 forall b.
65 forall b.
57 AST
66 AST
58 -> (a -> b)
67 -> (a -> b)
59− -> (E.Problem e -> b)
68+ -> (Problem x -> b)
60 -> b
69 -> b
61 )
70 )
62
71
63
72
64
73
74+-- ERRORS
75+
76+
77+data Error x
78+ = DecodeProblem (Problem x)
79+ | ParseProblem ParseError
80+
81+
82+
83+-- DECODE PROBLEMS
84+
85+
86+data Problem x
87+ = Field B.ByteString (Problem x)
88+ | Index Int (Problem x)
89+ | OneOf (Problem x) [Problem x]
90+ | Failure x
91+ | Expecting DecodeExpectation
92+
93+
94+data DecodeExpectation
95+ = TObject
96+ | TArray
97+ | TString
98+ | TBool
99+ | TInt
100+ | TObjectWith B.ByteString
101+ | TArrayPair Int
102+
103+
104+
65-- INSTANCES
105-- INSTANCES
66
106
67
107
68−instance Functor (Decoder e) where
108+instance Functor (Decoder x) where
69 {-# INLINE fmap #-}
109 {-# INLINE fmap #-}
70 fmap func (Decoder decodeA) =
110 fmap func (Decoder decodeA) =
71 Decoder $ \ast ok err ->
111 Decoder $ \ast ok err ->
@@ -75,7 +115,7 @@ instance Functor (Decoder e) where
75 decodeA ast ok' err
115 decodeA ast ok' err
76
116
77
117
78−instance Applicative (Decoder e) where
118+instance Applicative (Decoder x) where
79 {-# INLINE pure #-}
119 {-# INLINE pure #-}
80 pure = return
120 pure = return
81
121
@@ -92,7 +132,7 @@ instance Applicative (Decoder e) where
92 decodeFunc ast okF err
132 decodeFunc ast okF err
93
133
94
134
95−instance Monad (Decoder e) where
135+instance Monad (Decoder x) where
96 {-# INLINE return #-}
136 {-# INLINE return #-}
97 return a =
137 return a =
98 Decoder $ \_ ok _ ->
138 Decoder $ \_ ok _ ->
@@ -113,22 +153,35 @@ instance Monad (Decoder e) where
113-- STRINGS
153-- STRINGS
114
154
115
155
116−string :: Decoder e Utf8.String
156+string :: Decoder x Json.String
117string =
157string =
118 Decoder $ \ast ok err ->
158 Decoder $ \ast ok err ->
119 case ast of
159 case ast of
120− String bits ->
160+ String snippet ->
121− ok bits
161+ ok (Json.fromSnippet snippet)
162+
163+ _ ->
164+ err (Expecting TString)
165+
166+
167+customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
168+customString parser toBadEnd =
169+ Decoder $ \ast ok err ->
170+ case ast of
171+ String snippet ->
172+ case P.fromSnippet parser toBadEnd snippet of
173+ Right a -> ok a
174+ Left x -> err (Failure x)
122
175
123 _ ->
176 _ ->
124− err (E.Expecting E.TString)
177+ err (Expecting TString)
125
178
126
179
127
180
128-- BOOL
181-- BOOL
129
182
130
183
131−bool :: Decoder e Bool
184+bool :: Decoder x Bool
132bool =
185bool =
133 Decoder $ \ast ok err ->
186 Decoder $ \ast ok err ->
134 case ast of
187 case ast of
@@ -139,14 +192,14 @@ bool =
139 ok False
192 ok False
140
193
141 _ ->
194 _ ->
142− err (E.Expecting E.TBool)
195+ err (Expecting TBool)
143
196
144
197
145
198
146-- INT
199-- INT
147
200
148
201
149−int :: Decoder e Int
202+int :: Decoder x Int
150int =
203int =
151 Decoder $ \ast ok err ->
204 Decoder $ \ast ok err ->
152 case ast of
205 case ast of
@@ -154,14 +207,14 @@ int =
154 ok n
207 ok n
155
208
156 _ ->
209 _ ->
157− err (E.Expecting E.TInt)
210+ err (Expecting TInt)
158
211
159
212
160
213
161−-- ARRAYS
214+-- LISTS
162
215
163
216
164−list :: Decoder e a -> Decoder e [a]
217+list :: Decoder x a -> Decoder x [a]
165list decoder =
218list decoder =
166 Decoder $ \ast ok err ->
219 Decoder $ \ast ok err ->
167 case ast of
220 case ast of
@@ -169,10 +222,10 @@ list decoder =
169 listHelp decoder ok err 0 asts []
222 listHelp decoder ok err 0 asts []
170
223
171 _ ->
224 _ ->
172− err (E.Expecting E.TArray)
225+ err (Expecting TArray)
173
226
174
227
175−listHelp :: Decoder e a -> ([a] -> b) -> (E.Problem e -> b) -> Int -> [AST] -> [a] -> b
228+listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
176listHelp decoder@(Decoder decodeA) ok err !i asts revs =
229listHelp decoder@(Decoder decodeA) ok err !i asts revs =
177 case asts of
230 case asts of
178 [] ->
231 [] ->
@@ -180,13 +233,29 @@ listHelp decoder@(Decoder decodeA) ok err !i asts revs =
180
233
181 ast:asts ->
234 ast:asts ->
182 let
235 let
183− ok' a = listHelp decoder ok err (i+1) asts (a:revs)
236+ ok' value = listHelp decoder ok err (i+1) asts (value:revs)
184− err' e = err (E.Index i e)
237+ err' prob = err (Index i prob)
185 in
238 in
186 decodeA ast ok' err'
239 decodeA ast ok' err'
187
240
188
241
242+
243+-- NON-EMPTY LISTS
244+
245+
246+nonEmptyList :: Decoder x a -> x -> Decoder x (NE.List a)
247+nonEmptyList decoder x =
248+ do values <- list decoder
249+ case values of
250+ v:vs -> return (NE.List v vs)
251+ [] -> failure x
252+
253+
254+
255+-- PAIR
256+
257+
189−pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)
258+pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
190pair (Decoder decodeA) (Decoder decodeB) =
259pair (Decoder decodeA) (Decoder decodeB) =
191 Decoder $ \ast ok err ->
260 Decoder $ \ast ok err ->
192 case ast of
261 case ast of
@@ -194,10 +263,10 @@ pair (Decoder decodeA) (Decoder decodeB) =
194 case vs of
263 case vs of
195 [astA,astB] ->
264 [astA,astB] ->
196 let
265 let
197− err0 e = err (E.Index 0 e)
266+ err0 e = err (Index 0 e)
198 ok0 a =
267 ok0 a =
199 let
268 let
200− err1 e = err (E.Index 1 e)
269+ err1 e = err (Index 1 e)
201 ok1 b = ok (a,b)
270 ok1 b = ok (a,b)
202 in
271 in
203 decodeB astB ok1 err1
272 decodeB astB ok1 err1
@@ -205,70 +274,98 @@ pair (Decoder decodeA) (Decoder decodeB) =
205 decodeA astA ok0 err0
274 decodeA astA ok0 err0
206
275
207 _ ->
276 _ ->
208− err (E.Expecting (E.TArrayPair (length vs)))
277+ err (Expecting (TArrayPair (length vs)))
209
278
210 _ ->
279 _ ->
211− err (E.Expecting E.TArray)
280+ err (Expecting TArray)
212
281
213
282
214
283
215−-- OBJECT
284+-- OBJECTS
216
285
217
286
218−dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)
287+data KeyDecoder x a =
219−dict decoder =
288+ KeyDecoder (P.Parser x a) (Row -> Col -> x)
220− Map.fromList <$> pairs decoder
221
289
222
290
291+dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)
292+dict keyDecoder valueDecoder =
293+ Map.fromList <$> pairs keyDecoder valueDecoder
294+
295+
223−pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]
296+pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
224−pairs decoder =
297+pairs keyDecoder valueDecoder =
225 Decoder $ \ast ok err ->
298 Decoder $ \ast ok err ->
226 case ast of
299 case ast of
227 Object kvs ->
300 Object kvs ->
228− pairsHelp decoder ok err kvs []
301+ pairsHelp keyDecoder valueDecoder ok err kvs []
229
302
230 _ ->
303 _ ->
231− err (E.Expecting E.TObject)
304+ err (Expecting TObject)
232
305
233
306
234−pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b
307+pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
235−pairsHelp decoder@(Decoder decodeA) ok err kvs revs =
308+pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =
236 case kvs of
309 case kvs of
237 [] ->
310 [] ->
238 ok (reverse revs)
311 ok (reverse revs)
239
312
240− (key, ast) : kvs ->
313+ (snippet, ast) : kvs ->
241− let
314+ case P.fromSnippet keyParser toBadEnd snippet of
315+ Left x ->
316+ err (Failure x)
317+
318+ Right key ->
319+ let
242− ok' a = pairsHelp decoder ok err kvs ((key,a):revs)
320+ ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)
243− err' e = err (E.Field key e)
321+ err' prob =
322+ let (P.Snippet fptr off len _ _) = snippet in
323+ err (Field (B.PS fptr off len) prob)
244− in
324+ in
245− decodeA ast ok' err'
325+ decodeA ast ok' err'
326+
246
327
247
328
329+-- FIELDS
330+
331+
248−field :: Utf8.String -> Decoder e a -> Decoder e a
332+field :: B.ByteString -> Decoder x a -> Decoder x a
249field key (Decoder decodeA) =
333field key (Decoder decodeA) =
250 Decoder $ \ast ok err ->
334 Decoder $ \ast ok err ->
251 case ast of
335 case ast of
252 Object kvs ->
336 Object kvs ->
253− case List.lookup key kvs of
337+ case findField key kvs of
254− Just v ->
338+ Just value ->
255 let
339 let
340+ err' prob =
256− err' e = err (E.Field key e)
341+ err (Field key prob)
257 in
342 in
258− decodeA v ok err'
343+ decodeA value ok err'
259
344
260 Nothing ->
345 Nothing ->
261− err (E.Expecting (E.TObjectWith key))
346+ err (Expecting (TObjectWith key))
262
347
263 _ ->
348 _ ->
264− err (E.Expecting E.TObject)
349+ err (Expecting TObject)
350+
351+
352+findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
353+findField key pairs =
354+ case pairs of
355+ [] ->
356+ Nothing
357+
358+ (P.Snippet fptr off len _ _, value) : remainingPairs ->
359+ if key == B.PS fptr off len
360+ then Just value
361+ else findField key remainingPairs
265
362
266
363
267
364
268-- ONE OF
365-- ONE OF
269
366
270
367
271−oneOf :: [Decoder e a] -> Decoder e a
368+oneOf :: [Decoder x a] -> Decoder x a
272oneOf decoders =
369oneOf decoders =
273 Decoder $ \ast ok err ->
370 Decoder $ \ast ok err ->
274 case decoders of
371 case decoders of
@@ -283,61 +380,61 @@ oneOf decoders =
283 error "Ran into (Json.Decode.oneOf [])"
380 error "Ran into (Json.Decode.oneOf [])"
284
381
285
382
286−oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b
383+oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b
287−oneOfHelp ast ok err decoders e es =
384+oneOfHelp ast ok err decoders p ps =
288 case decoders of
385 case decoders of
289 Decoder decodeA : decoders ->
386 Decoder decodeA : decoders ->
290 let
387 let
291− err' e' =
388+ err' p' =
292− oneOfHelp ast ok err decoders e' (e:es)
389+ oneOfHelp ast ok err decoders p' (p:ps)
293 in
390 in
294 decodeA ast ok err'
391 decodeA ast ok err'
295
392
296 [] ->
393 [] ->
297− err (oneOfError [] e es)
394+ err (oneOfError [] p ps)
298
395
299
396
300−oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e
397+oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x
301−oneOfError errors err es =
398+oneOfError problems prob ps =
302− case es of
399+ case ps of
303 [] ->
400 [] ->
304− E.OneOf err errors
401+ OneOf prob problems
305
402
306− e:es ->
403+ p:ps ->
307− oneOfError (err:errors) e es
404+ oneOfError (prob:problems) p ps
308
405
309
406
310
407
311-- FAILURE
408-- FAILURE
312
409
313
410
314−failure :: e -> Decoder e a
411+failure :: x -> Decoder x a
315−failure e =
412+failure x =
316 Decoder $ \_ _ err ->
413 Decoder $ \_ _ err ->
317− err (E.Failure e)
414+ err (Failure x)
318
415
319
416
320
417
321-- ERRORS
418-- ERRORS
322
419
323
420
324−mapError :: (e -> e') -> Decoder e a -> Decoder e' a
421+mapError :: (x -> y) -> Decoder x a -> Decoder y a
325mapError func (Decoder decodeA) =
422mapError func (Decoder decodeA) =
326 Decoder $ \ast ok err ->
423 Decoder $ \ast ok err ->
327 let
424 let
328− err' e = err (mapErrorHelp func e)
425+ err' prob = err (mapErrorHelp func prob)
329 in
426 in
330 decodeA ast ok err'
427 decodeA ast ok err'
331
428
332
429
333−mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'
430+mapErrorHelp :: (x -> y) -> Problem x -> Problem y
334−mapErrorHelp func err =
431+mapErrorHelp func problem =
335− case err of
432+ case problem of
336− E.Field k e -> E.Field k (mapErrorHelp func e)
433+ Field k p -> Field k (mapErrorHelp func p)
337− E.Index i e -> E.Index i (mapErrorHelp func e)
434+ Index i p -> Index i (mapErrorHelp func p)
338− E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)
435+ OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
339− E.Failure e -> E.Failure (func e)
436+ Failure x -> Failure (func x)
340− E.Expecting e -> E.Expecting e
437+ Expecting e -> Expecting e
341
438
342
439
343
440
@@ -346,8 +443,8 @@ mapErrorHelp func err =
346
443
347data AST
444data AST
348 = Array [AST]
445 = Array [AST]
349− | Object [(Utf8.String, AST)]
446+ | Object [(P.Snippet, AST)]
350− | String Utf8.String
447+ | String P.Snippet
351 | Int Int
448 | Int Int
352 | TRUE
449 | TRUE
353 | FALSE
450 | FALSE
@@ -359,7 +456,40 @@ data AST
359
456
360
457
361type Parser a =
458type Parser a =
362− P.Parser E.ParseError a
459+ P.Parser ParseError a
460+
461+
462+data ParseError
463+ = ObjectStart Row Col
464+ | ObjectMore Row Col
465+ | ObjectEnd Row Col
466+ | ArrayStart Row Col
467+ | ArrayMore Row Col
468+ | ArrayEnd Row Col
469+ | StringStart Row Col
470+ | StringProblem StringProblem Row Col
471+ | IntStart Row Col
472+ | NoLeadingZeros Row Col
473+ | NoFloats Row Col
474+ | Bool Row Col
475+ | Null Row Col
476+ | Value Row Col
477+ | Colon Row Col
478+ | BadEnd Row Col
479+
480+-- PIndex Int ParseError Row Col
481+-- PField Json.String ParseError Row Col
482+
483+
484+data StringProblem
485+ = BadStringEnd
486+ | BadStringControlChar
487+ | BadStringEscapeChar
488+ | BadStringEscapeHex
489+
490+
491+
492+-- PARSE AST
363
493
364
494
365pFile :: Parser AST
495pFile :: Parser AST
@@ -367,69 +497,59 @@ pFile =
367 do spaces
497 do spaces
368 value <- pValue
498 value <- pValue
369 spaces
499 spaces
370− endOfFile
371 return value
500 return value
372
501
373
502
374pValue :: Parser AST
503pValue :: Parser AST
375pValue =
504pValue =
376− P.oneOf E.Value
505+ P.oneOf Value
377− [ fmap String pString
506+ [ String <$> pString
378 , pObject
507 , pObject
379 , pArray
508 , pArray
380 , pInt
509 , pInt
381− , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE
510+ , K.k4 0x74 0x72 0x75 0x65 Bool >> return TRUE
382− , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE
511+ , K.k5 0x66 0x61 0x6C 0x73 0x65 Bool >> return FALSE
383− , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL
512+ , K.k4 0x6E 0x75 0x6C 0x6C Null >> return NULL
384 ]
513 ]
385
514
386
515
387−endOfFile :: Parser ()
388−endOfFile =
389− P.Parser $ \state@(P.State pos end _ row col) _ eok _ eerr ->
390− if pos < end then
391− eerr row col E.EndOfFile
392− else
393− eok () state
394−
395−
396
516
397-- OBJECT
517-- OBJECT
398
518
399
519
400pObject :: Parser AST
520pObject :: Parser AST
401pObject =
521pObject =
402− do P.word1 0x7B {- { -} E.ObjectStart
522+ do P.word1 0x7B {- { -} ObjectStart
403 spaces
523 spaces
404− P.oneOf E.ObjectMore
524+ P.oneOf ObjectMore
405 [ do entry <- pField
525 [ do entry <- pField
406 spaces
526 spaces
407 pObjectHelp [entry]
527 pObjectHelp [entry]
408− , do P.word1 0x7D {-}-} E.ObjectEnd
528+ , do P.word1 0x7D {-}-} ObjectEnd
409 return (Object [])
529 return (Object [])
410 ]
530 ]
411
531
412
532
413−pObjectHelp :: [(Utf8.String, AST)] -> Parser AST
533+pObjectHelp :: [(P.Snippet, AST)] -> Parser AST
414pObjectHelp revEntries =
534pObjectHelp revEntries =
415− P.oneOf E.ObjectMore
535+ P.oneOf ObjectMore
416 [
536 [
417− do P.word1 0x2C {-,-} E.ObjectMore
537+ do P.word1 0x2C {-,-} ObjectMore
418 spaces
538 spaces
419 entry <- pField
539 entry <- pField
420 spaces
540 spaces
421 pObjectHelp (entry:revEntries)
541 pObjectHelp (entry:revEntries)
422 ,
542 ,
423− do P.word1 0x7D {-}-} E.ObjectEnd
543+ do P.word1 0x7D {-}-} ObjectEnd
424 return (Object (reverse revEntries))
544 return (Object (reverse revEntries))
425 ]
545 ]
426
546
427
547
428−pField :: Parser (Utf8.String, AST)
548+pField :: Parser (P.Snippet, AST)
429pField =
549pField =
430 do key <- pString
550 do key <- pString
431 spaces
551 spaces
432− P.word1 0x3A {-:-} E.Colon
552+ P.word1 0x3A {-:-} Colon
433 spaces
553 spaces
434 value <- pValue
554 value <- pValue
435 return (key, value)
555 return (key, value)
@@ -441,28 +561,28 @@ pField =
441
561
442pArray :: Parser AST
562pArray :: Parser AST
443pArray =
563pArray =
444− do P.word1 0x5B {-[-} E.ArrayStart
564+ do P.word1 0x5B {-[-} ArrayStart
445 spaces
565 spaces
446− P.oneOf E.ArrayMore
566+ P.oneOf ArrayMore
447 [ do entry <- pValue
567 [ do entry <- pValue
448 spaces
568 spaces
449 pArrayHelp 1 [entry]
569 pArrayHelp 1 [entry]
450− , do P.word1 0x5D {-]-} E.ArrayEnd
570+ , do P.word1 0x5D {-]-} ArrayEnd
451 return (Array [])
571 return (Array [])
452 ]
572 ]
453
573
454
574
455pArrayHelp :: Int -> [AST] -> Parser AST
575pArrayHelp :: Int -> [AST] -> Parser AST
456pArrayHelp !len revEntries =
576pArrayHelp !len revEntries =
457− P.oneOf E.ArrayMore
577+ P.oneOf ArrayMore
458 [
578 [
459− do P.word1 0x2C {-,-} E.ArrayMore
579+ do P.word1 0x2C {-,-} ArrayMore
460 spaces
580 spaces
461 entry <- pValue
581 entry <- pValue
462 spaces
582 spaces
463 pArrayHelp (len + 1) (entry:revEntries)
583 pArrayHelp (len + 1) (entry:revEntries)
464 ,
584 ,
465− do P.word1 0x5D {-]-} E.ArrayEnd
585+ do P.word1 0x5D {-]-} ArrayEnd
466 return (Array (reverse revEntries))
586 return (Array (reverse revEntries))
467 ]
587 ]
468
588
@@ -471,41 +591,44 @@ pArrayHelp !len revEntries =
471-- STRING
591-- STRING
472
592
473
593
474−pString :: Parser Utf8.String
594+pString :: Parser P.Snippet
475pString =
595pString =
476− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
596+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
477 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
597 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
478
598
479 let
599 let
480 !pos1 = plusPtr pos 1
600 !pos1 = plusPtr pos 1
601+ !col1 = col + 1
481
602
482 (# status, newPos, newRow, newCol #) =
603 (# status, newPos, newRow, newCol #) =
483− pStringHelp pos1 end row (col + 1)
604+ pStringHelp pos1 end row col1
484 in
605 in
485 case status of
606 case status of
486 GoodString ->
607 GoodString ->
487 let
608 let
609+ !off = minusPtr pos1 (unsafeForeignPtrToPtr src)
610+ !len = minusPtr newPos pos1 - 1
611+ !snp = P.Snippet src off len row col1
488− !newState = P.State newPos end indent newRow newCol
612+ !newState = P.State src newPos end indent newRow newCol
489− !content = Utf8.fromPtr pos1 (plusPtr newPos (-1))
490 in
613 in
491− cok content newState
614+ cok snp newState
492
615
493− BadStringEnd ->
616+ BadString problem ->
494− cerr newRow newCol E.StringEnd
617+ cerr newRow newCol (StringProblem problem)
495
618
496 else
619 else
497− eerr row col E.StringStart
620+ eerr row col StringStart
498
621
499
622
500data StringStatus
623data StringStatus
501 = GoodString
624 = GoodString
502− | BadStringEnd
625+ | BadString StringProblem
503
626
504
627
505pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
628pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
506pStringHelp pos end row col =
629pStringHelp pos end row col =
507 if pos >= end then
630 if pos >= end then
508− (# BadStringEnd, pos, row, col #)
631+ (# BadString BadStringEnd, pos, row, col #)
509
632
510 else
633 else
511 case P.unsafeIndex pos of
634 case P.unsafeIndex pos of
@@ -513,26 +636,50 @@ pStringHelp pos end row col =
513 (# GoodString, plusPtr pos 1, row, col + 1 #)
636 (# GoodString, plusPtr pos 1, row, col + 1 #)
514
637
515 0x0A {-\n-} ->
638 0x0A {-\n-} ->
516− (# BadStringEnd, pos, row, col #)
639+ (# BadString BadStringEnd, pos, row, col #)
517
640
518 0x5C {-\-} ->
641 0x5C {-\-} ->
519− let
520− !pos1 = plusPtr pos 1
642+ let !pos1 = plusPtr pos 1 in
521− in
522− if pos1 < end then
643+ if pos1 >= end then
523−
644+ (# BadString BadStringEnd, pos1, row + 1, col #)
524− let
525− !word = P.unsafeIndex pos1
526− !newPos = plusPtr pos1 (P.getCharWidth pos1 end word)
527− in
528− pStringHelp newPos end row (col + 2)
529−
530 else
645 else
531− (# BadStringEnd, pos1, row + 1, col #)
646+ case P.unsafeIndex pos1 of
647+ 0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
648+ 0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
649+ 0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
650+ 0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
651+ 0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
652+ 0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
653+ 0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
654+ 0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
655+ 0x75 {-u-} ->
656+ let !pos6 = plusPtr pos 6 in
657+ if pos6 <= end
658+ && isHex (P.unsafeIndex (plusPtr pos 2))
659+ && isHex (P.unsafeIndex (plusPtr pos 3))
660+ && isHex (P.unsafeIndex (plusPtr pos 4))
661+ && isHex (P.unsafeIndex (plusPtr pos 5))
662+ then
663+ pStringHelp pos6 end row (col + 6)
664+ else
665+ (# BadString BadStringEscapeHex, pos, row, col #)
666+
667+ _ ->
668+ (# BadString BadStringEscapeChar, pos, row, col #)
532
669
533 word ->
670 word ->
671+ if word < 0x20 then
672+ (# BadString BadStringControlChar, pos, row, col #)
673+ else
534− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
674+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
535− pStringHelp newPos end row (col + 1)
675+ pStringHelp newPos end row (col + 1)
676+
677+
678+isHex :: Word8 -> Bool
679+isHex word =
680+ 0x30 {-0-} <= word && word <= 0x39 {-9-}
681+ || 0x61 {-a-} <= word && word <= 0x66 {-f-}
682+ || 0x41 {-A-} <= word && word <= 0x46 {-F-}
536
683
537
684
538
685
@@ -541,7 +688,7 @@ pStringHelp pos end row col =
541
688
542spaces :: Parser ()
689spaces :: Parser ()
543spaces =
690spaces =
544− P.Parser $ \state@(P.State pos end indent row col) cok eok _ _ ->
691+ P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->
545 let
692 let
546 (# newPos, newRow, newCol #) =
693 (# newPos, newRow, newCol #) =
547 eatSpaces pos end row col
694 eatSpaces pos end row col
@@ -551,7 +698,7 @@ spaces =
551 else
698 else
552 let
699 let
553 !newState =
700 !newState =
554− P.State newPos end indent newRow newCol
701+ P.State src newPos end indent newRow newCol
555 in
702 in
556 cok () newState
703 cok () newState
557
704
@@ -577,27 +724,27 @@ eatSpaces pos end row col =
577
724
578pInt :: Parser AST
725pInt :: Parser AST
579pInt =
726pInt =
580− P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
727+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
581 if pos >= end then
728 if pos >= end then
582− eerr row col E.IntStart
729+ eerr row col IntStart
583
730
584 else
731 else
585 let !word = P.unsafeIndex pos in
732 let !word = P.unsafeIndex pos in
586 if not (isDecimalDigit word) then
733 if not (isDecimalDigit word) then
587− eerr row col E.IntStart
734+ eerr row col IntStart
588
735
589 else if word == 0x30 {-0-} then
736 else if word == 0x30 {-0-} then
590
737
591 let
738 let
592 !pos1 = plusPtr pos 1
739 !pos1 = plusPtr pos 1
593− !newState = P.State pos1 end indent row (col + 1)
740+ !newState = P.State src pos1 end indent row (col + 1)
594 in
741 in
595 if pos1 < end then
742 if pos1 < end then
596 let !word1 = P.unsafeIndex pos1 in
743 let !word1 = P.unsafeIndex pos1 in
597 if isDecimalDigit word1 then
744 if isDecimalDigit word1 then
598− cerr row (col + 1) E.NoLeadingZeros
745+ cerr row (col + 1) NoLeadingZeros
599 else if word1 == 0x2E {-.-} then
746 else if word1 == 0x2E {-.-} then
600− cerr row (col + 1) E.NoFloats
747+ cerr row (col + 1) NoFloats
601 else
748 else
602 cok (Int 0) newState
749 cok (Int 0) newState
603 else
750 else
@@ -614,12 +761,12 @@ pInt =
614 GoodInt ->
761 GoodInt ->
615 let
762 let
616 !newState =
763 !newState =
617− P.State newPos end indent row (col + len)
764+ P.State src newPos end indent row (col + len)
618 in
765 in
619 cok (Int n) newState
766 cok (Int n) newState
620
767
621 BadIntEnd ->
768 BadIntEnd ->
622− cerr row (col + len) E.NoFloats
769+ cerr row (col + len) NoFloats
623
770
624
771
625data IntStatus = GoodInt | BadIntEnd
772data IntStatus = GoodInt | BadIntEnd