master...9e30cc9 · typeable/aeson

git.iko.soy/typeable/aeson

6 files changed+108−33

since splitsnapshots

unifiedsplit

Data/Aeson.hs+2−2 Data/Aeson/Parser/Internal.hs+30−5 Data/Aeson/TH.hs+37−13 Data/Aeson/Types.hs+1 Data/Aeson/Types/Internal.hs+30−13 tests/UnitTests.hs+8

Data/Aeson.hs+2−2

@@ -257,7 +257,7 @@ eitherDecodeStrict =

257257-- | Like 'decodeFileStrict' but returns an error message when decoding fails.

258258eitherDecodeFileStrict :: (FromJSON a) => FilePath -> IO (Either String a)

259259eitherDecodeFileStrict =

260− fmap (eitherFormatError . eitherDecodeStrictWith jsonEOF ifromJSON) . B.readFile

260+ fmap eitherDecodeStrict . B.readFile

261261{-# INLINE eitherDecodeFileStrict #-}

262262

263263-- | Like 'decode'' but returns an error message when decoding fails.

@@ -274,7 +274,7 @@ eitherDecodeStrict' =

274274-- | Like 'decodeFileStrict'' but returns an error message when decoding fails.

275275eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a)

276276eitherDecodeFileStrict' =

277− fmap (eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON) . B.readFile

277+ fmap eitherDecodeStrict' . B.readFile

278278{-# INLINE eitherDecodeFileStrict' #-}

279279

280280-- $use

Data/Aeson/Parser/Internal.hs+30−5

@@ -59,6 +59,7 @@ import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDi

5959import Data.Function (fix)

6060import Data.Functor.Compat (($>))

6161import Data.Scientific (Scientific)

62+import Data.Semigroup ((<>))

6263import Data.Text (Text)

6364import Data.Vector (Vector)

6465import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse)

@@ -67,6 +68,9 @@ import qualified Data.Attoparsec.Lazy as L

6768import qualified Data.ByteString as B

6869import qualified Data.ByteString.Unsafe as B

6970import qualified Data.ByteString.Lazy as L

71+import qualified Data.ByteString.Lazy as BSL

72+import qualified Data.ByteString.Lazy.Char8 as C

73+import qualified Data.ByteString.Builder as B

7074import qualified Data.HashMap.Strict as H

7175import qualified Data.Scientific as Sci

7276import Data.Aeson.Parser.Unescape (unescapeText)

@@ -390,14 +394,35 @@ eitherDecodeWith p to s =

390394 L.Done _ v -> case to v of

391395 ISuccess a -> Right a

392396 IError path msg -> Left (path, msg)

393− L.Fail _ ctx msg -> Left ([], buildMsg ctx msg)

397+ L.Fail notparsed ctx msg -> Left ([], buildMsg notparsed ctx msg)

394398 where

395− buildMsg :: [String] -> String -> String

396− buildMsg [] msg = msg

397− buildMsg (expectation:_) msg =

398− msg ++ ". Expecting " ++ expectation

399+ buildMsg :: L.ByteString -> [String] -> String -> String

400+ buildMsg notYetParsed [] msg = msg ++ formatErrorLine notYetParsed

401+ buildMsg notYetParsed (expectation:_) msg =

402+ msg ++ ". Expecting " ++ expectation ++ formatErrorLine notYetParsed

399403{-# INLINE eitherDecodeWith #-}

400404

405+-- | Grab the first 100 bytes from the non parsed portion and

406+-- format to get nicer error messages

407+formatErrorLine :: L.ByteString -> String

408+formatErrorLine bs =

409+ C.unpack .

410+ -- if formatting results in empty ByteString just return that

411+ -- otherwise construct the error message with the bytestring builder

412+ (\bs' ->

413+ if BSL.null bs'

414+ then BSL.empty

415+ else

416+ B.toLazyByteString $

417+ B.stringUtf8 " at '" <> B.lazyByteString bs' <> B.stringUtf8 "'"

418+ ) .

419+ -- if newline is present cut at that position

420+ BSL.takeWhile (10 /=) .

421+ -- remove spaces, CR's, tabs, backslashes and quotes characters

422+ BSL.filter (`notElem` [9, 13, 32, 34, 47, 92]) .

423+ -- take 100 bytes

424+ BSL.take 100 $ bs

425+

401426eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString

402427 -> Either (JSONPath, String) a

403428eitherDecodeStrictWith p to s =

Data/Aeson/TH.hs+37−13

@@ -1304,9 +1304,8 @@ dispatchFunByType jc jf conName tvMap list ty = do

13041304 tyVarNames :: [Name]

13051305 tyVarNames = M.keys tvMap

13061306

1307− itf <- isTyFamily tyCon

1308− if any (`mentionsName` tyVarNames) lhsArgs

1309− || itf && any (`mentionsName` tyVarNames) tyArgs

1307+ itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs

1308+ if any (`mentionsName` tyVarNames) lhsArgs || itf

13101309 then outOfPlaceTyVarError jc conName

13111310 else if any (`mentionsName` tyVarNames) rhsArgs

13121311 then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs)

