{-# Language DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes,
             ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}

-- | A special case of an attribute grammar where every node has only a single inherited and a single synthesized
-- attribute of the same monoidal type. The synthesized attributes of child nodes are all 'mconcat`ted together.

module Transformation.AG.Dimorphic where

import Data.Data (Data, Typeable)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Const (Const(..))
import Data.Kind (Type)
import Data.Semigroup (Semigroup(..))
import qualified Rank2
import Transformation (Transformation, Domain, Codomain, At)
import qualified Transformation
import qualified Transformation.Deep as Deep
import qualified Transformation.Full as Full

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

-- | Transformation wrapper that allows automatic inference of attribute rules and preservation of the attribute with
-- the original nodes.
newtype Keep t = Keep t

data Atts a b = Atts{
   forall a b. Atts a b -> a
inh :: a,
   forall a b. Atts a b -> b
syn :: b}
   deriving (Atts a b -> DataType
Atts a b -> Constr
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall {a} {b}. (Data a, Data b) => Typeable (Atts a b)
forall a b. (Data a, Data b) => Atts a b -> DataType
forall a b. (Data a, Data b) => Atts a b -> Constr
forall a b.
(Data a, Data b) =>
(forall b. Data b => b -> b) -> Atts a b -> Atts a b
forall a b u.
(Data a, Data b) =>
Int -> (forall d. Data d => d -> u) -> Atts a b -> u
forall a b u.
(Data a, Data b) =>
(forall d. Data d => d -> u) -> Atts a b -> [u]
forall a b r r'.
(Data a, Data b) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r
forall a b r r'.
(Data a, Data b) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b)
forall a b (m :: * -> *).
(Data a, Data b, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b)
forall a b (c :: * -> *).
(Data a, Data b) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a b)
forall a b (c :: * -> *).
(Data a, Data b) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Atts a b -> c (Atts a b)
forall a b (t :: * -> *) (c :: * -> *).
(Data a, Data b, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Atts a b))
forall a b (t :: * -> * -> *) (c :: * -> *).
(Data a, Data b, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Atts a b))
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a b)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Atts a b -> c (Atts a b)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Atts a b))
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b)
$cgmapMo :: forall a b (m :: * -> *).
(Data a, Data b, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b)
$cgmapMp :: forall a b (m :: * -> *).
(Data a, Data b, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b)
$cgmapM :: forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b)
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Atts a b -> u
$cgmapQi :: forall a b u.
(Data a, Data b) =>
Int -> (forall d. Data d => d -> u) -> Atts a b -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Atts a b -> [u]
$cgmapQ :: forall a b u.
(Data a, Data b) =>
(forall d. Data d => d -> u) -> Atts a b -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r
$cgmapQr :: forall a b r r'.
(Data a, Data b) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r
$cgmapQl :: forall a b r r'.
(Data a, Data b) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r
gmapT :: (forall b. Data b => b -> b) -> Atts a b -> Atts a b
$cgmapT :: forall a b.
(Data a, Data b) =>
(forall b. Data b => b -> b) -> Atts a b -> Atts a b
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Atts a b))
$cdataCast2 :: forall a b (t :: * -> * -> *) (c :: * -> *).
(Data a, Data b, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Atts a b))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Atts a b))
$cdataCast1 :: forall a b (t :: * -> *) (c :: * -> *).
(Data a, Data b, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Atts a b))
dataTypeOf :: Atts a b -> DataType
$cdataTypeOf :: forall a b. (Data a, Data b) => Atts a b -> DataType
toConstr :: Atts a b -> Constr
$ctoConstr :: forall a b. (Data a, Data b) => Atts a b -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a b)
$cgunfold :: forall a b (c :: * -> *).
(Data a, Data b) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a b)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Atts a b -> c (Atts a b)
$cgfoldl :: forall a b (c :: * -> *).
(Data a, Data b) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Atts a b -> c (Atts a b)
Data, Typeable, Int -> Atts a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> Atts a b -> ShowS
forall a b. (Show a, Show b) => [Atts a b] -> ShowS
forall a b. (Show a, Show b) => Atts a b -> String
showList :: [Atts a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [Atts a b] -> ShowS
show :: Atts a b -> String
$cshow :: forall a b. (Show a, Show b) => Atts a b -> String
showsPrec :: Int -> Atts a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> Atts a b -> ShowS
Show)

instance (Semigroup a, Semigroup b) => Semigroup (Atts a b) where
   Atts a
