{-# Language DataKinds, DefaultSignatures, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,
             InstanceSigs, MultiParamTypeClasses, PolyKinds, QuantifiedConstraints,
             RankNTypes, ScopedTypeVariables, StandaloneDeriving,
             TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}

-- | This module can be used to scrap the boilerplate attribute declarations. In particular:
--
-- * If an 'attribution' rule always merely copies the inherited attributes to the children's inherited attributes of
--   the same name, the rule can be left out by wrapping the transformation into an 'Auto' constructor and deriving
--   the 'Generic' instance of the inherited attributes.
-- * A synthesized attribute whose value is a fold of all same-named attributes of the children can be wrapped in the
--   'Folded' constructor and calculated automatically.
-- * A synthesized attribute that is a copy of the current node but with every child taken from the same-named
--   synthesized child attribute can be wrapped in the 'Mapped' constructor and calculated automatically.
-- * If the attribute additionally carries an applicative effect, the 'Mapped' wrapper can be replaced by 'Traversed'.

module Transformation.AG.Generics (-- * Type wrappers for automatic attribute inference
                                   Auto(..), Folded(..), Mapped(..), Traversed(..),
                                   -- * Type classes replacing 'Attribution'
                                   Bequether(..), Synthesizer(..), SynthesizedField(..),
                                   -- * The default behaviour on generic datatypes
                                   foldedField, mappedField, passDown, bequestDefault)
where

import Data.Functor.Compose (Compose(..))
import Data.Functor.Const (Const(..))
import Data.Kind (Type)
import Data.Generics.Product.Subtype (Subtype(upcast))
import Data.Proxy (Proxy(..))
import GHC.Generics
import GHC.Records
import GHC.TypeLits (Symbol, ErrorMessage (Text), TypeError)
import Unsafe.Coerce (unsafeCoerce)
import qualified Rank2
import Transformation (Transformation, Codomain)
import Transformation.AG
import qualified Transformation
import qualified Transformation.Shallow as Shallow

-- | Transformation wrapper that allows automatic inference of attribute rules.
newtype Auto t = Auto t

type instance Atts (Inherited (Auto t)) x = Atts (Inherited t) x
type instance Atts (Synthesized (Auto t)) x = Atts (Synthesized t) x

instance Attribution t => Attribution (Auto t) where
   type Origin (Auto t) = Origin t
   unwrap :: forall x. Auto t -> Origin (Auto t) x -> x
unwrap (Auto t
t) = t -> Origin t x -> x
forall x. t -> Origin t x -> x
forall t x. Attribution t => t -> Origin t x -> x
unwrap t
t