@@ -1657,19 +1656,44 @@ isTyVar (VarT _) = True

16571656isTyVar (SigT t _) = isTyVar t

16581657isTyVar _ = False

16591658

1660−-- | Is the given type a type family constructor (and not a data family constructor)?

1661−isTyFamily :: Type -> Q Bool

1662−isTyFamily (ConT n) = do

1663− info <- reify n

1664− return $ case info of

1659+-- | Detect if a Name in a list of provided Names occurs as an argument to some

1660+-- type family. This makes an effort to exclude /oversaturated/ arguments to

1661+-- type families. For instance, if one declared the following type family:

1662+--

1663+-- @

1664+-- type family F a :: Type -> Type

1665+-- @

1666+--

1667+-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,

1668+-- but not @b@.

1669+isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool

1670+isInTypeFamilyApp names tyFun tyArgs =

1671+ case tyFun of

1672+ ConT tcName -> go tcName

1673+ _ -> return False

1674+ where

1675+ go :: Name -> Q Bool

1676+ go tcName = do

1677+ info <- reify tcName

1678+ case info of

16651679#if MIN_VERSION_template_haskell(2,11,0)

1666− FamilyI OpenTypeFamilyD{} _ -> True

1680+ FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _

1681+ -> withinFirstArgs bndrs

1682+ FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _

1683+ -> withinFirstArgs bndrs

16671684#else

1668− FamilyI (FamilyD TypeFam _ _ _) _ -> True

1685+ FamilyI (FamilyD TypeFam _ bndrs _) _

1686+ -> withinFirstArgs bndrs

1687+ FamilyI (ClosedTypeFamilyD _ bndrs _ _) _

1688+ -> withinFirstArgs bndrs

16691689#endif

1670− FamilyI ClosedTypeFamilyD{} _ -> True

1671− _ -> False

1672−isTyFamily _ = return False

1690+ _ -> return False

1691+ where

1692+ withinFirstArgs :: [a] -> Q Bool

1693+ withinFirstArgs bndrs =

1694+ let firstArgs = take (length bndrs) tyArgs

1695+ argFVs = freeVariables firstArgs

1696+ in return $ any (`elem` argFVs) names

16731697

16741698-- | Peel off a kind signature from a Type (if it has one).

16751699unSigT :: Type -> Type

Data/Aeson/Types.hs+1

@@ -35,6 +35,7 @@ module Data.Aeson.Types

3535 , parse

3636 , parseEither

3737 , parseMaybe

38+ , parseFail

3839 , ToJSON(..)

3940 , KeyValue(..)

4041 , modifyFailure

Data/Aeson/Types/Internal.hs+30−13

@@ -44,6 +44,7 @@ module Data.Aeson.Types.Internal

4444 , parse

4545 , parseEither

4646 , parseMaybe

47+ , parseFail

4748 , modifyFailure

4849 , prependFailure

4950 , parserThrowError

@@ -342,6 +343,10 @@ instance Monoid (Parser a) where

342343 mappend = (<>)

