composite-aeson 0.1.1.0 → 0.2.0.0

raw patch · 15 files changed

+1023/−134 lines, 15 filesdep +Framesdep +QuickCheckdep +aeson-qqPVP ok

version bump matches the API change (PVP)

Dependencies added: Frames, QuickCheck, aeson-qq, composite-aeson, hspec, tagged, template-haskell, time, vector

API changes (from Hackage documentation)

Files

• composite-aeson.cabal +50/−3
• src/Composite/Aeson.hs +8/−2
• src/Composite/Aeson/Base.hs +3/−3
• src/Composite/Aeson/DateTimeFormatUtils.hs +29/−0
• src/Composite/Aeson/Default.hs +0/−105
• src/Composite/Aeson/Formats/DateTime.hs +102/−0
• src/Composite/Aeson/Formats/Default.hs +109/−0
• src/Composite/Aeson/Formats/Generic.hs +208/−0
• src/Composite/Aeson/Formats/InternalTH.hs +96/−0
• src/Composite/Aeson/Formats/Provided.hs +175/−0
• src/Composite/Aeson/Record.hs +60/−21
• src/Composite/Aeson/TH.hs +111/−0
• test/Main.hs +10/−0
• test/RecordSpec.hs +45/−0
• test/TupleSpec.hs +17/−0

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           composite-aeson-version:        0.1.1.0+version:        0.2.0.0 synopsis:       JSON for Vinyl/Frames records description:    Integration between Aeson and Vinyl/Frames records allowing records to be easily converted to JSON using automatic derivation, explicit formats, or a mix of both. category:       Records@@ -18,10 +18,11 @@ library   hs-source-dirs:       src-  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NoImplicitPrelude OverloadedStrings PolyKinds ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns+  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns   ghc-options: -Wall -O2   build-depends:       base >= 4.7 && < 5+    , Frames     , aeson     , aeson-better-errors     , basic-prelude@@ -32,13 +33,59 @@     , lens     , profunctors     , scientific+    , tagged+    , template-haskell     , text+    , time     , unordered-containers+    , vector     , vinyl   exposed-modules:       Composite.Aeson       Composite.Aeson.Base-      Composite.Aeson.Default+      Composite.Aeson.DateTimeFormatUtils       Composite.Aeson.Enum+      Composite.Aeson.Formats.DateTime+      Composite.Aeson.Formats.Default+      Composite.Aeson.Formats.Generic+      Composite.Aeson.Formats.InternalTH+      Composite.Aeson.Formats.Provided       Composite.Aeson.Record+      Composite.Aeson.TH+  default-language: Haskell2010++test-suite composite-aeson-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      test+  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns+  ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans+  build-depends:+      base >= 4.7 && < 5+    , Frames+    , aeson+    , aeson-better-errors+    , basic-prelude+    , composite-base+    , containers+    , contravariant+    , generic-deriving+    , lens+    , profunctors+    , scientific+    , tagged+    , template-haskell+    , text+    , time+    , unordered-containers+    , vector+    , vinyl+    , QuickCheck+    , aeson-qq+    , composite-aeson+    , hspec+  other-modules:+      RecordSpec+      TupleSpec   default-language: Haskell2010

@@ -1,11 +1,17 @@ module Composite.Aeson   ( module Composite.Aeson.Base-  , module Composite.Aeson.Default   , module Composite.Aeson.Enum+  , module Composite.Aeson.Formats.DateTime+  , module Composite.Aeson.Formats.Default+  , module Composite.Aeson.Formats.Generic+  , module Composite.Aeson.Formats.Provided   , module Composite.Aeson.Record   ) where  import Composite.Aeson.Base-import Composite.Aeson.Default import Composite.Aeson.Enum+import Composite.Aeson.Formats.DateTime+import Composite.Aeson.Formats.Default+import Composite.Aeson.Formats.Generic+import Composite.Aeson.Formats.Provided import Composite.Aeson.Record

