{-# Language DataKinds, DefaultSignatures, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,
             MultiParamTypeClasses, PolyKinds, 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 making the
--   inherited attributes a 'Generic' instance.
-- * 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(..), Revelation(..),
                                   -- * The default behaviour on generic datatypes
                                   foldedField, mappedField, passDown, bequestDefault)
where

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

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

instance {-# overlappable #-} (Bequether (Auto t) g d s, Synthesizer (Auto t) g d s) => Attribution (Auto t) g d s where
   attribution :: Auto t -> s (g d d) -> Rule (Auto t) g
attribution Auto t
t s (g d d)
l (Inherited Atts (Inherited (Auto t)) (g sem sem)
i, g sem (Synthesized (Auto t))
s) = (Atts (Synthesized (Auto t)) (g sem sem)
-> Synthesized (Auto t) (g sem sem)
forall t a. Atts (Synthesized t) a -> Synthesized t a
Synthesized (Atts (Synthesized (Auto t)) (g sem sem)
 -> Synthesized (Auto t) (g sem sem))
-> Atts (Synthesized (Auto t)) (g sem sem)
-> Synthesized (Auto t) (g sem sem)
forall a b. (a -> b) -> a -> b
$ Auto t
-> s (g d d)
-> Atts (Inherited (Auto t)) (g sem sem)
-> g sem (Synthesized (Auto t))
-> Atts (Synthesized (Auto t)) (g sem sem)
forall t (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
       (shallow :: * -> *) (sem :: * -> *).
(Synthesizer t g deep shallow, sem ~ Semantics t) =>
t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> Atts (Synthesized t) (g sem sem)
synthesis Auto t
t s (g d d)
l Atts (Inherited (Auto t)) (g sem sem)
i g sem (Synthesized (Auto t))
s, Auto t
-> s (g d d)
-> Atts (Inherited (Auto t)) (g sem sem)
-> g sem (Synthesized (Auto t))
-> g sem (Inherited (Auto t))
forall t (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
       (shallow :: * -> *) (sem :: * -> *).
(Bequether t g deep shallow, sem ~ Semantics t) =>
t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> g sem (Inherited t)
bequest Auto t
t s (g d d)
l Atts (Inherited (Auto t)) (g sem sem)
i g sem (Synthesized (Auto t))
s)

class (Transformation t, dom ~ Domain t) => Revelation t dom where
   -- | Extract the value from the transformation domain
   reveal :: t -> dom x -> x

-- | A half of the 'Attribution' class used to specify all inherited attributes.
class Bequether t g deep shallow where
   bequest     :: forall sem. sem ~ Semantics t =>
                  t                                -- ^ transformation        
               -> shallow (g deep deep)            -- ^ tree node
               -> Atts (Inherited t) (g sem sem)   -- ^ 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 Synthesizer t g deep shallow where
   synthesis   :: forall sem. sem ~ Semantics t =>
                  t                                -- ^ transformation        
               -> shallow (g deep deep)            -- ^ tre node
               -> Atts (Inherited t) (g sem sem)   -- ^ inherited attributes  
               -> g sem (Synthesized t)            -- ^ synthesized attributes
               -> Atts (Synthesized t) (g sem sem)

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

instance (Transformation t, Domain t ~ Identity) => Revelation t Identity where
   reveal :: t -> Identity x -> x
reveal t
_ (Identity x
x) = x
x

instance (Transformation t, Domain t ~ (,) a) => Revelation t ((,) a) where
   reveal :: t -> (a, x) -> x
reveal t
_ (a
_, x
x) = x
x

instance {-# overlappable #-} (sem ~ Semantics t, Domain t ~ shallow, Revelation t shallow,
                               Shallow.Functor (PassDown t sem (Atts (Inherited t) (g sem sem))) (g sem)) =>
                              Bequether t g (Semantics t) shallow where
   bequest :: t
-> shallow (g (Semantics t) (Semantics t))
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> g sem (Inherited t)
bequest = t
-> shallow (g (Semantics t) (Semantics t))
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> g sem (Inherited t)
forall k t (g :: (* -> *) -> (* -> *) -> *) (shallow :: * -> *)
       (deep :: k) (sem :: * -> *).
(sem ~ Semantics t, Domain t ~ shallow, Revelation t shallow,
 Functor
   (PassDown t sem (Atts (Inherited t) (g sem sem))) (g sem)) =>
t
-> shallow (g sem sem)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> g sem (Inherited t)
bequestDefault

instance {-# overlappable #-} (Atts (Synthesized t) (g sem sem) ~ result, Generic result, sem ~ Semantics t,
                               GenericSynthesizer t g d s (Rep result)) => Synthesizer t g d s where
   synthesis :: t
-> s (g d d)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> Atts (Synthesized t) (g sem sem)
synthesis t
t s (g d d)
node Atts (Inherited t) (g sem sem)
i g sem (Synthesized t)
s = Rep result Any -> result
forall a x. Generic a => Rep a x -> a
to (t
-> s (g d d)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> Rep result Any
forall k t (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
       (shallow :: * -> *) (result :: k -> *) (a :: k) (sem :: * -> *).
(GenericSynthesizer t g deep shallow result, sem ~ Semantics t) =>
t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> result a
genericSynthesis t
t s (g d d)
node Atts (Inherited t) (g sem sem)
i g sem (Synthesized 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{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
/= :: Folded a -> Folded a -> Bool
$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
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
min :: Folded a -> Folded a -> Folded a
$cmin :: forall a. Ord a => Folded a -> Folded a -> Folded a
max :: Folded a -> Folded a -> Folded a
$cmax :: forall a. Ord a => Folded a -> Folded a -> Folded a
>= :: 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
$c< :: forall a. Ord a => Folded a -> Folded a -> Bool
compare :: Folded a -> Folded a -> Ordering
$ccompare :: forall a. Ord a => Folded a -> Folded a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (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
showList :: [Folded a] -> ShowS
$cshowList :: forall a. Show a => [Folded a] -> ShowS
show :: Folded a -> String
$cshow :: forall a. Show a => Folded a -> String
showsPrec :: Int -> Folded a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Folded a -> ShowS
Show, b -> Folded a -> Folded a
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
stimes :: b -> Folded a -> Folded a
$cstimes :: forall a b. (Semigroup a, Integral b) => b -> Folded a -> Folded a
sconcat :: NonEmpty (Folded a) -> Folded a
$csconcat :: forall a. Semigroup a => NonEmpty (Folded a) -> Folded a
<> :: Folded a -> Folded a -> Folded a
$c<> :: forall a. Semigroup a => Folded a -> 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
mconcat :: [Folded a] -> Folded a
$cmconcat :: forall a. Monoid a => [Folded a] -> Folded a
mappend :: Folded a -> Folded a -> Folded a
$cmappend :: forall a. Monoid a => Folded a -> Folded a -> Folded a
mempty :: Folded a
$cmempty :: forall a. Monoid a => Folded a
$cp1Monoid :: forall a. Monoid a => Semigroup (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{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
/= :: 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
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
min :: 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
max :: Mapped f a -> Mapped f a -> Mapped f a
$cmax :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Mapped f a
>= :: 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
$c< :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Bool
compare :: Mapped f a -> Mapped f a -> Ordering
$ccompare :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
Mapped f a -> Mapped f a -> Ordering
$cp1Ord :: forall k (f :: k -> *) (a :: k). Ord (f a) => Eq (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
showList :: [Mapped f a] -> ShowS
$cshowList :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
[Mapped f a] -> ShowS
show :: Mapped f a -> String
$cshow :: forall k (f :: k -> *) (a :: k). Show (f a) => Mapped f a -> String
showsPrec :: Int -> Mapped f a -> ShowS
$cshowsPrec :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
Int -> Mapped f a -> ShowS
Show, b -> Mapped f a -> Mapped f a
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
stimes :: b -> 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
sconcat :: NonEmpty (Mapped f a) -> Mapped f a
$csconcat :: forall k (f :: k -> *) (a :: k).
Semigroup (f a) =>
NonEmpty (Mapped f a) -> Mapped f a
<> :: Mapped f a -> 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
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
mconcat :: [Mapped f a] -> Mapped f a
$cmconcat :: forall k (f :: k -> *) (a :: k).
Monoid (f a) =>
[Mapped f a] -> Mapped f a
mappend :: Mapped f a -> Mapped f a -> Mapped f a
$cmappend :: forall k (f :: k -> *) (a :: k).
Monoid (f a) =>
Mapped f a -> Mapped f a -> Mapped f a
mempty :: Mapped f a
$cmempty :: forall k (f :: k -> *) (a :: k). Monoid (f a) => Mapped f a
$cp1Monoid :: forall k (f :: k -> *) (a :: k).
Monoid (f a) =>
Semigroup (Mapped f a)
Monoid, a -> Mapped f b -> Mapped f a
(a -> b) -> Mapped f a -> Mapped f b
(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
<$ :: a -> Mapped f b -> Mapped f a
$c<$ :: forall (f :: * -> *) a b.
Functor f =>
a -> Mapped f b -> Mapped f a
fmap :: (a -> b) -> Mapped f a -> Mapped f b
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Mapped f a -> Mapped f b
Functor, Functor (Mapped f)
a -> Mapped f a
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)
Mapped f a -> Mapped f b -> Mapped f b
Mapped f a -> Mapped f b -> Mapped f a
Mapped f (a -> b) -> Mapped f a -> Mapped f b
(a -> b -> c) -> Mapped f a -> Mapped f b -> Mapped f c
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
<* :: Mapped f a -> Mapped f b -> Mapped f a
$c<* :: forall (f :: * -> *) a b.
Applicative f =>
Mapped f a -> Mapped f b -> Mapped f a
*> :: Mapped f a -> Mapped f b -> Mapped f b
$c*> :: forall (f :: * -> *) a b.
Applicative f =>
Mapped f a -> Mapped f b -> Mapped f b
liftA2 :: (a -> b -> c) -> Mapped f a -> Mapped f b -> Mapped f c
$cliftA2 :: forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> Mapped f a -> Mapped f b -> Mapped f c
<*> :: Mapped f (a -> b) -> Mapped f a -> Mapped f b
$c<*> :: forall (f :: * -> *) a b.
Applicative f =>
Mapped f (a -> b) -> Mapped f a -> Mapped f b
pure :: a -> Mapped f a
$cpure :: forall (f :: * -> *) a. Applicative f => a -> Mapped f a
$cp1Applicative :: forall (f :: * -> *). Applicative f => Functor (Mapped f)
Applicative, Applicative (Mapped f)
a -> Mapped f a
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)
Mapped f a -> (a -> Mapped f b) -> Mapped f b
Mapped f a -> Mapped f b -> Mapped f b
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
return :: a -> Mapped f a
$creturn :: forall (f :: * -> *) a. Monad f => a -> Mapped f a
>> :: Mapped f a -> Mapped f b -> Mapped f b
$c>> :: forall (f :: * -> *) a b.
Monad f =>
Mapped f a -> Mapped f b -> Mapped f b
>>= :: Mapped f a -> (a -> Mapped f b) -> Mapped f b
$c>>= :: forall (f :: * -> *) a b.
Monad f =>
Mapped f a -> (a -> Mapped f b) -> Mapped f b
$cp1Monad :: forall (f :: * -> *). Monad f => Applicative (Mapped f)
Monad, a -> Mapped f a -> Bool
Mapped f m -> m
Mapped f a -> [a]
Mapped f a -> Bool
Mapped f a -> Int
Mapped f a -> a
Mapped f a -> a
Mapped f a -> a
Mapped f a -> a
(a -> m) -> Mapped f a -> m
(a -> m) -> Mapped f a -> m
(a -> b -> b) -> b -> Mapped f a -> b
(a -> b -> b) -> b -> Mapped f a -> b
(b -> a -> b) -> b -> Mapped f a -> b
(b -> a -> b) -> b -> Mapped f a -> b
(a -> a -> a) -> Mapped f a -> a
(a -> a -> a) -> Mapped f a -> a
(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
product :: Mapped f a -> a
$cproduct :: forall (f :: * -> *) a. (Foldable f, Num a) => Mapped f a -> a
sum :: Mapped f a -> a
$csum :: forall (f :: * -> *) a. (Foldable f, Num a) => Mapped f a -> a
minimum :: Mapped f a -> a
$cminimum :: forall (f :: * -> *) a. (Foldable f, Ord a) => Mapped f a -> a
maximum :: Mapped f a -> a
$cmaximum :: forall (f :: * -> *) a. (Foldable f, Ord a) => Mapped f a -> a
elem :: a -> Mapped f a -> Bool
$celem :: forall (f :: * -> *) a.
(Foldable f, Eq a) =>
a -> Mapped f a -> Bool
length :: Mapped f a -> Int
$clength :: forall (f :: * -> *) a. Foldable f => Mapped f a -> Int
null :: Mapped f a -> Bool
$cnull :: forall (f :: * -> *) a. Foldable f => Mapped f a -> Bool
toList :: Mapped f a -> [a]
$ctoList :: forall (f :: * -> *) a. Foldable f => Mapped f a -> [a]
foldl1 :: (a -> a -> a) -> Mapped f a -> a
$cfoldl1 :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> Mapped f a -> a
foldr1 :: (a -> a -> a) -> Mapped f a -> a
$cfoldr1 :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> Mapped f a -> a
foldl' :: (b -> a -> b) -> b -> Mapped f a -> b
$cfoldl' :: forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> Mapped f a -> b
foldl :: (b -> a -> b) -> b -> Mapped f a -> b
$cfoldl :: forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> Mapped f a -> b
foldr' :: (a -> b -> b) -> b -> Mapped f a -> b
$cfoldr' :: forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> Mapped f a -> b
foldr :: (a -> b -> b) -> b -> Mapped f a -> b
$cfoldr :: forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> Mapped f a -> b
foldMap' :: (a -> m) -> Mapped f a -> m
$cfoldMap' :: forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> Mapped f a -> m
foldMap :: (a -> m) -> Mapped f a -> m
$cfoldMap :: forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> Mapped f a -> m
fold :: Mapped f m -> m
$cfold :: forall (f :: * -> *) m. (Foldable f, Monoid m) => Mapped f m -> m
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 a = Traversed{Traversed m f a -> m (f a)
getTraversed :: m (f a)} deriving (Traversed m f a -> Traversed m f a -> Bool
(Traversed m f a -> Traversed m f a -> Bool)
-> (Traversed m f a -> Traversed m f a -> Bool)
-> Eq (Traversed m f a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Eq (m (f a)) =>
Traversed m f a -> Traversed m f a -> Bool
/= :: Traversed m f a -> Traversed m f a -> Bool
$c/= :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Eq (m (f a)) =>
Traversed m f a -> Traversed m f a -> Bool
== :: Traversed m f a -> Traversed m f a -> Bool
$c== :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Eq (m (f a)) =>
Traversed m f a -> Traversed m f a -> Bool
Eq, Eq (Traversed m f a)
Eq (Traversed m f a)
-> (Traversed m f a -> Traversed m f a -> Ordering)
-> (Traversed m f a -> Traversed m f a -> Bool)
-> (Traversed m f a -> Traversed m f a -> Bool)
-> (Traversed m f a -> Traversed m f a -> Bool)
-> (Traversed m f a -> Traversed m f a -> Bool)
-> (Traversed m f a -> Traversed m f a -> Traversed m f a)
-> (Traversed m f a -> Traversed m f a -> Traversed m f a)
-> Ord (Traversed m f a)
Traversed m f a -> Traversed m f a -> Bool
Traversed m f a -> Traversed m f a -> Ordering
Traversed m f a -> Traversed m f a -> Traversed m 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 (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Eq (Traversed m f a)
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Traversed m f a -> Traversed m f a -> Bool
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Traversed m f a -> Traversed m f a -> Ordering
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Traversed m f a -> Traversed m f a -> Traversed m f a
min :: Traversed m f a -> Traversed m f a -> Traversed m f a
$cmin :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Traversed m f a -> Traversed m f a -> Traversed m f a
max :: Traversed m f a -> Traversed m f a -> Traversed m f a
$cmax :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Traversed m f a -> Traversed m f a -> Traversed m f a
>= :: Traversed m f a -> Traversed m f a -> Bool
$c>= :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Traversed m f a -> Traversed m f a -> Bool
> :: Traversed m f a -> Traversed m f a -> Bool
$c> :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Traversed m f a -> Traversed m f a -> Bool
<= :: Traversed m f a -> Traversed m f a -> Bool
$c<= :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Traversed m f a -> Traversed m f a -> Bool
< :: Traversed m f a -> Traversed m f a -> Bool
$c< :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Traversed m f a -> Traversed m f a -> Bool
compare :: Traversed m f a -> Traversed m f a -> Ordering
$ccompare :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Traversed m f a -> Traversed m f a -> Ordering
$cp1Ord :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Ord (m (f a)) =>
Eq (Traversed m f a)
Ord, Int -> Traversed m f a -> ShowS
[Traversed m f a] -> ShowS
Traversed m f a -> String
(Int -> Traversed m f a -> ShowS)
-> (Traversed m f a -> String)
-> ([Traversed m f a] -> ShowS)
-> Show (Traversed m f a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Show (m (f a)) =>
Int -> Traversed m f a -> ShowS
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Show (m (f a)) =>
[Traversed m f a] -> ShowS
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Show (m (f a)) =>
Traversed m f a -> String
showList :: [Traversed m f a] -> ShowS
$cshowList :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Show (m (f a)) =>
[Traversed m f a] -> ShowS
show :: Traversed m f a -> String
$cshow :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Show (m (f a)) =>
Traversed m f a -> String
showsPrec :: Int -> Traversed m f a -> ShowS
$cshowsPrec :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Show (m (f a)) =>
Int -> Traversed m f a -> ShowS
Show, b -> Traversed m f a -> Traversed m f a
NonEmpty (Traversed m f a) -> Traversed m f a
Traversed m f a -> Traversed m f a -> Traversed m f a
(Traversed m f a -> Traversed m f a -> Traversed m f a)
-> (NonEmpty (Traversed m f a) -> Traversed m f a)
-> (forall b.
    Integral b =>
    b -> Traversed m f a -> Traversed m f a)
-> Semigroup (Traversed m f a)
forall b. Integral b => b -> Traversed m f a -> Traversed m f a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Semigroup (m (f a)) =>
NonEmpty (Traversed m f a) -> Traversed m f a
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Semigroup (m (f a)) =>
Traversed m f a -> Traversed m f a -> Traversed m f a
forall k (m :: k -> *) k (f :: k -> k) (a :: k) b.
(Semigroup (m (f a)), Integral b) =>
b -> Traversed m f a -> Traversed m f a
stimes :: b -> Traversed m f a -> Traversed m f a
$cstimes :: forall k (m :: k -> *) k (f :: k -> k) (a :: k) b.
(Semigroup (m (f a)), Integral b) =>
b -> Traversed m f a -> Traversed m f a
sconcat :: NonEmpty (Traversed m f a) -> Traversed m f a
$csconcat :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Semigroup (m (f a)) =>
NonEmpty (Traversed m f a) -> Traversed m f a
<> :: Traversed m f a -> Traversed m f a -> Traversed m f a
$c<> :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Semigroup (m (f a)) =>
Traversed m f a -> Traversed m f a -> Traversed m f a
Semigroup, Semigroup (Traversed m f a)
Traversed m f a
Semigroup (Traversed m f a)
-> Traversed m f a
-> (Traversed m f a -> Traversed m f a -> Traversed m f a)
-> ([Traversed m f a] -> Traversed m f a)
-> Monoid (Traversed m f a)
[Traversed m f a] -> Traversed m f a
Traversed m f a -> Traversed m f a -> Traversed m f a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Monoid (m (f a)) =>
Semigroup (Traversed m f a)
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Monoid (m (f a)) =>
Traversed m f a
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Monoid (m (f a)) =>
[Traversed m f a] -> Traversed m f a
forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Monoid (m (f a)) =>
Traversed m f a -> Traversed m f a -> Traversed m f a
mconcat :: [Traversed m f a] -> Traversed m f a
$cmconcat :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Monoid (m (f a)) =>
[Traversed m f a] -> Traversed m f a
mappend :: Traversed m f a -> Traversed m f a -> Traversed m f a
$cmappend :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Monoid (m (f a)) =>
Traversed m f a -> Traversed m f a -> Traversed m f a
mempty :: Traversed m f a
$cmempty :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Monoid (m (f a)) =>
Traversed m f a
$cp1Monoid :: forall k (m :: k -> *) k (f :: k -> k) (a :: k).
Monoid (m (f a)) =>
Semigroup (Traversed m f a)
Monoid)

instance (Functor m, Functor f) => Functor (Traversed m f) where
   fmap :: (a -> b) -> Traversed m f a -> Traversed m f b
fmap a -> b
f (Traversed m (f a)
x) = m (f b) -> Traversed m f b
forall k k (m :: k -> *) (f :: k -> k) (a :: k).
m (f a) -> Traversed m f a
Traversed ((a -> b
f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (f a -> f b) -> m (f a) -> m (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (f a)
x)

-- * Generic transformations

-- | Internal transformation for passing down the inherited attributes.
newtype PassDown (t :: Type) (f :: * -> *) 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) 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) a -> Inherited t a
forall t a. Atts (Inherited t) a -> Inherited t a
Inherited (b -> Atts (Inherited t) a
forall sup sub. Subtype sup sub => sub -> sup
upcast b
i)

instance (Monoid a, r ~ Atts (Synthesized t) 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 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 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 a x. Generic a => a -> Rep a x
from r
Atts (Synthesized t) x
r)

instance (HasField name (Atts (Synthesized t) 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 r = Mapped f a -> f a
forall k (f :: k -> *) (a :: k). Mapped f a -> f a
getMapped (Atts (Synthesized t) a -> Mapped f a
forall k (x :: k) r a. HasField x r a => r -> a
getField @name Atts (Synthesized t) a
r)

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

-- * Generic classes

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

-- | The 'Generic' mirror of 'SynthesizedField'
class GenericSynthesizedField (name :: Symbol) result t g deep shallow where
   genericSynthesizedField  :: forall a sem. sem ~ Semantics t =>
                               Proxy name
                            -> t
                            -> shallow (g deep deep)
                            -> Atts (Inherited t) (g sem sem)
                            -> 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 :: Proxy name -> (:*:) x y x -> a
getMonoidalField Proxy name
name (x x
x :*: y x
y) = 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 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 :: 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 :: Proxy name -> M1 i ('MetaSel ('Just name) su ss ds) f x -> a
getMonoidalField Proxy name
name (M1 f x
x) = 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 :: 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 :: 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 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 :: 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 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 :: Proxy name -> f x -> a
getMonoidalField Proxy name
name f x
_ = a
forall a. Monoid a => a
mempty

instance FoundField a f => FoundField a (M1 i j f) where
     getFoundField :: M1 i j f x -> a
getFoundField (M1 f x
f) = 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 :: K1 i a x -> a
getFoundField (K1 a
a) = a
a

instance (GenericSynthesizer t g deep shallow x, GenericSynthesizer t g deep shallow y) =>
         GenericSynthesizer t g deep shallow (x :*: y) where
   genericSynthesis :: t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> (:*:) x y a
genericSynthesis t
t shallow (g deep deep)
node Atts (Inherited t) (g sem sem)
i g sem (Synthesized t)
s = t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> x a
forall k t (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
       (shallow :: * -> *) (result :: k -> *) (a :: k) (sem :: * -> *).
(GenericSynthesizer t g deep shallow result, sem ~ Semantics t) =>
t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> result a
genericSynthesis t
t shallow (g deep deep)
node Atts (Inherited t) (g sem sem)
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
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> y a
forall k t (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
       (shallow :: * -> *) (result :: k -> *) (a :: k) (sem :: * -> *).
(GenericSynthesizer t g deep shallow result, sem ~ Semantics t) =>
t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> result a
genericSynthesis t
t shallow (g deep deep)
node Atts (Inherited t) (g sem sem)
i g sem (Synthesized t)
s

instance {-# overlappable #-} GenericSynthesizer t g deep shallow f =>
                              GenericSynthesizer t g deep shallow (M1 i meta f) where
   genericSynthesis :: t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> M1 i meta f a
genericSynthesis t
t shallow (g deep deep)
node Atts (Inherited t) (g sem sem)
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
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> f a
forall k t (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
       (shallow :: * -> *) (result :: k -> *) (a :: k) (sem :: * -> *).
(GenericSynthesizer t g deep shallow result, sem ~ Semantics t) =>
t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> result a
genericSynthesis t
t shallow (g deep deep)
node Atts (Inherited t) (g sem sem)
i g sem (Synthesized t)
s)

instance {-# overlaps #-} GenericSynthesizedField name f t g deep shallow =>
                          GenericSynthesizer t g deep shallow (M1 i ('MetaSel ('Just name) su ss ds) f) where
   genericSynthesis :: t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> M1 i ('MetaSel ('Just name) su ss ds) f a
genericSynthesis t
t shallow (g deep deep)
node Atts (Inherited t) (g sem sem)
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
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> f a
forall k (name :: Symbol) (result :: k -> *) t
       (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
       (shallow :: * -> *) (a :: k) (sem :: * -> *).
(GenericSynthesizedField name result t g deep shallow,
 sem ~ Semantics t) =>
Proxy name
-> t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> result a
genericSynthesizedField (Proxy name
forall k (t :: k). Proxy t
Proxy :: Proxy name) t
t shallow (g deep deep)
node Atts (Inherited t) (g sem sem)
i g sem (Synthesized t)
s)

instance SynthesizedField name a t g deep shallow => GenericSynthesizedField name (K1 i a) t g deep shallow where
   genericSynthesizedField :: Proxy name
-> t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> K1 i a a
genericSynthesizedField Proxy name
name t
t shallow (g deep deep)
node Atts (Inherited t) (g sem sem)
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
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> a
forall (name :: Symbol) result t (g :: (* -> *) -> (* -> *) -> *)
       (deep :: * -> *) (shallow :: * -> *) (sem :: * -> *).
(SynthesizedField name result t g deep shallow,
 sem ~ Semantics t) =>
Proxy name
-> t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> result
synthesizedField Proxy name
name t
t shallow (g deep deep)
node Atts (Inherited t) (g sem sem)
i g sem (Synthesized t)
s)

instance  {-# overlappable #-} (Monoid a, Shallow.Foldable (Accumulator t name a) (g (Semantics t))) =>
                               SynthesizedField name (Folded a) t g deep shallow where
   synthesizedField :: Proxy name
-> t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> Folded a
synthesizedField Proxy name
name t
t shallow (g deep deep)
_ Atts (Inherited t) (g sem sem)
_ 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 #-} (Functor f, Shallow.Functor (Replicator t f name) (g f),
                                Atts (Synthesized t) (g (Semantics t) (Semantics t)) ~ Atts (Synthesized t) (g f f)) =>
                               SynthesizedField name (Mapped f (g f f)) t g deep f where
   synthesizedField :: Proxy name
-> t
-> f (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> Mapped f (g f f)
synthesizedField Proxy name
name t
t f (g deep deep)
local Atts (Inherited t) (g sem sem)
_ 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),
 Atts (Synthesized t) (g sem sem) ~ Atts (Synthesized t) (g f 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 deep deep) -> f (g f f)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f (g deep deep)
local)

instance  {-# overlappable #-} (Traversable f, Applicative m, Shallow.Traversable (Traverser t m f name) (g f),
                                Atts (Synthesized t) (g (Semantics t) (Semantics t)) ~ Atts (Synthesized t) (g f f)) =>
                               SynthesizedField name (Traversed m f (g f f)) t g deep f where
   synthesizedField :: Proxy name
-> t
-> f (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> Traversed m f (g f f)
synthesizedField Proxy name
name t
t f (g deep deep)
local Atts (Inherited t) (g sem sem)
_ g sem (Synthesized t)
s = m (f (g f f)) -> Traversed m f (g f f)
forall k k (m :: k -> *) (f :: k -> k) (a :: k).
m (f a) -> Traversed m f a
Traversed ((g deep deep -> m (g f f)) -> f (g deep deep) -> m (f (g f f))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (m (g f f) -> g deep deep -> m (g f f)
forall a b. a -> b -> a
const (m (g f f) -> g deep deep -> m (g f f))
-> m (g f f) -> g deep deep -> 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),
 Atts (Synthesized t) (g sem sem) ~ Atts (Synthesized t) (g f 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 deep deep)
local)

-- | The default 'bequest' method definition relies on generics to automatically pass down all same-named inherited
-- attributes.
bequestDefault :: forall t g shallow deep sem.
                  (sem ~ Semantics t, Domain t ~ shallow, Revelation t shallow,
                   Shallow.Functor (PassDown t sem (Atts (Inherited t) (g sem sem))) (g sem))
               => t -> shallow (g sem sem) -> Atts (Inherited t) (g sem sem) -> g sem (Synthesized t)
               -> g sem (Inherited t)
bequestDefault :: t
-> shallow (g sem sem)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> g sem (Inherited t)
bequestDefault t
t shallow (g sem sem)
local Atts (Inherited t) (g sem sem)
inheritance g sem (Synthesized t)
synthesized = Atts (Inherited t) (g (Semantics t) (Semantics t))
-> g sem sem -> g sem (Inherited t)
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 (Inherited t) (g sem sem)
Atts (Inherited t) (g (Semantics t) (Semantics t))
inheritance (t -> shallow (g sem sem) -> g sem sem
forall t (dom :: * -> *) x. Revelation t dom => t -> dom x -> x
reveal t
t shallow (g sem sem)
local)

-- | 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)
passDown :: atts -> g deep shallow -> g deep (Inherited t)
passDown atts
inheritance g deep shallow
local = atts -> PassDown t shallow atts
forall t (f :: * -> *) a. a -> PassDown t f a
PassDown 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 :: 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 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),
                   Atts (Synthesized t) (g sem sem) ~ Atts (Synthesized t) (g f f)) =>
                  Proxy name -> t -> g sem (Synthesized t) -> g f f
mappedField :: 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),
                      Atts (Synthesized t) (g sem sem) ~ Atts (Synthesized t) (g f f)) =>
                     Proxy name -> t -> g sem (Synthesized t) -> m (g f f)
traversedField :: 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)
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))