diff --git a/attoparsec-aeson.cabal b/attoparsec-aeson.cabal --- a/attoparsec-aeson.cabal +++ b/attoparsec-aeson.cabal @@ -1,19 +1,9 @@ cabal-version: 1.12 name: attoparsec-aeson -version: 2.1.0.0 +version: 2.2.0.0 synopsis: Parsing of aeson's Value with attoparsec description: Parsing of aeson's Value with attoparsec, originally from aeson. - . - This version is an empty package with bounds on @aeson@ - which has "Data.Aeson.Parser" module. - This way e.g. specifying - . - @ - build-depends: aeson >= 1.4.1.0 && \<2.3, attoparsec-aeson >=2.1.0.0 && \<2.3 - @ - . - will have "Data.Aeson.Parser" available for all @aeson@ versions in range. license: BSD3 license-file: LICENSE @@ -28,12 +18,40 @@ homepage: https://github.com/haskell/aeson bug-reports: https://github.com/haskell/aeson/issues build-type: Simple +tested-with: + GHC ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.8 + || ==9.4.5 + || ==9.6.2 library + hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall + exposed-modules: + Data.Aeson.Parser + Data.Aeson.Parser.Internal + + other-modules: + Data.Aeson.Internal.ByteString + Data.Aeson.Internal.Text + Data.Aeson.Internal.Word8 + build-depends: - aeson >=1.4.1.0 && <2.2 - , base <5 + aeson >=2.2.0.0 && <2.3 + , attoparsec >=0.14.2 && <0.15 + , base >=4.10.0.0 && <5 + , bytestring >=0.10.8.2 && <0.12 + , integer-conversion >=0.1 && <0.2 + , primitive >=0.8.0.0 && <0.9 + , scientific >=0.3.7.0 && <0.4 + , text >=1.2.3.0 && <1.3 || >=2.0 && <2.1 + , vector >=0.12.0.1 && <0.14 source-repository head type: git diff --git a/src/Data/Aeson/Internal/ByteString.hs b/src/Data/Aeson/Internal/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Internal/ByteString.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +module Data.Aeson.Internal.ByteString ( + mkBS, + withBS, +#ifdef MIN_VERSION_template_haskell + liftSBS, +#endif +) where + +import Data.ByteString.Internal (ByteString (..)) +import Data.Word (Word8) +import Foreign.ForeignPtr (ForeignPtr) + +#if !MIN_VERSION_bytestring(0,11,0) +import GHC.ForeignPtr (plusForeignPtr) +#endif + +#ifdef MIN_VERSION_template_haskell +import Data.ByteString.Short (ShortByteString, fromShort) +import Data.ByteString.Short.Internal (createFromPtr) +import GHC.Exts (Addr#, Ptr (Ptr)) +import System.IO.Unsafe (unsafeDupablePerformIO) + +import qualified Language.Haskell.TH.Lib as TH +import qualified Language.Haskell.TH.Syntax as TH + +#if !MIN_VERSION_template_haskell(2,16,0) +import qualified Data.ByteString as BS +#endif +#endif + +------------------------------------------------------------------------------- +-- bytestring-0.11 compat +------------------------------------------------------------------------------- + +mkBS :: ForeignPtr Word8 -> Int -> ByteString +#if MIN_VERSION_bytestring(0,11,0) +mkBS dfp n = BS dfp n +#else +mkBS dfp n = PS dfp 0 n +#endif +{-# INLINE mkBS #-} + +withBS :: ByteString -> (ForeignPtr Word8 -> Int -> r) -> r +#if MIN_VERSION_bytestring(0,11,0) +withBS (BS !sfp !slen) kont = kont sfp slen +#else +withBS (PS !sfp !soff !slen) kont = kont (plusForeignPtr sfp soff) slen +#endif +{-# INLINE withBS #-} + +------------------------------------------------------------------------------- +-- Template Haskell +------------------------------------------------------------------------------- + +#ifdef MIN_VERSION_template_haskell +liftSBS :: ShortByteString -> TH.ExpQ +#if MIN_VERSION_template_haskell(2,16,0) +liftSBS sbs = withBS bs $ \ptr len -> [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.BytesPrimL $ TH.Bytes ptr 0 (fromIntegral len)) + where + bs = fromShort sbs +#else +liftSBS sbs = withBS bs $ \_ len -> [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.StringPrimL $ BS.unpack bs) + where + bs = fromShort sbs +#endif + +-- this is copied verbatim from @bytestring@, but only in recent versions. +unsafePackLenLiteral :: Int -> Addr# -> ShortByteString +unsafePackLenLiteral len addr# = + unsafeDupablePerformIO $ createFromPtr (Ptr addr#) len +#endif diff --git a/src/Data/Aeson/Internal/Text.hs b/src/Data/Aeson/Internal/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Internal/Text.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +module Data.Aeson.Internal.Text ( + unsafeDecodeASCII, +) where + +import Data.ByteString (ByteString) +import qualified Data.Text as T + +#if MIN_VERSION_text(2,0,0) +import Data.Text.Array (Array (..)) +import qualified Data.Text.Internal as T (Text (..)) + +import qualified Data.ByteString.Short.Internal as SBS + +import Data.Aeson.Internal.ByteString + +#else +import qualified Data.Text.Encoding as TE + +#endif + +-- | The input is assumed to contain only 7bit ASCII characters (i.e. @< 0x80@). +-- We use TE.decodeLatin1 here because TE.decodeASCII is currently (text-1.2.4.0) +-- deprecated and equal to TE.decodeUtf8, which is slower than TE.decodeLatin1. +unsafeDecodeASCII :: ByteString -> T.Text + +#if MIN_VERSION_text(2,0,0) +unsafeDecodeASCII bs = withBS bs $ \_fp len -> if len == 0 then T.empty else + let !(SBS.SBS arr) = SBS.toShort bs in T.Text (ByteArray arr) 0 len + +#else +unsafeDecodeASCII = TE.decodeLatin1 +#endif diff --git a/src/Data/Aeson/Internal/Word8.hs b/src/Data/Aeson/Internal/Word8.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Internal/Word8.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE PatternSynonyms #-} +module Data.Aeson.Internal.Word8 where + +import Data.Word (Word8) + +------------------------------------------------------------------------------- +-- Word8 ASCII codes as patterns +------------------------------------------------------------------------------- + +-- GHC-8.0 doesn't support giving multiple pattern synonyms type signature at once + +-- spaces +pattern W8_SPACE :: Word8 +pattern W8_NL :: Word8 +pattern W8_CR :: Word8 +pattern W8_TAB :: Word8 + +pattern W8_SPACE = 0x20 +pattern W8_NL = 0x0a +pattern W8_CR = 0x0d +pattern W8_TAB = 0x09 + +-- punctuation +pattern W8_BACKSLASH :: Word8 +pattern W8_DOUBLE_QUOTE :: Word8 +pattern W8_DOT :: Word8 +pattern W8_COMMA :: Word8 +pattern W8_COLON :: Word8 + +pattern W8_BACKSLASH = 92 +pattern W8_COMMA = 44 +pattern W8_DOT = 46 +pattern W8_DOUBLE_QUOTE = 34 +pattern W8_COLON = 58 + +-- parentheses +pattern W8_CLOSE_CURLY :: Word8 +pattern W8_CLOSE_SQUARE :: Word8 +pattern W8_OPEN_SQUARE :: Word8 +pattern W8_OPEN_CURLY :: Word8 + +pattern W8_OPEN_CURLY = 123 +pattern W8_OPEN_SQUARE = 91 +pattern W8_CLOSE_CURLY = 125 +pattern W8_CLOSE_SQUARE = 93 + +-- operators +pattern W8_MINUS :: Word8 +pattern W8_PLUS :: Word8 + +pattern W8_PLUS = 43 +pattern W8_MINUS = 45 + +-- digits +pattern W8_0 :: Word8 +pattern W8_9 :: Word8 + +pattern W8_0 = 48 +pattern W8_9 = 57 + +-- lower case +pattern W8_e :: Word8 +pattern W8_f :: Word8 +pattern W8_n :: Word8 +pattern W8_t :: Word8 + +pattern W8_e = 101 +pattern W8_f = 102 +pattern W8_n = 110 +pattern W8_t = 116 + +-- upper case +pattern W8_E :: Word8 +pattern W8_E = 69 diff --git a/src/Data/Aeson/Parser.hs b/src/Data/Aeson/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Parser.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: Data.Aeson.Parser +-- Copyright: (c) 2012-2016 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Efficiently and correctly parse a JSON string. The string must be +-- encoded as UTF-8. +-- +-- It can be useful to think of parsing as occurring in two phases: +-- +-- * Identification of the textual boundaries of a JSON value. This +-- is always strict, so that an invalid JSON document can be +-- rejected as soon as possible. +-- +-- * Conversion of a JSON value to a Haskell value. This may be +-- either immediate (strict) or deferred (lazy); see below for +-- details. +-- +-- The question of whether to choose a lazy or strict parser is +-- subtle, but it can have significant performance implications, +-- resulting in changes in CPU use and memory footprint of 30% to 50%, +-- or occasionally more. Measure the performance of your application +-- with each! + +module Data.Aeson.Parser + ( + -- * Lazy parsers + -- $lazy + json + , value + , jstring + , scientific + -- ** Handling objects with duplicate keys + , jsonWith + , jsonLast + , jsonAccum + , jsonNoDup + -- * Strict parsers + -- $strict + , json' + , value' + -- ** Handling objects with duplicate keys + , jsonWith' + , jsonLast' + , jsonAccum' + , jsonNoDup' + -- * Decoding without FromJSON instances + , decodeWith + , decodeStrictWith + , eitherDecodeWith + , eitherDecodeStrictWith + ) where + + +import Data.Aeson.Parser.Internal + +-- $lazy +-- +-- The 'json' and 'value' parsers decouple identification from +-- conversion. Identification occurs immediately (so that an invalid +-- JSON document can be rejected as early as possible), but conversion +-- to a Haskell value is deferred until that value is needed. +-- +-- This decoupling can be time-efficient if only a smallish subset of +-- elements in a JSON value need to be inspected, since the cost of +-- conversion is zero for uninspected elements. The trade off is an +-- increase in memory usage, due to allocation of thunks for values +-- that have not yet been converted. + +-- $strict +-- +-- The 'json'' and 'value'' parsers combine identification with +-- conversion. They consume more CPU cycles up front, but have a +-- smaller memory footprint. diff --git a/src/Data/Aeson/Parser/Internal.hs b/src/Data/Aeson/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Parser/Internal.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module: Data.Aeson.Parser.Internal +-- Copyright: (c) 2011-2016 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Efficiently and correctly parse a JSON string. The string must be +-- encoded as UTF-8. + +module Data.Aeson.Parser.Internal + ( + -- * Lazy parsers + json, jsonEOF + , jsonWith + , jsonLast + , jsonAccum + , jsonNoDup + , value + , jstring + , jstring_ + , scientific + -- * Strict parsers + , json', jsonEOF' + , jsonWith' + , jsonLast' + , jsonAccum' + , jsonNoDup' + , value' + -- * Helpers + , decodeWith + , decodeStrictWith + , eitherDecodeWith + , eitherDecodeStrictWith + -- ** Handling objects with duplicate keys + , fromListAccum + , parseListNoDup + -- * Text literal unescaping + , unescapeText + ) where + +import Control.Applicative ((<|>)) +import Control.Monad (when, void) +import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string) +import Data.Function (fix) +import Data.Functor (($>)) +import Data.Integer.Conversion (byteStringToInteger) +import Data.Scientific (Scientific) +import Data.Text (Text) +import Data.Vector (Vector) + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>)) +#endif + +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KM +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.Lazy as L +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as C +import qualified Data.ByteString.Unsafe as B +import qualified Data.Scientific as Sci +import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse) + +import Data.Aeson.Types (IResult(..), JSONPath, Object, Result(..), Value(..), Key) +import Data.Aeson.Internal.Text +import Data.Aeson.Decoding (unescapeText) +import Data.Aeson.Internal.Word8 + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Aeson.Types + +------------------------------------------------------------------------------- +-- Parsers +------------------------------------------------------------------------------- + +-- | Parse any JSON value. +-- +-- The conversion of a parsed value to a Haskell value is deferred +-- until the Haskell value is needed. This may improve performance if +-- only a subset of the results of conversions are needed, but at a +-- cost in thunk allocation. +-- +-- This function is an alias for 'value'. In aeson 0.8 and earlier, it +-- parsed only object or array types, in conformance with the +-- now-obsolete RFC 4627. +-- +-- ==== Warning +-- +-- If an object contains duplicate keys, only the first one will be kept. +-- For a more flexible alternative, see 'jsonWith'. +json :: Parser Value +json = value + +-- | Parse any JSON value. +-- +-- This is a strict version of 'json' which avoids building up thunks +-- during parsing; it performs all conversions immediately. Prefer +-- this version if most of the JSON data needs to be accessed. +-- +-- This function is an alias for 'value''. In aeson 0.8 and earlier, it +-- parsed only object or array types, in conformance with the +-- now-obsolete RFC 4627. +-- +-- ==== Warning +-- +-- If an object contains duplicate keys, only the first one will be kept. +-- For a more flexible alternative, see 'jsonWith''. +json' :: Parser Value +json' = value' + +-- Open recursion: object_, object_', array_, array_' are parameterized by the +-- toplevel Value parser to be called recursively, to keep the parameter +-- mkObject outside of the recursive loop for proper inlining. + +object_ :: ([(Key, Value)] -> Either String Object) -> Parser Value -> Parser Value +object_ mkObject val = Object <$> objectValues mkObject key val +{-# INLINE object_ #-} + +object_' :: ([(Key, Value)] -> Either String Object) -> Parser Value -> Parser Value +object_' mkObject val' = do + !vals <- objectValues mkObject key' val' + return (Object vals) + where + key' = do + !s <- key + return s +{-# INLINE object_' #-} + +objectValues :: ([(Key, Value)] -> Either String Object) + -> Parser Key -> Parser Value -> Parser (KM.KeyMap Value) +objectValues mkObject str val = do + skipSpace + w <- A.peekWord8' + if w == W8_CLOSE_CURLY + then A.anyWord8 >> return KM.empty + else loop [] + where + -- Why use acc pattern here, you may ask? because then the underlying 'KM.fromList' + -- implementation can make use of mutation when constructing a map. For example, + -- 'HashMap` uses 'unsafeInsert' and it's much faster because it's doing in place + -- update to the 'HashMap'! + loop acc = do + k <- (str A. "object key") <* skipSpace <* (char ':' A. "':'") + v <- (val A. "object value") <* skipSpace + ch <- A.satisfy (\w -> w == W8_COMMA || w == W8_CLOSE_CURLY) A. "',' or '}'" + let acc' = (k, v) : acc + if ch == W8_COMMA + then skipSpace >> loop acc' + else case mkObject acc' of + Left err -> fail err + Right obj -> pure obj +{-# INLINE objectValues #-} + +array_ :: Parser Value -> Parser Value +array_ val = Array <$> arrayValues val +{-# INLINE array_ #-} + +array_' :: Parser Value -> Parser Value +array_' val = do + !vals <- arrayValues val + return (Array vals) +{-# INLINE array_' #-} + +arrayValues :: Parser Value -> Parser (Vector Value) +arrayValues val = do + skipSpace + w <- A.peekWord8' + if w == W8_CLOSE_SQUARE + then A.anyWord8 >> return Vector.empty + else loop [] 1 + where + loop acc !len = do + v <- (val A. "json list value") <* skipSpace + ch <- A.satisfy (\w -> w == W8_COMMA || w == W8_CLOSE_SQUARE) A. "',' or ']'" + if ch == W8_COMMA + then skipSpace >> loop (v:acc) (len+1) + else return (Vector.reverse (Vector.fromListN len (v:acc))) +{-# INLINE arrayValues #-} + +-- | Parse any JSON value. Synonym of 'json'. +value :: Parser Value +value = jsonWith (pure . KM.fromList) + +-- | Parse any JSON value. +-- +-- This parser is parameterized by a function to construct an 'Object' +-- from a raw list of key-value pairs, where duplicates are preserved. +-- The pairs appear in __reverse order__ from the source. +-- +-- ==== __Examples__ +-- +-- 'json' keeps only the first occurrence of each key, using 'Data.Aeson.KeyMap.fromList'. +-- +-- @ +-- 'json' = 'jsonWith' ('Right' '.' 'H.fromList') +-- @ +-- +-- 'jsonLast' keeps the last occurrence of each key, using +-- @'HashMap.Lazy.fromListWith' ('const' 'id')@. +-- +-- @ +-- 'jsonLast' = 'jsonWith' ('Right' '.' 'HashMap.Lazy.fromListWith' ('const' 'id')) +-- @ +-- +-- 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using +-- 'fromListAccum'. +-- +-- @ +-- 'jsonAccum' = 'jsonWith' ('Right' . 'fromListAccum') +-- @ +-- +-- 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'. +-- +-- @ +-- 'jsonNoDup' = 'jsonWith' 'parseListNoDup' +-- @ +jsonWith :: ([(Key, Value)] -> Either String Object) -> Parser Value +jsonWith mkObject = fix $ \value_ -> do + skipSpace + w <- A.peekWord8' + case w of + W8_DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_) + W8_OPEN_CURLY -> A.anyWord8 *> object_ mkObject value_ + W8_OPEN_SQUARE -> A.anyWord8 *> array_ value_ + W8_f -> string "false" $> Bool False + W8_t -> string "true" $> Bool True + W8_n -> string "null" $> Null + _ | w >= W8_0 && w <= W8_9 || w == W8_MINUS + -> Number <$> scientific + | otherwise -> fail "not a valid json value" +{-# INLINE jsonWith #-} + +-- | Variant of 'json' which keeps only the last occurrence of every key. +jsonLast :: Parser Value +jsonLast = jsonWith (Right . KM.fromListWith (const id)) + +-- | Variant of 'json' wrapping all object mappings in 'Array' to preserve +-- key-value pairs with the same keys. +jsonAccum :: Parser Value +jsonAccum = jsonWith (Right . fromListAccum) + +-- | Variant of 'json' which fails if any object contains duplicate keys. +jsonNoDup :: Parser Value +jsonNoDup = jsonWith parseListNoDup + +-- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all +-- associated values from the original list @kvs@. +-- +-- >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)] +-- fromList [("apple",Array [Bool False,Bool True]),("orange",Array [Bool False])] +fromListAccum :: [(Key, Value)] -> Object +fromListAccum = + fmap (Array . Vector.fromList . ($ [])) . KM.fromListWith (.) . (fmap . fmap) (:) + +-- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys. +parseListNoDup :: [(Key, Value)] -> Either String Object +parseListNoDup = + KM.traverseWithKey unwrap . KM.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just + where + + unwrap k Nothing = Left $ "found duplicate key: " ++ show k + unwrap _ (Just v) = Right v + +-- | Strict version of 'value'. Synonym of 'json''. +value' :: Parser Value +value' = jsonWith' (pure . KM.fromList) + +-- | Strict version of 'jsonWith'. +jsonWith' :: ([(Key, Value)] -> Either String Object) -> Parser Value +jsonWith' mkObject = fix $ \value_ -> do + skipSpace + w <- A.peekWord8' + case w of + W8_DOUBLE_QUOTE -> do + !s <- A.anyWord8 *> jstring_ + return (String s) + W8_OPEN_CURLY -> A.anyWord8 *> object_' mkObject value_ + W8_OPEN_SQUARE -> A.anyWord8 *> array_' value_ + W8_f -> string "false" $> Bool False + W8_t -> string "true" $> Bool True + W8_n -> string "null" $> Null + _ | w >= W8_0 && w <= W8_9 || w == W8_MINUS + -> do + !n <- scientific + return (Number n) + | otherwise -> fail "not a valid json value" +{-# INLINE jsonWith' #-} + +-- | Variant of 'json'' which keeps only the last occurrence of every key. +jsonLast' :: Parser Value +jsonLast' = jsonWith' (pure . KM.fromListWith (const id)) + +-- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve +-- key-value pairs with the same keys. +jsonAccum' :: Parser Value +jsonAccum' = jsonWith' (pure . fromListAccum) + +-- | Variant of 'json'' which fails if any object contains duplicate keys. +jsonNoDup' :: Parser Value +jsonNoDup' = jsonWith' parseListNoDup + +-- | Parse a quoted JSON string. +jstring :: Parser Text +jstring = A.word8 W8_DOUBLE_QUOTE *> jstring_ + +-- | Parse a JSON Key +key :: Parser Key +key = Key.fromText <$> jstring + +-- | Parse a string without a leading quote. +jstring_ :: Parser Text +{-# INLINE jstring_ #-} +jstring_ = do + s <- A.takeWhile (\w -> w /= W8_DOUBLE_QUOTE && w /= W8_BACKSLASH && w >= 0x20 && w < 0x80) + mw <- A.peekWord8 + case mw of + Nothing -> fail "string without end" + Just W8_DOUBLE_QUOTE -> A.anyWord8 $> unsafeDecodeASCII s + Just w | w < 0x20 -> fail "unescaped control character" + _ -> jstringSlow s + +jstringSlow :: B.ByteString -> Parser Text +{-# INLINE jstringSlow #-} +jstringSlow s' = do + s <- A.scan startState go <* A.anyWord8 + case unescapeText (B.append s' s) of + Right r -> return r + Left err -> fail $ show err + where + startState = False + go a c + | a = Just False + | c == W8_DOUBLE_QUOTE = Nothing + | otherwise = let a' = c == W8_BACKSLASH + in Just a' + +decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a +decodeWith p to s = + case L.parse p s of + L.Done _ v -> case to v of + Success a -> Just a + _ -> Nothing + _ -> Nothing +{-# INLINE decodeWith #-} + +decodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString + -> Maybe a +decodeStrictWith p to s = + case either Error to (A.parseOnly p s) of + Success a -> Just a + _ -> Nothing +{-# INLINE decodeStrictWith #-} + +eitherDecodeWith :: Parser Value -> (Value -> IResult a) -> L.ByteString + -> Either (JSONPath, String) a +eitherDecodeWith p to s = + case L.parse p s of + L.Done _ v -> case to v of + ISuccess a -> Right a + IError path msg -> Left (path, msg) + L.Fail notparsed ctx msg -> Left ([], buildMsg notparsed ctx msg) + where + buildMsg :: L.ByteString -> [String] -> String -> String + buildMsg notYetParsed [] msg = msg ++ formatErrorLine notYetParsed + buildMsg notYetParsed (expectation:_) msg = + msg ++ ". Expecting " ++ expectation ++ formatErrorLine notYetParsed +{-# INLINE eitherDecodeWith #-} + +-- | Grab the first 100 bytes from the non parsed portion and +-- format to get nicer error messages +formatErrorLine :: L.ByteString -> String +formatErrorLine bs = + C.unpack . + -- if formatting results in empty ByteString just return that + -- otherwise construct the error message with the bytestring builder + (\bs' -> + if BSL.null bs' + then BSL.empty + else + B.toLazyByteString $ + B.stringUtf8 " at '" <> B.lazyByteString bs' <> B.stringUtf8 "'" + ) . + -- if newline is present cut at that position + BSL.takeWhile (10 /=) . + -- remove spaces, CR's, tabs, backslashes and quotes characters + BSL.filter (`notElem` [9, 13, 32, 34, 47, 92]) . + -- take 100 bytes + BSL.take 100 $ bs + +eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString + -> Either (JSONPath, String) a +eitherDecodeStrictWith p to s = + case either (IError []) to (A.parseOnly p s) of + ISuccess a -> Right a + IError path msg -> Left (path, msg) +{-# INLINE eitherDecodeStrictWith #-} + +-- $lazy +-- +-- The 'json' and 'value' parsers decouple identification from +-- conversion. Identification occurs immediately (so that an invalid +-- JSON document can be rejected as early as possible), but conversion +-- to a Haskell value is deferred until that value is needed. +-- +-- This decoupling can be time-efficient if only a smallish subset of +-- elements in a JSON value need to be inspected, since the cost of +-- conversion is zero for uninspected elements. The trade off is an +-- increase in memory usage, due to allocation of thunks for values +-- that have not yet been converted. + +-- $strict +-- +-- The 'json'' and 'value'' parsers combine identification with +-- conversion. They consume more CPU cycles up front, but have a +-- smaller memory footprint. + +-- | Parse a top-level JSON value followed by optional whitespace and +-- end-of-input. See also: 'json'. +jsonEOF :: Parser Value +jsonEOF = json <* skipSpace <* endOfInput + +-- | Parse a top-level JSON value followed by optional whitespace and +-- end-of-input. See also: 'json''. +jsonEOF' :: Parser Value +jsonEOF' = json' <* skipSpace <* endOfInput + +-- | The only valid whitespace in a JSON document is space, newline, +-- carriage return, and tab. +skipSpace :: Parser () +skipSpace = A.skipWhile $ \w -> w == W8_SPACE || w == W8_NL || w == W8_CR || w == W8_TAB +{-# INLINE skipSpace #-} + +------------------ Copy-pasted and adapted from attoparsec ------------------ + +-- A strict pair +data SP = SP !Integer {-# UNPACK #-}!Int + +decimal0 :: Parser Integer +decimal0 = do + digits <- A.takeWhile1 isDigit_w8 + if B.length digits > 1 && B.unsafeHead digits == W8_0 + then fail "leading zero" + else return (byteStringToInteger digits) + +-- | Parse a JSON number. +scientific :: Parser Scientific +scientific = do + sign <- A.peekWord8' + let !positive = not (sign == W8_MINUS) + when (sign == W8_PLUS || sign == W8_MINUS) $ + void A.anyWord8 + + n <- decimal0 + + let f fracDigits = SP (B.foldl' step n fracDigits) + (negate $ B.length fracDigits) + step a w = a * 10 + fromIntegral (w - W8_0) + + dotty <- A.peekWord8 + SP c e <- case dotty of + Just W8_DOT -> A.anyWord8 *> (f <$> A.takeWhile1 isDigit_w8) + _ -> pure (SP n 0) + + let !signedCoeff | positive = c + | otherwise = -c + + (A.satisfy (\ex -> case ex of W8_e -> True; W8_E -> True; _ -> False) *> + fmap (Sci.scientific signedCoeff . (e +)) (signed decimal)) <|> + return (Sci.scientific signedCoeff e) +{-# INLINE scientific #-}