deep-transformations 0.3 → 0.4

raw patch · 17 files changed

+633/−487 lines, 17 filesdep −doctestdep ~generic-lensdep ~rank2classessetup-changed

Dependencies removed: doctest

Dependency ranges changed: generic-lens, rank2classes

Files

• CHANGELOG.md +48/−0
• README.md +63/−35
• Setup.hs +2/−6
• deep-transformations.cabal +11/−18
• src/Transformation.hs +14/−3
• src/Transformation/AG.hs +91/−70
• src/Transformation/AG/Dimorphic.hs +59/−104
• src/Transformation/AG/Generics.hs +71/−108
• src/Transformation/AG/Monomorphic.hs +18/−45
• src/Transformation/Deep.hs +9/−2
• src/Transformation/Full.hs +7/−1
• src/Transformation/Rank2.hs +0/−5
• test/Doctest.hs +0/−8
• test/README.lhs +63/−35
• test/RepMin.hs +29/−27
• test/RepMinAuto.hs +18/−20
• test/RepMinKeepAG.hs +130/−0

@@ -1,5 +1,53 @@ # Revision history for deep-transformations +## 0.4 -- 2025-10-26++### **BREAKING**++Major type changes:++* Moved the `attribution` method from the `AG.Attribution` class to the new `AG.At` class+* Changed the kind of the second parameter of the `AG.Atts` type family from `Type` to `(Type -> Type) -> (Type ->+  Type) -> Type`+* As a consequence, removed the two deep&shallow type parameters of the `AG.Attribution` and `AG.At` classes+* Adopted the same naming scheme in `AG.Dimorphic` and `AG.Monomorphic`+* Dropped functions `applyDefault`, and `applyDefaultWithAttributes` from `Transformation.AG`++Major reorganization of the data types around the `Keep` semantics:++* Dropped `PreservingSemantics` from `AG`, `Monomorphic`, and `Dimorphic` modules+* Dropped `AG.knitKeeping`, making `AG.Keep` an attribution wrapper instead+* Dropped `Keep` from `Mono`/`Dimorphic` modules+* Replaced `AG.AllAtts` with the `AG.Kept` data type+* Introduced the `AG.Kept` attribute synthesized by the `AG.Keep` transformation wrapper++Breaking instance changes:++* Strengthened the `Foldable` constraint on the `attribution` method to `Traversable`+* Made the default `Bequether` & `Synthesizer` instances specific to `Auto`+* Dropped the fixed instance `Full.Functor (Transformation.Rank2.Map p q)`++### Additions++* the `AG.Knit` transformation+* `Transformation.Coercion` and `Full.coerce`+* the wrapper `Dimorphic.T` separate from `Dimorphic.Auto`+* the `Origin` associated type+* `mapInherited` and `mapSynthesized`+* `Semigroup` and `Monoid` instances for `Inherited` and `Synthesized`+* `Deep.Const2`+* `instance Attribution (Keep t)`++### Other improvements++* Added `test/RepMinKeep ` and `test/RepMinKeepAG`+* Bumped the lower bound of the `rank2classes` dependency to require the new `Rank2.coerce` method+* Bumped the upper bound of the `generic-lens` dependency+* Expanded documentation+* Fixed the Transformation doctests for docspec+* Turned `doctests` from a testsuite into a named library, dropped `cabal-doctest`+* Updated GitHub CI action+ ## 0.3 -- 2025-01-01  * **BREAKING**: Changed the definitions of `Deep.Product` and `Deep.Sum`

