composite-aeson 0.5.4.0 → 0.5.5.0
raw patch · 5 files changed
+87/−17 lines, 5 filesdep ~aesondep ~template-haskelldep ~vinyl
Dependency ranges changed: aeson, template-haskell, vinyl
Files
- composite-aeson.cabal +11/−10
- src/Composite/Aeson/Formats/InternalTH.hs +54/−3
- src/Composite/Aeson/Formats/Provided.hs +3/−1
- test/Main.hs +2/−1
- test/TupleSpec.hs +17/−2
composite-aeson.cabal view
@@ -1,11 +1,13 @@--- This file has been generated from package.yaml by hpack version 0.20.0.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.0. -- -- see: https://github.com/sol/hpack ----- hash: e5cf48f0def6a0629ab84aeef3ea62b238fbc13d5a79a01f1bd4ebbdccf3df5f+-- hash: 8d9a0c14fd8218f00a30ca1a388ca7f73e99ec3e5dd977fcbe895c9f9ad35e25 name: composite-aeson-version: 0.5.4.0+version: 0.5.5.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@@ -15,7 +17,6 @@ copyright: 2017 Confer Health, Inc. license: BSD3 build-type: Simple-cabal-version: >= 1.10 library hs-source-dirs:@@ -23,7 +24,7 @@ default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns ghc-options: -Wall -O2 build-depends:- aeson >=1.1.2.0 && <1.3+ aeson >=1.1.2.0 && <1.4 , aeson-better-errors >=0.9.1.0 && <0.10 , base >=4.7 && <5 , composite-base >=0.5.3.0 && <0.6@@ -37,12 +38,12 @@ , profunctors >=5.2.1 && <5.3 , scientific >=0.3.5.1 && <0.4 , tagged >=0.8.5 && <0.9- , template-haskell >=2.11.1.0 && <2.13+ , template-haskell >=2.11.1.0 && <2.14 , text >=1.2.2.2 && <1.3 , time >=1.6.0.1 && <1.9 , unordered-containers >=0.2.8.0 && <0.3 , vector >=0.12.0.1 && <0.13- , vinyl >=0.5.3 && <0.8+ , vinyl >=0.5.3 && <0.9 exposed-modules: Composite.Aeson Composite.Aeson.Base@@ -69,7 +70,7 @@ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans build-depends: QuickCheck- , aeson >=1.1.2.0 && <1.3+ , aeson >=1.1.2.0 && <1.4 , aeson-better-errors >=0.9.1.0 && <0.10 , aeson-qq , base >=4.7 && <5@@ -86,12 +87,12 @@ , profunctors >=5.2.1 && <5.3 , scientific >=0.3.5.1 && <0.4 , tagged >=0.8.5 && <0.9- , template-haskell >=2.11.1.0 && <2.13+ , template-haskell >=2.11.1.0 && <2.14 , text >=1.2.2.2 && <1.3 , time >=1.6.0.1 && <1.9 , unordered-containers >=0.2.8.0 && <0.3 , vector >=0.12.0.1 && <0.13- , vinyl >=0.5.3 && <0.8+ , vinyl >=0.5.3 && <0.9 other-modules: DateTimeSpec EnumSpec
src/Composite/Aeson/Formats/InternalTH.hs view
@@ -1,12 +1,14 @@ module Composite.Aeson.Formats.InternalTH- ( makeTupleDefaults, makeTupleFormats+ ( makeTupleDefaults, makeTupleFormats, makeNamedTupleFormats ) where 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.Lazy as HM import Data.List (foldl') import Data.Monoid ((<>))+import Data.Text (Text) import qualified Data.Vector as V import Language.Haskell.TH ( Name, mkName, newName, tupleDataName@@ -64,8 +66,8 @@ 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)+ (foldr (\ tyName rest -> ArrowT `AppT` (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tyName) `AppT` rest)+ (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tupleType) (map VarT tyNames)) oTupImpl = lamE@@ -89,6 +91,55 @@ , 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) []+ ]+ ]+ ]++-- |Splice which inserts the @namedTupleNJsonFormat@ implementations for tuples.+makeNamedTupleFormats :: Q [Dec]+makeNamedTupleFormats = concat <$> traverse makeNamedTupleFormat [2..59]+ where+ makeNamedTupleFormat arity = do+ tyNames <- traverse (newName . ("t" ++) . show) [1..arity]+ fNames <- traverse (newName . ("f" ++) . 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 $ "namedTuple" <> show arity <> "JsonFormat"+ tupleType = foldl' AppT (TupleT arity) (map VarT tyNames)+ funType =+ ForallT+ (PlainTV tyErrName : map PlainTV tyNames)+ []+ (foldr (\ tyName rest -> ArrowT `AppT` ConT ''Text `AppT` (ArrowT `AppT` (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tyName) `AppT` rest))+ (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tupleType)+ (map VarT tyNames))+ oTupImpl =+ lamE+ [conP (tupleDataName arity) (map varP valNames)]+ [| (Aeson.Object . HM.fromList)+ $(listE $ map (\ (fName, varName, oName) -> [| ($(varE fName), $(varE oName) $(varE varName)) |])+ (zip3 fNames valNames oNames)) |]+ iTupImpl =+ doE+ $ map ( \ (fName, valName, iName) ->+ bindS (varP valName) [| ABE.key $(varE fName) $(varE iName) |] )+ (zip3 fNames valNames iNames)+ ++ [ noBindS (appE (varE 'pure) (pure $ foldl' AppE (ConE (tupleDataName arity)) (map VarE valNames))) ]+ sequence+ [ sigD name (pure funType)+ , funD name+ [ clause+ (foldr (\ (fName, oName, iName) rest -> varP fName : conP 'JsonFormat [conP 'JsonProfunctor [varP oName, varP iName]] : rest)+ []+ (zip3 fNames oNames iNames)) (normalB [| JsonFormat (JsonProfunctor $(varE oTupName) $(varE iTupName)) |]) [ valD (varP oTupName) (normalB oTupImpl) [] , valD (varP iTupName) (normalB iTupImpl) []
src/Composite/Aeson/Formats/Provided.hs view
@@ -3,7 +3,7 @@ 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 Composite.Aeson.Formats.InternalTH (makeTupleFormats, makeNamedTupleFormats) import Control.Arrow (first) import Control.Lens (_2, _Wrapped, over, view) import qualified Data.Aeson as Aeson@@ -161,6 +161,8 @@ textJsonFormat = abeJsonFormat ABE.asText $makeTupleFormats++$makeNamedTupleFormats -- |'JsonFormat' for '()' which maps to an empty array. unitJsonFormat :: JsonFormat e ()
test/Main.hs view
@@ -4,12 +4,13 @@ import EnumSpec (enumSuite) import RecordSpec (recordSuite) import THSpec (thSuite)-import TupleSpec (tupleSuite)+import TupleSpec (tupleSuite, namedTupleSuite) main :: IO () main = hspec $ do dateTimeSuite enumSuite+ namedTupleSuite recordSuite thSuite tupleSuite
test/TupleSpec.hs view
@@ -1,8 +1,9 @@ module TupleSpec where import Composite.Aeson.Base (JsonFormat, fromJsonWithFormat, toJsonWithFormat)-import Composite.Aeson.Formats.Provided (tuple3JsonFormat, integralJsonFormat, stringJsonFormat, charJsonFormat)+import Composite.Aeson.Formats.Provided (tuple3JsonFormat, namedTuple3JsonFormat, integralJsonFormat, stringJsonFormat, charJsonFormat) import Data.Aeson.BetterErrors (parseValue)+import Data.Aeson.QQ (aesonQQ) import Data.Void (Void) import Test.Hspec (Spec, describe, it, shouldBe) import Test.QuickCheck (property)@@ -11,6 +12,20 @@ tupleSuite = describe "Tuple formats" $ do it "works for 3-tuples" $ do- let fmt = tuple3JsonFormat (integralJsonFormat :: JsonFormat Void Int) stringJsonFormat charJsonFormat+ let fmt :: JsonFormat Void (Int, String, Char)+ fmt = tuple3JsonFormat integralJsonFormat stringJsonFormat charJsonFormat property $ \ t -> parseValue (fromJsonWithFormat fmt) (toJsonWithFormat fmt t) `shouldBe` Right t++namedTupleSuite :: Spec+namedTupleSuite =+ describe "Named tuple formats" $ do+ let fmt :: JsonFormat Void (String, String, String)+ fmt = namedTuple3JsonFormat "foo" stringJsonFormat "bar" stringJsonFormat "baz" stringJsonFormat++ it "round trips" $+ property $ \ t ->+ parseValue (fromJsonWithFormat fmt) (toJsonWithFormat fmt t) `shouldBe` Right t++ it "property names the fields" $+ toJsonWithFormat fmt ("a", "b", "c") `shouldBe` [aesonQQ| {foo: "a", bar: "b", baz: "c"} |]