i1 b
s1 <> :: Atts a b -> Atts a b -> Atts a b
<> Atts a
i2 b
s2 = forall a b. a -> b -> Atts a b
Atts (a
i1 forall a. Semigroup a => a -> a -> a
<> a
i2) (b
s1 forall a. Semigroup a => a -> a -> a
<> b
s2)

instance (Monoid a, Monoid b) => Monoid (Atts a b) where
   mappend :: Atts a b -> Atts a b -> Atts a b
mappend = forall a. Semigroup a => a -> a -> a
(<>)
   mempty :: Atts a b
mempty = forall a b. a -> b -> Atts a b
Atts forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

-- | A node's 'Semantics' maps its inherited attribute to its synthesized attribute.
type Semantics a b = Const (a -> b)

-- | A node's 'PreservingSemantics' maps its inherited attribute to its synthesized attribute.
type PreservingSemantics f a b = Compose ((->) a) (Compose ((,) (Atts a b)) f)

-- | An attribution rule maps a node's inherited attribute and its child nodes' synthesized attribute to the node's
-- synthesized attribute and the children nodes' inherited attributes.
type Rule a b = Atts a b -> Atts a b

instance {-# overlappable #-} Attribution t a b g deep shallow where
   attribution :: t -> shallow (g deep deep) -> Rule a b
attribution = forall a b. a -> b -> a
const (forall a b. a -> b -> a
const forall a. a -> a
id)

instance {-# overlappable #-} (Transformation (Auto t), p ~ Domain (Auto t), q ~ Codomain (Auto t), q ~ Semantics a b,
                               Rank2.Foldable (g q), Monoid a, Monoid b, Foldable p, Attribution (Auto t) a b g q p) =>
                              (Auto t) `At` g (Semantics a b) (Semantics a b) where
   $ :: Auto t
-> Domain (Auto t) (g (Semantics a b) (Semantics a b))
-> Codomain (Auto t) (g (Semantics a b) (Semantics a b))
($) = forall (p :: * -> *) t (q :: * -> *) a b x
       (g :: (* -> *) -> (* -> *) -> *).
(p ~ Domain t, q ~ Semantics a b, x ~ g q q, Foldable (g q),
 Attribution t a b g q p, Monoid a, Monoid b) =>
(forall y. p y -> y) -> t -> p x -> q x
applyDefault (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"Missing node")
   {-# INLINE ($) #-}

instance {-# overlappable #-} (Transformation (Keep t), p ~ Domain (Keep t), q ~ Codomain (Keep t),
                               q ~ PreservingSemantics p a b, Rank2.Foldable (g q), Monoid a, Monoid b,
                               Foldable p, Functor p, Attribution (Keep t) a b g q p) =>
                              (Keep t) `At` g (PreservingSemantics p a b) (PreservingSemantics p a b) where
   $ :: Keep t
-> Domain
     (Keep t)
     (g (PreservingSemantics p a b) (PreservingSemantics p a b))
-> Codomain
     (Keep t)
     (g (PreservingSemantics p a b) (PreservingSemantics p a b))
($) = forall (p :: * -> *) t (q :: * -> *) a b x
       (g :: (* -> *) -> (* -> *) -> *).
(p ~ Domain t, q ~ PreservingSemantics p a b, x ~ g q q,
 Attribution t a b g q p, Foldable (g q), Monoid a, Monoid b,
 Foldable p, Functor p) =>
t -> p x -> q x
applyDefaultWithAttributes
   {-# INLINE ($) #-}

instance (Transformation (Auto t), Domain (Auto t) ~ f, Functor f, Codomain (Auto t) ~ Semantics a b,
          Deep.Functor (Auto t) g, Auto t `At` g (Semantics a b) (Semantics a b)) =>
         Full.Functor (Auto t) g where
   <$> :: Auto t
-> Domain (Auto t) (g (Domain (Auto t)) (Domain (Auto t)))
-> Codomain (Auto t) (g (Codomain (Auto t)) (Codomain (Auto t)))
(<$>) = forall t (g :: (* -> *) -> (* -> *) -> *).
(Functor t g, At t (g (Codomain t) (Codomain t)),
 Functor (Domain t)) =>
t
-> Domain t (g (Domain t) (Domain t))
-> Codomain t (g (Codomain t) (Codomain t))
Full.mapUpDefault

instance (Transformation (Keep t), Domain (Keep t) ~ f, Functor f, Codomain (Keep t) ~ PreservingSemantics f a b,
          Functor f, Deep.Functor (Keep t) g,
          Keep t `At` g (PreservingSemantics f a b) (PreservingSemantics f a b)) =>
         Full.Functor (Keep t) g where
   <$> :: Keep t
-> Domain (Keep t) (g (Domain (Keep t)) (Domain (Keep t)))
-> Codomain (Keep t) (g (Codomain (Keep t)) (Codomain (Keep t)))
(<$>) = forall t (g :: (* -> *) -> (* -> *) -> *).
(Functor t g, At t (g (Codomain t) (Codomain t)),
 Functor (Domain t)) =>
t
-> Domain t (g (Domain t) (Domain t))
-> Codomain t (g (Codomain t) (Codomain t))
Full.mapUpDefault

instance (Transformation (Keep t), Domain (Keep t) ~ f, Traversable f, Rank2.Traversable (g f),
          Codomain (Keep t) ~ PreservingSemantics f a b, Deep.Traversable (Feeder a b f) g, Full.Functor (Keep t) g,
          Keep t `At` g (PreservingSemantics f a b) (PreservingSemantics f a b)) =>
         Full.Traversable (Keep t) g where
   traverse :: forall (m :: * -> *) (f :: * -> *).
(Codomain (Keep t) ~ Compose m f) =>
Keep t
-> Domain (Keep t) (g (Domain (Keep t)) (Domain (Keep t)))
-> m (f (g f f))
traverse = forall t (p :: * -> *) (q :: * -> *) (r :: * -> *) a b
       (g :: (* -> *) -> (* -> *) -> *).
(Transformation t, Domain t ~ p, Codomain t ~ Compose ((->) a) q,
 q ~ Compose ((,) (Atts a b)) p, r ~ Compose ((->) a) q,
 Traversable p, Functor t g, Traversable (Feeder a b p) g,
 At t (g r r)) =>
t -> p (g p p) -> a -> q (g q q)
traverseDefaultWithAttributes

-- | The core function to tie the recursive knot, turning a 'Rule' for a node into its 'Semantics'.
knit :: (Rank2.Foldable (g sem), sem ~ Semantics a b, Monoid a, Monoid b)
     => Rule a b -> g sem sem -> sem (g sem sem)
knit :: forall (g :: (* -> *) -> (* -> *) -> *) (sem :: * -> *) a b.
(Foldable (g sem), sem ~ Semantics a b, Monoid a, Monoid b) =>
Rule a b -> g sem sem -> sem (g sem sem)
knit Rule a b
r g sem sem
chSem = forall {k} a (b :: k). a -> Const a b
Const a -> b
knitted
   where knitted :: a -> b
knitted a
inherited = b
synthesized
            where Atts{syn :: forall a b. Atts a b -> b
syn= b
synthesized, inh :: forall a b. Atts a b -> a
inh= a
chInh} = Rule a b
r Atts{inh :: a
inh= a
inherited, syn :: b
syn= b
chSyn}
                  chSyn :: b
chSyn = forall {k} (g :: (k -> *) -> *) m (p :: k -> *).
(Foldable g, Monoid m) =>
(forall (a :: k). p a -> m) -> g p -> m
Rank2.foldMap ((forall a b. (a -> b) -> a -> b
$ a
chInh) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). Const a b -> a
getConst) g sem sem
chSem

-- | Another way to tie the recursive knot, using a 'Rule' to add attributes to every node througha stateful calculation
knitKeeping :: forall a b f g sem. (Rank2.Foldable (g sem), sem ~ PreservingSemantics f a b,
                                    Monoid a, Monoid b, Foldable f, Functor f)
            => Rule a b -> f (g sem sem) -> sem (g sem sem)
knitKeeping :: forall a b (f :: * -> *) (g :: (* -> *) -> (* -> *) -> *)
       (sem :: * -> *).
(Foldable (g sem), sem ~ PreservingSemantics f a b, Monoid a,
 Monoid b, Foldable f, Functor f) =>
Rule a b -> f (g sem sem) -> sem (g sem sem)
knitKeeping Rule a b
r f (g sem sem)
x = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose a -> Compose ((,) (Atts a b)) f (g sem sem)
knitted
   where knitted :: a -> Compose ((,) (Atts a b)) f (g sem sem)
         knitted :: a -> Compose ((,) (Atts a b)) f (g sem sem)
knitted a
inherited = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Atts a b
results, f (g sem sem)
x)
            where results :: Atts a b
results@Atts{inh :: forall a b. Atts a b -> a
inh= a
chInh} = Rule a b
r Atts{inh :: a
inh= a
inherited, syn :: b
syn= b
chSyn}
                  chSyn :: b
chSyn = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall {k} (g :: (k -> *) -> *) m (p :: k -> *).
(Foldable g, Monoid m) =>
(forall (a :: k). p a -> m) -> g p -> m
Rank2.foldMap (forall a b. Atts a b -> b
syn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ a
chInh) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose)) f (g sem sem)
x

