{-# Language DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes,
ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
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
newtype Auto t = Auto t
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 (Typeable (Atts a b)
Typeable (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 (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a b))
-> (Atts a b -> Constr)
-> (Atts a b -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (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)))
-> ((forall b. Data b => b -> b) -> Atts a b -> Atts a b)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r)
-> (forall u. (forall d. Data d => d -> u) -> Atts a b -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Atts a b -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b))
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b))
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b))
-> Data (Atts a b)
Atts a b -> Constr
Atts a b -> DataType
(forall b. Data b => b -> b) -> Atts a b -> Atts a b
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 b -> u
forall u. (forall d. Data d => d -> u) -> Atts a b -> [u]
forall a b. (Data a, Data b) => Typeable (Atts a b)
forall a b. (Data a, Data b) => Atts a b -> Constr
forall a b. (Data a, Data b) => Atts a b -> DataType
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 r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Atts a b -> m (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. Data d => c (t d)) -> Maybe (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))
$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)
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)
$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)
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Atts a b)
$ctoConstr :: forall a b. (Data a, Data b) => Atts a b -> Constr
toConstr :: Atts a b -> Constr
$cdataTypeOf :: forall a b. (Data a, Data b) => Atts a b -> DataType
dataTypeOf :: Atts a b -> DataType
$cdataCast1 :: forall a b (t :: * -> *) (c :: * -> *).
(Data a, Data b, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Atts a b))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> 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))
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Atts a b))
$cgmapT :: forall a b.
(Data a, Data b) =>
(forall b. Data b => b -> b) -> Atts a b -> Atts a b
gmapT :: (forall b. Data b => b -> b) -> Atts a b -> Atts a b
$cgmapQl :: 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
$cgmapQr :: forall a b r r'.
(Data a, Data b) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Atts a b -> r
$cgmapQ :: forall a b u.
(Data a, Data b) =>
(forall d. Data d => d -> u) -> Atts a b -> [u]
gmapQ :: forall u. (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
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Atts a b -> u
$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)
gmapM :: forall (m :: * -> *).
Monad 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)
gmapMp :: 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)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Atts a b -> m (Atts a b)
Data, Typeable, Int -> Atts a b -> ShowS
[Atts a b] -> ShowS
Atts a b -> String
(Int -> Atts a b -> ShowS)
-> (Atts a b -> String) -> ([Atts a b] -> ShowS) -> Show (Atts a b)
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
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> Atts a b -> ShowS
showsPrec :: Int -> Atts a b -> ShowS
$cshow :: forall a b. (Show a, Show b) => Atts a b -> String
show :: Atts a b -> String
$cshowList :: forall a b. (Show a, Show b) => [Atts a b] -> ShowS
showList :: [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 = a -> b -> Atts a b
forall a b. a -> b -> Atts a b
Atts (a
i1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
i2) (b
s1 b -> b -> b
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 = Atts a b -> Atts a b -> Atts a b
forall a. Semigroup a => a -> a -> a
(<>)
mempty :: Atts a b
mempty = a -> b -> Atts a b
forall a b. a -> b -> Atts a b
Atts a
forall a. Monoid a => a
mempty b
forall a. Monoid a => a
mempty
type Semantics a b = Const (a -> b)
type PreservingSemantics f a b = Compose ((->) a) (Compose ((,) (Atts a b)) f)
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 = (shallow (g deep deep) -> Rule a b)
-> t -> shallow (g deep deep) -> Rule a b
forall a b. a -> b -> a
const (Rule a b -> shallow (g deep deep) -> Rule a b
forall a b. a -> b -> a
const Rule a b
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 y. p y -> y)
-> Auto t
-> p (g (Semantics a b) (Semantics a b))
-> Semantics a b (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 ((y -> y -> y) -> y -> p y -> y
forall a b. (a -> b -> b) -> b -> p a -> b
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 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))
($) = Keep t
-> p (g (PreservingSemantics p a b) (PreservingSemantics p a b))
-> PreservingSemantics
p a b (g (PreservingSemantics p a b) (PreservingSemantics p a b))
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,
Rank2.Functor (g f), 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)))
(<$>) = 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,
Rank2.Functor (g 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)))
(<$>) = 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 = Keep t
-> f (g f f)
-> a
-> Compose
((,) (Atts a b))
f
(g (Compose ((,) (Atts a b)) f) (Compose ((,) (Atts a b)) f))
Keep t
-> Domain (Keep t) (g (Domain (Keep t)) (Domain (Keep t)))
-> m (f (g f f))
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
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 = (a -> b) -> Const (a -> b) (g sem sem)
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 a. sem a -> b) -> g sem sem -> b
forall m (p :: * -> *).
Monoid m =>
(forall a. p a -> m) -> g sem p -> m
forall {k} (g :: (k -> *) -> *) m (p :: k -> *).
(Foldable g, Monoid m) =>
(forall (a :: k). p a -> m) -> g p -> m
Rank2.foldMap (((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
chInh) ((a -> b) -> b) -> (sem a -> a -> b) -> sem a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sem a -> a -> b
Const (a -> b) a -> a -> b
forall {k} a (b :: k). Const a b -> a
getConst) g sem sem
chSem
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 = (a -> Compose ((,) (Atts a b)) f (g sem sem))
-> Compose ((->) a) (Compose ((,) (Atts a b)) 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 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 = (Atts a b, f (g sem sem)) -> Compose ((,) (Atts a b)) f (g sem sem)
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 = (g sem sem -> b) -> f (g sem sem) -> b
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((forall a. sem a -> b) -> g sem sem -> b
forall m (p :: * -> *).
Monoid m =>
(forall a. p a -> m) -> g sem p -> m
forall {k} (g :: (k -> *) -> *) m (p :: k -> *).
(Foldable g, Monoid m) =>
(forall (a :: k). p a -> m) -> g p -> m
Rank2.foldMap (Atts a b -> b
forall a b. Atts a b -> b
syn (Atts a b -> b) -> (sem a -> Atts a b) -> sem a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Atts a b, f a) -> Atts a b
forall a b. (a, b) -> a
fst ((Atts a b, f a) -> Atts a b)
-> (sem a -> (Atts a b, f a)) -> sem a -> Atts a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose ((,) (Atts a b)) f a -> (Atts a b, f a)
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose ((,) (Atts a b)) f a -> (Atts a b, f a))
-> (sem a -> Compose ((,) (Atts a b)) f a)
-> sem a
-> (Atts a b, f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> Compose ((,) (Atts a b)) f a)
-> a -> Compose ((,) (Atts a b)) f a
forall a b. (a -> b) -> a -> b
$ a
chInh) ((a -> Compose ((,) (Atts a b)) f a)
-> Compose ((,) (Atts a b)) f a)
-> (sem a -> a -> Compose ((,) (Atts a b)) f a)
-> sem a
-> Compose ((,) (Atts a b)) f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sem a -> a -> Compose ((,) (Atts a b)) f a
Compose ((->) a) (Compose ((,) (Atts a b)) f) a
-> a -> Compose ((,) (Atts a b)) f a
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose)) f (g sem sem)
x
class Attribution t a b g (deep :: Type -> Type) shallow where
attribution :: t -> shallow (g deep deep) -> Rule a b
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 = Rule a b -> g q q -> q (g q q)
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 (t -> p (g (Semantics a b) (Semantics a b)) -> Rule a b
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
p (g (Semantics a b) (Semantics a b))
x) (p (g q q) -> g q q
forall y. p y -> y
extract p x
p (g q q)
x)
{-# INLINE applyDefault #-}
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 = Rule a b -> g q q -> q (g q q)
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 (t -> p (g p p) -> Rule a b
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 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 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 = Rule a b -> p (g q q) -> q (g q q)
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 (t
-> p (g (PreservingSemantics p a b) (PreservingSemantics p a b))
-> Rule a b
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
p (g (PreservingSemantics p a b) (PreservingSemantics p a b))
x) p x
p (g q q)
x
{-# INLINE applyDefaultWithAttributes #-}
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 = Feeder a b p
-> Domain
(Feeder a b p) (g (Domain (Feeder a b p)) (Domain (Feeder a b p)))
-> a
-> Compose
((,) (Atts a b))
p
(g (Compose ((,) (Atts a b)) p) (Compose ((,) (Atts a b)) p))
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))
forall (m :: * -> *) (f :: * -> *).
(Codomain (Feeder a b p) ~ Compose m f) =>
Feeder a b p
-> Domain
(Feeder a b p) (g (Domain (Feeder a b p)) (Domain (Feeder a b p)))
-> m (f (g f f))
Full.traverse Feeder a b p
forall a b (f :: * -> *). Feeder a b 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 b (f :: Type -> Type) = Feeder
type FeederDomain a b f = Compose ((->) a) (Compose ((,) (Atts a b)) f)
instance Transformation (Feeder a b f) where
type Domain (Feeder a b f) = FeederDomain a b f
type Codomain (Feeder a b f) = FeederDomain 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
Codomain (Feeder a b f) g
x
instance (Traversable f, Rank2.Traversable (g (FeederDomain a b 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 = (Atts a b,
f (g (Compose ((,) (Atts a b)) f) (Compose ((,) (Atts a b)) f)))
-> Compose
((,) (Atts a b))
f
(g (Compose ((,) (Atts a b)) f) (Compose ((,) (Atts a b)) f))
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Atts a b
atts{inh= inheritance}, (g (FeederDomain a b f) (FeederDomain a b f)
-> a
-> g (Compose ((,) (Atts a b)) f) (Compose ((,) (Atts a b)) f))
-> f (g (FeederDomain a b f) (FeederDomain a b f))
-> a
-> f (g (Compose ((,) (Atts a b)) f) (Compose ((,) (Atts a b)) f))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse (Feeder a b f
-> g (Domain (Feeder a b f)) (Domain (Feeder a b f))
-> a
-> g (Compose ((,) (Atts a b)) f) (Compose ((,) (Atts a b)) f)
forall t (g :: (* -> *) -> (* -> *) -> *) (m :: * -> *)
(f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> g (Domain t) (Domain t) -> m (g f f)
forall (m :: * -> *) (f :: * -> *).
(Codomain (Feeder a b f) ~ Compose m f) =>
Feeder a b f
-> g (Domain (Feeder a b f)) (Domain (Feeder a b f)) -> m (g f f)
Deep.traverse Feeder a b f
t) f (g (FeederDomain a b f) (FeederDomain a b f))
y (Atts a b -> a
forall a b. Atts a b -> a
inh Atts a b
atts))
where Compose (Atts a b
atts, f (g (FeederDomain a b f) (FeederDomain a b f))
y) = Compose
((->) a)
(Compose ((,) (Atts a b)) f)
(g (FeederDomain a b f) (FeederDomain a b f))
-> a
-> Compose
((,) (Atts a b)) f (g (FeederDomain a b f) (FeederDomain a b f))
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose Compose
((->) a)
(Compose ((,) (Atts a b)) f)
(g (FeederDomain a b f) (FeederDomain a b f))
Domain
(Feeder a b f) (g (Domain (Feeder a b f)) (Domain (Feeder a b f)))
x a
inheritance