@@ -1,320 +1,267 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
33module Json.Decode
4− ( Decoder, Error(..), decode, parse
5− , string, text, bool, int, float
6− , list, dict, maybe
7− , field, at
8− , index
9− , map, map2, succeed, fail, andThen, oneOf
10− , aeson
4+ ( parse
5+ -- re-export from Json.Decode.Internals
6+ , Json.Decoder, Json.Error(..)
7+ , Json.string, Json.text, Json.bool, Json.int
8+ , Json.list, Json.dict, Json.maybe
9+ , Json.field, Json.at
10+ , Json.index
11+ , Json.map, Json.map2
12+ , Json.succeed, Json.fail
13+ , Json.andThen, Json.oneOf
1114 )
1215 where
1316
1417
15−import Data.Text (Text)
16−import Prelude hiding (fail, map, maybe)
17−
18−import qualified Control.Monad as Monad
19−import qualified Data.Aeson as Aeson
20−import qualified Data.ByteString.Lazy as BS
21−import qualified Data.HashMap.Lazy as HashMap
22−import qualified Data.Scientific as Scientific
18+import Prelude hiding (length)
19+import qualified Data.ByteString.Internal as B
20+import qualified Data.HashMap.Strict as HashMap
2321import qualified Data.Text as Text
22+import qualified Data.Text.Encoding as Text
2423import qualified Data.Vector as Vector
25−import Data.Vector ((!?))
26−
27−
28−
29−-- DECODERS
24+import Foreign.ForeignPtr (ForeignPtr)
25+import GHC.Word (Word8(..))
3026
27+import qualified Json.Decode.Internals as Json
28+import 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.Symbol as Symbol
33+import qualified Reporting.Error.Syntax as E
34+import qualified Reporting.Region as R
3135
32−data Decoder a =
33− Decoder
34− { _run :: (Error -> Error) -> Aeson.Value -> Either Error a
35− }
3636
3737
38−data Error
39− = Field Text Error
40− | Index Int Error
41− | OneOf [Error]
42− | Failure Aeson.Value String
43− deriving (Show)
38+-- PARSE
4439
4540
46−decode :: Decoder a -> Aeson.Value -> Either Error a
47−decode decoder value =
48− _run decoder id value
41+data Result e a
42+ = BadJson E.Error
43+ | BadContent (Json.Error e)
44+ | Success a
4945
5046
51−parse :: Decoder a -> BS.ByteString -> Either (Maybe Error) a
52−parse decoder bytestring =
53− case Aeson.eitherDecode bytestring of
54− Left _ ->
55− Left Nothing
47+parse :: Json.Decoder e a -> B.ByteString -> Result e a
48+parse (Json.Decoder run) bytestring =
49+ case P.run jsonFile bytestring of
50+ Left err ->
51+ BadJson err
5652
57− Right json ->
58− case decode decoder json of
53+ Right value ->
54+ case run id value of
5955 Left err ->
60− Left (Just err)
61−
62− Right value ->
63− Right value
64−
65−
66−
67−-- PRIMITIVES
68−
69−
70−string :: Decoder String
71−string =
72− Text.unpack <$> text
73−
74−
75−text :: Decoder Text
76−text =
77− Decoder $ \mkError value ->
78− case value of
79− Aeson.String txt ->
80− Right txt
81−
82− _ ->
83− Left (mkError (Failure value "Expecting a STRING"))
84−
85−
86−bool :: Decoder Bool
87−bool =
88− Decoder $ \mkError value ->
89− case value of
90− Aeson.Bool boolean ->
91− Right boolean
92−
93− _ ->
94− Left (mkError (Failure value "Expecting a BOOL"))
95−
96−
97−int :: Decoder Int
98−int =
99− Decoder $ \mkError value ->
100− case value of
101− Aeson.Number number ->
102− case Scientific.toBoundedInteger number of
103− Nothing ->
104− Left (mkError (Failure value "Expecting an INT"))
105−
106− Just integer ->
107− Right integer
108−
109− _ ->
110− Left (mkError (Failure value "Expecting an INT"))
111−
112−
113−float :: Decoder Float
114−float =
115− Decoder $ \mkError value ->
116− case value of
117− Aeson.Number number ->
118− Right (Scientific.toRealFloat number)
119−
120− _ ->
121− Left (mkError (Failure value "Expecting a FLOAT"))
122−
123−
124−
125−-- DATA STRUCTURES
126−
127−
128−list :: Decoder a -> Decoder [a]
129−list (Decoder run) =
130− Decoder $ \mkError value ->
131− case value of
132− Aeson.Array vector ->
133− Vector.toList <$>
134− Vector.imapM (\i v -> run (mkError . Index i) v) vector
135−
136− _ ->
137− Left (mkError (Failure value "Expecting an ARRAY"))
138−
56+ BadContent err
57+
58+ Right answer ->
59+ Success answer
60+
61+
62+
63+-- JSON
64+
65+
66+jsonFile :: Parser Json.Value
67+jsonFile =
68+ do spaces
69+ value <- jsonValue
70+ spaces
71+ P.endOfFile
72+ return value
13973
140−dict :: Decoder a -> Decoder (HashMap.HashMap Text a)
141−dict (Decoder run) =
142− Decoder $ \mkError value ->
143− case value of
144− Aeson.Object hashMap ->
145− HashMap.traverseWithKey (\k v -> run (mkError . Field k) v) hashMap
14674
147− _ ->
148− Left (mkError (Failure value "Expecting an OBJECT"))
75+jsonValue :: Parser Json.Value
76+jsonValue =
77+ do start <- P.getPosition
78+ I.oneOf
79+ [ Json.String <$> string
80+ , object start
81+ , array start
82+ , number
83+ , Keyword.jsonTrue >> return Json.TRUE
84+ , Keyword.jsonFalse >> return Json.FALSE
85+ , Keyword.jsonNull >> return Json.NULL
86+ ]
14987
15088
151−maybe :: Decoder a -> Decoder (Maybe a)
152−maybe (Decoder run) =
153− Decoder $ \mkError value ->
154− case run mkError value of
155− Left _ ->
156− Right Nothing
15789
158− Right a ->
159− Right (Just a)
90+-- OBJECT
16091
16192
93+object :: R.Position -> Parser Json.Value
94+object start =
95+ do Symbol.leftCurly
96+ P.inContext start E.ExprRecord $
97+ do spaces
98+ I.oneOf
99+ [ do entry <- field
100+ spaces
101+ objectHelp [entry]
102+ , do Symbol.rightCurly
103+ return (Json.Object [] HashMap.empty)
104+ ]
162105
163−-- OBJECT PRIMITIVES
164106
107+objectHelp :: [(Text.Text, Json.Value)] -> Parser Json.Value
108+objectHelp revEntries =
109+ I.oneOf
110+ [
111+ do Symbol.comma
112+ spaces
113+ entry <- field
114+ spaces
115+ objectHelp (entry:revEntries)
116+ ,
117+ do Symbol.rightCurly
118+ return (Json.Object (reverse revEntries) (HashMap.fromList revEntries))
119+ ]
165120
166−field :: Text -> Decoder a -> Decoder a
167−field name (Decoder run) =
168− Decoder $ \mkError value ->
169− case value of
170− Aeson.Object hashMap ->
171− case HashMap.lookup name hashMap of
172− Just v ->
173− run (mkError . Field name) v
174121
175− Nothing ->
176− Left $ mkError $ Failure value $
177− "Expecting a \"" ++ Text.unpack name ++ "\" field."
122+field :: Parser (Text.Text, Json.Value)
123+field =
124+ do key <- string
125+ spaces
126+ Symbol.hasType
127+ spaces
128+ value <- jsonValue
129+ return (key, value)
178130
179− _ ->
180− Left (mkError (Failure value "Expecting an OBJECT"))
181131
182132
183−at :: [Text] -> Decoder a -> Decoder a
184−at names decoder =
185− foldr field decoder names
133+-- ARRAY
186134
187135
136+array :: R.Position -> Parser Json.Value
137+array start =
138+ do Symbol.leftSquare
139+ P.inContext start E.ExprList $
140+ do spaces
141+ I.oneOf
142+ [ do entry <- jsonValue
143+ spaces
144+ arrayHelp 1 [entry]
145+ , do Symbol.rightSquare
146+ return (Json.Array Vector.empty)
147+ ]
188148
189−-- ARRAY PRIMITIVES
190149
150+arrayHelp :: Int -> [Json.Value] -> Parser Json.Value
151+arrayHelp !length revEntries =
152+ I.oneOf
153+ [
154+ do Symbol.comma
155+ spaces
156+ entry <- jsonValue
157+ spaces
158+ arrayHelp (length + 1) (entry:revEntries)
159+ ,
160+ do Symbol.rightSquare
161+ return $ Json.Array $ Vector.reverse $
162+ Vector.fromListN length revEntries
163+ ]
191164
192−index :: Int -> Decoder a -> Decoder a
193−index i (Decoder run) =
194− Decoder $ \mkError value ->
195− case value of
196− Aeson.Array vector ->
197− case vector !? i of
198− Just v ->
199− run (mkError . Index i) v
200−
201− Nothing ->
202− Left $ mkError $ Failure value $
203− "Expecting a longer ARRAY. I need index " ++ show i
204− ++ ", but the array only has " ++ show (Vector.length vector)
205− ++ " elements."
206−
207− _ ->
208− Left (mkError (Failure value "Expecting an ARRAY"))
209165
210166
167+-- NUMBER
211168
212−-- MAPPING
213169
170+number :: Parser Json.Value
171+number =
172+ error "TODO"
214173
215−map :: (a -> value) -> Decoder a -> Decoder value
216−map func (Decoder run) =
217− Decoder $ \mkError value ->
218− func <$> run mkError value
219174
220175
221−map2 :: (a -> b -> value) -> Decoder a -> Decoder b -> Decoder value
222−map2 func (Decoder runA) (Decoder runB) =
223− Decoder $ \mkError value ->
224− func
225− <$> runA mkError value
226− <*> runB mkError value
176+-- STRING
227177
228178
229−apply :: Decoder (a -> b) -> Decoder a -> Decoder b
230−apply (Decoder runFunc) (Decoder runArg) =
231− Decoder $ \mkError value ->
232− do func <- runFunc mkError value
233− arg <- runArg mkError value
234− return (func arg)
235−
236−
237−instance Functor Decoder where
238− fmap =
239− map
240−
241−
242−instance Applicative Decoder where
243− pure =
244− succeed
245−
246− (<*>) =
247− apply
248−
249−
250−instance Monad Decoder where
251− return =
252− succeed
253−
254− (>>=) decoder callback =
255− andThen callback decoder
256−
257− fail msg =
258− fail msg
259−
179+string :: Parser Text.Text
180+string =
181+ Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
182+ if offset < terminal && I.unsafeIndex fp offset == 0x22 {- " -} then
260183
184+ case stringHelp fp (offset + 1) terminal row (col + 1) of
185+ Err err ->
186+ cerr err
261187
262−-- FANCY PRIMITIVES
188+ Ok newOffset newRow newCol ->
189+ let
190+ !newState = State fp newOffset terminal indent newRow newCol ctx
191+ !content = Text.decodeUtf8 (B.PS fp offset (newOffset - offset))
192+ in
193+ cok content newState noError
263194
195+ else
196+ eerr noError
264197
265−succeed :: a -> Decoder a
266−succeed a =
267− Decoder $ \_ _ -> Right a
268198
199+data StringResult
200+ = Err E.ParseError
201+ | Ok !Int !Int !Int
269202
270−fail :: String -> Decoder a
271−fail msg =
272− Decoder $ \mkError value ->
273− Left (mkError (Failure value msg))
274203
204+stringHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> StringResult
205+stringHelp fp offset terminal row col =
206+ if offset >= terminal then
207+ Err (E.ParseError row col E.EndOfFile_String)
275208
276−andThen :: (a -> Decoder b) -> Decoder a -> Decoder b
277−andThen callback (Decoder runA) =
278− Decoder $ \mkError value ->
279− do a <- runA mkError value
280− let (Decoder runB) = callback a
281− runB mkError value
209+ else
210+ case I.unsafeIndex fp offset of
211+ 0x22 {- " -} ->
212+ Ok (offset + 1) row (col + 1)
282213
214+ 0x0A {- \n -} ->
215+ Err (E.ParseError row col E.NewLineInString)
283216
217+ 0x5C {- \ -} ->
218+ let
219+ !offset1 = offset + 1
220+ in
221+ if offset1 < terminal then
284222
285−-- ONE OF
223+ let
224+ !word = I.unsafeIndex fp offset1
225+ !newOffset = offset1 + I.getCharWidth fp offset1 terminal word
226+ in
227+ stringHelp fp newOffset terminal row (col + 2)
286228
229+ else
230+ Err (E.ParseError (row + 1) col E.EndOfFile_String)
287231
288−oneOf :: [Decoder a] -> Decoder a
289−oneOf decoders =
290− Decoder (oneOfHelp decoders [])
232+ word ->
233+ let !newOffset = offset + I.getCharWidth fp offset terminal word in
234+ stringHelp fp newOffset terminal row (col + 1)
291235
292236
293−oneOfHelp :: [Decoder a] -> [Error] -> (Error -> Error) -> Aeson.Value -> Either Error a
294−oneOfHelp decoders errors mkError value =
295− case decoders of
296− [] ->
297− Left (mkError (OneOf (reverse errors)))
298237
299− Decoder run : otherDecoders ->
300− case run mkError value of
301− Right a ->
302− Right a
303238
304− Left err ->
305− oneOfHelp otherDecoders (err:errors) mkError value
239+-- SPACES
306240
307241
242+spaces :: Parser ()
243+spaces =
244+ Parser $ \(State fp offset terminal indent row col ctx) cok _ _ _ ->
245+ let
246+ (# newOffset, newRow, newCol #) =
247+ eatSpaces fp offset terminal row col
308248
309−-- AESON
249+ !newState =
250+ State fp newOffset terminal indent newRow newCol ctx
251+ in
252+ cok () newState noError
310253
311254
312−aeson :: (Aeson.FromJSON a) => Decoder a
313−aeson =
314− Decoder $ \mkError value ->
315− case Aeson.fromJSON value of
316− Aeson.Error msg ->
317− Left (mkError (Failure value msg))
255+eatSpaces :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Int, Int, Int #)
256+eatSpaces fp offset terminal row col =
257+ if offset >= terminal then
258+ (# offset, row, col #)
318259
319− Aeson.Success a ->
320− Right a
260+ else
261+ case I.unsafeIndex fp offset of
262+ 0x20 {- -} -> eatSpaces fp (offset + 1) terminal row (col + 1)
263+ 0x09 {- \t -} -> eatSpaces fp (offset + 1) terminal row (col + 1)
264+ 0x0A {- \n -} -> eatSpaces fp (offset + 1) terminal (row + 1) 1
265+ 0x0D {- \r -} -> eatSpaces fp (offset + 1) terminal row col
266+ _ ->
267+ (# offset, row, col #)