{-# LANGUAGE BangPatterns #-}{-# LANGUAGE CPP #-}{-# LANGUAGE NoImplicitPrelude #-}{-# LANGUAGE OverloadedStrings #-}#if MIN_VERSION_ghc_prim(0,3,1)
{-# LANGUAGE MagicHash #-}#endif
#if __GLASGOW_HASKELL__ <= 710 && __GLASGOW_HASKELL__ >= 706
-- Work around a compiler bug{-# OPTIONS_GHC -fsimpl-tick-factor=200 #-}#endif
-- |-- Module: Data.Aeson.Parser.Internal-- Copyright: (c) 2011-2016 Bryan O'Sullivan-- (c) 2011 MailRank, Inc.-- License: BSD3-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>-- Stability: experimental-- Portability: portable---- Efficiently and correctly parse a JSON string. The string must be-- encoded as UTF-8.moduleData.Aeson.Parser.Internal(-- * Lazy parsersjson ,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 )whereimportPrelude.CompatimportControl.Applicative((<|>))importControl.Monad(void,when)importData.Aeson.Types.Internal (IResult (..),JSONPath ,Object ,Result (..),Value (..))importData.Attoparsec.ByteString.Char8(Parser,char,decimal,endOfInput,isDigit_w8,signed,string)importData.Function(fix)importData.Functor.Compat(($>))importData.Scientific(Scientific)importData.Text(Text)importData.Vector(Vector)importqualifiedData.VectorasVector(empty,fromList,fromListN,reverse)importqualifiedData.Attoparsec.ByteStringasAimportqualifiedData.Attoparsec.LazyasLimportqualifiedData.ByteStringasBimportqualifiedData.ByteString.UnsafeasBimportqualifiedData.ByteString.LazyasLimportqualifiedData.HashMap.StrictasHimportqualifiedData.ScientificasSciimportData.Aeson.Parser.Unescape (unescapeText )#if MIN_VERSION_ghc_prim(0,3,1)
importGHC.Base(Int#,(==#),isTrue#,word2Int#,orI#,andI#)importGHC.Word(Word8(W8#))importqualifiedData.Text.EncodingasTE#endif
#define BACKSLASH 92
#define CLOSE_CURLY 125
#define CLOSE_SQUARE 93
#define COMMA 44
#define DOUBLE_QUOTE 34
#define OPEN_CURLY 123
#define OPEN_SQUARE 91
#define C_0 48
#define C_9 57
#define C_A 65
#define C_F 70
#define C_a 97
#define C_f 102
#define C_n 110
#define C_t 116
-- | 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::ParserValue 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'::ParserValue 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_::([(Text,Value )]->EitherStringObject )->ParserValue ->ParserValue object_ mkObject val ={-# SCC"object_"#-}Object <$>objectValues mkObject jstring val {-# INLINEobject_#-}object_'::([(Text,Value )]->EitherStringObject )->ParserValue ->ParserValue object_' mkObject val' ={-# SCC"object_'"#-}do!vals <-objectValues mkObject jstring' val' return(Object vals )wherejstring' =do!s <-jstring returns {-# INLINEobject_'#-}objectValues::([(Text,Value )]->EitherStringObject )->ParserText->ParserValue ->Parser(H.HashMapTextValue )objectValues mkObject str val =doskipSpace w <-A.peekWord8'ifw ==CLOSE_CURLYthenA.anyWord8>>returnH.emptyelseloop []where-- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'-- and it's much faster because it's doing in place update to the 'HashMap'!loop acc =dok <-(str A.<?>"object key")<*skipSpace <*(char':'A.<?>"':'")v <-(val A.<?>"object value")<*skipSpace ch <-A.satisfy(\w ->w ==COMMA||w==CLOSE_CURLY)A.<?>"',' or '}'"letacc' =(k ,v ):acc ifch ==COMMAthenskipSpace >>loop acc' elsecasemkObject acc' ofLefterr ->failerr Rightobj ->pureobj {-# INLINEobjectValues#-}array_::ParserValue ->ParserValue array_ val ={-# SCC"array_"#-}Array <$>arrayValues val {-# INLINEarray_#-}array_'::ParserValue ->ParserValue array_' val ={-# SCC"array_'"#-}do!vals <-arrayValues val return(Array vals ){-# INLINEarray_'#-}arrayValues::ParserValue ->Parser(VectorValue )arrayValues val =doskipSpace w <-A.peekWord8'ifw ==CLOSE_SQUAREthenA.anyWord8>>returnVector.emptyelseloop []1whereloop acc !len =dov <-(val A.<?>"json list value")<*skipSpace ch <-A.satisfy(\w ->w ==COMMA||w==CLOSE_SQUARE)A.<?>"',' or ']'"ifch ==COMMAthenskipSpace >>loop (v :acc )(len +1)elsereturn(Vector.reverse(Vector.fromListNlen (v :acc ))){-# INLINEarrayValues#-}-- | Parse any JSON value. Synonym of 'json'.value::ParserValue value =jsonWith (pure.H.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 occurence of each key, using 'HashMap.Lazy.fromList'.---- @-- 'json' = 'jsonWith' ('Right' '.' 'H.fromList')-- @---- 'jsonLast' keeps the last occurence 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::([(Text,Value )]->EitherStringObject )->ParserValue jsonWith mkObject =fix$\value_ ->doskipSpace w <-A.peekWord8'casew ofDOUBLE_QUOTE->A.anyWord8*>(String<$>jstring_)OPEN_CURLY->A.anyWord8*> object_mkObjectvalue_OPEN_SQUARE->A.anyWord8*>array_value_C_f->string"false"$>Bool FalseC_t->string"true"$>Bool TrueC_n->string"null"$>Null _|w >=48&&w <=57||w ==45->Number <$>scientific |otherwise->fail"not a valid json value"{-# INLINEjsonWith#-}-- | Variant of 'json' which keeps only the last occurence of every key.jsonLast::ParserValue jsonLast =jsonWith (Right.H.fromListWith(constid))-- | Variant of 'json' wrapping all object mappings in 'Array' to preserve-- key-value pairs with the same keys.jsonAccum::ParserValue jsonAccum =jsonWith (Right.fromListAccum )-- | Variant of 'json' which fails if any object contains duplicate keys.jsonNoDup::ParserValue 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", [Bool False, Bool True]), ("orange", [Bool False])]fromListAccum::[(Text,Value )]->Object fromListAccum =fmap(Array .Vector.fromList.($[])).H.fromListWith(.).(fmap.fmap)(:)-- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.parseListNoDup::[(Text,Value )]->EitherStringObject parseListNoDup =H.traverseWithKeyunwrap .H.fromListWith(\__->Nothing).(fmap.fmap)Justwhereunwrap k Nothing=Left$"found duplicate key: "++showk unwrap_(Justv )=Rightv -- | Strict version of 'value'. Synonym of 'json''.value'::ParserValue value' =jsonWith' (pure.H.fromList)-- | Strict version of 'jsonWith'.jsonWith'::([(Text,Value )]->EitherStringObject )->ParserValue jsonWith' mkObject =fix$\value_ ->doskipSpace w <-A.peekWord8'casew ofDOUBLE_QUOTE->do!s <-A.anyWord8*>jstring_ return(String s )OPEN_CURLY->A.anyWord8*> object_'mkObjectvalue_OPEN_SQUARE->A.anyWord8*>array_'value_C_f->string"false"$>Bool FalseC_t->string"true"$>Bool TrueC_n->string"null"$>Null _|w >=48&&w <=57||w ==45->do!n <-scientific return(Number n )|otherwise->fail"not a valid json value"{-# INLINEjsonWith'#-}-- | Variant of 'json'' which keeps only the last occurence of every key.jsonLast'::ParserValue jsonLast' =jsonWith' (pure.H.fromListWith(constid))-- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve-- key-value pairs with the same keys.jsonAccum'::ParserValue jsonAccum' =jsonWith' (pure.fromListAccum )-- | Variant of 'json'' which fails if any object contains duplicate keys.jsonNoDup'::ParserValue jsonNoDup' =jsonWith' parseListNoDup -- | Parse a quoted JSON string.jstring::ParserTextjstring =A.word8DOUBLE_QUOTE*>jstring_-- | Parse a string without a leading quote.jstring_::ParserText{-# INLINEjstring_#-}jstring_ ={-# SCC"jstring_"#-}do#if MIN_VERSION_ghc_prim(0,3,1)
(s ,S _escaped )<-A.runScannerstartState go <*A.anyWord8-- We escape only if there are-- non-ascii (over 7bit) characters or backslash present.---- Note: if/when text will have fast ascii -> text conversion-- (e.g. uses utf8 encoding) we can have further speedup.ifisTrue#escaped thencaseunescapeText s ofRightr ->returnr Lefterr ->fail$showerr elsereturn(TE.decodeUtf8s )wherestartState =S 0#0#go (S skip escaped )(W8#c )|isTrue#skip =Just(S 0#escaped' )|isTrue#(w ==#34#)=Nothing-- double quote|otherwise=Just(S skip' escaped' )wherew =word2Int#c skip' =w ==#92#-- backslashescaped' =escaped `orI#`(w `andI#`0x80#==#0x80#)-- c >= 0x80`orI#`skip' `orI#`(w `andI#`0x1f#==#w )-- c < 0x20dataS =S Int#Int##else
s<-A.scanstartStatego<*A.anyWord8caseunescapeTextsofRightr->returnrLefterr->fail$showerrwherestartState=Falsegoac|a=JustFalse|c==DOUBLE_QUOTE=Nothing|otherwise=leta'=c==backslashinJusta'wherebackslash=BACKSLASH#endif
decodeWith::ParserValue ->(Value ->Result a )->L.ByteString->Maybea decodeWith p to s =caseL.parsep s ofL.Done_v ->caseto v ofSuccess a ->Justa _->Nothing_->Nothing{-# INLINEdecodeWith#-}decodeStrictWith::ParserValue ->(Value ->Result a )->B.ByteString->Maybea decodeStrictWith p to s =caseeitherError to (A.parseOnlyp s )ofSuccess a ->Justa _->Nothing{-# INLINEdecodeStrictWith#-}eitherDecodeWith::ParserValue ->(Value ->IResult a )->L.ByteString->Either(JSONPath ,String)a eitherDecodeWith p to s =caseL.parsep s ofL.Done_v ->caseto v ofISuccess a ->Righta IError path msg ->Left(path ,msg )L.Fail_ctx msg ->Left([],buildMsg ctx msg )wherebuildMsg::[String]->String->StringbuildMsg []msg =msg buildMsg(expectation :_)msg =msg ++". Expecting "++expectation {-# INLINEeitherDecodeWith#-}eitherDecodeStrictWith::ParserValue ->(Value ->IResult a )->B.ByteString->Either(JSONPath ,String)a eitherDecodeStrictWith p to s =caseeither(IError [])to (A.parseOnlyp s )ofISuccess a ->Righta IError path msg ->Left(path ,msg ){-# INLINEeitherDecodeStrictWith#-}-- $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::ParserValue jsonEOF =json <*skipSpace <*endOfInput-- | Parse a top-level JSON value followed by optional whitespace and-- end-of-input. See also: 'json''.jsonEOF'::ParserValue 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 ==0x20||w ==0x0a||w ==0x0d||w ==0x09{-# INLINEskipSpace#-}------------------ Copy-pasted and adapted from attoparsec -------------------- A strict pairdataSP =SP !Integer{-# UNPACK#-}!Intdecimal0::ParserIntegerdecimal0 =doletzero =48digits <-A.takeWhile1isDigit_w8ifB.lengthdigits >1&&B.unsafeHeaddigits ==zero thenfail"leading zero"elsereturn(bsToInteger digits )-- | Parse a JSON number.scientific::ParserScientificscientific =doletminus =45plus =43sign <-A.peekWord8'let!positive =sign ==plus ||sign /=minus when(sign ==plus ||sign ==minus )$voidA.anyWord8n <-decimal0 letf fracDigits =SP (B.foldl'step n fracDigits )(negate$B.lengthfracDigits )step a w =a *10+fromIntegral(w -48)dotty <-A.peekWord8-- '.' -> ascii 46SP c e <-casedotty ofJust46->A.anyWord8*>(f <$>A.takeWhile1isDigit_w8)_->pure(SP n 0)let!signedCoeff |positive =c |otherwise=-c letlittleE =101bigE =69(A.satisfy(\ex ->ex ==littleE ||ex ==bigE )*>fmap(Sci.scientificsignedCoeff .(e +))(signeddecimal))<|>return(Sci.scientificsignedCoeff e ){-# INLINEscientific#-}------------------ Copy-pasted and adapted from base ------------------------bsToInteger::B.ByteString->IntegerbsToInteger bs |l >40=valInteger 10l [fromIntegral(w -48)|w <-B.unpackbs ]|otherwise=bsToIntegerSimple bs wherel =B.lengthbs bsToIntegerSimple::B.ByteString->IntegerbsToIntegerSimple =B.foldl'step 0wherestep a b =a *10+fromIntegral(b -48)-- 48 = '0'-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b-- digits are combined into a single radix b^2 digit. This process is-- repeated until we are left with a single digit. This algorithm-- performs well only on large inputs, so we use the simple algorithm-- for smaller inputs.valInteger::Integer->Int->[Integer]->IntegervalInteger =go wherego::Integer->Int->[Integer]->Integergo __[]=0go__[d ]=d gob l ds |l >40=b' `seq`go b' l' (combine b ds' )|otherwise=valSimple b ds where-- ensure that we have an even number of digits-- before we call combine:ds' =ifevenl thends else0:ds b' =b *b l' =(l +1)`quot`2combine b (d1 :d2 :ds )=d `seq`(d :combine b ds )whered =d1 *b +d2 combine_[]=[]combine_[_]=errorWithoutStackTrace"this should not happen"-- The following algorithm is only linear for types whose Num operations-- are in constant time.valSimple::Integer->[Integer]->IntegervalSimple base =go 0wherego r []=r gor (d :ds )=r' `seq`go r' ds wherer' =r *base +fromIntegrald