@@ -1,7 +1,7 @@ module Composite.Aeson.Base   ( ToJson(..), FromJson(..), JsonProfunctor(..), _JsonProfunctor, JsonFormat(..)   , toJsonWithFormat, fromJsonWithFormat, parseJsonWithFormat, parseJsonWithFormat'-  , dimapJsonFormat, jsonFormatWithIso, wrappedFormat+  , dimapJsonFormat, jsonFormatWithIso, wrappedJsonFormat   ) where  import BasicPrelude@@ -89,5 +89,5 @@ jsonFormatWithIso i = withIso i dimapJsonFormat  -- |Given a format for the value type inside some wrapper type @a@ which instances 'Wrapped', produce a format which works on the wrapper type.-wrappedFormat :: Wrapped a => JsonFormat e (Unwrapped a) -> JsonFormat e a-wrappedFormat = jsonFormatWithIso _Wrapped'+wrappedJsonFormat :: Wrapped a => JsonFormat e (Unwrapped a) -> JsonFormat e a+wrappedJsonFormat = jsonFormatWithIso _Wrapped'

@@ -0,0 +1,29 @@+module Composite.Aeson.DateTimeFormatUtils+  ( fixupTzIn, fixupTzOut, fixupMs+  ) where++import BasicPrelude+import Data.Char (isDigit)+import Data.Function (fix)++-- |Given a string, remove a trailing @Z@ (which is ISO8601 acceptable) and replace it with @+00:00@ (which is @ParseTime@ acceptable)+fixupTzIn :: String -> String+fixupTzIn s = maybe s ((++ "+00:00") . reverse) $ stripPrefix "Z"      (reverse s)++-- |Given a string, remove a trailing @+00:00@ (which @FormatTime@) and replace it with @Z@ (which is ISO8601 standard)+fixupTzOut :: String -> String+fixupTzOut s = maybe s ((++ "Z")      . reverse) $ stripPrefix "00:00+" (reverse s)++-- |Given a ISO8601-ish string generated by @FormatTime@ with @%Q@, generating between no decimal and 12 digits of decimal, normalize it to exactly+-- three digits.+--+-- E.g. from @2017-03-30T13:00:00Z@ generate @2017-03-30T13:00:00.000Z@, and from @2017-03-30T13:00:00.123456789Z@ generate @2017-03-30T12:00:00.123Z@+fixupMs :: String -> String+fixupMs (':':s10:s1:tzChar:rest) | tzChar == 'Z' || tzChar == '+' || tzChar == '-' =+  ':':s10:s1:'.':'0':'0':'0':tzChar:rest+fixupMs (':':s10:s1:'.':digitsAndRest) =+  let (digits, rest) = span isDigit digitsAndRest+      newDigits = take 3 (digits ++ fix ('0':))+  in ':':s10:s1:'.':(newDigits ++ rest)+fixupMs (c:cs) = c : fixupMs cs+fixupMs []     = []

@@ -1,105 +0,0 @@-module Composite.Aeson.Default where--import BasicPrelude-import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor))-import Data.Aeson (FromJSON, ToJSON(toJSON))-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.BetterErrors as ABE-import Data.Int (Int8, Int16)-import Data.Scientific (Scientific)-import qualified Data.Scientific as Scientific-import Data.Word (Word8, Word16)---- |Class for associating a default JSON format with a type.------ DO NOT use this as the primary interface. It should only be used for defaulting in contexts where an explicit choice can also be used.-class DefaultJsonFormat a where-  -- |Produce the default 'JsonFormat' for type @a@, which must not produce any custom errors.-  defaultJsonFormat :: JsonFormat e a--instance DefaultJsonFormat Bool         where defaultJsonFormat = boolJsonFormat-instance DefaultJsonFormat Char         where defaultJsonFormat = charJsonFormat-instance DefaultJsonFormat Scientific   where defaultJsonFormat = scientificJsonFormat-instance DefaultJsonFormat Float        where defaultJsonFormat = realFloatJsonFormat-instance DefaultJsonFormat Double       where defaultJsonFormat = realFloatJsonFormat-instance DefaultJsonFormat Int          where defaultJsonFormat = integralJsonFormat-instance DefaultJsonFormat Int8         where defaultJsonFormat = integralJsonFormat-instance DefaultJsonFormat Int16        where defaultJsonFormat = integralJsonFormat-instance DefaultJsonFormat Int32        where defaultJsonFormat = integralJsonFormat-instance DefaultJsonFormat Int64        where defaultJsonFormat = integralJsonFormat-instance DefaultJsonFormat Word8        where defaultJsonFormat = integralJsonFormat-instance DefaultJsonFormat Word16       where defaultJsonFormat = integralJsonFormat-instance DefaultJsonFormat Word32       where defaultJsonFormat = integralJsonFormat-instance DefaultJsonFormat Word64       where defaultJsonFormat = integralJsonFormat-instance DefaultJsonFormat String       where defaultJsonFormat = stringJsonFormat-instance DefaultJsonFormat Text         where defaultJsonFormat = textJsonFormat-instance DefaultJsonFormat Aeson.Value  where defaultJsonFormat = aesonValueJsonFormat-instance DefaultJsonFormat Aeson.Object where defaultJsonFormat = aesonObjectJsonFormat-instance DefaultJsonFormat Aeson.Array  where defaultJsonFormat = aesonArrayJsonFormat---- |Produce an explicit 'JsonFormat' by using the implicit Aeson 'FromJSON' and 'ToJSON' instances.------ If an @aeson-better-errors@ parser is available for @a@, it's probably better to use 'abeJsonFormat' to get the enhanced error reporting.-aesonJsonFormat :: (ToJSON a, FromJSON a) => JsonFormat e a-aesonJsonFormat = JsonFormat $ JsonProfunctor toJSON ABE.fromAesonParser---- |Produce an explicit 'JsonFormat' by using the implicit Aeson 'ToJSON' instance and an explicit @aeson-better-errors@ 'ABE.Parse'.-abeJsonFormat :: ToJSON a => ABE.Parse e a -> JsonFormat e a-abeJsonFormat p = JsonFormat $ JsonProfunctor toJSON p---- |'JsonFormat' for 'Bool', mapping to a JSON boolean.-boolJsonFormat :: JsonFormat e Bool-boolJsonFormat = abeJsonFormat ABE.asBool---- |'JsonFormat' for 'Char', mapping to a JSON string.-charJsonFormat :: JsonFormat e Char-charJsonFormat = aesonJsonFormat---- |'JsonFormat' for 'Scientific', mapping to a JSON number.------ __Warning:__ some JSON parsing libraries do not accept the scientific number notation even though it's part of the JSON standard, and this format--- uses 'Data.ByteString.Builder.Scientific.scientificBuilder' transitively which encodes very small (< 0.1) and large (> 9,999,999.0) fractional numbers--- using scientific notation.-scientificJsonFormat :: JsonFormat e Scientific-scientificJsonFormat = abeJsonFormat ABE.asScientific---- |Convert some 'RealFloat' value to 'Aeson.Value'. Copied from Aeson internals which do not export it.-realFloatToJson :: RealFloat a => a -> Aeson.Value-realFloatToJson d-  | isNaN d || isInfinite d = Aeson.Null-  | otherwise = Aeson.Number $ Scientific.fromFloatDigits d-{-# INLINE realFloatToJson #-}---- |Polymorphic JSON format for any type which instances 'RealFloat'. See warning in documentation for 'scientificJsonFormat' about scientific notation.-realFloatJsonFormat :: RealFloat a => JsonFormat e a-realFloatJsonFormat = JsonFormat $ JsonProfunctor realFloatToJson ABE.asRealFloat---- |Polymorphic JSON format for any type which instances 'Integral'.-integralJsonFormat :: Integral a => JsonFormat e a-integralJsonFormat = JsonFormat $ JsonProfunctor (Aeson.Number . fromIntegral) ABE.asIntegral---- |JSON format for 'String'.-stringJsonFormat :: JsonFormat e String-stringJsonFormat = abeJsonFormat ABE.asString---- |JSON format for 'Text'.-textJsonFormat :: JsonFormat e Text-textJsonFormat = abeJsonFormat ABE.asText---- |JSON format for '()' which maps to JSON as @null@.-nullJsonFormat :: JsonFormat e ()-nullJsonFormat = abeJsonFormat ABE.asNull---- |JSON format which does no parsing or encoding.-aesonValueJsonFormat :: JsonFormat e Aeson.Value-aesonValueJsonFormat = abeJsonFormat ABE.asValue---- |JSON format for 'Aeson.Object' which maps to any object in JSON.-aesonObjectJsonFormat :: JsonFormat e Aeson.Object-aesonObjectJsonFormat = abeJsonFormat ABE.asObject---- |JSON format for 'Aeson.Array' which maps to any array in JSON.-aesonArrayJsonFormat :: JsonFormat e Aeson.Array-aesonArrayJsonFormat = abeJsonFormat ABE.asArray---- FIXME all the rest!

@@ -0,0 +1,102 @@+module Composite.Aeson.Formats.DateTime+  ( DateTimeFormat(..), regularDateTimeFormat+  , dateTimeJsonFormat+  , iso8601DateJsonFormat, iso8601DateTimeJsonFormat, iso8601TimeJsonFormat+  ) where++import BasicPrelude+import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor))+import Composite.Aeson.DateTimeFormatUtils (fixupTzIn, fixupTzOut, fixupMs)+import Composite.Aeson.Formats.Provided (stringJsonFormat)+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as NEL+import Data.Time.Calendar (Day)+import Data.Time.Clock (UTCTime)+import Data.Time.Format (FormatTime, ParseTime, TimeLocale, defaultTimeLocale, formatTime, parseTimeM)+import Data.Time.LocalTime (TimeOfDay)++-- |Structure carrying the date/time format string along with an example for error messaging and functions which optionally permute the input or output+-- before using the format.+data DateTimeFormat = DateTimeFormat+  { dateTimeFormat           :: String+  , dateTimeFormatExample    :: String+  , dateTimeFormatPreParse   :: String -> String+  , dateTimeFormatPostFormat :: String -> String+  }++-- |Construct a 'DateTimeFormat' with no pre- or post- processing.+regularDateTimeFormat :: String -> String -> DateTimeFormat+regularDateTimeFormat format example = DateTimeFormat format example id id++-- |'JsonFormat' for any type which 'ParseTime' and 'FormatTime' are defined for which maps to JSON via the first format given and maps from JSON via+-- any format given.+dateTimeJsonFormat :: (ParseTime t, FormatTime t) => TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t+dateTimeJsonFormat locale formats@(outFormat :| otherInFormats) = JsonFormat (JsonProfunctor dayOut dayIn)+  where+    formatsList = NEL.toList formats+    JsonFormat (JsonProfunctor stringOut stringIn) = stringJsonFormat+    dayOut = stringOut . dateTimeFormatPostFormat outFormat . formatTime locale (dateTimeFormat outFormat)+    dayIn = do+      s <- stringIn+      let attempt format = successOrFail Left Right $ parseTimeM True locale (dateTimeFormat format) (dateTimeFormatPreParse format s)+          attempts = map attempt formatsList+      case partitionEithers attempts of+        (_, a : _) ->+          pure a+        (es, _) | null otherInFormats ->+          fail $ "expected date/time string formatted as " <> dateTimeFormatExample outFormat <> ", but: " <> intercalate ", " es+        (es, _) ->+          fail $ "expected date/time string formatted as one of "+              <> intercalate ", " (map dateTimeFormatExample formatsList)+              <> ", but: " <> intercalate ", " es++-- |ISO8601 extended date format (@yyyy-mm-dd@).+iso8601DateJsonFormat :: JsonFormat e Day+iso8601DateJsonFormat =+  dateTimeJsonFormat defaultTimeLocale (fmt :| [])+  where+    fmt = regularDateTimeFormat "%F" "yyyy-mm-dd"++-- |ISO8601 extended date/time format (@yyyy-mm-ddThh:mm:ss.sssZ@ or @yyyy-mm-ttThh:mm:ssZ@)+iso8601DateTimeJsonFormat :: JsonFormat e UTCTime+iso8601DateTimeJsonFormat =+  dateTimeJsonFormat defaultTimeLocale (withMs :| [withoutMs])+  where+    withMs    = DateTimeFormat "%FT%T.%Q%z" "yyyy-mm-ddThh:mm:ss.sssZ" fixupTzIn (fixupTzOut . fixupMs)+    withoutMs = DateTimeFormat "%FT%T%z"    "yyyy-mm-ddThh:mm:ssZ"     fixupTzIn fixupTzOut++-- |ISO8601 extended time format (@hh:mm:ss.sss@ or @hh:mm:ss@)+iso8601TimeJsonFormat :: JsonFormat e TimeOfDay+iso8601TimeJsonFormat =+  dateTimeJsonFormat defaultTimeLocale (withMs :| [withoutMs])+  where+    withMs    = DateTimeFormat "%T.%Q%z" "hh:mm:ss.sss" id fixupMs+    withoutMs = DateTimeFormat "%T.%Q"   "hh:mm:ss"     id id+++-- |Monad for capturing uses of 'fail', because @Data.Time.Format@ has a poorly factored interface.+data SuccessOrFail a = Fail String | Success a++instance Functor SuccessOrFail where+  fmap f (Success a) = Success (f a)+  fmap _ (Fail    f) = Fail    f++instance Applicative SuccessOrFail where+  pure   = Success+  Success f <*> Success a = Success (f a)+  Success _ <*> Fail    f = Fail    f+  Fail    f <*> _         = Fail    f++instance Monad SuccessOrFail where+  return = Success+  fail   = Fail++  Success a >>= k = k a+  Fail    f >>= _ = Fail f++-- |Evaluate some action of type @Monad m => m a@ and apply either the first or second function based on whether the computation completed or used @fail@.+successOrFail :: (String -> b) -> (a -> b) -> (forall m. Monad m => m a) -> b+successOrFail _ f (Success a) = f a+successOrFail f _ (Fail    s) = f s++