@@ -29,6 +29,7 @@ ~~~ {.haskell} import Control.Applicative import Data.Coerce (coerce)+import Data.Functor.Compose import Data.Functor.Const import Data.Functor.Identity import Data.Monoid@@ -111,11 +112,22 @@   f `foldMap` Mul x y = f x <> f y   f `foldMap` Let d e = f d <> f e   f `foldMap` EVar v  = mempty++instance Rank2.Traversable (Decl f') where+  f `traverse` (v := e) = (v :=) <$> f e+  f `traverse` Seq x y  = Seq <$> f x <*> f y++instance Rank2.Traversable (Expr f') where+  f `traverse` Con n   = pure (Con n)+  f `traverse` Add x y = Add <$> f x <*> f y+  f `traverse` Mul x y = Mul <$> f x <*> f y+  f `traverse` Let d e = Let <$> f d <*> f e+  f `traverse` EVar v  = pure (EVar v) ~~~ -While the methods declared above can be handy, they are limited in requiring that the function argument `f` must be- polymorphic in the wrapped field type. In other words, it cannot behave one way for an `Expr` and another for a- `Decl`. That can be a severe handicap.+While the methods declared above can be handy, they are limited because they require that the function argument `f`+ must be polymorphic in the wrapped field type. In other words, it cannot behave one way for an `Expr` and another+ for a `Decl`. That can be a severe handicap.  The class methods exported by `deep-transformations` therefore work not with polymorphic functions but with *transformations*. The instances of these classes are similar to the 'Rank2' instances above. Also as above, they can@@ -144,6 +156,19 @@   t `foldMap` Mul x y = t `Full.foldMap` x <> t `Full.foldMap` y   t `foldMap` Let d e = t `Full.foldMap` d <> t `Full.foldMap` e   t `foldMap` EVar v  = mempty++instance (Transformation t, Transformation.Codomain t ~ Compose m f, Applicative m,+          Full.Traversable t Decl, Full.Traversable t Expr) => Deep.Traversable t Decl where+  t `traverse` (v := e) = (v :=) <$> t `Full.traverse` e+  t `traverse` Seq x y  = Seq <$> t `Full.traverse` x <*> t `Full.traverse` y++instance (Transformation t, Transformation.Codomain t ~ Compose m f, Applicative m,+          Full.Traversable t Decl, Full.Traversable t Expr) => Deep.Traversable t Expr where+  t `traverse` Con n   = pure (Con n)+  t `traverse` Add x y = Add <$> t `Full.traverse` x <*> t `Full.traverse` y+  t `traverse` Mul x y = Mul <$> t `Full.traverse` x <*> t `Full.traverse` y+  t `traverse` Let d e = Let <$> t `Full.traverse` d <*> t `Full.traverse` e+  t `traverse` EVar v  = pure (EVar v) ~~~  Once the above boilerplate code is written or generated, no further boilerplate need be written.@@ -268,29 +293,29 @@  grammar. We can build one with the tools from  [`Transformation.AG`](https://hackage.haskell.org/package/deep-transformations/docs/Transformation-AG.html). -First we declare another transformation, just like before. Its `Codomain` will now be something called the attribute- grammar semantics, and it performs bottom-up.--~~~ {.haskell}-data DeadCodeEliminator = DeadCodeEliminator+Instead of declaring another transformation like before, this time we'll use a predefined transformation called+ `Knit`. Its `Codomain` will now be something called the attribute grammar semantics. It requires a parameter data+ type, an instance of `Attribution`. The associated type `Origin` of the parameter is also the `Domain` of the+ `Knit` transformation. -type Sem = AG.Semantics DeadCodeEliminator+~~~ {.haskell.ignore}+newtype Knit t = Knit t -instance Transformation DeadCodeEliminator where-   type Domain DeadCodeEliminator = Identity-   type Codomain DeadCodeEliminator = AG.Semantics DeadCodeEliminator+instance AG.Attribution t => Transformation (Knit t) where+   type Domain (Knit t) = AG.Origin t+   type Codomain (Knit t) = Semantics t -instance DeadCodeEliminator `Transformation.At` Decl Sem Sem where-  ($) = AG.applyDefault runIdentity+type Semantics t = Inherited t Rank2.~> Synthesized t+~~~ -instance DeadCodeEliminator `Transformation.At` Expr Sem Sem where-  ($) = AG.applyDefault runIdentity+As noted above, we need a new data type to make an `Attribution` instance. Let's call it `DeadCodeEliminator`. -instance Full.Functor DeadCodeEliminator Decl where-  (<$>) = Full.mapUpDefault+~~~ {.haskell}+data DeadCodeEliminator = DeadCodeEliminator -instance Full.Functor DeadCodeEliminator Expr where-  (<$>) = Full.mapUpDefault+instance AG.Attribution DeadCodeEliminator where+   type Origin DeadCodeEliminator = Identity+   unwrap DeadCodeEliminator = runIdentity ~~~  We also need another bit of a boilerplate instance that can be automatically generated with Template Haskell functions@@ -309,6 +334,9 @@   Mul x1 y1 <*> ~(Mul x2 y2) = Mul (Rank2.apply x1 x2) (Rank2.apply y1 y2) ~~~ +That's all the setup, the rest of the implementation consists of the actual attribute definitions specific to our+needs.+ ### Attributes  Every type of node can have different inherited and synthesized attributes, so we need to declare what they are. Since@@ -318,14 +346,14 @@  ~~~ {.haskell} type Env = Var -> Maybe (Expr Identity Identity)-type instance AG.Atts (AG.Inherited DeadCodeEliminator) (Expr _ _) = Env+type instance AG.Atts (AG.Inherited DeadCodeEliminator) Expr = Env ~~~  A declaration will also need to inherit the environment, if only to pass it on to the nested expressions. Because we  want to discard useless assignments, it will also need to know the list of all referenced variables.  ~~~ {.haskell}-type instance AG.Atts (AG.Inherited DeadCodeEliminator) (Decl _ _) = (Env, [Var])+type instance AG.Atts (AG.Inherited DeadCodeEliminator) Decl = (Env, [Var]) ~~~  A `Decl` needs to synthesize the environment of constant bindings it generates itself, as well as a modified@@ -333,7 +361,7 @@  need to wrap it in a `Maybe`.  ~~~ {.haskell}-type instance AG.Atts (AG.Synthesized DeadCodeEliminator) (Decl _ _) = (Env, Maybe (Decl Identity Identity))+type instance AG.Atts (AG.Synthesized DeadCodeEliminator) Decl = (Env, Maybe (Decl Identity Identity)) ~~~  All declarations inside an `Expr` need to be trimmed, so the `Expr` itself may be simplified but never completely@@ -342,20 +370,20 @@  easier to reuse the existing `GetVariables` transformation.  ~~~ {.haskell}-type instance AG.Atts (AG.Synthesized DeadCodeEliminator) (Expr _ _) = Expr Identity Identity+type instance AG.Atts (AG.Synthesized DeadCodeEliminator) Expr = Expr Identity Identity ~~~ -Now we need to describe how to calculate the attributes, by declaring `Attribution` instances of the node types. The- method `attribution` takes as arguments: the transformation - in this case `DeadCodeEliminator`, the node, the node's- inherited attributes, and the synthesized attributes of all the node's children grouped under the node- constructor. The last two inputs are grouped in a pair for symmetry with the function result, which is a pair of the- node's synthesized attributes and the inherited attributes for all the node's children grouped under the node+Now we need to describe how to calculate the attributes, by declaring the `At` instances of the node+ types. The method `attribution` takes as arguments: the transformation - in this case `DeadCodeEliminator`, the+ node, the node's inherited attributes, and the synthesized attributes of all the node's children grouped under the+ node constructor. The last two inputs are grouped in a pair for symmetry with the function result, which is a pair+ of the node's synthesized attributes and the inherited attributes for all the node's children grouped under the node  constructor. Perhaps this can be more succintly illustrated by the method's type signature:  ~~~ {.haskell.ignore}-class Attribution t g deep shallow where-   attribution :: sem ~ (Inherited t Rank2.~> Synthesized t)-               => t -> shallow (g deep deep)+class Attribution t => At t g where+   attribution :: forall sem. Rank2.Traversable (g sem)+               => t -> Origin t (g sem sem)                -> (Inherited   t (g sem sem), g sem (Synthesized t))                -> (Synthesized t (g sem sem), g sem (Inherited t)) ~~~@@ -366,7 +394,7 @@ because they don't have any children.  ~~~ {.haskell}-instance AG.Attribution DeadCodeEliminator Expr Sem Identity where+instance DeadCodeEliminator `AG.At` Expr 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, _) =@@ -403,7 +431,7 @@ The rules for `Decl` are a bit more involved.  ~~~ {.haskell}-instance AG.Attribution DeadCodeEliminator Decl Sem Identity where+instance DeadCodeEliminator `AG.At` Decl where ~~~  A single variable binding can be in three distinct situations. If the variable is not referenced at all, we can just@@ -438,7 +466,7 @@  ~~~ {.haskell} -- |--- >>> let s = Full.fmap DeadCodeEliminator (Identity $ bin Let d1 e1) `Rank2.apply` AG.Inherited (const Nothing)+-- >>> let s = Full.fmap (AG.Knit DeadCodeEliminator) (Identity $ bin Let d1 e1) `Rank2.apply` AG.Inherited (const Nothing) -- >>> s -- Synthesized {syn = Add (Identity (Con 42)) (Identity (Add (Identity (Mul (Identity (Con 42)) (Identity (Con 68)))) (Identity (Con 7))))} -- >>> Full.fmap ConstantFold $ Identity $ AG.syn s

@@ -1,6 +1,2 @@-module Main where--import Distribution.Extra.Doctest (defaultMainWithDoctests)--main :: IO ()-main = defaultMainWithDoctests "doctests"+import Distribution.Simple+main = defaultMain

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                deep-transformations-version:             0.3+version:             0.4 synopsis:            Deep natural and unnatural tree transformations, including attribute grammars description: @@ -20,18 +20,13 @@ maintainer:          blamario@protonmail.com copyright:           (c) 2019 Mario Blažević category:            Control, Generics-build-type:          Custom-cabal-version:       >=1.10-tested-with:         GHC==9.8.2, GHC==9.6.4, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7+build-type:          Simple+cabal-version:       2.0+tested-with:         GHC==9.12.2, GHC==9.10.2, GHC==9.8.4, GHC==9.6.7, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7 extra-source-files:  README.md, CHANGELOG.md source-repository head   type:              git   location:          https://github.com/blamario/grampa-custom-setup- setup-depends:-   base >= 4 && <5,-   Cabal < 4,-   cabal-doctest >= 1 && <1.1  library   hs-source-dirs:       src@@ -43,18 +38,16 @@                         Transformation.AG, Transformation.AG.Generics,                         Transformation.AG.Monomorphic, Transformation.AG.Dimorphic   ghc-options:         -Wall-  build-depends:        base >= 4.11 && < 5, rank2classes >= 1.4.1 && < 1.6,+  build-depends:        base >= 4.11 && < 5, rank2classes >= 1.5.5 && < 1.6,                         transformers >= 0.5 && < 0.7,-                        template-haskell >= 2.11 && < 2.24, generic-lens >= 1.2 && < 2.3+                        template-haskell >= 2.11 && < 2.24, generic-lens >= 1.2 && < 2.4   default-language:     Haskell2010 -test-suite doctests-  type:                exitcode-stdio-1.0+library doctests   hs-source-dirs:      test   default-language:    Haskell2010-  main-is:             Doctest.hs-  other-modules:       README, RepMin, RepMinAuto+  default-extensions:  FlexibleInstances, MultiParamTypeClasses, TypeFamilies, TypeOperators+  other-modules:       README, RepMin, RepMinAuto, RepMinKeepAG   ghc-options:         -threaded -pgmL markdown-unlit-  build-depends:       base, rank2classes, deep-transformations, doctest >= 0.8-  build-tool-depends:  markdown-unlit:markdown-unlit >= 0.5 && < 0.6-  x-doctest-options:   --fast+  build-depends:       base, rank2classes, deep-transformations+  build-tool-depends:  markdown-unlit:markdown-unlit >= 0.5 && < 0.6, doctest:doctest >= 0.8 && < 1

@@ -26,6 +26,7 @@  module Transformation where +import Data.Coerce (Coercible, coerce) import qualified Data.Functor.Compose as Functor import Data.Functor.Const (Const) import Data.Functor.Product (Product(Pair))@@ -36,19 +37,19 @@ import Prelude hiding (($))  -- $setup--- >>> {-# Language FlexibleInstances, MultiParamTypeClasses, TypeFamilies, TypeOperators #-}+-- >>> :seti -XFlexibleInstances -XMultiParamTypeClasses -XTypeFamilies -XTypeOperators -- >>> import Transformation (Transformation) -- >>> import qualified Transformation+-- >>> data MaybeToList = MaybeToList+-- >>> instance Transformation MaybeToList where {type Domain MaybeToList = Maybe; type Codomain MaybeToList = []}  -- | A 'Transformation', natural or not, maps one functor to another. -- For example, here's the declaration for a transformation that maps `Maybe` to `[]`: ----- >>> :{ -- data MaybeToList = MaybeToList -- instance Transformation MaybeToList where --    type Domain MaybeToList = Maybe --    type Codomain MaybeToList = []--- :} class Transformation t where    type Domain t :: Type -> Type    type Codomain t :: Type -> Type@@ -82,6 +83,9 @@ apply :: t `At` x => t -> Domain t x -> Codomain t x apply = ($) +-- | Transformation that coerces a @p x@ to @q x@+data Coercion (p :: Type -> Type) (q :: Type -> Type) = Coercion+ -- | Composition of two transformations data Compose t u = Compose t u @@ -94,6 +98,10 @@ -- | Transformation under a 'Traversable' newtype Traversed (f :: Type -> Type) t = Traversed t +instance Transformation (Coercion p q) where+   type Domain (Coercion p q) = p+   type Codomain (Coercion p q) = q+ instance (Transformation t, Transformation u, Domain t ~ Codomain u) => Transformation (Compose t u) where    type Domain (Compose t u) = Domain u    type Codomain (Compose t u) = Codomain t@@ -110,6 +118,9 @@    type Domain (Traversed f t) = Functor.Compose f (Domain t)    type Codomain (Traversed f t) =       Functor.Compose (ComposeOuter (Codomain t)) (Functor.Compose f (ComposeInner (Codomain t)))++instance Coercible (p x) (q x) => Coercion p q `At` x where+   Coercion $ x = coerce x  type family ComposeOuter (c :: Type -> Type) :: Type -> Type where    ComposeOuter (Functor.Compose p q) = p

@@ -1,6 +1,6 @@-{-# Language FlexibleContexts, FlexibleInstances,-             MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving,-             TypeFamilies, TypeOperators, UndecidableInstances #-}+{-# Language FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes,+             MultiParamTypeClasses, NamedFieldPuns, RankNTypes, ScopedTypeVariables, StandaloneDeriving,+             TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}  -- | An attribute grammar is a particular kind of 'Transformation' that assigns attributes to nodes in a -- tree. Different node types may have different types of attributes, so the transformation is not natural. All@@ -12,69 +12,47 @@ import Unsafe.Coerce (unsafeCoerce)  import qualified Rank2+import Transformation (Transformation, Codomain)+import Transformation.Deep (Const2) import qualified Transformation+import qualified Transformation.Deep as Deep+import qualified Transformation.Full as Full  -- | Type family that maps a node type to the type of its attributes, indexed per type constructor.-type family Atts (f :: Type -> Type) a+type family Atts (f :: Type -> Type) (g :: (Type -> Type) -> (Type -> Type) -> Type) +-- | Type family that lops off the two type parameters+type family NodeConstructor (a :: Type) :: (Type -> Type) -> (Type -> Type) -> Type where+   NodeConstructor (g p q) = g+   NodeConstructor t = Const2 t+ -- | Type constructor wrapping the inherited attributes for the given transformation.-newtype Inherited t a = Inherited{inh :: Atts (Inherited t) a}+newtype Inherited t a = Inherited{inh :: Atts (Inherited t) (NodeConstructor a)} -- | Type constructor wrapping the synthesized attributes for the given transformation.-newtype Synthesized t a = Synthesized{syn :: Atts (Synthesized t) a}+newtype Synthesized t a = Synthesized{syn :: Atts (Synthesized t) (NodeConstructor a)} -deriving instance (Show (Atts (Inherited t) a)) => Show (Inherited t a)-deriving instance (Show (Atts (Synthesized t) a)) => Show (Synthesized t a)+deriving instance (Show (Atts (Inherited t) (NodeConstructor a))) => Show (Inherited t a)+deriving instance (Show (Atts (Synthesized t) (NodeConstructor a))) => Show (Synthesized t a)+deriving instance (Semigroup (Atts (Inherited t) (NodeConstructor a))) => Semigroup (Inherited t a)+deriving instance (Semigroup (Atts (Synthesized t) (NodeConstructor a))) => Semigroup (Synthesized t a)+deriving instance (Monoid (Atts (Inherited t) (NodeConstructor a))) => Monoid (Inherited t a)+deriving instance (Monoid (Atts (Synthesized t) (NodeConstructor a))) => Monoid (Synthesized t a) +mapInherited :: (Atts (Inherited t) (NodeConstructor a) -> Atts (Inherited t) (NodeConstructor b))+             -> Inherited t a -> Inherited t b+mapInherited f (Inherited a) = Inherited (f a)++mapSynthesized :: (Atts (Synthesized t) (NodeConstructor a) -> Atts (Synthesized t) (NodeConstructor b))+               -> Synthesized t a -> Synthesized t b+mapSynthesized f (Synthesized a) = Synthesized (f a)+ -- | A node's 'Semantics' is a natural tranformation from the node's inherited attributes to its synthesized -- 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 (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)-knit r chSem = Rank2.Arrow knit'-   where knit' inherited = synthesized-            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+-- > instance Attribution MyAttGrammar MyNode Identity where -- >   attribution MyAttGrammar{} (Identity MyNode{}) -- >               (Inherited   fromParent, -- >                Synthesized MyNode{firstChild= fromFirstChild, ...})@@ -85,24 +63,67 @@ -- instances of the 'Transformation.AG.Generics.Bequether' and 'Transformation.AG.Generics.Synthesizer' classes -- instead. If you derive 'GHC.Generics.Generic' instances for your attributes, you can even define each synthesized -- attribute individually with a 'Transformation.AG.Generics.SynthesizedField' instance.-class Attribution t g deep shallow where+class Attribution t where+   type Origin t :: Type -> Type+   -- | Unwrap the value from the original attribution domain+   unwrap :: t -> Origin t x -> x++class Attribution t => At t g where    -- | The attribution rule for a given transformation and node.-   attribution :: t -> shallow (g deep deep) -> Rule t g+   attribution :: forall sem. Rank2.Traversable (g sem)+               => t -> Origin t (g sem sem)+               -> (Inherited   t (g sem sem), g sem (Synthesized t))+               -> (Synthesized t (g sem sem), g sem (Inherited t)) --- | Drop-in implementation of 'Transformation.$'-applyDefault :: (q ~ Semantics t, x ~ g q q, Rank2.Apply (g q), Attribution t g q p)-             => (forall a. p a -> a) -> t -> p x -> q x-applyDefault extract t x = knit (attribution t x) (extract x)-{-# INLINE applyDefault #-}+newtype Knit t = Knit t --- | 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 #-}+instance Attribution t => Transformation (Knit t) where+   type Domain (Knit t) = Origin t+   type Codomain (Knit t) = Semantics t++instance (t `At` g, Rank2.Apply (g sem), Rank2.Traversable (g sem), sem ~ Semantics t) =>+         Knit t `Transformation.At` g sem sem where+   Knit t $ x = knit (attribution t x) (unwrap t x)++instance (t `At` g, Rank2.Apply (g (Semantics t)), Rank2.Traversable (g (Semantics t)),+          Functor (Origin t), Rank2.Functor (g (Origin t)), Deep.Functor (Knit t) g) =>+         Full.Functor (Knit t) g where+   (<$>) = Full.mapUpDefault++-- | Transformation wrapper that keeps all the original tree nodes alongside their attributes+newtype Keep t = Keep t deriving (Attribution)++data Kept t a = Kept{inherited   :: Atts (Inherited t) (NodeConstructor a),+                     synthesized :: Atts (Synthesized t) (NodeConstructor a),+                     original    :: Origin t a}++deriving instance (Show (Atts (Inherited t) (NodeConstructor a)),+                   Show (Atts (Synthesized t) (NodeConstructor a)),+                   Show (Origin t a)) => Show (Kept t a)++type instance Atts (Inherited (Keep t)) g = Atts (Inherited t) g+type instance Atts (Synthesized (Keep t)) g = Kept t (g (Kept t) (Kept t))++instance (Rank2.Functor (g (Semantics (Keep t))), Functor (Origin t), t `At` g) => Keep t `At` g where+   attribution (Keep t) x (Inherited i, childSynthesis) = (Synthesized synthesis', childInheritance') where+      (Synthesized s, childInheritance) = attribution t x (Inherited i :: Inherited t (g sem sem),+                                                           resynthesize Rank2.<$> childSynthesis)+      resynthesize :: forall a. Synthesized (Keep t) a -> Synthesized t a+      resynthesize (Synthesized Kept{synthesized}) = Synthesized synthesized+      synthesis' :: Atts (Synthesized (Keep t)) g+      synthesis' = Kept i s ((unsafeCoerce @(g _ (Synthesized (Keep t))) childSynthesis :: g (Kept t) (Kept t)) <$ x)+      childInheritance' :: g sem (Inherited (Keep t))+      childInheritance' = unsafeCoerce @(g _ (Inherited t)) childInheritance++-- | 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 (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)+knit r chSem = Rank2.Arrow knit'+   where knit' inherited = synthesized+            where (synthesized, chInh) = r (inherited, chSyn)+                  chSyn = chSem Rank2.<*> chInh

@@ -1,4 +1,5 @@-{-# Language Haskell2010, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes,+{-# Language Haskell2010, DefaultSignatures, 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@@ -7,25 +8,28 @@ 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 Unsafe.Coerce (unsafeCoerce) import qualified Rank2-import Transformation (Transformation, Domain, Codomain, At)+import Transformation (Transformation, Domain, Codomain) import qualified Transformation import qualified Transformation.Deep as Deep import qualified Transformation.Full as Full+import qualified Transformation.AG as AG --- | Transformation wrapper that allows automatic inference of attribute rules.-newtype Auto t = Auto t+-- | Wrapper that provides a 'Transformation' instance for any 'Attribution'+newtype T t = T t --- | Transformation wrapper that allows automatic inference of attribute rules and preservation of the attribute with--- the original nodes.-newtype Keep t = Keep t+-- | Wrapper that provides a default 'AG.Attribution' and (via AG.Knit) 'Transformation' instance for any 'Attribution'+newtype Auto t = Auto t +-- | Node attributes data Atts a b = Atts{+   -- | inherited    inh :: a,+   -- | synthesized    syn :: b}    deriving (Data, Typeable, Show) @@ -39,119 +43,70 @@ -- | A node's 'Semantics' maps its inherited attribute to its synthesized attribute. type Semantics a b = Const (a -> b) --- | A node's 'PreservingSemantics' maps its inherited attribute to its synthesized attribute.-type PreservingSemantics f a b = Compose ((->) a) (Compose ((,) (Atts a b)) f)---- | An attribution rule maps a node's inherited attribute and its child nodes' synthesized attribute to the node's+-- | An attribution rule maps a node's inherited attribute and its child nodes' synthesized attributes to the node's -- synthesized attribute and the children nodes' inherited attributes. type Rule a b = Atts a b -> Atts a b -instance {-# overlappable #-} Attribution t a b g deep shallow where-   attribution = const (const 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-   ($) = applyDefault (foldr const $ error "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-   ($) = 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-   (<$>) = 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-   (<$>) = 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 = 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 b, Monoid a, Monoid b)-     => Rule a b -> 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 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 r x = Compose knitted-   where knitted :: a -> Compose ((,) (Atts a b)) 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+-- | Class of transformations that assign the same type of inherited and synthesized attributes to every node.+class Attribution t where+   type Origin t :: Type -> Type+   type Inherited t :: Type+   type Synthesized t :: Type+   -- | Unwrap the value from the original attribution domain+   unwrap :: t -> Origin t x -> 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+-- > instance MyAttGrammar `At` MyNode where -- >   attribution MyAttGrammar{} (Identity MyNode{}) -- >               Atts{inh= fromParent, -- >                    syn= fromChildren} -- >             = Atts{syn= toParent, -- >                    inh= toChildren}-class Attribution t a b g (deep :: Type -> Type) shallow where+class Attribution t => At t (g :: (Type -> Type) -> (Type -> Type) -> Type) where    -- | The attribution rule for a given transformation and node.-   attribution :: t -> shallow (g deep deep) -> Rule a b---- | Drop-in implementation of 'Transformation.$'-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 extract t x = knit (attribution t x) (extract x)-{-# INLINE applyDefault #-}+   attribution :: forall f. Rank2.Functor (g f) => t -> Origin t (g f f) -> Rule (Inherited t) (Synthesized t) --- | Drop-in implementation of 'Full.<$>'-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 extract t local = knit (attribution t local) (t Deep.<$> extract local)-{-# INLINE fullMapDefault #-}+instance {-# overlappable #-} Attribution t => At t g where+   attribution = const (const id) --- | Drop-in implementation of 'Transformation.$' that stores all attributes with every original node-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 t x = knitKeeping (attribution t x) x-{-# INLINE applyDefaultWithAttributes #-}+instance {-# overlappable #-} (Attribution t, p ~ Origin t, a ~ Inherited t, b ~ Synthesized t,+                               q ~ Semantics a b, Rank2.Foldable (g q), Rank2.Functor (g q),+                               Monoid a, Monoid b, Foldable p, At t g) =>+                              T t `Transformation.At` g (Semantics a b) (Semantics a b) where+   T t $ x = knit (attribution t x) (unwrap t x)+   {-# INLINE ($) #-} --- | Drop-in implementation of 'Full.traverse' that stores all attributes with every original node-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 t x rootInheritance = Full.traverse Feeder (t Full.<$> x) rootInheritance-{-# INLINE traverseDefaultWithAttributes #-}+instance (Attribution t, At t g, p ~ Origin t, a ~ Inherited t, b ~ Synthesized t, q ~ Semantics a b,+          Monoid a, Monoid b, Foldable p, Functor p,+          Rank2.Foldable (g q), Rank2.Functor (g p), Rank2.Functor (g q), Deep.Functor (T t) g) =>+         Full.Functor (T t) g where+   (<$>) = Full.mapUpDefault -data Feeder (a :: Type) (b :: Type) (f :: Type -> Type) = Feeder+-- | 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 b, Monoid a, Monoid b)+     => Rule a b -> 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 -type FeederDomain (a :: Type) (b :: Type) f = Compose ((->) a) (Compose ((,) (Atts a b)) f)+instance Attribution t => Transformation (T t) where+   type Domain (T t) = Origin t+   type Codomain (T t) = Semantics (Inherited t) (Synthesized t) -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 (Attribution t, Foldable (Origin t)) => AG.Attribution (Auto t) where+   type Origin (Auto t) = Origin t+   unwrap _ = foldr1 const -instance Transformation.At (Feeder a b f) g where-   Feeder $ x = x+type instance AG.Atts (AG.Inherited (Auto t)) g = Inherited t+type instance AG.Atts (AG.Synthesized (Auto t)) g = Synthesized t -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 t x inheritance = Compose (atts{inh= inheritance}, traverse (Deep.traverse t) y (inh atts))-      where Compose (atts, y) = getCompose x inheritance+instance (Attribution t, f ~ Origin t, Foldable f, At t g,+          Rank2.Foldable (g (AG.Semantics (Auto t))), Rank2.Functor (g (AG.Semantics (Auto t))),+          Monoid (Synthesized t)) => Auto t `AG.At` g where+   attribution (Auto t) x (inherited, chSyn) = (AG.Synthesized $ unsafeCoerce $ syn result, unsafeCoerce chInh)+      where result = attribution t x Atts{inh=AG.inh inherited, syn=Rank2.foldMap AG.syn chSyn}+            chInh = uniformInheritance Rank2.<$> foldr const (error "Missing node") x+            uniformInheritance :: forall p a. p a -> AG.Inherited (Auto t) a+            uniformInheritance = const $ AG.Inherited (AG.inh inherited)

@@ -1,5 +1,6 @@ {-# Language DataKinds, DefaultSignatures, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,-             InstanceSigs, MultiParamTypeClasses, PolyKinds, RankNTypes, ScopedTypeVariables, StandaloneDeriving,+             InstanceSigs, MultiParamTypeClasses, PolyKinds, QuantifiedConstraints,+             RankNTypes, ScopedTypeVariables, StandaloneDeriving,              TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}  -- | This module can be used to scrap the boilerplate attribute declarations. In particular:@@ -14,9 +15,9 @@ -- * 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(..), Keep(..), Folded(..), Mapped(..), Traversed(..),+                                   Auto(..), Folded(..), Mapped(..), Traversed(..),                                    -- * Type classes replacing 'Attribution'-                                   Bequether(..), Synthesizer(..), SynthesizedField(..), Revelation(..),+                                   Bequether(..), Synthesizer(..), SynthesizedField(..),                                    -- * The default behaviour on generic datatypes                                    foldedField, mappedField, passDown, bequestDefault) where@@ -31,98 +32,60 @@ import GHC.TypeLits (Symbol, ErrorMessage (Text), TypeError) import Unsafe.Coerce (unsafeCoerce) import qualified Rank2-import Transformation (Transformation, Domain, Codomain, At)+import Transformation (Transformation, Codomain) 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),-          Rank2.Functor (g f), 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, Rank2.Functor (g 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 Attribution t => Attribution (Auto t) where+   type Origin (Auto t) = Origin t+   unwrap (Auto t) = unwrap t -instance {-# overlappable #-} (Bequether (Auto t) g d s, Synthesizer (Auto t) g d s) => Attribution (Auto t) g d s where+instance {-# overlappable #-} (Attribution t, Bequether (Auto t) g, Synthesizer (Auto t) g) =>+                              Auto t `At` g where    attribution t l (Inherited i, s) = (Synthesized $ synthesis t l i s, bequest t l i s) -class Transformation t => Revelation t where-   -- | Extract the value from the transformation domain-   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-   bequest     :: forall sem. sem ~ Semantics t =>-                  t                                -- ^ transformation        -               -> shallow (g deep deep)            -- ^ tree node-               -> Atts (Inherited t) (g sem sem)   -- ^ inherited attributes  +class Bequether t g where+   bequest     :: forall sem.+                  t                                -- ^ transformation+               -> Origin t (g sem sem)             -- ^ tree node+               -> Atts (Inherited t) g             -- ^ inherited attributes                -> g sem (Synthesized t)            -- ^ synthesized attributes                -> g sem (Inherited t)  -- | A half of the 'Attribution' class used to specify all synthesized attributes.-class Synthesizer t g deep shallow where-   synthesis   :: forall sem. sem ~ Semantics t =>-                  t                                -- ^ transformation        -               -> shallow (g deep deep)            -- ^ tree node-               -> Atts (Inherited t) (g sem sem)   -- ^ inherited attributes  +class Attribution t => Synthesizer t g where+   synthesis   :: forall sem.+                  t                                -- ^ transformation+               -> Origin t (g sem sem)             -- ^ tree node+               -> Atts (Inherited t) g             -- ^ inherited attributes                -> g sem (Synthesized t)            -- ^ synthesized attributes-               -> Atts (Synthesized t) (g sem sem)+               -> Atts (Synthesized t) g  -- | Class for specifying a single named attribute-class SynthesizedField (name :: Symbol) result t g deep shallow where-   synthesizedField  :: forall sem. sem ~ Semantics t =>+class Attribution t => SynthesizedField (name :: Symbol) result t g where+   synthesizedField  :: forall sem.                         Proxy name                      -- ^ attribute name                      -> t                               -- ^ transformation-                     -> shallow (g deep deep)           -- ^ tree node-                     -> Atts (Inherited t) (g sem sem)  -- ^ inherited attributes+                     -> Origin t (g sem sem)            -- ^ tree node+                     -> Atts (Inherited t) g            -- ^ inherited attributes                      -> g sem (Synthesized t)           -- ^ synthesized attributes                      -> result -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+instance {-# overlappable #-} (Attribution t, a ~ Atts (Inherited (Auto t)) g,+                               forall deep. Shallow.Functor (PassDown (Auto t) deep a) (g deep)) =>+                              Bequether (Auto t) g where    bequest = bequestDefault -instance {-# overlappable #-} (Atts (Synthesized t) (g sem sem) ~ result, Generic result, sem ~ Semantics t,-                               GenericSynthesizer t g d s (Rep result)) => Synthesizer t g d s where+instance {-# overlappable #-} (Attribution t, Atts (Synthesized (Auto t)) g ~ result, Generic result,+                               GenericSynthesizer (Auto t) g (Rep result)) => Synthesizer (Auto t) g where    synthesis t node i s = to (genericSynthesis t node i s)  -- | Wrapper for a field that should be automatically synthesized by folding together all child nodes' synthesized@@ -132,12 +95,10 @@ -- attribute of the same name. newtype Mapped f a = Mapped{getMapped :: f a}                    deriving (Eq, Ord, Show, Semigroup, Monoid, Functor, Applicative, Monad, Foldable)+ -- | Wrapper for a field that should be automatically synthesized by traversing over all child nodes and applying each -- node's synthesized attribute of the same name.-newtype Traversed m f a = Traversed{getTraversed :: m (f a)} deriving (Eq, Ord, Show, Semigroup, Monoid)--instance (Functor m, Functor f) => Functor (Traversed m f) where-   fmap f (Traversed x) = Traversed ((f <$>) <$> x)+newtype Traversed m f g = Traversed{getTraversed :: m (f (g f f))} --deriving (Eq, Ord, Show, Semigroup, Monoid)  -- * Generic transformations @@ -166,37 +127,39 @@   type Domain (Traverser t m f name) = Synthesized t   type Codomain (Traverser t m f name) = Compose m f -instance Subtype (Atts (Inherited t) a) b => Transformation.At (PassDown t f b) a where+instance Subtype (Atts (Inherited t) (NodeConstructor a)) b => Transformation.At (PassDown t f b) a where    ($) (PassDown i) _ = Inherited (upcast i) -instance (Monoid a, r ~ Atts (Synthesized t) x, Generic r, MayHaveMonoidalField name (Folded a) (Rep r)) =>+instance (Monoid a, r ~ Atts (Synthesized t) (NodeConstructor x), Generic r,+          MayHaveMonoidalField name (Folded a) (Rep r)) =>          Transformation.At (Accumulator t name a) x where    _ $ Synthesized r = Const (getMonoidalField (Proxy :: Proxy name) $ from r) -instance (HasField name (Atts (Synthesized t) a) (Mapped f a)) => Transformation.At (Replicator t f name) a where+instance (HasField name (Atts (Synthesized t) (NodeConstructor a)) (Mapped f a)) => Transformation.At (Replicator t f name) a where    _ $ Synthesized r = getMapped (getField @name r) -instance (HasField name (Atts (Synthesized t) a) (Traversed m f a)) => Transformation.At (Traverser t m f name) a where+instance (HasField name (Atts (Synthesized t) g) (Traversed m f g)) =>+         Transformation.At (Traverser t m f name) (g f f) where    _ $ Synthesized r = Compose (getTraversed $ getField @name r)  -- * Generic classes  -- | The 'Generic' mirror of 'Synthesizer'-class GenericSynthesizer t g deep shallow result where-   genericSynthesis  :: forall a sem. sem ~ Semantics t =>+class GenericSynthesizer t g result where+   genericSynthesis  :: forall a sem.                         t-                     -> shallow (g deep deep)-                     -> Atts (Inherited t) (g sem sem)+                     -> Origin t (g sem sem)+                     -> Atts (Inherited t) g                      -> g sem (Synthesized t)                      -> result a  -- | The 'Generic' mirror of 'SynthesizedField'-class GenericSynthesizedField (name :: Symbol) result t g deep shallow where-   genericSynthesizedField  :: forall a sem. sem ~ Semantics t =>+class Attribution t => GenericSynthesizedField (name :: Symbol) result t g where+   genericSynthesizedField  :: forall a sem.                                Proxy name                             -> t-                            -> shallow (g deep deep)-                            -> Atts (Inherited t) (g sem sem)+                            -> Origin t (g sem sem)+                            -> Atts (Inherited t) g                             -> g sem (Synthesized t)                             -> result a @@ -235,48 +198,48 @@ instance FoundField a (K1 i a) where      getFoundField (K1 a) = a -instance (GenericSynthesizer t g deep shallow x, GenericSynthesizer t g deep shallow y) =>-         GenericSynthesizer t g deep shallow (x :*: y) where+instance (GenericSynthesizer t g x, GenericSynthesizer t g y) => GenericSynthesizer t g (x :*: y) where    genericSynthesis t node i s = genericSynthesis t node i s :*: genericSynthesis t node i s -instance {-# overlappable #-} GenericSynthesizer t g deep shallow f =>-                              GenericSynthesizer t g deep shallow (M1 i meta f) where+instance {-# overlappable #-} GenericSynthesizer t g f =>+                              GenericSynthesizer t g (M1 i meta f) where    genericSynthesis t node i s = M1 (genericSynthesis t node i s) -instance {-# overlaps #-} GenericSynthesizedField name f t g deep shallow =>-                          GenericSynthesizer t g deep shallow (M1 i ('MetaSel ('Just name) su ss ds) f) where+instance {-# overlaps #-} GenericSynthesizedField name f t g =>+                          GenericSynthesizer t g (M1 i ('MetaSel ('Just name) su ss ds) f) where    genericSynthesis t node i s = M1 (genericSynthesizedField (Proxy :: Proxy name) t node i s) -instance SynthesizedField name a t g deep shallow => GenericSynthesizedField name (K1 i a) t g deep shallow where+instance SynthesizedField name a t g => GenericSynthesizedField name (K1 i a) t g where    genericSynthesizedField name t node i s = K1 (synthesizedField name t node i s) -instance  {-# overlappable #-} (Monoid a, Shallow.Foldable (Accumulator t name a) (g (Semantics t))) =>-                               SynthesizedField name (Folded a) t g deep shallow where+instance  {-# overlappable #-} (Attribution t, Monoid a,+                                forall sem. Shallow.Foldable (Accumulator t name a) (g sem)) =>+                               SynthesizedField name (Folded a) t g where    synthesizedField name t _ _ s = foldedField name t s -instance  {-# overlappable #-} (Functor f, Shallow.Functor (Replicator t f name) (g f),-                                Atts (Synthesized t) (g (Semantics t) (Semantics t)) ~ Atts (Synthesized t) (g f f)) =>-                               SynthesizedField name (Mapped f (g f f)) t g deep f where+instance  {-# overlappable #-} (Attribution t, Origin t ~ f, Functor f,+                                Shallow.Functor (Replicator t f name) (g f)) =>+                               SynthesizedField name (Mapped f (g f f)) t g where    synthesizedField name t local _ s = Mapped (mappedField name t s <$ local) -instance  {-# overlappable #-} (Traversable f, Applicative m, Shallow.Traversable (Traverser t m f name) (g f),-                                Atts (Synthesized t) (g (Semantics t) (Semantics t)) ~ Atts (Synthesized t) (g f f)) =>-                               SynthesizedField name (Traversed m f (g f f)) t g deep f where+instance  {-# overlappable #-} (Attribution t, Origin t ~ f, Traversable f, Applicative m,+                                Shallow.Traversable (Traverser t m f name) (g f)) =>+                               SynthesizedField name (Traversed m f g) t g where    synthesizedField name t local _ s = Traversed (traverse (const $ traversedField name t s) local)  -- | 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.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)+bequestDefault :: forall t g sem.+                  (Attribution t, Shallow.Functor (PassDown t sem (Atts (Inherited t) g)) (g sem))+               => t -> Origin t (g sem sem) -> Atts (Inherited t) g -> g sem (Synthesized t)                -> g sem (Inherited t)-bequestDefault t local inheritance _synthesized = passDown inheritance (reveal t local)+bequestDefault t local inheritance _synthesized = passDown @t inheritance (unwrap t local :: g sem sem)  -- | Pass down the given record of inherited fields to child nodes. passDown :: forall t g shallow deep atts. (Shallow.Functor (PassDown t shallow atts) (g deep)) =>             atts -> g deep shallow -> g deep (Inherited t)-passDown inheritance local = PassDown inheritance Shallow.<$> local+-- unsafeCoerce is safe here because Inherited doesn't refer to deep functor so the latter is a phantom+passDown inheritance local = Rank2.coerce (PassDown @t inheritance Shallow.<$> local)  -- | The default 'synthesizedField' method definition for 'Folded' fields. foldedField :: forall name t g a sem. (Monoid a, Shallow.Foldable (Accumulator t name a) (g sem)) =>@@ -285,14 +248,14 @@  -- | The default 'synthesizedField' method definition for 'Mapped' fields. mappedField :: forall name t g f sem.-                  (Shallow.Functor (Replicator t f name) (g f),-                   Atts (Synthesized t) (g sem sem) ~ Atts (Synthesized t) (g f f)) =>+                  (Shallow.Functor (Replicator t f name) (g f)) =>                   Proxy name -> t -> g sem (Synthesized t) -> g f f+-- unsafeCoerce is safe here because Synthesized doesn't refer to deep functor so the latter is a phantom mappedField _name _t s = (Replicator :: Replicator t f name) Shallow.<$> (unsafeCoerce s :: g f (Synthesized t))  -- | The default 'synthesizedField' method definition for 'Traversed' fields. traversedField :: forall name t g m f sem.-                     (Shallow.Traversable (Traverser t m f name) (g f),-                      Atts (Synthesized t) (g sem sem) ~ Atts (Synthesized t) (g f f)) =>+                     (Shallow.Traversable (Traverser t m f name) (g f)) =>                      Proxy name -> t -> g sem (Synthesized t) -> m (g f f)+-- unsafeCoerce is safe here because Synthesized doesn't refer to deep functor so the latter is a phantom traversedField _name _t s = Shallow.traverse (Traverser :: Traverser t m f name) (unsafeCoerce s :: g f (Synthesized t))

@@ -6,12 +6,9 @@  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+  Semantics, Rule, Attribution (attribution),+  Dimorphic.knit, applyDefault, fullMapDefault) where -import Data.Functor.Compose (Compose(..)) import Data.Functor.Const (Const(..)) import Data.Kind (Type) import qualified Rank2@@ -21,7 +18,7 @@ import qualified Transformation.Full as Full  import qualified Transformation.AG.Dimorphic as Dimorphic-import Transformation.AG.Dimorphic (knit, knitKeeping)+import Transformation.AG.Dimorphic (knit)   -- | Transformation wrapper that allows automatic inference of attribute rules.@@ -39,45 +36,28 @@ -- | 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+instance {-# overlappable #-} AttributeTransformation t => Attribution t g 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) =>+                               a ~ Attributes (Auto t),+                               Rank2.Foldable (g q), Monoid a, Foldable p, Attribution (Auto t) g) =>                               (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 a,           Rank2.Functor (g f), Deep.Functor (Auto t) g, Auto t `At` g (Semantics a) (Semantics a)) =>          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, 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-   (<$>) = 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 = Dimorphic.traverseDefaultWithAttributes+-- | Class of transformations that assign the same type of attributes to every node.+class Transformation t => AttributeTransformation t where+   type Attributes t :: Type  -- | The core type class for defining the attribute grammar. The instances of this class typically have a form like --@@ -87,28 +67,21 @@ -- >                    syn= fromChildren} -- >             = Atts{syn= toParent, -- >                    inh= toChildren}-class Attribution t a g (deep :: Type -> Type) shallow where+class AttributeTransformation t => Attribution t g where    -- | The attribution rule for a given transformation and node.-   attribution :: t -> shallow (g deep deep) -> Rule a+   attribution :: t -> Domain t (g (Codomain t) (Codomain t)) -> Rule (Attributes t)  -- | 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 :: (a ~ Attributes t, q ~ Codomain t, q ~ Semantics a, x ~ g q q, Rank2.Foldable (g q), Attribution t g,+                 Monoid a)+             => (forall y. Domain t y -> y) -> t -> Domain t 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)+fullMapDefault :: (p ~ Domain t, q ~ Semantics a, a ~ Attributes t, q ~ Codomain t, x ~ g q q, Rank2.Foldable (g q),+                   Functor p, Deep.Functor t g, Attribution t g, 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)+fullMapDefault extract t x = knit (attribution t (y <$ x)) y+   where y = t Deep.<$> extract x {-# 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 #-}--type Feeder a = Dimorphic.Feeder a a

@@ -1,5 +1,5 @@ {-# Language Haskell2010, DeriveDataTypeable, FlexibleInstances, KindSignatures, MultiParamTypeClasses, RankNTypes,-             StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}+             GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}  -- | Type classes 'Functor', 'Foldable', and 'Traversable' that correspond to the standard type classes of the same -- name, but applying the given transformation to every descendant of the given tree node. The corresponding classes@@ -16,14 +16,17 @@ import qualified Data.Functor as Rank1 import qualified Data.Traversable as Rank1 import Data.Kind (Type)+import Data.String (IsString) import qualified Rank2 import           Transformation (Transformation, Domain, Codomain) import qualified Transformation.Full as Full  import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd) --- | Like "Transformation.Shallow".'Transformation.Shallow.Functor' except it maps all descendants and not only immediate children+-- | 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+   -- | Apply the transformation to all descendants    (<$>) :: t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)    infixl 4 <$> @@ -34,6 +37,10 @@ -- | Like "Transformation.Shallow".'Transformation.Shallow.Traversable' except it folds all descendants and not only immediate children class (Transformation t, Rank2.Traversable (g (Domain t))) => Traversable t g where    traverse :: Codomain t ~ Compose m f => t -> g (Domain t) (Domain t) -> m (g f f)++-- | Ground type ignoring the wrappers+newtype Const2 (a :: Type) (deep :: Type -> Type) (shallow :: Type -> Type) = Const2{getConst2 :: a}+   deriving (Eq, Ord, Show, IsString, Num)  -- | A tuple of only one element newtype Only g (d :: Type -> Type) (s :: Type -> Type) =

@@ -1,4 +1,5 @@-{-# Language FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeOperators #-}+{-# Language FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+{-# Language QuantifiedConstraints, RankNTypes, TypeFamilies, TypeOperators #-}  -- | Type classes 'Functor', 'Foldable', and 'Traversable' that correspond to the standard type classes of the same -- name, but applying the given transformation to the given tree node and all its descendants. The corresponding classes@@ -7,6 +8,7 @@  module Transformation.Full where +import Data.Coerce (Coercible) import qualified Data.Functor import           Data.Functor.Compose (Compose(getCompose)) import           Data.Functor.Const (Const(getConst))@@ -16,12 +18,16 @@ import qualified Transformation import           Transformation (Transformation, Domain, Codomain) import {-# SOURCE #-} qualified Transformation.Deep as Deep+import Unsafe.Coerce (unsafeCoerce)  import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd)  -- | 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))+   -- | Equivalent to @(Transformation.Coercion <$>)@ but faster+   coerce :: (t ~ Transformation.Coercion p q, forall h. Coercible (p (h p p)) (q (h q q))) => p (g p p) -> q (g q q)+   coerce = unsafeCoerce    infixl 4 <$>  -- | Like "Transformation.Deep".'Deep.Foldable' except the entire tree is also wrapped

@@ -8,11 +8,9 @@ import Data.Functor.Compose (Compose(Compose)) import Data.Functor.Const (Const(Const)) import Data.Kind (Type)-import qualified Rank2 import           Transformation (Transformation, Domain, Codomain) import qualified Transformation import qualified Transformation.Deep as Deep-import qualified Transformation.Full as Full  -- | 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@@ -53,6 +51,3 @@  instance Transformation.At (Traversal p q m) x where    ($) (Traversal f) = Compose . f--instance (Rank2.Functor (g p), Deep.Functor (Map p q) g, Functor p) => Full.Functor (Map p q) g where-  (<$>) = Full.mapUpDefault

@@ -1,8 +0,0 @@-import Build_doctests (flags, pkgs, module_sources)-import Test.DocTest (doctest)--main :: IO ()-main = do-    doctest (flags ++ pkgs ++ module_sources)-    doctest (flags ++ pkgs ++ ["-pgmL", "markdown-unlit", "-isrc", "test/README.lhs"])-    doctest (flags ++ pkgs ++ ["-isrc", "test/RepMin.hs", "test/RepMinAuto.hs"])

@@ -29,6 +29,7 @@ ~~~ {.haskell} import Control.Applicative import Data.Coerce (coerce)+import Data.Functor.Compose import Data.Functor.Const import Data.Functor.Identity import Data.Monoid@@ -111,11 +112,22 @@   f `foldMap` Mul x y = f x <> f y   f `foldMap` Let d e = f d <> f e   f `foldMap` EVar v  = mempty++instance Rank2.Traversable (Decl f') where+  f `traverse` (v := e) = (v :=) <$> f e+  f `traverse` Seq x y  = Seq <$> f x <*> f y++instance Rank2.Traversable (Expr f') where+  f `traverse` Con n   = pure (Con n)+  f `traverse` Add x y = Add <$> f x <*> f y+  f `traverse` Mul x y = Mul <$> f x <*> f y+  f `traverse` Let d e = Let <$> f d <*> f e+  f `traverse` EVar v  = pure (EVar v) ~~~ -While the methods declared above can be handy, they are limited in requiring that the function argument `f` must be- polymorphic in the wrapped field type. In other words, it cannot behave one way for an `Expr` and another for a- `Decl`. That can be a severe handicap.+While the methods declared above can be handy, they are limited because they require that the function argument `f`+ must be polymorphic in the wrapped field type. In other words, it cannot behave one way for an `Expr` and another+ for a `Decl`. That can be a severe handicap.  The class methods exported by `deep-transformations` therefore work not with polymorphic functions but with *transformations*. The instances of these classes are similar to the 'Rank2' instances above. Also as above, they can@@ -144,6 +156,19 @@   t `foldMap` Mul x y = t `Full.foldMap` x <> t `Full.foldMap` y   t `foldMap` Let d e = t `Full.foldMap` d <> t `Full.foldMap` e   t `foldMap` EVar v  = mempty++instance (Transformation t, Transformation.Codomain t ~ Compose m f, Applicative m,+          Full.Traversable t Decl, Full.Traversable t Expr) => Deep.Traversable t Decl where+  t `traverse` (v := e) = (v :=) <$> t `Full.traverse` e+  t `traverse` Seq x y  = Seq <$> t `Full.traverse` x <*> t `Full.traverse` y++instance (Transformation t, Transformation.Codomain t ~ Compose m f, Applicative m,+          Full.Traversable t Decl, Full.Traversable t Expr) => Deep.Traversable t Expr where+  t `traverse` Con n   = pure (Con n)+  t `traverse` Add x y = Add <$> t `Full.traverse` x <*> t `Full.traverse` y+  t `traverse` Mul x y = Mul <$> t `Full.traverse` x <*> t `Full.traverse` y+  t `traverse` Let d e = Let <$> t `Full.traverse` d <*> t `Full.traverse` e+  t `traverse` EVar v  = pure (EVar v) ~~~  Once the above boilerplate code is written or generated, no further boilerplate need be written.@@ -268,29 +293,29 @@  grammar. We can build one with the tools from  [`Transformation.AG`](https://hackage.haskell.org/package/deep-transformations/docs/Transformation-AG.html). -First we declare another transformation, just like before. Its `Codomain` will now be something called the attribute- grammar semantics, and it performs bottom-up.--~~~ {.haskell}-data DeadCodeEliminator = DeadCodeEliminator+Instead of declaring another transformation like before, this time we'll use a predefined transformation called+ `Knit`. Its `Codomain` will now be something called the attribute grammar semantics. It requires a parameter data+ type, an instance of `Attribution`. The associated type `Origin` of the parameter is also the `Domain` of the+ `Knit` transformation. -type Sem = AG.Semantics DeadCodeEliminator+~~~ {.haskell.ignore}+newtype Knit t = Knit t -instance Transformation DeadCodeEliminator where-   type Domain DeadCodeEliminator = Identity-   type Codomain DeadCodeEliminator = AG.Semantics DeadCodeEliminator+instance AG.Attribution t => Transformation (Knit t) where+   type Domain (Knit t) = AG.Origin t+   type Codomain (Knit t) = Semantics t -instance DeadCodeEliminator `Transformation.At` Decl Sem Sem where-  ($) = AG.applyDefault runIdentity+type Semantics t = Inherited t Rank2.~> Synthesized t+~~~ -instance DeadCodeEliminator `Transformation.At` Expr Sem Sem where-  ($) = AG.applyDefault runIdentity+As noted above, we need a new data type to make an `Attribution` instance. Let's call it `DeadCodeEliminator`. -instance Full.Functor DeadCodeEliminator Decl where-  (<$>) = Full.mapUpDefault+~~~ {.haskell}+data DeadCodeEliminator = DeadCodeEliminator -instance Full.Functor DeadCodeEliminator Expr where-  (<$>) = Full.mapUpDefault+instance AG.Attribution DeadCodeEliminator where+   type Origin DeadCodeEliminator = Identity+   unwrap DeadCodeEliminator = runIdentity ~~~  We also need another bit of a boilerplate instance that can be automatically generated with Template Haskell functions@@ -309,6 +334,9 @@   Mul x1 y1 <*> ~(Mul x2 y2) = Mul (Rank2.apply x1 x2) (Rank2.apply y1 y2) ~~~ +That's all the setup, the rest of the implementation consists of the actual attribute definitions specific to our+needs.+ ### Attributes  Every type of node can have different inherited and synthesized attributes, so we need to declare what they are. Since@@ -318,14 +346,14 @@  ~~~ {.haskell} type Env = Var -> Maybe (Expr Identity Identity)-type instance AG.Atts (AG.Inherited DeadCodeEliminator) (Expr _ _) = Env+type instance AG.Atts (AG.Inherited DeadCodeEliminator) Expr = Env ~~~  A declaration will also need to inherit the environment, if only to pass it on to the nested expressions. Because we  want to discard useless assignments, it will also need to know the list of all referenced variables.  ~~~ {.haskell}-type instance AG.Atts (AG.Inherited DeadCodeEliminator) (Decl _ _) = (Env, [Var])+type instance AG.Atts (AG.Inherited DeadCodeEliminator) Decl = (Env, [Var]) ~~~  A `Decl` needs to synthesize the environment of constant bindings it generates itself, as well as a modified@@ -333,7 +361,7 @@  need to wrap it in a `Maybe`.  ~~~ {.haskell}-type instance AG.Atts (AG.Synthesized DeadCodeEliminator) (Decl _ _) = (Env, Maybe (Decl Identity Identity))+type instance AG.Atts (AG.Synthesized DeadCodeEliminator) Decl = (Env, Maybe (Decl Identity Identity)) ~~~  All declarations inside an `Expr` need to be trimmed, so the `Expr` itself may be simplified but never completely@@ -342,20 +370,20 @@  easier to reuse the existing `GetVariables` transformation.  ~~~ {.haskell}-type instance AG.Atts (AG.Synthesized DeadCodeEliminator) (Expr _ _) = Expr Identity Identity+type instance AG.Atts (AG.Synthesized DeadCodeEliminator) Expr = Expr Identity Identity ~~~ -Now we need to describe how to calculate the attributes, by declaring `Attribution` instances of the node types. The- method `attribution` takes as arguments: the transformation - in this case `DeadCodeEliminator`, the node, the node's- inherited attributes, and the synthesized attributes of all the node's children grouped under the node- constructor. The last two inputs are grouped in a pair for symmetry with the function result, which is a pair of the- node's synthesized attributes and the inherited attributes for all the node's children grouped under the node+Now we need to describe how to calculate the attributes, by declaring the `At` instances of the node+ types. The method `attribution` takes as arguments: the transformation - in this case `DeadCodeEliminator`, the+ node, the node's inherited attributes, and the synthesized attributes of all the node's children grouped under the+ node constructor. The last two inputs are grouped in a pair for symmetry with the function result, which is a pair+ of the node's synthesized attributes and the inherited attributes for all the node's children grouped under the node  constructor. Perhaps this can be more succintly illustrated by the method's type signature:  ~~~ {.haskell.ignore}-class Attribution t g deep shallow where-   attribution :: sem ~ (Inherited t Rank2.~> Synthesized t)-               => t -> shallow (g deep deep)+class Attribution t => At t g where+   attribution :: forall sem. Rank2.Traversable (g sem)+               => t -> Origin t (g sem sem)                -> (Inherited   t (g sem sem), g sem (Synthesized t))                -> (Synthesized t (g sem sem), g sem (Inherited t)) ~~~@@ -366,7 +394,7 @@ because they don't have any children.  ~~~ {.haskell}-instance AG.Attribution DeadCodeEliminator Expr Sem Identity where+instance DeadCodeEliminator `AG.At` Expr 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, _) =@@ -403,7 +431,7 @@ The rules for `Decl` are a bit more involved.  ~~~ {.haskell}-instance AG.Attribution DeadCodeEliminator Decl Sem Identity where+instance DeadCodeEliminator `AG.At` Decl where ~~~  A single variable binding can be in three distinct situations. If the variable is not referenced at all, we can just@@ -438,7 +466,7 @@  ~~~ {.haskell} -- |--- >>> let s = Full.fmap DeadCodeEliminator (Identity $ bin Let d1 e1) `Rank2.apply` AG.Inherited (const Nothing)+-- >>> let s = Full.fmap (AG.Knit DeadCodeEliminator) (Identity $ bin Let d1 e1) `Rank2.apply` AG.Inherited (const Nothing) -- >>> s -- Synthesized {syn = Add (Identity (Con 42)) (Identity (Add (Identity (Mul (Identity (Con 42)) (Identity (Con 68)))) (Identity (Con 7))))} -- >>> Full.fmap ConstantFold $ Identity $ AG.syn s

@@ -8,7 +8,7 @@ import Data.Kind (Type) import qualified Rank2 import Transformation (Transformation(..))-import Transformation.AG (Inherited(..), Synthesized(..))+import Transformation.AG (Attribution, Inherited(..), Synthesized(..)) import qualified Transformation import qualified Transformation.AG as AG import qualified Transformation.Deep as Deep@@ -31,6 +31,20 @@ instance Rank2.Functor (Root a f') where    f <$> Root x = Root (f x) +instance Rank2.Foldable (Tree a f') where+   f `foldMap` Fork l r = f l <> f r+   f `foldMap` Leaf x = f x++instance Rank2.Traversable (Root a f') where+   f `traverse` Root x = Root <$> f x++instance Rank2.Traversable (Tree a f') where+   f `traverse` Fork l r = Fork <$> f l <*> f r+   f `traverse` Leaf x = Leaf <$> f x++instance Rank2.Foldable (Root a f') where+   f `foldMap` Root x = f x+ instance Rank2.Apply (Tree a f') where    Fork fl fr <*> ~(Fork l r) = Fork (Rank2.apply fl l) (Rank2.apply fr r)    Leaf f <*> ~(Leaf x) = Leaf (Rank2.apply f x)@@ -51,11 +65,9 @@ -- | The transformation type data RepMin = RepMin -type Sem = AG.Semantics RepMin--instance Transformation RepMin where-   type Domain RepMin = Identity-   type Codomain RepMin = Sem+instance Attribution RepMin where+   type Origin RepMin = Identity+   unwrap RepMin = runIdentity  -- | Inherited attributes' type data InhRepMin = InhRepMin{global :: Int}@@ -66,34 +78,24 @@                            tree  :: Tree Int Identity Identity}                deriving Show -type instance AG.Atts (Inherited RepMin) (Tree Int f' f) = InhRepMin-type instance AG.Atts (Synthesized RepMin) (Tree Int f' f) = SynRepMin-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 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+type instance AG.Atts (Inherited RepMin) (Tree Int) = InhRepMin+type instance AG.Atts (Synthesized RepMin) (Tree Int) = SynRepMin+type instance AG.Atts (Inherited RepMin) (Root Int) = ()+type instance AG.Atts (Synthesized RepMin) (Root Int) = SynRepMin -instance Full.Functor RepMin (Tree Int) where-  (<$>) = Full.mapUpDefault-instance Full.Functor RepMin (Root Int) where-  (<$>) = Full.mapUpDefault+type instance AG.Atts (Inherited RepMin) (Deep.Const2 Int) = ()+type instance AG.Atts (Synthesized RepMin) (Deep.Const2 Int) = Int  -- | 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 Transformation.At (AG.Knit RepMin) Int where+   _ $ Identity n = Rank2.Arrow (const $ Synthesized n) -instance AG.Attribution RepMin (Root Int) Sem Identity where+instance AG.At RepMin (Root Int) 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) Sem Identity where+instance AG.At RepMin (Tree Int) where    attribution _ _ (inherited, Fork left right) = (Synthesized SynRepMin{local= local (syn left)                                                                                 `min` local (syn right),                                                                          tree= tree (syn left) `fork` tree (syn right)},@@ -113,5 +115,5 @@ exampleTree = Root (Identity $ leaf 7 `fork` (leaf 4 `fork` leaf 1) `fork` leaf 3)  -- |--- >>> Rank2.apply (Full.fmap RepMin $ Identity exampleTree) (Inherited ())+-- >>> Rank2.apply (Full.fmap (AG.Knit RepMin) $ Identity exampleTree) (Inherited ()) -- Synthesized {syn = SynRepMin {local = 1, tree = Fork {left = Identity (Fork {left = Identity (Leaf {leafValue = Identity 1}), right = Identity (Fork {left = Identity (Leaf {leafValue = Identity 1}), right = Identity (Leaf {leafValue = Identity 1})})}), right = Identity (Leaf {leafValue = Identity 1})}}}

@@ -12,7 +12,7 @@ import qualified Rank2 import qualified Rank2.TH import Transformation (Transformation(..))-import Transformation.AG (Inherited(..), Synthesized(..))+import Transformation.AG (Attribution, Inherited(..), Synthesized(..)) import qualified Transformation import qualified Transformation.AG as AG import qualified Transformation.AG.Generics as AG@@ -22,6 +22,10 @@ import qualified Transformation.Deep.TH import qualified Transformation.Shallow.TH +import qualified Data.Functor.Compose+import qualified Data.Functor.Const+import qualified Transformation.Shallow+ -- | tree data type data Tree a (f' :: Type -> Type) (f :: Type -> Type) = Fork{left :: f (Tree a f' f'),                                                             right:: f (Tree a f' f')}@@ -40,15 +44,9 @@ -- | The transformation type. It will always appear wrapped in 'Auto' to enable automatic attribute derivation. data RepMin = RepMin --- | The semantics type synonym for convenience-type Sem = AG.Semantics (Auto RepMin)--instance Transformation (Auto RepMin) where-   type Domain (Auto RepMin) = Identity-   type Codomain (Auto RepMin) = Sem--instance AG.Revelation (Auto RepMin) where-   reveal (Auto RepMin) = runIdentity+instance Attribution RepMin where+   type Origin RepMin = Identity+   unwrap RepMin = runIdentity     -- | Inherited attributes' type data InhRepMin = InhRepMin{global :: Int}@@ -66,24 +64,24 @@                              tree :: AG.Mapped Identity Int}                   deriving (Generic, Show) -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+type instance AG.Atts (Inherited RepMin) (Tree Int) = InhRepMin+type instance AG.Atts (Synthesized RepMin) (Tree Int) = SynRepMin Tree+type instance AG.Atts (Inherited RepMin) (Root Int) = ()+type instance AG.Atts (Synthesized RepMin) (Root Int) = SynRepMin Root -type instance AG.Atts (Inherited RepMin) Int = InhRepMin-type instance AG.Atts (Synthesized RepMin) Int = SynRepLeaf+type instance AG.Atts (Inherited RepMin) (Deep.Const2 Int) = InhRepMin+type instance AG.Atts (Synthesized RepMin) (Deep.Const2 Int) = SynRepLeaf  -- | The semantics of the primitive 'Int' type must be defined manually.-instance Transformation.At (Auto RepMin) Int where-   Auto RepMin $ Identity n = Rank2.Arrow f+instance Transformation.At (AG.Knit (Auto RepMin)) Int where+   _ $ Identity n = Rank2.Arrow f       where f (Inherited InhRepMin{global= n'}) =                Synthesized SynRepLeaf{local= AG.Folded (Min n),                                       tree= AG.Mapped (Identity n')}  -- | The only required attribute rule is the only non-trivial one, where we set the 'global' inherited attribute to -- | the 'local' minimum synthesized attribute at the tree root.-instance AG.Bequether (Auto RepMin) (Root Int) Sem Identity where+instance AG.Bequether (Auto RepMin) (Root Int) where    bequest (Auto RepMin) self inherited (Root (Synthesized SynRepMin{local= rootLocal})) =       Root{root= Inherited InhRepMin{global= getMin (AG.getFolded rootLocal)}} @@ -96,5 +94,5 @@ exampleTree = Root (Identity $ leaf 7 `fork` (leaf 4 `fork` leaf 1) `fork` leaf 3)  -- |--- >>> syn $ Rank2.apply (Auto RepMin Transformation.$ Identity (Auto RepMin Deep.<$> exampleTree)) (Inherited ())+-- >>> syn $ Rank2.apply (AG.Knit (Auto RepMin) Full.<$> Identity exampleTree) (Inherited ()) -- SynRepMin {local = Folded {getFolded = Min {getMin = 1}}, tree = Mapped {getMapped = Identity (Root {root = Identity (Fork {left = Identity (Fork {left = Identity (Leaf {leafValue = Identity 1}), right = Identity (Fork {left = Identity (Leaf {leafValue = Identity 1}), right = Identity (Leaf {leafValue = Identity 1})})}), right = Identity (Leaf {leafValue = Identity 1})})})}}

@@ -0,0 +1,130 @@+{-# Language FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, NamedFieldPuns, RankNTypes, StandaloneDeriving,+             TypeFamilies, TypeOperators, UndecidableInstances #-}++-- | The RepMin example using 'AG.Keep' to replicate the tree structure.+module RepMinKeepAG where++import Data.Functor.Identity+import Data.Kind (Type)+import qualified Rank2+import Transformation (Transformation(..))+import Transformation.AG (At, Inherited(..), Synthesized(..))+import qualified Transformation+import qualified Transformation.AG as AG+import qualified Transformation.Deep as Deep+import qualified Transformation.Full as Full++-- | tree data type+data Tree a (f' :: Type -> Type) (f :: Type -> Type) = Fork{left :: f (Tree a f' f'),+                                                            right:: f (Tree a f' f')}+                                                     | Leaf{leafValue :: f a}+-- | tree root+data Root a f' f = Root{root :: f (Tree a f' f')}++deriving instance (Show (f (Tree a f' f')), Show (f a)) => Show (Tree a f' f)+deriving instance (Show (f (Tree a f' f'))) => Show (Root a f' f)++instance Rank2.Functor (Tree a f') where+   f <$> Fork l r = Fork (f l) (f r)+   f <$> Leaf x = Leaf (f x)++instance Rank2.Functor (Root a f') where+   f <$> Root x = Root (f x)++instance Rank2.Foldable (Tree a f') where+   f `foldMap` Fork l r = f l <> f r+   f `foldMap` Leaf x = f x++instance Rank2.Traversable (Root a f') where+   f `traverse` Root x = Root <$> f x++instance Rank2.Traversable (Tree a f') where+   f `traverse` Fork l r = Fork <$> f l <*> f r+   f `traverse` Leaf x = Leaf <$> f x++instance Rank2.Foldable (Root a f') where+   f `foldMap` Root x = f x++instance Rank2.Apply (Tree a f') where+   Fork fl fr <*> ~(Fork l r) = Fork (Rank2.apply fl l) (Rank2.apply fr r)+   Leaf f <*> ~(Leaf x) = Leaf (Rank2.apply f x)++instance Rank2.Applicative (Tree a f') where+   pure x = Leaf x++instance Rank2.Apply (Root a f') where+   Root f <*> ~(Root x) = Root (Rank2.apply f x)++instance (Transformation t, Transformation.At t a, Full.Functor t (Tree a)) => Deep.Functor t (Tree a) where+   t <$> Fork l r = Fork (t Full.<$> l) (t Full.<$> r)+   t <$> Leaf x = Leaf (t Transformation.$ x)++instance (Transformation t, Full.Functor t (Tree a)) => Deep.Functor t (Root a) where+   t <$> Root x = Root (t Full.<$> x)++-- | The transformation type+data RepMin = RepMin++instance AG.Attribution RepMin where+   type Origin RepMin = Identity+   unwrap RepMin = runIdentity++-- | Inherited attributes' type+data InhRepMin = InhRepMin{global :: Int} deriving Show++-- | Synthesized attributes' type+data SynRepMin = SynRepMin{local :: Int} deriving Show++type instance AG.Atts (Inherited RepMin) (Tree Int) = InhRepMin+type instance AG.Atts (Synthesized RepMin) (Tree Int) = SynRepMin+type instance AG.Atts (Inherited RepMin) (Root Int) = ()+type instance AG.Atts (Synthesized RepMin) (Root Int) = SynRepMin++type instance AG.Atts (Inherited RepMin) (Deep.Const2 Int) = InhRepMin+type instance AG.Atts (Synthesized RepMin) (Deep.Const2 Int) = Int++-- | The semantics of the primitive 'Int' type must be defined manually.+instance Transformation.At (AG.Knit (AG.Keep RepMin)) Int where+   _ $ Identity n = Rank2.Arrow (\(Inherited i)-> Synthesized $ AG.Kept i n (Identity $ Deep.Const2 n))++instance RepMin `At` Root Int where+   attribution RepMin self (inherited, Root root) = (Synthesized SynRepMin{local= local (syn root)},+                                                     Root{root= Inherited InhRepMin{global= local (syn root)}})++instance RepMin `At` Tree Int where+   attribution _ _ (inherited, Fork left right) = (Synthesized SynRepMin{local= local (syn left)+                                                                                `min` local (syn right)},+                                                   Fork{left= Inherited InhRepMin{global= global $ inh inherited},+                                                        right= Inherited InhRepMin{global= global $ inh inherited}})+   attribution _ _ (inherited, Leaf value) = (Synthesized SynRepMin{local= syn value},+                                              Leaf{leafValue= Inherited InhRepMin{global= global $ inh inherited}})++-- * Helper functions+fork l r = Fork (Identity l) (Identity r)+leaf = Leaf . Identity++data Extractor = Extractor++instance Transformation Extractor where+  type Domain Extractor = AG.Kept RepMin+  type Codomain Extractor = Identity++instance Transformation.At Extractor (Root Int (AG.Kept RepMin) (AG.Kept RepMin)) where+  _ $ AG.Kept{AG.original} = original++instance Transformation.At Extractor (Tree Int (AG.Kept RepMin) (AG.Kept RepMin)) where+  _ $ AG.Kept{AG.original} = original++instance Transformation.At Extractor Int where+  _ $ AG.Kept{AG.inherited = InhRepMin{global = x}} = Identity x++instance Full.Functor Extractor (Tree Int) where+  (<$>) = Full.mapDownDefault++-- | The example tree+exampleTree :: Root Int Identity Identity+exampleTree = Root (Identity $ leaf 7 `fork` (leaf 4 `fork` leaf 1) `fork` leaf 3)++-- |+-- >>> Deep.fmap Extractor $ runIdentity $ AG.original $ AG.syn $ Rank2.apply (AG.Knit (AG.Keep RepMin) Full.<$> Identity exampleTree) (Inherited ())+-- Root {root = Identity (Fork {left = Identity (Fork {left = Identity (Leaf {leafValue = Identity 1}), right = Identity (Fork {left = Identity (Leaf {leafValue = Identity 1}), right = Identity (Leaf {leafValue = Identity 1})})}), right = Identity (Leaf {leafValue = Identity 1})})}