git.iko.soy/elk
on f4401ac help sign in
elk/compiler/src/Json/Decode.hs
799 lines 17 kB history raw
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}
2{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, UnboxedTuples #-}
3module Json.Decode
4 ( fromByteString
5 , Decoder
6 , string
7 , customString
8 , bool
9 , int
10 , list
11 , nonEmptyList
12 , pair
13 --
14 , KeyDecoder(..)
15 , dict
16 , pairs
17 , field
18 --
19 , oneOf
20 , failure
21 , mapError
22 --
23 , Error(..)
24 , Problem(..)
25 , DecodeExpectation(..)
26 , ParseError(..)
27 , StringProblem(..)
28 )
29 where
32import qualified Data.ByteString.Internal as B
33import qualified Data.Map as Map
34import qualified Data.NonEmptyList as NE
35import Data.Word (Word8, Word16)
36import Foreign.Ptr (Ptr, plusPtr, minusPtr)
37import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
39import qualified Json.String as Json
40import qualified Parse.Keyword as K
41import qualified Parse.Primitives as P
42import Parse.Primitives (Row, Col)
43import qualified Reporting.Annotation as A
47-- RUNNERS
50fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
51fromByteString (Decoder decode) src =
52 case P.fromByteString pFile BadEnd src of
53 Right ast ->
54 decode ast Right (Left . DecodeProblem src)
56 Left problem ->
57 Left (ParseProblem src problem)
61-- DECODERS
64newtype Decoder x a =
65 Decoder
66 (
67 forall b.
68 AST
69 -> (a -> b)
70 -> (Problem x -> b)
71 -> b
72 )
76-- ERRORS
79data Error x
80 = DecodeProblem B.ByteString (Problem x)
81 | ParseProblem B.ByteString ParseError
85-- DECODE PROBLEMS
88data Problem x
89 = Field B.ByteString (Problem x)
90 | Index Int (Problem x)
91 | OneOf (Problem x) [Problem x]
92 | Failure A.Region x
93 | Expecting A.Region DecodeExpectation
96data DecodeExpectation
97 = TObject
98 | TArray
99 | TString
100 | TBool
101 | TInt
102 | TObjectWith B.ByteString
103 | TArrayPair Int
107-- INSTANCES
110instance Functor (Decoder x) where
111 {-# INLINE fmap #-}
112 fmap func (Decoder decodeA) =
113 Decoder $ \ast ok err ->
114 let
115 ok' a = ok (func a)
116 in
117 decodeA ast ok' err
120instance Applicative (Decoder x) where
121 {-# INLINE pure #-}
122 pure = return
124 {-# INLINE (<*>) #-}
125 (<*>) (Decoder decodeFunc) (Decoder decodeArg) =
126 Decoder $ \ast ok err ->
127 let
128 okF func =
129 let
130 okA arg = ok (func arg)
131 in
132 decodeArg ast okA err
133 in
134 decodeFunc ast okF err
137instance Monad (Decoder x) where
138 {-# INLINE return #-}
139 return a =
140 Decoder $ \_ ok _ ->
141 ok a
143 {-# INLINE (>>=) #-}
144 (>>=) (Decoder decodeA) callback =
145 Decoder $ \ast ok err ->
146 let
147 ok' a =
148 case callback a of
149 Decoder decodeB -> decodeB ast ok err
150 in
151 decodeA ast ok' err
155-- STRINGS
158string :: Decoder x Json.String
159string =
160 Decoder $ \(A.At region ast) ok err ->
161 case ast of
162 String snippet ->
163 ok (Json.fromSnippet snippet)
165 _ ->
166 err (Expecting region TString)
169customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
170customString parser toBadEnd =
171 Decoder $ \(A.At region ast) ok err ->
172 case ast of
173 String snippet ->
174 case P.fromSnippet parser toBadEnd snippet of
175 Right a -> ok a
176 Left x -> err (Failure region x)
178 _ ->
179 err (Expecting region TString)
183-- BOOL
186bool :: Decoder x Bool
187bool =
188 Decoder $ \(A.At region ast) ok err ->
189 case ast of
190 TRUE ->
191 ok True
193 FALSE ->
194 ok False
196 _ ->
197 err (Expecting region TBool)
201-- INT
204int :: Decoder x Int
205int =
206 Decoder $ \(A.At region ast) ok err ->
207 case ast of
208 Int n ->
209 ok n
211 _ ->
212 err (Expecting region TInt)
216-- LISTS
219list :: Decoder x a -> Decoder x [a]
220list decoder =
221 Decoder $ \(A.At region ast) ok err ->
222 case ast of
223 Array asts ->
224 listHelp decoder ok err 0 asts []
226 _ ->
227 err (Expecting region TArray)
230listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
231listHelp decoder@(Decoder decodeA) ok err !i asts revs =
232 case asts of
233 [] ->
234 ok (reverse revs)
236 ast:asts ->
237 let
238 ok' value = listHelp decoder ok err (i+1) asts (value:revs)
239 err' prob = err (Index i prob)
240 in
241 decodeA ast ok' err'
245-- NON-EMPTY LISTS
248nonEmptyList :: Decoder x a -> x -> Decoder x (NE.List a)
249nonEmptyList decoder x =
250 do values <- list decoder
251 case values of
252 v:vs -> return (NE.List v vs)
253 [] -> failure x
257-- PAIR
260pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
261pair (Decoder decodeA) (Decoder decodeB) =
262 Decoder $ \(A.At region ast) ok err ->
263 case ast of
264 Array vs ->
265 case vs of
266 [astA,astB] ->
267 let
268 err0 e = err (Index 0 e)
269 ok0 a =
270 let
271 err1 e = err (Index 1 e)
272 ok1 b = ok (a,b)
273 in
274 decodeB astB ok1 err1
275 in
276 decodeA astA ok0 err0
278 _ ->
279 err (Expecting region (TArrayPair (length vs)))
281 _ ->
282 err (Expecting region TArray)
286-- OBJECTS
289data KeyDecoder x a =
290 KeyDecoder (P.Parser x a) (Row -> Col -> x)
293dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)
294dict keyDecoder valueDecoder =
295 Map.fromList <$> pairs keyDecoder valueDecoder
298pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
299pairs keyDecoder valueDecoder =
300 Decoder $ \(A.At region ast) ok err ->
301 case ast of
302 Object kvs ->
303 pairsHelp keyDecoder valueDecoder ok err kvs []
305 _ ->
306 err (Expecting region TObject)
309pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
310pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =
311 case kvs of
312 [] ->
313 ok (reverse revs)
315 (snippet, ast) : kvs ->
316 case P.fromSnippet keyParser toBadEnd snippet of
317 Left x ->
318 err (Failure (snippetToRegion snippet) x)
320 Right key ->
321 let
322 ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)
323 err' prob =
324 let (P.Snippet fptr off len _ _) = snippet in
325 err (Field (B.PS fptr off len) prob)
326 in
327 decodeA ast ok' err'
330snippetToRegion :: P.Snippet -> A.Region
331snippetToRegion (P.Snippet _ _ len row col) =
332 A.Region (A.Position row col) (A.Position row (col + fromIntegral len))
336-- FIELDS
339field :: B.ByteString -> Decoder x a -> Decoder x a
340field key (Decoder decodeA) =
341 Decoder $ \(A.At region ast) ok err ->
342 case ast of
343 Object kvs ->
344 case findField key kvs of
345 Just value ->
346 let
347 err' prob =
348 err (Field key prob)
349 in
350 decodeA value ok err'
352 Nothing ->
353 err (Expecting region (TObjectWith key))
355 _ ->
356 err (Expecting region TObject)
359findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
360findField key pairs =
361 case pairs of
362 [] ->
363 Nothing
365 (P.Snippet fptr off len _ _, value) : remainingPairs ->
366 if key == B.PS fptr off len
367 then Just value
368 else findField key remainingPairs
372-- ONE OF
375oneOf :: [Decoder x a] -> Decoder x a
376oneOf decoders =
377 Decoder $ \ast ok err ->
378 case decoders of
379 Decoder decodeA : decoders ->
380 let
381 err' e =
382 oneOfHelp ast ok err decoders e []
383 in
384 decodeA ast ok err'
386 [] ->
387 error "Ran into (Json.Decode.oneOf [])"
390oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b
391oneOfHelp ast ok err decoders p ps =
392 case decoders of
393 Decoder decodeA : decoders ->
394 let
395 err' p' =
396 oneOfHelp ast ok err decoders p' (p:ps)
397 in
398 decodeA ast ok err'
400 [] ->
401 err (oneOfError [] p ps)
404oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x
405oneOfError problems prob ps =
406 case ps of
407 [] ->
408 OneOf prob problems
410 p:ps ->
411 oneOfError (prob:problems) p ps
415-- FAILURE
418failure :: x -> Decoder x a
419failure x =
420 Decoder $ \(A.At region _) _ err ->
421 err (Failure region x)
425-- ERRORS
428mapError :: (x -> y) -> Decoder x a -> Decoder y a
429mapError func (Decoder decodeA) =
430 Decoder $ \ast ok err ->
431 let
432 err' prob = err (mapErrorHelp func prob)
433 in
434 decodeA ast ok err'
437mapErrorHelp :: (x -> y) -> Problem x -> Problem y
438mapErrorHelp func problem =
439 case problem of
440 Field k p -> Field k (mapErrorHelp func p)
441 Index i p -> Index i (mapErrorHelp func p)
442 OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
443 Failure r x -> Failure r (func x)
444 Expecting r e -> Expecting r e
448-- AST
451type AST =
452 A.Located AST_
455data AST_
456 = Array [AST]
457 | Object [(P.Snippet, AST)]
458 | String P.Snippet
459 | Int Int
460 | TRUE
461 | FALSE
462 | NULL
466-- PARSE
469type Parser a =
470 P.Parser ParseError a
473data ParseError
474 = Start Row Col
475 | ObjectField Row Col
476 | ObjectColon Row Col
477 | ObjectEnd Row Col
478 | ArrayEnd Row Col
479 | StringProblem StringProblem Row Col
480 | NoLeadingZeros Row Col
481 | NoFloats Row Col
482 | BadEnd Row Col
484-- PIndex Int ParseError Row Col
485-- PField Json.String ParseError Row Col
488data StringProblem
489 = BadStringEnd
490 | BadStringControlChar
491 | BadStringEscapeChar
492 | BadStringEscapeHex
496-- PARSE AST
499pFile :: Parser AST
500pFile =
501 do spaces
502 value <- pValue
503 spaces
504 return value
507pValue :: Parser AST
508pValue =
509 P.addLocation $
510 P.oneOf Start
511 [ String <$> pString Start
512 , pObject
513 , pArray
514 , pInt
515 , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE
516 , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE
517 , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL
518 ]
522-- OBJECT
525pObject :: Parser AST_
526pObject =
527 do P.word1 0x7B {- { -} Start
528 spaces
529 P.oneOf ObjectField
530 [ do entry <- pField
531 spaces
532 pObjectHelp [entry]
533 , do P.word1 0x7D {-}-} ObjectEnd
534 return (Object [])
535 ]
538pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_
539pObjectHelp revEntries =
540 P.oneOf ObjectEnd
541 [
542 do P.word1 0x2C {-,-} ObjectEnd
543 spaces
544 entry <- pField
545 spaces
546 pObjectHelp (entry:revEntries)
547 ,
548 do P.word1 0x7D {-}-} ObjectEnd
549 return (Object (reverse revEntries))
550 ]
553pField :: Parser (P.Snippet, AST)
554pField =
555 do key <- pString ObjectField
556 spaces
557 P.word1 0x3A {-:-} ObjectColon
558 spaces
559 value <- pValue
560 return (key, value)
564-- ARRAY
567pArray :: Parser AST_
568pArray =
569 do P.word1 0x5B {-[-} Start
570 spaces
571 P.oneOf Start
572 [ do entry <- pValue
573 spaces
574 pArrayHelp 1 [entry]
575 , do P.word1 0x5D {-]-} ArrayEnd
576 return (Array [])
577 ]
580pArrayHelp :: Int -> [AST] -> Parser AST_
581pArrayHelp !len revEntries =
582 P.oneOf ArrayEnd
583 [
584 do P.word1 0x2C {-,-} ArrayEnd
585 spaces
586 entry <- pValue
587 spaces
588 pArrayHelp (len + 1) (entry:revEntries)
589 ,
590 do P.word1 0x5D {-]-} ArrayEnd
591 return (Array (reverse revEntries))
592 ]
596-- STRING
599pString :: (Row -> Col -> ParseError) -> Parser P.Snippet
600pString start =
601 P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
602 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
604 let
605 !pos1 = plusPtr pos 1
606 !col1 = col + 1
608 (# status, newPos, newRow, newCol #) =
609 pStringHelp pos1 end row col1
610 in
611 case status of
612 GoodString ->
613 let
614 !off = minusPtr pos1 (unsafeForeignPtrToPtr src)
615 !len = minusPtr newPos pos1 - 1
616 !snp = P.Snippet src off len row col1
617 !newState = P.State src newPos end indent newRow newCol
618 in
619 cok snp newState
621 BadString problem ->
622 cerr newRow newCol (StringProblem problem)
624 else
625 eerr row col start
628data StringStatus
629 = GoodString
630 | BadString StringProblem
633pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
634pStringHelp pos end row col =
635 if pos >= end then
636 (# BadString BadStringEnd, pos, row, col #)
638 else
639 case P.unsafeIndex pos of
640 0x22 {-"-} ->
641 (# GoodString, plusPtr pos 1, row, col + 1 #)
643 0x0A {-\n-} ->
644 (# BadString BadStringEnd, pos, row, col #)
646 0x5C {-\-} ->
647 let !pos1 = plusPtr pos 1 in
648 if pos1 >= end then
649 (# BadString BadStringEnd, pos1, row + 1, col #)
650 else
651 case P.unsafeIndex pos1 of
652 0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
653 0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
654 0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
655 0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
656 0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
657 0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
658 0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
659 0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
660 0x75 {-u-} ->
661 let !pos6 = plusPtr pos 6 in
662 if pos6 <= end
663 && isHex (P.unsafeIndex (plusPtr pos 2))
664 && isHex (P.unsafeIndex (plusPtr pos 3))
665 && isHex (P.unsafeIndex (plusPtr pos 4))
666 && isHex (P.unsafeIndex (plusPtr pos 5))
667 then
668 pStringHelp pos6 end row (col + 6)
669 else
670 (# BadString BadStringEscapeHex, pos, row, col #)
672 _ ->
673 (# BadString BadStringEscapeChar, pos, row, col #)
675 word ->
676 if word < 0x20 then
677 (# BadString BadStringControlChar, pos, row, col #)
678 else
679 let !newPos = plusPtr pos (P.getCharWidth word) in
680 pStringHelp newPos end row (col + 1)
683isHex :: Word8 -> Bool
684isHex word =
685 0x30 {-0-} <= word && word <= 0x39 {-9-}
686 || 0x61 {-a-} <= word && word <= 0x66 {-f-}
687 || 0x41 {-A-} <= word && word <= 0x46 {-F-}
691-- SPACES
694spaces :: Parser ()
695spaces =
696 P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->
697 let
698 (# newPos, newRow, newCol #) =
699 eatSpaces pos end row col
700 in
701 if pos == newPos then
702 eok () state
703 else
704 let
705 !newState =
706 P.State src newPos end indent newRow newCol
707 in
708 cok () newState
711eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)
712eatSpaces pos end row col =
713 if pos >= end then
714 (# pos, row, col #)
716 else
717 case P.unsafeIndex pos of
718 0x20 {- -} -> eatSpaces (plusPtr pos 1) end row (col + 1)
719 0x09 {-\t-} -> eatSpaces (plusPtr pos 1) end row (col + 1)
720 0x0A {-\n-} -> eatSpaces (plusPtr pos 1) end (row + 1) 1
721 0x0D {-\r-} -> eatSpaces (plusPtr pos 1) end row col
722 _ ->
723 (# pos, row, col #)
727-- INTS
730pInt :: Parser AST_
731pInt =
732 P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
733 if pos >= end then
734 eerr row col Start
736 else
737 let !word = P.unsafeIndex pos in
738 if not (isDecimalDigit word) then
739 eerr row col Start
741 else if word == 0x30 {-0-} then
743 let
744 !pos1 = plusPtr pos 1
745 !newState = P.State src pos1 end indent row (col + 1)
746 in
747 if pos1 < end then
748 let !word1 = P.unsafeIndex pos1 in
749 if isDecimalDigit word1 then
750 cerr row (col + 1) NoLeadingZeros
751 else if word1 == 0x2E {-.-} then
752 cerr row (col + 1) NoFloats
753 else
754 cok (Int 0) newState
755 else
756 cok (Int 0) newState
758 else
759 let
760 (# status, n, newPos #) =
761 chompInt (plusPtr pos 1) end (fromIntegral (word - 0x30 {-0-}))
763 !len = fromIntegral (minusPtr newPos pos)
764 in
765 case status of
766 GoodInt ->
767 let
768 !newState =
769 P.State src newPos end indent row (col + len)
770 in
771 cok (Int n) newState
773 BadIntEnd ->
774 cerr row (col + len) NoFloats
777data IntStatus = GoodInt | BadIntEnd
780chompInt :: Ptr Word8 -> Ptr Word8 -> Int -> (# IntStatus, Int, Ptr Word8 #)
781chompInt pos end n =
782 if pos < end then
783 let !word = P.unsafeIndex pos in
784 if isDecimalDigit word then
785 let !m = 10 * n + fromIntegral (word - 0x30 {-0-}) in
786 chompInt (plusPtr pos 1) end m
787 else if word == 0x2E {-.-} || word == 0x65 {-e-} || word == 0x45 {-E-} then
788 (# BadIntEnd, n, pos #)
789 else
790 (# GoodInt, n, pos #)
792 else
793 (# GoodInt, n, pos #)
796{-# INLINE isDecimalDigit #-}
797isDecimalDigit :: Word8 -> Bool
798isDecimalDigit word =
799 word <= 0x39 {-9-} && word >= 0x30 {-0-}