diff --git a/demo/Main.hs b/demo/Main.hs deleted file mode 100644 --- a/demo/Main.hs +++ /dev/null @@ -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 - - |] diff --git a/domain-aeson.cabal b/domain-aeson.cabal --- a/domain-aeson.cabal +++ b/domain-aeson.cabal @@ -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 -maintainer: Nikita Volkov -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 +maintainer: Nikita Volkov +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 diff --git a/hspec-test/Main.hs b/hspec-test/Main.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Main.hs @@ -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 diff --git a/library/DomainAeson.hs b/library/DomainAeson.hs --- a/library/DomainAeson.hs +++ b/library/DomainAeson.hs @@ -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) diff --git a/library/DomainAeson/InstanceDecs.hs b/library/DomainAeson/InstanceDecs.hs deleted file mode 100644 --- a/library/DomainAeson/InstanceDecs.hs +++ /dev/null @@ -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 - ) diff --git a/library/DomainAeson/TH.hs b/library/DomainAeson/TH.hs new file mode 100644 --- /dev/null +++ b/library/DomainAeson/TH.hs @@ -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 diff --git a/library/DomainAeson/Util/AesonTH.hs b/library/DomainAeson/Util/AesonTH.hs --- a/library/DomainAeson/Util/AesonTH.hs +++ b/library/DomainAeson/Util/AesonTH.hs @@ -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 =