composite-aeson (empty) → 0.1.0.0
raw patch · 7 files changed
+422/−0 lines, 7 filesdep +aesondep +aeson-better-errorsdep +basesetup-changed
Dependencies added: aeson, aeson-better-errors, base, basic-prelude, composite-base, containers, contravariant, generic-deriving, lens, profunctors, scientific, text, unordered-containers, vinyl
Files
- Setup.hs +2/−0
- composite-aeson.cabal +44/−0
- src/Composite/Aeson.hs +11/−0
- src/Composite/Aeson/Base.hs +93/−0
- src/Composite/Aeson/Default.hs +105/−0
- src/Composite/Aeson/Enum.hs +53/−0
- src/Composite/Aeson/Record.hs +114/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ composite-aeson.cabal view
@@ -0,0 +1,44 @@+-- This file has been generated from package.yaml by hpack version 0.15.0.+--+-- see: https://github.com/sol/hpack++name: composite-aeson+version: 0.1.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+homepage: https://github.com/ConferHealth/composite#readme+author: Confer Health, Inc+maintainer: oss@confer.care+copyright: 2017 Confer Health, Inc.+license: BSD3+build-type: Simple+cabal-version: >= 1.10++library+ hs-source-dirs:+ src+ default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NoImplicitPrelude OverloadedStrings PolyKinds ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns+ ghc-options: -Wall -O2+ build-depends:+ base >= 4.7 && < 5+ , aeson+ , aeson-better-errors+ , basic-prelude+ , composite-base+ , containers+ , contravariant+ , generic-deriving+ , lens+ , profunctors+ , scientific+ , text+ , unordered-containers+ , vinyl+ exposed-modules:+ Composite.Aeson+ Composite.Aeson.Base+ Composite.Aeson.Default+ Composite.Aeson.Enum+ Composite.Aeson.Record+ default-language: Haskell2010
+ src/Composite/Aeson.hs view
@@ -0,0 +1,11 @@+module Composite.Aeson+ ( module Composite.Aeson.Base+ , module Composite.Aeson.Default+ , module Composite.Aeson.Enum+ , module Composite.Aeson.Record+ ) where++import Composite.Aeson.Base+import Composite.Aeson.Default+import Composite.Aeson.Enum+import Composite.Aeson.Record
+ src/Composite/Aeson/Base.hs view
@@ -0,0 +1,93 @@+module Composite.Aeson.Base+ ( ToJson(..), FromJson(..), JsonProfunctor(..), _JsonProfunctor, JsonFormat(..)+ , toJsonWithFormat, fromJsonWithFormat, parseJsonWithFormat, parseJsonWithFormat'+ , dimapJsonFormat, jsonFormatWithIso, wrappedFormat+ ) where++import BasicPrelude+import Control.Lens (AnIso', Iso, Wrapped(type Unwrapped), _Wrapped', _Wrapped, iso, over, withIso)+import Control.Lens.TH (makeWrapped)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import qualified Data.Aeson.BetterErrors as ABE+import Data.Functor.Contravariant (Contravariant, contramap)+import Data.Profunctor (Profunctor(dimap))+import Data.Void (Void)++-- |Type of functions which take a value @a@ and convert it to an 'Aeson.Value'.+--+-- Wrapper around a function of type @a -> Aeson.Value@.+--+-- Doesn't currently include support for the newer Aeson Encoding machinery, but should.+newtype ToJson a = ToJson { unToJson :: a -> Aeson.Value }++instance Contravariant ToJson where+ contramap f (ToJson g) = ToJson (g . f)++-- |Type of parsers which might emit some custom error of type @e@ and produce a value of type @a@ on success.+--+-- @a@ is the type of value that can be parsed from JSON using this profunctor, and @e@ is the type of custom error that can be produced when the JSON is+-- unacceptable. If your parser doesn't produce any custom errors, leave this type polymorphic.+--+-- Wrapper about an @aeson-better-errors@ 'ABE.Parse' @e@ @a@.+newtype FromJson e a = FromJson { unFromJson :: ABE.Parse e a }++deriving instance Functor (FromJson e)++-- |Type of profunctors which produce and consume JSON, a composition of @ToJson@ and @FromJson@.+--+-- @a@ is the type of value that can be converted to 'Aeson.Value' using this profunctor.+-- @b@ is the type of value that can be parsed from JSON using this profunctor, and @e@ is the type of custom error that can be produced when the JSON is+-- unacceptable. If your parser doesn't produce any custom errors, leave this type polymorphic.+--+-- Profunctors must have two type parameters @a@ and @b@ so this type has two, but @JsonProfunctor@s with different types aren't useful for JSON processing+-- directly. See 'JsonFormat' for a wrapper which fixes the two types.+--+-- Doesn't currently include support for the newer Aeson Encoding machinery, but should.+data JsonProfunctor e a b = JsonProfunctor (a -> Aeson.Value) (ABE.Parse e b)++instance Profunctor (JsonProfunctor e) where+ dimap f g (JsonProfunctor o i) = JsonProfunctor (o . f) (g <$> i)++-- |Observe that a 'JsonProfunctor' is isomorphic to a pair with a @ToJson@ and @FromJson@.+_JsonProfunctor :: Iso (JsonProfunctor e a b) (JsonProfunctor e' a' b') (ToJson a, FromJson e b) (ToJson a', FromJson e' b')+_JsonProfunctor =+ iso (\ (JsonProfunctor o i) -> (ToJson o, FromJson i))+ (\ (ToJson o, FromJson i) -> JsonProfunctor o i)++-- |Wrapper around 'JsonProfunctor' for use in JSON processing when the profunctor represents a bijection between JSON and a single type @a@, i.e. for+-- @JsonProfunctor e a a@.+newtype JsonFormat e a = JsonFormat { unJsonFormat :: JsonProfunctor e a a }++-- |Given a 'JsonFormat' for @a@, convert a value of @a@ into an 'Aeson.Value'.+toJsonWithFormat :: JsonFormat e a -> a -> Aeson.Value+toJsonWithFormat (JsonFormat (JsonProfunctor o _)) = o++-- |Given a 'JsonFormat' for @a@ which can produce custom errors of type @e@, yield an @aeson-better-errors@ 'ABE.Parse' which can be used to consume JSON.+fromJsonWithFormat :: JsonFormat e a -> ABE.Parse e a+fromJsonWithFormat (JsonFormat (JsonProfunctor _ i)) = i++-- |Given a 'JsonFormat' for @a@ which produces custom errors of type @e@ and some function to format those errors as messages, produce an Aeson parser function+-- @Value -> Parser a@.+parseJsonWithFormat :: (e -> Text) -> JsonFormat e a -> Aeson.Value -> Aeson.Parser a+parseJsonWithFormat showError = ABE.toAesonParser showError . fromJsonWithFormat++-- |Given a 'JsonFormat' for @a@ which doesn't produce custom errors, produce an Aeson parser function @Value -> Parser a@.+parseJsonWithFormat' :: JsonFormat Void a -> Aeson.Value -> Aeson.Parser a+parseJsonWithFormat' = ABE.toAesonParser' . fromJsonWithFormat++makeWrapped ''ToJson+makeWrapped ''FromJson+makeWrapped ''JsonFormat++-- |Wrap a 'JsonFormat' for type @a@ in a pair of functions representing an isomorphism between @a@ and @b@ to produce a new @JsonFormat@ for @b@.+dimapJsonFormat :: (b -> a) -> (a -> b) -> JsonFormat e a -> JsonFormat e b+dimapJsonFormat f g = over _Wrapped (dimap f g)++-- |Wrap a 'JsonFormat' for type @a@ in an isomorphism to produce a new @JsonFormat@ for @b@.+jsonFormatWithIso :: AnIso' b a -> JsonFormat e a -> JsonFormat e b+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'
+ src/Composite/Aeson/Default.hs view
@@ -0,0 +1,105 @@+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!
+ src/Composite/Aeson/Enum.hs view
@@ -0,0 +1,53 @@+module Composite.Aeson.Enum where++import BasicPrelude+import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.BetterErrors as ABE+import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as M+import Data.Text (pack, unpack)+import GHC.Generics (Generic(type Rep))+import Generics.Deriving.ConNames (ConNames, conNames)+import Generics.Deriving.Enum (Enum', genumDefault)++-- |For some type @a@ which represents an enumeration (i.e. all nullary constructors) generate a 'JsonFormat' which maps that type to strings in JSON.+--+-- Each constructor will be mapped to a string with the same value as its name with some prefix removed.+--+-- For example, given:+--+-- > data MyEnum = MyEnumFoo | MyEnumBar+-- > myEnumFormat :: JsonFormat e MyEnum+-- > myEnumFormat = enumJsonFormat "MyEnum"+--+-- Then:+--+-- > toJsonWithFormat myEnumFormat MyEnumFoo == Aeson.String "Foo"+enumJsonFormat :: forall e a. (Show a, Ord a, Generic a, ConNames (Rep a), Enum' (Rep a)) => String -> JsonFormat e a+enumJsonFormat prefix =+ let names = map (pack . removePrefix) $ conNames (undefined :: a)+ removePrefix s+ | Just suffix <- stripPrefix prefix s = suffix+ | otherwise = s+ values = genumDefault+ lookupText = flip HM.lookup . HM.fromList $ zip names values+ lookupValue = flip M.lookup . M.fromList $ zip values names+ expectedValues = "one of " ++ (intercalate ", " . map unpack $ names)+ in enumMapJsonFormat lookupText lookupValue expectedValues++-- |For some type @a@ which bidirectional mapping functions can be provided, produce a 'JsonFormat' which maps to JSON strings.+enumMapJsonFormat :: Show a => (Text -> Maybe a) -> (a -> Maybe Text) -> String -> JsonFormat e a+enumMapJsonFormat lookupText lookupValue expectedText = JsonFormat $ JsonProfunctor toJson fromJson+ where+ toJson a =+ case lookupValue a of+ Nothing -> error $ "unrecognized enum value " ++ show a -- eugh+ Just t -> Aeson.String t++ fromJson = do+ t <- ABE.asText+ case lookupText t of+ Nothing -> fail $ "expected " ++ expectedText ++ ", not " ++ unpack t+ Just v -> pure v+
+ src/Composite/Aeson/Record.hs view
@@ -0,0 +1,114 @@+module Composite.Aeson.Record where++import BasicPrelude+import Composite.Aeson.Base+ ( ToJson(ToJson)+ , FromJson(FromJson)+ , JsonProfunctor(JsonProfunctor), _JsonProfunctor+ , JsonFormat(JsonFormat)+ , wrappedFormat+ )+import Composite.Base (NamedField(fieldName))+import Composite.Aeson.Default (DefaultJsonFormat(defaultJsonFormat))+import Control.Lens (Wrapped(type Unwrapped, _Wrapped'), _1, _2, view)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.BetterErrors as ABE+import qualified Data.HashMap.Strict as HM+import Data.Proxy (Proxy(Proxy))+import Data.Vinyl (Rec((:&), RNil), rmap)+import Data.Vinyl.Functor (Identity(Identity))++-- |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'.+--+-- For example, given:+--+-- > type FId = "id" :-> Int+-- > type FName = "name" :-> Text+-- > type User = '[FId, FName]+--+-- A 'JsonFormatRec' for @User@ might be:+--+-- @+-- userFormatRec :: 'JsonFormatRec' e User+-- userFormatRec = 'Composite.Aeson.Default.integralJsonFormat'+-- &: 'Composite.Aeson.Default.textJsonFormat'+-- &: Nil+-- @+--+-- Or, using the default mappings for each field type:+--+-- @+-- userFormatRec :: 'JsonFormatRec' e User+-- userFormatRec = 'defaultJsonFormatRec'+-- @+--+-- Such a record is a first-class value like any other record, so can be composed into larger records, modified, etc. This is particularly useful in+-- combination with 'defaultJsonFormatRec', where you can automatically derive a format record for all fields you want defaults for and then extend or+-- override formats for particular fields, e.g.+--+-- @+-- fId :: Proxy FId+-- fId = Proxy+--+-- userFormatRec :: 'JsonFormatRec' e User+-- userFormatRec = 'Control.Lens.over' ('Frames.rlens' fId) ('Composite.Aeson.Base.dimapJsonFormat (+10) (subtract 10)) 'defaultJsonFormatRec'+-- @+--+-- 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++-- |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++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 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+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)++instance RecFromJson '[] where+ recFromJson _ = pure RNil++instance forall r rs. (NamedField r, RecFromJson rs) => RecFromJson (r ': rs) where+ recFromJson (FromJson aFromJson :& fs) =+ (:&)+ <$> ABE.key (fieldName (Proxy :: Proxy r)) (Identity <$> aFromJson)+ <*> 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)@.+--+-- See 'JsonFormatRec' for more.+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)++-- |Class to make a 'JsonFormatRec' with 'defaultJsonFormat' for each field.+class DefaultJsonFormatRec rs where+ -- |Produce a 'JsonFormatRec' for a record with fields @rs@ by using the default 'JsonFormat' for each field in @rs@, as provided by 'DefaultJsonFormat'.+ defaultJsonFormatRec :: JsonFormatRec e rs++instance (NamedField r, DefaultJsonFormat (Unwrapped r), DefaultJsonFormatRec rs) => DefaultJsonFormatRec (r ': rs) where+ defaultJsonFormatRec = wrappedFormat defaultJsonFormat :& defaultJsonFormatRec++instance DefaultJsonFormatRec '[] where+ defaultJsonFormatRec = RNil