@@ -0,0 +1,109 @@+module Composite.Aeson.Formats.Default+  ( DefaultJsonFormat(..)+  ) where++import BasicPrelude+import Composite.Aeson.Base (JsonFormat, wrappedJsonFormat)+import Composite.Aeson.Formats.Generic (aesonJsonFormat)+import Composite.Aeson.Formats.InternalTH (makeTupleDefaults)+import Composite.Aeson.Formats.Provided -- sorry+import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)+import qualified Data.Aeson as Aeson+import Data.Functor.Compose (Compose)+import Data.Functor.Const (Const)+import Data.Functor.Identity (Identity)+import Data.Int (Int8, Int16)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Monoid as Monoid+import Data.Scientific (Scientific)+import qualified Data.Semigroup as Semigroup+import Data.Tagged (Tagged)+import Data.Vector (Vector)+import Data.Version (Version)+import Data.Word (Word8, Word16)+import Numeric.Natural (Natural)++-- |Class for associating a default JSON format with a type.+--+-- DO NOT use this as the primary interface. It should only be used for defaulting in contexts where an explicit choice can also be used.+--+-- Instances of this class are (hopefully) provided for each type with an obviously correct interpretation, for example 'Text', 'Int', etc. Conversely types+-- without an obviously correct interpretation and in particular those with many contradictory interpretations are not included, for example 'UTCTime',+-- forcing you to choose one.+--+-- For types with surprising JSON mapping characteristics, take time and consider whether it would be better to explicitly configure what format to use+-- instead of providing a default.+class DefaultJsonFormat a where+  -- |Produce the default 'JsonFormat' for type @a@, which must not produce any custom errors.+  defaultJsonFormat :: JsonFormat e a++  -- |Produce the default 'JsonFormat' for a list of @a@, which must not produce any custom errors.+  -- This function does not usually need to be implemented as it has a sensible default. It exists to avoid overlapping instances, e.g. for @Char@+  -- and @String ~ [Char]@. The default implementation uses 'listJsonFormat'.+  defaultJsonFormatList :: JsonFormat e [a]+  defaultJsonFormatList = listJsonFormat defaultJsonFormat++instance DefaultJsonFormat a => DefaultJsonFormat (Identity a)                where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat+instance DefaultJsonFormat a => DefaultJsonFormat (Semigroup.Min a)           where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat+instance DefaultJsonFormat a => DefaultJsonFormat (Semigroup.Max a)           where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat+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+instance DefaultJsonFormat a => DefaultJsonFormat (Monoid.First a)            where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat+instance DefaultJsonFormat a => DefaultJsonFormat (Monoid.Last a)             where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat+instance DefaultJsonFormat a => DefaultJsonFormat (Const a b)                 where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat+instance DefaultJsonFormat a => DefaultJsonFormat (Tagged b a)                where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat+instance DefaultJsonFormat a => DefaultJsonFormat (Maybe a)                   where defaultJsonFormat = maybeJsonFormat defaultJsonFormat+instance DefaultJsonFormat a => DefaultJsonFormat (NonEmpty a)                where defaultJsonFormat = nonEmptyListJsonFormat defaultJsonFormat+instance DefaultJsonFormat a => DefaultJsonFormat (Seq a)                     where defaultJsonFormat = seqJsonFormat defaultJsonFormat+instance DefaultJsonFormat a => DefaultJsonFormat (Vector a)                  where defaultJsonFormat = vectorJsonFormat defaultJsonFormat++instance DefaultJsonFormat (f (g a)) => DefaultJsonFormat (Compose f g a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat++instance DefaultJsonFormat (f a) => DefaultJsonFormat (Monoid.Alt f a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat++instance (FromJSONKey k, ToJSONKey k, Ord k, FromJSON a, ToJSON a) => DefaultJsonFormat (Map k a) where+  defaultJsonFormat = aesonJsonFormat -- because of the insanity that is FromJSONKey / ToJSONKey++instance (FromJSONKey k, ToJSONKey k, Eq k, Hashable k, FromJSON a, ToJSON a) => DefaultJsonFormat (HashMap k a) where+  defaultJsonFormat = aesonJsonFormat -- because of the insanity that is FromJSONKey / ToJSONKey++$makeTupleDefaults++instance DefaultJsonFormat Monoid.All where defaultJsonFormat = wrappedJsonFormat boolJsonFormat+instance DefaultJsonFormat Monoid.Any where defaultJsonFormat = wrappedJsonFormat boolJsonFormat++instance DefaultJsonFormat Aeson.Value  where defaultJsonFormat = aesonValueJsonFormat+instance DefaultJsonFormat Bool         where defaultJsonFormat = boolJsonFormat+instance DefaultJsonFormat IntSet       where defaultJsonFormat = intSetJsonFormat+instance DefaultJsonFormat Int          where defaultJsonFormat = integralJsonFormat+instance DefaultJsonFormat Int8         where defaultJsonFormat = integralJsonFormat+instance DefaultJsonFormat Int16        where defaultJsonFormat = integralJsonFormat+instance DefaultJsonFormat Int32        where defaultJsonFormat = integralJsonFormat+instance DefaultJsonFormat Int64        where defaultJsonFormat = integralJsonFormat+instance DefaultJsonFormat Integer      where defaultJsonFormat = integralJsonFormat+instance DefaultJsonFormat Word         where defaultJsonFormat = integralJsonFormat+instance DefaultJsonFormat Word8        where defaultJsonFormat = integralJsonFormat+instance DefaultJsonFormat Word16       where defaultJsonFormat = integralJsonFormat+instance DefaultJsonFormat Word32       where defaultJsonFormat = integralJsonFormat+instance DefaultJsonFormat Word64       where defaultJsonFormat = integralJsonFormat+instance DefaultJsonFormat LText        where defaultJsonFormat = lazyTextJsonFormat+instance DefaultJsonFormat Natural      where defaultJsonFormat = naturalJsonFormat+instance DefaultJsonFormat Ordering     where defaultJsonFormat = orderingJsonFormat+instance DefaultJsonFormat Float        where defaultJsonFormat = realFloatJsonFormat+instance DefaultJsonFormat Double       where defaultJsonFormat = realFloatJsonFormat+instance DefaultJsonFormat Scientific   where defaultJsonFormat = scientificJsonFormat+instance DefaultJsonFormat Text         where defaultJsonFormat = textJsonFormat+instance DefaultJsonFormat ()           where defaultJsonFormat = unitJsonFormat+instance DefaultJsonFormat Version      where defaultJsonFormat = versionJsonFormat++instance DefaultJsonFormat Char where+  defaultJsonFormat = charJsonFormat+  defaultJsonFormatList = stringJsonFormat++instance DefaultJsonFormat a => DefaultJsonFormat [a] where+  defaultJsonFormat = defaultJsonFormatList

@@ -0,0 +1,208 @@+module Composite.Aeson.Formats.Generic+  ( abeJsonFormat, aesonJsonFormat, jsonArrayFormat, jsonObjectFormat+  , SumStyle(..), jsonSumFormat+  ) where++import BasicPrelude+import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor), FromJson(FromJson))+import Control.Lens (_Wrapped, over, unsnoc)+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 Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as NEL+import Data.Text (unpack)+import qualified Data.Vector as Vector++-- |Produce an explicit 'JsonFormat' by using the implicit Aeson 'ToJSON' instance and an explicit @aeson-better-errors@ 'ABE.Parse'.+abeJsonFormat :: ToJSON a => ABE.Parse e a -> JsonFormat e a+abeJsonFormat p = JsonFormat $ JsonProfunctor toJSON p++-- |Produce an explicit 'JsonFormat' by using the implicit Aeson 'FromJSON' and 'ToJSON' instances.+--+-- If an @aeson-better-errors@ parser is available for @a@, it's probably better to use 'abeJsonFormat' to get the enhanced error reporting.+aesonJsonFormat :: (ToJSON a, FromJSON a) => JsonFormat e a+aesonJsonFormat = JsonFormat $ JsonProfunctor toJSON ABE.fromAesonParser+++-- |'JsonFormat' for any type which can be converted to/from a list which maps to a JSON array.+jsonArrayFormat :: (t -> [a]) -> ([a] -> ABE.Parse e t) -> JsonFormat e a -> JsonFormat e t+jsonArrayFormat oToList iFromList =+  over _Wrapped $ \ (JsonProfunctor o i) ->+    JsonProfunctor (Aeson.Array . Vector.fromList . map o . oToList)+                   (ABE.eachInArray i >>= iFromList)++-- |'JsonFormat' for any type which can be converted to/from a list of pairs which maps to a JSON object.+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)+                   (ABE.eachInObject i >>= iFromList)+++-- Describes how a sum format should map to JSON.+--+-- Summary of the styles:+--+--   * 'SumStyleFieldName' represents alternate sum branches as different mutually exclusive fields in an object, e.g. @{ "first": 123 }@.+--   * 'SumStyleTypeValue' represents alternate sum branches as different two-field objects, e.g. @{ "type": "first", "value": 123 }@.+--   * 'SumStyleMergeType' represents alternate sum branches by an intrinsic type field and only works with objects, e.g. @{ "type": "first", "a": 123 }@+--+-- Given:+--+-- @+--   data MySum+--     = SumFirst Int+--     | SumSecond String+--+--   mySumFormat :: 'SumStyle' -> 'JsonFormat' e MySum+--   mySumFormat style = jsonSumFormat style o i+--     where+--       o = \ case+--         SumFirst  i -> ("first",  'toJsonWithFormat' 'intJsonFormat'    i)+--         SumSecond s -> ("second", 'toJsonWithFormat' 'stringJsonFormat' s)+--       i = \ case+--         "first"  -> SumFirst  <$> 'parseJsonWithFormat' 'intJsonFormat'+--         "second" -> SumSecond <$> 'parseJsonWithFormat' 'stringJsonFormat'+-- @+--+-- For 'SumStyleFieldName', the object will always have a single field whose name is determined by which element of the sum it represents. For example:+--+-- @+--   toJsonWithFormat (mySumFormat SumStyleFieldName) (SumFirst 123)+-- @+--+-- will yield+--+-- @+--   { "first": 123 }+-- @+--+-- For @'SumStyleTypeValue' typeField valueField@, the object will have two fields @typeField@ and @valueField@, the former determining the format of the+-- latter. For example:+--+-- @+--   toJsonWithFormat (mySumFormat (SumStyleTypeValue "typ" "val")) (SumFirst 123)+-- @+--+-- will yield+--+-- @+--   { "typ": "first", "val": 123 }+-- @+--+-- For @'SumStyleMergeType' typeField@, its expected that every branch of the sum maps to an object in JSON, and the sum will add a new field @typeField@+-- to the object. It's fundamentally a bit dangerous as the assertion that each branch maps as an object is not enforced in the type system, so errors will+-- be produced at runtime. The previously given example can't be used as both branches (@Int@ and @String@) map to JSON values other than objects.+--+-- Given:+--+-- @+--   data FirstThing = FirstThing { a :: Int, b :: String }+--   firstThingJsonFormat = ... -- maps as { a: 123, b: "foo" }+--+--   data MySum+--     = SumFirst FirstThing+--     | ...+--+--   mySumFormat :: 'SumStyle' -> 'JsonFormat' e MySum+--   mySumFormat style = jsonSumFormat style o i+--     where+--       o = \ case+--         SumFirst ft -> ("first", 'toJsonWithFormat' 'firstThingJsonFormat' ft)+--         ...+--       i = \ case+--         "first"  -> SumFirst <$> 'parseJsonWithFormat' 'firstThingJsonFormat'+--         ...+-- @+--+-- Then+--+-- @+--   toJsonWithFormat (SumStyleMergeType "typ") (SumFirst (FirstThing 123 "abc"))+-- @+--+-- will yield+--+-- @+--   { "typ": "first", "a": 123, "b": "abc" }+-- @+--+-- __Warning:__ (again) that 'SumStyleMergeType' will trigger __run time errors__ (ala @error@) when converting to JSON if any of the sum branches yields+-- something that isn't an object. It will also yield a run time error if that object already contains a conflicting field.+data SumStyle+  = SumStyleFieldName+  -- ^Map to a single-field object with the field name determined by the sum branch and the field value being the encoded value for that branch.+  | SumStyleTypeValue Text Text+  -- ^Map to a two-field object with fixed field names, the first being the type field and the second beind the value field.+  | SumStyleMergeType Text+  -- ^Given that each sum branch maps to a JSON object, add/parse an additional field to that object with the given name.++-- |Helper used by the various sum format functions which takes a list of input format pairs and makes an oxford comma list of them.+expectedFieldsForInputs :: NonEmpty (Text, x) -> String+expectedFieldsForInputs ((f, _) :| rest) =+  case unsnoc rest of+    Just (prefix, (fLast, _)) -> unpack $ f <> ", " <> intercalate ", " (map fst prefix) <> ", or " <> fLast+    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.+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++-- |'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)+  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"+++-- |'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)+  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 -> fail $ "expected " <> unpack typeField <> " to be one of " <> expected++-- |'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)+  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 -> fail $ "expected " <> unpack typeField <> " to be one of " <> expected

