{-# Language DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes,
ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Transformation.AG.Monomorphic 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
newtype Auto t = Auto t
newtype Keep t = Keep t
data Atts a = Atts{
Atts a -> a
inh :: a,
Atts a -> a
syn :: a}
deriving (Typeable (Atts a)
DataType
Constr
Typeable (Atts a)
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Atts a -> c (Atts a))
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a))
-> (Atts a -> Constr)
-> (Atts a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Atts a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Atts a)))
-> ((forall b. Data b => b -> b) -> Atts a -> Atts a)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a -> r)
-> (forall u. (forall d. Data d => d -> u) -> Atts a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Atts a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Atts a -> m (Atts a))
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Atts a -> m (Atts a))
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Atts a -> m (Atts a))
-> Data (Atts a)
Atts a -> DataType
Atts a -> Constr
(forall d. Data d => c (t d)) -> Maybe (c (Atts a))
(forall b. Data b => b -> b) -> Atts a -> Atts a
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Atts a -> c (Atts a)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a)
forall a. Data a => Typeable (Atts a)
forall a. Data a => Atts a -> DataType
forall a. Data a => Atts a -> Constr
forall a.
Data a =>
(forall b. Data b => b -> b) -> Atts a -> Atts a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Atts a -> u
forall a u. Data a => (forall d. Data d => d -> u) -> Atts a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Atts a -> r
forall a r r'.
Data a =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Atts a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Atts a -> m (Atts a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Atts a -> m (Atts a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Atts a -> c (Atts a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Atts a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Atts a))
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 u. Int -> (forall d. Data d => d -> u) -> Atts a -> u
forall u. (forall d. Data d => d -> u) -> Atts a -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Atts a -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Atts a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Atts a -> m (Atts a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Atts a -> m (Atts a)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Atts a -> c (Atts a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Atts a))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Atts a))
$cAtts :: Constr
$tAtts :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Atts a -> m (Atts a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Atts a -> m (Atts a)
gmapMp :: (forall d. Data d => d -> m d) -> Atts a -> m (Atts a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Atts a -> m (Atts a)
gmapM :: (forall d. Data d => d -> m d) -> Atts a -> m (Atts a)
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Atts a -> m (Atts a)
gmapQi :: Int -> (forall d. Data d => d -> u) -> Atts a -> u
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Atts a -> u
gmapQ :: (forall d. Data d => d -> u) -> Atts a -> [u]
$cgmapQ :: forall a u. Data a => (forall d. Data d => d -> u) -> Atts a -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Atts a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Atts a -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Atts a -> r
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Atts a -> r
gmapT :: (forall b. Data b => b -> b) -> Atts a -> Atts a
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> Atts a -> Atts a
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Atts a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Atts a))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (Atts a))
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Atts a))
dataTypeOf :: Atts a -> DataType
$cdataTypeOf :: forall a. Data a => Atts a -> DataType
toConstr :: Atts a -> Constr
$ctoConstr :: forall a. Data a => Atts a -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Atts a -> c (Atts a)
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Atts a -> c (Atts a)
$cp1Data :: forall a. Data a => Typeable (Atts a)
Data, Typeable, Int -> Atts a -> ShowS
[Atts a] -> ShowS
Atts a -> String
(Int -> Atts a -> ShowS)
-> (Atts a -> String) -> ([Atts a] -> ShowS) -> Show (Atts a)
forall a. Show a => Int -> Atts a -> ShowS
forall a. Show a => [Atts a] -> ShowS
forall a. Show a => Atts a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Atts a] -> ShowS
$cshowList :: forall a. Show a => [Atts a] -> ShowS
show :: Atts a -> String
$cshow :: forall a. Show a => Atts a -> String
showsPrec :: Int -> Atts a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Atts a -> ShowS
Show)
instance Semigroup a => Semigroup (Atts a) where
Atts a
i1 a
s1 <> :: Atts a -> Atts a -> Atts a
<> Atts a
i2 a
s2 = a -> a -> Atts a
forall a. a -> a -> Atts a
Atts (a
i1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
i2) (a
s1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s2)
instance Monoid a => Monoid (Atts a) where
mappend :: Atts a -> Atts a -> Atts a
mappend = Atts a -> Atts a -> Atts a
forall a. Semigroup a => a -> a -> a
(<>)
mempty :: Atts a
mempty = a -> a -> Atts a
forall a. a -> a -> Atts a
Atts a
forall a. Monoid a => a
mempty a
forall a. Monoid a => a
mempty
type Semantics a = Const (a -> a)
type PreservingSemantics f a = Compose ((->) a) (Compose ((,) (Atts a)) f)
type Rule a = Atts a -> Atts a
instance {-# overlappable #-} Attribution t a g deep shallow where
attribution :: t -> shallow (g deep deep) -> Rule a
attribution = (shallow (g deep deep) -> Rule a)
-> t -> shallow (g deep deep) -> Rule a
forall a b. a -> b -> a
const (Rule a -> shallow (g deep deep) -> Rule a
forall a b. a -> b -> a
const Rule a
forall a. a -> a
id)
instance {-# overlappable #-} (Transformation (Auto t), p ~ Domain (Auto t), q ~ Codomain (Auto t), q ~ Semantics a,
Rank2.Foldable (g q), Monoid a, Foldable p, Attribution (Auto t) a g q p) =>
(Auto t) `At` g (Semantics a) (Semantics a) where
$ :: Auto t
-> Domain (Auto t) (g (Semantics a) (Semantics a))
-> Codomain (Auto t) (g (Semantics a) (Semantics a))
($) = (forall y. p y -> y)
-> Auto t
-> p (g (Semantics a) (Semantics a))
-> Semantics a (g (Semantics a) (Semantics a))
forall (p :: * -> *) t (q :: * -> *) a x
(g :: (* -> *) -> (* -> *) -> *).
(p ~ Domain t, q ~ Semantics a, x ~ g q q, Foldable (g q),
Attribution t a g q p, Monoid a) =>
(forall y. p y -> y) -> t -> p x -> q x
applyDefault ((y -> y -> y) -> y -> p y -> y
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr y -> y -> y
forall a b. a -> b -> a
const (y -> p y -> y) -> y -> p y -> y
forall a b. (a -> b) -> a -> b
$ String -> y
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, Rank2.Foldable (g q), Monoid a,
Foldable p, Functor p, Attribution (Keep t) a g q p) =>
(Keep t) `At` g (PreservingSemantics p a) (PreservingSemantics p a) where
$ :: Keep t
-> Domain
(Keep t) (g (PreservingSemantics p a) (PreservingSemantics p a))
-> Codomain
(Keep t) (g (PreservingSemantics p a) (PreservingSemantics p a))
($) = Keep t
-> Domain
(Keep t) (g (PreservingSemantics p a) (PreservingSemantics p a))
-> Codomain
(Keep t) (g (PreservingSemantics p a) (PreservingSemantics p a))
forall (p :: * -> *) t (q :: * -> *) a x
(g :: (* -> *) -> (* -> *) -> *).
(p ~ Domain t, q ~ PreservingSemantics p a, x ~ g q q,
Attribution t a g q p, Foldable (g q), Monoid a, 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 (Auto t),
Deep.Functor (Auto t) g, Auto t `At` g (Semantics (Auto t)) (Semantics (Auto t))) =>
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)))
(<$>) = 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,
Functor f, Deep.Functor (Keep t) g,
Keep t `At` g (PreservingSemantics f a) (PreservingSemantics f a)) =>
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)))
(<$>) = 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, Deep.Traversable (Feeder a f) g, Full.Functor (Keep t) g,
Keep t `At` g (PreservingSemantics f a) (PreservingSemantics f a)) =>
Full.Traversable (Keep t) g where
traverse :: Keep t
-> Domain (Keep t) (g (Domain (Keep t)) (Domain (Keep t)))
-> m (f (g f f))
traverse = Keep t
-> Domain (Keep t) (g (Domain (Keep t)) (Domain (Keep t)))
-> m (f (g f f))
forall t (p :: * -> *) (q :: * -> *) (r :: * -> *) a
(g :: (* -> *) -> (* -> *) -> *).
(Transformation t, Domain t ~ p, Codomain t ~ Compose ((->) a) q,
q ~ Compose ((,) (Atts a)) p, r ~ Compose ((->) a) q,
Traversable p, Functor t g, Traversable (Feeder a p) g,
At t (g r r)) =>
t -> p (g p p) -> a -> q (g q q)
traverseDefaultWithAttributes
knit :: (Rank2.Foldable (g sem), sem ~ Semantics a, Monoid a)
=> Rule a -> g sem sem -> sem (g sem sem)
knit :: Rule a -> g sem sem -> sem (g sem sem)
knit Rule a
r g sem sem
chSem = (a -> a) -> Const (a -> a) (g sem sem)
forall k a (b :: k). a -> Const a b
Const a -> a
knitted
where knitted :: a -> a
knitted a
inherited = a
synthesized
where Atts{syn :: forall a. Atts a -> a
syn= a
synthesized, inh :: forall a. Atts a -> a
inh= a
chInh} = Rule a
r Atts :: forall a. a -> a -> Atts a
Atts{inh :: a
inh= a
inherited, syn :: a
syn= a
chSyn}
chSyn :: a
chSyn = (forall a. sem a -> a) -> g sem sem -> a
forall k (g :: (k -> *) -> *) m (p :: k -> *).
(Foldable g, Monoid m) =>
(forall (a :: k). p a -> m) -> g p -> m
Rank2.foldMap (((a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
chInh) ((a -> a) -> a)
-> (Const (a -> a) a -> a -> a) -> Const (a -> a) a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const (a -> a) a -> a -> a
forall a k (b :: k). Const a b -> a
getConst) g sem sem
chSem
knitKeeping :: forall a f g sem. (Rank2.Foldable (g sem), sem ~ PreservingSemantics f a,
Monoid a, Foldable f, Functor f)
=> Rule a -> f (g sem sem) -> sem (g sem sem)
knitKeeping :: Rule a -> f (g sem sem) -> sem (g sem sem)
knitKeeping Rule a
r f (g sem sem)
x = (a -> Compose ((,) (Atts a)) f (g sem sem))
-> Compose ((->) a) (Compose ((,) (Atts a)) f) (g sem sem)
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose a -> Compose ((,) (Atts a)) f (g sem sem)
knitted
where knitted :: a -> Compose ((,) (Atts a)) f (g sem sem)
knitted :: a -> Compose ((,) (Atts a)) f (g sem sem)
knitted a
inherited = (Atts a, f (g sem sem)) -> Compose ((,) (Atts a)) f (g sem sem)
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Atts a
results, f (g sem sem)
x)
where results :: Atts a
results@Atts{inh :: forall a. Atts a -> a
inh= a
chInh} = Rule a
r Atts :: forall a. a -> a -> Atts a
Atts{inh :: a
inh= a
inherited, syn :: a
syn= a
chSyn}
chSyn :: a
chSyn = (g sem sem -> a) -> f (g sem sem) -> a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((forall a. sem a -> a) -> g sem sem -> a
forall k (g :: (k -> *) -> *) m (p :: k -> *).
(Foldable g, Monoid m) =>
(forall (a :: k). p a -> m) -> g p -> m
Rank2.foldMap (Atts a -> a
forall a. Atts a -> a
syn (Atts a -> a)
-> (Compose ((->) a) (Compose ((,) (Atts a)) f) a -> Atts a)
-> Compose ((->) a) (Compose ((,) (Atts a)) f) a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Atts a, f a) -> Atts a
forall a b. (a, b) -> a
fst ((Atts a, f a) -> Atts a)
-> (Compose ((->) a) (Compose ((,) (Atts a)) f) a -> (Atts a, f a))
-> Compose ((->) a) (Compose ((,) (Atts a)) f) a
-> Atts a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose ((,) (Atts a)) f a -> (Atts a, f a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose ((,) (Atts a)) f a -> (Atts a, f a))
-> (Compose ((->) a) (Compose ((,) (Atts a)) f) a
-> Compose ((,) (Atts a)) f a)
-> Compose ((->) a) (Compose ((,) (Atts a)) f) a
-> (Atts a, f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> Compose ((,) (Atts a)) f a)
-> a -> Compose ((,) (Atts a)) f a
forall a b. (a -> b) -> a -> b
$ a
chInh) ((a -> Compose ((,) (Atts a)) f a) -> Compose ((,) (Atts a)) f a)
-> (Compose ((->) a) (Compose ((,) (Atts a)) f) a
-> a -> Compose ((,) (Atts a)) f a)
-> Compose ((->) a) (Compose ((,) (Atts a)) f) a
-> Compose ((,) (Atts a)) f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose ((->) a) (Compose ((,) (Atts a)) f) a
-> a -> Compose ((,) (Atts a)) f a
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose)) f (g sem sem)
x
class Attribution t a g (deep :: Type -> Type) shallow where
attribution :: t -> shallow (g deep deep) -> Rule a
applyDefault :: (p ~ Domain t, q ~ Semantics a, x ~ g q q, Rank2.Foldable (g q), Attribution t a g q p, Monoid a)
=> (forall y. p y -> y) -> t -> p x -> q x
applyDefault :: (forall y. p y -> y) -> t -> p x -> q x
applyDefault forall y. p y -> y
extract t
t p x
x = Rule a -> g q q -> q (g q q)
forall (g :: (* -> *) -> (* -> *) -> *) (sem :: * -> *) a.
(Foldable (g sem), sem ~ Semantics a, Monoid a) =>
Rule a -> g sem sem -> sem (g sem sem)
knit (t -> p (g (Semantics a) (Semantics a)) -> Rule a
forall t a (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
(shallow :: * -> *).
Attribution t a g deep shallow =>
t -> shallow (g deep deep) -> Rule a
attribution t
t p x
p (g (Semantics a) (Semantics a))
x) (p x -> x
forall y. p y -> y
extract p x
x)
{-# INLINE applyDefault #-}
fullMapDefault :: (p ~ Domain t, q ~ Semantics a, q ~ Codomain t, x ~ g q q, Rank2.Foldable (g q),
Deep.Functor t g, Attribution t a g p p, Monoid a)
=> (forall y. p y -> y) -> t -> p (g p p) -> q (g q q)
fullMapDefault :: (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 = Rule a -> g q q -> q (g q q)
forall (g :: (* -> *) -> (* -> *) -> *) (sem :: * -> *) a.
(Foldable (g sem), sem ~ Semantics a, Monoid a) =>
Rule a -> g sem sem -> sem (g sem sem)
knit (t -> p (g p p) -> Rule a
forall t a (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
(shallow :: * -> *).
Attribution t a g deep shallow =>
t -> shallow (g deep deep) -> Rule a
attribution t
t p (g p p)
local) (t
t t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)
forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)
Deep.<$> p (g p p) -> g p p
forall y. p y -> y
extract p (g p p)
local)
{-# INLINE fullMapDefault #-}
applyDefaultWithAttributes :: (p ~ Domain t, q ~ PreservingSemantics p a, x ~ g q q,
Attribution t a g q p, Rank2.Foldable (g q), Monoid a, Foldable p, Functor p)
=> t -> p x -> q x
applyDefaultWithAttributes :: t -> p x -> q x
applyDefaultWithAttributes t
t p x
x = Rule a -> p (g q q) -> q (g q q)
forall a (f :: * -> *) (g :: (* -> *) -> (* -> *) -> *)
(sem :: * -> *).
(Foldable (g sem), sem ~ PreservingSemantics f a, Monoid a,
Foldable f, Functor f) =>
Rule a -> f (g sem sem) -> sem (g sem sem)
knitKeeping (t
-> p (g (PreservingSemantics p a) (PreservingSemantics p a))
-> Rule a
forall t a (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
(shallow :: * -> *).
Attribution t a g deep shallow =>
t -> shallow (g deep deep) -> Rule a
attribution t
t p x
p (g (PreservingSemantics p a) (PreservingSemantics p a))
x) p x
p (g q q)
x
{-# INLINE applyDefaultWithAttributes #-}
traverseDefaultWithAttributes :: forall t p q r a g.
(Transformation t, Domain t ~ p, Codomain t ~ Compose ((->) a) q,
q ~ Compose ((,) (Atts a)) p, r ~ Compose ((->) a) q,
Traversable p, Full.Functor t g, Deep.Traversable (Feeder a p) g,
Transformation.At t (g r r))
=> t -> p (g p p) -> a -> q (g q q)
traverseDefaultWithAttributes :: t -> p (g p p) -> a -> q (g q q)
traverseDefaultWithAttributes t
t p (g p p)
x a
rootInheritance = Feeder a p
-> Domain
(Feeder a p) (g (Domain (Feeder a p)) (Domain (Feeder a p)))
-> a
-> q (g q q)
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 Feeder a p
forall a (f :: * -> *). Feeder a f
Feeder (t
t t
-> Domain t (g (Domain t) (Domain t))
-> Codomain t (g (Codomain t) (Codomain 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)
Domain t (g (Domain t) (Domain t))
x) a
rootInheritance
{-# INLINE traverseDefaultWithAttributes #-}
data Feeder a (f :: Type -> Type) = Feeder
instance Transformation (Feeder a f) where
type Domain (Feeder a f) = Compose ((->) a) (Compose ((,) (Atts a)) f)
type Codomain (Feeder a f) = Compose ((->) a) (Compose ((,) (Atts a)) f)
instance Transformation.At (Feeder a f) g where
Feeder a f
Feeder $ :: Feeder a f -> Domain (Feeder a f) g -> Codomain (Feeder a f) g
$ Domain (Feeder a f) g
x = Domain (Feeder a f) g
Codomain (Feeder a f) g
x
instance (Traversable f, Deep.Traversable (Feeder a f) g) => Full.Traversable (Feeder a f) g where
traverse :: Feeder a f
-> Domain
(Feeder a f) (g (Domain (Feeder a f)) (Domain (Feeder a f)))
-> m (f (g f f))
traverse Feeder a f
t Domain (Feeder a f) (g (Domain (Feeder a f)) (Domain (Feeder a f)))
x a
inheritance = (Atts a,
f (g (Compose ((,) (Atts a)) f) (Compose ((,) (Atts a)) f)))
-> Compose
((,) (Atts a))
f
(g (Compose ((,) (Atts a)) f) (Compose ((,) (Atts a)) f))
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Atts a
atts{inh :: a
inh= a
inheritance}, (g (Compose ((->) a) (Compose ((,) (Atts a)) f))
(Compose ((->) a) (Compose ((,) (Atts a)) f))
-> a -> g (Compose ((,) (Atts a)) f) (Compose ((,) (Atts a)) f))
-> f (g (Compose ((->) a) (Compose ((,) (Atts a)) f))
(Compose ((->) a) (Compose ((,) (Atts a)) f)))
-> a
-> f (g (Compose ((,) (Atts a)) f) (Compose ((,) (Atts a)) f))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Feeder a f
-> g (Domain (Feeder a f)) (Domain (Feeder a f))
-> a
-> g (Compose ((,) (Atts a)) f) (Compose ((,) (Atts a)) f)
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 f
t) f (g (Compose ((->) a) (Compose ((,) (Atts a)) f))
(Compose ((->) a) (Compose ((,) (Atts a)) f)))
y (Atts a -> a
forall a. Atts a -> a
inh Atts a
atts))
where Compose (Atts a
atts, f (g (Compose ((->) a) (Compose ((,) (Atts a)) f))
(Compose ((->) a) (Compose ((,) (Atts a)) f)))
y) = Compose
((->) a)
(Compose ((,) (Atts a)) f)
(g (Compose ((->) a) (Compose ((,) (Atts a)) f))
(Compose ((->) a) (Compose ((,) (Atts a)) f)))
-> a
-> Compose
((,) (Atts a))
f
(g (Compose ((->) a) (Compose ((,) (Atts a)) f))
(Compose ((->) a) (Compose ((,) (Atts a)) f)))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose Compose
((->) a)
(Compose ((,) (Atts a)) f)
(g (Compose ((->) a) (Compose ((,) (Atts a)) f))
(Compose ((->) a) (Compose ((,) (Atts a)) f)))
Domain (Feeder a f) (g (Domain (Feeder a f)) (Domain (Feeder a f)))
x a
inheritance