deep-transformations 0.1 → 0.2

raw patch · 16 files changed

+415/−83 lines, 16 filesdep +transformersdep ~basedep ~generic-lensdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependency ranges changed: base, generic-lens, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +24/−0
• README.md +16/−9
• deep-transformations.cabal +8/−5
• src/Transformation.hs +1/−1
• src/Transformation/AG.hs +47/−11
• src/Transformation/AG/Generics.hs +52/−14
• src/Transformation/AG/Monomorphic.hs +153/−0
• src/Transformation/Deep.hs +43/−3
• src/Transformation/Deep/TH.hs +9/−2
• src/Transformation/Full.hs +3/−2
• src/Transformation/Rank2.hs +1/−0
• src/Transformation/Shallow.hs +2/−1
• src/Transformation/Shallow/TH.hs +14/−1
• test/README.lhs +16/−9
• test/RepMin.hs +16/−9
• test/RepMinAuto.hs +10/−16

@@ -0,0 +1,24 @@+# Revision history for deep-transformations++## 0.2 -- 2022-03-27++* Changes necessary to compile with GHC 9.2.2+* Excluded GHC 8.2.2 from `deep-transformations` and GitHub CI+* Increased the `deep-transformations`' bottom bound of base dependency+* Fixed `deep-transformations` compilation with GHC 9.0.1+* Added an explicit implementation `mappend = (<>)`+* Used haskell-ci to generate GitHub CI+* Incremented upper dependency bounds+* Added `AG.Generics.Keep`+* Added `knitKeeping` and `applyDefaultWithAttributes` to `AG`+* Dropped `fullMapDefault`+* Switch the README's attribute grammar functor to map upwards+* Removed unused code+* Added `infixl 4` declarations for all `<$>` methods+* Added the `AG.Monomorphic` module+* Fixed `Transformation.Shallow.TH` for repeated type parameters+* Added `Transformation.Deep.Sum`++## 0.1 -- 2020-11-11++First version