@@ -0,0 +1,96 @@+module Composite.Aeson.Formats.InternalTH+  ( makeTupleDefaults, makeTupleFormats+  ) where++import BasicPrelude hiding (lift)+import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.BetterErrors as ABE+import qualified Data.Vector as V+import Language.Haskell.TH+  ( Name, mkName, newName, tupleDataName+  , Q+  , cxt, clause, normalB+  , Dec, funD, instanceD, sigD, valD+  , Exp(AppE, ConE, VarE), appE, doE, lamE, listE, varE+  , conP, varP, wildP+  , bindS, noBindS+  , Type(AppT, ArrowT, ConT, ForallT, TupleT, VarT), appT, conT, varT+  , TyVarBndr(PlainTV)+  )+import Language.Haskell.TH.Syntax (lift)++djfClassName :: Name+djfClassName = mkName "Composite.Aeson.Formats.Default.DefaultJsonFormat"++djfFunName :: Name+djfFunName = mkName "Composite.Aeson.Formats.Default.defaultJsonFormat"++-- |Splice which inserts the @DefaultJsonFormat@ instances for tuples.+makeTupleDefaults :: Q [Dec]+makeTupleDefaults = traverse makeTupleDefault [2..59]+  where+    makeTupleDefault arity = do+      names <- traverse (newName . ("a" ++) . show) [1..arity]+      let constraints = map (\ n -> appT (conT djfClassName) (varT n)) names+          instanceHead = appT (conT djfClassName) (pure $ foldl' AppT (TupleT arity) (map VarT names))+          implName = mkName $ "Composite.Aeson.Formats.Provided.tuple" <> show arity <> "JsonFormat"+      instanceD (cxt constraints) instanceHead+        [ funD (mkName "defaultJsonFormat")+          [ clause+              []+              (normalB (pure $ foldl' (\ lhs _ -> AppE lhs (VarE djfFunName)) (VarE implName) [1..arity]))+              []+          ]+        ]++-- |Splice which inserts the @tupleNJsonFormat@ implementations for tuples.+makeTupleFormats :: Q [Dec]+makeTupleFormats = concat <$> traverse makeTupleFormat [2..59]+  where+    makeTupleFormat arity = do+      tyNames   <- traverse (newName . ("t" ++) . show) [1..arity]+      oNames    <- traverse (newName . ("o" ++) . show) [1..arity]+      iNames    <- traverse (newName . ("i" ++) . show) [1..arity]+      oTupName  <- newName "oTup"+      iTupName  <- newName "iTup"+      valNames  <- traverse (newName . ("v" ++) . show) [1..arity]+      tyErrName <- newName "e"++      let name = mkName $ "tuple" <> show arity <> "JsonFormat"+          tupleType = foldl' AppT (TupleT arity) (map VarT tyNames)+          funType =+            ForallT+              (PlainTV tyErrName : map PlainTV tyNames)+              []+              (foldr (\ l r -> AppT (AppT ArrowT (AppT (AppT (ConT ''JsonFormat) (VarT tyErrName)) l)) r)+                     (AppT (AppT (ConT ''JsonFormat) (VarT tyErrName)) tupleType)+                     (map VarT tyNames))+          oTupImpl =+            lamE+              [conP (tupleDataName arity) (map varP valNames)]+              [| (Aeson.Array . V.fromList) $(listE $ map (\ (varName, oName) -> appE (varE oName) (varE varName)) (zip valNames oNames)) |]+          iTupImpl =+            doE+              $  [ bindS wildP [|+                     ABE.withArray Right >>= \ a ->+                       if V.length a == $(lift arity)+                         then pure ()+                         else fail $(lift $ "expected an array of exactly " <> show arity <> " elements")+                     |]+                 ]+              ++ map ( \ (n, valName, iName) ->+                       bindS (varP valName) [| ABE.nth $(lift (n :: Int)) $(varE iName) |] )+                     (zip3 [0..] valNames iNames)+              ++ [ noBindS (appE (varE 'pure) (pure $ foldl' AppE (ConE (tupleDataName arity)) (map VarE valNames))) ]+      sequence+        [ sigD name (pure funType)+        , funD name+          [ clause+              (map (\ (oName, iName) -> conP 'JsonFormat [conP 'JsonProfunctor [varP oName, varP iName]]) (zip oNames iNames))+              (normalB [| JsonFormat (JsonProfunctor $(varE oTupName) $(varE iTupName)) |])+              [ valD (varP oTupName) (normalB oTupImpl) []+              , valD (varP iTupName) (normalB iTupImpl) []+              ]+          ]+        ]

@@ -0,0 +1,175 @@+-- |Module which provides 'JsonFormat's for a variety of types from @base@ and other common packages.+module Composite.Aeson.Formats.Provided where++import BasicPrelude+import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor), _JsonProfunctor, dimapJsonFormat, toJsonWithFormat)+import Composite.Aeson.Formats.Generic (SumStyle, abeJsonFormat, aesonJsonFormat, jsonArrayFormat, jsonObjectFormat, jsonSumFormat)+import Composite.Aeson.Formats.InternalTH (makeTupleFormats)+import Control.Lens (_2, _Wrapped, over, view)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.BetterErrors as ABE+import Data.Fixed (HasResolution, Fixed)+import Data.Foldable (toList)+import qualified Data.HashMap.Lazy as LazyHashMap+import qualified Data.HashMap.Strict as StrictHashMap+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map.Lazy as LazyMap+import qualified Data.Map.Strict as StrictMap+import Data.Scientific (Scientific)+import qualified Data.Scientific as Scientific+import qualified Data.Sequence as Sequence+import qualified Data.Text.Lazy as LT+import qualified Data.Vector as V+import Data.Version (Version)+import Numeric.Natural (Natural)+++-- |JSON format for 'Aeson.Array' which maps to any array in JSON.+aesonArrayJsonFormat :: JsonFormat e Aeson.Array+aesonArrayJsonFormat = abeJsonFormat ABE.asArray++-- |JSON format for 'Aeson.Object' which maps to any object in JSON.+aesonObjectJsonFormat :: JsonFormat e Aeson.Object+aesonObjectJsonFormat = abeJsonFormat ABE.asObject++-- |JSON format which does no parsing or encoding.+aesonValueJsonFormat :: JsonFormat e Aeson.Value+aesonValueJsonFormat = abeJsonFormat ABE.asValue++-- |'JsonFormat' for 'Bool', mapping to a JSON boolean.+boolJsonFormat :: JsonFormat e Bool+boolJsonFormat = abeJsonFormat ABE.asBool++-- |'JsonFormat' for 'Char', mapping to a JSON string.+charJsonFormat :: JsonFormat e Char+charJsonFormat = aesonJsonFormat++-- |'JsonFormat' for 'Either' which maps to JSON as an object via 'jsonSumFormat'.+eitherJsonFormat :: SumStyle -> Text -> Text -> JsonFormat e a -> JsonFormat e b -> JsonFormat e (Either a b)+eitherJsonFormat style leftName rightName leftFormat rightFormat = jsonSumFormat style o is+  where+    o = \ case+      Left  a -> (leftName,  toJsonWithFormat leftFormat  a)+      Right b -> (rightName, toJsonWithFormat rightFormat b)+    is =+      (leftName, Left <$> view (_Wrapped . _JsonProfunctor . _2) leftFormat) :| [(rightName, Right <$> view (_Wrapped . _JsonProfunctor . _2) rightFormat)]++-- |'JsonFormat' for 'Fixed' precision real numbers.+fixedJsonFormat :: HasResolution r => JsonFormat e (Fixed r)+fixedJsonFormat = aesonJsonFormat++-- |'JsonFormat' for 'StrictHashMap.HashMap' where the key type can be converted to and from a 'Text', mapping to a JSON object.+strictHashMapJsonFormat :: (Eq k, Hashable k) => (k -> Text) -> (Text -> ABE.Parse e k) -> JsonFormat e a -> JsonFormat e (StrictHashMap.HashMap k a)+strictHashMapJsonFormat kToText kFromText =+  jsonObjectFormat (map (first kToText) . StrictHashMap.toList)+                   (map StrictHashMap.fromList . traverse (\ (k, a) -> (, a) <$> kFromText k))++-- |'JsonFormat' for 'LazyHashMap.HashMap' where the key type can be converted to and from a 'Text', mapping to a JSON object.+lazyHashMapJsonFormat :: (Eq k, Hashable k) => (k -> Text) -> (Text -> ABE.Parse e k) -> JsonFormat e a -> JsonFormat e (LazyHashMap.HashMap k a)+lazyHashMapJsonFormat kToText kFromText =+  jsonObjectFormat (map (first kToText) . LazyHashMap.toList)+                   (map LazyHashMap.fromList . traverse (\ (k, a) -> (, a) <$> kFromText k))++-- |'JsonFormat' for 'IntSet' which maps to an array of numbers.+intSetJsonFormat :: JsonFormat e IntSet+intSetJsonFormat = aesonJsonFormat++-- |Polymorphic JSON format for any type which instances 'Integral'.+integralJsonFormat :: Integral a => JsonFormat e a+integralJsonFormat = JsonFormat $ JsonProfunctor (Aeson.Number . fromIntegral) ABE.asIntegral++-- |'JsonFormat' for 'Data.Text.Lazy.Text'.+lazyTextJsonFormat :: JsonFormat e LT.Text+lazyTextJsonFormat = dimapJsonFormat LT.toStrict LT.fromStrict textJsonFormat++-- |'JsonFormat' for '[]' which maps to a JSON array.+listJsonFormat :: JsonFormat e a -> JsonFormat e [a]+listJsonFormat = jsonArrayFormat id pure++-- |'JsonFormat' for 'StrictMap.Map' where the key type can be converted to and from a 'Text', mapping to a JSON object.+strictMapJsonFormat :: Ord k => (k -> Text) -> (Text -> ABE.Parse e k) -> JsonFormat e a -> JsonFormat e (StrictMap.Map k a)+strictMapJsonFormat kToText kFromText =+  jsonObjectFormat (map (first kToText) . StrictMap.toAscList)+                   (map StrictMap.fromList . traverse (\ (k, a) -> (, a) <$> kFromText k))++-- |'JsonFormat' for 'LazyMap.Map' where the key type can be converted to and from a 'Text', mapping to a JSON object.+lazyMapJsonFormat :: Ord k => (k -> Text) -> (Text -> ABE.Parse e k) -> JsonFormat e a -> JsonFormat e (LazyMap.Map k a)+lazyMapJsonFormat kToText kFromText =+  jsonObjectFormat (map (first kToText) . LazyMap.toAscList)+                   (map LazyMap.fromList . traverse (\ (k, a) -> (, a) <$> kFromText k))++-- |'JsonFormat' for 'Maybe' which maps @Nothing@ to @null@.+maybeJsonFormat :: JsonFormat e a -> JsonFormat e (Maybe a)+maybeJsonFormat =+  over _Wrapped $ \ (JsonProfunctor o i) ->+    JsonProfunctor (maybe Aeson.Null o) (ABE.perhaps i)++-- |'JsonFormat' for 'Natural' numbers.+naturalJsonFormat :: JsonFormat e Natural+naturalJsonFormat = aesonJsonFormat++-- |'JsonFormat' for 'NonEmpty' which maps to a JSON array.+nonEmptyListJsonFormat :: JsonFormat e a -> JsonFormat e (NonEmpty a)+nonEmptyListJsonFormat =+  jsonArrayFormat NEL.toList (maybe (fail "expected nonempty array") pure . NEL.nonEmpty)++-- |JSON format for '()' which maps to JSON as @null@.+nullJsonFormat :: JsonFormat e ()+nullJsonFormat = abeJsonFormat ABE.asNull++-- |JSON format for 'Ordering' which maps to the strings @LT@, @GT@, and @EQ@+orderingJsonFormat :: JsonFormat e Ordering+orderingJsonFormat = aesonJsonFormat++-- |Polymorphic JSON format for any type which instances 'RealFloat'. See warning in documentation for 'scientificJsonFormat' about scientific notation.+realFloatJsonFormat :: RealFloat a => JsonFormat e a+realFloatJsonFormat = JsonFormat $ JsonProfunctor realFloatToJson ABE.asRealFloat++-- |Convert some 'RealFloat' value to 'Aeson.Value'. Copied from Aeson internals which do not export it.+realFloatToJson :: RealFloat a => a -> Aeson.Value+realFloatToJson d+  | isNaN d || isInfinite d = Aeson.Null+  | otherwise = Aeson.Number $ Scientific.fromFloatDigits d+{-# INLINE realFloatToJson #-}++-- |'JsonFormat' for 'Scientific', mapping to a JSON number.+--+-- __Warning:__ some JSON parsing libraries do not accept the scientific number notation even though it's part of the JSON standard, and this format+-- uses 'Data.ByteString.Builder.Scientific.scientificBuilder' transitively which encodes very small (< 0.1) and large (> 9,999,999.0) fractional numbers+-- using scientific notation.+scientificJsonFormat :: JsonFormat e Scientific+scientificJsonFormat = abeJsonFormat ABE.asScientific++-- |'JsonFormat' for 'Seq'.+seqJsonFormat :: JsonFormat e a -> JsonFormat e (Seq a)+seqJsonFormat = jsonArrayFormat toList (pure . Sequence.fromList)++-- |'JsonFormat' for 'String'.+stringJsonFormat :: JsonFormat e String+stringJsonFormat = abeJsonFormat ABE.asString++-- |'JsonFormat' for arbitrary sum types which maps to JSON as an object with fields determined by the 'SumStyle' chosen. See 'SumStyle' for more information+-- about the various styles.++-- |'JsonFormat' for 'Text'.+textJsonFormat :: JsonFormat e Text+textJsonFormat = abeJsonFormat ABE.asText++$makeTupleFormats++-- |'JsonFormat' for '()' which maps to an empty array.+unitJsonFormat :: JsonFormat e ()+unitJsonFormat = aesonJsonFormat++-- |'JsonFormat' for 'Vector's which map to an array.+vectorJsonFormat :: JsonFormat e a -> JsonFormat e (V.Vector a)+vectorJsonFormat (JsonFormat (JsonProfunctor oA iA)) =+  JsonFormat (JsonProfunctor o i)+  where+    o = Aeson.Array . map oA+    i = V.fromList <$> ABE.eachInArray iA++-- |'JsonFormat' for 'Version' which maps to a string.+versionJsonFormat :: JsonFormat e Version+versionJsonFormat = aesonJsonFormat

@@ -2,22 +2,61 @@  import BasicPrelude import Composite.Aeson.Base-  ( ToJson(ToJson)-  , FromJson(FromJson)-  , JsonProfunctor(JsonProfunctor), _JsonProfunctor+  ( JsonProfunctor(JsonProfunctor)   , JsonFormat(JsonFormat)-  , wrappedFormat+  , wrappedJsonFormat   ) import Composite.Base (NamedField(fieldName))-import Composite.Aeson.Default (DefaultJsonFormat(defaultJsonFormat))-import Control.Lens (Wrapped(type Unwrapped, _Wrapped'), _1, _2, view)+import Composite.Aeson.Formats.Default (DefaultJsonFormat(defaultJsonFormat))+import Control.Lens (Wrapped(type Unwrapped, _Wrapped'), from, view) import qualified Data.Aeson as Aeson import qualified Data.Aeson.BetterErrors as ABE+import Data.Functor.Contravariant (Contravariant, contramap) import qualified Data.HashMap.Strict as HM import Data.Proxy (Proxy(Proxy)) import Data.Vinyl (Rec((:&), RNil), rmap) import Data.Vinyl.Functor (Identity(Identity)) +-- |Function to encode a single field of a record, possibly choosing to elide the field with @Nothing@.+newtype ToField a = ToField { unToField :: a -> Maybe Aeson.Value }++instance Contravariant ToField where+  contramap f (ToField g) = ToField (g . f)++-- |Function to decode a single field of a record.+newtype FromField e a = FromField { unFromField :: Text -> ABE.Parse e a }++instance Functor (FromField e) where+  fmap f (FromField g) = FromField (fmap f . g)++-- |Descriptor of how to handle a single record field with functions to parse and emit the field which can handle missing fields on parse and elide fields on+-- encode.+data JsonField e a = JsonField (a -> Maybe Aeson.Value) (Text -> ABE.Parse e a)++-- |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 :: (Wrapped a', Unwrapped a' ~ a) => JsonFormat e a -> JsonField e a'+field fmt = field' (wrappedJsonFormat fmt)++-- |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 @Maybe a@ which substitutes @Nothing@ for either @null@ or missing field,+-- and which elides the field on @Nothing@.+optionalField :: forall e a a'. (Wrapped a', Unwrapped a' ~ Maybe a) => JsonFormat e a -> JsonField e a'+optionalField (JsonFormat (JsonProfunctor o i)) =+  JsonField+    (map o . view _Wrapped')+    (\ k -> view (from _Wrapped') . join <$> ABE.keyMay k (ABE.perhaps i))++-- |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)+optionalField' (JsonFormat (JsonProfunctor o i)) =+  JsonField+    (map o)+    (\ k -> join <$> ABE.keyMay k (ABE.perhaps i))+ -- |Type of a Vinyl/Frames record which describes how to map fields of a record to JSON and back. -- -- This record type has the same field names and types as a regular record with 'Identity' but instead of 'Identity' uses 'JsonFormat e'.@@ -32,8 +71,8 @@ -- -- @ --   userFormatRec :: 'JsonFormatRec' e User---   userFormatRec = 'Composite.Aeson.Default.integralJsonFormat'---                &: 'Composite.Aeson.Default.textJsonFormat'+--   userFormatRec = 'field' 'Composite.Aeson.Default.integralJsonFormat'+--                &: 'field' 'Composite.Aeson.Default.textJsonFormat' --                &: Nil -- @ --@@ -59,38 +98,38 @@ -- Would use the same JSON schema as the other examples, but the @id@ field would be encoded in JSON as 10 higher. -- -- Once you've produced an appropriate 'JsonFormatRec' for your case, use 'recJsonFormat' to make a @'JsonFormat' e (Record '[…])@ of it.-type JsonFormatRec e rs = Rec (JsonFormat e) rs+type JsonFormatRec e rs = Rec (JsonField e) rs  -- |Helper class which induces over the structure of a record, reflecting the name of each field and applying each 'ToJson' to its corresponding value to -- produce JSON. class RecToJsonObject rs where-  -- |Given a record of 'ToJson' functions for each field in @rs@, convert an 'Identity' record to 'Aeson.Object'.-  recToJsonObject :: Rec ToJson rs -> Rec Identity rs -> Aeson.Object+  -- |Given a record of 'ToField' functions for each field in @rs@, convert an 'Identity' record to 'Aeson.Object'.+  recToJsonObject :: Rec ToField rs -> Rec Identity rs -> Aeson.Object  instance RecToJsonObject '[] where   recToJsonObject _ = const mempty  instance forall r rs. (NamedField r, RecToJsonObject rs) => RecToJsonObject (r ': rs) where-  recToJsonObject (ToJson aToJson :& fs) (Identity a :& as) =-    HM.insert (fieldName (Proxy :: Proxy r)) (aToJson a) $+  recToJsonObject (ToField aToField :& fs) (Identity a :& as) =+    maybe id (HM.insert (fieldName (Proxy :: Proxy r))) (aToField a) $       recToJsonObject fs as --- |Given a record of 'ToJson' functions for each field in @rs@, convert an 'Identity' record to JSON. Equivalent to @Aeson.Object . 'recToJsonObject' fmt@-recToJson :: RecToJsonObject rs => Rec ToJson rs -> Rec Identity rs -> Aeson.Value+-- |Given a record of 'ToField' functions for each field in @rs@, convert an 'Identity' record to JSON. Equivalent to @Aeson.Object . 'recToJsonObject' fmt@+recToJson :: RecToJsonObject rs => Rec ToField rs -> Rec Identity rs -> Aeson.Value recToJson = map Aeson.Object . recToJsonObject  -- |Class which induces over the structure of a record, parsing fields using a record of 'FromJson' and assembling an 'Identity' record. class RecFromJson rs where   -- |Given a record of 'FromJson' parsers for each field in @rs@, produce an 'ABE.Parse' to make an 'Identity' record.-  recFromJson :: Rec (FromJson e) rs -> ABE.Parse e (Rec Identity rs)+  recFromJson :: Rec (FromField e) rs -> ABE.Parse e (Rec Identity rs)  instance RecFromJson '[] where   recFromJson _ = pure RNil  instance forall r rs. (NamedField r, RecFromJson rs) => RecFromJson (r ': rs) where-  recFromJson (FromJson aFromJson :& fs) =+  recFromJson (FromField aFromField :& fs) =     (:&)-      <$> ABE.key (fieldName (Proxy :: Proxy r)) (Identity <$> aFromJson)+      <$> (Identity <$> aFromField (fieldName (Proxy :: Proxy r)))       <*> recFromJson fs  -- |Take a 'JsonFormatRec' describing how to map a record with field @rs@ to and from JSON and produce a @'JsonFormat' e (Record rs)@.@@ -99,8 +138,8 @@ recJsonFormat :: (RecToJsonObject rs, RecFromJson rs) => JsonFormatRec e rs -> JsonFormat e (Rec Identity rs) recJsonFormat formatRec =   JsonFormat $ JsonProfunctor-    (recToJson   . rmap (view (_Wrapped' . _JsonProfunctor . _1)) $ formatRec)-    (recFromJson . rmap (view (_Wrapped' . _JsonProfunctor . _2)) $ formatRec)+    (recToJson   . rmap (\ (JsonField o _) -> ToField o  ) $ formatRec)+    (recFromJson . rmap (\ (JsonField _ i) -> FromField i) $ formatRec)  -- |Class to make a 'JsonFormatRec' with 'defaultJsonFormat' for each field. class DefaultJsonFormatRec rs where@@ -108,7 +147,7 @@   defaultJsonFormatRec :: JsonFormatRec e rs  instance (NamedField r, DefaultJsonFormat (Unwrapped r), DefaultJsonFormatRec rs) => DefaultJsonFormatRec (r ': rs) where-  defaultJsonFormatRec = wrappedFormat defaultJsonFormat :& defaultJsonFormatRec+  defaultJsonFormatRec = field defaultJsonFormat :& defaultJsonFormatRec  instance DefaultJsonFormatRec '[] where   defaultJsonFormatRec = RNil

@@ -0,0 +1,111 @@+module Composite.Aeson.TH+  ( makeRecJsonWrapper+  , makeRecJsonWrapperExplicit+  ) where++import BasicPrelude+import Composite.Aeson.Base (JsonFormat, dimapJsonFormat, parseJsonWithFormat', toJsonWithFormat)+import Composite.Aeson.Record (defaultJsonFormatRec, recJsonFormat)+import Control.Lens (_head, over)+import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))+import Data.Char (toLower)+import Frames (Record)+import Language.Haskell.TH+  ( Q, clause, cxt+  , normalB+  , recC, varBangType, bang, bangType, noSourceUnpackedness, noSourceStrictness+  , Dec, funD, instanceD, newtypeD, sigD, valD+  , Exp, conE, varE+  , Name, mkName, newName+  , varP+  , conT+  )++-- |TH splice which makes it more convenient to define ToJSON / FromJSON instances for record types.+--+-- For example:+--+-- @+--   type MyRecord = '[FFoo, FBar]+--   makeRecJsonWrapper "MyRecordJson" ''MyRecord+-- @+--+-- is equivalent to:+--+-- @+--   newtype MyRecordJson = MyRecordJson { unMyRecordJson :: Record MyRecord }+--   myRecordJsonFormat :: 'Composite.Aeson.Record.JsonFormatRec' Void MyRecordJson+--   myRecordJsonFormat =+--     'dimapJsonFormat' unMyRecordJson MyRecordJson $+--       'recJsonFormat' defaultJsonFormatRec+--   instance FromJSON MyRecordJson where+--     parseJSON = 'parseJsonWithFormat'' myRecordJsonFormat+--   instance ToJSON MyRecordJson where+--     toJSON = 'toJsonWithFormat' myRecordJsonFormat+-- @+--+-- This function uses 'defaultJsonFormatRec' to derive the formatting for the record. If you want to customize that formatting, use+-- 'makeRecJsonWrapperExplicit' instead.+makeRecJsonWrapper :: String -> Name -> Q [Dec]+makeRecJsonWrapper wrapperName tyName =+  makeRecJsonWrapperExplicit wrapperName tyName [| defaultJsonFormatRec |]++-- |TH splice which makes it more convenient to define ToJSON / FromJSON instances for record types.+--+-- For example:+--+-- @+--   type MyRecord = '[FFoo, FBar]+--   makeRecJsonWrapperExplicit "MyRecordJson" ''MyRecord [| set (rlens fFoo_) specialFormat defaultJsonFormatRec |]+-- @+--+-- is equivalent to:+--+-- @+--   newtype MyRecordJson = MyRecordJson { unMyRecordJson :: Record MyRecord }+--   myRecordJsonFormat :: 'Composite.Aeson.Record.JsonFormatRec' Void MyRecordJson+--   myRecordJsonFormat =+--     'dimapJsonFormat' unMyRecordJson MyRecordJson $+--       'recJsonFormat' (set (rlens fFoo_) specialFormat defaultJsonFormatRec)+--   instance FromJSON MyRecordJson where+--     parseJSON = 'parseJsonWithFormat'' myRecordJsonFormat+--   instance ToJSON MyRecordJson where+--     toJSON = 'toJsonWithFormat' myRecordJsonFormat+-- @+makeRecJsonWrapperExplicit :: String -> Name -> Q Exp -> Q [Dec]+makeRecJsonWrapperExplicit wrapperNameStr fieldsTyName recFormatExp = do+  let wrapperName = mkName wrapperNameStr+      extractorName = mkName $ "un" <> wrapperNameStr+      recordTy = [t| Record $(conT fieldsTyName) |]+  formatName <- newName $ over _head toLower wrapperNameStr <> "Format"+  sequence+    [ newtypeD+        (cxt [])+        wrapperName+        [] -- TyVarBndrs+        Nothing -- kind+        (recC wrapperName [varBangType extractorName (bangType (bang noSourceUnpackedness noSourceStrictness) recordTy)])+        (cxt []) -- deriving context+    , sigD+        formatName+        [t| forall e. JsonFormat e $(conT wrapperName) |]+    , valD+        (varP formatName)+        (normalB [| dimapJsonFormat $(varE extractorName) $(conE wrapperName) (recJsonFormat $recFormatExp) |])+        []+    , instanceD+        (cxt [])+        [t| FromJSON $(conT wrapperName) |]+        [ funD+            'parseJSON+            [ clause [] (normalB [| parseJsonWithFormat' $(varE formatName) |]) [] ]+        ]+    , instanceD+        (cxt [])+        [t| ToJSON $(conT wrapperName) |]+        [ funD+            'toJSON+            [ clause [] (normalB [| toJsonWithFormat $(varE formatName) |]) [] ]+        ]+    ]+

@@ -0,0 +1,10 @@+import BasicPrelude+import RecordSpec (recordSuite)+import TupleSpec (tupleSuite)+import Test.Hspec (hspec)++main :: IO ()+main = hspec $ do+  recordSuite+  tupleSuite+

@@ -0,0 +1,45 @@+module RecordSpec where++import BasicPrelude+import Composite.Aeson.Base (JsonFormat, fromJsonWithFormat, toJsonWithFormat)+import Composite.Aeson.Formats.Provided (stringJsonFormat)+import Composite.Aeson.Record (defaultJsonFormatRec, recJsonFormat, optionalField)+import Composite.TH (withLensesAndProxies)+import Control.Lens (set)+import Data.Aeson.BetterErrors (parseValue)+import Data.Aeson.QQ (aesonQQ)+import Data.Vinyl.Lens (rlens)+import Data.Void (Void)+import Frames (Record, (:->), (&:), pattern Nil)+import Test.Hspec (Spec, describe, it, shouldBe, shouldNotBe)++withLensesAndProxies [d|+  type FFoo = "foo" :-> Int+  type FBar = "bar" :-> Maybe String+  |]+type TestRec = '["foo" :-> Int, "bar" :-> Maybe String]++recordSuite :: Spec+recordSuite =+  describe "Record support" $ do+    let defaultFmt, optionalFmt :: JsonFormat Void (Record TestRec)+        defaultFmt = recJsonFormat defaultJsonFormatRec+        optionalFmt = recJsonFormat $ set (rlens fBar_) (optionalField stringJsonFormat) defaultJsonFormatRec++    it "by default requires all fields" $ do+      parseValue (fromJsonWithFormat defaultFmt) [aesonQQ| {foo: 123, bar: "abc"} |] `shouldBe`    Right (123 &: Just "abc" &: Nil)+      parseValue (fromJsonWithFormat defaultFmt) [aesonQQ| {foo: 123, bar: null}  |] `shouldBe`    Right (123 &: Nothing    &: Nil)+      parseValue (fromJsonWithFormat defaultFmt) [aesonQQ| {foo: 123}             |] `shouldNotBe` Right (123 &: Nothing    &: Nil)++    it "by default encodes all fields" $ do+      toJsonWithFormat defaultFmt (123 &: Just "abc" &: Nil) `shouldBe` [aesonQQ| {foo: 123, bar: "abc"} |]+      toJsonWithFormat defaultFmt (123 &: Nothing    &: Nil) `shouldBe` [aesonQQ| {foo: 123, bar: null}  |]++    it "can make fields optional" $ do+      parseValue (fromJsonWithFormat optionalFmt) [aesonQQ| {foo: 123, bar: "abc"} |] `shouldBe` Right (123 &: Just "abc" &: Nil)+      parseValue (fromJsonWithFormat optionalFmt) [aesonQQ| {foo: 123, bar: null}  |] `shouldBe` Right (123 &: Nothing    &: Nil)+      parseValue (fromJsonWithFormat optionalFmt) [aesonQQ| {foo: 123}             |] `shouldBe` Right (123 &: Nothing    &: Nil)++    it "omits Nothing fields when they're made optional" $ do+      toJsonWithFormat optionalFmt (123 &: Just "abc" &: Nil) `shouldBe` [aesonQQ| {foo: 123, bar: "abc"} |]+      toJsonWithFormat optionalFmt (123 &: Nothing    &: Nil) `shouldBe` [aesonQQ| {foo: 123}             |]

@@ -0,0 +1,17 @@+module TupleSpec where++import BasicPrelude+import Composite.Aeson.Base (JsonFormat, fromJsonWithFormat, toJsonWithFormat)+import Composite.Aeson.Formats.Provided (tuple3JsonFormat, integralJsonFormat, stringJsonFormat, charJsonFormat)+import Data.Aeson.BetterErrors (parseValue)+import Data.Void (Void)+import Test.Hspec (Spec, describe, it, shouldBe)+import Test.QuickCheck (property)++tupleSuite :: Spec+tupleSuite =+  describe "Tuple formats" $ do+    it "works for 3-tuples" $ do+      let fmt = tuple3JsonFormat (integralJsonFormat :: JsonFormat Void Int) stringJsonFormat charJsonFormat+      property $ \ t ->+        parseValue (fromJsonWithFormat fmt) (toJsonWithFormat fmt t) `shouldBe` Right t