diff --git a/composite-aeson.cabal b/composite-aeson.cabal --- a/composite-aeson.cabal +++ b/composite-aeson.cabal @@ -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 diff --git a/src/Composite/Aeson/Formats/InternalTH.hs b/src/Composite/Aeson/Formats/InternalTH.hs --- a/src/Composite/Aeson/Formats/InternalTH.hs +++ b/src/Composite/Aeson/Formats/InternalTH.hs @@ -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) [] diff --git a/src/Composite/Aeson/Formats/Provided.hs b/src/Composite/Aeson/Formats/Provided.hs --- a/src/Composite/Aeson/Formats/Provided.hs +++ b/src/Composite/Aeson/Formats/Provided.hs @@ -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 () diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/TupleSpec.hs b/test/TupleSpec.hs --- a/test/TupleSpec.hs +++ b/test/TupleSpec.hs @@ -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"} |]