by-other-names 1.2.2.0 → 1.2.3.0

raw patch · 11 files changed

+647/−22 lines, 11 filesdep ~aesonPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−1
• README.md +4/−2
• by-other-names.cabal +17/−1
• lib/ByOtherNames.hs +1/−1
• lib/ByOtherNames/Aeson.hs +4/−4
• lib/ByOtherNames/Internal.hs +18/−12
• lib/ByOtherNamesH.hs +298/−0
• lib/ByOtherNamesH/Aeson.hs +207/−0
• tests/doctests.hs +2/−0
• tests/tests.hs +1/−1
• tests/tests_higher_order.hs +85/−0

@@ -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

@@ -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) 

@@ -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,

@@ -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...).

@@ -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)

@@ -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. --

@@ -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)

@@ -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

@@ -6,4 +6,6 @@     , "lib/ByOtherNames/Aeson.hs"     , "lib/ByOtherNames/TH.hs"     , "lib/ByOtherNames/Constraint.hs"+    , "lib/ByOtherNamesH.hs"+    , "lib/ByOtherNamesH/Aeson.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

@@ -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+    ]