{-# 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.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

-- | 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 = 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

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

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

-- | 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, 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

-- | Another way to tie the recursive knot, using a 'Rule' to add attributes to every node througha stateful calculation
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

-- | 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 g (deep :: Type -> Type) shallow where
   -- | The attribution rule for a given transformation and node.
   attribution :: t -> shallow (g deep deep) -> Rule a

-- | Drop-in implementation of 'Transformation.$'
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 #-}

-- | Drop-in implementation of 'Full.<$>'
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 #-}

-- | Drop-in implementation of 'Transformation.$' that stores all attributes with every original node
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 #-}

-- | Drop-in implementation of 'Full.traverse' that stores all attributes with every original node
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