diff --git a/Data/Aeson/Parser/Internal.hs b/Data/Aeson/Parser/Internal.hs --- a/Data/Aeson/Parser/Internal.hs +++ b/Data/Aeson/Parser/Internal.hs @@ -38,10 +38,6 @@ import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..)) import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific, skipSpace, string) -import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific, skipSpace, string) -import Data.Bits ((.|.), shiftL) -import Data.ByteString.Internal (ByteString(..)) -import Data.Char (chr) import Data.Text (Text) import Data.Vector as Vector (Vector, empty, fromListN, reverse) import qualified Data.Attoparsec.ByteString as A diff --git a/Data/Aeson/TH.hs b/Data/Aeson/TH.hs --- a/Data/Aeson/TH.hs +++ b/Data/Aeson/TH.hs @@ -13,6 +13,7 @@ {-# LANGUAGE TemplateHaskell #-} #endif +#include "incoherent-compat.h" #include "overlapping-compat.h" {-| @@ -1222,7 +1223,7 @@ instance OVERLAPPABLE_ LookupField a where lookupField = lookupFieldWith -instance LookupField (Maybe a) where +instance INCOHERENT_ LookupField (Maybe a) where lookupField pj _ _ = parseOptionalFieldWith pj lookupFieldWith :: (Value -> Parser a) -> String -> String diff --git a/Data/Aeson/Types/FromJSON.hs b/Data/Aeson/Types/FromJSON.hs --- a/Data/Aeson/Types/FromJSON.hs +++ b/Data/Aeson/Types/FromJSON.hs @@ -18,6 +18,7 @@ {-# LANGUAGE PolyKinds #-} #endif +#include "incoherent-compat.h" #include "overlapping-compat.h" -- TODO: Drop this when we remove support for Data.Attoparsec.Number @@ -942,9 +943,8 @@ (:*:) <$> parseRecord opts fargs Nothing obj <*> parseRecord opts fargs Nothing obj -instance ( Selector s - , GFromJSON arity a - ) => FromRecord arity (S1 s a) where +instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) => + FromRecord arity (S1 s a) where parseRecord opts fargs lab = ( Key label) . gParseJSON opts fargs <=< (.: label) where @@ -952,7 +952,7 @@ defLabel = pack . fieldLabelModifier opts $ selName (undefined :: t s a p) -instance OVERLAPPING_ (Selector s, FromJSON a) => +instance INCOHERENT_ (Selector s, FromJSON a) => FromRecord arity (S1 s (K1 i (Maybe a))) where parseRecord _ _ (Just lab) obj = (M1 . K1) <$> obj .:? lab parseRecord opts _ Nothing obj = (M1 . K1) <$> obj .:? pack label diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,12 +1,12 @@ name: aeson -version: 1.0.1.0 +version: 1.0.2.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON copyright: (c) 2011-2016 Bryan O'Sullivan (c) 2011 MailRank, Inc. author: Bryan O'Sullivan -maintainer: Bryan O'Sullivan +maintainer: Adam Bergmark stability: experimental tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 synopsis: Fast JSON parsing and encoding @@ -47,6 +47,7 @@ benchmarks/Typed/*.hs benchmarks/json-data/*.json include/overlapping-compat.h + include/incoherent-compat.h changelog.md examples/*.cabal examples/*.hs @@ -173,7 +174,7 @@ build-depends: HUnit, - QuickCheck >= 2.7 && <2.9.2, + QuickCheck >= 2.7 && <2.9.3, aeson, attoparsec, base, diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,12 @@ For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md). -# 1.0.1.0 +### 1.0.2.0 + +* Fixes a regression where it was no longer possible to derive + instances for types such as `data T a = T { f1 :: a, f2 :: Maybe a }`. + The fix is available on GHC >= 7.10. + +### 1.0.1.0 * Decoding performance has been significantly improved (see https://github.com/bos/aeson/pull/452). diff --git a/include/incoherent-compat.h b/include/incoherent-compat.h new file mode 100644 --- /dev/null +++ b/include/incoherent-compat.h @@ -0,0 +1,7 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define INCOHERENT_ {-# INCOHERENT #-} +#else +-- This causes some type class instances to break: +-- {-# LANGUAGE IncoherentInstances #-} +#define INCOHERENT_ +#endif diff --git a/tests/Encoders.hs b/tests/Encoders.hs --- a/tests/Encoders.hs +++ b/tests/Encoders.hs @@ -235,6 +235,25 @@ gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields +-------------------------------------------------------------------------------- +-- IncoherentInstancesNeeded +-------------------------------------------------------------------------------- + +-- | This test demonstrates the need for IncoherentInstances. See the definition +-- of 'IncoherentInstancesNeeded' for a discussion of the issue. +-- +-- NOTE 1: We only need to compile this test. We do not need to run it. +-- +-- NOTE 2: We actually only use the INCOHERENT pragma on specific instances +-- instead of the IncoherentInstances language extension. Therefore, this is +-- only supported on GHC versions >= 7.10. +#if __GLASGOW_HASKELL__ >= 710 +incoherentInstancesNeededParseJSONString :: FromJSON a => Value -> Parser (IncoherentInstancesNeeded a) +incoherentInstancesNeededParseJSONString = case () of + _ | True -> $(mkParseJSON defaultOptions ''IncoherentInstancesNeeded) + | False -> genericParseJSON defaultOptions +#endif + ------------------------------------------------------------------------------- -- EitherTextInt encoders/decodes ------------------------------------------------------------------------------- diff --git a/tests/Types.hs b/tests/Types.hs --- a/tests/Types.hs +++ b/tests/Types.hs @@ -70,6 +70,18 @@ | List [a] deriving (Eq, Show) +-- | This type requires IncoherentInstances for the instances of the type +-- classes Data.Aeson.TH.LookupField and Data.Aeson.Types.FromJSON.FromRecord. +-- +-- The minimum known requirements for this type are: +-- * Record type with at least two fields +-- * One field type is either a type parameter or a type/data family +-- * Another field type is a @Maybe@ of the above field type +data IncoherentInstancesNeeded a = IncoherentInstancesNeeded + { incoherentInstancesNeededMaybeNot :: a + , incoherentInstancesNeededMaybeYes :: Maybe a + } deriving Generic + -- Used for testing UntaggedValue SumEncoding data EitherTextInt = LeftBool Bool