{-# 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/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
  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 :: forall a b c (rep :: * -> *).
(a -> b -> c) -> Aliases rep a -> Aliases rep b -> Aliases rep c
zipAliasesWith a -> b -> c
f Aliases rep a
a1 Aliases rep b
a2 = case (Aliases rep a
a1, Aliases rep b
a2) of
  (Field a
a, Field b
b) -> forall (name :: Symbol) a (names :: SourceUnpackedness)
       (y :: SourceStrictness) (v :: DecidedStrictness) (v :: * -> *).
KnownSymbol name =>
a -> Aliases (S1 ('MetaSel ('Just name) names y v) v) a
Field (a -> b -> c
f a
a b
b)
  (Branch a
a, Branch b
b) -> forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch (a -> b -> c
f a
a b
b)
  (FieldTree Aliases left a
a1 Aliases right a
a2, FieldTree Aliases left b
b1 Aliases right b
b2) -> forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :*: names) a
FieldTree (forall a b c (rep :: * -> *).
(a -> b -> c) -> Aliases rep a -> Aliases rep b -> Aliases rep c
zipAliasesWith a -> b -> c
f Aliases left a
a1 Aliases left b
b1) (forall a b c (rep :: * -> *).
(a -> b -> c) -> Aliases rep a -> Aliases rep b -> Aliases rep c
zipAliasesWith a -> b -> c
f Aliases right a
a2 Aliases right b
b2)
  (BranchTree Aliases left a
a1 Aliases right a
a2, BranchTree Aliases left b
b1 Aliases right b
b2) -> forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :+: names) a
BranchTree (forall a b c (rep :: * -> *).
(a -> b -> c) -> Aliases rep a -> Aliases rep b -> Aliases rep c
zipAliasesWith a -> b -> c
f Aliases left a
a1 Aliases left b
b1) (forall a b c (rep :: * -> *).
(a -> b -> c) -> Aliases rep a -> Aliases rep b -> Aliases rep c
zipAliasesWith a -> b -> c
f Aliases right a
a2 Aliases right b
b2)
  (Sum Aliases (left :+: right) a
a, Sum Aliases (left :+: right) b
b) -> forall (name :: * -> *) (names :: * -> *) a (y :: Meta).
Aliases (name :+: names) a -> Aliases (D1 y (name :+: names)) a
Sum (forall a b c (rep :: * -> *).
(a -> b -> c) -> Aliases rep a -> Aliases rep b -> Aliases rep c
zipAliasesWith a -> b -> c
f Aliases (left :+: right) a
a Aliases (left :+: right) b
b)
  (Record Aliases fields a
a, Record Aliases fields b
b) -> forall (name :: * -> *) a (names :: Meta) (y :: Meta).
Aliases name a -> Aliases (D1 names (C1 y name)) a
Record (forall a b c (rep :: * -> *).
(a -> b -> c) -> Aliases rep a -> Aliases rep b -> Aliases rep c
zipAliasesWith a -> b -> c
f Aliases fields a
a Aliases fields b
b)

instance Functor (Aliases rep) where
  fmap :: forall a b. (a -> b) -> Aliases rep a -> Aliases rep b
fmap a -> b
f Aliases rep a
as = case Aliases rep a
as of
    Field a
a -> forall (name :: Symbol) a (names :: SourceUnpackedness)
       (y :: SourceStrictness) (v :: DecidedStrictness) (v :: * -> *).
KnownSymbol name =>
a -> Aliases (S1 ('MetaSel ('Just name) names y v) v) a
Field (a -> b
f a
a)
    Branch a
a -> forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch (a -> b
f a
a)
    FieldTree Aliases left a
left Aliases right a
right -> forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :*: names) a
FieldTree (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Aliases left a
left) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Aliases right a
right)
    BranchTree Aliases left a
left Aliases right a
right -> forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :+: names) a
BranchTree (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Aliases left a
left) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Aliases right a
right)
    Sum Aliases (left :+: right) a
a -> forall (name :: * -> *) (names :: * -> *) a (y :: Meta).
Aliases (name :+: names) a -> Aliases (D1 y (name :+: names)) a
Sum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Aliases (left :+: right) a
a)
    Record Aliases fields a
a -> forall (name :: * -> *) a (names :: Meta) (y :: Meta).
Aliases name a -> Aliases (D1 names (C1 y name)) a
Record (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Aliases fields a
a)

instance Foldable (Aliases rep) where
  foldMap :: forall m a. Monoid m => (a -> m) -> Aliases rep a -> m
foldMap a -> m
f Aliases rep a
as = case Aliases rep a
as of
    Field a
a -> a -> m
f a
a
    Branch a
a -> a -> m
f a
a
    FieldTree Aliases left a
left Aliases right a
right -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Aliases left a
left forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Aliases right a
right
    BranchTree Aliases left a
left Aliases right a
right -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Aliases left a
left forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Aliases right a
right
    Sum Aliases (left :+: right) a
a -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Aliases (left :+: right) a
a
    Record Aliases fields a
a -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Aliases fields a
a

instance Traversable (Aliases rep) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Aliases rep a -> f (Aliases rep b)
traverse a -> f b
f Aliases rep a
as = case Aliases rep a
as of
    Field a
a -> forall (name :: Symbol) a (names :: SourceUnpackedness)
       (y :: SourceStrictness) (v :: DecidedStrictness) (v :: * -> *).
KnownSymbol name =>
a -> Aliases (S1 ('MetaSel ('Just name) names y v) v) a
Field forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
    Branch a
a -> forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
    FieldTree Aliases left a
left Aliases right a
right -> forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :*: names) a
FieldTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Aliases left a
left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Aliases right a
right
    BranchTree Aliases left a
left Aliases right a
right -> forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :+: names) a
BranchTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Aliases left a
left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Aliases right a
right
    Sum Aliases (left :+: right) a
a -> forall (name :: * -> *) (names :: * -> *) a (y :: Meta).
Aliases (name :+: names) a -> Aliases (D1 y (name :+: names)) a
Sum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Aliases (left :+: right) a
a
    Record Aliases fields a
