composite-aeson 0.7.0.0 → 0.7.1.0

raw patch · 3 files changed

+116/−55 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• composite-aeson.cabal +2/−2
• src/Composite/Aeson/CoRecord.hs +52/−4
• src/Composite/Aeson/Formats/Generic.hs +62/−49

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 063cebc00b21d00793a2b94c8665f3dab675e7035434cce92187f5d8b06b25dc+-- hash: 919dc4a730a4bdf0886303870c36a4f70ad3fdb530eba59def3f5b105c4cb6b0  name:           composite-aeson-version:        0.7.0.0+version:        0.7.1.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

@@ -1,14 +1,16 @@ module Composite.Aeson.CoRecord-  ( JsonFormatField, DefaultJsonFormatField(defaultJsonFormatField)-  , fieldJsonFormat+  ( ToJsonFormatField, FromJsonFormatField, JsonFormatField+  , DefaultJsonFormatField(defaultJsonFormatField)+  , fieldToJson, fieldFromJson, fieldJsonFormat   ) where -import Composite.Aeson.Base (FromJson(FromJson), JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor), wrappedJsonFormat)+import Composite.Aeson.Base (FromJson(FromJson), JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor), ToJson(ToJson), wrappedJsonFormat) import Composite.Aeson.Formats.Default (DefaultJsonFormat, defaultJsonFormat)-import Composite.Aeson.Formats.Generic (SumStyle, jsonSumFormat)+import Composite.Aeson.Formats.Generic (SumStyle, jsonSumFormat, sumToJson, sumFromJson) import Composite.CoRecord (CoRec(CoVal), Field, fieldToRec) import Composite.Record ((:->), Rec((:&), RNil), RecWithContext(rmapWithContext), recordToNonEmpty, ReifyNames, reifyNames) import Data.Aeson (Value)+import qualified Data.Aeson.BetterErrors as ABE import Data.Functor.Identity (Identity(Identity)) import Data.List.NonEmpty (NonEmpty) import Data.Maybe (catMaybes, fromMaybe, listToMaybe)@@ -18,6 +20,12 @@ import Data.Vinyl.Lens (type (∈)) import Data.Proxy (Proxy(Proxy)) +-- |Type of records which contain JSON encoders for each element of @rs@.+type ToJsonFormatField rs = Rec ToJson rs++-- |Type of records which contain JSON decoders for each element of @rs@.+type FromJsonFormatField e rs = Rec (FromJson e) rs+ -- |Type of records which contain JSON formats for each element of @rs@. type JsonFormatField e rs = Rec (JsonFormat e) rs @@ -31,6 +39,46 @@  instance forall s a rs. (DefaultJsonFormat a, DefaultJsonFormatField rs) => DefaultJsonFormatField (s :-> a ': rs) where   defaultJsonFormatField = wrappedJsonFormat defaultJsonFormat :& (defaultJsonFormatField :: JsonFormatField e rs)++-- |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' :: [*]).+     ( rs ~ (r' ': rs'), RApply rs, RMap rs+     , RecApplicative rs, RecWithContext rs rs, RecordToList rs', ReifyNames rs )+  => SumStyle -> ToJsonFormatField rs -> Field rs -> Value+fieldToJson sumStyle fmts = sumToJson sumStyle o+  where+    namedFmts :: Rec ((,) Text :. ToJson) rs+    namedFmts = reifyNames fmts++    o :: Field rs -> (Text, Value)+    o = fromMaybe (error "fieldToRec somehow produced all Nothings")+      . listToMaybe . catMaybes+      . (recordToList :: Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)])+      . rapply outputs+      . fieldToRec++    outputs :: Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs+    outputs = namedFmts <<&>> \ (Compose (name, ToJson oa)) ->+      Lift $ Const . fmap ((name,) . oa)++-- |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.+     ( 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)+fieldFromJson sumStyle fmts = sumFromJson sumStyle i+  where+    namedFmts :: Rec ((,) Text :. FromJson e) rs+    namedFmts = reifyNames fmts++    i :: NonEmpty (Text, FromJson e (Field rs))+    i = recordToNonEmpty $ rmapWithContext (Proxy @rs) oneCase namedFmts+      where+        oneCase :: forall r. r ∈ rs => ((,) Text :. FromJson e) r -> Const (Text, FromJson e (Field rs)) r+        oneCase (Compose (name, FromJson ia)) =+          Const (name, FromJson (CoVal . Identity <$> ia))  -- |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

