diff --git a/composite-aeson.cabal b/composite-aeson.cabal --- a/composite-aeson.cabal +++ b/composite-aeson.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.3. +-- This file has been generated from package.yaml by hpack version 0.34.5. -- -- see: https://github.com/sol/hpack -- --- hash: 684ff7558a2f16e5bba77f441093b403df9653bd523915ff4733380484d28c1d +-- hash: 15940f55e4ff012339686c8d68ef398a5eb7acbcd09b10646b4b1f92cf09604f name: composite-aeson -version: 0.7.5.0 +version: 0.8.0.0 synopsis: JSON for Vinyl records description: Integration between Aeson and Vinyl records allowing records to be easily converted to JSON using automatic derivation, explicit formats, or a mix of both. category: Records @@ -36,29 +36,50 @@ Paths_composite_aeson hs-source-dirs: src - default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns + default-extensions: + DataKinds + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns ghc-options: -Wall -O2 build-depends: - aeson >=1.1.2.0 && <1.6 + aeson >=1.1.2.0 && <2.1 , aeson-better-errors >=0.9.1.0 && <0.10 - , base >=4.7 && <5 - , composite-base >=0.7 && <0.8 + , base >=4.12 && <5 + , composite-base ==0.8.* , containers >=0.5.7.0 && <0.7 , contravariant >=1.4 && <1.6 - , generic-deriving >=1.11.2 && <1.14 + , generic-deriving >=1.11.2 && <1.15 , hashable >=1.2.6.1 && <1.4 - , lens >=4.15.4 && <5.1 + , lens >=4.15.4 && <5.2 , mmorph >=1.0.9 && <1.2 , mtl >=2.2.1 && <2.3 - , profunctors >=5.2.1 && <5.6 + , profunctors >=5.2.1 && <5.7 , scientific >=0.3.5.1 && <0.4 , tagged >=0.8.5 && <0.9 - , template-haskell >=2.11.1.0 && <2.17 + , template-haskell >=2.11.1.0 && <2.19 , text >=1.2.2.2 && <1.3 - , time >=1.6.0.1 && <1.10 + , time >=1.6.0.1 && <1.12 , unordered-containers >=0.2.8.0 && <0.3 , vector >=0.12.0.1 && <0.13 - , vinyl >=0.5.3 && <0.14 + , vinyl >=0.5.3 && <0.15 default-language: Haskell2010 test-suite composite-aeson-test @@ -74,31 +95,52 @@ Paths_composite_aeson hs-source-dirs: test - default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns + default-extensions: + DataKinds + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans build-depends: QuickCheck - , aeson >=1.1.2.0 && <1.6 + , aeson >=1.1.2.0 && <2.1 , aeson-better-errors >=0.9.1.0 && <0.10 , aeson-qq - , base >=4.7 && <5 + , base >=4.12 && <5 , composite-aeson - , composite-base >=0.7 && <0.8 + , composite-base ==0.8.* , containers >=0.5.7.0 && <0.7 , contravariant >=1.4 && <1.6 - , generic-deriving >=1.11.2 && <1.14 + , generic-deriving >=1.11.2 && <1.15 , hashable >=1.2.6.1 && <1.4 , hspec - , lens >=4.15.4 && <5.1 + , lens >=4.15.4 && <5.2 , mmorph >=1.0.9 && <1.2 , mtl >=2.2.1 && <2.3 - , profunctors >=5.2.1 && <5.6 + , profunctors >=5.2.1 && <5.7 , scientific >=0.3.5.1 && <0.4 , tagged >=0.8.5 && <0.9 - , template-haskell >=2.11.1.0 && <2.17 + , template-haskell >=2.11.1.0 && <2.19 , text >=1.2.2.2 && <1.3 - , time >=1.6.0.1 && <1.10 + , time >=1.6.0.1 && <1.12 , unordered-containers >=0.2.8.0 && <0.3 , vector >=0.12.0.1 && <0.13 - , vinyl >=0.5.3 && <0.14 + , vinyl >=0.5.3 && <0.15 default-language: Haskell2010 diff --git a/src/Composite/Aeson/Formats/Default.hs b/src/Composite/Aeson/Formats/Default.hs --- a/src/Composite/Aeson/Formats/Default.hs +++ b/src/Composite/Aeson/Formats/Default.hs @@ -53,7 +53,6 @@ instance DefaultJsonFormat a => DefaultJsonFormat (Semigroup.First a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat instance DefaultJsonFormat a => DefaultJsonFormat (Semigroup.Last a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat instance DefaultJsonFormat a => DefaultJsonFormat (Semigroup.WrappedMonoid a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat -instance DefaultJsonFormat a => DefaultJsonFormat (Semigroup.Option a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat instance DefaultJsonFormat a => DefaultJsonFormat (Monoid.Dual a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat instance DefaultJsonFormat a => DefaultJsonFormat (Monoid.Sum a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat instance DefaultJsonFormat a => DefaultJsonFormat (Monoid.Product a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat diff --git a/src/Composite/Aeson/Formats/Generic.hs b/src/Composite/Aeson/Formats/Generic.hs --- a/src/Composite/Aeson/Formats/Generic.hs +++ b/src/Composite/Aeson/Formats/Generic.hs @@ -5,13 +5,14 @@ ) where import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor), FromJson(FromJson)) -import Control.Arrow (second) +import Control.Arrow (first, second) import Control.Lens (_Wrapped, over, unsnoc) import Control.Monad.Error.Class (throwError) import Data.Aeson (FromJSON, ToJSON, (.=), toJSON) import qualified Data.Aeson as Aeson import qualified Data.Aeson.BetterErrors as ABE -import qualified Data.HashMap.Strict as StrictHashMap +import qualified Data.Aeson.Key as Aeson.Key +import qualified Data.Aeson.KeyMap as Aeson.KeyMap import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NEL import Data.Text (Text, intercalate, unpack) @@ -21,6 +22,9 @@ #if MIN_VERSION_template_haskell(2,16,0) , liftTyped, TExp(TExp) #endif +#if MIN_VERSION_template_haskell(2,17,0) + , liftCode +#endif ) -- |Produce an explicit 'JsonFormat' by using the implicit Aeson 'ToJSON' instance and an explicit @aeson-better-errors@ 'ABE.Parse'. @@ -45,7 +49,7 @@ jsonObjectFormat :: (t -> [(Text, a)]) -> ([(Text, a)] -> ABE.Parse e t) -> JsonFormat e a -> JsonFormat e t jsonObjectFormat oToList iFromList = over _Wrapped $ \ (JsonProfunctor o i) -> - JsonProfunctor (Aeson.Object . StrictHashMap.fromList . map (second o) . oToList) + JsonProfunctor (Aeson.Object . Aeson.KeyMap.fromList . map (first Aeson.Key.fromText . second o) . oToList) (ABE.eachInObject i >>= iFromList) @@ -153,7 +157,9 @@ SumStyleFieldName -> [| SumStyleFieldName |] SumStyleTypeValue a b -> [| SumStyleTypeValue $(liftString $ unpack a) $(liftString $ unpack b) |] SumStyleMergeType a -> [| SumStyleMergeType $(liftString $ unpack a) |] -#if MIN_VERSION_template_haskell(2,16,0) +#if MIN_VERSION_template_haskell(2,17,0) + liftTyped = liftCode . fmap TExp . lift +#elif MIN_VERSION_template_haskell(2,16,0) liftTyped = fmap TExp . lift #endif @@ -186,12 +192,13 @@ -- |Map a sum type from JSON in the 'SumStyleFieldName' style. fieldNameSumFromJson :: NonEmpty (Text, FromJson e a) -> ABE.Parse e a fieldNameSumFromJson iAs = do - fields <- ABE.withObject $ pure . StrictHashMap.keys + fields <- ABE.withObject $ pure . Aeson.KeyMap.keys case fields of [f] -> - case lookup f (NEL.toList iAs) of - Just (FromJson iA) -> ABE.key f iA - Nothing -> throwError $ ABE.InvalidJSON $ "unknown field " <> unpack f <> ", expected one of " <> expected + let ft = Aeson.Key.toText f + in case lookup ft (NEL.toList iAs) of + Just (FromJson iA) -> ABE.key ft iA + Nothing -> throwError $ ABE.InvalidJSON $ "unknown field " <> unpack ft <> ", expected one of " <> expected [] -> throwError $ ABE.InvalidJSON $ "expected an object with one field (" <> expected <> ") not an empty object" _ -> @@ -201,7 +208,7 @@ -- |Map a sum type to JSON in the 'SumStyleFieldName' style. fieldNameSumToJson :: (a -> (Text, Aeson.Value)) -> a -> Aeson.Value -fieldNameSumToJson oA = \ (oA -> (t, v)) -> Aeson.object [t .= v] +fieldNameSumToJson oA = \ (oA -> (t, v)) -> Aeson.object [Aeson.Key.fromText t .= v] -- |Map a sum type from JSON in the 'SumStyleTypeValue' style. typeValueSumFromJson :: Text -> Text -> NonEmpty (Text, FromJson e a) -> ABE.Parse e a @@ -216,7 +223,7 @@ -- |Map a sum type to JSON in the 'SumStyleTypeValue' style. typeValueSumToJson :: Text -> Text -> (a -> (Text, Aeson.Value)) -> a -> Aeson.Value -typeValueSumToJson typeField valueField oA = \ (oA -> (t, v)) -> Aeson.object [typeField .= t, valueField .= v] +typeValueSumToJson typeField valueField oA = \ (oA -> (t, v)) -> Aeson.object [Aeson.Key.fromText typeField .= t, Aeson.Key.fromText valueField .= v] -- |Map a sum type from JSON in the 'SumStyleMergeType' style. mergeTypeSumFromJson :: Text -> NonEmpty (Text, FromJson e a) -> ABE.Parse e a @@ -232,11 +239,11 @@ -- |Map a sum type to JSON in the 'SumStyleMergeType' style. mergeTypeSumToJson :: Text -> (a -> (Text, Aeson.Value)) -> a -> Aeson.Value mergeTypeSumToJson typeField oA = \ a -> case oA a of - (t, Aeson.Object fields) | StrictHashMap.member typeField fields -> + (t, Aeson.Object fields) | Aeson.KeyMap.member (Aeson.Key.fromText typeField) fields -> error $ "PRECONDITION VIOLATED: encoding a value with merge type sum style yielded " <> "(" <> unpack t <> ", " <> show (Aeson.Object fields) <> ") which already contains the field " <> unpack typeField (t, Aeson.Object fields) -> - Aeson.Object (StrictHashMap.insert typeField (Aeson.String t) fields) + Aeson.Object (Aeson.KeyMap.insert (Aeson.Key.fromText typeField) (Aeson.String t) fields) (t, other) -> error $ "PRECONDITION VIOLATED: encoding a value with merge type sum style yielded " <> "(" <> unpack t <> ", " <> show other <> ") which isn't an object" diff --git a/src/Composite/Aeson/Formats/InternalTH.hs b/src/Composite/Aeson/Formats/InternalTH.hs --- a/src/Composite/Aeson/Formats/InternalTH.hs +++ b/src/Composite/Aeson/Formats/InternalTH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Composite.Aeson.Formats.InternalTH ( makeTupleDefaults, makeTupleFormats, makeNamedTupleFormats ) where @@ -5,8 +6,9 @@ import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor)) import Control.Monad.Except (throwError) import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Aeson.Key +import qualified Data.Aeson.KeyMap as Aeson.KeyMap import qualified Data.Aeson.BetterErrors as ABE -import qualified Data.HashMap.Lazy as HM import Data.List (foldl') import Data.Text (Text) import qualified Data.Vector as V @@ -20,6 +22,9 @@ , bindS, noBindS , Type(AppT, ArrowT, ConT, ForallT, TupleT, VarT), appT, conT, varT , TyVarBndr(PlainTV) +#if MIN_VERSION_template_haskell(2,17,0) + , Specificity(SpecifiedSpec) +#endif ) import Language.Haskell.TH.Syntax (lift) @@ -64,7 +69,11 @@ tupleType = foldl' AppT (TupleT arity) (map VarT tyNames) funType = ForallT +#if MIN_VERSION_template_haskell(2,17,0) + (PlainTV tyErrName SpecifiedSpec : map (flip PlainTV SpecifiedSpec) tyNames) +#else (PlainTV tyErrName : map PlainTV tyNames) +#endif [] (foldr (\ tyName rest -> ArrowT `AppT` (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tyName) `AppT` rest) (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tupleType) @@ -116,7 +125,11 @@ tupleType = foldl' AppT (TupleT arity) (map VarT tyNames) funType = ForallT +#if MIN_VERSION_template_haskell(2,17,0) + (PlainTV tyErrName SpecifiedSpec : map (flip PlainTV SpecifiedSpec) tyNames) +#else (PlainTV tyErrName : map PlainTV tyNames) +#endif [] (foldr (\ tyName rest -> ArrowT `AppT` ConT ''Text `AppT` (ArrowT `AppT` (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tyName) `AppT` rest)) (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tupleType) @@ -124,8 +137,8 @@ oTupImpl = lamE [conP (tupleDataName arity) (map varP valNames)] - [| (Aeson.Object . HM.fromList) - $(listE $ map (\ (fName, varName, oName) -> [| ($(varE fName), $(varE oName) $(varE varName)) |]) + [| (Aeson.Object . Aeson.KeyMap.fromList) + $(listE $ map (\ (fName, varName, oName) -> [| (Aeson.Key.fromText $(varE fName), $(varE oName) $(varE varName)) |]) (zip3 fNames valNames oNames)) |] iTupImpl = doE diff --git a/src/Composite/Aeson/Record.hs b/src/Composite/Aeson/Record.hs --- a/src/Composite/Aeson/Record.hs +++ b/src/Composite/Aeson/Record.hs @@ -20,9 +20,10 @@ import Control.Monad (join) import qualified Data.Aeson as Aeson import qualified Data.Aeson.BetterErrors as ABE +import qualified Data.Aeson.Key as Aeson.Key +import qualified Data.Aeson.KeyMap as Aeson.KeyMap import Data.Functor.Contravariant (Contravariant, contramap) import Data.Functor.Identity (Identity(Identity)) -import qualified Data.HashMap.Strict as HM import Data.Proxy (Proxy(Proxy)) import Data.Text (Text, pack) import Data.Vinyl (RApply, RMap, Rec((:&), RNil), rmap, rzipWith) @@ -185,7 +186,7 @@ instance forall s a rs. (KnownSymbol s, RecordToJsonObject rs) => RecordToJsonObject (s :-> a ': rs) where recordToJsonObject (ToJsonField aToField :& fs) (Identity a :& as) = - maybe id (HM.insert (pack . symbolVal $ (Proxy :: Proxy s))) (aToField a) $ + maybe id (Aeson.KeyMap.insert (Aeson.Key.fromString . symbolVal $ (Proxy :: Proxy s))) (aToField a) $ recordToJsonObject fs as -- |Given a record of 'ToField' functions for each field in @rs@, convert an 'Identity' record to JSON. Equivalent to @Aeson.Object . 'recordToJsonObject' fmt@