a -> forall (name :: * -> *) a (names :: Meta) (y :: Meta).
Aliases name a -> Aliases (D1 names (C1 y name)) a
Record forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Aliases fields a
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 :: forall (f :: * -> *) a b.
Applicative f =>
(String -> a -> f b) -> Aliases rep a -> f (Aliases rep b)
itraverse String -> a -> f b
f Aliases rep a
as = case Aliases rep a
as of
    afield :: Aliases rep a
afield@(Field a
a) -> forall (name :: Symbol) a (names :: SourceUnpackedness)
       (y :: SourceStrictness) (v :: DecidedStrictness) (v :: * -> *).
KnownSymbol name =>
a -> Aliases (S1 ('MetaSel ('Just name) names y v) v) a
Field forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} {k} (fieldName :: Symbol) a (m :: k -> *) (b :: k)
       (v :: k -> *) (proxy :: (k -> *) -> * -> *)
       (unpackedness :: SourceUnpackedness)
       (strictness :: SourceStrictness) (laziness :: DecidedStrictness).
KnownSymbol fieldName =>
(String -> a -> m b)
-> proxy
     (S1
        ('MetaSel ('Just fieldName) unpackedness strictness laziness) v)
     a
-> a
-> m b
traverseField String -> a -> f b
f Aliases rep a
afield a
a
    abranch :: Aliases rep a
abranch@(Branch a
a) -> forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} {k} (branchName :: Symbol) a (m :: k -> *) (b :: k)
       (v :: k -> *) (proxy :: (k -> *) -> * -> *) (fixity :: FixityI)
       (sels :: Bool).
KnownSymbol branchName =>
(String -> a -> m b)
-> proxy (C1 ('MetaCons branchName fixity sels) v) a -> a -> m b
traverseBranch String -> a -> f b
f Aliases rep a
abranch a
a
    FieldTree Aliases left a
left Aliases right a
right -> forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :*: names) a
FieldTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse String -> a -> f b
f Aliases left a
left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse String -> a -> f b
f Aliases right a
right
    BranchTree Aliases left a
left Aliases right a
right -> forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :+: names) a
BranchTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse String -> a -> f b
f Aliases left a
left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse String -> a -> f b
f Aliases right a
right
    Sum Aliases (left :+: right) a
a -> forall (name :: * -> *) (names :: * -> *) a (y :: Meta).
Aliases (name :+: names) a -> Aliases (D1 y (name :+: names)) a
Sum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse String -> a -> f b
f Aliases (left :+: right) a
a
    Record Aliases fields a
a -> forall (name :: * -> *) a (names :: Meta) (y :: Meta).
Aliases name a -> Aliases (D1 names (C1 y name)) a
Record forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse String -> a -> f b
f Aliases fields a
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 :: forall {k} {k} (fieldName :: Symbol) a (m :: k -> *) (b :: k)
       (v :: k -> *) (proxy :: (k -> *) -> * -> *)
       (unpackedness :: SourceUnpackedness)
       (strictness :: SourceStrictness) (laziness :: DecidedStrictness).
KnownSymbol fieldName =>
(String -> a -> m b)
-> proxy
     (S1
        ('MetaSel ('Just fieldName) unpackedness strictness laziness) v)
     a
-> a
-> m b
traverseField String -> a -> m b
f proxy
  (S1
     ('MetaSel ('Just fieldName) unpackedness strictness laziness) v)
  a
_ a
a =
        let fieldName :: String
fieldName = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @fieldName)
         in String -> a -> m b
f String
fieldName a
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 :: forall {k} {k} (branchName :: Symbol) a (m :: k -> *) (b :: k)
       (v :: k -> *) (proxy :: (k -> *) -> * -> *) (fixity :: FixityI)
       (sels :: Bool).