-- | The core type class for defining the attribute grammar. The instances of this class typically have a form like
--
-- > instance Attribution MyAttGrammar MyMonoid MyNode (Semantics MyAttGrammar) Identity where
-- >   attribution MyAttGrammar{} (Identity MyNode{})
-- >               Atts{inh= fromParent,
-- >                    syn= fromChildren}
-- >             = Atts{syn= toParent,
-- >                    inh= toChildren}
class Attribution t a b g (deep :: Type -> Type) shallow where
   -- | The attribution rule for a given transformation and node.
   attribution :: t -> shallow (g deep deep) -> Rule a b

-- | Drop-in implementation of 'Transformation.$'
applyDefault :: (p ~ Domain t, q ~ Semantics a b, x ~ g q q,
                 Rank2.Foldable (g q), Attribution t a b g q p, Monoid a, Monoid b)
             => (forall y. p y -> y) -> t -> p x -> q x
applyDefault :: forall (p :: * -> *) t (q :: * -> *) a b x
       (g :: (* -> *) -> (* -> *) -> *).
(p ~ Domain t, q ~ Semantics a b, x ~ g q q, Foldable (g q),
 Attribution t a b g q p, Monoid a, Monoid b) =>
(forall y. p y -> y) -> t -> p x -> q x
applyDefault forall y. p y -> y
extract t
t p x
x = forall (g :: (* -> *) -> (* -> *) -> *) (sem :: * -> *) a b.
(Foldable (g sem), sem ~ Semantics a b, Monoid a, Monoid b) =>
Rule a b -> g sem sem -> sem (g sem sem)
knit (forall t a b (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
       (shallow :: * -> *).
Attribution t a b g deep shallow =>
t -> shallow (g deep deep) -> Rule a b
attribution t
t p x
x) (forall y. p y -> y
extract p x
x)
{-# INLINE applyDefault #-}

-- | Drop-in implementation of 'Full.<$>'
fullMapDefault :: (p ~ Domain t, q ~ Semantics a b, q ~ Codomain t, x ~ g q q, Rank2.Foldable (g q),
                   Deep.Functor t g, Attribution t a b g p p, Monoid a, Monoid b)
               => (forall y. p y -> y) -> t -> p (g p p) -> q (g q q)
fullMapDefault :: forall (p :: * -> *) t (q :: * -> *) a b x
       (g :: (* -> *) -> (* -> *) -> *).
(p ~ Domain t, q ~ Semantics a b, q ~ Codomain t, x ~ g q q,
 Foldable (g q), Functor t g, Attribution t a b g p p, Monoid a,
 Monoid b) =>
(forall y. p y -> y) -> t -> p (g p p) -> q (g q q)
fullMapDefault forall y. p y -> y
extract t
t p (g p p)
local = forall (g :: (* -> *) -> (* -> *) -> *) (sem :: * -> *) a b.
(Foldable (g sem), sem ~ Semantics a b, Monoid a, Monoid b) =>
Rule a b -> g sem sem -> sem (g sem sem)
knit (forall t a b (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
       (shallow :: * -> *).
Attribution t a b g deep shallow =>
t -> shallow (g deep deep) -> Rule a b
attribution t
t p (g p p)
local) (t
t forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)
Deep.<$> forall y. p y -> y
extract p (g p p)
local)
{-# INLINE fullMapDefault #-}

-- | Drop-in implementation of 'Transformation.$' that stores all attributes with every original node
applyDefaultWithAttributes :: (p ~ Domain t, q ~ PreservingSemantics p a b, x ~ g q q,
                               Attribution t a b g q p, Rank2.Foldable (g q), Monoid a, Monoid b, Foldable p, Functor p)
                           => t -> p x -> q x
applyDefaultWithAttributes :: forall (p :: * -> *) t (q :: * -> *) a b x
       (g :: (* -> *) -> (* -> *) -> *).
(p ~ Domain t, q ~ PreservingSemantics p a b, x ~ g q q,
 Attribution t a b g q p, Foldable (g q), Monoid a, Monoid b,
 Foldable p, Functor p) =>
t -> p x -> q x
applyDefaultWithAttributes t
t p x
x = forall a b (f :: * -> *) (g :: (* -> *) -> (* -> *) -> *)
       (sem :: * -> *).
(Foldable (g sem), sem ~ PreservingSemantics f a b, Monoid a,
 Monoid b, Foldable f, Functor f) =>
Rule a b -> f (g sem sem) -> sem (g sem sem)
knitKeeping (forall t a b (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
       (shallow :: * -> *).
Attribution t a b g deep shallow =>
t -> shallow (g deep deep) -> Rule a b
attribution t
t p x
x) p x
x
{-# INLINE applyDefaultWithAttributes #-}

-- | Drop-in implementation of 'Full.traverse' that stores all attributes with every original node
traverseDefaultWithAttributes :: forall t p q r a b g.
                                 (Transformation t, Domain t ~ p, Codomain t ~ Compose ((->) a) q,
                                 q ~ Compose ((,) (Atts a b)) p, r ~ Compose ((->) a) q,
                                 Traversable p, Full.Functor t g, Deep.Traversable (Feeder a b p) g,
                                 Transformation.At t (g r r))
                              => t -> p (g p p) -> a -> q (g q q)
traverseDefaultWithAttributes :: forall t (p :: * -> *) (q :: * -> *) (r :: * -> *) a b
       (g :: (* -> *) -> (* -> *) -> *).
(Transformation t, Domain t ~ p, Codomain t ~ Compose ((->) a) q,
 q ~ Compose ((,) (Atts a b)) p, r ~ Compose ((->) a) q,
 Traversable p, Functor t g, Traversable (Feeder a b p) g,
 At t (g r r)) =>
t -> p (g p p) -> a -> q (g q q)
traverseDefaultWithAttributes t
t p (g p p)
x a
rootInheritance = forall t (g :: (* -> *) -> (* -> *) -> *) (m :: * -> *)
       (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> Domain t (g (Domain t) (Domain t)) -> m (f (g f f))
Full.traverse forall a b (f :: * -> *). Feeder a b f
Feeder (t
t forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t
-> Domain t (g (Domain t) (Domain t))
-> Codomain t (g (Codomain t) (Codomain t))
Full.<$> p (g p p)
x) a
rootInheritance
{-# INLINE traverseDefaultWithAttributes #-}

data Feeder a b (f :: Type -> Type) = Feeder

instance Transformation (Feeder a b f) where
   type Domain (Feeder a b f) = Compose ((->) a) (Compose ((,) (Atts a b)) f)
   type Codomain (Feeder a b f) = Compose ((->) a) (Compose ((,) (Atts a b)) f)

instance Transformation.At (Feeder a b f) g where
   Feeder a b f
Feeder $ :: Feeder a b f
-> Domain (Feeder a b f) g -> Codomain (Feeder a b f) g
$ Domain (Feeder a b f) g
x = Domain (Feeder a b f) g
x

instance (Traversable f, Deep.Traversable (Feeder a b f) g) => Full.Traversable (Feeder a b f) g where
   traverse :: forall (m :: * -> *) (f :: * -> *).
(Codomain (Feeder a b f) ~ Compose m f) =>
Feeder a b f
-> Domain
     (Feeder a b f) (g (Domain (Feeder a b f)) (Domain (Feeder a b f)))
-> m (f (g f f))
traverse Feeder a b f
t Domain
  (Feeder a b f) (g (Domain (Feeder a b f)) (Domain (Feeder a b f)))
x a
inheritance = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Atts a b
atts{inh :: a
inh= a
inheritance}, forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall t (g :: (* -> *) -> (* -> *) -> *) (m :: * -> *)
       (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> g (Domain t) (Domain t) -> m (g f f)
Deep.traverse Feeder a b f
t) f (g (Compose ((->) a) (Compose ((,) (Atts a b)) f))
     (Compose ((->) a) (Compose ((,) (Atts a b)) f)))
y (forall a b. Atts a b -> a
inh Atts a b
atts))
      where Compose (Atts a b
atts, f (g (Compose ((->) a) (Compose ((,) (Atts a b)) f))
     (Compose ((->) a) (Compose ((,) (Atts a b)) f)))
y) = forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose Domain
  (Feeder a b f) (g (Domain (Feeder a b f)) (Domain (Feeder a b f)))
x a
inheritance