@@ -1,320 +1,267 @@
1−{-# OPTIONS_GHC -Wall #-}
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
3module Json.Decode
3module Json.Decode
5+ -- re-export from Json.Decode.Internals
4− ( Decoder, Error(..), decode, parse
6+ , Json.Decoder, Json.Error(..)
5− , string, text, bool, int, float
7+ , Json.string, Json.text, Json.bool, Json.int
6− , list, dict, maybe
8+ , Json.list, Json.dict, Json.maybe
7− , field, at
9+ , Json.field, Json.at
8− , index
10+ , Json.index
11+ , Json.map, Json.map2
12+ , Json.succeed, Json.fail
9− , map, map2, succeed, fail, andThen, oneOf
13+ , Json.andThen, Json.oneOf
15−import Data.Text (Text)
16−import Prelude hiding (fail, map, maybe)
18+import Prelude hiding (length)
18−import qualified Control.Monad as Monad
19−import qualified Data.Aeson as Aeson
20−import qualified Data.ByteString.Lazy as BS
19+import qualified Data.ByteString.Internal as B
21−import qualified Data.HashMap.Lazy as HashMap
20+import qualified Data.HashMap.Strict as HashMap
22−import qualified Data.Scientific as Scientific
23import qualified Data.Text as Text
21import qualified Data.Text as Text
22+import qualified Data.Text.Encoding as Text
24import qualified Data.Vector as Vector
23import qualified Data.Vector as Vector
25−import Data.Vector ((!?))
24+import Foreign.ForeignPtr (ForeignPtr)
26−
25+import GHC.Word (Word8(..))
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
34− { _run :: (Error -> Error) -> Aeson.Value -> Either Error a
42− | Failure Aeson.Value String
46−decode :: Decoder a -> Aeson.Value -> Either Error a
41+data Result e a
47−decode decoder value =
42+ = BadJson E.Error
48− _run decoder id value
43+ | BadContent (Json.Error e)
51−parse :: Decoder a -> BS.ByteString -> Either (Maybe Error) a
47+parse :: Json.Decoder e a -> B.ByteString -> Result e a
52−parse decoder bytestring =
48+parse (Json.Decoder run) bytestring =
53− case Aeson.eitherDecode bytestring of
49+ case P.run jsonFile bytestring of
54− Left _ ->
50+ Left err ->
55− Left Nothing
51+ BadJson err
57− Right json ->
53+ Right value ->
58− case decode decoder json of
54+ case run id value of
59 Left err ->
55 Left err ->
60− Left (Just err)
56+ BadContent err
62− Right value ->
58+ Right answer ->
63− Right value
59+ Success answer
67−-- PRIMITIVES
63+-- JSON
70−string :: Decoder String
66+jsonFile :: Parser Json.Value
72− Text.unpack <$> text
68+ do spaces
73−
69+ value <- jsonValue
75−text :: Decoder Text
71+ P.endOfFile
76−text =
72+ return value
77− Decoder $ \mkError value ->
83− Left (mkError (Failure value "Expecting a STRING"))
88− Decoder $ \mkError value ->
90− Aeson.Bool boolean ->
94− Left (mkError (Failure value "Expecting a BOOL"))
99− Decoder $ \mkError value ->
101− Aeson.Number number ->
102− case Scientific.toBoundedInteger number of
104− Left (mkError (Failure value "Expecting an INT"))
110− Left (mkError (Failure value "Expecting an INT"))
113−float :: Decoder Float
115− Decoder $ \mkError value ->
117− Aeson.Number number ->
118− Right (Scientific.toRealFloat number)
121− Left (mkError (Failure value "Expecting a FLOAT"))
128−list :: Decoder a -> Decoder [a]
130− Decoder $ \mkError value ->
132− Aeson.Array vector ->
134− Vector.imapM (\i v -> run (mkError . Index i) v) vector
137− Left (mkError (Failure value "Expecting an ARRAY"))
140−dict :: Decoder a -> Decoder (HashMap.HashMap Text a)
142− Decoder $ \mkError value ->
144− Aeson.Object hashMap ->
145− HashMap.traverseWithKey (\k v -> run (mkError . Field k) v) hashMap
147− _ ->
75+jsonValue :: Parser Json.Value
148− Left (mkError (Failure value "Expecting an OBJECT"))
76+jsonValue =
77+ do start <- P.getPosition
79+ [ Json.String <$> string
83+ , Keyword.jsonTrue >> return Json.TRUE
84+ , Keyword.jsonFalse >> return Json.FALSE
85+ , Keyword.jsonNull >> return Json.NULL
151−maybe :: Decoder a -> Decoder (Maybe a)
152−maybe (Decoder run) =
153− Decoder $ \mkError value ->
154− case run mkError value of
158− Right a ->
90+-- OBJECT
93+object :: R.Position -> Parser Json.Value
96+ P.inContext start E.ExprRecord $
102+ , do Symbol.rightCurly
103+ return (Json.Object [] HashMap.empty)
107+objectHelp :: [(Text.Text, Json.Value)] -> Parser Json.Value
108+objectHelp revEntries =
115+ objectHelp (entry:revEntries)
117+ do Symbol.rightCurly
118+ return (Json.Object (reverse revEntries) (HashMap.fromList revEntries))
166−field :: Text -> Decoder a -> Decoder a
167−field name (Decoder run) =
168− Decoder $ \mkError value ->
170− Aeson.Object hashMap ->
171− case HashMap.lookup name hashMap of
173− run (mkError . Field name) v
175− Nothing ->
122+field :: Parser (Text.Text, Json.Value)
176− Left $ mkError $ Failure value $
123+field =
177− "Expecting a \"" ++ Text.unpack name ++ "\" field."
124+ do key <- string
180− Left (mkError (Failure value "Expecting an OBJECT"))
183−at :: [Text] -> Decoder a -> Decoder a
133+-- ARRAY
185− foldr field decoder names
136+array :: R.Position -> Parser Json.Value
138+ do Symbol.leftSquare
139+ P.inContext start E.ExprList $
142+ [ do entry <- jsonValue
145+ , do Symbol.rightSquare
146+ return (Json.Array Vector.empty)
150+arrayHelp :: Int -> [Json.Value] -> Parser Json.Value
151+arrayHelp !length revEntries =
158+ arrayHelp (length + 1) (entry:revEntries)
160+ do Symbol.rightSquare
161+ return $ Json.Array $ Vector.reverse $
162+ Vector.fromListN length revEntries
192−index :: Int -> Decoder a -> Decoder a
193−index i (Decoder run) =
194− Decoder $ \mkError value ->
196− Aeson.Array vector ->
199− run (mkError . Index i) v
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)
208− Left (mkError (Failure value "Expecting an ARRAY"))
170+number :: Parser Json.Value
215−map :: (a -> value) -> Decoder a -> Decoder value
216−map func (Decoder run) =
217− Decoder $ \mkError value ->
218− func <$> run mkError value
221−map2 :: (a -> b -> value) -> Decoder a -> Decoder b -> Decoder value
176+-- STRING
222−map2 func (Decoder runA) (Decoder runB) =
223− Decoder $ \mkError value ->
225− <$> runA mkError value
226− <*> runB mkError value
229−apply :: Decoder (a -> b) -> Decoder a -> Decoder b
179+string :: Parser Text.Text
230−apply (Decoder runFunc) (Decoder runArg) =
180+string =
231− Decoder $ \mkError value ->
181+ Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
232− do func <- runFunc mkError value
182+ if offset < terminal && I.unsafeIndex fp offset == 0x22 {- " -} then
233− arg <- runArg mkError value
237−instance Functor Decoder where
242−instance Applicative Decoder where
250−instance Monad Decoder where
254− (>>=) decoder callback =
255− andThen callback decoder
184+ case stringHelp fp (offset + 1) terminal row (col + 1) of
262−-- FANCY PRIMITIVES
188+ Ok newOffset newRow newCol ->
190+ !newState = State fp newOffset terminal indent newRow newCol ctx
191+ !content = Text.decodeUtf8 (B.PS fp offset (newOffset - offset))
193+ cok content newState noError
265−succeed :: a -> Decoder a
267− Decoder $ \_ _ -> Right a
270−fail :: String -> Decoder a
272− Decoder $ \mkError value ->
273− Left (mkError (Failure value msg))
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)
276−andThen :: (a -> Decoder b) -> Decoder a -> Decoder b
209+ else
277−andThen callback (Decoder runA) =
210+ case I.unsafeIndex fp offset of
278− Decoder $ \mkError value ->
211+ 0x22 {- " -} ->
279− do a <- runA mkError value
212+ Ok (offset + 1) row (col + 1)
280− let (Decoder runB) = callback a
215+ Err (E.ParseError row col E.NewLineInString)
219+ !offset1 = offset + 1
221+ if offset1 < terminal then
224+ !word = I.unsafeIndex fp offset1
225+ !newOffset = offset1 + I.getCharWidth fp offset1 terminal word
227+ stringHelp fp newOffset terminal row (col + 2)
230+ Err (E.ParseError (row + 1) col E.EndOfFile_String)
288−oneOf :: [Decoder a] -> Decoder a
232+ word ->
289−oneOf decoders =
233+ let !newOffset = offset + I.getCharWidth fp offset terminal word in
290− Decoder (oneOfHelp decoders [])
234+ stringHelp fp newOffset terminal row (col + 1)
293−oneOfHelp :: [Decoder a] -> [Error] -> (Error -> Error) -> Aeson.Value -> Either Error a
294−oneOfHelp decoders errors mkError value =
297− Left (mkError (OneOf (reverse errors)))
299− Decoder run : otherDecoders ->
300− case run mkError value of
304− Left err ->
239+-- SPACES
305− oneOfHelp otherDecoders (err:errors) mkError value
244+ Parser $ \(State fp offset terminal indent row col ctx) cok _ _ _ ->
246+ (# newOffset, newRow, newCol #) =
247+ eatSpaces fp offset terminal row col
309−-- AESON
249+ !newState =
250+ State fp newOffset terminal indent newRow newCol ctx
252+ cok () newState noError
312−aeson :: (Aeson.FromJSON a) => Decoder a
255+eatSpaces :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Int, Int, Int #)
313−aeson =
256+eatSpaces fp offset terminal row col =
314− Decoder $ \mkError value ->
257+ if offset >= terminal then
315− case Aeson.fromJSON value of
258+ (# offset, row, col #)
317− Left (mkError (Failure value msg))
319− Aeson.Success a ->
260+ else
320− Right a
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
267+ (# offset, row, col #)