KnownSymbol branchName =>
(String -> a -> m b)
-> proxy (C1 ('MetaCons branchName fixity sels) v) a -> a -> m b
traverseBranch String -> a -> m b
f proxy (C1 ('MetaCons branchName fixity sels) v) a
_ a
a =
        let branchName :: String
branchName = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @branchName)
         in String -> a -> m b
f String
branchName a
a

-- | An intermediate helper 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. 
  -- | The alias value
  a -> 
  AliasList names a -> 
  AliasList (name : names) a
alias :: forall (name :: Symbol) a (names :: [Symbol]).
a -> AliasList names a -> AliasList (name : names) a
alias = forall (name :: Symbol) a (names :: [Symbol]).
Proxy name -> a -> AliasList names a -> AliasList (name : names) a
Cons (forall {k} (t :: k). Proxy t
Proxy @name)

-- | Define the aliases for a type by listing them.
--
-- See also 'alias' and 'aliasListEnd'.
--
-- The type of the argument is indexed by a list of 'Symbol's, while the 
-- type of the result is indexed by a generic 'Rep'.
--
-- Example for a record:
--
-- >>> :{
-- data Foo = Foo {aa :: Int, bb :: Bool}
--   deriving (Read, Show, Generic)
-- fieldAliases :: Aliases (Rep Foo) String
-- fieldAliases = aliasListBegin $ alias @"aa" "alias1" $ alias @"bb" "alias2" $ aliasListEnd
-- :}
--
-- Example for a sum:
--
-- >>> :{
-- data Bar = Aa Int | Bb
--   deriving (Read, Show, Generic)
-- branchAliases :: Aliases (Rep Bar) String
-- branchAliases = aliasListBegin $ alias @"Aa" "alias1" $ alias @"Bb" "alias2" $ aliasListEnd
-- :}
--
--
aliasListBegin :: forall names a rep. (AliasTree names rep '[]) 
  => AliasList names a -- ^ indexed by a list of names
  -> Aliases rep a -- ^ indexed by a generic 'Rep'
aliasListBegin :: forall (names :: [Symbol]) a (rep :: * -> *).
AliasTree names rep '[] =>
AliasList names a -> Aliases rep a
aliasListBegin AliasList names a
names =
  let (Aliases rep a
aliases, AliasList '[] a
Null) = forall (before :: [Symbol]) (rep :: * -> *) (after :: [Symbol]) a.
AliasTree before rep after =>
AliasList before a -> (Aliases rep a, AliasList after a)
parseAliasTree @names @rep AliasList names a
names
   in Aliases rep a
aliases

-- | The empty `AliasList`.
aliasListEnd :: AliasList '[] a
aliasListEnd :: forall a. AliasList '[] a
aliasListEnd = forall a. AliasList '[] a
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 :: forall a.
AliasList (name : names) a
-> (Aliases (S1 ('MetaSel ('Just name') x y z) v) a,
    AliasList names a)
parseAliasTree (Cons Proxy name
_ a
a AliasList names a
rest) = (forall (name :: Symbol) a (names :: SourceUnpackedness)
       (y :: SourceStrictness) (v :: DecidedStrictness) (v :: * -> *).
KnownSymbol name =>
a -> Aliases (S1 ('MetaSel ('Just name) names y v) v) a
Field a
a, AliasList names 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 :: forall a.
AliasList before a -> (Aliases (left :*: right) a, AliasList end a)
parseAliasTree AliasList before a
as =
    let (Aliases left a
left, AliasList middle a
middle) = forall (before :: [Symbol]) (rep :: * -> *) (after :: [Symbol]) a.
AliasTree before rep after =>
AliasList before a -> (Aliases rep a, AliasList after a)
parseAliasTree @before AliasList before a
as
        (Aliases right a
right, AliasList end a
end) = forall (before :: [Symbol]) (rep :: * -> *) (after :: [Symbol]) a.
AliasTree before rep after =>
AliasList before a -> (Aliases rep a, AliasList after a)
parseAliasTree @middle AliasList middle a
middle
     in (forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :*: names) a
FieldTree Aliases left a
left Aliases right a
right, AliasList end a
end)

instance AliasTree before tree '[] => AliasTree before (D1 x (C1 y tree)) '[] where
  parseAliasTree :: forall a.
AliasList before a
-> (Aliases (D1 x (C1 y tree)) a, AliasList '[] a)
parseAliasTree AliasList before a
as =
    let (Aliases tree a
aliases', AliasList '[] a
as') = forall (before :: [Symbol]) (rep :: * -> *) (after :: [Symbol]) a.
AliasTree before rep after =>
AliasList before a -> (Aliases rep a, AliasList after a)
parseAliasTree AliasList before a
as
     in (forall (name :: * -> *) a (names :: Meta) (y :: Meta).
Aliases name a -> Aliases (D1 names (C1 y name)) a
Record Aliases tree a
aliases', AliasList '[] a
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 :: forall a.
AliasList (name : names) a
-> (Aliases (C1 ('MetaCons name' fixity 'False) slots) a,
    AliasList names a)
parseAliasTree (Cons Proxy name
_ a
a AliasList names a
rest) = (forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch a
a, AliasList names 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 :: forall a.
AliasList before a -> (Aliases (left :+: right) a, AliasList end a)
parseAliasTree AliasList before a
as =
    let (Aliases left a
left, AliasList middle a
middle) = forall (before :: [Symbol]) (rep :: * -> *) (after :: [Symbol]) a.
AliasTree before rep after =>
AliasList before a -> (Aliases rep a, AliasList after a)
parseAliasTree @before AliasList before a
as
        (Aliases right a
right, AliasList end a
end) = forall (before :: [Symbol]) (rep :: * -> *) (after :: [Symbol]) a.
AliasTree before rep after =>
AliasList before a -> (Aliases rep a, AliasList after a)
parseAliasTree @middle AliasList middle a
middle
     in (forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :+: names) a
BranchTree Aliases left a
left Aliases right a
right, AliasList end a
end)

instance AliasTree before (left :+: right) '[] => AliasTree before (D1 x (left :+: right)) '[] where
  parseAliasTree :: forall a.
AliasList before a
-> (Aliases (D1 x (left :+: right)) a, AliasList '[] a)
parseAliasTree AliasList before a
as =
    let (Aliases (left :+: right) a
aliases', AliasList '[] a
as') = forall (before :: [Symbol]) (rep :: * -> *) (after :: [Symbol]) a.
AliasTree before rep after =>
AliasList before a -> (Aliases rep a, AliasList after a)
parseAliasTree AliasList before a
as
     in (forall (name :: * -> *) (names :: * -> *) a (y :: Meta).
Aliases (name :+: names) a -> Aliases (D1 y (name :+: names)) a
Sum Aliases (left :+: right) a
aliases', AliasList '[] a
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

-- | Given a datatype's 'Rep', obtain the datatype's name.
class GHasDatatypeName rep where
  gGetDatatypeName :: String

instance KnownSymbol datatypeName => GHasDatatypeName (D1 (MetaData datatypeName m p nt) (C1 y prod)) where
  gGetDatatypeName :: String
gGetDatatypeName = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @datatypeName)

-- | Given a datatype's 'Rep', obtain its field names, assuming the datatype is a record.
class GHasFieldNames rep where
  gGetFieldNames :: Aliases rep String

instance GHasFieldNames prod => GHasFieldNames (D1 x (C1 y prod)) where
  gGetFieldNames :: Aliases (D1 x (C1 y prod)) String
gGetFieldNames = forall (name :: * -> *) a (names :: Meta) (y :: Meta).
Aliases name a -> Aliases (D1 names (C1 y name)) a
Record (forall (rep :: * -> *). GHasFieldNames rep => Aliases rep String
gGetFieldNames @prod)

instance KnownSymbol fieldName => GHasFieldNames (S1 ('MetaSel ('Just fieldName) unpackedness strictness laziness) (Rec0 v)) where
  gGetFieldNames :: Aliases
  (S1
     ('MetaSel ('Just fieldName) unpackedness strictness laziness)
     (Rec0 v))
  String
gGetFieldNames = forall (name :: Symbol) a (names :: SourceUnpackedness)
       (y :: SourceStrictness) (v :: DecidedStrictness) (v :: * -> *).
KnownSymbol name =>
a -> Aliases (S1 ('MetaSel ('Just name) names y v) v) a
Field (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @fieldName))

instance
  (GHasFieldNames left, GHasFieldNames right) =>
  GHasFieldNames (left :*: right)
  where
  gGetFieldNames :: Aliases (left :*: right) String
gGetFieldNames = forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :*: names) a
FieldTree (forall (rep :: * -> *). GHasFieldNames rep => Aliases rep String
gGetFieldNames @left) (forall (rep :: * -> *). GHasFieldNames rep => Aliases rep String
gGetFieldNames @right)

-- | Given a datatype's 'Rep', obtain its brach names, assuming the datatype is a sum.
class GHasBranchNames rep where
  gGetBranchNames :: Aliases rep String

instance
  (GHasBranchNames (left :+: right)) =>
  GHasBranchNames (D1 x (left :+: right))
  where
  gGetBranchNames :: Aliases (D1 x (left :+: right)) String
gGetBranchNames = forall (name :: * -> *) (names :: * -> *) a (y :: Meta).
Aliases (name :+: names) a -> Aliases (D1 y (name :+: names)) a
Sum (forall (rep :: * -> *). GHasBranchNames rep => Aliases rep String
gGetBranchNames @(left :+: right))

instance
  ( GHasBranchNames left,
    GHasBranchNames right
  ) =>
  GHasBranchNames (left :+: right)
  where
  gGetBranchNames :: Aliases (left :+: right) String
gGetBranchNames = forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :+: names) a
BranchTree (forall (rep :: * -> *). GHasBranchNames rep => Aliases rep String
gGetBranchNames @left) (forall (rep :: * -> *). GHasBranchNames rep => Aliases rep String
gGetBranchNames @right)

instance KnownSymbol branchName => GHasBranchNames (C1 ('MetaCons branchName fixity sels) y) where
  gGetBranchNames :: Aliases (C1 ('MetaCons branchName fixity sels) y) String
gGetBranchNames = forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @branchName))

-- | Helper typeclass for defining typeclass instances for record types.
--
-- Parameterized by a constraint @c@ that each field of the record must satisfy, and by
-- the generic 'Rep' of the record.
class GRecord (c :: Type -> Constraint) rep where
  -- | Builds a parser for the entire generic 'Rep' out of parsers for each field.
  gToRecord ::
    Applicative m =>
    -- | Field aliases.
    Aliases rep a ->
    (forall v. c v => a -> m v) ->
    m (rep z)

  -- | Returns an uniform representation of each field's value in a record.
  --
  -- Useful for serializing.
  gFromRecord ::
    -- | Field aliases.
    Aliases rep a ->
    (forall v. c v => a -> v -> o) ->
    rep z ->
    Aliases rep o

  -- | Decorates an 'Aliases' value with values derived from the type of the corresponding fields.
  gRecordEnum ::
    -- | Field aliases.
    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 :: forall (m :: * -> *) a z.
Applicative m =>
Aliases (D1 x (C1 y prod)) a
-> (forall v. c v => a -> m v) -> m (D1 x (C1 y prod) z)
gToRecord (Record Aliases fields a
as) forall v. c v => a -> m v
parseField =
    forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> Constraint) (rep :: * -> *) (m :: * -> *) a z.
(GRecord c rep, Applicative m) =>
Aliases rep a -> (forall v. c v => a -> m v) -> m (rep z)
gToRecord @c Aliases fields a
as forall v. c v => a -> m v
parseField
  gFromRecord :: forall a o z.
Aliases (D1 x (C1 y prod)) a
-> (forall v. c v => a -> v -> o)
-> D1 x (C1 y prod) z
-> Aliases (D1 x (C1 y prod)) o
gFromRecord (Record Aliases fields a
as) forall v. c v => a -> v -> o
renderField (M1 (M1 prod z
prod)) =
    forall (name :: * -> *) a (names :: Meta) (y :: Meta).
Aliases name a -> Aliases (D1 names (C1 y name)) a
Record (forall (c :: * -> Constraint) (rep :: * -> *) a o z.
GRecord c rep =>
Aliases rep a
-> (forall v. c v => a -> v -> o) -> rep z -> Aliases rep o
gFromRecord @c Aliases fields a
as forall v. c v => a -> v -> o
renderField prod z
prod)
  gRecordEnum :: forall a o.
Aliases (D1 x (C1 y prod)) a
-> (forall v. c v => Proxy v -> o)
-> Aliases (D1 x (C1 y prod)) (a, o)
gRecordEnum (Record Aliases fields a
as) forall v. c v => Proxy v -> o
renderField = forall (name :: * -> *) a (names :: Meta) (y :: Meta).
Aliases name a -> Aliases (D1 names (C1 y name)) a
Record (forall (c :: * -> Constraint) (rep :: * -> *) a o.
GRecord c rep =>
Aliases rep a
-> (forall v. c v => Proxy v -> o) -> Aliases rep (a, o)
gRecordEnum @c @prod Aliases fields a
as forall v. c v => Proxy v -> o
renderField)

instance
  (GRecord c left, GRecord c right) =>
  GRecord c (left :*: right)
  where
  gToRecord :: forall (m :: * -> *) a z.
Applicative m =>
Aliases (left :*: right) a
-> (forall v. c v => a -> m v) -> m ((:*:) left right z)
gToRecord (FieldTree Aliases left a
aleft Aliases right a
aright) forall v. c v => a -> m v
parseField =
    forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> Constraint) (rep :: * -> *) (m :: * -> *) a z.
(GRecord c rep, Applicative m) =>
Aliases rep a -> (forall v. c v => a -> m v) -> m (rep z)
gToRecord @c Aliases left a
aleft forall v. c v => a -> m v
parseField forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (rep :: * -> *) (m :: * -> *) a z.
(GRecord c rep, Applicative m) =>
Aliases rep a -> (forall v. c v => a -> m v) -> m (rep z)
gToRecord @c Aliases right a
aright forall v. c v => a -> m v
parseField
  gFromRecord :: forall a o z.
Aliases (left :*: right) a
-> (forall v. c v => a -> v -> o)
-> (:*:) left right z
-> Aliases (left :*: right) o
gFromRecord (FieldTree Aliases left a
aleft Aliases right a
aright) forall v. c v => a -> v -> o
renderField (left z
left :*: right z
right) =
    forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :*: names) a
FieldTree (forall (c :: * -> Constraint) (rep :: * -> *) a o z.
GRecord c rep =>
Aliases rep a
-> (forall v. c v => a -> v -> o) -> rep z -> Aliases rep o
gFromRecord @c Aliases left a
aleft forall v. c v => a -> v -> o
renderField left z
left) (forall (c :: * -> Constraint) (rep :: * -> *) a o z.
GRecord c rep =>
Aliases rep a
-> (forall v. c v => a -> v -> o) -> rep z -> Aliases rep o
gFromRecord @c Aliases right a
aright forall v. c v => a -> v -> o
renderField right z
right)
  gRecordEnum :: forall a o.
Aliases (left :*: right) a
-> (forall v. c v => Proxy v -> o)
-> Aliases (left :*: right) (a, o)
gRecordEnum (FieldTree Aliases left a
aleft Aliases right a
aright) forall v. c v => Proxy v -> o
renderField =
    forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :*: names) a
FieldTree (forall (c :: * -> Constraint) (rep :: * -> *) a o.
GRecord c rep =>
Aliases rep a
-> (forall v. c v => Proxy v -> o) -> Aliases rep (a, o)
gRecordEnum @c @left Aliases left a
aleft forall v. c v => Proxy v -> o
renderField) (forall (c :: * -> Constraint) (rep :: * -> *) a o.
GRecord c rep =>
Aliases rep a
-> (forall v. c v => Proxy v -> o) -> Aliases rep (a, o)
gRecordEnum @c @right Aliases right a
aright forall v. c v => Proxy v -> o
renderField)

instance c v => GRecord c (S1 x (Rec0 v)) where
  gToRecord :: forall (m :: * -> *) a z.
Applicative m =>
Aliases (S1 x (Rec0 v)) a
-> (forall v. c v => a -> m v) -> m (S1 x (Rec0 v) z)
gToRecord (Field a
a) forall v. c v => a -> m v
parseField =
    forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. c v => a -> m v
parseField a
a
  gFromRecord :: forall a o z.
Aliases (S1 x (Rec0 v)) a
-> (forall v. c v => a -> v -> o)
-> S1 x (Rec0 v) z
-> Aliases (S1 x (Rec0 v)) o
gFromRecord (Field a
a) forall v. c v => a -> v -> o
renderField (M1 (K1 v
v)) = forall (name :: Symbol) a (names :: SourceUnpackedness)
       (y :: SourceStrictness) (v :: DecidedStrictness) (v :: * -> *).
KnownSymbol name =>
a -> Aliases (S1 ('MetaSel ('Just name) names y v) v) a
Field (forall v. c v => a -> v -> o
renderField a
a v
v)
  gRecordEnum :: forall a o.
Aliases (S1 x (Rec0 v)) a
-> (forall v. c v => Proxy v -> o)
-> Aliases (S1 x (Rec0 v)) (a, o)
gRecordEnum (Field a
a) forall v. c v => Proxy v -> o
renderField = forall (name :: Symbol) a (names :: SourceUnpackedness)
       (y :: SourceStrictness) (v :: DecidedStrictness) (v :: * -> *).
KnownSymbol name =>
a -> Aliases (S1 ('MetaSel ('Just name) names y v) v) a
Field (a
a, forall v. c v => Proxy v -> o
renderField (forall {k} (t :: k). Proxy t
Proxy @v))


-- | Helper for defining branch parsers.
--
-- @v@ is some part of a generic 'Rep', @m1@ is some parser type for when there's a single
-- field in the branch, and @m2@ is some parser type for when there's more than one field
-- in the branch.
--
-- @m1@ and @m2@ might be the same type.
data Slots m1 m2 v
  = ZeroSlots v
  | SingleSlot (m1 v)
  | ManySlots (m2 v)
  deriving stock (Int -> Slots m1 m2 v -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m1 :: * -> *) (m2 :: * -> *) v.
(Show v, Show (m1 v), Show (m2 v)) =>
Int -> Slots m1 m2 v -> ShowS
forall (m1 :: * -> *) (m2 :: * -> *) v.
(Show v, Show (m1 v), Show (m2 v)) =>
[Slots m1 m2 v] -> ShowS
forall (m1 :: * -> *) (m2 :: * -> *) v.
(Show v, Show (m1 v), Show (m2 v)) =>
Slots m1 m2 v -> String
showList :: [Slots m1 m2 v] -> ShowS
$cshowList :: forall (m1 :: * -> *) (m2 :: * -> *) v.
(Show v, Show (m1 v), Show (m2 v)) =>
[Slots m1 m2 v] -> ShowS
show :: Slots m1 m2 v -> String
$cshow :: forall (m1 :: * -> *) (m2 :: * -> *) v.
(Show v, Show (m1 v), Show (m2 v)) =>
Slots m1 m2 v -> String
showsPrec :: Int -> Slots m1 m2 v -> ShowS
$cshowsPrec :: forall (m1 :: * -> *) (m2 :: * -> *) v.
(Show v, Show (m1 v), Show (m2 v)) =>
Int -> Slots m1 m2 v -> ShowS
Show, forall a b. a -> Slots m1 m2 b -> Slots m1 m2 a
forall a b. (a -> b) -> Slots m1 m2 a -> Slots m1 m2 b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m1 :: * -> *) (m2 :: * -> *) a b.
(Functor m1, Functor m2) =>
a -> Slots m1 m2 b -> Slots m1 m2 a
forall (m1 :: * -> *) (m2 :: * -> *) a b.
(Functor m1, Functor m2) =>
(a -> b) -> Slots m1 m2 a -> Slots m1 m2 b
<$ :: forall a b. a -> Slots m1 m2 b -> Slots m1 m2 a
$c<$ :: forall (m1 :: * -> *) (m2 :: * -> *) a b.
(Functor m1, Functor m2) =>
a -> Slots m1 m2 b -> Slots m1 m2 a
fmap :: forall a b. (a -> b) -> Slots m1 m2 a -> Slots m1 m2 b
$cfmap :: forall (m1 :: * -> *) (m2 :: * -> *) a b.
(Functor m1, Functor m2) =>
(a -> b) -> Slots m1 m2 a -> Slots m1 m2 b
Functor)

