diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,13 @@ -1.2.2.0 +1.2.3.0 +======= + +- New modules 'ByOtherNamesH' and 'ByOtherNamesH.Aeson' (The "H" is for +"higher-order") that let you go beyond field/branch aliases and specify +"wrappers" for each field. This lets you for example to specify JSON parsers for +a particular field without always depending on its `FromJSON`/`ToJSON` +instances. + +1.2.2.0 ======= - GeneralJSONEnum : like JSONEnum, but lets you define FromJSON/ToJSON instances diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,11 +19,13 @@ ``` build-depends: - by-other-names ^>= 1.2.0.0 + by-other-names ^>= 1.2.3.0 ``` ## Other related packages -- [generics-sop](https://hackage.haskell.org/package/generics-sop) +- [autodocodec](https://hackage.haskell.org/package/autodocodec). A [family](https://github.com/NorfairKing/autodocodec#readme) of packages for deriving JSON and Openapi-related classes. More mature and fully-featured than this package. [A blog post about it](https://www.dylanamartin.com/2022/11/08/improving-the-aeson-experience.html). + +- [generics-sop](https://hackage.haskell.org/package/generics-sop). - [barbies](https://hackage.haskell.org/package/barbies) diff --git a/by-other-names.cabal b/by-other-names.cabal --- a/by-other-names.cabal +++ b/by-other-names.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: by-other-names -version: 1.2.2.0 +version: 1.2.3.0 synopsis: Give aliases to record fields. description: Give aliases to record fields. @@ -24,6 +24,8 @@ ByOtherNames.Constraint ByOtherNames.TH ByOtherNames.Internal + ByOtherNamesH + ByOtherNamesH.Aeson build-depends: base >= 4.10.0.0 && < 5, aeson >= 2.1.0.0, text >= 1.2.3.0, @@ -34,10 +36,24 @@ ghc-options: -W default-language: Haskell2010 + + test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: tests.hs + build-depends: + base >= 4.10.0.0 && < 5, + tasty >= 0.10.1.1, + tasty-hunit >= 0.9.2, + aeson >= 1.5.2.0, + by-other-names, + default-language: Haskell2010 + +test-suite tests-higher-order + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: tests_higher_order.hs build-depends: base >= 4.10.0.0 && < 5, tasty >= 0.10.1.1, diff --git a/lib/ByOtherNames.hs b/lib/ByOtherNames.hs --- a/lib/ByOtherNames.hs +++ b/lib/ByOtherNames.hs @@ -1,4 +1,4 @@ --- | This package provides the general mechanism for defining field and branch +-- | This module provides the general mechanism for defining field and branch -- aliases for algebraic datatypes. -- -- Aliases can be defined for multiple contexts (json serialization, orms...). diff --git a/lib/ByOtherNames/Aeson.hs b/lib/ByOtherNames/Aeson.hs --- a/lib/ByOtherNames/Aeson.hs +++ b/lib/ByOtherNames/Aeson.hs @@ -36,7 +36,7 @@ -- -- >>> :{ -- data Foo = Foo {aa :: Int, bb :: Bool, cc :: Char} --- deriving (Read, Show, Eq, Generic) +-- deriving stock (Read, Show, Eq, Generic) -- deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo) -- instance Aliased JSON Foo where -- aliases = @@ -54,7 +54,7 @@ -- = Aa Int -- | Bb Bool -- | Cc --- deriving (Read, Show, Eq, Generic) +-- deriving stock (Read, Show, Eq, Generic) -- deriving (FromJSON, ToJSON) via (JSONSum "sum" Summy) -- instance Aliased JSON Summy where -- aliases = @@ -80,7 +80,7 @@ -- = Xx -- | Yy -- | Zz --- deriving (Read, Show, Eq, Generic) +-- deriving stock (Read, Show, Eq, Generic) -- deriving (FromJSON, ToJSON) via (JSONEnum Enumy) -- instance Aliased JSON Enumy where -- aliases = @@ -316,8 +316,8 @@ in GeneralJSONRecord . to <$> withObject objectName parser v instance (Rubric rubric, - AliasType rubric ~ Key, Aliased rubric r, + AliasType rubric ~ Key, GRecord ToJSON (Rep r)) => ToJSON (GeneralJSONRecord rubric objectName r) where toJSON (GeneralJSONRecord o) = object $ Data.Foldable.toList $ gFromRecord @ToJSON @(Rep r) @Key (aliases @_ @rubric @r) (\a v -> (a, toJSON v)) (from @r o) diff --git a/lib/ByOtherNames/Internal.hs b/lib/ByOtherNames/Internal.hs --- a/lib/ByOtherNames/Internal.hs +++ b/lib/ByOtherNames/Internal.hs @@ -64,8 +64,9 @@ import GHC.Generics import GHC.TypeLits --- | This datatype carries the field aliases and matches the structure of the --- generic Rep' shape. +-- | This datatype carries the field/branch aliases. +-- +-- It matches the structure of the generic 'Rep'. type Aliases :: (Type -> Type) -> Type -> Type data Aliases rep a where Field :: KnownSymbol fieldName => a -> Aliases (S1 ('MetaSel ('Just fieldName) unpackedness strictness laziness) v) a @@ -145,7 +146,7 @@ let branchName = symbolVal (Proxy @branchName) in f branchName a --- | An intermediate datatype for specifying the aliases. See +-- | An intermediate helper datatype for specifying the aliases. See -- 'aliasListBegin', 'alias' and 'aliasListEnd'. type AliasList :: [Symbol] -> Type -> Type data AliasList names a where @@ -155,7 +156,11 @@ -- | Add an alias to an `AliasList`. -- -- __/TYPE APPLICATION REQUIRED!/__ You must provide the field/branch name using a type application. -alias :: forall name a names. a -> AliasList names a -> AliasList (name : names) a +alias :: forall name a names. + -- | The alias value + a -> + AliasList names a -> + AliasList (name : names) a alias = Cons (Proxy @name) -- | Define the aliases for a type by listing them. @@ -185,8 +190,8 @@ -- -- aliasListBegin :: forall names a rep. (AliasTree names rep '[]) - => AliasList names a - -> Aliases rep a + => AliasList names a -- ^ indexed by a list of names + -> Aliases rep a -- ^ indexed by a generic 'Rep' aliasListBegin names = let (aliases, Null) = parseAliasTree @names @rep names in aliases @@ -368,12 +373,6 @@ Record (gFromRecord @c as renderField prod) gRecordEnum (Record as) renderField = Record (gRecordEnum @c @prod as renderField) -instance c v => GRecord c (S1 x (Rec0 v)) where - gToRecord (Field a) parseField = - M1 . K1 <$> parseField a - gFromRecord (Field a) renderField (M1 (K1 v)) = Field (renderField a v) - gRecordEnum (Field a) renderField = Field (a, renderField (Proxy @v)) - instance (GRecord c left, GRecord c right) => GRecord c (left :*: right) @@ -384,6 +383,13 @@ FieldTree (gFromRecord @c aleft renderField left) (gFromRecord @c aright renderField right) gRecordEnum (FieldTree aleft aright) renderField = FieldTree (gRecordEnum @c @left aleft renderField) (gRecordEnum @c @right aright renderField) + +instance c v => GRecord c (S1 x (Rec0 v)) where + gToRecord (Field a) parseField = + M1 . K1 <$> parseField a + gFromRecord (Field a) renderField (M1 (K1 v)) = Field (renderField a v) + gRecordEnum (Field a) renderField = Field (a, renderField (Proxy @v)) + -- | Helper for defining branch parsers. -- diff --git a/lib/ByOtherNamesH.hs b/lib/ByOtherNamesH.hs new file mode 100644 --- /dev/null +++ b/lib/ByOtherNamesH.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-methods #-} + +-- | +-- This module provides the general mechanism for defining field and branch +-- aliases for algebraic datatypes. +-- +-- Aliases can be defined for multiple contexts (json serialization, orms...). +-- Each of those contexts is termed a Rubric, basically a marker datakind used +-- to namespace the aliases. +-- +-- This module should only be imported if you want to define your own adapter +-- package for some new 'Rubric'. See "ByOtherNamesH.Aeson" for a concrete +-- example. +-- +-- This module provides a more versatile, but also more verbose, version of the +-- functionality provided by "ByOtherNames". If you plan to use both +-- "ByOtherNames" and "ByOtherNamesH", import this module qualified to avoid +-- name collisions: +-- +-- > import qualified ByOthernamesH as H +-- +module ByOtherNamesH ( + -- * Aliases + Aliases, + AliasList, + aliasListBegin, + alias, + aliasListEnd, + SlotList, + singleSlot, + slot, + slotListEnd, + -- * Rubrics + Rubric (..), + Aliased (..), + -- * Generic helpers + GRecord(..), + -- * Re-exports + Symbol, +) where + +import Control.Applicative +import Data.Kind +import Data.Proxy +import GHC.Generics +import GHC.TypeLits +import Data.Functor.Identity + +-- | This datatype carries the field/branch aliases, along with a value wrapped in @h@ +-- for each field in the original datatype. +-- +-- It matches the shape of the generic 'Rep'. +type Aliases :: (Type -> Type) -> Type -> (Type -> Type) -> Type +data Aliases rep a (h :: Type -> Type) where + Field :: + KnownSymbol fieldName => + a -> + h v -> + Aliases (S1 ('MetaSel ('Just fieldName) unpackedness strictness laziness) (Rec0 v)) a h + Branch :: + KnownSymbol branchName => + a -> + BranchFields v h -> + Aliases (C1 ('MetaCons branchName fixity sels) v) a h + EmptyBranch :: + KnownSymbol branchName => + a -> + Aliases (C1 ('MetaCons branchName fixity sels) U1) a h + FieldTree :: + Aliases left a h -> + Aliases right a h -> + Aliases (left :*: right) a h + BranchTree :: + Aliases left a h -> + Aliases right a h -> + Aliases (left :+: right) a h + -- | We force the sum to contain at least two branches. + Sum :: + Aliases (left :+: right) a h -> + Aliases (D1 x (left :+: right)) a h + Record :: + Aliases fields a h -> + Aliases (D1 x (C1 y fields)) a h + +type BranchFields :: (Type -> Type) -> (Type -> Type) -> Type +data BranchFields rep h where + BranchFieldTree :: + BranchFields left h -> + BranchFields right h -> + BranchFields (left :*: right) h + BranchField :: + h v -> + BranchFields (S1 ('MetaSel 'Nothing unpackedness strictness laziness) (Rec0 v)) h + +-- | A list of slots associated an alias. Indexed by the types of each slot +-- and a type constructor that wraps each slot value. +-- +-- For records, each field alias will have one and only one slot: the +-- corresponding record field. See 'singleSlot'. +-- +-- For sum types, each branch alias might have zero or more slots, depending on +-- the structure of the datatype. See 'slot' and 'slotListEnd'. +data SlotList :: [Type] -> (Type -> Type) -> Type where + EmptyTuple :: SlotList '[] h + ConsTuple :: h x -> SlotList xs h -> SlotList (x ': xs) h + +-- | An intermediate helper datatype for specifying the aliases. +-- +-- Indexed by a list of names accompanied by field types. +-- +-- See 'aliasListBegin', 'alias' and 'aliasListEnd'. +type AliasList :: [(Symbol, [Type])] -> Type -> (Type -> Type) -> Type +data AliasList (names_slots :: [(Symbol, [Type])]) a (h :: Type -> Type) where + EmptyAliasList :: AliasList '[] a h + ConsAliasList :: + Proxy name -> + a -> + SlotList slots h -> + AliasList prev a h -> AliasList ('(name,slots) : prev) a h + +type ToAliases :: [(Symbol, [Type])] -> (Type -> Type) -> [(Symbol, [Type])] -> Constraint +-- | The second functional dependency is needed for type inference to work. +class ToAliases before rep after | before rep -> after, after rep -> before where + parseAliasTree :: AliasList before a h -> (Aliases rep a h, AliasList after a h) + +type ToBranchFields :: [Type] -> (Type -> Type) -> [Type] -> Constraint +-- | The second functional dependency is needed for type inference to work. +class ToBranchFields before rep after | before rep -> after, after rep -> before where + parseBranchFields :: SlotList before h -> (BranchFields rep h, SlotList after h) + +instance (ToBranchFields before left middle, + ToBranchFields middle right end) + => ToBranchFields before (left :*: right) end where + parseBranchFields t0 = do + let (leftResult, leftLeftover) = parseBranchFields @before t0 + (rightResult, rightLeftover) = parseBranchFields @middle leftLeftover + (BranchFieldTree leftResult rightResult, rightLeftover) + +instance ToBranchFields (v ': vs) (S1 ('MetaSel 'Nothing unpackedness strictness laziness) (Rec0 v)) vs where + parseBranchFields (ConsTuple hv rest) = (BranchField hv, rest) + +instance ToAliases before tree '[] => ToAliases before (D1 x (C1 y tree)) '[] where + parseAliasTree as = + let (aliases', as') = parseAliasTree as + in (Record aliases', as') + +instance (ToAliases before left middle, ToAliases middle right end) + => ToAliases before (left :*: right) end where + parseAliasTree as = + let (left, middle) = parseAliasTree @before as + (right, end) = parseAliasTree @middle middle + in (FieldTree left right, end) + +instance KnownSymbol name + => ToAliases ('(name, '[v]) : rest) (S1 ('MetaSel (Just name) x y z) (Rec0 v)) rest where + parseAliasTree (ConsAliasList _ a (ConsTuple hv EmptyTuple) rest) = (Field a hv, rest) + +instance ToAliases before (left :+: right) '[] => ToAliases before (D1 x (left :+: right)) '[] where + parseAliasTree as = + let (aliases', as') = parseAliasTree as + in (Sum aliases', as') + +instance (ToAliases before left middle, ToAliases middle right end) => ToAliases before (left :+: right) end where + parseAliasTree as = + let (left, middle) = parseAliasTree @before as + (right, end) = parseAliasTree @middle middle + in (BranchTree left right, end) + +instance (KnownSymbol name, + ToBranchFields vs (S1 u v) '[]) => + ToAliases ('(name, vs) : rest) (C1 ('MetaCons name fixity False) (S1 u v)) rest where + parseAliasTree (ConsAliasList _ a branchFields rest) = do + let (theBranchFields, EmptyTuple) = parseBranchFields @vs branchFields + (Branch a theBranchFields, rest) + +instance (KnownSymbol name, + ToBranchFields vs (left :*: right) '[]) => + ToAliases ('(name, vs) : rest) (C1 ('MetaCons name fixity False) (left :*: right)) rest where + parseAliasTree (ConsAliasList _ a branchFields rest) = do + let (theBranchFields, EmptyTuple) = parseBranchFields @vs branchFields + (Branch a theBranchFields, rest) + +instance KnownSymbol name => + ToAliases ('(name, '[]) : rest) (C1 ('MetaCons name fixity False) U1) rest where + parseAliasTree (ConsAliasList _ a EmptyTuple rest) = do + (EmptyBranch a, rest) + +-- +-- + +type Aliased :: k -> Type -> Constraint +class (Rubric k, Generic r) => Aliased k r where + aliases :: Aliases (Rep r) (AliasType k) (WrapperType k) + +type Rubric :: k -> Constraint +class Rubric k where + type AliasType k :: Type + type WrapperType k :: Type -> Type + +aliasListBegin :: forall names_slots a h rep. (ToAliases names_slots rep '[]) + => AliasList names_slots a h -- ^ indexed by a list of alias names / slots types + -> Aliases rep a h -- ^ indexed by a generic 'Rep' +aliasListBegin names = + let (aliases, EmptyAliasList) = parseAliasTree @names_slots @rep names + in aliases + +-- | The empty 'AliasList'. +aliasListEnd :: AliasList '[] a h +aliasListEnd = EmptyAliasList + +alias :: forall name slots a h names_slots. + -- | The alias value + a -> + -- | \"wrapped\" values for each slot of the alias + SlotList slots h -> + AliasList names_slots a h -> + AliasList ('(name, slots) : names_slots) a h +alias = ConsAliasList (Proxy @name) + +-- | The empty 'SlotList'. +slotListEnd :: SlotList '[] h +slotListEnd = EmptyTuple + +singleSlot :: h v -> SlotList '[v] h +singleSlot hv = ConsTuple hv EmptyTuple + +slot :: h v -> SlotList rest h -> SlotList (v ': rest) h +slot hv = ConsTuple hv + +class GRecord rep where + -- | Builds a parser for the entire generic 'Rep' out of parsers for each field. + gToRecord :: + Applicative g => + -- | Field aliases. + Aliases rep a h -> + (forall v. a -> h v -> g v) -> + g (rep z) + gFromRecord :: + -- | Record representation. + rep z -> + Aliases rep String Identity + gBiliftA2RecordAliases :: + -- | Combine aliases + (a1 -> a2 -> ar) -> + -- | Combine slots + (forall v. h1 v -> h2 v -> hr v) -> + Aliases rep a1 h1 -> + Aliases rep a2 h2 -> + Aliases rep ar hr + +instance GRecord prod => GRecord (D1 x (C1 y prod)) where + gToRecord (Record as) parseField = + M1 . M1 <$> gToRecord as parseField + gFromRecord (M1 (M1 prod)) = + Record (gFromRecord prod) + gBiliftA2RecordAliases f g (Record a1) (Record a2) = + Record (gBiliftA2RecordAliases f g a1 a2) + +instance + (GRecord left, GRecord right) => + GRecord (left :*: right) + where + gToRecord (FieldTree aleft aright) parseField = + (:*:) <$> gToRecord aleft parseField <*> gToRecord aright parseField + gFromRecord (left :*: right) = + FieldTree (gFromRecord left) (gFromRecord right) + gBiliftA2RecordAliases f g (FieldTree left1 right1) (FieldTree left2 right2) = + FieldTree (gBiliftA2RecordAliases f g left1 left2) (gBiliftA2RecordAliases f g right1 right2) + +instance KnownSymbol fieldName => GRecord (S1 ('MetaSel ('Just fieldName) unpackedness strictness laziness) (Rec0 v)) where + gToRecord (Field a hv) parseField = + M1 . K1 <$> parseField a hv + gFromRecord (M1 (K1 v)) = Field (symbolVal (Proxy @fieldName)) (Identity v) + gBiliftA2RecordAliases f g (Field a1 h1) (Field a2 h2) = + Field (f a1 a2) (g h1 h2) diff --git a/lib/ByOtherNamesH/Aeson.hs b/lib/ByOtherNamesH/Aeson.hs new file mode 100644 --- /dev/null +++ b/lib/ByOtherNamesH/Aeson.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + + +-- | A 'Rubric' for JSON serialization using Aeson, along with some helper +-- newtypes and re-exports. +-- +-- A more versatile version of the functionality provided by +-- "ByOtherNames.Aeson", in that it allows you to manually specify +-- parsers/decoders for each field. But, because of that, it's also more +-- verbose. And the error messages are worse. +-- +-- If you plan to use both "ByOtherNames.Aeson" and "ByOtherNamesH.Aeson", +-- import this module qualified to avoid name collisions: +-- +-- > import qualified ByOthernamesH.Aeson as H +-- +-- Required extensions: +-- +-- - DataKinds +-- - DeriveGeneric +-- - DerivingVia +-- - FlexibleInstances +-- - MultiParamTypeClasses +-- - OverloadedStrings +-- - TypeApplications +-- - ScopedTypeVariables +-- +-- Example of use for a record type: +-- +-- >>> :{ +-- data Foo = Foo {aa :: Int, bb :: Bool, cc :: Char, dd :: String, ee :: Int} +-- deriving stock (Read, Show, Eq, Generic) +-- deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo) +-- instance Aliased JSON Foo where +-- aliases = +-- aliasListBegin +-- . alias @"aa" "aax" (singleSlot fromToJSON) +-- . alias @"bb" "bbx" (singleSlot fromToJSON) +-- . alias @"cc" "ccx" (singleSlot fromToJSON) +-- . alias @"dd" "ddx" (singleSlot fromToJSON) +-- . alias @"ee" "eex" (singleSlot fromToJSON) +-- $ aliasListEnd +-- :} +-- +module ByOtherNamesH.Aeson + ( -- * JSON helpers + JSONRubric (..), + JSONRecord (..), + FromToJSON (..), + fromToJSON, + -- ** Advanced JSON helpers + GeneralJSONRecord (..), + -- * Re-exports from ByOtherNames + Aliased (aliases), + aliasListBegin, + alias, + aliasListEnd, + SlotList, + singleSlot, + slot, + slotListEnd, + -- * Re-exports from Data.Aeson + FromJSON, + ToJSON, + + ) +where + +import ByOtherNamesH +import Data.Aeson +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.Types +import Data.Functor.Compose +import Data.Kind +import Data.Proxy +import Data.Void +import GHC.Generics +import GHC.TypeLits +import Data.Functor.Identity +import Data.Functor.Const + +-- | Aliases for JSON serialization fall under this 'Rubric'. +-- The constructor 'JSON' is used as a type, with DataKinds. +data JSONRubric = JSON + +-- | The aliases will be of type "Data.Aeson.Key". +instance Rubric JSON where + type AliasType JSON = Key + type WrapperType JSON = FromToJSON + +-- | Packs together a JSON parser and a encoder for some type. +-- +data FromToJSON v = FromToJSON { + parseJSON' :: Value -> Parser v, + toJSON' :: v -> Value + } + +fromToJSON :: (ToJSON v, FromJSON v) => FromToJSON v +fromToJSON = FromToJSON { parseJSON' = parseJSON, toJSON' = toJSON} + +type JSONRecord :: Symbol -> Type -> Type +newtype JSONRecord objectName r = JSONRecord r + +deriving via (GeneralJSONRecord 'JSON objectName r) instance (KnownSymbol objectName, Aliased 'JSON r, GRecord (Rep r)) => FromJSON (JSONRecord objectName r) +deriving via (GeneralJSONRecord 'JSON objectName r) instance (Aliased 'JSON r, GRecord (Rep r)) => ToJSON (JSONRecord objectName r) + + +-- | A more flexible version of 'JSONRecord' that lets you use any 'Rubric' whose +-- 'AliasType' is 'Data.Aeson.Key' and its 'WrapperType' is 'FromToJSON'. +-- +-- It allows deriving 'FromJSON' and 'ToJSON' for a newtype, using the generic +-- 'Rep' and the aliases of the underlying type, but __without__ defining +-- 'FromJSON' and 'ToJSON' instances for the underlying type. +-- +-- >>> :{ +-- data Foo = Foo {aa :: Int, bb :: Bool, cc :: Char} +-- deriving (Read, Show, Eq, Generic) +-- data JSONLocal +-- -- We define a local rubric type to avoid colliding "Aliased" instances over Foo. +-- instance Rubric JSONLocal where +-- type AliasType JSONLocal = Key +-- type WrapperType JSONLocal = FromToJSON +-- instance Aliased JSONLocal Foo where +-- aliases = +-- aliasListBegin +-- $ alias @"aa" "aax" (singleSlot fromToJSON) +-- $ alias @"bb" "bbx" (singleSlot fromToJSON) +-- $ alias @"cc" "ccx" (singleSlot fromToJSON) +-- $ aliasListEnd +-- newtype FooN = FooN Foo +-- deriving (FromJSON, ToJSON) via (GeneralJSONRecord JSONLocal "obj" Foo) +-- :} +-- +-- +type GeneralJSONRecord :: rubric -> Symbol -> Type -> Type +newtype GeneralJSONRecord rubric objectName r = GeneralJSONRecord r + +instance (KnownSymbol objectName, + Rubric rubric, + Aliased rubric r, + AliasType rubric ~ Key, + WrapperType rubric ~ FromToJSON, + GRecord (Rep r)) + => FromJSON (GeneralJSONRecord rubric objectName r) where + parseJSON v = + let FieldParser parser = + gToRecord + (aliases @_ @rubric @r) + (\fieldName (FromToJSON {parseJSON'}) -> FieldParser (\o -> explicitParseField parseJSON' o fieldName)) + objectName = symbolVal (Proxy @objectName) + in GeneralJSONRecord . to <$> withObject objectName parser v + +newtype FieldParser a = FieldParser (Object -> Parser a) + deriving (Functor, Applicative) via ((->) Object `Compose` Parser) + +instance (Rubric rubric, + Aliased rubric r, + AliasType rubric ~ Key, + WrapperType rubric ~ FromToJSON, + GRecord (Rep r)) => ToJSON (GeneralJSONRecord rubric objectName r) where + toJSON (GeneralJSONRecord o) = do + let plainRecord = gFromRecord $ from @r o + deserializers = aliases @_ @rubric @r + combineAliases _ k = k + combineWrappers (Identity v) (FromToJSON {toJSON'}) = Const (toJSON' v) + eachFieldRendered = gBiliftA2RecordAliases combineAliases combineWrappers plainRecord deserializers + Const objects = gToRecord eachFieldRendered (\a (Const v) -> Const [(a,v)]) + object objects + + +-- $setup +-- +-- >>> :set -XBlockArguments +-- >>> :set -XTypeApplications +-- >>> :set -XDerivingStrategies +-- >>> :set -XDerivingVia +-- >>> :set -XDataKinds +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XDeriveGeneric +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeFamilies +-- >>> :set -XDerivingStrategies +-- >>> :set -XDerivingVia +-- >>> import ByOtherNamesH.Aeson +-- >>> import Data.Aeson +-- >>> import Data.Aeson.Types +-- >>> import GHC.Generics +-- >>> import GHC.TypeLits diff --git a/tests/doctests.hs b/tests/doctests.hs --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -6,4 +6,6 @@ , "lib/ByOtherNames/Aeson.hs" , "lib/ByOtherNames/TH.hs" , "lib/ByOtherNames/Constraint.hs" + , "lib/ByOtherNamesH.hs" + , "lib/ByOtherNamesH/Aeson.hs" ] diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -37,7 +37,7 @@ import Test.Tasty.HUnit data Foo = Foo {aa :: Int, bb :: Bool, cc :: Char, dd :: String, ee :: Int} - deriving (Read, Show, Eq, Generic) + deriving stock (Read, Show, Eq, Generic) deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo) instance Aliased JSON Foo where diff --git a/tests/tests_higher_order.hs b/tests/tests_higher_order.hs new file mode 100644 --- /dev/null +++ b/tests/tests_higher_order.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Main where + +import ByOtherNamesH +import ByOtherNamesH.Aeson +import ByOtherNames.TH +import Control.Monad (forM) +import Data.Aeson +import Data.Aeson.Types +import Data.Foldable +import Data.Typeable +import GHC.Generics +import GHC.TypeLits +import Test.Tasty +import Test.Tasty.HUnit +import Data.Functor.Identity + + +data Foo = Foo {aa :: Int, bb :: Bool, cc :: Char, dd :: String, ee :: Int} + deriving stock (Read, Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo) +instance Aliased JSON Foo where + aliases = + aliasListBegin + . alias @"aa" "aax" (singleSlot fromToJSON) + . alias @"bb" "bbx" (singleSlot fromToJSON) + . alias @"cc" "ccx" (singleSlot fromToJSON) + . alias @"dd" "ddx" (singleSlot fromToJSON) + . alias @"ee" "eex" (singleSlot fromToJSON) + $ aliasListEnd + +data X +instance Rubric X where + type AliasType X = String + type WrapperType X = Identity + +data Summy + = Aa Int + | Bb Bool + | Cc + | Dd Char Bool Int + | Ee Int + deriving (Read, Show, Eq, Generic) + +instance Aliased X Summy where + aliases = + aliasListBegin + . alias @"Aa" "Aax" (singleSlot (Identity 5)) + . alias @"Bb" "Bbx" (singleSlot (Identity False)) + . alias @"Cc" "Ccx" slotListEnd + . alias @"Dd" "Ddx" (slot (Identity 'c') . slot (Identity False) . slot (Identity 5) $ slotListEnd) + . alias @"Ee" "Eex" (singleSlot (Identity 5)) + $ aliasListEnd + +-- +-- +roundtrip :: forall t. (Eq t, Show t, FromJSON t, ToJSON t) => t -> IO () +roundtrip t = + let reparsed = parseEither parseJSON (toJSON t) + in case reparsed of + Left err -> assertFailure err + Right t' -> assertEqual "" t t' + +-- +-- +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "All" + [ testCase "recordRoundtrip" $ roundtrip $ Foo 0 False 'f' "foo" 3 + ]