git.iko.soy/elk
on master help sign in
Collapse JSON decoding into one file and use new parser
7d81bcbEvan Czaplicki
compiler/src/Json/Decode.hs+544−205
compare with master
unifiedsplit
@@ -1,278 +1,537 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, UnboxedTuples #-}
3module Json.Decode
3module Json.Decode
4− ( parse
4+ ( fromByteString
5− -- re-export from Json.Decode.Internals
5+ , fromFile
6− , Json.Decoder
6+ , Decoder
7− , Json.string, Json.text, Json.name, Json.bool, Json.int
7+ , string
8− , Json.list, Json.dict, Json.pairs, Json.maybe
8+ , bool
9− , Json.field, Json.at
9+ , int
10− , Json.pair
10+ , list, pair
11+ , dict, pairs, field
12+ , oneOf
13+ , failure
11− , Json.map, Json.map2, Json.mapError
14+ , mapError
12− , Json.succeed, Json.fail
13− , Json.andThen, Json.oneOf
14 )
15 )
15 where
16 where
16
17
17
18
18−import Prelude hiding (length)
19−import qualified Data.ByteString.Char8 as Char8
20−import qualified Data.ByteString.Internal as B
19+import qualified Data.ByteString as B
21−import qualified Data.Text as Text
20+import qualified Data.List as List
22−import qualified Data.Text.Encoding as Text
21+import qualified Data.Map as Map
23−import Foreign.ForeignPtr (ForeignPtr)
22+import qualified Data.Utf8 as Utf8
24−import GHC.Word (Word8(..))
23+import Data.Word (Word8, Word16)
24+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
25
25
26−import qualified Json.Decode.Error as DecodeError
26+import qualified Parse.Keyword as K
27−import qualified Json.Decode.Internals as Json
28import qualified Parse.Primitives as P
27import qualified Parse.Primitives as P
29−import qualified Parse.Primitives.Internals as I
30−import Parse.Primitives.Internals (Parser(..), State(..), noError)
31−import qualified Parse.Primitives.Keyword as Keyword
32−import qualified Parse.Primitives.Number as Number
33−import qualified Parse.Primitives.Symbol as Symbol
34−import qualified Reporting.Doc as D
35−import qualified Reporting.Error.Syntax as E
28+import qualified Reporting.Error.Json as E
36−import qualified Reporting.Region as R
37−import qualified Reporting.Render.Code as Code
38
29
39
30
40
31
41−-- PARSE
32+-- RUNNERS
42
33
43
34
44−parse :: String -> (e -> [D.Doc]) -> Json.Decoder e a -> B.ByteString -> Either D.Doc a
35+fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a
45−parse rootName userErrorToDocs (Json.Decoder run) bytestring =
36+fromByteString decoder src =
46− let
37+ fromAST decoder (P.fromByteString pFile src)
47− source =
48− Code.toSource (Text.replace "\t" " " (Text.decodeUtf8 bytestring))
49
38
50− toDoc err =
51− DecodeError.toDoc rootName source userErrorToDocs err
52− in
53− case P.run jsonFile bytestring of
54− Left err ->
55− Left (toDoc (DecodeError.BadJson err))
56
39
57− Right value ->
40+fromFile :: Decoder e a -> FilePath -> IO (Either (E.Error e) a)
58− case run value of
41+fromFile decoder path =
59− Left err ->
42+ fromAST decoder <$> P.fromFile pFile path
60− Left (toDoc (DecodeError.BadContent err))
61
43
62− Right answer ->
63− Right answer
64
44
45+fromAST :: Decoder e a -> P.Result E.Context E.ParseExpectation AST -> Either (E.Error e) a
46+fromAST (Decoder decode) parserResult =
47+ case parserResult of
48+ P.Ok ast _ ->
49+ decode ast Right (Left . E.DecodeProblem)
65
50
51+ P.Err row col ctx expectation ->
52+ Left (E.ParseProblem row col ctx expectation)
66
53
67−-- JSON
68
54
69
55
70−jsonFile :: Parser Json.Value
56+-- DECODERS
71−jsonFile =
72− do spaces
73− value <- jsonValue
74− spaces
75− P.endOfFile
76− return value
77
57
78
58
79−jsonValue :: Parser Json.Value
59+newtype Decoder e a =
80−jsonValue =
60+ Decoder (forall b. AST -> (a -> b) -> (E.Problem e -> b) -> b)
81− do start <- P.getPosition
82− I.oneOf
83− [ Json.String <$> string
84− , object start
85− , array start
86− , number
87− , Keyword.jsonTrue >> return Json.TRUE
88− , Keyword.jsonFalse >> return Json.FALSE
89− , Keyword.jsonNull >> return Json.NULL
90− ]
91
61
92
62
93
63
94−-- OBJECT
64+-- INSTANCES
95
65
96
66
97−object :: R.Position -> Parser Json.Value
67+instance Functor (Decoder e) where
98−object start =
68+ {-# INLINE fmap #-}
99− do Symbol.leftCurly
69+ fmap func (Decoder decodeA) =
100− P.inContext start E.ExprRecord $
70+ Decoder $ \ast ok err ->
101− do spaces
71+ let
102− I.oneOf
72+ ok' a = ok (func a)
103− [ do entry <- field
73+ in
104− spaces
74+ decodeA ast ok' err
105− objectHelp [entry]
106− , do Symbol.rightCurly
107− return (Json.Object [])
108− ]
109
75
110
76
111−objectHelp :: [(Text.Text, Json.Value)] -> Parser Json.Value
77+instance Applicative (Decoder e) where
112−objectHelp revEntries =
78+ {-# INLINE pure #-}
113− I.oneOf
79+ pure = return
114− [
115− do Symbol.comma
116− spaces
117− entry <- field
118− spaces
119− objectHelp (entry:revEntries)
120− ,
121− do Symbol.rightCurly
122− return (Json.Object (reverse revEntries))
123− ]
124
80
81+ {-# INLINE (<*>) #-}
82+ (<*>) (Decoder decodeFunc) (Decoder decodeArg) =
83+ Decoder $ \ast ok err ->
84+ let
85+ okF func =
86+ let
87+ okA arg = ok (func arg)
88+ in
89+ decodeArg ast okA err
90+ in
91+ decodeFunc ast okF err
125
92
126−field :: Parser (Text.Text, Json.Value)
127−field =
128− do key <- string
129− spaces
130− Symbol.hasType
131− spaces
132− value <- jsonValue
133− return (key, value)
134
93
94+instance Monad (Decoder e) where
95+ {-# INLINE return #-}
96+ return a =
97+ Decoder $ \_ ok _ ->
98+ ok a
135
99
100+ {-# INLINE (>>=) #-}
101+ (>>=) (Decoder decodeA) callback =
102+ Decoder $ \ast ok err ->
103+ let
104+ ok' a =
105+ case callback a of
106+ Decoder decodeB -> decodeB ast ok err
107+ in
108+ decodeA ast ok' err
136
109
137−-- ARRAY
138
110
139
111
140−array :: R.Position -> Parser Json.Value
112+-- STRINGS
141−array start =
142− do Symbol.leftSquare
143− P.inContext start E.ExprList $
144− do spaces
145− I.oneOf
146− [ do entry <- jsonValue
147− spaces
148− arrayHelp 1 [entry]
149− , do Symbol.rightSquare
150− return (Json.Array [])
151− ]
152
113
153
114
154−arrayHelp :: Int -> [Json.Value] -> Parser Json.Value
115+string :: Decoder e Utf8.String
155−arrayHelp !length revEntries =
116+string =
156− I.oneOf
117+ Decoder $ \ast ok err ->
157− [
118+ case ast of
158− do Symbol.comma
119+ String bits ->
159− spaces
120+ ok bits
160− entry <- jsonValue
121+
161− spaces
122+ _ ->
162− arrayHelp (length + 1) (entry:revEntries)
123+ err (E.Expecting E.TString)
163− ,
124+
164− do Symbol.rightSquare
125+
165− return $ Json.Array $ reverse revEntries
126+
166− ]
127+-- BOOL
128+
129+
130+bool :: Decoder e Bool
131+bool =
132+ Decoder $ \ast ok err ->
133+ case ast of
134+ TRUE ->
135+ ok True
136+
137+ FALSE ->
138+ ok False
139+
140+ _ ->
141+ err (E.Expecting E.TBool)
142+
143+
144+
145+-- INT
146+
147+
148+int :: Decoder e Int
149+int =
150+ Decoder $ \ast ok err ->
151+ case ast of
152+ Int n ->
153+ ok n
154+
155+ _ ->
156+ err (E.Expecting E.TInt)
167
157
168
158
169
159
170−-- NUMBER
160+-- ARRAYS
171
161
172
162
173−number :: Parser Json.Value
163+list :: Decoder e a -> Decoder e [a]
174−number =
164+list decoder =
175− Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
165+ Decoder $ \ast ok err ->
176− if offset < terminal then
166+ case ast of
167+ Array asts ->
168+ listHelp decoder ok err 0 asts []
169+
170+ _ ->
171+ err (E.Expecting E.TArray)
172+
177
173
174+listHelp :: Decoder e a -> ([a] -> b) -> (E.Problem e -> b) -> Int -> [AST] -> [a] -> b
175+listHelp decoder@(Decoder decodeA) ok err !i asts revs =
176+ case asts of
177+ [] ->
178+ ok (reverse revs)
179+
180+ ast:asts ->
178 let
181 let
179− !word = I.unsafeIndex fp offset
182+ ok' a = listHelp decoder ok err (i+1) asts (a:revs)
180− !offset1 = offset + 1
183+ err' e = err (E.Index i e)
181 in
184 in
182− if word <= 0x39 {- 9 -} && word >= 0x31 {- 1 -} then
185+ decodeA ast ok' err'
183− case Number.chompInt fp offset1 terminal (fromIntegral (word - 0x30 {- 0 -})) of
186+
184− Number.Err newOffset problem ->
185− cerr (E.ParseError row (col + (newOffset - offset)) problem)
186
187
187− Number.OkInt newOffset n ->
188+pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)
189+pair (Decoder decodeA) (Decoder decodeB) =
190+ Decoder $ \ast ok err ->
191+ case ast of
192+ Array vs ->
193+ case vs of
194+ [astA,astB] ->
188 let
195 let
189− !newState = State fp newOffset terminal indent row (col + (newOffset - offset)) ctx
196+ err0 e = err (E.Index 0 e)
197+ ok0 a =
198+ let
199+ err1 e = err (E.Index 1 e)
200+ ok1 b = ok (a,b)
201+ in
202+ decodeB astB ok1 err1
190 in
203 in
191− cok (Json.Integer n) newState noError
204+ decodeA astA ok0 err0
205+
206+ _ ->
207+ err (E.Expecting (E.TArrayPair (length vs)))
208+
209+ _ ->
210+ err (E.Expecting E.TArray)
211+
212+
213+
214+-- OBJECT
215+
216+
217+dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)
218+dict decoder =
219+ Map.fromList <$> pairs decoder
220+
192
221
193− Number.OkFloat newOffset ->
222+pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]
223+pairs decoder =
224+ Decoder $ \ast ok err ->
225+ case ast of
226+ Object kvs ->
227+ pairsHelp decoder ok err kvs []
228+
229+ _ ->
230+ err (E.Expecting E.TObject)
231+
232+
233+pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b
234+pairsHelp decoder@(Decoder decodeA) ok err kvs revs =
235+ case kvs of
236+ [] ->
237+ ok (reverse revs)
238+
239+ (key, ast) : kvs ->
240+ let
241+ ok' a = pairsHelp decoder ok err kvs ((key,a):revs)
242+ err' e = err (E.Field key e)
243+ in
244+ decodeA ast ok' err'
245+
246+
247+field :: Utf8.String -> Decoder e a -> Decoder e a
248+field key (Decoder decodeA) =
249+ Decoder $ \ast ok err ->
250+ case ast of
251+ Object kvs ->
252+ case List.lookup key kvs of
253+ Just v ->
194 let
254 let
195− !length = newOffset - offset
255+ err' e = err (E.Field key e)
196− !scientific = read $ Char8.unpack $ B.PS fp offset length
197− !newState = State fp newOffset terminal indent row (col + length) ctx
198 in
256 in
199− cok (Json.Float scientific) newState noError
257+ decodeA v ok err'
200
258
201− else if word == 0x30 {- 0 -} then
259+ Nothing ->
202− cok (Json.Integer 0) (State fp offset1 terminal indent row (col + 1) ctx) noError
260+ err (E.Expecting (E.TObjectWith key))
261+
262+ _ ->
263+ err (E.Expecting E.TObject)
264+
265+
266+
267+-- ONE OF
268+
269+
270+oneOf :: [Decoder e a] -> Decoder e a
271+oneOf decoders =
272+ Decoder $ \ast ok err ->
273+ case decoders of
274+ Decoder decodeA : decoders ->
275+ let
276+ err' e =
277+ oneOfHelp ast ok err decoders e []
278+ in
279+ decodeA ast ok err'
280+
281+ [] ->
282+ error "Ran into (Json.Decode.oneOf [])"
283+
284+
285+oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b
286+oneOfHelp ast ok err decoders e es =
287+ case decoders of
288+ Decoder decodeA : decoders ->
289+ let
290+ err' e' =
291+ oneOfHelp ast ok err decoders e' (e:es)
292+ in
293+ decodeA ast ok err'
294+
295+ [] ->
296+ err (oneOfError [] e es)
297+
298+
299+oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e
300+oneOfError errors err es =
301+ case es of
302+ [] ->
303+ E.OneOf err errors
304+
305+ e:es ->
306+ oneOfError (err:errors) e es
307+
308+
309+
310+-- FAILURE
311+
312+
313+failure :: e -> Decoder e a
314+failure e =
315+ Decoder $ \_ _ err ->
316+ err (E.Failure e)
317+
318+
319+
320+-- ERRORS
203
321
204− else
205− eerr noError
206
322
323+mapError :: (e -> e') -> Decoder e a -> Decoder e' a
324+mapError func (Decoder decodeA) =
325+ Decoder $ \ast ok err ->
326+ let
327+ err' e = err (mapErrorHelp func e)
328+ in
329+ decodeA ast ok err'
330+
331+
332+mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'
333+mapErrorHelp func err =
334+ case err of
335+ E.Field k e -> E.Field k (mapErrorHelp func e)
336+ E.Index i e -> E.Index i (mapErrorHelp func e)
337+ E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)
338+ E.Failure e -> E.Failure (func e)
339+ E.Expecting e -> E.Expecting e
340+
341+
342+
343+-- AST
344+
345+
346+data AST
347+ = Array [AST]
348+ | Object [(Utf8.String, AST)]
349+ | String Utf8.String
350+ | Int Int
351+ | TRUE
352+ | FALSE
353+ | NULL
354+
355+
356+
357+-- PARSE
358+
359+
360+type Parser a =
361+ P.Parser E.Context E.ParseExpectation a
362+
363+
364+pFile :: Parser AST
365+pFile =
366+ do spaces
367+ value <- pValue
368+ spaces
369+ endOfFile
370+ return value
371+
372+
373+pValue :: Parser AST
374+pValue =
375+ P.oneOf E.Value
376+ [ fmap String pString
377+ , pObject
378+ , pArray
379+ , pInt
380+ , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE
381+ , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE
382+ , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL
383+ ]
384+
385+
386+endOfFile :: Parser ()
387+endOfFile =
388+ P.Parser $ \state@(P.State pos end _ row col ctx) _ eok _ eerr ->
389+ if pos < end then
390+ eerr row col ctx E.EndOfFile
207 else
391 else
208− eerr noError
392+ eok () state
209
393
210
394
211
395
396+-- OBJECT
397+
398+
399+pObject :: Parser AST
400+pObject =
401+ do P.word1 0x7B {- { -} E.ObjectStart
402+ spaces
403+ P.oneOf E.ObjectMore
404+ [ do entry <- pField
405+ spaces
406+ pObjectHelp [entry]
407+ , do P.word1 0x7D {-}-} E.ObjectEnd
408+ return (Object [])
409+ ]
410+
411+
412+pObjectHelp :: [(Utf8.String, AST)] -> Parser AST
413+pObjectHelp revEntries =
414+ P.oneOf E.ObjectMore
415+ [
416+ do P.word1 0x2C {-,-} E.ObjectMore
417+ spaces
418+ entry <- pField
419+ spaces
420+ pObjectHelp (entry:revEntries)
421+ ,
422+ do P.word1 0x7D {-}-} E.ObjectEnd
423+ return (Object (reverse revEntries))
424+ ]
425+
426+
427+pField :: Parser (Utf8.String, AST)
428+pField =
429+ do key <- pString
430+ spaces
431+ P.word1 0x3A {-:-} E.Colon
432+ spaces
433+ value <- pValue
434+ return (key, value)
435+
436+
437+
438+-- ARRAY
439+
440+
441+pArray :: Parser AST
442+pArray =
443+ do P.word1 0x5B {-[-} E.ArrayStart
444+ spaces
445+ P.oneOf E.ArrayMore
446+ [ do entry <- pValue
447+ spaces
448+ pArrayHelp 1 [entry]
449+ , do P.word1 0x5D {-]-} E.ArrayEnd
450+ return (Array [])
451+ ]
452+
453+
454+pArrayHelp :: Int -> [AST] -> Parser AST
455+pArrayHelp !len revEntries =
456+ P.oneOf E.ArrayMore
457+ [
458+ do P.word1 0x2C {-,-} E.ArrayMore
459+ spaces
460+ entry <- pValue
461+ spaces
462+ pArrayHelp (len + 1) (entry:revEntries)
463+ ,
464+ do P.word1 0x5D {-]-} E.ArrayEnd
465+ return (Array (reverse revEntries))
466+ ]
467+
468+
212
469
213-- STRING
470-- STRING
214
471
215
472
216−string :: Parser Text.Text
473+pString :: Parser Utf8.String
217−string =
474+pString =
218− Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
475+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
219− if offset < terminal && I.unsafeIndex fp offset == 0x22 {- " -} then
476+ if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
220
477
221 let
478 let
222− !offset1 = offset + 1
479+ !pos1 = plusPtr pos 1
223− in
224− case stringHelp fp offset1 terminal row (col + 1) of
225− Err err ->
226− cerr err
227
480
228− Ok newOffset newRow newCol ->
481+ (# status, newPos, newRow, newCol #) =
482+ pStringHelp pos1 end row (col + 1)
483+ in
484+ case status of
485+ GoodString ->
229 let
486 let
230− !newState = State fp newOffset terminal indent newRow newCol ctx
487+ !newState = P.State newPos end indent newRow newCol ctx
231− !content = Text.decodeUtf8 (B.PS fp offset1 (newOffset - offset1 - 1))
488+ !content = Utf8.fromPtr pos1 (plusPtr newPos (-1))
232 in
489 in
233− cok content newState noError
490+ cok content newState
491+
492+ BadStringEnd ->
493+ cerr newRow newCol ctx E.StringEnd
234
494
235 else
495 else
236− eerr noError
496+ eerr row col ctx E.StringStart
237
497
238
498
239−data StringResult
499+data StringStatus
240− = Err E.ParseError
500+ = GoodString
241− | Ok !Int !Int !Int
501+ | BadStringEnd
242
502
243
503
244−stringHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> StringResult
504+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
245−stringHelp fp offset terminal row col =
505+pStringHelp pos end row col =
246− if offset >= terminal then
506+ if pos >= end then
247− Err (E.ParseError row col E.EndOfFile_String)
507+ (# BadStringEnd, pos, row, col #)
248
508
249 else
509 else
250− case I.unsafeIndex fp offset of
510+ case P.unsafeIndex pos of
251− 0x22 {- " -} ->
511+ 0x22 {-"-} ->
252− Ok (offset + 1) row (col + 1)
512+ (# GoodString, plusPtr pos 1, row, col + 1 #)
253
513
254− 0x0A {- \n -} ->
514+ 0x0A {-\n-} ->
255− Err (E.ParseError row col E.NewLineInString)
515+ (# BadStringEnd, pos, row, col #)
256
516
257− 0x5C {- \ -} ->
517+ 0x5C {-\-} ->
258 let
518 let
259− !offset1 = offset + 1
519+ !pos1 = plusPtr pos 1
260 in
520 in
261− if offset1 < terminal then
521+ if pos1 < end then
262
522
263 let
523 let
264− !word = I.unsafeIndex fp offset1
524+ !word = P.unsafeIndex pos1
265− !newOffset = offset1 + I.getCharWidth fp offset1 terminal word
525+ !newPos = plusPtr pos1 (P.getCharWidth pos1 end word)
266 in
526 in
267− stringHelp fp newOffset terminal row (col + 2)
527+ pStringHelp newPos end row (col + 2)
268
528
269 else
529 else
270− Err (E.ParseError (row + 1) col E.EndOfFile_String)
530+ (# BadStringEnd, pos1, row + 1, col #)
271
531
272 word ->
532 word ->
273− let !newOffset = offset + I.getCharWidth fp offset terminal word in
533+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
274− stringHelp fp newOffset terminal row (col + 1)
534+ pStringHelp newPos end row (col + 1)
275−
276
535
277
536
278
537
@@ -281,27 +540,107 @@ stringHelp fp offset terminal row col =
281
540
282spaces :: Parser ()
541spaces :: Parser ()
283spaces =
542spaces =
284− Parser $ \(State fp offset terminal indent row col ctx) cok _ _ _ ->
543+ P.Parser $ \state@(P.State pos end indent row col ctx) cok eok _ _ ->
285 let
544 let
286− (# newOffset, newRow, newCol #) =
545+ (# newPos, newRow, newCol #) =
287− eatSpaces fp offset terminal row col
546+ eatSpaces pos end row col
288−
289− !newState =
290− State fp newOffset terminal indent newRow newCol ctx
291 in
547 in
548+ if pos == newPos then
549+ eok () state
550+ else
551+ let
552+ !newState =
553+ P.State newPos end indent newRow newCol ctx
554+ in
292− cok () newState noError
555+ cok () newState
293
556
294
557
295−eatSpaces :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Int, Int, Int #)
558+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)
296−eatSpaces fp offset terminal row col =
559+eatSpaces pos end row col =
297− if offset >= terminal then
560+ if pos >= end then
298− (# offset, row, col #)
561+ (# pos, row, col #)
299
562
300 else
563 else
301− case I.unsafeIndex fp offset of
564+ case P.unsafeIndex pos of
302− 0x20 {- -} -> eatSpaces fp (offset + 1) terminal row (col + 1)
565+ 0x20 {- -} -> eatSpaces (plusPtr pos 1) end row (col + 1)
303− 0x09 {- \t -} -> eatSpaces fp (offset + 1) terminal row (col + 1)
566+ 0x09 {-\t-} -> eatSpaces (plusPtr pos 1) end row (col + 1)
304− 0x0A {- \n -} -> eatSpaces fp (offset + 1) terminal (row + 1) 1
567+ 0x0A {-\n-} -> eatSpaces (plusPtr pos 1) end (row + 1) 1
305− 0x0D {- \r -} -> eatSpaces fp (offset + 1) terminal row col
568+ 0x0D {-\r-} -> eatSpaces (plusPtr pos 1) end row col
306 _ ->
569 _ ->
307− (# offset, row, col #)
570+ (# pos, row, col #)
571+
572+
573+
574+-- INTS
575+
576+
577+pInt :: Parser AST
578+pInt =
579+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
580+ if pos >= end then
581+ eerr row col ctx E.IntStart
582+
583+ else
584+ let !word = P.unsafeIndex pos in
585+ if not (isDecimalDigit word) then
586+ eerr row col ctx E.IntStart
587+
588+ else if word == 0x30 {-0-} then
589+
590+ let
591+ !pos1 = plusPtr pos 1
592+ !newState = P.State pos1 end indent row (col + 1) ctx
593+ in
594+ if pos1 < end then
595+ let !word1 = P.unsafeIndex pos1 in
596+ if isDecimalDigit word1 then
597+ cerr row (col + 1) ctx E.NoLeadingZeros
598+ else if word1 == 0x2E {-.-} then
599+ cerr row (col + 1) ctx E.NoFloats
600+ else
601+ cok (Int 0) newState
602+ else
603+ cok (Int 0) newState
604+
605+ else
606+ let
607+ (# status, n, newPos #) =
608+ chompInt (plusPtr pos 1) end (fromIntegral (word - 0x30 {-0-}))
609+
610+ !len = fromIntegral (minusPtr newPos pos)
611+ in
612+ case status of
613+ GoodInt ->
614+ let
615+ !newState =
616+ P.State newPos end indent row (col + len) ctx
617+ in
618+ cok (Int n) newState
619+
620+ BadIntEnd ->
621+ cerr row (col + len) ctx E.NoFloats
622+
623+
624+data IntStatus = GoodInt | BadIntEnd
625+
626+
627+chompInt :: Ptr Word8 -> Ptr Word8 -> Int -> (# IntStatus, Int, Ptr Word8 #)
628+chompInt pos end n =
629+ if pos < end then
630+ let !word = P.unsafeIndex pos in
631+ if isDecimalDigit word then
632+ let !m = 10 * n + fromIntegral (word - 0x30 {-0-}) in
633+ chompInt (plusPtr pos 1) end m
634+ else if word == 0x2E {-.-} || word == 0x65 {-e-} || word == 0x45 {-E-} then
635+ (# BadIntEnd, n, pos #)
636+ else
637+ (# GoodInt, n, pos #)
638+
639+ else
640+ (# GoodInt, n, pos #)
641+
642+
643+{-# INLINE isDecimalDigit #-}
644+isDecimalDigit :: Word8 -> Bool
645+isDecimalDigit word =
646+ word <= 0x39 {-9-} && word >= 0x30 {-0-}
compiler/src/Json/Decode/Internals.hsdeleted−367
@@ -1,367 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Json.Decode.Internals
4− ( Value(..)
5− , Decoder(..)
6− , Error(..)
7− , Type(..)
8− , string, text, name, bool, int
9− , list, dict, pairs
10− , maybe
11− , field, at
12− , pair
13− , map, map2, mapError
14− , succeed, fail
15− , andThen, oneOf
16− )
17− where
18−
19−
20−import Data.Text (Text)
21−import Prelude hiding (fail, map, maybe)
22−
23−import qualified Data.List as List
24−import qualified Data.Map.Strict as Map
25−import qualified Data.Name as Name
26−import qualified Data.Scientific as Sci
27−import qualified Data.Text as Text
28−import qualified Json.Encode as E
29−
30−
31−
32−-- VALUE
33−
34−
35−data Value
36− = Array [Value]
37− | Object [(Text, Value)]
38− | String Text
39− | Integer Int
40− | Float Sci.Scientific
41− | TRUE
42− | FALSE
43− | NULL
44−
45−
46−
47−-- DECODERS
48−
49−
50−-- TODO switch to CPS if possible
51−--
52−newtype Decoder e a =
53− Decoder {
54− _run :: Value -> Either (Error e) a
55− }
56−
57−
58−data Error e
59− = Field Text (Error e)
60− | Index Int (Error e)
61− | OneOf [Error e]
62− | Failure E.Value e
63− | Expecting E.Value Type
64−
65−
66−data Type
67− = TObject
68− | TArray
69− | TString
70− | TBool
71− | TInt
72− | TObjectWith Text
73− | TArrayPair Int
74−
75−
76−
77−-- PRIMITIVES
78−
79−
80−string :: Decoder e String
81−string =
82− Text.unpack <$> text
83−
84−
85−text :: Decoder e Text
86−text =
87− Decoder $ \value ->
88− case value of
89− String txt ->
90− Right txt
91−
92− _ ->
93− Left (expecting value TString)
94−
95−
96−name :: Decoder e Name.Name
97−name =
98− Name.fromString <$> string
99−
100−
101−bool :: Decoder e Bool
102−bool =
103− Decoder $ \value ->
104− case value of
105− TRUE ->
106− Right True
107−
108− FALSE ->
109− Right False
110−
111− _ ->
112− Left (expecting value TBool)
113−
114−
115−int :: Decoder e Int
116−int =
117− Decoder $ \value ->
118− case value of
119− Integer integer ->
120− Right integer
121−
122− _ ->
123− Left (expecting value TInt)
124−
125−
126−
127−-- DATA STRUCTURES
128−
129−
130−list :: Decoder e a -> Decoder e [a]
131−list (Decoder run) =
132− Decoder $ \value ->
133− case value of
134− Array vs ->
135− let
136− runHelp i v =
137− mapLeft (Index i) (run v)
138− in
139− sequenceA (zipWith runHelp [0..] vs)
140−
141− _ ->
142− Left (expecting value TArray)
143−
144−
145−dict :: Decoder e a -> Decoder e (Map.Map Text a)
146−dict (Decoder run) =
147− Decoder $ \value ->
148− case value of
149− Object kvs ->
150− let
151− runHelp k v =
152− mapLeft (Field k) (run v)
153− in
154− Map.traverseWithKey runHelp (Map.fromList kvs)
155−
156− _ ->
157− Left (expecting value TObject)
158−
159−
160−pairs :: Decoder e a -> Decoder e [(Text, a)]
161−pairs (Decoder run) =
162− Decoder $ \value ->
163− case value of
164− Object kvs ->
165− let
166− runHelp (k,v) =
167− case run v of
168− Right a -> Right (k, a)
169− Left e -> Left (Field k e)
170− in
171− traverse runHelp kvs
172−
173− _ ->
174− Left (expecting value TObject)
175−
176−
177−maybe :: Decoder e a -> Decoder e (Maybe a)
178−maybe (Decoder run) =
179− Decoder $ \value ->
180− case run value of
181− Right a ->
182− Right (Just a)
183−
184− Left _ ->
185− Right Nothing
186−
187−
188−
189−-- OBJECT PRIMITIVES
190−
191−
192−field :: Text -> Decoder e a -> Decoder e a
193−field k (Decoder run) =
194− Decoder $ \value ->
195− case value of
196− Object kvs ->
197− case List.lookup k kvs of
198− Just v ->
199− mapLeft (Field k) (run v)
200−
201− Nothing ->
202− Left (expecting value (TObjectWith k))
203−
204− _ ->
205− Left (expecting value TObject)
206−
207−
208−at :: [Text] -> Decoder e a -> Decoder e a
209−at names decoder =
210− foldr field decoder names
211−
212−
213−
214−-- ARRAY PRIMITIVES
215−
216−
217−pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)
218−pair (Decoder runA) (Decoder runB) =
219− Decoder $ \value ->
220− case value of
221− Array vs ->
222− case vs of
223− [a,b] ->
224− (,)
225− <$> mapLeft (Index 0) (runA a)
226− <*> mapLeft (Index 1) (runB b)
227−
228− _ ->
229− Left (expecting value (TArrayPair (length vs)))
230−
231− _ ->
232− Left (expecting value TArray)
233−
234−
235−
236−-- ERRORS
237−
238−
239−mapError :: (e -> e') -> Decoder e a -> Decoder e' a
240−mapError func (Decoder run) =
241− Decoder $ \value ->
242− mapLeft (mapErrorHelp func) (run value)
243−
244−
245−mapErrorHelp :: (e -> e') -> Error e -> Error e'
246−mapErrorHelp func err =
247− case err of
248− Field f subErr -> Field f (mapErrorHelp func subErr)
249− Index i subErr -> Index i (mapErrorHelp func subErr)
250− OneOf errors -> OneOf (fmap (mapErrorHelp func) errors)
251− Failure v e -> Failure v (func e)
252− Expecting v e -> Expecting v e
253−
254−
255−mapLeft :: (e -> e') -> Either e a -> Either e' a
256−mapLeft func eith =
257− case eith of
258− Right a -> Right a
259− Left e -> Left (func e)
260−
261−
262−expecting :: Value -> Type -> Error e
263−expecting value tipe =
264− Expecting (toEncodeValue value) tipe
265−
266−
267−toEncodeValue :: Value -> E.Value
268−toEncodeValue value =
269− case value of
270− Array vs -> E.array (fmap toEncodeValue vs)
271− Object kvs -> E.object (fmap (fmap toEncodeValue) kvs)
272− String txt -> E.text txt
273− Integer n -> E.int n
274− Float n -> E.number n
275− TRUE -> E.bool True
276− FALSE -> E.bool False
277− NULL -> E.null
278−
279−
280−
281−-- MAPPING
282−
283−
284−map :: (a -> value) -> Decoder e a -> Decoder e value
285−map func (Decoder run) =
286− Decoder $ \value ->
287− func <$> run value
288−
289−
290−map2 :: (a -> b -> value) -> Decoder e a -> Decoder e b -> Decoder e value
291−map2 func (Decoder runA) (Decoder runB) =
292− Decoder $ \value ->
293− func
294− <$> runA value
295− <*> runB value
296−
297−
298−apply :: Decoder e (a -> b) -> Decoder e a -> Decoder e b
299−apply (Decoder runFunc) (Decoder runArg) =
300− Decoder $ \value ->
301− runFunc value <*> runArg value
302−
303−
304−
305−-- FANCY PRIMITIVES
306−
307−
308−succeed :: a -> Decoder e a
309−succeed a =
310− Decoder $ \_ -> Right a
311−
312−
313−fail :: e -> Decoder e a
314−fail err =
315− Decoder $ \value ->
316− Left (Failure (toEncodeValue value) err)
317−
318−
319−andThen :: (a -> Decoder e b) -> Decoder e a -> Decoder e b
320−andThen callback (Decoder runA) =
321− Decoder $ \value ->
322− do a <- runA value
323− let (Decoder runB) = callback a
324− runB value
325−
326−
327−
328−-- ONE OF
329−
330−
331−oneOf :: [Decoder e a] -> Decoder e a
332−oneOf decoders =
333− Decoder (oneOfHelp decoders [])
334−
335−
336−oneOfHelp :: [Decoder e a] -> [Error e] -> Value -> Either (Error e) a
337−oneOfHelp decoders errors value =
338− case decoders of
339− [] ->
340− Left (OneOf (reverse errors))
341−
342− Decoder run : otherDecoders ->
343− case run value of
344− Right a ->
345− Right a
346−
347− Left err ->
348− oneOfHelp otherDecoders (err:errors) value
349−
350−
351−
352−-- INSTANCES
353−
354−
355−instance Functor (Decoder e) where
356− fmap = map
357−
358−
359−instance Applicative (Decoder e) where
360− pure = succeed
361− (<*>) = apply
362−
363−
364−instance Monad (Decoder e) where
365− return = succeed
366− (>>=) decoder callback =
367− andThen callback decoder