-- | Helper typeclass for defining typeclass instances for sum types.
--
-- Parameterized by a constraint @c@ that each field in each branch of the sum must satisfy, and by
-- the generic 'Rep' of the sum.
class GSum (c :: Type -> Constraint) rep where
  -- | Builds a parser for the entire generic 'Rep'.
  gToSum ::
    (Functor n, Applicative m2) =>
    -- | Branch aliases.
    Aliases rep a ->
    -- | Convert a parser for a branch's fields into a parser for the branch.
    (forall b. a -> Slots m1 m2 b -> n b) ->
    -- | Parser for when there's only one field in a branch.
    (forall v. c v => m1 v) ->
    -- | Parser for when there's more than one field in a branch.
    (forall v. c v => m2 v) ->
    Aliases rep (n (rep z))

  -- | Returns the annotation corresponding to the current branch,
  -- along with an uniform representation of the branch field's values.
  --
  -- Useful for serializing.
  gFromSum ::
    -- | Branch aliases.
    Aliases rep a ->
    (forall v. c v => v -> o) ->
    rep z ->
    (a, [o])

  -- | Decorates an 'Aliases' value with values derived from the type of each branch's fields.
  gSumEnum ::
    -- | Branch aliases.
    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 :: forall (n :: * -> *) (m2 :: * -> *) a (m1 :: * -> *) z.
