@@ -4,68 +4,108 @@ module Json.Decode
44 ( fromByteString
55 , Decoder
66 , string
7+ , customString
78 , bool
89 , int
9− , list, pair
10− , dict, pairs, field
10+ , list
11+ , nonEmptyList
12+ , pair
13+ --
14+ , KeyDecoder(..)
15+ , dict
16+ , pairs
17+ , field
18+ --
1119 , oneOf
1220 , failure
1321 , mapError
22+ --
23+ , Error(..)
24+ , Problem(..)
25+ , DecodeExpectation(..)
26+ , ParseError(..)
1427 )
1528 where
1629
1730
18−import qualified Data.ByteString as B
19−import qualified Data.List as List
31+import qualified Data.ByteString.Internal as B
2032import qualified Data.Map as Map
21−import qualified Data.Utf8 as Utf8
33+import qualified Data.NonEmptyList as NE
2234import Data.Word (Word8, Word16)
2335import Foreign.Ptr (Ptr, plusPtr, minusPtr)
36+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
2437
38+import qualified Json.String as Json
2539import qualified Parse.Keyword as K
2640import qualified Parse.Primitives as P
27−import qualified Reporting.Error.Json as E
41+import Parse.Primitives (Row, Col)
2842
2943
3044
3145-- RUNNERS
3246
3347
34−fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a
35−fromByteString decoder src =
36− fromAST decoder (P.fromByteString pFile src)
48+fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
49+fromByteString (Decoder decode) src =
50+ case P.fromByteString pFile BadEnd src of
51+ Right ast ->
52+ decode ast Right (Left . DecodeProblem)
3753
38−
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)
54+ Left problem ->
55+ Left (ParseProblem problem)
4756
4857
4958
5059-- DECODERS
5160
5261
53−newtype Decoder e a =
62+newtype Decoder x a =
5463 Decoder
5564 (
5665 forall b.
5766 AST
5867 -> (a -> b)
59− -> (E.Problem e -> b)
68+ -> (Problem x -> b)
6069 -> b
6170 )
6271
6372
6473
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+
65105-- INSTANCES
66106
67107
68−instance Functor (Decoder e) where
108+instance Functor (Decoder x) where
69109 {-# INLINE fmap #-}
70110 fmap func (Decoder decodeA) =
71111 Decoder $ \ast ok err ->
@@ -75,7 +115,7 @@ instance Functor (Decoder e) where
75115 decodeA ast ok' err
76116
77117
78−instance Applicative (Decoder e) where
118+instance Applicative (Decoder x) where
79119 {-# INLINE pure #-}
80120 pure = return
81121
@@ -92,7 +132,7 @@ instance Applicative (Decoder e) where
92132 decodeFunc ast okF err
93133
94134
95−instance Monad (Decoder e) where
135+instance Monad (Decoder x) where
96136 {-# INLINE return #-}
97137 return a =
98138 Decoder $ \_ ok _ ->
@@ -113,22 +153,35 @@ instance Monad (Decoder e) where
113153-- STRINGS
114154
115155
116−string :: Decoder e Utf8.String
156+string :: Decoder x Json.String
117157string =
118158 Decoder $ \ast ok err ->
119159 case ast of
120− String bits ->
121− ok bits
160+ String snippet ->
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)
122175
123176 _ ->
124− err (E.Expecting E.TString)
177+ err (Expecting TString)
125178
126179
127180
128181-- BOOL
129182
130183
131−bool :: Decoder e Bool
184+bool :: Decoder x Bool
132185bool =
133186 Decoder $ \ast ok err ->
134187 case ast of
@@ -139,14 +192,14 @@ bool =
139192 ok False
140193
141194 _ ->
142− err (E.Expecting E.TBool)
195+ err (Expecting TBool)
143196
144197
145198
146199-- INT
147200
148201
149−int :: Decoder e Int
202+int :: Decoder x Int
150203int =
151204 Decoder $ \ast ok err ->
152205 case ast of
@@ -154,14 +207,14 @@ int =
154207 ok n
155208
156209 _ ->
157− err (E.Expecting E.TInt)
210+ err (Expecting TInt)
158211
159212
160213
161−-- ARRAYS
214+-- LISTS
162215
163216
164−list :: Decoder e a -> Decoder e [a]
217+list :: Decoder x a -> Decoder x [a]
165218list decoder =
166219 Decoder $ \ast ok err ->
167220 case ast of
@@ -169,10 +222,10 @@ list decoder =
169222 listHelp decoder ok err 0 asts []
170223
171224 _ ->
172− err (E.Expecting E.TArray)
225+ err (Expecting TArray)
173226
174227
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
176229listHelp decoder@(Decoder decodeA) ok err !i asts revs =
177230 case asts of
178231 [] ->
@@ -180,13 +233,29 @@ listHelp decoder@(Decoder decodeA) ok err !i asts revs =
180233
181234 ast:asts ->
182235 let
183− ok' a = listHelp decoder ok err (i+1) asts (a:revs)
184− err' e = err (E.Index i e)
236+ ok' value = listHelp decoder ok err (i+1) asts (value:revs)
237+ err' prob = err (Index i prob)
185238 in
186239 decodeA ast ok' err'
187240
188241
189−pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)
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+
258+pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
190259pair (Decoder decodeA) (Decoder decodeB) =
191260 Decoder $ \ast ok err ->
192261 case ast of
@@ -194,10 +263,10 @@ pair (Decoder decodeA) (Decoder decodeB) =
194263 case vs of
195264 [astA,astB] ->
196265 let
197− err0 e = err (E.Index 0 e)
266+ err0 e = err (Index 0 e)
198267 ok0 a =
199268 let
200− err1 e = err (E.Index 1 e)
269+ err1 e = err (Index 1 e)
201270 ok1 b = ok (a,b)
202271 in
203272 decodeB astB ok1 err1
@@ -205,70 +274,98 @@ pair (Decoder decodeA) (Decoder decodeB) =
205274 decodeA astA ok0 err0
206275
207276 _ ->
208− err (E.Expecting (E.TArrayPair (length vs)))
277+ err (Expecting (TArrayPair (length vs)))
209278
210279 _ ->
211− err (E.Expecting E.TArray)
280+ err (Expecting TArray)
212281
213282
214283
215−-- OBJECT
284+-- OBJECTS
216285
217286
218−dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)
219−dict decoder =
220− Map.fromList <$> pairs decoder
287+data KeyDecoder x a =
288+ KeyDecoder (P.Parser x a) (Row -> Col -> x)
221289
222290
223−pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]
224−pairs decoder =
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+
296+pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
297+pairs keyDecoder valueDecoder =
225298 Decoder $ \ast ok err ->
226299 case ast of
227300 Object kvs ->
228− pairsHelp decoder ok err kvs []
301+ pairsHelp keyDecoder valueDecoder ok err kvs []
229302
230303 _ ->
231− err (E.Expecting E.TObject)
304+ err (Expecting TObject)
232305
233306
234−pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b
235−pairsHelp decoder@(Decoder decodeA) ok err kvs revs =
307+pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
308+pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =
236309 case kvs of
237310 [] ->
238311 ok (reverse revs)
239312
240− (key, ast) : kvs ->
241− let
242− ok' a = pairsHelp decoder ok err kvs ((key,a):revs)
243− err' e = err (E.Field key e)
244− in
245− decodeA ast ok' err'
313+ (snippet, ast) : kvs ->
314+ case P.fromSnippet keyParser toBadEnd snippet of
315+ Left x ->
316+ err (Failure x)
317+
318+ Right key ->
319+ let
320+ ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)
321+ err' prob =
322+ let (P.Snippet fptr off len _ _) = snippet in
323+ err (Field (B.PS fptr off len) prob)
324+ in
325+ decodeA ast ok' err'
326+
246327
247328
248−field :: Utf8.String -> Decoder e a -> Decoder e a
329+-- FIELDS
330+
331+
332+field :: B.ByteString -> Decoder x a -> Decoder x a
249333field key (Decoder decodeA) =
250334 Decoder $ \ast ok err ->
251335 case ast of
252336 Object kvs ->
253− case List.lookup key kvs of
254− Just v ->
337+ case findField key kvs of
338+ Just value ->
255339 let
256− err' e = err (E.Field key e)
340+ err' prob =
341+ err (Field key prob)
257342 in
258− decodeA v ok err'
343+ decodeA value ok err'
259344
260345 Nothing ->
261− err (E.Expecting (E.TObjectWith key))
346+ err (Expecting (TObjectWith key))
262347
263348 _ ->
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
265362
266363
267364
268365-- ONE OF
269366
270367
271−oneOf :: [Decoder e a] -> Decoder e a
368+oneOf :: [Decoder x a] -> Decoder x a
272369oneOf decoders =
273370 Decoder $ \ast ok err ->
274371 case decoders of
@@ -283,61 +380,61 @@ oneOf decoders =
283380 error "Ran into (Json.Decode.oneOf [])"
284381
285382
286−oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b
287−oneOfHelp ast ok err decoders e es =
383+oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b
384+oneOfHelp ast ok err decoders p ps =
288385 case decoders of
289386 Decoder decodeA : decoders ->
290387 let
291− err' e' =
292− oneOfHelp ast ok err decoders e' (e:es)
388+ err' p' =
389+ oneOfHelp ast ok err decoders p' (p:ps)
293390 in
294391 decodeA ast ok err'
295392
296393 [] ->
297− err (oneOfError [] e es)
394+ err (oneOfError [] p ps)
298395
299396
300−oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e
301−oneOfError errors err es =
302− case es of
397+oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x
398+oneOfError problems prob ps =
399+ case ps of
303400 [] ->
304− E.OneOf err errors
401+ OneOf prob problems
305402
306− e:es ->
307− oneOfError (err:errors) e es
403+ p:ps ->
404+ oneOfError (prob:problems) p ps
308405
309406
310407
311408-- FAILURE
312409
313410
314−failure :: e -> Decoder e a
315−failure e =
411+failure :: x -> Decoder x a
412+failure x =
316413 Decoder $ \_ _ err ->
317− err (E.Failure e)
414+ err (Failure x)
318415
319416
320417
321418-- ERRORS
322419
323420
324−mapError :: (e -> e') -> Decoder e a -> Decoder e' a
421+mapError :: (x -> y) -> Decoder x a -> Decoder y a
325422mapError func (Decoder decodeA) =
326423 Decoder $ \ast ok err ->
327424 let
328− err' e = err (mapErrorHelp func e)
425+ err' prob = err (mapErrorHelp func prob)
329426 in
330427 decodeA ast ok err'
331428
332429
333−mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'
334−mapErrorHelp func err =
335− case err of
336− E.Field k e -> E.Field k (mapErrorHelp func e)
337− E.Index i e -> E.Index i (mapErrorHelp func e)
338− E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)
339− E.Failure e -> E.Failure (func e)
340− E.Expecting e -> E.Expecting e
430+mapErrorHelp :: (x -> y) -> Problem x -> Problem y
431+mapErrorHelp func problem =
432+ case problem of
433+ Field k p -> Field k (mapErrorHelp func p)
434+ Index i p -> Index i (mapErrorHelp func p)
435+ OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
436+ Failure x -> Failure (func x)
437+ Expecting e -> Expecting e
341438
342439
343440
@@ -346,8 +443,8 @@ mapErrorHelp func err =
346443
347444data AST
348445 = Array [AST]
349− | Object [(Utf8.String, AST)]
350− | String Utf8.String
446+ | Object [(P.Snippet, AST)]
447+ | String P.Snippet
351448 | Int Int
352449 | TRUE
353450 | FALSE
@@ -359,7 +456,40 @@ data AST
359456
360457
361458type 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
363493
364494
365495pFile :: Parser AST
@@ -367,69 +497,59 @@ pFile =
367497 do spaces
368498 value <- pValue
369499 spaces
370− endOfFile
371500 return value
372501
373502
374503pValue :: Parser AST
375504pValue =
376− P.oneOf E.Value
377− [ fmap String pString
505+ P.oneOf Value
506+ [ String <$> pString
378507 , pObject
379508 , pArray
380509 , pInt
381− , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE
382− , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE
383− , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL
510+ , K.k4 0x74 0x72 0x75 0x65 Bool >> return TRUE
511+ , K.k5 0x66 0x61 0x6C 0x73 0x65 Bool >> return FALSE
512+ , K.k4 0x6E 0x75 0x6C 0x6C Null >> return NULL
384513 ]
385514
386515
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−
396516
397517-- OBJECT
398518
399519
400520pObject :: Parser AST
401521pObject =
402− do P.word1 0x7B {- { -} E.ObjectStart
522+ do P.word1 0x7B {- { -} ObjectStart
403523 spaces
404− P.oneOf E.ObjectMore
524+ P.oneOf ObjectMore
405525 [ do entry <- pField
406526 spaces
407527 pObjectHelp [entry]
408− , do P.word1 0x7D {-}-} E.ObjectEnd
528+ , do P.word1 0x7D {-}-} ObjectEnd
409529 return (Object [])
410530 ]
411531
412532
413−pObjectHelp :: [(Utf8.String, AST)] -> Parser AST
533+pObjectHelp :: [(P.Snippet, AST)] -> Parser AST
414534pObjectHelp revEntries =
415− P.oneOf E.ObjectMore
535+ P.oneOf ObjectMore
416536 [
417− do P.word1 0x2C {-,-} E.ObjectMore
537+ do P.word1 0x2C {-,-} ObjectMore
418538 spaces
419539 entry <- pField
420540 spaces
421541 pObjectHelp (entry:revEntries)
422542 ,
423− do P.word1 0x7D {-}-} E.ObjectEnd
543+ do P.word1 0x7D {-}-} ObjectEnd
424544 return (Object (reverse revEntries))
425545 ]
426546
427547
428−pField :: Parser (Utf8.String, AST)
548+pField :: Parser (P.Snippet, AST)
429549pField =
430550 do key <- pString
431551 spaces
432− P.word1 0x3A {-:-} E.Colon
552+ P.word1 0x3A {-:-} Colon
433553 spaces
434554 value <- pValue
435555 return (key, value)
@@ -441,28 +561,28 @@ pField =
441561
442562pArray :: Parser AST
443563pArray =
444− do P.word1 0x5B {-[-} E.ArrayStart
564+ do P.word1 0x5B {-[-} ArrayStart
445565 spaces
446− P.oneOf E.ArrayMore
566+ P.oneOf ArrayMore
447567 [ do entry <- pValue
448568 spaces
449569 pArrayHelp 1 [entry]
450− , do P.word1 0x5D {-]-} E.ArrayEnd
570+ , do P.word1 0x5D {-]-} ArrayEnd
451571 return (Array [])
452572 ]
453573
454574
455575pArrayHelp :: Int -> [AST] -> Parser AST
456576pArrayHelp !len revEntries =
457− P.oneOf E.ArrayMore
577+ P.oneOf ArrayMore
458578 [
459− do P.word1 0x2C {-,-} E.ArrayMore
579+ do P.word1 0x2C {-,-} ArrayMore
460580 spaces
461581 entry <- pValue
462582 spaces
463583 pArrayHelp (len + 1) (entry:revEntries)
464584 ,
465− do P.word1 0x5D {-]-} E.ArrayEnd
585+ do P.word1 0x5D {-]-} ArrayEnd
466586 return (Array (reverse revEntries))
467587 ]
468588
@@ -471,41 +591,44 @@ pArrayHelp !len revEntries =
471591-- STRING
472592
473593
474−pString :: Parser Utf8.String
594+pString :: Parser P.Snippet
475595pString =
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 ->
477597 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
478598
479599 let
480600 !pos1 = plusPtr pos 1
601+ !col1 = col + 1
481602
482603 (# status, newPos, newRow, newCol #) =
483− pStringHelp pos1 end row (col + 1)
604+ pStringHelp pos1 end row col1
484605 in
485606 case status of
486607 GoodString ->
487608 let
488− !newState = P.State newPos end indent newRow newCol
489− !content = Utf8.fromPtr pos1 (plusPtr newPos (-1))
609+ !off = minusPtr pos1 (unsafeForeignPtrToPtr src)
610+ !len = minusPtr newPos pos1 - 1
611+ !snp = P.Snippet src off len row col1
612+ !newState = P.State src newPos end indent newRow newCol
490613 in
491− cok content newState
614+ cok snp newState
492615
493− BadStringEnd ->
494− cerr newRow newCol E.StringEnd
616+ BadString problem ->
617+ cerr newRow newCol (StringProblem problem)
495618
496619 else
497− eerr row col E.StringStart
620+ eerr row col StringStart
498621
499622
500623data StringStatus
501624 = GoodString
502− | BadStringEnd
625+ | BadString StringProblem
503626
504627
505628pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
506629pStringHelp pos end row col =
507630 if pos >= end then
508− (# BadStringEnd, pos, row, col #)
631+ (# BadString BadStringEnd, pos, row, col #)
509632
510633 else
511634 case P.unsafeIndex pos of
@@ -513,26 +636,50 @@ pStringHelp pos end row col =
513636 (# GoodString, plusPtr pos 1, row, col + 1 #)
514637
515638 0x0A {-\n-} ->
516− (# BadStringEnd, pos, row, col #)
639+ (# BadString BadStringEnd, pos, row, col #)
517640
518641 0x5C {-\-} ->
519− let
520− !pos1 = plusPtr pos 1
521− in
522− if pos1 < end then
523−
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−
642+ let !pos1 = plusPtr pos 1 in
643+ if pos1 >= end then
644+ (# BadString BadStringEnd, pos1, row + 1, col #)
530645 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 #)
532669
533670 word ->
534− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
535− pStringHelp newPos end row (col + 1)
671+ if word < 0x20 then
672+ (# BadString BadStringControlChar, pos, row, col #)
673+ else
674+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
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-}
536683
537684
538685
@@ -541,7 +688,7 @@ pStringHelp pos end row col =
541688
542689spaces :: Parser ()
543690spaces =
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 _ _ ->
545692 let
546693 (# newPos, newRow, newCol #) =
547694 eatSpaces pos end row col
@@ -551,7 +698,7 @@ spaces =
551698 else
552699 let
553700 !newState =
554− P.State newPos end indent newRow newCol
701+ P.State src newPos end indent newRow newCol
555702 in
556703 cok () newState
557704
@@ -577,27 +724,27 @@ eatSpaces pos end row col =
577724
578725pInt :: Parser AST
579726pInt =
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 ->
581728 if pos >= end then
582− eerr row col E.IntStart
729+ eerr row col IntStart
583730
584731 else
585732 let !word = P.unsafeIndex pos in
586733 if not (isDecimalDigit word) then
587− eerr row col E.IntStart
734+ eerr row col IntStart
588735
589736 else if word == 0x30 {-0-} then
590737
591738 let
592739 !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)
594741 in
595742 if pos1 < end then
596743 let !word1 = P.unsafeIndex pos1 in
597744 if isDecimalDigit word1 then
598− cerr row (col + 1) E.NoLeadingZeros
745+ cerr row (col + 1) NoLeadingZeros
599746 else if word1 == 0x2E {-.-} then
600− cerr row (col + 1) E.NoFloats
747+ cerr row (col + 1) NoFloats
601748 else
602749 cok (Int 0) newState
603750 else
@@ -614,12 +761,12 @@ pInt =
614761 GoodInt ->
615762 let
616763 !newState =
617− P.State newPos end indent row (col + len)
764+ P.State src newPos end indent row (col + len)
618765 in
619766 cok (Int n) newState
620767
621768 BadIntEnd ->
622− cerr row (col + len) E.NoFloats
769+ cerr row (col + len) NoFloats
623770
624771
625772data IntStatus = GoodInt | BadIntEnd