packages feed

by-other-names (empty) → 1.2.0.0

raw patch · 11 files changed

+1162/−0 lines, 11 filesdep +aesondep +basedep +by-other-names

Dependencies added: aeson, base, by-other-names, doctest, indexed-traversable, tasty, tasty-hunit, template-haskell, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,22 @@++1.2.0.0+=======++- Hid the internals of the `Aliases` module in the main module.+- Various generic helpers.++1.0.1.0+=======++- deprecated fieldAliases and branchAliases in favor of aliasListBegin.++1.0.2.0+=======++- added a quasiquoter in a new public library++1.1.0.0+=======++- removed deprecated functions fieldAliases and branchAliases+- renamed ForRubric to AliasType
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2020, Daniel Díaz Carrete+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,34 @@+# by-other-names++Give aliases to record fields.++When generically deriving [aeson](http://hackage.haskell.org/package/aeson)'s+`FromJSON` and `ToJSON` instances, field names are used as the keys for the+serialized JSON. If you don't want that, another option is to write the+instances manually. Problem is, you have to repeat the field names once for+`FromJSON` and once for `ToJSON`.++I wanted an intermediate solution similar to what is provided by Go's [struct+tags](https://www.digitalocean.com/community/tutorials/how-to-use-struct-tags-in-go):+associate aliases with each field and use those aliases when+serializing/deserializing. There can be different sets of aliases for different+contexts (json, orm...). In this library, each of those possible contexts is+called a "rubric".++## How to depend on this library?++```+build-depends:+  by-other-names ^>= 1.2.0.0+```+## Other related packages++- [generics-sop](https://hackage.haskell.org/package/generics-sop)++- [barbies](https://hackage.haskell.org/package/barbies)++- [higgledy](https://hackage.haskell.org/package/higgledy)++- [generic-data-surgery](https://hackage.haskell.org/package/generic-data-surgery)++- [one-liner](https://hackage.haskell.org/package/one-liner)
+ by-other-names.cabal view
@@ -0,0 +1,60 @@+cabal-version:       3.0+name:                by-other-names+version:             1.2.0.0+synopsis:            Give aliases to record fields.++description:         Give aliases to record fields.++license:             BSD-3-Clause+license-file:        LICENSE+author:              Daniel Diaz+maintainer:          diaz_carrete@yahoo.com+category:            Data+extra-source-files:  CHANGELOG.md,+                     README.md+build-type:          Simple++source-repository head+    type: git+    location: https://github.com/danidiaz/by-other-names.git++library+  exposed-modules:     ByOtherNames+                       ByOtherNames.Aeson+                       ByOtherNames.Constraint+                       ByOtherNames.TH+                       ByOtherNames.Internal+  build-depends:       base                 >= 4.10.0.0 && < 5,+                       aeson                >= 2.1.0.0,+                       text                 >= 1.2.3.0,+                       template-haskell     >= 2.16.0.0,+                       indexed-traversable  >= 0.1.2+  hs-source-dirs:      lib+  -- https://downloads.haskell.org/ghc/latest/docs/html/users_guide/using-warnings.html+  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++-- VERY IMPORTANT for doctests to work: https://stackoverflow.com/a/58027909/1364288+-- http://hackage.haskell.org/package/cabal-doctest+test-suite doctests+  ghc-options:         -threaded+  type:                exitcode-stdio-1.0+  hs-source-dirs:      tests+  main-is:             doctests.hs+  build-depends:       +                       base                 >= 4.10.0.0 && < 5,+                       doctest            ^>= 0.20,+                       by-other-names, +  default-language:    Haskell2010
+ lib/ByOtherNames.hs view
@@ -0,0 +1,33 @@+-- | This package 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 "ByOtherNames.Aeson" for a concrete example.+module ByOtherNames+  ( -- * Aliases +    Aliases,+    zipAliasesWith,+    AliasList,+    aliasListBegin,+    alias,+    aliasListEnd,+    -- * Rubrics+    Rubric (..),+    Aliased (aliases),+    -- * Generic helpers+    GHasDatatypeName(..),+    GHasFieldNames (..),+    GRecord (..),+    GHasBranchNames (..),+    GSum (..),+    Slots (..),+    -- * Re-exports+    Symbol,+  )+where++import ByOtherNames.Internal
+ lib/ByOtherNames/Aeson.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-}++-- | A 'Rubric' for JSON serialization using Aeson, along with some helper+-- newtypes and re-exports.+--+-- 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}+--   deriving (Read, Show, Eq, Generic)+--   deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo)+-- instance Aliased JSON Foo where+--   aliases =+--     aliasListBegin+--       $ alias @"aa" "aax"+--       $ alias @"bb" "bbx"+--       $ alias @"cc" "ccx"+--       $ aliasListEnd+-- :}+--+-- Example of use for a sum type:+--+-- >>> :{+-- data Summy+--   = Aa Int+--   | Bb Bool+--   | Cc+--   deriving (Read, Show, Eq, Generic)+--   deriving (FromJSON, ToJSON) via (JSONSum "sum" Summy)+-- instance Aliased JSON Summy where+--   aliases =+--     aliasListBegin+--       $ alias @"Aa" "Aax"+--       $ alias @"Bb" "Bbx"+--       $ alias @"Cc" "Ccx"+--       $ aliasListEnd+-- :}+--+-- Some limitations:+-- +-- - Fields in branches of sum types can't have selectors. When there is more than one field in a branch, they are parsed as a JSON Array.+-- +-- - For sum types, only the "object with a single key consisting in the branch tag" style of serialization is supported.+--+module ByOtherNames.Aeson+  ( -- * JSON helpers+    JSONRubric (..),+    JSONRecord (..),+    JSONSum (..),++    -- * Re-exports from ByOtherNames+    Aliased (aliases),+    aliasListBegin,+    alias,+    aliasListEnd,++    -- * Re-exports from Data.Aeson+    FromJSON,+    ToJSON,+  )+where++import ByOtherNames+import Control.Applicative+import Data.Aeson+import Data.Aeson.Types+import Data.Functor.Compose+import Data.Kind+import GHC.Generics+import GHC.TypeLits+import Data.Proxy+import Data.Foldable++-- | 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++-- | Helper newtype for deriving 'FromJSON' and 'ToJSON' for record types,+-- using DerivingVia.+--+-- The @objectName@ type parameter of kind 'Symbol' is used in parse error messages.+type JSONRecord :: Symbol -> Type -> Type+newtype JSONRecord objectName r = JSONRecord r++-- | Helper newtype for deriving 'FromJSON' and 'ToJSON' for sum types,+-- using DerivingVia.+--+-- The 'Symbol' type parameter is used in parse error messages.+type JSONSum :: Symbol -> Type -> Type+newtype JSONSum objectName r = JSONSum r++--+--+instance (KnownSymbol objectName, Aliased JSON r, GSum FromJSON (Rep r)) => FromJSON (JSONSum objectName r) where+  parseJSON v =+    let parsers = gToSum @FromJSON (aliases @JSONRubric @JSON @r) +          (\a -> \case +              ZeroSlots v -> BranchParser \o -> do+                Null :: Value <- o .: a+                pure v+              SingleSlot p -> BranchParser \o -> do+                value <- o .: a+                runProductInBranchParser1 p value+              ManySlots p -> BranchParser \o -> do+                valueList <- o .: a+                (prod, _) <- runProductInBranchParser p valueList+                pure prod+            ) +          (ProductInBranchParser1 parseJSON) +          (ProductInBranchParser \case +            [] -> parseFail "not enough field values for branch"+            v : vs -> do+              r <- parseJSON v+              pure (r, vs))+        parserForObject o = asum $ fmap (($ o) . runBranchParser) parsers+     in JSONSum . to <$> withObject (symbolVal (Proxy @objectName)) parserForObject v+newtype BranchParser v = BranchParser { runBranchParser :: Object -> Parser v}+  deriving stock Functor++newtype ProductInBranchParser1 v = ProductInBranchParser1 { runProductInBranchParser1 :: Value -> Parser v }+  deriving stock Functor+  deriving Applicative via (Compose ((->) Value) Parser)++newtype ProductInBranchParser v = ProductInBranchParser { runProductInBranchParser :: [Value] -> Parser (v, [Value]) }+  deriving stock Functor++instance Applicative ProductInBranchParser where+  pure v = ProductInBranchParser \vs -> pure (v, vs)+  ProductInBranchParser left <*> ProductInBranchParser right =+    ProductInBranchParser \vs0 -> do+      (f, vs1) <- left vs0+      (x, vs2) <- right vs1+      pure (f x, vs2)+++--+--+instance (KnownSymbol objectName, Aliased JSON r, GRecord FromJSON (Rep r)) => FromJSON (JSONRecord objectName r) where+  parseJSON v =+    let FieldParser parser = gToRecord @FromJSON (aliases @JSONRubric @JSON @r) +          (\fieldName -> FieldParser (\o ->explicitParseField parseJSON o fieldName))+        objectName = symbolVal (Proxy @objectName)+     in JSONRecord . to <$> withObject objectName parser v+newtype FieldParser a = FieldParser (Object -> Parser a)+  deriving (Functor, Applicative) via ((->) Object `Compose` Parser)+++--+--+instance (Aliased JSON r, GSum ToJSON (Rep r)) => ToJSON (JSONSum objectName r) where+  toJSON (JSONSum o) =+    let (key, slots) = gFromSum @ToJSON @(Rep r) @Key @Value @Value (aliases @JSONRubric @JSON @r) toJSON (from @r o)+     in case slots of+          [] -> object [(key, Null)]+          [x] -> object [(key, toJSON x)]+          xs -> object [(key, toJSON xs)]++--+--+instance (Aliased JSON r, GRecord ToJSON (Rep r)) => ToJSON (JSONRecord objectName r) where+  toJSON (JSONRecord o) =+    object $ Data.Foldable.toList $ gFromRecord @ToJSON @(Rep r) @Key (aliases @JSONRubric @JSON @r) (\a v -> (a, toJSON v)) (from @r o)++-- $setup+--+-- >>> :set -XBlockArguments+-- >>> :set -XTypeApplications+-- >>> :set -XDerivingStrategies+-- >>> :set -XDerivingVia+-- >>> :set -XDataKinds+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XDeriveGeneric+-- >>> :set -XOverloadedStrings+-- >>> import ByOtherNames.Aeson+-- >>> import Data.Aeson+-- >>> import Data.Aeson.Types+-- >>> import GHC.Generics+-- >>> import GHC.TypeLits
+ lib/ByOtherNames/Constraint.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE FlexibleInstances #-}+module ByOtherNames.Constraint (Top) where++-- | A constraint that can always be satisfied.+--+-- Copied from the @sop-core@ package.+--+class Top x+instance Top x
+ lib/ByOtherNames/Internal.hs view
@@ -0,0 +1,445 @@+{-# 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 package 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`.+module ByOtherNames.Internal+  ( Aliases (..),+    zipAliasesWith,+    AliasList,+    aliasListBegin,+    alias,+    aliasListEnd,+    Aliased (aliases),+    Rubric (..),++    -- * Generic helpers+    GHasDatatypeName(..),+    GHasFieldNames (..),+    GRecord (..),+    GHasBranchNames (..),+    GSum (..),+    Slots (..),+    -- * Re-exports+    Symbol,+  )+where++import Control.Applicative+import Data.Foldable.WithIndex+import Data.Functor.WithIndex+import Data.Kind+import Data.Proxy+import Data.Traversable.WithIndex+import GHC.Generics+import GHC.TypeLits++-- | This datatype carries the field aliases and matches the structure of the+--   generic Rep' shape.+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+  Branch :: KnownSymbol branchName => a -> Aliases (C1 ('MetaCons branchName fixity sels) v) a+  FieldTree ::+    Aliases left a ->+    Aliases right a ->+    Aliases (left :*: right) a+  BranchTree ::+    Aliases left a ->+    Aliases right a ->+    Aliases (left :+: right) a+  -- | We force the sum to contain at least two branches.+  Sum ::+    Aliases (left :+: right) a ->+    Aliases (D1 x (left :+: right)) a+  Record ::+    Aliases fields a ->+    Aliases (D1 x (C1 y fields)) a++zipAliasesWith :: (a -> b -> c) -> Aliases rep a -> Aliases rep b -> Aliases rep c+zipAliasesWith f a1 a2 = case (a1, a2) of+    (Field a, Field b) -> Field (f a b)+    (Branch a, Branch b) -> Branch (f a b)+    (FieldTree a1 a2, FieldTree b1 b2) -> FieldTree (zipAliasesWith f a1 b1) (zipAliasesWith f a2 b2)+    (BranchTree a1 a2, BranchTree b1 b2) -> BranchTree (zipAliasesWith f a1 b1) (zipAliasesWith f a2 b2)+    (Sum a, Sum b) -> Sum (zipAliasesWith f a b)+    (Record a, Record b) -> Record (zipAliasesWith f a b)++instance Functor (Aliases rep) where+  fmap f as = case as of+    Field a -> Field (f a)+    Branch a -> Branch (f a)+    FieldTree left right -> FieldTree (fmap f left) (fmap f right)+    BranchTree left right -> BranchTree (fmap f left) (fmap f right)+    Sum a -> Sum (fmap f a)+    Record a -> Record (fmap f a)++instance Foldable (Aliases rep) where+  foldMap f as = case as of+    Field a -> f a+    Branch a -> f a+    FieldTree left right -> foldMap f left <> foldMap f right+    BranchTree left right -> foldMap f left <> foldMap f right+    Sum a -> foldMap f a+    Record a -> foldMap f a++instance Traversable (Aliases rep) where+  traverse f as = case as of+    Field a -> Field <$> f a+    Branch a -> Branch <$> f a+    FieldTree left right -> FieldTree <$> traverse f left <*> traverse f right+    BranchTree left right -> BranchTree <$> traverse f left <*> traverse f right+    Sum a -> Sum <$> traverse f a+    Record a -> Record <$> traverse f a++-- | Indexed by the field or branch names.+deriving anyclass instance (FunctorWithIndex String (Aliases rep))++deriving anyclass instance (FoldableWithIndex String (Aliases rep))++instance TraversableWithIndex String (Aliases rep) where+  itraverse f as = case as of+    afield@(Field a) -> Field <$> traverseField f afield a+    abranch@(Branch a) -> Branch <$> traverseBranch f abranch a+    FieldTree left right -> FieldTree <$> itraverse f left <*> itraverse f right+    BranchTree left right -> BranchTree <$> itraverse f left <*> itraverse f right+    Sum a -> Sum <$> itraverse f a+    Record a -> Record <$> itraverse f a+    where+      traverseField :: forall fieldName a m b v proxy unpackedness strictness laziness. KnownSymbol fieldName => (String -> a -> m b) -> proxy (S1 ('MetaSel ('Just fieldName) unpackedness strictness laziness) v) a -> a -> m b+      traverseField f _ a =+        let fieldName = symbolVal (Proxy @fieldName)+         in f fieldName a+      traverseBranch :: forall branchName a m b v proxy fixity sels. KnownSymbol branchName => (String -> a -> m b) -> proxy (C1 ('MetaCons branchName fixity sels) v) a -> a -> m b+      traverseBranch f _ a =+        let branchName = symbolVal (Proxy @branchName)+         in f branchName a++-- | An intermediate datatype for specifying the aliases.  See+-- 'aliasListBegin', 'alias' and 'aliasListEnd'.+type AliasList :: [Symbol] -> Type -> Type+data AliasList names a where+  Null :: AliasList '[] a+  Cons :: Proxy name -> a -> AliasList names a -> AliasList (name : names) a++-- | 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 = Cons (Proxy @name)++-- | Define the aliases for a type by listing them.+--+-- See also 'alias' and 'aliasListEnd'.+aliasListBegin :: forall before a tree. (AliasTree before tree '[]) => AliasList before a -> Aliases tree a+aliasListBegin names =+  let (aliases, Null) = parseAliasTree @before @tree names+   in aliases++-- | The empty `AliasList`.+aliasListEnd :: AliasList '[] a+aliasListEnd = Null++type AssertNamesAreEqual :: Symbol -> Symbol -> Constraint+type family AssertNamesAreEqual given expected where+  AssertNamesAreEqual expected expected = ()+  AssertNamesAreEqual given expected =+    TypeError+      ( Text "Expected field or constructor name \"" :<>: Text expected :<>: Text "\","+          :$$: Text "but instead found name \"" :<>: Text given :<>: Text "\"."+      )++type MissingAlias :: Symbol -> Constraint+type family MissingAlias expected where+  MissingAlias expected =+    TypeError+      (Text "No alias given for field or constructor name \"" :<>: Text expected :<>: Text "\".")++-- type ExcessAliasError :: Symbol -> Constraint+-- type family ExcessAliasError name where+--   ExcessAliasError name =+--     TypeError+--       ( Text "Alias given for nonexistent field or constructor \"" :<>: Text name :<>: Text "\".")++-- | This typeclass converts the list-representation of aliases `AliasList` to+-- the tree of aliases 'Aliases' that matches the generic Rep's shape.+--+-- Also, quite importantly, it ensures that the field names in the list match+-- the field names in the Rep.+type AliasTree :: [Symbol] -> (Type -> Type) -> [Symbol] -> Constraint+-- Note that we could add the functional dependency "rep after -> before", but+-- we don't want that because it would allow us to omit the field name+-- annotation when giving the aliases. We *don't* want inference there!+class AliasTree before rep after | before rep -> after where+  parseAliasTree :: AliasList before a -> (Aliases rep a, AliasList after a)++--+instance (AssertNamesAreEqual name name', KnownSymbol name') => AliasTree (name : names) (S1 ('MetaSel (Just name') x y z) v) names where+  parseAliasTree (Cons _ a rest) = (Field a, rest)++instance MissingAlias name' => AliasTree '[] (S1 ('MetaSel (Just name') x y z) v) '[]++instance (AliasTree before left middle, AliasTree middle right end) => AliasTree before (left :*: right) end where+  parseAliasTree as =+    let (left, middle) = parseAliasTree @before as+        (right, end) = parseAliasTree @middle middle+     in (FieldTree left right, end)++instance AliasTree before tree '[] => AliasTree before (D1 x (C1 y tree)) '[] where+  parseAliasTree as =+    let (aliases', as') = parseAliasTree as+     in (Record aliases', as')++-- doesn't work because of the functional dependency :(+-- instance ExcessAliasError name => AliasTree before (D1 x (C1 y tree)) (name : names) where++--+instance (AssertNamesAreEqual name name', KnownSymbol name') => AliasTree (name : names) (C1 ('MetaCons name' fixity False) slots) names where+  parseAliasTree (Cons _ a rest) = (Branch a, rest)++instance MissingAlias name' => AliasTree '[] (C1 ('MetaCons name' fixity False) slots) '[]++instance (AliasTree before left middle, AliasTree middle right end) => AliasTree before (left :+: right) end where+  parseAliasTree as =+    let (left, middle) = parseAliasTree @before as+        (right, end) = parseAliasTree @middle middle+     in (BranchTree left right, end)++instance AliasTree before (left :+: right) '[] => AliasTree before (D1 x (left :+: right)) '[] where+  parseAliasTree as =+    let (aliases', as') = parseAliasTree as+     in (Sum aliases', as')++-- doesn't work because of the functional dependency :(+-- instance ExcessAliasError name => AliasTree before (D1 x (left :+: right)) (name : names) where++-- | Typeclass for datatypes @r@ that have aliases for some 'Rubric' @k@.+type Aliased :: k -> Type -> Constraint+class (Rubric k, Generic r) => Aliased k r where+  aliases :: Aliases (Rep r) (AliasType k)++-- | Typeclass for marker datakinds used as rubrics, for classifying aliases according to their use.+--+-- The associated type family `AliasType` gives the type of the aliases.+--+-- 'Rubric's are needed when defining helper newtypes for use with @-XDerivingVia@. Because+-- 'Aliases' are defined at the value level, we need a way to relate the aliases with+-- the datatype during deriving.++-- If you are using 'Aliases' in standalone functions (possibly in combination with+-- 'GRecord' and 'GSum') you might not need to define a 'Rubric'. +type Rubric :: k -> Constraint+class Rubric k where+  type AliasType k :: Type++class GHasDatatypeName rep where+  gGetDatatypeName :: String++instance KnownSymbol datatypeName => GHasDatatypeName (D1 (MetaData datatypeName m p nt) (C1 y prod)) where+  gGetDatatypeName = symbolVal (Proxy @datatypeName)++class GHasFieldNames rep where+  gGetFieldNames :: Aliases rep String+++instance GHasFieldNames prod => GHasFieldNames (D1 x (C1 y prod)) where+  gGetFieldNames = Record (gGetFieldNames @prod)++instance KnownSymbol fieldName => GHasFieldNames (S1 ('MetaSel ('Just fieldName) unpackedness strictness laziness) (Rec0 v)) where+  gGetFieldNames = Field (symbolVal (Proxy @fieldName))++instance+  (GHasFieldNames left, GHasFieldNames right) =>+  GHasFieldNames (left :*: right)+  where+  gGetFieldNames = FieldTree (gGetFieldNames @left) (gGetFieldNames @right)+++class GHasBranchNames rep where+  gGetBranchNames :: Aliases rep String++instance+  (GHasBranchNames (left :+: right)) =>+  GHasBranchNames (D1 x (left :+: right))+  where+  gGetBranchNames = Sum (gGetBranchNames @(left :+: right))++instance+  ( GHasBranchNames left,+    GHasBranchNames right+  ) =>+  GHasBranchNames (left :+: right)+  where+  gGetBranchNames = BranchTree (gGetBranchNames @left) (gGetBranchNames @right)++instance KnownSymbol branchName => GHasBranchNames (C1 ('MetaCons branchName fixity sels) y) where+  gGetBranchNames = Branch (symbolVal (Proxy @branchName))++--+--+class GRecord (c :: Type -> Constraint) rep where+  gToRecord ::+    Applicative m =>+    Aliases rep a ->+    (forall v. c v => a -> m v) ->+    m (rep z)+  gFromRecord ::+    Aliases rep a ->+    (forall v. c v => a -> v -> o) ->+    rep z ->+    Aliases rep o+  gRecordEnum ::+    Aliases rep a ->+    (forall v. c v => Proxy v -> o) ->+    Aliases rep (a, o)++instance GRecord c prod => GRecord c (D1 x (C1 y prod)) where+  gToRecord (Record as) parseField =+    M1 . M1 <$> gToRecord @c as parseField+  gFromRecord (Record as) renderField (M1 (M1 prod)) =+    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)+  where+  gToRecord (FieldTree aleft aright) parseField =+    (:*:) <$> gToRecord @c aleft parseField <*> gToRecord @c aright parseField+  gFromRecord (FieldTree aleft aright) renderField (left :*: right) =+    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)++--+--+data Slots m1 m2 v+  = ZeroSlots v+  | SingleSlot (m1 v)+  | ManySlots (m2 v)+  deriving stock (Show, Functor)++class GSum (c :: Type -> Constraint) rep where+  gToSum ::+    (Functor n, Applicative m2) =>+    Aliases rep a ->+    (forall b. a -> Slots m1 m2 b -> n b) ->+    (forall v. c v => m1 v) ->+    (forall v. c v => m2 v) ->+    Aliases rep (n (rep z))+  gFromSum ::+    Aliases rep a ->+    (forall v. c v => v -> o) ->+    rep z ->+    (a, [o])+  gSumEnum ::+    Aliases rep a ->+    (forall v. c v => Proxy v -> o) ->+    Aliases rep (a, [o])++instance+  (GSum c (left :+: right)) =>+  GSum c (D1 x (left :+: right))+  where+  gToSum (Sum s) parseBranch parseSlot1 parseSlot2 = Sum (fmap M1 <$> gToSum @c s parseBranch parseSlot1 parseSlot2)+  gFromSum (Sum s) renderSlot (M1 srep) = gFromSum @c s renderSlot srep+  gSumEnum (Sum s) renderSlot = Sum (gSumEnum @c @_ @_ @_ s renderSlot)++instance+  ( GSum c left,+    GSum c right+  ) =>+  GSum c (left :+: right)+  where+  gToSum (BranchTree aleft aright) parseBranch parseSlot1 parseSlot2 =+    BranchTree (fmap L1 <$> gToSum @c @left aleft parseBranch parseSlot1 parseSlot2) (fmap R1 <$> gToSum @c @right aright parseBranch parseSlot1 parseSlot2)+  gFromSum (BranchTree aleft aright) renderSlot = \case+    L1 rleft -> gFromSum @c aleft renderSlot rleft+    R1 rright -> gFromSum @c aright renderSlot rright+  gSumEnum (BranchTree aleft aright) renderSlot =+    BranchTree (gSumEnum @c aleft renderSlot) (gSumEnum @c aright renderSlot)++instance GSum c (C1 x U1) where+  gToSum (Branch fieldName) parseBranch parseSlot1 parseSlot2 =+    Branch (parseBranch fieldName (ZeroSlots (M1 U1)))+  gFromSum (Branch fieldName) renderSlot _ =+    (fieldName, [])+  gSumEnum (Branch fieldName) renderSlot =+    Branch (fieldName, [])++instance (c v) => GSum c (C1 x (S1 y (Rec0 v))) where+  gToSum (Branch fieldName) parseBranch parseSlot1 parseSlot2 =+    Branch (M1 . M1 . K1 <$> parseBranch fieldName (SingleSlot parseSlot1))+  gFromSum (Branch fieldName) renderSlot (M1 (M1 (K1 slots))) =+    (fieldName, [renderSlot slots])+  gSumEnum (Branch fieldName) renderSlot =+    Branch (fieldName, [renderSlot (Proxy @v)])++instance (GSumSlots c (left :*: right)) => GSum c (C1 x (left :*: right)) where+  gToSum (Branch fieldName) parseBranch parseSlot1 parseSlot2 =+    Branch (M1 <$> parseBranch fieldName (ManySlots (gToSumSlots @c parseSlot2)))+  gFromSum (Branch fieldName) renderSlot (M1 slots) =+    (fieldName, gFromSumSlots @c renderSlot slots)+  gSumEnum (Branch fieldName) renderSlot =+    Branch (fieldName, gSumEnumSlots @c @(left :*: right) renderSlot)++class GSumSlots (c :: Type -> Constraint) rep where+  gToSumSlots ::+    Applicative m =>+    (forall v. c v => m v) ->+    m (rep z)+  gFromSumSlots :: (forall v. c v => v -> o) -> rep z -> [o]+  gSumEnumSlots :: (forall v. c v => Proxy v -> o) -> [o]++instance c v => GSumSlots c (S1 y (Rec0 v)) where+  gToSumSlots parseSlot = M1 . K1 <$> parseSlot+  gFromSumSlots renderSlot (M1 (K1 v)) = [renderSlot v]+  gSumEnumSlots renderSlot = [renderSlot (Proxy @v)]++instance+  ( GSumSlots c left,+    GSumSlots c right+  ) =>+  GSumSlots c (left :*: right)+  where+  gToSumSlots parseSlot =+    (:*:) <$> gToSumSlots @c @left parseSlot <*> gToSumSlots @c @right parseSlot+  gFromSumSlots renderSlot (left :*: right) =+    gFromSumSlots @c renderSlot left ++ gFromSumSlots @c renderSlot right+  gSumEnumSlots renderSlot =+    gSumEnumSlots @c @left renderSlot ++ gSumEnumSlots @c @right renderSlot
+ lib/ByOtherNames/TH.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- | This module provides a quasiquoter which makes it a bit easier to define+-- lists of textual aliases.+--+-- >>> :{+-- data Foo = Foo {xa :: Int, xb :: Bool, xc :: Char, xd :: String, xe :: Int}+--            deriving stock (Read, Show, Eq, Generic)+--            deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo)+-- instance Aliased JSON Foo where+--   aliases = [aliasList| +--      xa = "aax",+--      xb = "bbx",+--      xc = "ccx",+--      xd = "ddx",+--      xe = "eex",+--    |]+-- :}+--+--+module ByOtherNames.TH (aliasList) where++import Control.Applicative+import Control.Monad+import GHC.Read+import Language.Haskell.TH+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote+import Text.ParserCombinators.ReadP+import Text.ParserCombinators.ReadPrec+import Text.Read.Lex (Lexeme (..))++-- if you are only interested in defining a quasiquoter to be used for+-- expressions, you would define a QuasiQuoter with only quoteExp, and leave+-- the other fields stubbed out with errors.+aliasList :: QuasiQuoter+aliasList =+  QuasiQuoter+    { quoteExp = quoteExp',+      quotePat = error "can only be used as expression",+      quoteType = error "can only be used as expression",+      quoteDec = error "can only be used as expression"+    }++quoteExp' :: String -> Q Exp+quoteExp' input = do+  let parsed = readPrec_to_S parseManyAlias 0 input+  case parsed of+    _ : _ : _ -> fail "ambiguous parse"+    [] -> fail "couldn't parse"+    (pairs, _) : _ ->+      pure $ TH.AppE (VarE (mkName "aliasListBegin")) $+        foldr addAlias (VarE (mkName "aliasListEnd")) pairs+  where+    addAlias (fieldName, fieldAlias) =+      TH.AppE $+        VarE (mkName "alias") `TH.AppTypeE` LitT (StrTyLit fieldName) `TH.AppE` LitE (StringL fieldAlias)++parseManyAlias :: ReadPrec [(String, String)]+parseManyAlias = do+  pairs <-+    sepEndBy1+      parseAlias+      ( do+          Punc punc <- lexP+          guard (punc == ",")+      )+  lift skipSpaces+  lift eof+  return pairs++parseAlias :: ReadPrec (String, String)+parseAlias = do+  Ident name <- lexP+  Punc punc <- lexP+  guard (punc == "=")+  String theAlias <- lexP+  return (name, theAlias)++-- how to use standard ReadP combinators here?+--+-- https://hackage.haskell.org/package/parser-combinators++-- | @'sepEndBy' p sep@ parses /zero/ or more occurrences of @p@, separated+-- and optionally ended by @sep@. Returns a list of values returned by @p@.+sepEndBy :: Alternative m => m a -> m sep -> m [a]+sepEndBy p sep = sepEndBy1 p sep <|> pure []+{-# INLINE sepEndBy #-}++-- | @'sepEndBy1' p sep@ parses /one/ or more occurrences of @p@, separated+-- and optionally ended by @sep@. Returns a list of values returned by @p@.+sepEndBy1 :: Alternative m => m a -> m sep -> m [a]+sepEndBy1 p sep = liftA2 (:) p ((sep *> sepEndBy p sep) <|> pure [])+{-# INLINEABLE sepEndBy1 #-}++-- $setup+--+-- >>> :set -XBlockArguments+-- >>> :set -XTypeApplications+-- >>> :set -XDerivingStrategies+-- >>> :set -XDerivingVia+-- >>> :set -XDataKinds+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XDeriveGeneric+-- >>> :set -XOverloadedStrings+-- >>> :set -XTemplateHaskell+-- >>> :set -XQuasiQuotes+-- >>> import ByOtherNames.Aeson+-- >>> import ByOtherNames.TH+-- >>> import Data.Aeson+-- >>> import Data.Aeson.Types+-- >>> import GHC.Generics+-- >>> import GHC.TypeLits
+ tests/doctests.hs view
@@ -0,0 +1,9 @@+module Main where+import Test.DocTest+main = doctest [+      "-ilib"+    , "lib/ByOtherNames.hs"+    , "lib/ByOtherNames/Aeson.hs"+    , "lib/ByOtherNames/TH.hs"+    , "lib/ByOtherNames/Constraint.hs"+    ]
+ tests/tests.hs view
@@ -0,0 +1,183 @@+{-# 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 ByOtherNames+import ByOtherNames.Aeson+  ( Aliased,+    JSONRecord (..),+    JSONRubric (JSON),+    JSONSum (..),+    alias,+    aliasListBegin,+    aliasListEnd,+    aliases,+  )+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++data Foo = Foo {aa :: Int, bb :: Bool, cc :: Char, dd :: String, ee :: Int}+  deriving (Read, Show, Eq, Generic)+  deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo)++instance Aliased JSON Foo where+  aliases =+    aliasListBegin+      . alias @"aa" "aax"+      . alias @"bb" "bbx"+      . alias @"cc" "ccx"+      . alias @"dd" "ddx"+      . alias @"ee" "eex"+      $ aliasListEnd++enumFoo :: [(Key, TypeRep)]+enumFoo =+  Data.Foldable.toList $+    gRecordEnum @Typeable @(Rep Foo)+      ( aliasListBegin+          . alias @"aa" "aax"+          . alias @"bb" "bbx"+          . alias @"cc" "ccx"+          . alias @"dd" "ddx"+          . alias @"ee" "eex"+          $ aliasListEnd+      )+      typeRep++expectedEnumFoo :: [(Key, TypeRep)]+expectedEnumFoo =+  [ ("aax", typeRep (Proxy @Int)),+    ("bbx", typeRep (Proxy @Bool)),+    ("ccx", typeRep (Proxy @Char)),+    ("ddx", typeRep (Proxy @String)),+    ("eex", typeRep (Proxy @Int))+  ]++data FooTH = FooTH {xa :: Int, xb :: Bool, xc :: Char, xd :: String, xe :: Int}+  deriving (Read, Show, Eq, Generic)+  deriving (FromJSON, ToJSON) via (JSONRecord "obj" FooTH)++instance Aliased JSON FooTH where+  aliases =+    [aliasList| +    xa = "aax",+    xb = "bbx",+    xc = "ccx",+    xd = "ddx",+    xe = "eex",+  |]++data Summy+  = Aa Int+  | Bb Bool+  | Cc+  | Dd Char Bool Int+  | Ee Int+  deriving (Read, Show, Eq, Generic)+  deriving (FromJSON, ToJSON) via (JSONSum "sum" Summy)++instance Aliased JSON Summy where+  aliases =+    aliasListBegin+      . alias @"Aa" "Aax"+      . alias @"Bb" "Bbx"+      . alias @"Cc" "Ccx"+      . alias @"Dd" "Ddx"+      . alias @"Ee" "Eex"+      $ aliasListEnd++enumSummy :: [(Key, [TypeRep])]+enumSummy =+  Data.Foldable.toList $+    gSumEnum @Typeable @(Rep Summy)+      ( aliasListBegin+          . alias @"Aa" "Aax"+          . alias @"Bb" "Bbx"+          . alias @"Cc" "Ccx"+          . alias @"Dd" "Ddx"+          . alias @"Ee" "Eex"+          $ aliasListEnd+      )+      typeRep++expectedEnumSummy :: [(Key, [TypeRep])]+expectedEnumSummy =+  [ ("Aax", [typeRep (Proxy @Int)]),+    ("Bbx", [typeRep (Proxy @Bool)]),+    ("Ccx", []),+    ("Ddx", [typeRep (Proxy @Char), typeRep (Proxy @Bool), typeRep (Proxy @Int)]),+    ("Eex", [typeRep (Proxy @Int)])+  ]++-- >>> enumSummy++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'++data SingleField = SingleField {single :: Int}+  deriving (Read, Show, Eq, Generic)+  deriving (FromJSON, ToJSON) via (JSONRecord "sng" SingleField)++instance Aliased JSON SingleField where+  aliases =+    aliasListBegin+      . alias @"single" "Aa"+      $ aliasListEnd++-- data SingleBranch = SingleBranch Int+--   deriving (Read, Show, Eq, Generic)+--   deriving (FromJSON, ToJSON) via (JSONSum "sng" SingleBranch)++-- instance Aliased JSON SingleBranch where+--   aliases =+--     branchAliases+--         $ alias (Proxy @"SingleBranch") "Aa"+--         $ aliasListEnd++--+--+main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+  testGroup+    "All"+    [ testCase "recordRoundtrip" $ roundtrip $ Foo 0 False 'f' "foo" 3,+      testCase "recordRoundtripSingle" $ roundtrip $ SingleField 3,+      testGroup+        "sumRoundtrip"+        [ testCase "a" $ roundtrip $ Aa 5,+          testCase "b" $ roundtrip $ Bb False,+          testCase "c" $ roundtrip $ Cc,+          testCase "d" $ roundtrip $ Dd 'f' True 0,+          testCase "e" $ roundtrip $ Ee 3+        ],+      testGroup+        "enums"+        [ testCase "prod typeReps" $ assertEqual "prod typeReps match" expectedEnumFoo enumFoo,+          testCase "sum typeReps" $ assertEqual "sum typeReps match" expectedEnumSummy enumSummy+        ]+    ]