(Functor n, Applicative m2) =>
Aliases (D1 x (left :+: right)) a
-> (forall b. a -> Slots m1 m2 b -> n b)
-> (forall v. c v => m1 v)
-> (forall v. c v => m2 v)
-> Aliases (D1 x (left :+: right)) (n (D1 x (left :+: right) z))
gToSum (Sum Aliases (left :+: right) a
s) forall b. a -> Slots m1 m2 b -> n b
parseBranch forall v. c v => m1 v
parseSlot1 forall v. c v => m2 v
parseSlot2 = forall (name :: * -> *) (names :: * -> *) a (y :: Meta).
Aliases (name :+: names) a -> Aliases (D1 y (name :+: names)) a
Sum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> Constraint) (rep :: * -> *) (n :: * -> *)
       (m2 :: * -> *) a (m1 :: * -> *) z.
(GSum c rep, 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))
gToSum @c Aliases (left :+: right) a
s forall b. a -> Slots m1 m2 b -> n b
parseBranch forall v. c v => m1 v
parseSlot1 forall v. c v => m2 v
parseSlot2)
  gFromSum :: forall a o z.
Aliases (D1 x (left :+: right)) a
-> (forall v. c v => v -> o) -> D1 x (left :+: right) z -> (a, [o])
gFromSum (Sum Aliases (left :+: right) a
s) forall v. c v => v -> o
renderSlot (M1 (:+:) left right z
srep) = forall (c :: * -> Constraint) (rep :: * -> *) a o z.
GSum c rep =>
Aliases rep a -> (forall v. c v => v -> o) -> rep z -> (a, [o])
gFromSum @c Aliases (left :+: right) a
s forall v. c v => v -> o
renderSlot (:+:) left right z
srep
  gSumEnum :: forall a o.
