{-# Language FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, PatternSynonyms, RankNTypes,
TypeFamilies, TypeOperators, UndecidableInstances #-}
module Transformation.AG.Monomorphic (
Auto (Auto), Keep (Keep), Atts, pattern Atts, inh, syn,
Semantics, PreservingSemantics, Rule, Attribution (attribution), Feeder,
Dimorphic.knit, Dimorphic.knitKeeping,
applyDefault, applyDefaultWithAttributes,
fullMapDefault, Dimorphic.traverseDefaultWithAttributes) where
import Data.Functor.Compose (Compose(..))
import Data.Functor.Const (Const(..))
import Data.Kind (Type)
import qualified Rank2
import Transformation (Transformation, Domain, Codomain, At)
import qualified Transformation
import qualified Transformation.Deep as Deep
import qualified Transformation.Full as Full
import qualified Transformation.AG.Dimorphic as Dimorphic
import Transformation.AG.Dimorphic (knit, knitKeeping)
newtype Auto t = Auto t
newtype Keep t = Keep t
type Atts a = Dimorphic.Atts a a
pattern Atts :: a -> a -> Atts a
pattern $mAtts :: forall {r} {a}. Atts a -> (a -> a -> r) -> ((# #) -> r) -> r
$bAtts :: forall a. a -> a -> Atts a
Atts{forall a. Atts a -> a
inh, forall a. Atts a -> a
syn} = Dimorphic.Atts inh syn
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 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
$ [Char] -> y
forall a. HasCallStack => [Char] -> a
error [Char]
"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
-> p (g (PreservingSemantics p a) (PreservingSemantics p a))
-> PreservingSemantics
p a (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 a,
Rank2.Functor (g f), Deep.Functor (Auto t) g, Auto t `At` g (Semantics a) (Semantics a)) =>
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, Rank2.Functor (g 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 :: 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))
f
(g (Compose ((,) (Atts a)) f) (Compose ((,) (Atts a)) 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)
Dimorphic.traverseDefaultWithAttributes
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 (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 forall y. p y -> y
extract t
t p x
x = Rule a a -> 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) (Semantics a)) -> Rule a 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 (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, 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 (p :: * -> *) t (q :: * -> *) a x
(g :: (* -> *) -> (* -> *) -> *).
(p ~ Domain t, q ~ Semantics a, q ~ Codomain t, x ~ g q q,
Foldable (g q), 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
extract t
t p (g p p)
local = Rule a a -> 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 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 :: 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 t
t p x
x = Rule a a -> 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) (PreservingSemantics p a))
-> Rule a 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 #-}
type Feeder a = Dimorphic.Feeder a a