343344 {-# INLINE mappend #-}

344345

346+-- | Raise a parsing failure with some custom message.

347+parseFail :: String -> Parser a

348+parseFail = fail

349+

345350apP :: Parser (a -> b) -> Parser a -> Parser b

346351apP d e = do

347352 b <- d

@@ -581,41 +586,53 @@ data Options = Options

581586 -- the constructor tag. If 'False' the encoding will always

582587 -- follow the `sumEncoding`.

583588 , omitNothingFields :: Bool

584− -- ^ If 'True' record fields with a 'Nothing' value will be

585− -- omitted from the resulting object. If 'False' the resulting

589+ -- ^ If 'True', record fields with a 'Nothing' value will be

590+ -- omitted from the resulting object. If 'False', the resulting

586591 -- object will include those fields mapping to @null@.

587592 --

593+ -- Note that this /does not/ affect parsing: 'Maybe' fields are

594+ -- optional regardless of the value of 'omitNothingFields', subject

595+ -- to the note below.

596+ --

588597 -- === Note

589598 --

590599 -- Setting 'omitNothingFields' to 'True' only affects fields which are of

591− -- type 'Maybe' /uniformly/ in the 'ToJSON' or 'FromJSON' instance. In

592− -- particular, if the type of a field is declared as a type variable, it

600+ -- type 'Maybe' /uniformly/ in the 'ToJSON' instance.

601+ -- In particular, if the type of a field is declared as a type variable, it

593602 -- will not be omitted from the JSON object, unless the field is

594603 -- specialized upfront in the instance.

595604 --

605+ -- The same holds for 'Maybe' fields being optional in the 'FromJSON' instance.

606+ --

596607 -- ==== __Example__

597608 --

598609 -- The generic instance for the following type @Fruit@ depends on whether

599610 -- the instance head is @Fruit a@ or @Fruit (Maybe a)@.

600611 --

601612 -- @

602− -- data Fruit a =

613+ -- data Fruit a = Fruit

603614 -- { apples :: a -- A field whose type is a type variable.

604615 -- , oranges :: 'Maybe' Int

605− -- }

606− --

607− -- options :: 'Options'

608− -- options = 'defaultOptions' { 'omitNothingFields' = 'True' }

616+ -- } deriving 'Generic'

609617 --

610618 -- -- apples required, oranges optional

611619 -- -- Even if 'Data.Aeson.fromJSON' is then specialized to (Fruit ('Maybe' a)).

612− -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit a) where

613− -- 'Data.Aeson.fromJSON' = 'Data.Aeson.genericFromJSON' options

620+ -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit a)

614621 --

615622 -- -- apples optional, oranges optional

616623 -- -- In this instance, the field apples is uniformly of type ('Maybe' a).

617− -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit ('Maybe' a)) where

618− -- 'Data.Aeson.fromJSON' = 'Data.Aeson.genericFromJSON' options

624+ -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit ('Maybe' a))

625+ --

626+ -- options :: 'Options'

627+ -- options = 'defaultOptions' { 'omitNothingFields' = 'True' }

628+ --

629+ -- -- apples always present in the output, oranges is omitted if 'Nothing'

630+ -- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit a) where

631+ -- 'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options

632+ --

633+ -- -- both apples and oranges are omitted if 'Nothing'

634+ -- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit ('Maybe' a)) where

635+ -- 'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options

619636 -- @

620637 , sumEncoding :: SumEncoding

621638 -- ^ Specifies how to encode constructors of a sum datatype.

tests/UnitTests.hs+8

@@ -5,6 +5,7 @@

55{-# LANGUAGE OverloadedStrings #-}

66{-# LANGUAGE ScopedTypeVariables #-}

77{-# LANGUAGE TemplateHaskell #-}

8+{-# LANGUAGE TypeFamilies #-}

89{-# LANGUAGE QuasiQuotes #-}

910

1011-- For Data.Aeson.Types.camelTo

@@ -747,6 +748,11 @@ bigNaturalKeyDecoding =

747748 (Left "Error in $['1e2000']: found a number with exponent 2000, but it must not be greater than 1024")

748749 ((eitherDecode :: L.ByteString -> Either String (HashMap Natural Value)) "{ \"1e2000\": null }")

749750

751+-- A regression test for: https://github.com/bos/aeson/issues/757

752+type family Fam757 :: * -> *

753+type instance Fam757 = Maybe

754+newtype Newtype757 a = MkNewtype757 (Fam757 a)

755+

750756deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord

751757

752758deriveToJSON defaultOptions ''Foo

@@ -758,3 +764,5 @@ deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFields

758764deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsTag

759765deriveJSON defaultOptions{tagSingleConstructors=True,rejectUnknownFields=True} ''UnknownFieldsUnaryTagged

760766deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsSum

767+

768+deriveToJSON1 defaultOptions ''Newtype757