Aliases (D1 x (left :+: right)) a
-> (forall v. c v => Proxy v -> o)
-> Aliases (D1 x (left :+: right)) (a, [o])
gSumEnum (Sum Aliases (left :+: right) a
s) forall v. c v => Proxy v -> o
renderSlot = forall (name :: * -> *) (names :: * -> *) a (y :: Meta).
Aliases (name :+: names) a -> Aliases (D1 y (name :+: names)) a
Sum (forall (c :: * -> Constraint) (rep :: * -> *) a o.
GSum c rep =>
Aliases rep a
-> (forall v. c v => Proxy v -> o) -> Aliases rep (a, [o])
gSumEnum @c @_ @_ @_ Aliases (left :+: right) a
s forall v. c v => Proxy v -> o
renderSlot)

instance
  ( GSum c left,
    GSum c right
  ) =>
  GSum c (left :+: right)
  where
  gToSum :: forall (n :: * -> *) (m2 :: * -> *) a (m1 :: * -> *) z.
(Functor n, Applicative m2) =>
Aliases (left :+: right) a
-> (forall b. a -> Slots m1 m2 b -> n b)
-> (forall v. c v => m1 v)
-> (forall v. c v => m2 v)
-> Aliases (left :+: right) (n ((:+:) left right z))
gToSum (BranchTree Aliases left a
aleft Aliases right a
aright) forall b. a -> Slots m1 m2 b -> n b
parseBranch forall v. c v => m1 v
parseSlot1 forall v. c v => m2 v
parseSlot2 =
    forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :+: names) a
BranchTree (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> Constraint) (rep :: * -> *) (n :: * -> *)
       (m2 :: * -> *) a (m1 :: * -> *) z.
(GSum c rep, 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))
gToSum @c @left Aliases left a
aleft forall b. a -> Slots m1 m2 b -> n b
parseBranch forall v. c v => m1 v
parseSlot1 forall v. c v => m2 v
parseSlot2) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> Constraint) (rep :: * -> *) (n :: * -> *)
       (m2 :: * -> *) a (m1 :: * -> *) z.