@@ -31,6 +31,7 @@ import Data.Coerce (coerce) import Data.Functor.Const import Data.Functor.Identity+import Data.Monoid import qualified Rank2 import Transformation (Transformation, At) import qualified Transformation@@ -279,11 +280,17 @@    type Domain DeadCodeEliminator = Identity    type Codomain DeadCodeEliminator = AG.Semantics DeadCodeEliminator +instance DeadCodeEliminator `Transformation.At` Decl Sem Sem where+  ($) = AG.applyDefault runIdentity++instance DeadCodeEliminator `Transformation.At` Expr Sem Sem where+  ($) = AG.applyDefault runIdentity+ instance Full.Functor DeadCodeEliminator Decl where-  (<$>) = AG.fullMapDefault runIdentity+  (<$>) = Full.mapUpDefault  instance Full.Functor DeadCodeEliminator Expr where-  (<$>) = AG.fullMapDefault runIdentity+  (<$>) = Full.mapUpDefault ~~~  We also need another bit of a boilerplate instance that can be automatically generated with Template Haskell functions@@ -359,11 +366,11 @@ because they don't have any children.  ~~~ {.haskell}-instance AG.Attribution DeadCodeEliminator Expr Identity Identity where-  attribution DeadCodeEliminator (Identity e@(EVar v)) (AG.Inherited env, _) =-    (AG.Synthesized (maybe e id $ env v), EVar v)-  attribution DeadCodeEliminator (Identity e@(Con n)) (AG.Inherited env, _) =-    (AG.Synthesized e, Con n)+instance AG.Attribution DeadCodeEliminator Expr Sem Identity where+  attribution DeadCodeEliminator (Identity (EVar v)) (AG.Inherited env, _) =+    (AG.Synthesized (maybe (EVar v) id $ env v), EVar v)+  attribution DeadCodeEliminator (Identity (Con n)) (AG.Inherited env, _) =+    (AG.Synthesized (Con n), Con n) ~~~  The `Add` and `Mul` nodes' rules need only to pass their inheritance down and to re-join the synthesized child@@ -388,7 +395,7 @@   attribution DeadCodeEliminator (Identity (Let _decl expr))               (AG.Inherited env, (Let (AG.Synthesized ~(env', decl')) (AG.Synthesized expr'))) =     (AG.Synthesized (maybe id (bin Let) decl' expr'),-     Let (AG.Inherited (env, Full.foldMap GetVariables expr)) (AG.Inherited $ \v-> env' v <|> env v))+     Let (AG.Inherited (env, Deep.foldMap GetVariables expr')) (AG.Inherited $ \v-> env' v <|> env v)) ~~~  ### Declaration rules@@ -396,7 +403,7 @@ The rules for `Decl` are a bit more involved.  ~~~ {.haskell}-instance AG.Attribution DeadCodeEliminator Decl Identity Identity where+instance AG.Attribution DeadCodeEliminator Decl Sem Identity where ~~~  A single variable binding can be in three distinct situations. If the variable is not referenced at all, we can just

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                deep-transformations-version:             0.1+version:             0.2 synopsis:            Deep natural and unnatural tree transformations, including attribute grammars description: @@ -22,7 +22,8 @@ category:            Control, Generics build-type:          Custom cabal-version:       >=1.10-extra-source-files:  README.md+tested-with:         GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4+extra-source-files:  README.md, CHANGELOG.md source-repository head   type:              git   location:          https://github.com/blamario/grampa@@ -38,10 +39,12 @@                         Transformation.Shallow, Transformation.Shallow.TH,                         Transformation.Deep, Transformation.Deep.TH,                         Transformation.Full, Transformation.Full.TH,-                        Transformation.Rank2, Transformation.AG, Transformation.AG.Generics+                        Transformation.Rank2,+                        Transformation.AG, Transformation.AG.Monomorphic, Transformation.AG.Generics   ghc-options:         -Wall-  build-depends:        base >= 4.7 && < 5, rank2classes >= 1.4.1 && < 1.5,-                        template-haskell >= 2.11 && < 2.17, generic-lens == 2.0.*+  build-depends:        base >= 4.11 && < 5, rank2classes >= 1.4.1 && < 1.5,+                        transformers >= 0.5 && < 0.7,+                        template-haskell >= 2.11 && < 2.19, generic-lens >= 1.2 && < 2.3   default-language:     Haskell2010  test-suite doctests

@@ -56,7 +56,7 @@ instance (t `At` x, u `At` x, Domain t ~ Codomain u) => Compose t u `At` x where    Compose t u $ x =  t $ (u $ x) -instance Transformation (Rank2.Arrow p q x) where+instance Transformation (Rank2.Arrow (p :: Type -> Type) q x) where    type Domain (Rank2.Arrow p q x) = p    type Codomain (Rank2.Arrow p q x) = q 

@@ -1,5 +1,5 @@ {-# Language FlexibleContexts, FlexibleInstances,-             MultiParamTypeClasses, RankNTypes, StandaloneDeriving,+             MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving,              TypeFamilies, TypeOperators, UndecidableInstances #-}  -- | An attribute grammar is a particular kind of 'Transformation' that assigns attributes to nodes in a@@ -8,9 +8,10 @@  module Transformation.AG where +import Unsafe.Coerce (unsafeCoerce)+ import qualified Rank2-import Transformation (Domain, Codomain)-import qualified Transformation.Deep as Deep+import qualified Transformation  -- | Type family that maps a node type to the type of its attributes, indexed per type constructor. type family Atts (f :: * -> *) a@@ -27,11 +28,19 @@ -- attributes. type Semantics t = Inherited t Rank2.~> Synthesized t +-- | A node's 'PreservingSemantics' is a natural tranformation from the node's inherited attributes to all its+-- attributes paired with the preserved node.+type PreservingSemantics t f = Rank2.Arrow (Inherited t) (Rank2.Product (AllAtts t) f)++-- | All inherited and synthesized attributes+data AllAtts t a = AllAtts{allInh :: Atts (Inherited t) a,+                           allSyn :: Atts (Synthesized t) a}+ -- | An attribution rule maps a node's inherited attributes and its child nodes' synthesized attributes to the node's -- synthesized attributes and the children nodes' inherited attributes. type Rule t g =  forall sem . sem ~ Semantics t-              => (Inherited   t (g sem sem), g sem (Synthesized t))-              -> (Synthesized t (g sem sem), g sem (Inherited t))+              => (Inherited   t (g sem (Semantics t)), g sem (Synthesized t))+              -> (Synthesized t (g sem (Semantics t)), g sem (Inherited t))  -- | The core function to tie the recursive knot, turning a 'Rule' for a node into its 'Semantics'. knit :: (Rank2.Apply (g sem), sem ~ Semantics t) => Rule t g -> g sem sem -> sem (g sem sem)@@ -40,6 +49,28 @@             where (synthesized, chInh) = r (inherited, chSyn)                   chSyn = chSem Rank2.<*> chInh +-- | Another way to tie the recursive knot, using a 'Rule' to add 'AllAtts' information to every node+knitKeeping :: forall t f g sem. (sem ~ PreservingSemantics t f, Rank2.Apply (g sem),+                              Atts (Inherited t) (g sem sem) ~ Atts (Inherited t) (g (Semantics t) (Semantics t)),+                              Atts (Synthesized t) (g sem sem) ~ Atts (Synthesized t) (g (Semantics t) (Semantics t)),+                              g sem (Synthesized t) ~ g (Semantics t) (Synthesized t),+                              g sem (Inherited t) ~ g (Semantics t) (Inherited t))+            => (forall a. f a -> a) -> Rule t g -> f (g (PreservingSemantics t f) (PreservingSemantics t f))+            -> PreservingSemantics t f (g (PreservingSemantics t f) (PreservingSemantics t f))+knitKeeping extract rule x = Rank2.Arrow knitted+   where knitted :: Inherited t (g (PreservingSemantics t f) (PreservingSemantics t f))+                 -> Rank2.Product (AllAtts t) f (g (PreservingSemantics t f) (PreservingSemantics t f))+         chSem :: g (PreservingSemantics t f) (PreservingSemantics t f)+         knitted inherited = Rank2.Pair AllAtts{allInh= inh inherited, allSyn= syn synthesized} x+            where chInh :: g (PreservingSemantics t f) (Inherited t)+                  chSyn :: g (PreservingSemantics t f) (Synthesized t)+                  chKept :: g (PreservingSemantics t f) (Rank2.Product (AllAtts t) f)+                  synthesized :: Synthesized t (g (PreservingSemantics t f) (PreservingSemantics t f))+                  (synthesized, chInh) = unsafeCoerce (rule (unsafeCoerce inherited, unsafeCoerce chSyn))+                  chSyn = Synthesized . allSyn . Rank2.fst Rank2.<$> chKept+                  chKept = chSem Rank2.<*> chInh+         chSem = extract x+ -- | The core type class for defining the attribute grammar. The instances of this class typically have a form like -- -- > instance Attribution MyAttGrammar MyNode (Semantics MyAttGrammar) Identity where@@ -63,9 +94,14 @@ applyDefault extract t x = knit (attribution t x) (extract x) {-# INLINE applyDefault #-} --- | Drop-in implementation of 'Transformation.Full.<$>'-fullMapDefault :: (p ~ Domain t, q ~ Semantics t, q ~ Codomain t, x ~ g q q, Rank2.Apply (g q),-                   Deep.Functor t g, Attribution t g p p)-               => (forall a. p a -> a) -> t -> p (g p p) -> q (g q q)-fullMapDefault extract t local = knit (attribution t local) (t Deep.<$> extract local)-{-# INLINE fullMapDefault #-}+-- | Drop-in implementation of 'Transformation.$' that preserves all attributes with every original node+applyDefaultWithAttributes :: (p ~ Transformation.Domain t, q ~ PreservingSemantics t p, x ~ g q q, Rank2.Apply (g q),+                               Atts (Inherited t) (g q q) ~ Atts (Inherited t) (g (Semantics t) (Semantics t)),+                               Atts (Synthesized t) (g q q) ~ Atts (Synthesized t) (g (Semantics t) (Semantics t)),+                               g q (Synthesized t) ~ g (Semantics t) (Synthesized t),+                               g q (Inherited t) ~ g (Semantics t) (Inherited t),+                               Attribution t g (PreservingSemantics t p) p)+                           => (forall a. p a -> a) -> t -> p (g (PreservingSemantics t p) (PreservingSemantics t p))+                           -> PreservingSemantics t p (g (PreservingSemantics t p) (PreservingSemantics t p))+applyDefaultWithAttributes extract t x = knitKeeping extract (attribution t x) x+{-# INLINE applyDefaultWithAttributes #-}

@@ -1,5 +1,5 @@ {-# Language DataKinds, DefaultSignatures, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,-             MultiParamTypeClasses, PolyKinds, RankNTypes, ScopedTypeVariables, StandaloneDeriving,+             InstanceSigs, MultiParamTypeClasses, PolyKinds, RankNTypes, ScopedTypeVariables, StandaloneDeriving,              TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}  -- | This module can be used to scrap the boilerplate attribute declarations. In particular:@@ -14,7 +14,7 @@ -- * If the attribute additionally carries an applicative effect, the 'Mapped' wrapper can be replaced by 'Traversed'.  module Transformation.AG.Generics (-- * Type wrappers for automatic attribute inference-                                   Auto(..), Folded(..), Mapped(..), Traversed(..),+                                   Auto(..), Keep(..), Folded(..), Mapped(..), Traversed(..),                                    -- * Type classes replacing 'Attribution'                                    Bequether(..), Synthesizer(..), SynthesizedField(..), Revelation(..),                                    -- * The default behaviour on generic datatypes@@ -27,24 +27,68 @@ import Data.Kind (Type) import Data.Generics.Product.Subtype (Subtype(upcast)) import Data.Proxy (Proxy(..))+import Data.Semigroup (Semigroup(..)) import GHC.Generics import GHC.Records import GHC.TypeLits (Symbol, ErrorMessage (Text), TypeError) import Unsafe.Coerce (unsafeCoerce)-import Transformation (Transformation, Domain, Codomain)+import qualified Rank2+import Transformation (Transformation, Domain, Codomain, At) import Transformation.AG import qualified Transformation import qualified Transformation.Shallow as Shallow+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 all attributes with+-- the original nodes.+newtype Keep t = Keep t++type instance Atts (Inherited (Auto t)) x = Atts (Inherited t) x+type instance Atts (Synthesized (Auto t)) x = Atts (Synthesized t) x++type instance Atts (Inherited (Keep t)) x = Atts (Inherited t) x+type instance Atts (Synthesized (Keep t)) x = Atts (Synthesized t) x++instance {-# overlappable #-} (Revelation (Auto t), Domain (Auto t) ~ f, Codomain (Auto t) ~ Semantics (Auto t),+                               Rank2.Apply (g (Semantics (Auto t))), Attribution (Auto t) g (Semantics (Auto t)) f) =>+                              Auto t `At` g (Semantics (Auto t)) (Semantics (Auto t)) where+   t $ x = applyDefault (reveal t) t x+   {-# INLINE ($) #-}++instance {-# overlappable #-}+         (Revelation (Keep t), p ~ Transformation.Domain (Keep t), Rank2.Apply (g q),+          q ~ Transformation.Codomain (Keep t), q ~ PreservingSemantics (Keep t) p, s ~ Semantics (Keep t),+          Atts (Inherited (Keep t)) (g q q) ~ Atts (Inherited (Keep t)) (g s s),+          Atts (Synthesized (Keep t)) (g q q) ~ Atts (Synthesized (Keep t)) (g s s),+          g q (Synthesized (Keep t)) ~ g s (Synthesized (Keep t)),+          g q (Inherited (Keep t)) ~ g s (Inherited (Keep t)), Attribution (Keep t) g q p) =>+         Keep t `At` g (PreservingSemantics (Keep t) p) (PreservingSemantics (Keep t) p) where+   ($) :: Keep t -> p (g (PreservingSemantics (Keep t) p) (PreservingSemantics (Keep t) p))+       -> PreservingSemantics (Keep t) p (g (PreservingSemantics (Keep t) p) (PreservingSemantics (Keep t) p))+   t $ x = applyDefaultWithAttributes (reveal t) t x+   {-# 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+   (<$>) = Full.mapUpDefault++instance (Transformation (Keep t), Domain (Keep t) ~ f, Functor f, Codomain (Keep t) ~ PreservingSemantics (Keep t) f,+          Functor f, Deep.Functor (Keep t) g,+          Keep t `At` g (PreservingSemantics (Keep t) f) (PreservingSemantics (Keep t) f)) =>+         Full.Functor (Keep t) g where+   (<$>) = Full.mapUpDefault+ instance {-# overlappable #-} (Bequether (Auto t) g d s, Synthesizer (Auto t) g d s) => Attribution (Auto t) g d s where    attribution t l (Inherited i, s) = (Synthesized $ synthesis t l i s, bequest t l i s) -class (Transformation t, dom ~ Domain t) => Revelation t dom where+class Transformation t => Revelation t where    -- | Extract the value from the transformation domain-   reveal :: t -> dom x -> x+   reveal :: t -> Domain t x -> x  -- | A half of the 'Attribution' class used to specify all inherited attributes. class Bequether t g deep shallow where@@ -59,7 +103,7 @@ class Synthesizer t g deep shallow where    synthesis   :: forall sem. sem ~ Semantics t =>                   t                                -- ^ transformation        -               -> shallow (g deep deep)            -- ^ tre node+               -> shallow (g deep deep)            -- ^ tree node                -> Atts (Inherited t) (g sem sem)   -- ^ inherited attributes                  -> g sem (Synthesized t)            -- ^ synthesized attributes                -> Atts (Synthesized t) (g sem sem)@@ -74,13 +118,7 @@                      -> g sem (Synthesized t)           -- ^ synthesized attributes                      -> result -instance (Transformation t, Domain t ~ Identity) => Revelation t Identity where-   reveal _ (Identity x) = x--instance (Transformation t, Domain t ~ (,) a) => Revelation t ((,) a) where-   reveal _ (_, x) = x--instance {-# overlappable #-} (sem ~ Semantics t, Domain t ~ shallow, Revelation t shallow,+instance {-# overlappable #-} (sem ~ Semantics t, Domain t ~ shallow, Revelation t,                                Shallow.Functor (PassDown t sem (Atts (Inherited t) (g sem sem))) (g sem)) =>                               Bequether t g (Semantics t) shallow where    bequest = bequestDefault@@ -231,7 +269,7 @@ -- | The default 'bequest' method definition relies on generics to automatically pass down all same-named inherited -- attributes. bequestDefault :: forall t g shallow sem.-                  (sem ~ Semantics t, Domain t ~ shallow, Revelation t shallow,+                  (sem ~ Semantics t, Domain t ~ shallow, Revelation t,                    Shallow.Functor (PassDown t sem (Atts (Inherited t) (g sem sem))) (g sem))                => t -> shallow (g sem sem) -> Atts (Inherited t) (g sem sem) -> g sem (Synthesized t)                -> g sem (Inherited t)

@@ -0,0 +1,153 @@+{-# 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{+   inh :: a,+   syn :: a}+   deriving (Data, Typeable, Show)++instance Semigroup a => Semigroup (Atts a) where+   Atts i1 s1 <> Atts i2 s2 = Atts (i1 <> i2) (s1 <> s2)++instance Monoid a => Monoid (Atts a) where+   mappend = (<>)+   mempty = Atts mempty 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 = const (const 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+   ($) = applyDefault (foldr const $ error "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+   ($) = 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+   (<$>) = 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+   (<$>) = 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 = 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 r chSem = Const knitted+   where knitted inherited = synthesized+            where Atts{syn= synthesized, inh= chInh} = r Atts{inh= inherited, syn= chSyn}+                  chSyn = Rank2.foldMap (($ chInh) . getConst) 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 r x = Compose knitted+   where knitted :: a -> Compose ((,) (Atts a)) f (g sem sem)+         knitted inherited = Compose (results, x)+            where results@Atts{inh= chInh} = r Atts{inh= inherited, syn= chSyn}+                  chSyn = foldMap (Rank2.foldMap (syn . fst . getCompose . ($ chInh) . getCompose)) 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 extract t x = knit (attribution t x) (extract 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 extract t local = knit (attribution t local) (t Deep.<$> extract 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 x = knitKeeping (attribution t x) 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 x rootInheritance = Full.traverse Feeder (t Full.<$> x) 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 $ x = x++instance (Traversable f, Deep.Traversable (Feeder a f) g) => Full.Traversable (Feeder a f) g where+   traverse t x inheritance = Compose (atts{inh= inheritance}, traverse (Deep.traverse t) y (inh atts))+      where Compose (atts, y) = getCompose x inheritance

@@ -12,6 +12,7 @@ import Data.Data (Data, Typeable) import Data.Functor.Compose (Compose) import Data.Functor.Const (Const)+import qualified Data.Functor as Rank1 import qualified Rank2 import qualified Data.Functor import           Transformation (Transformation, Domain, Codomain)@@ -22,6 +23,7 @@ -- | Like "Transformation.Shallow".'Transformation.Shallow.Functor' except it maps all descendants and not only immediate children class (Transformation t, Rank2.Functor (g (Domain t))) => Functor t g where    (<$>) :: t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)+   infixl 4 <$>  -- | Like "Transformation.Shallow".'Transformation.Shallow.Foldable' except it folds all descendants and not only immediate children class (Transformation t, Rank2.Foldable (g (Domain t))) => Foldable t g where@@ -32,10 +34,14 @@    traverse :: Codomain t ~ Compose m f => t -> g (Domain t) (Domain t) -> m (g f f)  -- | Like 'Data.Functor.Product.Product' for data types with two type constructor parameters-data Product g1 g2 (p :: * -> *) (q :: * -> *) = Pair{fst :: q (g1 p p),-                                                      snd :: q (g2 p p)}+data Product g h (d :: * -> *) (s :: * -> *) = Pair{fst :: s (g d d),+                                                    snd :: s (h d d)} -instance Rank2.Functor (Product g1 g2 p) where+-- | Like 'Data.Functor.Sum.Sum' for data types with two type constructor parameters+data Sum g h (d :: * -> *) (s :: * -> *) = InL (s (g d d))+                                         | InR (s (h d d))++instance Rank2.Functor (Product g h p) where    f <$> ~(Pair left right) = Pair (f left) (f right)  instance Rank2.Apply (Product g h p) where@@ -68,6 +74,40 @@                    Data (q (g1 p p)), Data (q (g2 p p))) => Data (Product g1 g2 p q) deriving instance (Show (q (g1 p p)), Show (q (g2 p p))) => Show (Product g1 g2 p q) +instance Rank2.Functor (Sum g h p) where+   f <$> InL left = InL (f left)+   f <$> InR right = InR (f right)++instance Rank2.Foldable (Sum g h p) where+   foldMap f (InL left) = f left+   foldMap f (InR right) = f right++instance Rank2.Traversable (Sum g h p) where+   traverse f (InL left) = InL Rank1.<$> f left+   traverse f (InR right) = InR Rank1.<$> f right++instance (Full.Functor t g, Full.Functor t h) => Functor t (Sum g h) where+   t <$> InL left = InL (t Full.<$> left)+   t <$> InR right = InR (t Full.<$> right)++instance (Full.Foldable t g, Full.Foldable t h, Codomain t ~ Const m) => Foldable t (Sum g h) where+   foldMap t (InL left) = Full.foldMap t left+   foldMap t (InR right) = Full.foldMap t right++instance (Full.Traversable t g, Full.Traversable t h, Codomain t ~ Compose m f, Applicative m) =>+         Traversable t (Sum g h) where+   traverse t (InL left) = InL Rank1.<$> Full.traverse t left+   traverse t (InR right) = InR Rank1.<$> Full.traverse t right++deriving instance (Typeable p, Typeable q, Typeable g1, Typeable g2,+                   Data (q (g1 p p)), Data (q (g2 p p))) => Data (Sum g1 g2 p q)+deriving instance (Show (q (g1 p p)), Show (q (g2 p p))) => Show (Sum g1 g2 p q)+ -- | Alphabetical synonym for '<$>' fmap :: Functor t g => t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t) fmap = (<$>)++-- | Equivalent of 'Data.Either.either'+eitherFromSum :: Sum g h d s -> Either (s (g d d)) (s (h d d))+eitherFromSum (InL left) = Left left+eitherFromSum (InR right) = Right right

@@ -6,7 +6,7 @@ -- > $(Transformation.Deep.TH.deriveFunctor ''MyDataType) -- -{-# Language TemplateHaskell #-}+{-# Language CPP, TemplateHaskell #-} -- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial  module Transformation.Deep.TH (deriveAll, deriveFunctor, deriveTraversable)@@ -95,11 +95,18 @@       NewtypeD _ nm tyVars kind c _ -> return (nm, tyVars, kind, [c])       _ -> fail "deriveApply: tyCon may not be a type synonym." +#if MIN_VERSION_template_haskell(2,17,0)+   let (KindedTV tyVar _ (AppT (AppT ArrowT StarT) StarT) :+        KindedTV tyVar' _ (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars+       apply t (PlainTV name _)    = appT t (varT name)+       apply t (KindedTV name _ _) = appT t (varT name)+#else    let (KindedTV tyVar  (AppT (AppT ArrowT StarT) StarT) :         KindedTV tyVar' (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars-       instanceType           = foldl apply (conT tyConName) (reverse $ drop 2 $ reverse tyVars)        apply t (PlainTV name)    = appT t (varT name)        apply t (KindedTV name _) = appT t (varT name)+#endif+       instanceType           = foldl apply (conT tyConName) (reverse $ drop 2 $ reverse tyVars)     putQ (Deriving tyConName tyVar' tyVar)    return (instanceType, cs)

@@ -22,6 +22,7 @@ -- | Like "Transformation.Deep".'Deep.Functor' except it maps an additional wrapper around the entire tree class (Transformation t, Rank2.Functor (g (Domain t))) => Functor t g where    (<$>) :: t -> Domain t (g (Domain t) (Domain t)) -> Codomain t (g (Codomain t) (Codomain t))+   infixl 4 <$>  -- | Like "Transformation.Deep".'Deep.Foldable' except the entire tree is also wrapped class (Transformation t, Rank2.Foldable (g (Domain t))) => Foldable t g where@@ -49,9 +50,9 @@                                          Codomain t ~ Const m, Data.Foldable.Foldable (Domain t), Monoid m)                                      => t -> Domain t (g (Domain t) (Domain t)) -> m -- | Default implementation for 'foldMap' that folds the wrapper and then the tree-foldMapDownDefault t x = getConst (t Transformation.$ x) <> Data.Foldable.foldMap (Deep.foldMap t) x+foldMapDownDefault t x = getConst (t Transformation.$ x) `mappend` Data.Foldable.foldMap (Deep.foldMap t) x -- | Default implementation for 'foldMap' that folds the tree and then the wrapper-foldMapUpDefault   t x = Data.Foldable.foldMap (Deep.foldMap t) x <> getConst (t Transformation.$ x)+foldMapUpDefault   t x = Data.Foldable.foldMap (Deep.foldMap t) x `mappend` getConst (t Transformation.$ x)  -- | Default implementation for 'traverse' that traverses the wrapper and then the tree traverseDownDefault :: (Deep.Traversable t g, t `Transformation.At` g (Domain t) (Domain t),

@@ -15,6 +15,7 @@ -- | Transform (naturally) the containing functor of every node in the given tree. (<$>) :: Deep.Functor (Map p q) g => (forall a. p a -> q a) -> g p p -> g q q (<$>) f = (Deep.<$>) (Map f)+infixl 4 <$>  -- | Fold the containing functor of every node in the given tree. foldMap :: (Deep.Foldable (Fold p m) g, Monoid m) => (forall a. p a -> m) -> g p p -> m

@@ -18,6 +18,7 @@ -- | Like Rank2.'Rank2.Functor' except it takes a 'Transformation' instead of a polymorphic function class (Transformation t, Rank2.Functor g) => Functor t g where    (<$>) :: t -> g (Domain t) -> g (Codomain t)+   infixl 4 <$>  -- | Like Rank2.'Rank2.Foldable' except it takes a 'Transformation' instead of a polymorphic function class (Transformation t, Rank2.Foldable g) => Foldable t g where@@ -31,7 +32,7 @@    t <$> Rank2.Pair left right = Rank2.Pair (t <$> left) (t <$> right)  instance (Foldable t g, Foldable t h, Codomain t ~ Const m, Monoid m) => Foldable t (Rank2.Product g h) where-   foldMap t (Rank2.Pair left right) = foldMap t left <> foldMap t right+   foldMap t (Rank2.Pair left right) = foldMap t left `mappend` foldMap t right  instance (Traversable t g, Traversable t h, Codomain t ~ Compose m f, Applicative m) => Traversable t (Rank2.Product g h) where    traverse t (Rank2.Pair left right) = liftA2 Rank2.Pair (traverse t left) (traverse t right)

@@ -6,7 +6,7 @@ -- > $(Transformation.Shallow.TH.deriveFunctor ''MyDataType) -- -{-# Language TemplateHaskell #-}+{-# Language CPP, TemplateHaskell #-} -- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial  module Transformation.Shallow.TH (deriveAll, deriveFunctor, deriveFoldable, deriveTraversable)@@ -91,10 +91,17 @@       NewtypeD _ nm tyVars kind c _ -> return (nm, tyVars, kind, [c])       _ -> fail "deriveApply: tyCon may not be a type synonym." +#if MIN_VERSION_template_haskell(2,17,0)+   let (KindedTV tyVar _ (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars+       instanceType           = foldl apply (conT tyConName) (reverse $ drop 1 $ reverse tyVars)+       apply t (PlainTV name _)    = appT t (varT name)+       apply t (KindedTV name _ _) = appT t (varT name)+#else    let (KindedTV tyVar  (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars        instanceType           = foldl apply (conT tyConName) (reverse $ drop 1 $ reverse tyVars)        apply t (PlainTV name)    = appT t (varT name)        apply t (KindedTV name _) = appT t (varT name)+#endif     putQ (Deriving tyConName tyVar)    return (instanceType, cs)@@ -257,6 +264,8 @@      AppT ty a | ty == VarT typeVar ->         (,) <$> ((:[]) <$> baseConstraint (pure a))             <*> (wrap (varE '(Transformation.$) `appE` trans) `appE` fieldAccess)+     AppT t1 t2 | t2 == VarT typeVar -> (,) <$> traverse shallowConstraint [pure t1]+                                            <*> appE (wrap [| ($trans Transformation.Shallow.<$>) |]) fieldAccess      AppT t1 t2 | t1 /= VarT typeVar ->         genShallowmapField trans t2 shallowConstraint baseConstraint fieldAccess (wrap . appE (varE '(<$>)))      SigT ty _kind -> genShallowmapField trans ty shallowConstraint baseConstraint fieldAccess wrap@@ -272,6 +281,8 @@         (,) <$> ((:[]) <$> baseConstraint (pure a))             <*> (wrap (varE '(.) `appE` varE 'getConst `appE` (varE '(Transformation.$) `appE` trans))                  `appE` fieldAccess)+     AppT t1 t2 | t2 == VarT typeVar -> (,) <$> traverse shallowConstraint [pure t1]+                                            <*> appE (wrap [| (Transformation.Shallow.foldMap $trans) |]) fieldAccess      AppT t1 t2 | t1 /= VarT typeVar ->                   genFoldMapField trans t2 shallowConstraint baseConstraint fieldAccess (wrap . appE (varE 'foldMap))      SigT ty _kind -> genFoldMapField trans ty shallowConstraint baseConstraint fieldAccess wrap@@ -286,6 +297,8 @@         (,) <$> ((:[]) <$> baseConstraint (pure a))             <*> (wrap (varE '(.) `appE` varE 'getCompose `appE` (varE '(Transformation.$) `appE` trans))                  `appE` fieldAccess)+     AppT t1 t2 | t2 == VarT typeVar -> (,) <$> traverse shallowConstraint [pure t1]+                                            <*> appE (wrap [| (Transformation.Shallow.traverse $trans) |]) fieldAccess      AppT t1 t2 | t1 /= VarT typeVar ->         genTraverseField trans t2 shallowConstraint baseConstraint fieldAccess (wrap . appE (varE 'traverse))      SigT ty _kind -> genTraverseField trans ty shallowConstraint baseConstraint fieldAccess wrap

@@ -31,6 +31,7 @@ import Data.Coerce (coerce) import Data.Functor.Const import Data.Functor.Identity+import Data.Monoid import qualified Rank2 import Transformation (Transformation, At) import qualified Transformation@@ -279,11 +280,17 @@    type Domain DeadCodeEliminator = Identity    type Codomain DeadCodeEliminator = AG.Semantics DeadCodeEliminator +instance DeadCodeEliminator `Transformation.At` Decl Sem Sem where+  ($) = AG.applyDefault runIdentity++instance DeadCodeEliminator `Transformation.At` Expr Sem Sem where+  ($) = AG.applyDefault runIdentity+ instance Full.Functor DeadCodeEliminator Decl where-  (<$>) = AG.fullMapDefault runIdentity+  (<$>) = Full.mapUpDefault  instance Full.Functor DeadCodeEliminator Expr where-  (<$>) = AG.fullMapDefault runIdentity+  (<$>) = Full.mapUpDefault ~~~  We also need another bit of a boilerplate instance that can be automatically generated with Template Haskell functions@@ -359,11 +366,11 @@ because they don't have any children.  ~~~ {.haskell}-instance AG.Attribution DeadCodeEliminator Expr Identity Identity where-  attribution DeadCodeEliminator (Identity e@(EVar v)) (AG.Inherited env, _) =-    (AG.Synthesized (maybe e id $ env v), EVar v)-  attribution DeadCodeEliminator (Identity e@(Con n)) (AG.Inherited env, _) =-    (AG.Synthesized e, Con n)+instance AG.Attribution DeadCodeEliminator Expr Sem Identity where+  attribution DeadCodeEliminator (Identity (EVar v)) (AG.Inherited env, _) =+    (AG.Synthesized (maybe (EVar v) id $ env v), EVar v)+  attribution DeadCodeEliminator (Identity (Con n)) (AG.Inherited env, _) =+    (AG.Synthesized (Con n), Con n) ~~~  The `Add` and `Mul` nodes' rules need only to pass their inheritance down and to re-join the synthesized child@@ -388,7 +395,7 @@   attribution DeadCodeEliminator (Identity (Let _decl expr))               (AG.Inherited env, (Let (AG.Synthesized ~(env', decl')) (AG.Synthesized expr'))) =     (AG.Synthesized (maybe id (bin Let) decl' expr'),-     Let (AG.Inherited (env, Full.foldMap GetVariables expr)) (AG.Inherited $ \v-> env' v <|> env v))+     Let (AG.Inherited (env, Deep.foldMap GetVariables expr')) (AG.Inherited $ \v-> env' v <|> env v)) ~~~  ### Declaration rules@@ -396,7 +403,7 @@ The rules for `Decl` are a bit more involved.  ~~~ {.haskell}-instance AG.Attribution DeadCodeEliminator Decl Identity Identity where+instance AG.Attribution DeadCodeEliminator Decl Sem Identity where ~~~  A single variable binding can be in three distinct situations. If the variable is not referenced at all, we can just

@@ -1,4 +1,4 @@-{-# Language FlexibleInstances, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, +{-# Language FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, StandaloneDeriving,              TypeFamilies, UndecidableInstances #-}  -- | The RepMin example - replicate a binary tree with all leaves replaced by the minimal leaf value.@@ -35,7 +35,7 @@    Leaf f <*> ~(Leaf x) = Leaf (Rank2.apply f x)  instance Rank2.Applicative (Tree a f') where-   pure = Leaf+   pure x = Leaf x  instance Rank2.Apply (Root a f') where    Root f <*> ~(Root x) = Root (Rank2.apply f x)@@ -50,9 +50,11 @@ -- | The transformation type data RepMin = RepMin +type Sem = AG.Semantics RepMin+ instance Transformation RepMin where    type Domain RepMin = Identity-   type Codomain RepMin = AG.Semantics RepMin+   type Codomain RepMin = Sem  -- | Inherited attributes' type data InhRepMin = InhRepMin{global :: Int}@@ -68,24 +70,29 @@ type instance AG.Atts (Inherited RepMin) (Root Int f' f) = () type instance AG.Atts (Synthesized RepMin) (Root Int f' f) = SynRepMin -type instance AG.Atts (Inherited a) Int = ()-type instance AG.Atts (Synthesized a) Int = Int+type instance AG.Atts (Inherited RepMin) Int = ()+type instance AG.Atts (Synthesized RepMin) Int = Int +instance Transformation.At RepMin (Tree Int Sem Sem) where+  ($) = AG.applyDefault runIdentity+instance Transformation.At RepMin (Root Int Sem Sem) where+  ($) = AG.applyDefault runIdentity+ instance Full.Functor RepMin (Tree Int) where-  (<$>) = AG.fullMapDefault runIdentity+  (<$>) = Full.mapUpDefault instance Full.Functor RepMin (Root Int) where-  (<$>) = AG.fullMapDefault runIdentity+  (<$>) = Full.mapUpDefault  -- | The semantics of the primitive 'Int' type must be defined manually. instance Transformation.At RepMin Int where    RepMin $ Identity n = Rank2.Arrow (const $ Synthesized n) -instance AG.Attribution RepMin (Root Int) Identity Identity where+instance AG.Attribution RepMin (Root Int) Sem Identity where    attribution RepMin self (inherited, Root root) = (Synthesized SynRepMin{local= local (syn root),                                                                            tree= tree (syn root)},                                                      Root{root= Inherited InhRepMin{global= local (syn root)}}) -instance AG.Attribution RepMin (Tree Int) Identity Identity where+instance AG.Attribution RepMin (Tree Int) Sem Identity where    attribution _ _ (inherited, Fork left right) = (Synthesized SynRepMin{local= local (syn left)                                                                                 `min` local (syn right),                                                                          tree= tree (syn left) `fork` tree (syn right)},

@@ -1,4 +1,4 @@-{-# Language DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleInstances, MultiParamTypeClasses, RankNTypes,+{-# Language DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes,              StandaloneDeriving, TemplateHaskell, TypeFamilies, UndecidableInstances #-}  -- | The RepMin example with automatic derivation of attributes.@@ -36,10 +36,6 @@         [Rank2.TH.deriveFunctor, Rank2.TH.deriveFoldable, Rank2.TH.deriveTraversable, Rank2.TH.unsafeDeriveApply,          Transformation.Shallow.TH.deriveAll, Transformation.Deep.TH.deriveAll])) -instance (Transformation t, Transformation.At t a, Transformation.At t (Tree a (Codomain t) (Codomain t)),-          Functor (Domain t)) => Full.Functor t (Tree a) where-   (<$>) = Full.mapUpDefault- -- | The transformation type. It will always appear wrapped in 'Auto' to enable automatic attribute derivation. data RepMin = RepMin @@ -50,6 +46,9 @@    type Domain (Auto RepMin) = Identity    type Codomain (Auto RepMin) = Sem +instance AG.Revelation (Auto RepMin) where+   reveal (Auto RepMin) = runIdentity+    -- | Inherited attributes' type data InhRepMin = InhRepMin{global :: Int}                deriving (Generic, Show)@@ -66,18 +65,13 @@                              tree :: AG.Mapped Identity Int}                   deriving (Generic, Show) -type instance AG.Atts (Inherited (Auto RepMin)) (Tree Int f' f) = InhRepMin-type instance AG.Atts (Synthesized (Auto RepMin)) (Tree Int f' f) = SynRepMin Tree-type instance AG.Atts (Inherited (Auto RepMin)) (Root Int f' f) = ()-type instance AG.Atts (Synthesized (Auto RepMin)) (Root Int f' f) = SynRepMin Root--type instance AG.Atts (Inherited a) Int = InhRepMin-type instance AG.Atts (Synthesized a) Int = SynRepLeaf+type instance AG.Atts (Inherited RepMin) (Tree Int f' f) = InhRepMin+type instance AG.Atts (Synthesized RepMin) (Tree Int f' f) = SynRepMin Tree+type instance AG.Atts (Inherited RepMin) (Root Int f' f) = ()+type instance AG.Atts (Synthesized RepMin) (Root Int f' f) = SynRepMin Root -instance Transformation.At (Auto RepMin) (Tree Int Sem Sem) where-   ($) = AG.applyDefault runIdentity-instance Transformation.At (Auto RepMin) (Root Int Sem Sem) where-   ($) = AG.applyDefault runIdentity+type instance AG.Atts (Inherited RepMin) Int = InhRepMin+type instance AG.Atts (Synthesized RepMin) Int = SynRepLeaf  -- | The semantics of the primitive 'Int' type must be defined manually. instance Transformation.At (Auto RepMin) Int where