@@ -1,6 +1,6 @@ module Composite.Aeson.Formats.Generic   ( abeJsonFormat, aesonJsonFormat, jsonArrayFormat, jsonObjectFormat-  , SumStyle(..), jsonSumFormat+  , SumStyle(..), sumFromJson, sumToJson, jsonSumFormat   ) where  import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor), FromJson(FromJson))@@ -157,64 +157,77 @@     Nothing                   -> unpack f  -- |'JsonFormat' which maps sum types to JSON according to 'SumStyle', given a pair of functions to decompose and recompose the sum type.+sumFromJson :: SumStyle -> NonEmpty (Text, FromJson e a) -> ABE.Parse e a+sumFromJson = \ case+  SumStyleFieldName     -> fieldNameSumFromJson+  SumStyleTypeValue t v -> typeValueSumFromJson t v+  SumStyleMergeType t   -> mergeTypeSumFromJson t++-- |'JsonFormat' which maps sum types to JSON according to 'SumStyle', given a pair of functions to decompose and recompose the sum type.+sumToJson :: SumStyle -> (a -> (Text, Aeson.Value)) -> a -> Aeson.Value+sumToJson = \ case+  SumStyleFieldName     -> fieldNameSumToJson+  SumStyleTypeValue t v -> typeValueSumToJson t v+  SumStyleMergeType t   -> mergeTypeSumToJson t++-- |'JsonFormat' which maps sum types to JSON according to 'SumStyle', given a pair of functions to decompose and recompose the sum type. jsonSumFormat :: SumStyle -> (a -> (Text, Aeson.Value)) -> NonEmpty (Text, FromJson e a) -> JsonFormat e a-jsonSumFormat = \ case-  SumStyleFieldName     -> jsonFieldNameSumFormat-  SumStyleTypeValue t v -> jsonTypeValueSumFormat t v-  SumStyleMergeType t   -> jsonMergeTypeSumFormat t+jsonSumFormat style oA iAs = JsonFormat (JsonProfunctor (sumToJson style oA) (sumFromJson style iAs)) --- |'JsonFormat' which maps sum types to JSON in the 'SumStyleFieldName' style.-jsonFieldNameSumFormat :: (a -> (Text, Aeson.Value)) -> NonEmpty (Text, FromJson e a) -> JsonFormat e a-jsonFieldNameSumFormat oA iAs =-  JsonFormat (JsonProfunctor o i)+-- |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+  case fields of+    [f] ->+      case lookup f (NEL.toList iAs) of+        Just (FromJson iA) -> ABE.key f iA+        Nothing -> fail $ "unknown field " <> unpack f <> ", expected one of " <> expected+    [] ->+      fail $ "expected an object with one field (" <> expected <> ") not an empty object"+    _ ->+      fail $ "expected an object with one field (" <> expected <> ") not many fields"   where     expected = expectedFieldsForInputs iAs-    o a = let (t, v) = oA a in Aeson.object [t .= v]-    i = do-      fields <- ABE.withObject $ pure . StrictHashMap.keys-      case fields of-        [f] ->-          case lookup f (NEL.toList iAs) of-            Just (FromJson iA) -> ABE.key f iA-            Nothing -> fail $ "unknown field " <> unpack f <> ", expected one of " <> expected-        [] ->-          fail $ "expected an object with one field (" <> expected <> ") not an empty object"-        _ ->-          fail $ "expected an object with one field (" <> expected <> ") not many fields" +-- |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] --- |'JsonFormat' which maps sum types to JSON in the 'SumStyleTypeValue' style.-jsonTypeValueSumFormat :: Text -> Text -> (a -> (Text, Aeson.Value)) -> NonEmpty (Text, FromJson e a) -> JsonFormat e a-jsonTypeValueSumFormat typeField valueField oA iAs =-  JsonFormat (JsonProfunctor o i)+-- |Map a sum type from JSON in the 'SumStyleTypeValue' style.+typeValueSumFromJson :: Text -> Text -> NonEmpty (Text, FromJson e a) -> ABE.Parse e a+typeValueSumFromJson typeField valueField iAs = do+  t <- ABE.key typeField ABE.asText+  case lookup t (NEL.toList iAs) of+    Just (FromJson iA) -> ABE.key valueField iA+    Nothing -> toss $ "expected " <> unpack typeField <> " to be one of " <> expected   where     expected = expectedFieldsForInputs iAs-    o a = let (t, v) = oA a in Aeson.object [typeField .= t, valueField .= v]-    i = do-      t <- ABE.key typeField ABE.asText-      case lookup t (NEL.toList iAs) of-        Just (FromJson iA) -> ABE.key valueField iA-        Nothing -> toss $ "expected " <> unpack typeField <> " to be one of " <> expected     toss = throwError . ABE.BadSchema [] . ABE.FromAeson --- |'JsonFormat' which maps sum types to JSON in the 'SumStyleMergeType' style.-jsonMergeTypeSumFormat :: Text -> (a -> (Text, Aeson.Value)) -> NonEmpty (Text, FromJson e a) -> JsonFormat e a-jsonMergeTypeSumFormat typeField oA iAs =-  JsonFormat (JsonProfunctor o i)+-- |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]++-- |Map a sum type from JSON in the 'SumStyleMergeType' style.+mergeTypeSumFromJson :: Text -> NonEmpty (Text, FromJson e a) -> ABE.Parse e a+mergeTypeSumFromJson typeField iAs = do+  t <- ABE.key typeField ABE.asText+  case lookup t (NEL.toList iAs) of+    Just (FromJson iA) -> iA+    Nothing -> toss $ "expected " <> unpack typeField <> " to be one of " <> expected   where     expected = expectedFieldsForInputs iAs-    o a = case oA a of-      (t, Aeson.Object fields) | StrictHashMap.member 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)-      (t, other) ->-        error $ "PRECONDITION VIOLATED: encoding a value with merge type sum style yielded "-             <> "(" <> unpack t <> ", " <> show other <> ") which isn't an object"-    i = do-      t <- ABE.key typeField ABE.asText-      case lookup t (NEL.toList iAs) of-        Just (FromJson iA) -> iA-        Nothing -> toss $ "expected " <> unpack typeField <> " to be one of " <> expected     toss = throwError . ABE.BadSchema [] . ABE.FromAeson++-- |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 ->+    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)+  (t, other) ->+    error $ "PRECONDITION VIOLATED: encoding a value with merge type sum style yielded "+         <> "(" <> unpack t <> ", " <> show other <> ") which isn't an object"