(GSum c rep, 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))
gToSum @c @right Aliases right a
aright forall b. a -> Slots m1 m2 b -> n b
parseBranch forall v. c v => m1 v
parseSlot1 forall v. c v => m2 v
parseSlot2)
  gFromSum :: forall a o z.
Aliases (left :+: right) a
-> (forall v. c v => v -> o) -> (:+:) left right z -> (a, [o])
gFromSum (BranchTree Aliases left a
aleft Aliases right a
aright) forall v. c v => v -> o
renderSlot = \case
    L1 left z
rleft -> forall (c :: * -> Constraint) (rep :: * -> *) a o z.
GSum c rep =>
Aliases rep a -> (forall v. c v => v -> o) -> rep z -> (a, [o])
gFromSum @c Aliases left a
aleft forall v. c v => v -> o
renderSlot left z
rleft
    R1 right z
rright -> forall (c :: * -> Constraint) (rep :: * -> *) a o z.
GSum c rep =>
Aliases rep a -> (forall v. c v => v -> o) -> rep z -> (a, [o])
gFromSum @c Aliases right a
aright forall v. c v => v -> o
renderSlot right z
rright
  gSumEnum :: forall a o.
Aliases (left :+: right) a
-> (forall v. c v => Proxy v -> o)
-> Aliases (left :+: right) (a, [o])
gSumEnum (BranchTree Aliases left a
aleft Aliases right a
aright) forall v. c v => Proxy v -> o
renderSlot =
    forall (name :: * -> *) a (names :: * -> *).
Aliases name a -> Aliases names a -> Aliases (name :+: names) a
BranchTree (forall (c :: * -> Constraint) (rep :: * -> *) a o.
GSum c rep =>
Aliases rep a
-> (forall v. c v => Proxy v -> o) -> Aliases rep (a, [o])
gSumEnum @c Aliases left a
aleft forall v. c v => Proxy v -> o
renderSlot) (forall (c :: * -> Constraint) (rep :: * -> *) a o.
GSum c rep =>
Aliases rep a
-> (forall v. c v => Proxy v -> o) -> Aliases rep (a, [o])
gSumEnum @c Aliases right a
aright forall v. c v => Proxy v -> o
renderSlot)

instance GSum c (C1 x U1) where
  gToSum :: forall (n :: * -> *) (m2 :: * -> *) a (m1 :: * -> *) z.
(Functor n, Applicative m2) =>
Aliases (C1 x U1) a
-> (forall b. a -> Slots m1 m2 b -> n b)
-> (forall v. c v => m1 v)
-> (forall v. c v => m2 v)
-> Aliases (C1 x U1) (n (C1 x U1 z))
gToSum (Branch a
fieldName) forall b. a -> Slots m1 m2 b -> n b
parseBranch forall v. c v => m1 v
parseSlot1 forall v. c v => m2 v
parseSlot2 =
    forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch (forall b. a -> Slots m1 m2 b -> n b
parseBranch a
fieldName (forall (m1 :: * -> *) (m2 :: * -> *) v. v -> Slots m1 m2 v
ZeroSlots (forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall k (p :: k). U1 p
U1)))
  gFromSum :: forall a o z.
Aliases (C1 x U1) a
-> (forall v. c v => v -> o) -> C1 x U1 z -> (a, [o])
gFromSum (Branch a
fieldName) forall v. c v => v -> o
renderSlot C1 x U1 z
_ =
    (a
fieldName, [])
  gSumEnum :: forall a o.
Aliases (C1 x U1) a
-> (forall v. c v => Proxy v -> o) -> Aliases (C1 x U1) (a, [o])
gSumEnum (Branch a
fieldName) forall v. c v => Proxy v -> o
renderSlot =
    forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch (a
fieldName, [])

instance (c v) => GSum c (C1 x (S1 y (Rec0 v))) where
  gToSum :: forall (n :: * -> *) (m2 :: * -> *) a (m1 :: * -> *) z.
(Functor n, Applicative m2) =>
Aliases (C1 x (S1 y (Rec0 v))) a
-> (forall b. a -> Slots m1 m2 b -> n b)
-> (forall v. c v => m1 v)
-> (forall v. c v => m2 v)
-> Aliases (C1 x (S1 y (Rec0 v))) (n (C1 x (S1 y (Rec0 v)) z))
gToSum (Branch a
fieldName) forall b. a -> Slots m1 m2 b -> n b
parseBranch forall v. c v => m1 v
parseSlot1 forall v. c v => m2 v
parseSlot2 =
    forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch (forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b. a -> Slots m1 m2 b -> n b
parseBranch a
fieldName (forall (m1 :: * -> *) (m2 :: * -> *) v. m1 v -> Slots m1 m2 v
SingleSlot forall v. c v => m1 v
parseSlot1))
  gFromSum :: forall a o z.
Aliases (C1 x (S1 y (Rec0 v))) a
-> (forall v. c v => v -> o) -> C1 x (S1 y (Rec0 v)) z -> (a, [o])
gFromSum (Branch a
fieldName) forall v. c v => v -> o
renderSlot (M1 (M1 (K1 v
slots))) =
    (a
fieldName, [forall v. c v => v -> o
renderSlot v
slots])
  gSumEnum :: forall a o.
Aliases (C1 x (S1 y (Rec0 v))) a
-> (forall v. c v => Proxy v -> o)
-> Aliases (C1 x (S1 y (Rec0 v))) (a, [o])
gSumEnum (Branch a
fieldName) forall v. c v => Proxy v -> o
renderSlot =
    forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch (a
fieldName, [forall v. c v => Proxy v -> o
renderSlot (forall {k} (t :: k). Proxy t
Proxy @v)])

instance (GSumSlots c (left :*: right)) => GSum c (C1 x (left :*: right)) where
  gToSum :: forall (n :: * -> *) (m2 :: * -> *) a (m1 :: * -> *) z.
