packages feed

composite-aeson 0.7.5.0 → 0.8.2.2

raw patch · 10 files changed

Files

composite-aeson.cabal view
@@ -1,17 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.3.------ see: https://github.com/sol/hpack------ hash: 684ff7558a2f16e5bba77f441093b403df9653bd523915ff4733380484d28c1d- name:           composite-aeson-version:        0.7.5.0+version:        0.8.2.2 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-homepage:       https://github.com/ConferOpenSource/composite#readme+homepage:       https://github.com/composite-hs/composite#readme author:         Confer Health, Inc maintainer:     oss@vitalbio.com copyright:      2017 Confer Health, Inc., 2020-2021 Vital Biosciences@@ -22,6 +16,7 @@   exposed-modules:       Composite.Aeson       Composite.Aeson.Base+      Composite.Aeson.Compat       Composite.Aeson.CoRecord       Composite.Aeson.DateTimeFormatUtils       Composite.Aeson.Enum@@ -36,29 +31,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-    , hashable >=1.2.6.1 && <1.4-    , lens >=4.15.4 && <5.1+    , generic-deriving >=1.11.2 && <1.15+    , hashable >=1.2.6.1 && <1.5+    , lens >=4.15.4 && <5.3     , 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 +90,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-    , hashable >=1.2.6.1 && <1.4+    , generic-deriving >=1.11.2 && <1.15+    , hashable >=1.2.6.1 && <1.5     , hspec-    , lens >=4.15.4 && <5.1+    , lens >=4.15.4 && <5.3     , 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
src/Composite/Aeson.hs view
@@ -1,5 +1,6 @@ module Composite.Aeson   ( module Composite.Aeson.Base+  , module Composite.Aeson.Compat   , module Composite.Aeson.CoRecord   , module Composite.Aeson.Enum   , module Composite.Aeson.Formats.DateTime@@ -10,6 +11,7 @@   ) where  import Composite.Aeson.Base+import Composite.Aeson.Compat import Composite.Aeson.CoRecord import Composite.Aeson.Enum import Composite.Aeson.Formats.DateTime
src/Composite/Aeson/Base.hs view
@@ -1,9 +1,10 @@ module Composite.Aeson.Base   ( ToJson(..), FromJson(..), JsonProfunctor(..), _JsonProfunctor, JsonFormat(..)   , toJsonWithFormat, fromJsonWithFormat, parseJsonWithFormat, parseJsonWithFormat'-  , dimapJsonFormat, jsonFormatWithIso, wrapJsonFormat, jsonFormatWithoutCustomError, wrappedJsonFormat+  , dimapJsonFormat, jsonFormatWithIso, wrapJsonFormat, jsonFormatWithoutCustomError, wrappedJsonFormat, valJsonFormat   ) where +import Composite.Record ((:->)) import Control.Lens (AnIso', Iso, _2, Wrapped(type Unwrapped), _Wrapped', _Wrapped, iso, over, withIso) import Control.Lens.TH (makeWrapped) import Control.Monad.Except (withExceptT)@@ -132,3 +133,7 @@ -- |Given a format for the value type inside some wrapper type @a@ which instances 'Wrapped', produce a format which works on the wrapper type. wrappedJsonFormat :: Wrapped a => JsonFormat e (Unwrapped a) -> JsonFormat e a wrappedJsonFormat = jsonFormatWithIso _Wrapped'++-- |Specialized type for 'wrappedJsonFormat' so we can specify the 'Val' symbol.+valJsonFormat :: forall s a e. JsonFormat e a -> JsonFormat e (s :-> a)+valJsonFormat = wrappedJsonFormat
src/Composite/Aeson/CoRecord.hs view
@@ -12,6 +12,7 @@ import Data.Aeson (Value) import qualified Data.Aeson.BetterErrors as ABE import Data.Functor.Identity (Identity(Identity))+import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty) import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Text (Text)@@ -30,7 +31,7 @@ type JsonFormatField e rs = Rec (JsonFormat e) rs  -- |Class which makes up a 'JsonFormatField' for some @rs@ where each @r ~ s :-> a@ by using the 'DefaultJsonFormat' instance for each @a@.-class DefaultJsonFormatField (rs :: [*]) where+class DefaultJsonFormatField (rs :: [Type]) where   -- |Make up a 'JsonFormatField' for some @rs@ where each @r ~ s :-> a@ by using the 'DefaultJsonFormat' instance for each @a@.   defaultJsonFormatField :: JsonFormatField e rs @@ -42,7 +43,7 @@  -- |Make a @'Field' rs -> 'Value'@ given how to map the sum type to JSON along with a record with encoders for each value the field could have. fieldToJson-  :: forall (rs :: [*]) r' (rs' :: [*]).+  :: forall (rs :: [Type]) r' (rs' :: [Type]).      ( rs ~ (r' ': rs'), RApply rs, RMap rs      , RecApplicative rs, RecWithContext rs rs, RecordToList rs', ReifyNames rs )   => SumStyle -> ToJsonFormatField rs -> Field rs -> Value@@ -64,7 +65,7 @@  -- |Make a @'ABE.Parse' e (Field rs)@ given how to map the sum type from JSON along with a record with decoders for each value the field could have. fieldFromJson-  :: forall (rs :: [*]) r' (rs' :: [*]) e.+  :: forall (rs :: [Type]) r' (rs' :: [Type]) e.      ( rs ~ (r' ': rs'), RApply rs, RMap rs      , RecApplicative rs, RecWithContext rs rs, RecordToList rs', ReifyNames rs )   => SumStyle -> FromJsonFormatField e rs -> ABE.Parse e (Field rs)@@ -82,7 +83,7 @@  -- |Make a @'JsonFormat' e (Field rs)@ given how to map the sum type to JSON along with a record with formatters for each value the field could have. fieldJsonFormat-  :: forall (rs :: [*]) r' (rs' :: [*]) e.+  :: forall (rs :: [Type]) r' (rs' :: [Type]) e.      ( rs ~ (r' ': rs'), RApply rs, RMap rs      , RecApplicative rs, RecWithContext rs rs, RecordToList rs', ReifyNames rs )   => SumStyle -> JsonFormatField e rs -> JsonFormat e (Field rs)@@ -108,4 +109,3 @@         oneCase :: forall r. r ∈ rs => ((,) Text :. JsonFormat e) r -> Const (Text, FromJson e (Field rs)) r         oneCase (Compose (name, JsonFormat (JsonProfunctor _ ia))) =           Const (name, FromJson (CoVal . Identity <$> ia))-
+ src/Composite/Aeson/Compat.hs view
@@ -0,0 +1,15 @@+module Composite.Aeson.Compat +  ( CompositeFormat(..)+  ) where++import Composite.Aeson.Base (parseJsonWithFormat', toJsonWithFormat)+import Composite.Aeson.Formats.Default (DefaultJsonFormat(..))+import Data.Aeson (FromJSON(..), ToJSON(..))++newtype CompositeFormat a = CompositeFormat {unCompositeFormat :: a}++instance DefaultJsonFormat a => FromJSON (CompositeFormat a) where+  parseJSON = fmap CompositeFormat . parseJsonWithFormat' defaultJsonFormat++instance DefaultJsonFormat a => ToJSON (CompositeFormat a) where+  toJSON = toJsonWithFormat defaultJsonFormat . unCompositeFormat
src/Composite/Aeson/Formats/DateTime.hs view
@@ -93,7 +93,7 @@   Fail    f <*> _         = Fail    f  instance Monad SuccessOrFail where-  return = Success+  return = pure   Success a >>= k = k a   Fail    f >>= _ = Fail f #if MIN_VERSION_base(4,13,0)
src/Composite/Aeson/Formats/Default.hs view
@@ -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
src/Composite/Aeson/Formats/Generic.hs view
@@ -5,13 +5,18 @@   ) 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+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Aeson.Key+import qualified Data.Aeson.KeyMap as Aeson.KeyMap+#else import qualified Data.HashMap.Strict as StrictHashMap+#endif import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NEL import Data.Text (Text, intercalate, unpack)@@ -21,6 +26,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 +53,11 @@ jsonObjectFormat :: (t -> [(Text, a)]) -> ([(Text, a)] -> ABE.Parse e t) -> JsonFormat e a -> JsonFormat e t jsonObjectFormat oToList iFromList =   over _Wrapped $ \ (JsonProfunctor o i) ->+#if MIN_VERSION_aeson(2,0,0)+    JsonProfunctor (Aeson.Object . Aeson.KeyMap.fromList . map (first Aeson.Key.fromText . second o) . oToList)+#else     JsonProfunctor (Aeson.Object . StrictHashMap.fromList . map (second o) . oToList)+#endif                    (ABE.eachInObject i >>= iFromList)  @@ -153,7 +165,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 +200,23 @@ -- |Map a sum type from JSON in the 'SumStyleFieldName' style. fieldNameSumFromJson :: NonEmpty (Text, FromJson e a) -> ABE.Parse e a fieldNameSumFromJson iAs = do+#if MIN_VERSION_aeson(2,0,0)+  fields <- ABE.withObject $ pure . Aeson.KeyMap.keys+#else   fields <- ABE.withObject $ pure . StrictHashMap.keys+#endif   case fields of     [f] ->+#if MIN_VERSION_aeson(2,0,0)+      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+#else       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+#endif     [] ->       throwError $ ABE.InvalidJSON $ "expected an object with one field (" <> expected <> ") not an empty object"     _ ->@@ -201,7 +226,11 @@  -- |Map a sum type to JSON in the 'SumStyleFieldName' style. fieldNameSumToJson :: (a -> (Text, Aeson.Value)) -> a -> Aeson.Value+#if MIN_VERSION_aeson(2,0,0)+fieldNameSumToJson oA = \ (oA -> (t, v)) -> Aeson.object [Aeson.Key.fromText t .= v]+#else fieldNameSumToJson oA = \ (oA -> (t, v)) -> Aeson.object [t .= v]+#endif  -- |Map a sum type from JSON in the 'SumStyleTypeValue' style. typeValueSumFromJson :: Text -> Text -> NonEmpty (Text, FromJson e a) -> ABE.Parse e a@@ -216,7 +245,11 @@  -- |Map a sum type to JSON in the 'SumStyleTypeValue' style. typeValueSumToJson :: Text -> Text -> (a -> (Text, Aeson.Value)) -> a -> Aeson.Value+#if MIN_VERSION_aeson(2,0,0)+typeValueSumToJson typeField valueField oA = \ (oA -> (t, v)) -> Aeson.object [Aeson.Key.fromText typeField .= t, Aeson.Key.fromText valueField .= v]+#else typeValueSumToJson typeField valueField oA = \ (oA -> (t, v)) -> Aeson.object [typeField .= t, valueField .= v]+#endif  -- |Map a sum type from JSON in the 'SumStyleMergeType' style. mergeTypeSumFromJson :: Text -> NonEmpty (Text, FromJson e a) -> ABE.Parse e a@@ -232,11 +265,19 @@ -- |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+#if MIN_VERSION_aeson(2,0,0)+  (t, Aeson.Object fields) | Aeson.KeyMap.member (Aeson.Key.fromText typeField) fields ->+#else   (t, Aeson.Object fields) | StrictHashMap.member typeField fields ->+#endif     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) ->+#if MIN_VERSION_aeson(2,0,0)+    Aeson.Object (Aeson.KeyMap.insert (Aeson.Key.fromText typeField) (Aeson.String t) fields)+#else     Aeson.Object (StrictHashMap.insert typeField (Aeson.String t) fields)+#endif   (t, other) ->     error $ "PRECONDITION VIOLATED: encoding a value with merge type sum style yielded "          <> "(" <> unpack t <> ", " <> show other <> ") which isn't an object"
src/Composite/Aeson/Formats/InternalTH.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Composite.Aeson.Formats.InternalTH   ( makeTupleDefaults, makeTupleFormats, makeNamedTupleFormats   ) where@@ -5,8 +6,13 @@ import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor)) import Control.Monad.Except (throwError) import qualified Data.Aeson as Aeson-import qualified Data.Aeson.BetterErrors as ABE+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Aeson.Key+import qualified Data.Aeson.KeyMap as Aeson.KeyMap+#else import qualified Data.HashMap.Lazy as HM+#endif+import qualified Data.Aeson.BetterErrors as ABE import Data.List (foldl') import Data.Text (Text) import qualified Data.Vector as V@@ -20,6 +26,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 +73,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 +129,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 +141,13 @@           oTupImpl =             lamE               [conP (tupleDataName arity) (map varP valNames)]+#if MIN_VERSION_aeson(2,0,0)+              [| (Aeson.Object . Aeson.KeyMap.fromList)+                 $(listE $ map (\ (fName, varName, oName) -> [| (Aeson.Key.fromText $(varE fName), $(varE oName) $(varE varName)) |])+#else               [| (Aeson.Object . HM.fromList)                  $(listE $ map (\ (fName, varName, oName) -> [| ($(varE fName), $(varE oName) $(varE varName)) |])+#endif                                (zip3 fNames valNames oNames)) |]           iTupImpl =             doE
src/Composite/Aeson/Record.hs view
@@ -1,31 +1,43 @@+{-# LANGUAGE CPP #-} module Composite.Aeson.Record   ( ToJsonField(..), FromJsonField(..), JsonField(..)-  , field, field', fromField, fromField', toField, toField'-  , optionalField, optionalField', fromOptionalField, fromOptionalField', toOptionalField, toOptionalField'+  , field, valField, field', fromField, valFromField, fromField', toField, toField'+  , defaultField, valDefaultField, defaultField'+  , optionalField, valOptionalField, optionalField', fromOptionalField, valFromOptionalField, fromOptionalField', toOptionalField, toOptionalField', defaultValFromOptionalField   , JsonFormatRecord, ToJsonFormatRecord, FromJsonFormatRecord, zipJsonFormatRecord, toJsonFormatRecord, fromJsonFormatRecord   , DefaultJsonFormatRecord, defaultJsonFormatRecord   , RecordToJsonObject, recordToJsonObject, recordToJson   , RecordFromJson, recordFromJson   , recordJsonFormat+  , valMaybeParser, valMaybeField+  , MaybeRecordFromJson, maybeRecordFromJson   ) where  import Composite.Aeson.Base   ( JsonProfunctor(JsonProfunctor)   , JsonFormat(JsonFormat)+  , fromJsonWithFormat   , wrappedJsonFormat   ) import Composite.Aeson.Formats.Default (DefaultJsonFormat(defaultJsonFormat))-import Composite.Record ((:->))+import Composite.Record ((:->)(Val)) import Control.Lens (Wrapped(type Unwrapped, _Wrapped'), from, review, view) import Control.Monad (join) import qualified Data.Aeson as Aeson import qualified Data.Aeson.BetterErrors as ABE+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Aeson.Key+import qualified Data.Aeson.KeyMap as Aeson.KeyMap+#else+import qualified Data.HashMap.Strict as HM+#endif import Data.Functor.Contravariant (Contravariant, contramap) import Data.Functor.Identity (Identity(Identity))-import qualified Data.HashMap.Strict as HM+import Data.Maybe (fromMaybe) import Data.Proxy (Proxy(Proxy)) import Data.Text (Text, pack) import Data.Vinyl (RApply, RMap, Rec((:&), RNil), rmap, rzipWith)+import Data.Vinyl.Functor (Compose (..), (:.)) import GHC.TypeLits (KnownSymbol, symbolVal)  -- |Function to encode a single field of a record, possibly choosing to elide the field with @Nothing@.@@ -48,14 +60,42 @@ field :: (Wrapped a', Unwrapped a' ~ a) => JsonFormat e a -> JsonField e a' field fmt = field' (wrappedJsonFormat fmt) +-- |Specialized type for 'field' so we can specify the 'Val' symbol.+valField :: forall s a e. JsonFormat e a -> JsonField e (s :-> a)+valField = field+ -- |Given a 'JsonFormat' for some type @a@, produce a 'JsonField' for fields of type @a@ which fails if the field is missing and never elides the field. field' :: JsonFormat e a -> JsonField e a field' (JsonFormat (JsonProfunctor o i)) = JsonField (Just . o) (`ABE.key` i) +-- | Given a 'JsonFormat' for some type @a@, produce a 'JsonField' for fields of type @a@ which substitutes a default value if the field is missing+--  and never elides the field.+defaultField :: (Wrapped a', Unwrapped a' ~ a) => a -> JsonFormat e a -> JsonField e a'+defaultField default_ (JsonFormat (JsonProfunctor o i)) =+  JsonField+    (Just . o . view _Wrapped')+    (\k -> view (from _Wrapped') . fromMaybe default_ . join <$> ABE.keyMay k (ABE.perhaps i))++-- | Specialized type for 'defaultField' so we can specify the 'Val' symbol.+valDefaultField :: forall s a e. a -> JsonFormat e a -> JsonField e (s :-> a)+valDefaultField = defaultField++-- | Given a 'JsonFormat' for some type @a@, produce a 'JsonField' for fields of type @a@ which substitutes a default value if the field is missing+--  and never elides the field.+defaultField' :: a -> JsonFormat e a -> JsonField e a+defaultField' default_ (JsonFormat (JsonProfunctor o i)) =+  JsonField+    (Just . o)+    (\k -> fromMaybe default_ . join <$> ABE.keyMay k (ABE.perhaps i))+ -- |Given a parser for @'Unwrapped' a@, produce a @'FromField' e a@. fromField :: Wrapped a => ABE.Parse e (Unwrapped a) -> FromJsonField e a fromField = FromJsonField . flip ABE.key . fmap (review _Wrapped') +-- |Specialized type for 'fromField' so we can specify the Val symbol.+valFromField :: forall s a e. ABE.Parse e a -> FromJsonField e (s :-> a)+valFromField = fromField+ -- |Given a parser for @a@, produce a @'FromField' e a@. fromField' :: ABE.Parse e a -> FromJsonField e a fromField' = FromJsonField . flip ABE.key@@ -76,6 +116,10 @@     (fmap o . view _Wrapped')     (\ k -> view (from _Wrapped') . join <$> ABE.keyMay k (ABE.perhaps i)) +-- |Specialized type for 'optionalField' so we can specify the 'Val' symbol.+valOptionalField :: forall s a e. JsonFormat e a -> JsonField e (s :-> Maybe a)+valOptionalField = optionalField+ -- |Given a 'JsonFormat' for some type @a@, produce a 'JsonField' for fields of type @Maybe a@ which substitutes @Nothing@ for either @null@ or missing field, -- and which elides the field on @Nothing@. optionalField' :: JsonFormat e a -> JsonField e (Maybe a)@@ -90,12 +134,20 @@   where     f k = view (from _Wrapped') . join <$> ABE.keyMay k (ABE.perhaps i) +-- |Specialized type for 'fromOptionalField' so we can specify the 'Val' symbol.+valFromOptionalField :: forall s a e. ABE.Parse e a -> FromJsonField e (s :-> Maybe a)+valFromOptionalField = fromOptionalField+ -- |Given a parser for @a@, produce a @'FromField' e (Maybe a)@ which represents an optional field. fromOptionalField' :: ABE.Parse e a -> FromJsonField e (Maybe a) fromOptionalField' i = FromJsonField f   where     f k = join <$> ABE.keyMay k (ABE.perhaps i) +-- |Given a default @a@ value to use if the field is missing and a parser to use if the field is present, produce a @'FromJsonField' e (s :-> a)@.+defaultValFromOptionalField :: forall s a e. a -> JsonFormat e a -> FromJsonField e (s :-> a)+defaultValFromOptionalField default_ = fmap (Val . fromMaybe default_) . fromOptionalField' . fromJsonWithFormat+ -- |Given an encoding function for some type @a@, produce a 'ToField' for fields of type @Maybe a@ which elides the field on @Nothing@. toOptionalField :: (Wrapped a', Unwrapped a' ~ Maybe a) => (a -> Aeson.Value) -> ToJsonField a' toOptionalField o = ToJsonField (fmap o . view _Wrapped')@@ -104,6 +156,16 @@ toOptionalField' :: (a -> Aeson.Value) -> ToJsonField (Maybe a) toOptionalField' o = ToJsonField (fmap o) +-- |Promote an ABE value parser to one which can be used to parse a field of a sparse JSON record using 'maybeRecordFromJson'.+valMaybeParser :: forall s a e. ABE.Parse e a -> (FromJsonField e :. Maybe) (s :-> a)+valMaybeParser r =+  let r' str = fmap Val <$> ABE.keyMay str r+   in Compose (FromJsonField r')++-- |Promote a value parser to one which can be used to parse a field of a sparse JSON record using 'maybeRecordFromJson'.+valMaybeField :: forall s a e. JsonFormat e a -> (FromJsonField e :. Maybe) (s :-> a)+valMaybeField (JsonFormat (JsonProfunctor _ r)) = valMaybeParser r+ -- |Type of a Vinyl record which describes how to map fields of a record to JSON and back. -- --@@ -185,7 +247,11 @@  instance forall s a rs. (KnownSymbol s, RecordToJsonObject rs) => RecordToJsonObject (s :-> a ': rs) where   recordToJsonObject (ToJsonField aToField :& fs) (Identity a :& as) =+#if MIN_VERSION_aeson(2,0,0)+    maybe id (Aeson.KeyMap.insert (Aeson.Key.fromString . symbolVal $ (Proxy :: Proxy s))) (aToField a) $+#else     maybe id (HM.insert (pack . symbolVal $ (Proxy :: Proxy s))) (aToField a) $+#endif       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@@@ -225,3 +291,16 @@  instance DefaultJsonFormatRecord '[] where   defaultJsonFormatRecord = RNil++-- |Class to make a parser for a @Rec Maybe rs@ given a @Rec@ of parsers.+class MaybeRecordFromJson rs where+  maybeRecordFromJson :: Rec (FromJsonField e :. Maybe) rs -> ABE.Parse e (Rec Maybe rs)++instance MaybeRecordFromJson '[] where+  maybeRecordFromJson _ = pure RNil++instance forall s a rs. (KnownSymbol s, MaybeRecordFromJson rs) => MaybeRecordFromJson (s :-> a ': rs) where+  maybeRecordFromJson (Compose (FromJsonField aFromField) :& fs) =+    (:&)+      <$> aFromField (pack . symbolVal $ (Proxy :: Proxy s))+      <*> maybeRecordFromJson fs