instance {-# overlappable #-} (Attribution t, Bequether (Auto t) g, Synthesizer (Auto t) g) =>
                              Auto t `At` g where
   attribution :: forall (sem :: * -> *).
Traversable (g sem) =>
Auto t
-> Origin (Auto t) (g sem sem)
-> (Inherited (Auto t) (g sem sem), g sem (Synthesized (Auto t)))
-> (Synthesized (Auto t) (g sem sem), g sem (Inherited (Auto t)))
attribution Auto t
t Origin (Auto t) (g sem sem)
l (Inherited Atts (Inherited (Auto t)) (NodeConstructor (g sem sem))
i, g sem (Synthesized (Auto t))
s) = (Atts (Synthesized (Auto t)) (NodeConstructor (g sem sem))
-> Synthesized (Auto t) (g sem sem)
forall t a.
Atts (Synthesized t) (NodeConstructor a) -> Synthesized t a
Synthesized (Atts (Synthesized (Auto t)) (NodeConstructor (g sem sem))
 -> Synthesized (Auto t) (g sem sem))
-> Atts (Synthesized (Auto t)) (NodeConstructor (g sem sem))
-> Synthesized (Auto t) (g sem sem)
forall a b. (a -> b) -> a -> b
$ Auto t
-> Origin (Auto t) (g sem sem)
-> Atts (Inherited (Auto t)) g
-> g sem (Synthesized (Auto t))
-> Atts (Synthesized (Auto t)) g
forall t (g :: (* -> *) -> (* -> *) -> *) (sem :: * -> *).
Synthesizer t g =>
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> Atts (Synthesized t) g
forall (sem :: * -> *).
Auto t
-> Origin (Auto t) (g sem sem)
-> Atts (Inherited (Auto t)) g
-> g sem (Synthesized (Auto t))
-> Atts (Synthesized (Auto t)) g
synthesis Auto t
t Origin (Auto t) (g sem sem)
l Atts (Inherited (Auto t)) g
Atts (Inherited (Auto t)) (NodeConstructor (g sem sem))
i g sem (Synthesized (Auto t))
s, Auto t
-> Origin (Auto t) (g sem sem)
-> Atts (Inherited (Auto t)) g
-> g sem (Synthesized (Auto t))
-> g sem (Inherited (Auto t))
forall t (g :: (* -> *) -> (* -> *) -> *) (sem :: * -> *).
Bequether t g =>
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> g sem (Inherited t)
forall (sem :: * -> *).
Auto t
-> Origin (Auto t) (g sem sem)
-> Atts (Inherited (Auto t)) g
-> g sem (Synthesized (Auto t))
-> g sem (Inherited (Auto t))
bequest Auto t
t Origin (Auto t) (g sem sem)
l Atts (Inherited (Auto t)) g
Atts (Inherited (Auto t)) (NodeConstructor (g sem sem))
i g sem (Synthesized (Auto t))
s)

-- | A half of the 'Attribution' class used to specify all inherited attributes.
class Bequether t g where
   bequest     :: forall sem.
                  t                                -- ^ transformation
               -> Origin t (g sem sem)             -- ^ tree node
               -> Atts (Inherited t) g             -- ^ inherited attributes
               -> g sem (Synthesized t)            -- ^ synthesized attributes
               -> g sem (Inherited t)

-- | A half of the 'Attribution' class used to specify all synthesized attributes.
class Attribution t => Synthesizer t g where
   synthesis   :: forall sem.
                  t                                -- ^ transformation
               -> Origin t (g sem sem)             -- ^ tree node
               -> Atts (Inherited t) g             -- ^ inherited attributes
               -> g sem (Synthesized t)            -- ^ synthesized attributes
               -> Atts (Synthesized t) g

-- | Class for specifying a single named attribute
class Attribution t => SynthesizedField (name :: Symbol) result t g where
   synthesizedField  :: forall sem.
                        Proxy name                      -- ^ attribute name
                     -> t                               -- ^ transformation
                     -> Origin t (g sem sem)            -- ^ tree node
                     -> Atts (Inherited t) g            -- ^ inherited attributes
                     -> g sem (Synthesized t)           -- ^ synthesized attributes
                     -> result

instance {-# overlappable #-} (Attribution t, a ~ Atts (Inherited (Auto t)) g,
                               forall deep. Shallow.Functor (PassDown (Auto t) deep a) (g deep)) =>
                              Bequether (Auto t) g where
   bequest :: forall (sem :: * -> *).
Auto t
-> Origin (Auto t) (g sem sem)
-> Atts (Inherited (Auto t)) g
-> g sem (Synthesized (Auto t))
-> g sem (Inherited (Auto t))
bequest = Auto t
-> Origin (Auto t) (g sem sem)
-> Atts (Inherited (Auto t)) g
-> g sem (Synthesized (Auto t))
-> g sem (Inherited (Auto t))
forall t (g :: (* -> *) -> (* -> *) -> *) (sem :: * -> *).
(Attribution t,
 Functor (PassDown t sem (Atts (Inherited t) g)) (g sem)) =>
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> g sem (Inherited t)
bequestDefault

instance {-# overlappable #-} (Attribution t, Atts (Synthesized (Auto t)) g ~ result, Generic result,
                               GenericSynthesizer (Auto t) g (Rep result)) => Synthesizer (Auto t) g where
   synthesis :: forall (sem :: * -> *).
Auto t
-> Origin (Auto t) (g sem sem)
-> Atts (Inherited (Auto t)) g
-> g sem (Synthesized (Auto t))
-> Atts (Synthesized (Auto t)) g
synthesis Auto t
t Origin (Auto t) (g sem sem)
node Atts (Inherited (Auto t)) g
i g sem (Synthesized (Auto t))
s = Rep result Any -> result
forall a x. Generic a => Rep a x -> a
forall x. Rep result x -> result
to (Auto t
-> Origin (Auto t) (g sem sem)
-> Atts (Inherited (Auto t)) g
-> g sem (Synthesized (Auto t))
-> Rep result Any
forall {k} t (g :: (* -> *) -> (* -> *) -> *) (result :: k -> *)
       (a :: k) (sem :: * -> *).
GenericSynthesizer t g result =>
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> result a
forall a (sem :: * -> *).
Auto t
-> Origin (Auto t) (g sem sem)
-> Atts (Inherited (Auto t)) g
-> g sem (Synthesized (Auto t))
-> Rep result a
genericSynthesis Auto t
t Origin (Auto t) (g sem sem)
node Atts (Inherited (Auto t)) g
i g sem (Synthesized (Auto t))
s)

-- | Wrapper for a field that should be automatically synthesized by folding together all child nodes' synthesized
-- attributes of the same name.
newtype Folded a = Folded{forall a. Folded a -> a
getFolded :: a} deriving (Folded a -> Folded a -> Bool
(Folded a -> Folded a -> Bool)
-> (Folded a -> Folded a -> Bool) -> Eq (Folded a)
forall a. Eq a => Folded a -> Folded a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Folded a -> Folded a -> Bool
== :: Folded a -> Folded a -> Bool
$c/= :: forall a. Eq a => Folded a -> Folded a -> Bool
/= :: Folded a -> Folded a -> Bool
Eq, Eq (Folded a)
Eq (Folded a) =>
(Folded a -> Folded a -> Ordering)
-> (Folded a -> Folded a -> Bool)
-> (Folded a -> Folded a -> Bool)
-> (Folded a -> Folded a -> Bool)
-> (Folded a -> Folded a -> Bool)
-> (Folded a -> Folded a -> Folded a)
-> (Folded a -> Folded a -> Folded a)
-> Ord (Folded a)
Folded a -> Folded a -> Bool
Folded a -> Folded a -> Ordering
Folded a -> Folded a -> Folded a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Folded a)
forall a. Ord a => Folded a -> Folded a -> Bool
forall a. Ord a => Folded a -> Folded a -> Ordering
forall a. Ord a => Folded a -> Folded a -> Folded a
$ccompare :: forall a. Ord a => Folded a -> Folded a -> Ordering
compare :: Folded a -> Folded a -> Ordering
$c< :: forall a. Ord a => Folded a -> Folded a -> Bool
< :: Folded a -> Folded a -> Bool
$c<= :: forall a. Ord a => Folded a -> Folded a -> Bool
<= :: Folded a -> Folded a -> Bool
$c> :: forall a. Ord a => Folded a -> Folded a -> Bool
> :: Folded a -> Folded a -> Bool
$c>= :: forall a. Ord a => Folded a -> Folded a -> Bool
>= :: Folded a -> Folded a -> Bool
$cmax :: forall a. Ord a => Folded a -> Folded a -> Folded a
max :: Folded a -> Folded a -> Folded a
$cmin :: forall a. Ord a => Folded a -> Folded a -> Folded a
min :: Folded a -> Folded a -> Folded a
Ord, Int -> Folded a -> ShowS
[Folded a] -> ShowS
Folded a -> String
(Int -> Folded a -> ShowS)
-> (Folded a -> String) -> ([Folded a] -> ShowS) -> Show (Folded a)
forall a. Show a => Int -> Folded a -> ShowS
forall a. Show a => [Folded a] -> ShowS
forall a. Show a => Folded a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Folded a -> ShowS
showsPrec :: Int -> Folded a -> ShowS
$cshow :: forall a. Show a => Folded a -> String
show :: Folded a -> String
$cshowList :: forall a. Show a => [Folded a] -> ShowS
showList :: [Folded a] -> ShowS
Show, NonEmpty (Folded a) -> Folded a
Folded a -> Folded a -> Folded a
(Folded a -> Folded a -> Folded a)
-> (NonEmpty (Folded a) -> Folded a)
-> (forall b. Integral b => b -> Folded a -> Folded a)
-> Semigroup (Folded a)
forall b. Integral b => b -> Folded a -> Folded a
forall a. Semigroup a => NonEmpty (Folded a) -> Folded a
forall a. Semigroup a => Folded a -> Folded a -> Folded a
forall a b. (Semigroup a, Integral b) => b -> Folded a -> Folded a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: forall a. Semigroup a => Folded a -> Folded a -> Folded a
<> :: Folded a -> Folded a -> Folded a
$csconcat :: forall a. Semigroup a => NonEmpty (Folded a) -> Folded a
sconcat :: NonEmpty (Folded a) -> Folded a
$cstimes :: forall a b. (Semigroup a, Integral b) => b -> Folded a -> Folded a
stimes :: forall b. Integral b => b -> Folded a -> Folded a
Semigroup, Semigroup (Folded a)
Folded a
Semigroup (Folded a) =>
Folded a
-> (Folded a -> Folded a -> Folded a)
-> ([Folded a] -> Folded a)
-> Monoid (Folded a)
[Folded a] -> Folded a
Folded a -> Folded a -> Folded a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (Folded a)
forall a. Monoid a => Folded a
forall a. Monoid a => [Folded a] -> Folded a
forall a. Monoid a => Folded a -> Folded a -> Folded a
$cmempty :: forall a. Monoid a => Folded a
mempty :: Folded a
$cmappend :: forall a. Monoid a => Folded a -> Folded a -> Folded a
mappend :: Folded a -> Folded a -> Folded a
$cmconcat :: forall a. Monoid a => [Folded a] -> Folded a
mconcat :: [Folded a] -> Folded a
Monoid)
-- | Wrapper for a field that should be automatically synthesized by replacing every child node by its synthesized
-- attribute of the same name.
newtype Mapped f a = Mapped{forall {k} (f :: k -> *) (a :: k). Mapped f a -> f a
getMapped :: f a}
                   deriving (Mapped f a -> Mapped f a -> Bool
(Mapped f a -> Mapped f a -> Bool)
-> (Mapped f a -> Mapped f a -> Bool) -> Eq (Mapped f a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (f :: k -> *) (a :: k).
Eq (f a) =>
Mapped f a -> Mapped f a -> Bool
$c== :: forall k (f :: k -> *) (a :: k).
Eq (f a) =>
Mapped f a -> Mapped f a -> Bool
== :: Mapped f a -> Mapped f a -> Bool
$c/= :: forall k (f :: k -> *) (a :: k).
Eq (f a) =>
Mapped f a -> Mapped f a -> Bool
/= :: Mapped f a -> Mapped f a -> Bool
Eq, Eq (Mapped f a)
Eq (Mapped f a) =>
(Mapped f a -> Mapped f a -> Ordering)
-> (Mapped f a -> Mapped f a -> Bool)
-> (Mapped f a -> Mapped f a -> Bool)
-> (Mapped f a -> Mapped f a -> Bool)
-> (Mapped f a -> Mapped f a -> Bool)
-> (Mapped f a -> Mapped f a -> Mapped f a)
-> (Mapped f a -> Mapped f a -> Mapped f a)
-> Ord (Mapped f a)
Mapped f a -> Mapped f a -> Bool
Mapped f a -> Mapped f a -> Ordering
Mapped f a -> Mapped f a -> Mapped f a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall k (f :: k -> *) (a :: k). Ord (f a) => Eq (Mapped f a)
forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Bool
forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Ordering
forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Mapped f a
$ccompare :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Ordering
compare :: Mapped f a -> Mapped f a -> Ordering
$c< :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Bool
< :: Mapped f a -> Mapped f a -> Bool
$c<= :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Bool
<= :: Mapped f a -> Mapped f a -> Bool
$c> :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Bool
> :: Mapped f a -> Mapped f a -> Bool
$c>= :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Bool
>= :: Mapped f a -> Mapped f a -> Bool
$cmax :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Mapped f a
max :: Mapped f a -> Mapped f a -> Mapped f a
$cmin :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Mapped f a
min :: Mapped f a -> Mapped f a -> Mapped f a
Ord, Int -> Mapped f a -> ShowS
[Mapped f a] -> ShowS
Mapped f a -> String
(Int -> Mapped f a -> ShowS)
-> (Mapped f a -> String)
-> ([Mapped f a] -> ShowS)
-> Show (Mapped f a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (f :: k -> *) (a :: k).
Show (f a) =>
Int -> Mapped f a -> ShowS
forall k (f :: k -> *) (a :: k).
Show (f a) =>
[Mapped f a] -> ShowS
forall k (f :: k -> *) (a :: k). Show (f a) => Mapped f a -> String
$cshowsPrec :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
Int -> Mapped f a -> ShowS
showsPrec :: Int -> Mapped f a -> ShowS
$cshow :: forall k (f :: k -> *) (a :: k). Show (f a) => Mapped f a -> String
show :: Mapped f a -> String
$cshowList :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
[Mapped f a] -> ShowS
showList :: [Mapped f a] -> ShowS
Show, NonEmpty (Mapped f a) -> Mapped f a
Mapped f a -> Mapped f a -> Mapped f a
(Mapped f a -> Mapped f a -> Mapped f a)
-> (NonEmpty (Mapped f a) -> Mapped f a)
-> (forall b. Integral b => b -> Mapped f a -> Mapped f a)
-> Semigroup (Mapped f a)
forall b. Integral b => b -> Mapped f a -> Mapped f a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall k (f :: k -> *) (a :: k).
Semigroup (f a) =>
NonEmpty (Mapped f a) -> Mapped f a
forall k (f :: k -> *) (a :: k).
Semigroup (f a) =>
Mapped f a -> Mapped f a -> Mapped f a
forall k (f :: k -> *) (a :: k) b.
(Semigroup (f a), Integral b) =>
b -> Mapped f a -> Mapped f a
$c<> :: forall k (f :: k -> *) (a :: k).
Semigroup (f a) =>
Mapped f a -> Mapped f a -> Mapped f a
<> :: Mapped f a -> Mapped f a -> Mapped f a
$csconcat :: forall k (f :: k -> *) (a :: k).
Semigroup (f a) =>
NonEmpty (Mapped f a) -> Mapped f a
sconcat :: NonEmpty (Mapped f a) -> Mapped f a
$cstimes :: forall k (f :: k -> *) (a :: k) b.
(Semigroup (f a), Integral b) =>
b -> Mapped f a -> Mapped f a
stimes :: forall b. Integral b => b -> Mapped f a -> Mapped f a
Semigroup, Semigroup (Mapped f a)
Mapped f a
Semigroup (Mapped f a) =>
Mapped f a
-> (Mapped f a -> Mapped f a -> Mapped f a)
-> ([Mapped f a] -> Mapped f a)
-> Monoid (Mapped f a)
[Mapped f a] -> Mapped f a
Mapped f a -> Mapped f a -> Mapped f a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall k (f :: k -> *) (a :: k).
Monoid (f a) =>
Semigroup (Mapped f a)
forall k (f :: k -> *) (a :: k). Monoid (f a) => Mapped f a
forall k (f :: k -> *) (a :: k).
Monoid (f a) =>
[Mapped f a] -> Mapped f a
forall k (f :: k -> *) (a :: k).
Monoid (f a) =>
Mapped f a -> Mapped f a -> Mapped f a
$cmempty :: forall k (f :: k -> *) (a :: k). Monoid (f a) => Mapped f a
mempty :: Mapped f a
$cmappend :: forall k (f :: k -> *) (a :: k).
Monoid (f a) =>
Mapped f a -> Mapped f a -> Mapped f a
mappend :: Mapped f a -> Mapped f a -> Mapped f a
$cmconcat :: forall k (f :: k -> *) (a :: k).
Monoid (f a) =>
[Mapped f a] -> Mapped f a
mconcat :: [Mapped f a] -> Mapped f a
Monoid, (forall a b. (a -> b) -> Mapped f a -> Mapped f b)
-> (forall a b. a -> Mapped f b -> Mapped f a)
-> Functor (Mapped f)
forall a b. a -> Mapped f b -> Mapped f a
forall a b. (a -> b) -> Mapped f a -> Mapped f b
forall (f :: * -> *) a b.
Functor f =>
a -> Mapped f b -> Mapped f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Mapped f a -> Mapped f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Mapped f a -> Mapped f b
fmap :: forall a b. (a -> b) -> Mapped f a -> Mapped f b
$c<$ :: forall (f :: * -> *) a b.
Functor f =>
a -> Mapped f b -> Mapped f a
<$ :: forall a b. a -> Mapped f b -> Mapped f a
Functor, Functor (Mapped f)
Functor (Mapped f) =>
(forall a. a -> Mapped f a)
-> (forall a b. Mapped f (a -> b) -> Mapped f a -> Mapped f b)
-> (forall a b c.
    (a -> b -> c) -> Mapped f a -> Mapped f b -> Mapped f c)
-> (forall a b. Mapped f a -> Mapped f b -> Mapped f b)
-> (forall a b. Mapped f a -> Mapped f b -> Mapped f a)
-> Applicative (Mapped f)
forall a. a -> Mapped f a
forall a b. Mapped f a -> Mapped f b -> Mapped f a
forall a b. Mapped f a -> Mapped f b -> Mapped f b
forall a b. Mapped f (a -> b) -> Mapped f a -> Mapped f b
forall a b c.
(a -> b -> c) -> Mapped f a -> Mapped f b -> Mapped f c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (f :: * -> *). Applicative f => Functor (Mapped f)
forall (f :: * -> *) a. Applicative f => a -> Mapped f a
forall (f :: * -> *) a b.
Applicative f =>
Mapped f a -> Mapped f b -> Mapped f a
forall (f :: * -> *) a b.
Applicative f =>
Mapped f a -> Mapped f b -> Mapped f b
forall (f :: * -> *) a b.
Applicative f =>
Mapped f (a -> b) -> Mapped f a -> Mapped f b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> Mapped f a -> Mapped f b -> Mapped f c
$cpure :: forall (f :: * -> *) a. Applicative f => a -> Mapped f a
pure :: forall a. a -> Mapped f a
$c<*> :: forall (f :: * -> *) a b.
Applicative f =>
Mapped f (a -> b) -> Mapped f a -> Mapped f b
<*> :: forall a b. Mapped f (a -> b) -> Mapped f a -> Mapped f b
$cliftA2 :: forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> Mapped f a -> Mapped f b -> Mapped f c
liftA2 :: forall a b c.
(a -> b -> c) -> Mapped f a -> Mapped f b -> Mapped f c
$c*> :: forall (f :: * -> *) a b.
Applicative f =>
Mapped f a -> Mapped f b -> Mapped f b
*> :: forall a b. Mapped f a -> Mapped f b -> Mapped f b
$c<* :: forall (f :: * -> *) a b.
Applicative f =>
Mapped f a -> Mapped f b -> Mapped f a
<* :: forall a b. Mapped f a -> Mapped f b -> Mapped f a
Applicative, Applicative (Mapped f)
Applicative (Mapped f) =>
(forall a b. Mapped f a -> (a -> Mapped f b) -> Mapped f b)
-> (forall a b. Mapped f a -> Mapped f b -> Mapped f b)
-> (forall a. a -> Mapped f a)
-> Monad (Mapped f)
forall a. a -> Mapped f a
forall a b. Mapped f a -> Mapped f b -> Mapped f b
forall a b. Mapped f a -> (a -> Mapped f b) -> Mapped f b
forall (f :: * -> *). Monad f => Applicative (Mapped f)
forall (f :: * -> *) a. Monad f => a -> Mapped f a
forall (f :: * -> *) a b.
Monad f =>
Mapped f a -> Mapped f b -> Mapped f b
forall (f :: * -> *) a b.
Monad f =>
Mapped f a -> (a -> Mapped f b) -> Mapped f b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (f :: * -> *) a b.
Monad f =>
Mapped f a -> (a -> Mapped f b) -> Mapped f b
>>= :: forall a b. Mapped f a -> (a -> Mapped f b) -> Mapped f b
$c>> :: forall (f :: * -> *) a b.
Monad f =>
Mapped f a -> Mapped f b -> Mapped f b
>> :: forall a b. Mapped f a -> Mapped f b -> Mapped f b
$creturn :: forall (f :: * -> *) a. Monad f => a -> Mapped f a
return :: forall a. a -> Mapped f a
Monad, (forall m. Monoid m => Mapped f m -> m)
-> (forall m a. Monoid m => (a -> m) -> Mapped f a -> m)
-> (forall m a. Monoid m => (a -> m) -> Mapped f a -> m)
-> (forall a b. (a -> b -> b) -> b -> Mapped f a -> b)
-> (forall a b. (a -> b -> b) -> b -> Mapped f a -> b)
-> (forall b a. (b -> a -> b) -> b -> Mapped f a -> b)
-> (forall b a. (b -> a -> b) -> b -> Mapped f a -> b)
-> (forall a. (a -> a -> a) -> Mapped f a -> a)
-> (forall a. (a -> a -> a) -> Mapped f a -> a)
-> (forall a. Mapped f a -> [a])
-> (forall a. Mapped f a -> Bool)
-> (forall a. Mapped f a -> Int)
-> (forall a. Eq a => a -> Mapped f a -> Bool)
-> (forall a. Ord a => Mapped f a -> a)
-> (forall a. Ord a => Mapped f a -> a)
-> (forall a. Num a => Mapped f a -> a)
-> (forall a. Num a => Mapped f a -> a)
-> Foldable (Mapped f)
forall a. Eq a => a -> Mapped f a -> Bool
forall a. Num a => Mapped f a -> a
forall a. Ord a => Mapped f a -> a
forall m. Monoid m => Mapped f m -> m
forall a. Mapped f a -> Bool
forall a. Mapped f a -> Int
forall a. Mapped f a -> [a]
forall a. (a -> a -> a) -> Mapped f a -> a
forall m a. Monoid m => (a -> m) -> Mapped f a -> m
forall b a. (b -> a -> b) -> b -> Mapped f a -> b
forall a b. (a -> b -> b) -> b -> Mapped f a -> b
forall (f :: * -> *) a.
(Foldable f, Eq a) =>
a -> Mapped f a -> Bool
forall (f :: * -> *) a. (Foldable f, Num a) => Mapped f a -> a
forall (f :: * -> *) a. (Foldable f, Ord a) => Mapped f a -> a
forall (f :: * -> *) m. (Foldable f, Monoid m) => Mapped f m -> m
forall (f :: * -> *) a. Foldable f => Mapped f a -> Bool
forall (f :: * -> *) a. Foldable f => Mapped f a -> Int
forall (f :: * -> *) a. Foldable f => Mapped f a -> [a]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> Mapped f a -> a
forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> Mapped f a -> m
forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> Mapped f a -> b
forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> Mapped f a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall (f :: * -> *) m. (Foldable f, Monoid m) => Mapped f m -> m
fold :: forall m. Monoid m => Mapped f m -> m
$cfoldMap :: forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> Mapped f a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Mapped f a -> m
$cfoldMap' :: forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> Mapped f a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Mapped f a -> m
$cfoldr :: forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> Mapped f a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Mapped f a -> b
$cfoldr' :: forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> Mapped f a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Mapped f a -> b
$cfoldl :: forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> Mapped f a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Mapped f a -> b
$cfoldl' :: forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> Mapped f a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Mapped f a -> b
$cfoldr1 :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> Mapped f a -> a
foldr1 :: forall a. (a -> a -> a) -> Mapped f a -> a
$cfoldl1 :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> Mapped f a -> a
foldl1 :: forall a. (a -> a -> a) -> Mapped f a -> a
$ctoList :: forall (f :: * -> *) a. Foldable f => Mapped f a -> [a]
toList :: forall a. Mapped f a -> [a]
$cnull :: forall (f :: * -> *) a. Foldable f => Mapped f a -> Bool
null :: forall a. Mapped f a -> Bool
$clength :: forall (f :: * -> *) a. Foldable f => Mapped f a -> Int
length :: forall a. Mapped f a -> Int
$celem :: forall (f :: * -> *) a.
(Foldable f, Eq a) =>
a -> Mapped f a -> Bool
elem :: forall a. Eq a => a -> Mapped f a -> Bool
$cmaximum :: forall (f :: * -> *) a. (Foldable f, Ord a) => Mapped f a -> a
maximum :: forall a. Ord a => Mapped f a -> a
$cminimum :: forall (f :: * -> *) a. (Foldable f, Ord a) => Mapped f a -> a
minimum :: forall a. Ord a => Mapped f a -> a
$csum :: forall (f :: * -> *) a. (Foldable f, Num a) => Mapped f a -> a
sum :: forall a. Num a => Mapped f a -> a
$cproduct :: forall (f :: * -> *) a. (Foldable f, Num a) => Mapped f a -> a
product :: forall a. Num a => Mapped f a -> a
Foldable)

-- | Wrapper for a field that should be automatically synthesized by traversing over all child nodes and applying each
-- node's synthesized attribute of the same name.
newtype Traversed m f g = Traversed{forall {k} {k} (m :: k -> *) (f :: k -> k)
       (g :: (k -> k) -> (k -> k) -> k).
Traversed m f g -> m (f (g f f))
getTraversed :: m (f (g f f))} --deriving (Eq, Ord, Show, Semigroup, Monoid)

-- * Generic transformations

-- | Internal transformation for passing down the inherited attributes.
newtype PassDown (t :: Type) (f :: Type -> Type) a = PassDown a
-- | Internal transformation for accumulating the 'Folded' attributes.
data Accumulator (t :: Type) (name :: Symbol) (a :: Type) = Accumulator
-- | Internal transformation for replicating the 'Mapped' attributes.
data Replicator (t :: Type) (f :: Type -> Type) (name :: Symbol) = Replicator
-- | Internal transformation for traversing the 'Traversed' attributes.
data Traverser (t :: Type) (m :: Type -> Type) (f :: Type -> Type) (name :: Symbol) = Traverser

instance Transformation (PassDown t f a) where
  type Domain (PassDown t f a) = f
  type Codomain (PassDown t f a) = Inherited t

instance Transformation (Accumulator t name a) where
  type Domain (Accumulator t name a) = Synthesized t
  type Codomain (Accumulator t name a) = Const (Folded a)

instance Transformation (Replicator t f name) where
  type Domain (Replicator t f name) = Synthesized t
  type Codomain (Replicator t f name) = f

instance Transformation (Traverser t m f name) where
  type Domain (Traverser t m f name) = Synthesized t
  type Codomain (Traverser t m f name) = Compose m f

instance Subtype (Atts (Inherited t) (NodeConstructor a)) b => Transformation.At (PassDown t f b) a where
   $ :: PassDown t f b
-> Domain (PassDown t f b) a -> Codomain (PassDown t f b) a
($) (PassDown b
i) Domain (PassDown t f b) a
_ = Atts (Inherited t) (NodeConstructor a) -> Inherited t a
forall t a. Atts (Inherited t) (NodeConstructor a) -> Inherited t a
Inherited (b -> Atts (Inherited t) (NodeConstructor a)
forall sup sub. Subtype sup sub => sub -> sup
upcast b
i)

instance (Monoid a, r ~ Atts (Synthesized t) (NodeConstructor x), Generic r,
          MayHaveMonoidalField name (Folded a) (Rep r)) =>
         Transformation.At (Accumulator t name a) x where
   Accumulator t name a
_ $ :: Accumulator t name a
-> Domain (Accumulator t name a) x
-> Codomain (Accumulator t name a) x
$ Synthesized Atts (Synthesized t) (NodeConstructor x)
r = Folded a -> Const (Folded a) x
forall {k} a (b :: k). a -> Const a b
Const (Proxy name -> Rep r Any -> Folded a
forall x. Proxy name -> Rep r x -> Folded a
forall {k} (name :: Symbol) a (f :: k -> *) (x :: k).
MayHaveMonoidalField name a f =>
Proxy name -> f x -> a
getMonoidalField (Proxy name
forall {k} (t :: k). Proxy t
Proxy :: Proxy name) (Rep r Any -> Folded a) -> Rep r Any -> Folded a
forall a b. (a -> b) -> a -> b
$ r -> Rep r Any
forall x. r -> Rep r x
forall a x. Generic a => a -> Rep a x
from r
Atts (Synthesized t) (NodeConstructor x)
r)

instance (HasField name (Atts (Synthesized t) (NodeConstructor a)) (Mapped f a)) => Transformation.At (Replicator t f name) a where
   Replicator t f name
_ $ :: Replicator t f name
-> Domain (Replicator t f name) a
-> Codomain (Replicator t f name) a
$ Synthesized Atts (Synthesized t) (NodeConstructor a)
r = Mapped f a -> f a
forall {k} (f :: k -> *) (a :: k). Mapped f a -> f a
getMapped (forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @name Atts (Synthesized t) (NodeConstructor a)
r)

instance (HasField name (Atts (Synthesized t) g) (Traversed m f g)) =>
         Transformation.At (Traverser t m f name) (g f f) where
   Traverser t m f name
_ $ :: Traverser t m f name
-> Domain (Traverser t m f name) (g f f)
-> Codomain (Traverser t m f name) (g f f)
$ Synthesized Atts (Synthesized t) (NodeConstructor (g f f))
r = m (f (g f f)) -> Compose m f (g f f)
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Traversed m f g -> m (f (g f f))
forall {k} {k} (m :: k -> *) (f :: k -> k)
       (g :: (k -> k) -> (k -> k) -> k).
Traversed m f g -> m (f (g f f))
getTraversed (Traversed m f g -> m (f (g f f)))
-> Traversed m f g -> m (f (g f f))
forall a b. (a -> b) -> a -> b
$ forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @name Atts (Synthesized t) g
Atts (Synthesized t) (NodeConstructor (g f f))
r)

-- * Generic classes

-- | The 'Generic' mirror of 'Synthesizer'
class GenericSynthesizer t g result where
   genericSynthesis  :: forall a sem.
                        t
                     -> Origin t (g sem sem)
                     -> Atts (Inherited t) g
                     -> g sem (Synthesized t)
                     -> result a

-- | The 'Generic' mirror of 'SynthesizedField'
class Attribution t => GenericSynthesizedField (name :: Symbol) result t g where
   genericSynthesizedField  :: forall a sem.
                               Proxy name
                            -> t
                            -> Origin t (g sem sem)
                            -> Atts (Inherited t) g
                            -> g sem (Synthesized t)
                            -> result a

-- | Used for accumulating the 'Folded' fields 
class MayHaveMonoidalField (name :: Symbol) a f where
   getMonoidalField :: Proxy name -> f x -> a
class FoundField a f where
   getFoundField :: f x -> a

instance {-# overlaps #-} (MayHaveMonoidalField name a x, MayHaveMonoidalField name a y, Semigroup a) =>
         MayHaveMonoidalField name a (x :*: y) where
   getMonoidalField :: forall (x :: k). Proxy name -> (:*:) x y x -> a
getMonoidalField Proxy name
name (x x
x :*: y x
y) = Proxy name -> x x -> a
forall (x :: k). Proxy name -> x x -> a
forall {k} (name :: Symbol) a (f :: k -> *) (x :: k).
MayHaveMonoidalField name a f =>
Proxy name -> f x -> a
getMonoidalField Proxy name
name x x
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Proxy name -> y x -> a
forall (x :: k). Proxy name -> y x -> a
forall {k} (name :: Symbol) a (f :: k -> *) (x :: k).
MayHaveMonoidalField name a f =>
Proxy name -> f x -> a
getMonoidalField Proxy name
name y x
y

instance {-# overlaps #-} TypeError ('Text "Cannot get a single field value from a sum type") =>
         MayHaveMonoidalField name a (x :+: y) where
   getMonoidalField :: forall (x :: k). Proxy name -> (:+:) x y x -> a
getMonoidalField Proxy name
_ (:+:) x y x
_ = String -> a
forall a. HasCallStack => String -> a
error String
"getMonoidalField on sum type"

instance {-# overlaps #-} FoundField a f => MayHaveMonoidalField name a (M1 i ('MetaSel ('Just name) su ss ds) f) where
   getMonoidalField :: forall (x :: k).
Proxy name -> M1 i ('MetaSel ('Just name) su ss ds) f x -> a
getMonoidalField Proxy name
_ (M1 f x
x) = f x -> a
forall (x :: k). f x -> a
forall {k} a (f :: k -> *) (x :: k). FoundField a f => f x -> a
getFoundField f x
x

instance {-# overlaps #-} Monoid a => MayHaveMonoidalField name a (M1 i ('MetaSel 'Nothing su ss ds) f) where
   getMonoidalField :: forall (x :: k).
Proxy name -> M1 i ('MetaSel 'Nothing su ss ds) f x -> a
getMonoidalField Proxy name
_ M1 i ('MetaSel 'Nothing su ss ds) f x
_ = a
forall a. Monoid a => a
mempty

instance {-# overlaps #-} MayHaveMonoidalField name a f => MayHaveMonoidalField name a (M1 i ('MetaData n m p nt) f) where
   getMonoidalField :: forall (x :: k). Proxy name -> M1 i ('MetaData n m p nt) f x -> a
getMonoidalField Proxy name
name (M1 f x
x) = Proxy name -> f x -> a
forall (x :: k). Proxy name -> f x -> a
forall {k} (name :: Symbol) a (f :: k -> *) (x :: k).
MayHaveMonoidalField name a f =>
Proxy name -> f x -> a
getMonoidalField Proxy name
name f x
x

instance {-# overlaps #-} MayHaveMonoidalField name a f => MayHaveMonoidalField name a (M1 i ('MetaCons n fi s) f) where
   getMonoidalField :: forall (x :: k). Proxy name -> M1 i ('MetaCons n fi s) f x -> a
getMonoidalField Proxy name
name (M1 f x
x) = Proxy name -> f x -> a
forall (x :: k). Proxy name -> f x -> a
forall {k} (name :: Symbol) a (f :: k -> *) (x :: k).
MayHaveMonoidalField name a f =>
Proxy name -> f x -> a
getMonoidalField Proxy name
name f x
x

instance {-# overlappable #-} Monoid a => MayHaveMonoidalField name a f where
   getMonoidalField :: forall (x :: k). Proxy name -> f x -> a
getMonoidalField Proxy name
_ f x
_ = a
forall a. Monoid a => a
mempty

instance FoundField a f => FoundField a (M1 i j f) where
     getFoundField :: forall (x :: k). M1 i j f x -> a
getFoundField (M1 f x
f) = f x -> a
forall (x :: k). f x -> a
forall {k} a (f :: k -> *) (x :: k). FoundField a f => f x -> a
getFoundField f x
f

instance FoundField a (K1 i a) where
     getFoundField :: forall (x :: k). K1 i a x -> a
getFoundField (K1 a
a) = a
a

instance (GenericSynthesizer t g x, GenericSynthesizer t g y) => GenericSynthesizer t g (x :*: y) where
   genericSynthesis :: forall (a :: k) (sem :: * -> *).
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> (:*:) x y a
genericSynthesis t
t Origin t (g sem sem)
node Atts (Inherited t) g
i g sem (Synthesized t)
s = t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> x a
forall (a :: k) (sem :: * -> *).
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> x a
forall {k} t (g :: (* -> *) -> (* -> *) -> *) (result :: k -> *)
       (a :: k) (sem :: * -> *).
GenericSynthesizer t g result =>
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> result a
genericSynthesis t
t Origin t (g sem sem)
node Atts (Inherited t) g
i g sem (Synthesized t)
s x a -> y a -> (:*:) x y a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> y a
forall (a :: k) (sem :: * -> *).
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> y a
forall {k} t (g :: (* -> *) -> (* -> *) -> *) (result :: k -> *)
       (a :: k) (sem :: * -> *).
GenericSynthesizer t g result =>
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> result a
genericSynthesis t
t Origin t (g sem sem)
node Atts (Inherited t) g
i g sem (Synthesized t)
s

instance {-# overlappable #-} GenericSynthesizer t g f =>
                              GenericSynthesizer t g (M1 i meta f) where
   genericSynthesis :: forall (a :: k) (sem :: * -> *).
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> M1 i meta f a
genericSynthesis t
t Origin t (g sem sem)
node Atts (Inherited t) g
i g sem (Synthesized t)
s = f a -> M1 i meta f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> f a
forall (a :: k) (sem :: * -> *).
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> f a
forall {k} t (g :: (* -> *) -> (* -> *) -> *) (result :: k -> *)
       (a :: k) (sem :: * -> *).
GenericSynthesizer t g result =>
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> result a
genericSynthesis t
t Origin t (g sem sem)
node Atts (Inherited t) g
i g sem (Synthesized t)
s)

instance {-# overlaps #-} GenericSynthesizedField name f t g =>
                          GenericSynthesizer t g (M1 i ('MetaSel ('Just name) su ss ds) f) where
   genericSynthesis :: forall (a :: k) (sem :: * -> *).
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> M1 i ('MetaSel ('Just name) su ss ds) f a
genericSynthesis t
t Origin t (g sem sem)
node Atts (Inherited t) g
i g sem (Synthesized t)
s = f a -> M1 i ('MetaSel ('Just name) su ss ds) f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy name
-> t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> f a
forall (a :: k) (sem :: * -> *).
Proxy name
-> t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> f a
forall {k} (name :: Symbol) (result :: k -> *) t
       (g :: (* -> *) -> (* -> *) -> *) (a :: k) (sem :: * -> *).
GenericSynthesizedField name result t g =>
Proxy name
-> t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> result a
genericSynthesizedField (Proxy name
forall {k} (t :: k). Proxy t
Proxy :: Proxy name) t
t Origin t (g sem sem)
node Atts (Inherited t) g
i g sem (Synthesized t)
s)

instance SynthesizedField name a t g => GenericSynthesizedField name (K1 i a) t g where
   genericSynthesizedField :: forall (a :: k) (sem :: * -> *).
Proxy name
-> t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> K1 i a a
genericSynthesizedField Proxy name
name t
t Origin t (g sem sem)
node Atts (Inherited t) g
i g sem (Synthesized t)
s = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (Proxy name
-> t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> a
forall (name :: Symbol) result t (g :: (* -> *) -> (* -> *) -> *)
       (sem :: * -> *).
SynthesizedField name result t g =>
Proxy name
-> t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> result
forall (sem :: * -> *).
Proxy name
-> t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> a
synthesizedField Proxy name
name t
t Origin t (g sem sem)
node Atts (Inherited t) g
i g sem (Synthesized t)
s)

instance  {-# overlappable #-} (Attribution t, Monoid a,
                                forall sem. Shallow.Foldable (Accumulator t name a) (g sem)) =>
                               SynthesizedField name (Folded a) t g where
   synthesizedField :: forall (sem :: * -> *).
Proxy name
-> t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> Folded a
synthesizedField Proxy name
name t
t Origin t (g sem sem)
_ Atts (Inherited t) g
_ g sem (Synthesized t)
s = Proxy name -> t -> g sem (Synthesized t) -> Folded a
forall {k} (name :: Symbol) t (g :: k -> (* -> *) -> *) a
       (sem :: k).
(Monoid a, Foldable (Accumulator t name a) (g sem)) =>
Proxy name -> t -> g sem (Synthesized t) -> Folded a
foldedField Proxy name
name t
t g sem (Synthesized t)
s

instance  {-# overlappable #-} (Attribution t, Origin t ~ f, Functor f,
                                Shallow.Functor (Replicator t f name) (g f)) =>
                               SynthesizedField name (Mapped f (g f f)) t g where
   synthesizedField :: forall (sem :: * -> *).
Proxy name
-> t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> Mapped f (g f f)
synthesizedField Proxy name
name t
t Origin t (g sem sem)
local Atts (Inherited t) g
_ g sem (Synthesized t)
s = f (g f f) -> Mapped f (g f f)
forall {k} (f :: k -> *) (a :: k). f a -> Mapped f a
Mapped (Proxy name -> t -> g sem (Synthesized t) -> g f f
forall (name :: Symbol) t (g :: (* -> *) -> (* -> *) -> *)
       (f :: * -> *) (sem :: * -> *).
Functor (Replicator t f name) (g f) =>
Proxy name -> t -> g sem (Synthesized t) -> g f f
mappedField Proxy name
name t
t g sem (Synthesized t)
s g f f -> f (g sem sem) -> f (g f f)
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f (g sem sem)
Origin t (g sem sem)
local)

instance  {-# overlappable #-} (Attribution t, Origin t ~ f, Traversable f, Applicative m,
                                Shallow.Traversable (Traverser t m f name) (g f)) =>
                               SynthesizedField name (Traversed m f g) t g where
   synthesizedField :: forall (sem :: * -> *).
Proxy name
-> t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> Traversed m f g
synthesizedField Proxy name
name t
t Origin t (g sem sem)
local Atts (Inherited t) g
_ g sem (Synthesized t)
s = m (f (g f f)) -> Traversed m f g
forall {k} {k} (m :: k -> *) (f :: k -> k)
       (g :: (k -> k) -> (k -> k) -> k).
m (f (g f f)) -> Traversed m f g
Traversed ((g sem sem -> m (g f f)) -> f (g sem sem) -> m (f (g f f))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse (m (g f f) -> g sem sem -> m (g f f)
forall a b. a -> b -> a
const (m (g f f) -> g sem sem -> m (g f f))
-> m (g f f) -> g sem sem -> m (g f f)
forall a b. (a -> b) -> a -> b
$ Proxy name -> t -> g sem (Synthesized t) -> m (g f f)
forall (name :: Symbol) t (g :: (* -> *) -> (* -> *) -> *)
       (m :: * -> *) (f :: * -> *) (sem :: * -> *).
Traversable (Traverser t m f name) (g f) =>
Proxy name -> t -> g sem (Synthesized t) -> m (g f f)
traversedField Proxy name
name t
t g sem (Synthesized t)
s) f (g sem sem)
Origin t (g sem sem)
local)

-- | The default 'bequest' method definition relies on generics to automatically pass down all same-named inherited
-- attributes.
bequestDefault :: forall t g sem.
                  (Attribution t, Shallow.Functor (PassDown t sem (Atts (Inherited t) g)) (g sem))
               => t -> Origin t (g sem sem) -> Atts (Inherited t) g -> g sem (Synthesized t)
               -> g sem (Inherited t)
bequestDefault :: forall t (g :: (* -> *) -> (* -> *) -> *) (sem :: * -> *).
(Attribution t,
 Functor (PassDown t sem (Atts (Inherited t) g)) (g sem)) =>
t
-> Origin t (g sem sem)
-> Atts (Inherited t) g
-> g sem (Synthesized t)
-> g sem (Inherited t)
bequestDefault t
t Origin t (g sem sem)
local Atts (Inherited t) g
inheritance g sem (Synthesized t)
_synthesized = forall {k} t (g :: k -> (* -> *) -> *) (shallow :: * -> *)
       (deep :: k) atts.
Functor (PassDown t shallow atts) (g deep) =>
atts -> g deep shallow -> g deep (Inherited t)
forall t (g :: (* -> *) -> (* -> *) -> *) (shallow :: * -> *)
       (deep :: * -> *) atts.
Functor (PassDown t shallow atts) (g deep) =>
atts -> g deep shallow -> g deep (Inherited t)
passDown @t Atts (Inherited t) g
inheritance (t -> Origin t (g sem sem) -> g sem sem
forall x. t -> Origin t x -> x
forall t x. Attribution t => t -> Origin t x -> x
unwrap t
t Origin t (g sem sem)
local :: g sem sem)

-- | Pass down the given record of inherited fields to child nodes.
passDown :: forall t g shallow deep atts. (Shallow.Functor (PassDown t shallow atts) (g deep)) =>
            atts -> g deep shallow -> g deep (Inherited t)
-- unsafeCoerce is safe here because Inherited doesn't refer to deep functor so the latter is a phantom
passDown :: forall {k} t (g :: k -> (* -> *) -> *) (shallow :: * -> *)
       (deep :: k) atts.
Functor (PassDown t shallow atts) (g deep) =>
atts -> g deep shallow -> g deep (Inherited t)
passDown atts
inheritance g deep shallow
local = g deep (Inherited t) -> g deep (Inherited t)
forall {k} (g :: (k -> *) -> *) (p :: k -> *) (q :: k -> *).
(Functor g, forall (a :: k). Coercible (p a) (q a)) =>
g p -> g q
forall (p :: * -> *) (q :: * -> *).
(forall a. Coercible (p a) (q a)) =>
g deep p -> g deep q
Rank2.coerce (forall t (f :: * -> *) a. a -> PassDown t f a
PassDown @t atts
inheritance PassDown t shallow atts
-> g deep (Domain (PassDown t shallow atts))
-> g deep (Codomain (PassDown t shallow atts))
forall t (g :: (* -> *) -> *).
Functor t g =>
t -> g (Domain t) -> g (Codomain t)
Shallow.<$> g deep shallow
g deep (Domain (PassDown t shallow atts))
local)

-- | The default 'synthesizedField' method definition for 'Folded' fields.
foldedField :: forall name t g a sem. (Monoid a, Shallow.Foldable (Accumulator t name a) (g sem)) =>
               Proxy name -> t -> g sem (Synthesized t) -> Folded a
foldedField :: forall {k} (name :: Symbol) t (g :: k -> (* -> *) -> *) a
       (sem :: k).
(Monoid a, Foldable (Accumulator t name a) (g sem)) =>
Proxy name -> t -> g sem (Synthesized t) -> Folded a
foldedField Proxy name
_name t
_t g sem (Synthesized t)
s = Accumulator t name a
-> g sem (Domain (Accumulator t name a)) -> Folded a
forall m.
(Codomain (Accumulator t name a) ~ Const m, Monoid m) =>
Accumulator t name a -> g sem (Domain (Accumulator t name a)) -> m
forall t (g :: (* -> *) -> *) m.
(Foldable t g, Codomain t ~ Const m, Monoid m) =>
t -> g (Domain t) -> m
Shallow.foldMap (Accumulator t name a
forall t (name :: Symbol) a. Accumulator t name a
Accumulator :: Accumulator t name a) g sem (Domain (Accumulator t name a))
g sem (Synthesized t)
s

-- | The default 'synthesizedField' method definition for 'Mapped' fields.
mappedField :: forall name t g f sem.
                  (Shallow.Functor (Replicator t f name) (g f)) =>
                  Proxy name -> t -> g sem (Synthesized t) -> g f f
-- unsafeCoerce is safe here because Synthesized doesn't refer to deep functor so the latter is a phantom
mappedField :: forall (name :: Symbol) t (g :: (* -> *) -> (* -> *) -> *)
       (f :: * -> *) (sem :: * -> *).
Functor (Replicator t f name) (g f) =>
Proxy name -> t -> g sem (Synthesized t) -> g f f
mappedField Proxy name
_name t
_t g sem (Synthesized t)
s = (Replicator t f name
forall t (f :: * -> *) (name :: Symbol). Replicator t f name
Replicator :: Replicator t f name) Replicator t f name
-> g f (Domain (Replicator t f name))
-> g f (Codomain (Replicator t f name))
forall t (g :: (* -> *) -> *).
Functor t g =>
t -> g (Domain t) -> g (Codomain t)
Shallow.<$> (g sem (Synthesized t) -> g f (Synthesized t)
forall a b. a -> b
unsafeCoerce g sem (Synthesized t)
s :: g f (Synthesized t))

-- | The default 'synthesizedField' method definition for 'Traversed' fields.
traversedField :: forall name t g m f sem.
                     (Shallow.Traversable (Traverser t m f name) (g f)) =>
                     Proxy name -> t -> g sem (Synthesized t) -> m (g f f)
-- unsafeCoerce is safe here because Synthesized doesn't refer to deep functor so the latter is a phantom
traversedField :: forall (name :: Symbol) t (g :: (* -> *) -> (* -> *) -> *)
       (m :: * -> *) (f :: * -> *) (sem :: * -> *).
Traversable (Traverser t m f name) (g f) =>
Proxy name -> t -> g sem (Synthesized t) -> m (g f f)
traversedField Proxy name
_name t
_t g sem (Synthesized t)
s = Traverser t m f name
-> g f (Domain (Traverser t m f name)) -> m (g f f)
forall t (g :: (* -> *) -> *) (m :: * -> *) (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> g (Domain t) -> m (g f)
forall (m :: * -> *) (f :: * -> *).
(Codomain (Traverser t m f name) ~ Compose m f) =>
Traverser t m f name
-> g f (Domain (Traverser t m f name)) -> m (g f f)
Shallow.traverse (Traverser t m f name
forall t (m :: * -> *) (f :: * -> *) (name :: Symbol).
Traverser t m f name
Traverser :: Traverser t m f name) (g sem (Synthesized t) -> g f (Synthesized t)
forall a b. a -> b
unsafeCoerce g sem (Synthesized t)
s :: g f (Synthesized t))