(Functor n, Applicative m2) =>
Aliases (C1 x (left :*: right)) a
-> (forall b. a -> Slots m1 m2 b -> n b)
-> (forall v. c v => m1 v)
-> (forall v. c v => m2 v)
-> Aliases (C1 x (left :*: right)) (n (C1 x (left :*: right) z))
gToSum (Branch a
fieldName) forall b. a -> Slots m1 m2 b -> n b
parseBranch forall v. c v => m1 v
parseSlot1 forall v. c v => m2 v
parseSlot2 =
    forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch (forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b. a -> Slots m1 m2 b -> n b
parseBranch a
fieldName (forall (m1 :: * -> *) (m2 :: * -> *) v. m2 v -> Slots m1 m2 v
ManySlots (forall {k} (c :: * -> Constraint) (rep :: k -> *) (m :: * -> *)
       (z :: k).
(GSumSlots c rep, Applicative m) =>
(forall v. c v => m v) -> m (rep z)
gToSumSlots @c forall v. c v => m2 v
parseSlot2)))
  gFromSum :: forall a o z.
Aliases (C1 x (left :*: right)) a
-> (forall v. c v => v -> o) -> C1 x (left :*: right) z -> (a, [o])
gFromSum (Branch a
fieldName) forall v. c v => v -> o
renderSlot (M1 (:*:) left right z
slots) =
    (a
fieldName, forall {k} (c :: * -> Constraint) (rep :: k -> *) o (z :: k).
GSumSlots c rep =>
(forall v. c v => v -> o) -> rep z -> [o]
gFromSumSlots @c forall v. c v => v -> o
renderSlot (:*:) left right z
slots)
  gSumEnum :: forall a o.
Aliases (C1 x (left :*: right)) a
-> (forall v. c v => Proxy v -> o)
-> Aliases (C1 x (left :*: right)) (a, [o])
gSumEnum (Branch a
fieldName) forall v. c v => Proxy v -> o
renderSlot =
    forall (name :: Symbol) a (names :: FixityI) (y :: Bool)
       (v :: * -> *).
KnownSymbol name =>
a -> Aliases (C1 ('MetaCons name names y) v) a
Branch (a
fieldName, forall {k} (c :: * -> Constraint) (rep :: k -> *) o.
GSumSlots c rep =>
(forall v. c v => Proxy v -> o) -> [o]
gSumEnumSlots @c @(left :*: right) forall v. c v => Proxy v -> o
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 :: forall (m :: * -> *) (z :: k).
Applicative m =>
(forall v. c v => m v) -> m (S1 y (Rec0 v) z)
gToSumSlots forall v. c v => m v
parseSlot = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. c v => m v
parseSlot
  gFromSumSlots :: forall o (z :: k).
(forall v. c v => v -> o) -> S1 y (Rec0 v) z -> [o]
gFromSumSlots forall v. c v => v -> o
renderSlot (M1 (K1 v
v)) = [forall v. c v => v -> o
renderSlot v
v]
  gSumEnumSlots :: forall o. (forall v. c v => Proxy v -> o) -> [o]
gSumEnumSlots forall v. c v => Proxy v -> o
renderSlot = [forall v. c v => Proxy v -> o
renderSlot (forall {k} (t :: k). Proxy t
Proxy @v)]

instance
  ( GSumSlots c left,
    GSumSlots c right
  ) =>
  GSumSlots c (left :*: right)
  where
  gToSumSlots :: forall (m :: * -> *) (z :: k).
Applicative m =>
(forall v. c v => m v) -> m ((:*:) left right z)
gToSumSlots forall v. c v => m v
parseSlot =
    forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (c :: * -> Constraint) (rep :: k -> *) (m :: * -> *)
       (z :: k).
(GSumSlots c rep, Applicative m) =>
(forall v. c v => m v) -> m (rep z)
gToSumSlots @c @left forall v. c v => m v
parseSlot forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {k} (c :: * -> Constraint) (rep :: k -> *) (m :: * -> *)
       (z :: k).
(GSumSlots c rep, Applicative m) =>
(forall v. c v => m v) -> m (rep z)
gToSumSlots @c @right forall v. c v => m v
parseSlot
  gFromSumSlots :: forall o (z :: k).
(forall v. c v => v -> o) -> (:*:) left right z -> [o]
gFromSumSlots forall v. c v => v -> o
renderSlot (left z
left :*: right z
right) =
    forall {k} (c :: * -> Constraint) (rep :: k -> *) o (z :: k).
GSumSlots c rep =>
(forall v. c v => v -> o) -> rep z -> [o]
gFromSumSlots @c forall v. c v => v -> o
renderSlot left z
left forall a. [a] -> [a] -> [a]
++ forall {k} (c :: * -> Constraint) (rep :: k -> *) o (z :: k).
GSumSlots c rep =>
(forall v. c v => v -> o) -> rep z -> [o]
gFromSumSlots @c forall v. c v => v -> o
renderSlot right z
right
  gSumEnumSlots :: forall o. (forall v. c v => Proxy v -> o) -> [o]
gSumEnumSlots forall v. c v => Proxy v -> o
renderSlot =
    forall {k} (c :: * -> Constraint) (rep :: k -> *) o.
GSumSlots c rep =>
(forall v. c v => Proxy v -> o) -> [o]
gSumEnumSlots @c @left forall v. c v => Proxy v -> o
renderSlot forall a. [a] -> [a] -> [a]
++ forall {k} (c :: * -> Constraint) (rep :: k -> *) o.
GSumSlots c rep =>
(forall v. c v => Proxy v -> o) -> [o]
gSumEnumSlots @c @right forall v. c v => Proxy v -> o
renderSlot


-- $setup
--
-- >>> :set -XBlockArguments
-- >>> :set -XTypeApplications
-- >>> :set -XDerivingStrategies
-- >>> :set -XDerivingVia
-- >>> :set -XDataKinds
-- >>> :set -XMultiParamTypeClasses
-- >>> :set -XDeriveGeneric
-- >>> :set -XOverloadedStrings
-- >>> import ByOtherNames
-- >>> import GHC.Generics
-- >>> import GHC.TypeLits