{-# 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 $bAtts :: forall a. a -> a -> Atts a
$mAtts :: forall {r} {a}. Atts a -> (a -> a -> r) -> ((# #) -> r) -> r
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 = 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,
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 (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 (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 => [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))
($) = 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,
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)))
(<$>) = 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)))
(<$>) = 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 = 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 = 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 (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
(shallow :: * -> *).
Attribution t a g deep shallow =>
t -> shallow (g deep deep) -> Rule a
attribution t
t 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 (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 = 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 (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 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 #-}
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 = 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 (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
(shallow :: * -> *).
Attribution t a g deep shallow =>
t -> shallow (g deep deep) -> Rule a
attribution t
t p x
x) p x
x
{-# INLINE applyDefaultWithAttributes #-}
type Feeder a = Dimorphic.Feeder a a