domain-aeson 0.1 → 0.1.1
raw patch · 7 files changed
+330/−130 lines, 7 filesdep +generic-arbitrarydep +hspecdep +quickcheck-classesdep ~template-haskell-compat-v0208PVP ok
version bump matches the API change (PVP)
Dependencies added: generic-arbitrary, hspec, quickcheck-classes, quickcheck-instances
Dependency ranges changed: template-haskell-compat-v0208
API changes (from Hackage documentation)
+ DomainAeson: fromJsonDeriver :: Deriver
Files
- demo/Main.hs +0/−55
- domain-aeson.cabal +82/−34
- hspec-test/Main.hs +75/−0
- library/DomainAeson.hs +6/−2
- library/DomainAeson/InstanceDecs.hs +0/−27
- library/DomainAeson/TH.hs +55/−0
- library/DomainAeson/Util/AesonTH.hs +112/−12
− demo/Main.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Main where--import Domain-import DomainAeson-import Prelude--main :: IO ()-main =- return ()--declare- Nothing- toJsonDeriver- [schema|-- ServiceAddress:- sum:- network: NetworkAddress- local: FilePath-- NetworkAddress:- product:- protocol: TransportProtocol- host: Host- port: Word16-- TransportProtocol:- enum:- - tcp- - udp-- Host:- sum:- ip: Ip- name: Text-- Ip:- sum:- v4: Word32- v6: Word128-- Word128:- product:- part1: Word64- part2: Word64-- |]
domain-aeson.cabal view
@@ -1,48 +1,96 @@ cabal-version: 3.0--name: domain-aeson-version: 0.1-synopsis: Integration of domain with aeson-homepage: https://github.com/nikita-volkov/domain-aeson-bug-reports: https://github.com/nikita-volkov/domain-aeson/issues-author: Nikita Volkov <nikita.y.volkov@mail.ru>-maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>-copyright: (c) 2022 Nikita Volkov-license: MIT-license-file: LICENSE-build-type: Simple+name: domain-aeson+version: 0.1.1+synopsis: Integration of domain with aeson+homepage: https://github.com/nikita-volkov/domain-aeson+bug-reports: https://github.com/nikita-volkov/domain-aeson/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2022 Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple source-repository head- type: git+ type: git location: git://github.com/nikita-volkov/domain-aeson.git +common base-settings+ default-extensions:+ NoImplicitPrelude+ NoMonomorphismRestriction+ BangPatterns+ BlockArguments+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingVia+ EmptyDataDecls+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ LambdaCase+ LiberalTypeSynonyms+ MagicHash+ MultiParamTypeClasses+ MultiWayIf+ OverloadedLabels+ OverloadedStrings+ ParallelListComp+ PatternGuards+ QuasiQuotes+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ StrictData+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UnboxedTuples+ library- hs-source-dirs: library- default-extensions: BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DerivingVia, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedLabels, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples+ import: base-settings+ hs-source-dirs: library default-language: Haskell2010- exposed-modules:- DomainAeson+ exposed-modules: DomainAeson other-modules:- DomainAeson.InstanceDecs DomainAeson.Prelude+ DomainAeson.TH DomainAeson.Util.AesonTH+ build-depends:- aeson >=2 && <3,- base >=4.12 && <5,- domain-core >=0.1 && <0.2,- text >=1 && <3,- template-haskell >=2.14 && <3,- template-haskell-compat-v0208 >=0.1.7 && <0.2,- th-lego >=0.2.1 && <0.4,- unordered-containers >=0.2.10 && <0.3,- vector >=0.12 && <0.13,+ , aeson >=2 && <3+ , base >=4.12 && <5+ , domain-core >=0.1 && <0.2+ , template-haskell >=2.14 && <3+ , template-haskell-compat-v0208 >=0.1.9 && <0.2+ , text >=1 && <3+ , th-lego >=0.2.1 && <0.4+ , unordered-containers >=0.2.10 && <0.3+ , vector >=0.12 && <0.13 -test-suite demo- type: exitcode-stdio-1.0- hs-source-dirs: demo- main-is: Main.hs+test-suite hspec-test+ import: base-settings+ type: exitcode-stdio-1.0+ hs-source-dirs: hspec-test+ main-is: Main.hs default-language: Haskell2010 build-depends:- domain,- domain-aeson,- rerebase >=1.9 && <2,+ , domain+ , domain-aeson+ , generic-arbitrary >=1.0.1 && <1.1+ , hspec+ , quickcheck-classes+ , quickcheck-instances >=0.3.28 && <0.4+ , rerebase >=1.9 && <2
+ hspec-test/Main.hs view
@@ -0,0 +1,75 @@+module Main where++import Domain+import DomainAeson+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck.Arbitrary.Generic+import Test.QuickCheck.Classes+import Test.QuickCheck.Instances+import Prelude++declare+ Nothing+ (eqDeriver <> showDeriver <> genericDeriver <> toJsonDeriver <> fromJsonDeriver)+ [schema|++ ServiceAddress:+ sum:+ network: NetworkAddress+ local: FilePath++ NetworkAddress:+ product:+ protocol: TransportProtocol+ host: Host+ port: Word16++ TransportProtocol:+ enum:+ - tcp+ - udp++ Host:+ sum:+ ip: Ip+ name: Text++ Ip:+ sum:+ v4: Word32+ v6: Word128++ Word128:+ product:+ part1: Word64+ part2: Word64++ |]++deriving via (GenericArbitrary ServiceAddress) instance Arbitrary ServiceAddress++deriving via (GenericArbitrary NetworkAddress) instance Arbitrary NetworkAddress++deriving via (GenericArbitrary TransportProtocol) instance Arbitrary TransportProtocol++deriving via (GenericArbitrary Host) instance Arbitrary Host++deriving via (GenericArbitrary Ip) instance Arbitrary Ip++deriving via (GenericArbitrary Word128) instance Arbitrary Word128++main :: IO ()+main =+ hspec $ do+ lawsSpec $ jsonLaws (Proxy @ServiceAddress)+ lawsSpec $ jsonLaws (Proxy @NetworkAddress)+ lawsSpec $ jsonLaws (Proxy @TransportProtocol)+ lawsSpec $ jsonLaws (Proxy @Host)+ lawsSpec $ jsonLaws (Proxy @Ip)+ lawsSpec $ jsonLaws (Proxy @Word128)++lawsSpec :: Laws -> Spec+lawsSpec (Laws name properties) =+ describe name $ for_ properties $ \(lawName, property) ->+ prop lawName property
library/DomainAeson.hs view
@@ -1,9 +1,13 @@ module DomainAeson where -import qualified DomainAeson.InstanceDecs as InstanceDecs import DomainAeson.Prelude+import qualified DomainAeson.TH as TH import qualified DomainCore.Deriver as Deriver toJsonDeriver :: Deriver.Deriver toJsonDeriver =- Deriver.effectless InstanceDecs.toJson+ Deriver.effectless (pure . TH.toJsonDec)++fromJsonDeriver :: Deriver.Deriver+fromJsonDeriver =+ Deriver.effectless (pure . TH.fromJsonDec)
− library/DomainAeson/InstanceDecs.hs
@@ -1,27 +0,0 @@-module DomainAeson.InstanceDecs where--import DomainAeson.Prelude-import qualified DomainAeson.Util.AesonTH as AesonTH-import qualified DomainCore.Model as Model-import qualified DomainCore.TH as DomainTH-import Language.Haskell.TH.Syntax-import THLego.Helpers--toJson :: Model.TypeDec -> [Dec]-toJson (Model.TypeDec typeName typeDef) =- pure $ case typeDef of- Model.ProductTypeDef members ->- AesonTH.productToJsonInstanceDec- (ConT (textName typeName))- (textName typeName)- (fmap fst members)- Model.SumTypeDef members ->- AesonTH.sumToJsonInstanceDec- (ConT (textName typeName))- (fmap member members)- where- member (memberName, memberComponentTypes) =- ( memberName,- DomainTH.sumConstructorName typeName memberName,- length memberComponentTypes- )
+ library/DomainAeson/TH.hs view
@@ -0,0 +1,55 @@+module DomainAeson.TH where++import DomainAeson.Prelude+import qualified DomainAeson.Util.AesonTH as AesonTH+import qualified DomainCore.Model as Model+import qualified DomainCore.TH as DomainTH+import Language.Haskell.TH.Syntax+import THLego.Helpers++toJsonDec :: Model.TypeDec -> Dec+toJsonDec (Model.TypeDec typeName typeDef) =+ case typeDef of+ Model.ProductTypeDef members ->+ AesonTH.productToJsonInstanceDec+ (ConT (textName typeName))+ (textName typeName)+ (fmap fst members)+ Model.SumTypeDef members ->+ AesonTH.sumToJsonInstanceDec+ (ConT (textName typeName))+ (fmap member members)+ where+ member (memberName, memberComponentTypes) =+ ( memberName,+ DomainTH.sumConstructorName typeName memberName,+ length memberComponentTypes+ )++fromJsonDec :: Model.TypeDec -> Dec+fromJsonDec (Model.TypeDec typeName typeDef) =+ case typeDef of+ Model.ProductTypeDef members ->+ AesonTH.productFromJsonInstanceDec+ (ConT (textName typeName))+ (textName typeName)+ (fmap (second typeIsRequired) members)+ Model.SumTypeDef members ->+ AesonTH.sumFromJsonInstanceDec+ (ConT (textName typeName))+ (fmap member members)+ where+ member (memberName, memberComponentTypes) =+ ( memberName,+ DomainTH.sumConstructorName typeName memberName,+ length memberComponentTypes+ )++typeIsRequired :: Model.Type -> Bool+typeIsRequired = \case+ Model.AppType (Model.RefType ref :| _) ->+ case ref of+ -- FIXME: get a better detection of maybe+ "Maybe" -> False+ _ -> True+ _ -> True
library/DomainAeson/Util/AesonTH.hs view
@@ -10,11 +10,76 @@ import DomainAeson.Prelude import Language.Haskell.TH.Syntax import THLego.Helpers+import qualified THLego.Helpers as Helpers import qualified THLego.Lambdas as Lambdas import qualified TemplateHaskell.Compat.V0208 as Compat -productParseJsonD :: Name -> [(Text, Bool)] -> Dec-productParseJsonD conName fields =+-- * FromJSON++productFromJsonInstanceDec :: Type -> Name -> [(Text, Bool)] -> Dec+productFromJsonInstanceDec type_ conName fields =+ fromJsonInstanceDec type_ $+ productParseJsonDec conName fields++sumFromJsonInstanceDec :: Type -> [(Text, Name, Int)] -> Dec+sumFromJsonInstanceDec type_ variants =+ fromJsonInstanceDec type_ $+ parseJsonDec+ where+ parseJsonDec =+ FunD 'Ae.parseJSON [clause]+ where+ clause =+ Clause [] (NormalB bodyExp) []+ where+ bodyExp =+ Lambdas.matcher+ [ Match+ (ConP 'Ae.Object [] [VarP aName])+ (NormalB (sumObjectParserE (VarE aName) variants))+ [],+ Match+ (ConP 'Ae.String [] [VarP aName])+ (NormalB stringBody)+ []+ ]+ where+ stringBody =+ CaseE (VarE aName) matches+ where+ matches =+ foldr step [failure] variants+ where+ step (jsonName, conName, members) next =+ case members of+ 0 ->+ Match+ (LitP (StringL (toList jsonName)))+ (NormalB bodyExp)+ []+ : next+ where+ bodyExp =+ AppE (VarE 'pure) (ConE conName)+ _ -> next++ failure =+ Match WildP (NormalB bodyExp) []+ where+ bodyExp =+ AppE (VarE 'fail) (LitE (StringL "Unexpected enum value"))++-- ** FromJSON Helpers++fromJsonInstanceDec :: Type -> Dec -> Dec+fromJsonInstanceDec type_ fromJsonFunDec =+ InstanceD Nothing [] headType [fromJsonFunDec]+ where+ headType =+ AppT (ConT ''Ae.FromJSON) type_++productParseJsonDec :: Name -> [(Text, Bool)] -> Dec+productParseJsonDec conName fields = FunD 'Ae.parseJSON [clause] where clause =@@ -29,7 +94,7 @@ productObjectParsingLamE :: Name -> [(Text, Bool)] -> Exp productObjectParsingLamE conName fields =- LamE [VarP aName] (productObjectParserE (ConE aName) conName fields)+ LamE [VarP aName] (productObjectParserE (VarE aName) conName fields) productObjectParserE :: Exp -> Name -> [(Text, Bool)] -> Exp productObjectParserE objectE conName fields =@@ -43,8 +108,43 @@ then '(Ae..:) else '(Ae..:?) --- *+sumObjectParserE :: Exp -> [(Text, Name, Int)] -> Exp+sumObjectParserE objectE variants =+ build variants+ where+ build = \case+ (jsonName, conName, components) : tail ->+ CaseE+ ( AppE+ (AppE (VarE 'AeKeyMap.lookup) (textKeyE jsonName))+ objectE+ )+ [ Match+ (ConP 'Just [] [VarP (mkName "fieldValue")])+ ( NormalB+ ( case components of+ 0 ->+ AppE (VarE 'pure) (ConE conName)+ 1 ->+ applicativeChainE+ (ConE conName)+ [AppE (VarE 'Ae.parseJSON) (VarE (mkName "fieldValue"))]+ _ -> error "TODO: Handle multi-arity"+ )+ )+ [],+ Match+ (ConP 'Nothing [] [])+ (NormalB (build tail))+ []+ ]+ _ ->+ AppE+ (VarE 'fail)+ (LitE (StringL "No expected sum-type tag found")) +-- * ToJSON instance declaration+ toJsonInstanceDec :: Type -> Dec -> Dec toJsonInstanceDec type_ toJsonFunDec = InstanceD Nothing [] headType [toJsonFunDec]@@ -64,7 +164,7 @@ enumToJsonInstanceDec type_ members = toJsonInstanceDec type_ $ enumToJsonFunD members --- *+-- ** ToJSON Helpers productToJsonFunD :: Name -> [Text] -> Dec productToJsonFunD conName members =@@ -73,7 +173,7 @@ varNamesAndJsonNames = mapWithAlphabeticName (,) members clause =- Clause [Compat.conp conName memberPats] body []+ Clause [Compat.conP conName memberPats] body [] where memberPats = fmap memberPat varNamesAndJsonNames where@@ -94,13 +194,13 @@ memberClause (jsonName, conName, components) = case components of 0 ->- Clause [Compat.conp conName []] (NormalB bodyExp) []+ Clause [Compat.conP conName []] (NormalB bodyExp) [] where bodyExp = stringJsonE jsonName 1 ->- Clause [Compat.conp conName [VarP varName]] (NormalB bodyExp) []+ Clause [Compat.conP conName [VarP varName]] (NormalB bodyExp) [] where- varName = mkName "a"+ varName = aName bodyExp = AppE (ConE 'Ae.Object)@@ -111,7 +211,7 @@ ] ) _ ->- Clause [Compat.conp conName (fmap VarP varNames)] (NormalB bodyExp) []+ Clause [Compat.conP conName (fmap VarP varNames)] (NormalB bodyExp) [] where varNames = enumAlphabeticNames components bodyExp =@@ -131,11 +231,11 @@ clauses = fmap memberClause members where memberClause (jsonName, conName) =- Clause [Compat.conp conName []] (NormalB bodyExp) []+ Clause [Compat.conP conName []] (NormalB bodyExp) [] where bodyExp = stringJsonE jsonName --- *+-- * Helpers jsonArrayE :: [Exp] -> Exp jsonArrayE exps =