deep-transformations (empty) → 0.1

raw patch · 19 files changed

+2560/−0 lines, 19 filesdep +basedep +deep-transformationsdep +doctestbuild-type:Customsetup-changed

Dependencies added: base, deep-transformations, doctest, generic-lens, rank2classes, template-haskell

Files

• LICENSE +26/−0
• README.md +439/−0
• Setup.hs +6/−0
• deep-transformations.cabal +55/−0
• src/Transformation.hs +79/−0
• src/Transformation/AG.hs +71/−0
• src/Transformation/AG/Generics.hs +262/−0
• src/Transformation/Deep.hs +73/−0
• src/Transformation/Deep.hs-boot +19/−0
• src/Transformation/Deep/TH.hs +335/−0
• src/Transformation/Full.hs +66/−0
• src/Transformation/Full/TH.hs +79/−0
• src/Transformation/Rank2.hs +55/−0
• src/Transformation/Shallow.hs +41/−0
• src/Transformation/Shallow/TH.hs +293/−0
• test/Doctest.hs +8/−0
• test/README.lhs +439/−0
• test/RepMin.hs +109/−0
• test/RepMinAuto.hs +105/−0

@@ -0,0 +1,26 @@+Copyright (c) 2016, Mario Blažević+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the+   distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,439 @@+Deep transformations+====================++An abstract syntax tree of a realistic programming language will generally contain more than one node type. In other+ words, its type will involve several mutually recursive data types: the usual suspects would be expression,+ declaration, type, statement, and module.++This library, `deep-transformations`, provides a solution to the problem of traversing and transforming such+ heterogenous trees. It does this by generalizing the+ [`rank2classes`](http://github.com/blamario/grampa/tree/master/rank2classes) library and by replacing parametric+ polymorphism with ad-hoc polymorphism. The result is powerful enough to support a new embedding of attribute+ grammars, as shown below and in two+ [RepMin](http://github.com/blamario/grampa/blob/master/deep-transformations/test/RepMin.hs)+ [examples](http://github.com/blamario/grampa/blob/master/deep-transformations/test/RepMinAuto.hs)++This is not the only solution by far. The venerable [`multiplate`](http://hackage.haskell.org/package/multiplate) has+ long offered a very approachable way to traverse and fold heterogenous trees, without even depending on any extension+ to standard Haskell. Multiplate is not as expressive as the present library, but if it satisfies your needs go with+ it. If not, be aware that `deep-transformations` relies on quite a number of extensions:++~~~ {.haskell}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,+             StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}+module README where+~~~++It will also require several imports.++~~~ {.haskell}+import Control.Applicative+import Data.Coerce (coerce)+import Data.Functor.Const+import Data.Functor.Identity+import qualified Rank2+import Transformation (Transformation, At)+import qualified Transformation+import qualified Transformation.AG as AG+import qualified Transformation.Deep as Deep+import qualified Transformation.Full as Full+import qualified Transformation.Shallow as Shallow+~~~++Let us start with the same example handled by [Multiplate](https://wiki.haskell.org/Multiplate). It's a relatively+ simple set of two mutually recursive data types.++    data Expr = Con Int+              | Add Expr Expr+              | Mul Expr Expr+              | EVar Var+              | Let Decl Expr++    data Decl = Var := Expr+              | Seq Decl Decl++    type Var = String++This kind of tree is *not* something that `deep-transformations` can handle. Before you can use this library, you must+parameterize every data type and wrap every recursive field of every constructor as follows:++~~~ {.haskell}+data Expr d s = Con Int+              | Add (s (Expr d d)) (s (Expr d d))+              | Mul (s (Expr d d)) (s (Expr d d))+              | EVar Var+              | Let (s (Decl d d)) (s (Expr d d))++data Decl d s = Var := s (Expr d d)+              | Seq (s (Decl d d)) (s (Decl d d))++type Var = String+~~~++The parameters `d` and `s` stand for the *deep* and *shallow* type constructor. A typical occurrence of the tree will+ instantiate the same type for both parameters. While it may look complicated and annoying, this kind of+ parameterization carries benefits beyond this library's use. The parameters may vary from `Identity`, equivalent to+ the original simple formulation, via `(,) LexicalInfo` to store the source code position and white-space and comments+ for every node, or `[]` if you need some ambiguity, to attribute grammar semantics.++Now, let's declare all the class instances. First make the tree `Show`.++~~~ {.haskell}+deriving instance (Show (f (Expr f' f')), Show (f (Decl f' f'))) => Show (Expr f' f)+deriving instance (Show (f (Expr f' f')), Show (f (Decl f' f'))) => Show (Decl f' f)+~~~++The shallow parameter comes last so that every data type can have instances of+ [`rank2classes`](https://hackage.haskell.org/package/rank2classes). The instances below are written manually for+ exposition, but it would be easier to generate them automatically using the Template Haskell imports from+ [`Rank2.TH`](https://hackage.haskell.org/package/rank2classes/docs/Rank2-TH.html).++~~~ {.haskell}+instance Rank2.Functor (Decl f') where+  f <$> (v := e) = (v := f e)+  f <$> Seq x y  = Seq (f x) (f y)++instance Rank2.Functor (Expr f') where+  f <$> Con n   = Con n+  f <$> Add x y = Add (f x) (f y)+  f <$> Mul x y = Mul (f x) (f y)+  f <$> Let d e = Let (f d) (f e)+  f <$> EVar v  = EVar v++instance Rank2.Foldable (Decl f') where+  f `foldMap` (v := e) = f e+  f `foldMap` Seq x y  = f x <> f y++instance Rank2.Foldable (Expr f') where+  f `foldMap` Con n   = mempty+  f `foldMap` Add x y = f x <> f y+  f `foldMap` Mul x y = f x <> f y+  f `foldMap` Let d e = f d <> f e+  f `foldMap` EVar v  = mempty+~~~++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.++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+be generated automatically with Template Haskell functions from+[`Transformation.Deep.TH`](https://hackage.haskell.org/package/deep-transformations/docs/Transformation-Deep-TH.html).++~~~ {.haskell}+instance (Transformation t, Full.Functor t Decl, Full.Functor t Expr) => Deep.Functor t Decl where+  t <$> (v := e)   = (v := (t Full.<$> e))+  t <$> Seq x y = Seq (t Full.<$> x) (t Full.<$> y)++instance (Transformation t, Full.Functor t Decl, Full.Functor t Expr) => Deep.Functor t Expr where+  t <$> Con n   = Con n+  t <$> Add x y = Add (t Full.<$> x) (t Full.<$> y)+  t <$> Mul x y = Mul (t Full.<$> x) (t Full.<$> y)+  t <$> Let d e = Let (t Full.<$> d) (t Full.<$> e)+  t <$> EVar v  = EVar v++instance (Transformation t, Full.Foldable t Decl, Full.Foldable t Expr) => Deep.Foldable t Decl where+  t `foldMap` (v := e) = t `Full.foldMap` e+  t `foldMap` Seq x y  = t `Full.foldMap` x <> t `Full.foldMap` y++instance (Transformation t, Full.Foldable t Decl, Full.Foldable t Expr) => Deep.Foldable t Expr where+  t `foldMap` Con n   = mempty+  t `foldMap` Add x y = t `Full.foldMap` x <> t `Full.foldMap` y+  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+~~~++Once the above boilerplate code is written or generated, no further boilerplate need be written.++Generic Programing with deep-transformations+============================================++Folding+-------++Suppose we we want to get a list of all variables used in an expression. To do this we would declare the appropriate+ [`Transformation`](https://hackage.haskell.org/package/deep-transformations/docs/Transformation.html) instance for an+ arbitrary data type. We'll give this data type an evocative name.++~~~ {.haskell}+data GetVariables = GetVariables++instance Transformation GetVariables where+  type Domain GetVariables = Identity+  type Codomain GetVariables = Const [Var]+~~~++The `Transformation` instance for `GetVariables` converts the `Identity` wrapper of a given node into a constant list+ of variables contained within it. To do that, it must behave differently for `Expr` and for `Decl`:++~~~ {.haskell}+instance GetVariables `At` Expr Identity Identity where+  GetVariables $ Identity (EVar v) = Const [v]+  GetVariables $ x = mempty++instance GetVariables `At` Decl Identity Identity where+  GetVariables $ x = mempty+~~~++There is one last decision to make about our transformation: is it a pre-order or a post-order fold? In this case it+ doesn't matter, so let's pick pre-order:++~~~ {.haskell}+instance Full.Foldable GetVariables Decl where+  foldMap = Full.foldMapDownDefault++instance Full.Foldable GetVariables Expr where+  foldMap = Full.foldMapDownDefault+~~~++Now the transformation is ready. We'll try it on this example:++~~~ {.haskell}+e1 :: Expr Identity Identity+e1 = bin Let ("x" := Identity (Con 42)) (bin Add (EVar "x") (EVar "y"))+~~~++with the help of a little combinator to shorten the construction of binary nodes:++~~~ {.haskell}+bin f a b = f (Identity a) (Identity b)+~~~++Folding the entire expression tree is as simple as applying `Deep.foldMap` at its root:++~~~ {.haskell}+-- |+-- >>> Deep.foldMap GetVariables e1+-- ["x","y"]+~~~++Traversing+----------++Suppose we want to recursively evaluate constant expressions in the language. We define another data type with a+ `Transformation` instance for the purpose. This time `Domain` and `Codomain` are both `Identity`, since the+ simplification doesn't change the tree type.++~~~ {.haskell}+data ConstantFold = ConstantFold++instance Transformation ConstantFold where+  type Domain ConstantFold = Identity+  type Codomain ConstantFold = Identity++instance ConstantFold `At` Expr Identity Identity where+  ConstantFold $ Identity (Add (Identity (Con x)) (Identity (Con y))) = Identity (Con (x + y))+  ConstantFold $ Identity (Mul (Identity (Con x)) (Identity (Con y))) = Identity (Con (x * y))+  ConstantFold $ Identity x = Identity x++instance ConstantFold `At` Decl Identity Identity where+  ConstantFold $ Identity x = Identity x+~~~++This transformation has to work bottom-up, so we declare++~~~ {.haskell}+instance Full.Functor ConstantFold Decl where+  (<$>) = Full.mapUpDefault++instance Full.Functor ConstantFold Expr where+  (<$>) = Full.mapUpDefault+~~~++Let's build a declaration to test.++~~~ {.haskell}+d1 :: Decl Identity Identity+d1 = "y" := Identity (bin Add (bin Mul (Con 42) (Con 68)) (Con 7))+~~~++As we're keeping the tree this time, instead of `Deep.foldMap` we can use `Deep.fmap`:++~~~ {.haskell}+-- |+-- >>> Deep.fmap ConstantFold d1+-- "y" := Identity (Con 2863)+~~~++Attribute Grammars+------------------++All right, can we do something more complicated? How about inlining all constant let bindings? And while we're at it,+ removing all unused declarations - also known as dead code elimination?++When it comes to complex transformations like this, the best tool in compiler writer's belt is an attribute+ 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++type Sem = AG.Semantics DeadCodeEliminator++instance Transformation DeadCodeEliminator where+   type Domain DeadCodeEliminator = Identity+   type Codomain DeadCodeEliminator = AG.Semantics DeadCodeEliminator++instance Full.Functor DeadCodeEliminator Decl where+  (<$>) = AG.fullMapDefault runIdentity++instance Full.Functor DeadCodeEliminator Expr where+  (<$>) = AG.fullMapDefault runIdentity+~~~++We also need another bit of a boilerplate instance that can be automatically generated with Template Haskell functions+ from [`Rank2.TH`](https://hackage.haskell.org/package/rank2classes/docs/Rank2-TH.html):++~~~ {.haskell}+instance Rank2.Apply (Decl f') where+  (v := e1) <*> ~(_ := e2) = v := (Rank2.apply e1 e2)+  Seq x1 y1 <*> ~(Seq x2 y2) = Seq (Rank2.apply x1 x2) (Rank2.apply y1 y2)++instance Rank2.Apply (Expr f') where+  Con n <*> _  = Con n+  EVar v <*> _ = EVar v+  Let d1 e1 <*> ~(Let d2 e2) = Let (Rank2.apply d1 d2) (Rank2.apply e1 e2)+  Add x1 y1 <*> ~(Add x2 y2) = Add (Rank2.apply x1 x2) (Rank2.apply y1 y2)+  Mul x1 y1 <*> ~(Mul x2 y2) = Mul (Rank2.apply x1 x2) (Rank2.apply y1 y2)+~~~++### Attributes++Every type of node can have different inherited and synthesized attributes, so we need to declare what they are. Since+ we want to inline the constant bindings declared in outer scopes, we must keep track of all visible bindings. This+ kind of *environment* is a typical example of an inherited attribute. It is also the only attribute inherited by an+ expression.++~~~ {.haskell}+type Env = Var -> Maybe (Expr Identity Identity)+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])+~~~++A `Decl` needs to synthesize the environment of constant bindings it generates itself, as well as a modified+ declaration without useless assignments. To cover the case where the whole of synthesized declaration is useless, we+ need to wrap it in a `Maybe`.++~~~ {.haskell}+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+ eliminated. The simplified exression is our one synthesized attribute. The only other thing we need to know about an+ `Expr` is the list of variables it uses. We *could* make the used variable list its synthesized attribute, but it's+ easier to reuse the existing `GetVariables` transformation.++~~~ {.haskell}+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+ 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)+               -> (Inherited   t (g sem sem), g sem (Synthesized t))+               -> (Synthesized t (g sem sem), g sem (Inherited t))+~~~++### Expression rules++Let's see a few simple `attribution` rules first. The rules for leaf nodes can ignore their childrens' attributes+because they don't have any children.++~~~ {.haskell}+instance AG.Attribution DeadCodeEliminator Expr Identity Identity where+  attribution DeadCodeEliminator (Identity e@(EVar v)) (AG.Inherited env, _) =+    (AG.Synthesized (maybe e id $ env v), EVar v)+  attribution DeadCodeEliminator (Identity e@(Con n)) (AG.Inherited env, _) =+    (AG.Synthesized e, Con n)+~~~++The `Add` and `Mul` nodes' rules need only to pass their inheritance down and to re-join the synthesized child+expressions. Note that boilerplate code like this can be eliminated using the constructs from the+[`Transformation.AG.Generics`](https://hackage.haskell.org/package/deep-transformations/docs/Transformation-AG-Generics.html)+module.++~~~ {.haskell}+  attribution DeadCodeEliminator (Identity Add{}) (inh, (Add (AG.Synthesized e1') (AG.Synthesized e2'))) =+    (AG.Synthesized (bin Add e1' e2'),+     Add inh inh)+  attribution DeadCodeEliminator (Identity Mul{}) (inh, Mul (AG.Synthesized e1') (AG.Synthesized e2')) =+    (AG.Synthesized (bin Mul e1' e2'),+     Mul inh inh)+~~~++The only non-trivial rule is for the `Let` node. It needs to pass the list of variables used in its expression child+ as an inherited attribute of its declaration child. Furthermore, in case its declaration is useless the `Let` node+ should disappear from the synthesized expression.++~~~ {.haskell}+  attribution DeadCodeEliminator (Identity (Let _decl expr))+              (AG.Inherited env, (Let (AG.Synthesized ~(env', decl')) (AG.Synthesized expr'))) =+    (AG.Synthesized (maybe id (bin Let) decl' expr'),+     Let (AG.Inherited (env, Full.foldMap GetVariables expr)) (AG.Inherited $ \v-> env' v <|> env v))+~~~++### Declaration rules++The rules for `Decl` are a bit more involved.++~~~ {.haskell}+instance AG.Attribution DeadCodeEliminator Decl Identity Identity where+~~~++A single variable binding can be in three distinct situations. If the variable is not referenced at all, we can just+erase the declaration. If the variable is referenced but the value assigned to it is constant, we can again erase the+declaration and store the constant binding in the environment instead. Finally, if nothing else works we must preserve+the declaration.++~~~ {.haskell}+  attribution DeadCodeEliminator (Identity (v := e)) (AG.Inherited ~(env, used), (_ := AG.Synthesized e')) =+    (AG.Synthesized (if null (Deep.foldMap GetVariables e')+                     then (\var-> if var == v then Just e' else Nothing, Nothing)  -- constant binding+                     else (const Nothing, if v `elem` used+                                          then Just (v := Identity e')             -- used binding+                                          else Nothing)),                          -- unused binding+     v := AG.Inherited env)+~~~++The rule for a sequence of declarations is much simpler: we only need to combine the two synthesized environments into+their union and to reconstruct the simplified sequence from its simplified children. Note that the sequence becomes+unnecessary if either of its children disappears.++~~~ {.haskell}+  attribution DeadCodeEliminator (Identity Seq{}) (inh, (Seq (AG.Synthesized (env1, d1')) (AG.Synthesized (env2, d2')))) =+    (AG.Synthesized (\v-> env1 v <|> env2 v,+                     bin Seq <$> d1' <*> d2' <|> d1' <|> d2'),+     Seq inh inh)+~~~++### Test++Here is the attribute grammar finally in action:++~~~ {.haskell}+-- |+-- >>> let s = Full.fmap 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+-- Identity (Con 2905)+~~~

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

@@ -0,0 +1,55 @@+-- Initial language-oberon.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                deep-transformations+version:             0.1+synopsis:            Deep natural and unnatural tree transformations, including attribute grammars+description:++   This library builds on the <http://hackage.haskell.org/package/rank2classes rank2classes> package to provide the+   equivalents of 'Functor' and related classes for heterogenous trees, including complex abstract syntax trees of+   real-world programming languages.+   .+   The functionality includes attribute grammars in "Transformation.AG".++homepage:            https://github.com/blamario/grampa/tree/master/deep-transformations+bug-reports:         https://github.com/blamario/grampa/issues+license:             BSD3+license-file:        LICENSE+author:              Mario Blažević+maintainer:          blamario@protonmail.com+copyright:           (c) 2019 Mario Blažević+category:            Control, Generics+build-type:          Custom+cabal-version:       >=1.10+extra-source-files:  README.md+source-repository head+  type:              git+  location:          https://github.com/blamario/grampa+custom-setup+ setup-depends:+   base >= 4 && <5,+   Cabal,+   cabal-doctest >= 1 && <1.1+ +library+  hs-source-dirs:       src+  exposed-modules:      Transformation,+                        Transformation.Shallow, Transformation.Shallow.TH,+                        Transformation.Deep, Transformation.Deep.TH,+                        Transformation.Full, Transformation.Full.TH,+                        Transformation.Rank2, Transformation.AG, Transformation.AG.Generics+  ghc-options:         -Wall+  build-depends:        base >= 4.7 && < 5, rank2classes >= 1.4.1 && < 1.5,+                        template-haskell >= 2.11 && < 2.17, generic-lens == 2.0.*+  default-language:     Haskell2010++test-suite doctests+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  default-language:    Haskell2010+  main-is:             Doctest.hs+  other-modules:       README, RepMin, RepMinAuto+  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

@@ -0,0 +1,79 @@+{-# Language FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables,+             TypeFamilies, TypeOperators, UndecidableInstances #-}++-- | A /natural transformation/ is a concept from category theory for a mapping between two functors and their objects+-- that preserves a naturality condition. In Haskell the naturality condition boils down to parametricity, so a+-- natural transformation between two functors @f@ and @g@ is represented as+--+-- > type NaturalTransformation f g = ∀a. f a → g a+--+-- This type appears in several Haskell libraries, most obviously in+-- [natural-transformations](https://hackage.haskell.org/package/natural-transformation). There are times, however,+-- when we crave more control. Sometimes what we want to do depends on which type @a@ is hiding in that @f a@ we're+-- given. Sometimes, in other words, we need an /unnatural/ transformation.+--+-- This means we have to abandon parametricity for ad-hoc polymorphism, and that means type classes. There are two+-- steps to defining a transformation:+--+-- * an instance of the base class 'Transformation' declares the two functors being mapped, much like a function type+--   signature,+-- * while the actual mapping of values is performed by an arbitrary number of instances of the method '$', a bit like+--   multiple equation clauses that make up a single function definition.+--+-- The module is meant to be imported qualified.++module Transformation where++import Data.Functor.Product (Product(Pair))+import Data.Functor.Sum (Sum(InL, InR))+import Data.Kind (Type)+import qualified Rank2++import Prelude hiding (($))++-- | A 'Transformation', natural or not, maps one functor to another.+class Transformation t where+   type Domain t :: Type -> Type+   type Codomain t :: Type -> Type++-- | An unnatural 'Transformation' can behave differently at different points.+class Transformation t => At t x where+   -- | Apply the transformation @t@ at type @x@ to map 'Domain' to the 'Codomain' functor.+   ($) :: t -> Domain t x -> Codomain t x+   infixr 0 $++-- | Alphabetical synonym for '$'+apply :: t `At` x => t -> Domain t x -> Codomain t x+apply = ($)++-- | Composition of two transformations+data Compose t u = Compose t u++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++instance (t `At` x, u `At` x, Domain t ~ Codomain u) => Compose t u `At` x where+   Compose t u $ x =  t $ (u $ x)++instance Transformation (Rank2.Arrow p q x) where+   type Domain (Rank2.Arrow p q x) = p+   type Codomain (Rank2.Arrow p q x) = q++instance Rank2.Arrow p q x `At` x where+   ($) = Rank2.apply++instance (Transformation t1, Transformation t2, Domain t1 ~ Domain t2) => Transformation (t1, t2) where+   type Domain (t1, t2) = Domain t1+   type Codomain (t1, t2) = Product (Codomain t1) (Codomain t2)++instance (t `At` x, u `At` x, Domain t ~ Domain u) => (t, u) `At` x where+   (t, u) $ x = Pair (t $ x) (u $ x)++instance (Transformation t1, Transformation t2, Domain t1 ~ Domain t2) => Transformation (Either t1 t2) where+   type Domain (Either t1 t2) = Domain t1+   type Codomain (Either t1 t2) = Sum (Codomain t1) (Codomain t2)++instance (t `At` x, u `At` x, Domain t ~ Domain u) => Either t u `At` x where+   Left t $ x = InL (t $ x)+   Right t $ x = InR (t $ x)

@@ -0,0 +1,71 @@+{-# Language FlexibleContexts, FlexibleInstances,+             MultiParamTypeClasses, RankNTypes, StandaloneDeriving,+             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+-- attributes are divided into 'Inherited' and 'Synthesized' attributes.++module Transformation.AG where++import qualified Rank2+import Transformation (Domain, Codomain)+import qualified Transformation.Deep as Deep++-- | Type family that maps a node type to the type of its attributes, indexed per type constructor.+type family Atts (f :: * -> *) a++-- | Type constructor wrapping the inherited attributes for the given transformation.+newtype Inherited t a = Inherited{inh :: Atts (Inherited t) a}+-- | Type constructor wrapping the synthesized attributes for the given transformation.+newtype Synthesized t a = Synthesized{syn :: Atts (Synthesized t) a}++deriving instance (Show (Atts (Inherited t) a)) => Show (Inherited t a)+deriving instance (Show (Atts (Synthesized t) a)) => Show (Synthesized t 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++-- | An attribution rule maps a node's inherited attributes and its child nodes' synthesized attributes to the node's+-- synthesized attributes and the children nodes' inherited attributes.+type Rule t g =  forall sem . sem ~ Semantics t+              => (Inherited   t (g sem sem), g sem (Synthesized t))+              -> (Synthesized t (g sem sem), g sem (Inherited t))++-- | 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++-- | 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+-- >   attribution MyAttGrammar{} (Identity MyNode{})+-- >               (Inherited   fromParent,+-- >                Synthesized MyNode{firstChild= fromFirstChild, ...})+-- >             = (Synthesized _forMyself,+-- >                Inherited   MyNode{firstChild= _forFirstChild, ...})+--+-- If you prefer to separate the calculation of different attributes, you can split the above instance into two+-- 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+   -- | The attribution rule for a given transformation and node.+   attribution :: t -> shallow (g deep deep) -> Rule t g++-- | 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 #-}++-- | Drop-in implementation of 'Transformation.Full.<$>'+fullMapDefault :: (p ~ Domain t, q ~ Semantics t, q ~ Codomain t, x ~ g q q, Rank2.Apply (g q),+                   Deep.Functor t g, Attribution t g p p)+               => (forall a. p a -> a) -> t -> p (g p p) -> q (g q q)+fullMapDefault extract t local = knit (attribution t local) (t Deep.<$> extract local)+{-# INLINE fullMapDefault #-}

@@ -0,0 +1,262 @@+{-# Language DataKinds, DefaultSignatures, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,+             MultiParamTypeClasses, PolyKinds, RankNTypes, ScopedTypeVariables, StandaloneDeriving,+             TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}++-- | This module can be used to scrap the boilerplate attribute declarations. In particular:+--+-- * If an 'attribution' rule always merely copies the inherited attributes to the children's inherited attributes of+--   the same name, the rule can be left out by wrapping the transformation into an 'Auto' constructor and deriving+--   the 'Generic' instance of the inherited attributes.+-- * A synthesized attribute whose value is a fold of all same-named attributes of the children can be wrapped in the+--   'Folded' constructor and calculated automatically.+-- * A synthesized attribute that is a copy of the current node but with every child taken from the same-named+--   synthesized child attribute can be wrapped in the 'Mapped' constructor and calculated automatically.+-- * If the attribute additionally carries an applicative effect, the 'Mapped' wrapper can be replaced by 'Traversed'.++module Transformation.AG.Generics (-- * Type wrappers for automatic attribute inference+                                   Auto(..), Folded(..), Mapped(..), Traversed(..),+                                   -- * Type classes replacing 'Attribution'+                                   Bequether(..), Synthesizer(..), SynthesizedField(..), Revelation(..),+                                   -- * The default behaviour on generic datatypes+                                   foldedField, mappedField, passDown, bequestDefault)+where++import Data.Functor.Compose (Compose(..))+import Data.Functor.Const (Const(..))+import Data.Functor.Identity (Identity(..))+import Data.Kind (Type)+import Data.Generics.Product.Subtype (Subtype(upcast))+import Data.Proxy (Proxy(..))+import GHC.Generics+import GHC.Records+import GHC.TypeLits (Symbol, ErrorMessage (Text), TypeError)+import Unsafe.Coerce (unsafeCoerce)+import Transformation (Transformation, Domain, Codomain)+import Transformation.AG+import qualified Transformation+import qualified Transformation.Shallow as Shallow++-- | Transformation wrapper that allows automatic inference of attribute rules.+newtype Auto t = Auto t++instance {-# overlappable #-} (Bequether (Auto t) g d s, Synthesizer (Auto t) g d s) => Attribution (Auto t) g d s where+   attribution t l (Inherited i, s) = (Synthesized $ synthesis t l i s, bequest t l i s)++class (Transformation t, dom ~ Domain t) => Revelation t dom where+   -- | Extract the value from the transformation domain+   reveal :: t -> dom 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  +               -> 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)            -- ^ tre node+               -> Atts (Inherited t) (g sem sem)   -- ^ inherited attributes  +               -> g sem (Synthesized t)            -- ^ synthesized attributes+               -> Atts (Synthesized t) (g sem sem)++-- | Class for specifying a single named attribute+class SynthesizedField (name :: Symbol) result t g deep shallow where+   synthesizedField  :: forall sem. sem ~ Semantics t =>+                        Proxy name                      -- ^ attribute name+                     -> t                               -- ^ transformation+                     -> shallow (g deep deep)           -- ^ tree node+                     -> Atts (Inherited t) (g sem sem)  -- ^ inherited attributes+                     -> g sem (Synthesized t)           -- ^ synthesized attributes+                     -> result++instance (Transformation t, Domain t ~ Identity) => Revelation t Identity where+   reveal _ (Identity x) = x++instance (Transformation t, Domain t ~ (,) a) => Revelation t ((,) a) where+   reveal _ (_, x) = x++instance {-# overlappable #-} (sem ~ Semantics t, Domain t ~ shallow, Revelation t shallow,+                               Shallow.Functor (PassDown t sem (Atts (Inherited t) (g sem sem))) (g sem)) =>+                              Bequether t g (Semantics t) shallow 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+   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+-- attributes of the same name.+newtype Folded a = Folded{getFolded :: a} deriving (Eq, Ord, Show, Semigroup, Monoid)+-- | Wrapper for a field that should be automatically synthesized by replacing every child node by its synthesized+-- 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)++-- * Generic transformations++-- | Internal transformation for passing down the inherited attributes.+newtype PassDown (t :: Type) (f :: * -> *) a = PassDown a+-- | Internal transformation for accumulating the 'Folded' attributes.+data Accumulator (t :: Type) (name :: Symbol) (a :: Type) = Accumulator+-- | Internal transformation for replicating the 'Mapped' attributes.+data Replicator (t :: Type) (f :: Type -> Type) (name :: Symbol) = Replicator+-- | Internal transformation for traversing the 'Traversed' attributes.+data Traverser (t :: Type) (m :: Type -> Type) (f :: Type -> Type) (name :: Symbol) = Traverser++instance Transformation (PassDown t f a) where+  type Domain (PassDown t f a) = f+  type Codomain (PassDown t f a) = Inherited t++instance Transformation (Accumulator t name a) where+  type Domain (Accumulator t name a) = Synthesized t+  type Codomain (Accumulator t name a) = Const (Folded a)++instance Transformation (Replicator t f name) where+  type Domain (Replicator t f name) = Synthesized t+  type Codomain (Replicator t f name) = f++instance Transformation (Traverser t m f name) where+  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+   ($) (PassDown i) _ = Inherited (upcast i)++instance (Monoid a, r ~ Atts (Synthesized t) 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+   _ $ 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+   _ $ 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 =>+                        t+                     -> shallow (g deep deep)+                     -> Atts (Inherited t) (g sem sem)+                     -> 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 =>+                               Proxy name+                            -> t+                            -> shallow (g deep deep)+                            -> Atts (Inherited t) (g sem sem)+                            -> g sem (Synthesized t)+                            -> result a++-- | Used for accumulating the 'Folded' fields +class MayHaveMonoidalField (name :: Symbol) a f where+   getMonoidalField :: Proxy name -> f x -> a+class FoundField a f where+   getFoundField :: f x -> a++instance {-# overlaps #-} (MayHaveMonoidalField name a x, MayHaveMonoidalField name a y, Semigroup a) =>+         MayHaveMonoidalField name a (x :*: y) where+   getMonoidalField name (x :*: y) = getMonoidalField name x <> getMonoidalField name y++instance {-# overlaps #-} TypeError ('Text "Cannot get a single field value from a sum type") =>+         MayHaveMonoidalField name a (x :+: y) where+   getMonoidalField _ _ = error "getMonoidalField on sum type"++instance {-# overlaps #-} FoundField a f => MayHaveMonoidalField name a (M1 i ('MetaSel ('Just name) su ss ds) f) where+   getMonoidalField _ (M1 x) = getFoundField x++instance {-# overlaps #-} Monoid a => MayHaveMonoidalField name a (M1 i ('MetaSel 'Nothing su ss ds) f) where+   getMonoidalField _ _ = mempty++instance {-# overlaps #-} MayHaveMonoidalField name a f => MayHaveMonoidalField name a (M1 i ('MetaData n m p nt) f) where+   getMonoidalField name (M1 x) = getMonoidalField name x++instance {-# overlaps #-} MayHaveMonoidalField name a f => MayHaveMonoidalField name a (M1 i ('MetaCons n fi s) f) where+   getMonoidalField name (M1 x) = getMonoidalField name x++instance {-# overlappable #-} Monoid a => MayHaveMonoidalField name a f where+   getMonoidalField _ _ = mempty++instance FoundField a f => FoundField a (M1 i j f) where+     getFoundField (M1 f) = getFoundField f++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+   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+   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+   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+   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+   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+   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+   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,+                   Shallow.Functor (PassDown t sem (Atts (Inherited t) (g sem sem))) (g sem))+               => t -> shallow (g sem sem) -> Atts (Inherited t) (g sem sem) -> g sem (Synthesized t)+               -> g sem (Inherited t)+bequestDefault t local inheritance _synthesized = passDown inheritance (reveal t local)++-- | 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++-- | 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)) =>+               Proxy name -> t -> g sem (Synthesized t) -> Folded a+foldedField _name _t s = Shallow.foldMap (Accumulator :: Accumulator t name a) s++-- | 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)) =>+                  Proxy name -> t -> g sem (Synthesized t) -> g f f+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)) =>+                     Proxy name -> t -> g sem (Synthesized t) -> m (g f f)+traversedField _name _t s = Shallow.traverse (Traverser :: Traverser t m f name) (unsafeCoerce s :: g f (Synthesized t))

@@ -0,0 +1,73 @@+{-# Language DeriveDataTypeable, FlexibleInstances, KindSignatures, MultiParamTypeClasses, RankNTypes,+             StandaloneDeriving, TypeFamilies, 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+-- in the "Transformation.Shallow" module operate only on the immediate children, while those from the+-- "Transformation.Full" module include the argument node itself.++module Transformation.Deep where++import Control.Applicative (Applicative, liftA2)+import Data.Data (Data, Typeable)+import Data.Functor.Compose (Compose)+import Data.Functor.Const (Const)+import qualified Rank2+import qualified Data.Functor+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+class (Transformation t, Rank2.Functor (g (Domain t))) => Functor t g where+   (<$>) :: t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)++-- | Like "Transformation.Shallow".'Transformation.Shallow.Foldable' except it folds all descendants and not only immediate children+class (Transformation t, Rank2.Foldable (g (Domain t))) => Foldable t g where+   foldMap :: (Codomain t ~ Const m, Monoid m) => t -> g (Domain t) (Domain t) -> m++-- | 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)++-- | Like 'Data.Functor.Product.Product' for data types with two type constructor parameters+data Product g1 g2 (p :: * -> *) (q :: * -> *) = Pair{fst :: q (g1 p p),+                                                      snd :: q (g2 p p)}++instance Rank2.Functor (Product g1 g2 p) where+   f <$> ~(Pair left right) = Pair (f left) (f right)++instance Rank2.Apply (Product g h p) where+   ~(Pair g1 h1) <*> ~(Pair g2 h2) = Pair (Rank2.apply g1 g2) (Rank2.apply h1 h2)+   liftA2 f ~(Pair g1 h1) ~(Pair g2 h2) = Pair (f g1 g2) (f h1 h2)++instance Rank2.Applicative (Product g h p) where+   pure f = Pair f f++instance Rank2.Foldable (Product g h p) where+   foldMap f ~(Pair g h) = f g `mappend` f h++instance Rank2.Traversable (Product g h p) where+   traverse f ~(Pair g h) = liftA2 Pair (f g) (f h)++instance Rank2.DistributiveTraversable (Product g h p)++instance Rank2.Distributive (Product g h p) where+   cotraverse w f = Pair{fst= w (fst Data.Functor.<$> f),+                         snd= w (snd Data.Functor.<$> f)}++instance (Full.Functor t g, Full.Functor t h) => Functor t (Product g h) where+   t <$> Pair left right = Pair (t Full.<$> left) (t Full.<$> right)++instance (Full.Traversable t g, Full.Traversable t h, Codomain t ~ Compose m f, Applicative m) =>+         Traversable t (Product g h) where+   traverse t (Pair left right) = liftA2 Pair (Full.traverse t left) (Full.traverse t right)++deriving instance (Typeable p, Typeable q, Typeable g1, Typeable g2,+                   Data (q (g1 p p)), Data (q (g2 p p))) => Data (Product g1 g2 p q)+deriving instance (Show (q (g1 p p)), Show (q (g2 p p))) => Show (Product g1 g2 p q)++-- | Alphabetical synonym for '<$>'+fmap :: Functor t g => t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)+fmap = (<$>)

@@ -0,0 +1,19 @@+{-# Language MultiParamTypeClasses, RankNTypes, TypeFamilies #-}++module Transformation.Deep where++import Data.Functor.Compose (Compose)+import Data.Functor.Const (Const)+import qualified Rank2+import           Transformation (Transformation, Domain, Codomain)++import Prelude hiding (Functor, Foldable, Traversable, (<$>), foldMap, traverse)++class (Transformation t, Rank2.Functor (g (Domain t))) => Functor t g where+   (<$>) :: t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)++class (Transformation t, Rank2.Foldable (g (Domain t))) => Foldable t g where+   foldMap :: (Codomain t ~ Const m, Monoid m) => t -> g (Domain t) (Domain t) -> m++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)

@@ -0,0 +1,335 @@+-- | This module exports the templates for automatic instance deriving of "Transformation.Deep" type classes. The most+-- common way to use it would be+--+-- > import qualified Transformation.Deep.TH+-- > data MyDataType f' f = ...+-- > $(Transformation.Deep.TH.deriveFunctor ''MyDataType)+--++{-# Language TemplateHaskell #-}+-- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial++module Transformation.Deep.TH (deriveAll, deriveFunctor, deriveTraversable)+where++import Control.Applicative (liftA2)+import Control.Monad (replicateM)+import Data.Functor.Compose (Compose(getCompose))+import Data.Functor.Const (Const(getConst))+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (BangType, VarBangType, getQ, putQ)++import qualified Transformation+import qualified Transformation.Deep+import qualified Transformation.Full+++data Deriving = Deriving { _constructor :: Name, _variableN :: Name, _variable1 :: Name }++deriveAll :: Name -> Q [Dec]+deriveAll ty = foldr f (pure []) [deriveFunctor, deriveFoldable, deriveTraversable]+   where f derive rest = (<>) <$> derive ty <*> rest++deriveFunctor :: Name -> Q [Dec]+deriveFunctor typeName = do+   t <- varT <$> newName "t"+   (instanceType, cs) <- reifyConstructors typeName+   let deepConstraint ty = conT ''Transformation.Deep.Functor `appT` t `appT` ty+       fullConstraint ty = conT ''Transformation.Full.Functor `appT` t `appT` ty+       baseConstraint ty = conT ''Transformation.At `appT` t `appT` ty+   (constraints, dec) <- genDeepmap baseConstraint deepConstraint fullConstraint instanceType cs+   sequence [instanceD (cxt $ appT (conT ''Transformation.Transformation) t : map pure constraints)+                       (deepConstraint instanceType)+                       [pure dec]]++deriveFoldable :: Name -> Q [Dec]+deriveFoldable typeName = do+   t <- varT <$> newName "t"+   m <- varT <$> newName "m"+   (instanceType, cs) <- reifyConstructors typeName+   let deepConstraint ty = conT ''Transformation.Deep.Foldable `appT` t `appT` ty+       fullConstraint ty = conT ''Transformation.Full.Foldable `appT` t `appT` ty+       baseConstraint ty = conT ''Transformation.At `appT` t `appT` ty+   (constraints, dec) <- genFoldMap baseConstraint deepConstraint fullConstraint instanceType cs+   sequence [instanceD (cxt (appT (conT ''Transformation.Transformation) t :+                             appT (appT equalityT (conT ''Transformation.Codomain `appT` t))+                                  (conT ''Const `appT` m) :+                             appT (conT ''Monoid) m : map pure constraints))+                       (deepConstraint instanceType)+                       [pure dec]]++deriveTraversable :: Name -> Q [Dec]+deriveTraversable typeName = do+   t <- varT <$> newName "t"+   m <- varT <$> newName "m"+   f <- varT <$> newName "f"+   (instanceType, cs) <- reifyConstructors typeName+   let deepConstraint ty = conT ''Transformation.Deep.Traversable `appT` t `appT` ty+       fullConstraint ty = conT ''Transformation.Full.Traversable `appT` t `appT` ty+       baseConstraint ty = conT ''Transformation.At `appT` t `appT` ty+   (constraints, dec) <- genTraverse baseConstraint deepConstraint fullConstraint instanceType cs+   sequence [instanceD (cxt (appT (conT ''Transformation.Transformation) t :+                             appT (appT equalityT (conT ''Transformation.Codomain `appT` t))+                                  (conT ''Compose `appT` m `appT` f) :+                             appT (conT ''Applicative) m : map pure constraints))+                       (deepConstraint instanceType)+                       [pure dec]]++substitute :: Type -> Q Type -> Q Type -> Q Type+substitute resultType = liftA2 substitute'+   where substitute' instanceType argumentType =+            substituteVars (substitutions resultType instanceType) argumentType+         substitutions (AppT t1 (VarT name1)) (AppT t2 (VarT name2)) = (name1, name2) : substitutions t1 t2+         substitutions _t1 _t2 = []+         substituteVars subs (VarT name) = VarT (fromMaybe name $ lookup name subs)+         substituteVars subs (AppT t1 t2) = AppT (substituteVars subs t1) (substituteVars subs t2)+         substituteVars _ t = t++reifyConstructors :: Name -> Q (TypeQ, [Con])+reifyConstructors ty = do+   (TyConI tyCon) <- reify ty+   (tyConName, tyVars, _kind, cs) <- case tyCon of+      DataD _ nm tyVars kind cs _   -> return (nm, tyVars, kind, cs)+      NewtypeD _ nm tyVars kind c _ -> return (nm, tyVars, kind, [c])+      _ -> fail "deriveApply: tyCon may not be a type synonym."++   let (KindedTV tyVar  (AppT (AppT ArrowT StarT) StarT) :+        KindedTV tyVar' (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars+       instanceType           = foldl apply (conT tyConName) (reverse $ drop 2 $ reverse tyVars)+       apply t (PlainTV name)    = appT t (varT name)+       apply t (KindedTV name _) = appT t (varT name)++   putQ (Deriving tyConName tyVar' tyVar)+   return (instanceType, cs)++genDeepmap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)+genDeepmap baseConstraint deepConstraint fullConstraint instanceType cs = do+   (constraints, clauses) <- unzip <$> mapM (genDeepmapClause baseConstraint deepConstraint+                                                              fullConstraint instanceType) cs+   return (concat constraints, FunD '(Transformation.Deep.<$>) clauses)++genFoldMap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)+genFoldMap baseConstraint deepConstraint fullConstraint instanceType cs = do+   (constraints, clauses) <- unzip <$> mapM (genFoldMapClause baseConstraint deepConstraint+                                                              fullConstraint instanceType) cs+   return (concat constraints, FunD 'Transformation.Deep.foldMap clauses)++genTraverse :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)+genTraverse baseConstraint deepConstraint fullConstraint instanceType cs = do+   (constraints, clauses) <- unzip+     <$> mapM (genTraverseClause genTraverseField baseConstraint deepConstraint fullConstraint instanceType) cs+   return (concat constraints, FunD 'Transformation.Deep.traverse clauses)++genDeepmapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Con+                 -> Q ([Type], Clause)+genDeepmapClause baseConstraint deepConstraint fullConstraint _instanceType (NormalC name fieldTypes) = do+   t          <- newName "t"+   fieldNames <- replicateM (length fieldTypes) (newName "x")+   let pats = [varP t, parensP (conP name $ map varP fieldNames)]+       constraintsAndFields = zipWith newField fieldNames fieldTypes+       newFields = map (snd <$>) constraintsAndFields+       body = normalB $ appsE $ conE name : newFields+       newField :: Name -> BangType -> Q ([Type], Exp)+       newField x (_, fieldType) =+          genDeepmapField (varE t) fieldType baseConstraint deepConstraint fullConstraint (varE x) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause pats body []+genDeepmapClause baseConstraint deepConstraint fullConstraint _instanceType (RecC name fields) = do+   t <- newName "t"+   x <- newName "x"+   let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields+       constraintsAndFields = map newNamedField fields+       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))+       newNamedField (fieldName, _, fieldType) =+          ((,) fieldName <$>)+          <$> genDeepmapField (varE t) fieldType baseConstraint deepConstraint fullConstraint+                              (appE (varE fieldName) (varE x)) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP t, x `asP` recP name []] body []+genDeepmapClause baseConstraint deepConstraint fullConstraint instanceType+                 (GadtC [name] fieldTypes (AppT (AppT resultType (VarT tyVar')) (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar' _tyVar) <- getQ+      putQ (Deriving tyConName tyVar' tyVar)+      genDeepmapClause (baseConstraint . substitute resultType instanceType)+                       (deepConstraint . substitute resultType instanceType)+                       (fullConstraint . substitute resultType instanceType)+                       instanceType (NormalC name fieldTypes)+genDeepmapClause baseConstraint deepConstraint fullConstraint instanceType+                 (RecGadtC [name] fields (AppT (AppT resultType (VarT tyVar')) (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar' _tyVar) <- getQ+      putQ (Deriving tyConName tyVar' tyVar)+      genDeepmapClause (baseConstraint . substitute resultType instanceType)+                       (deepConstraint . substitute resultType instanceType)+                       (fullConstraint . substitute resultType instanceType)+                       instanceType (RecC name fields)+genDeepmapClause baseConstraint deepConstraint fullConstraint instanceType (ForallC _vars _cxt con) =+   genDeepmapClause baseConstraint deepConstraint fullConstraint instanceType con++genFoldMapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Con+                 -> Q ([Type], Clause)+genFoldMapClause baseConstraint deepConstraint fullConstraint _instanceType (NormalC name fieldTypes) = do+   t          <- newName "t"+   fieldNames <- replicateM (length fieldTypes) (newName "x")+   let pats = [varP t, conP name (map varP fieldNames)]+       constraintsAndFields = zipWith newField fieldNames fieldTypes+       body | null fieldNames = [| mempty |]+            | otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields+       append a b = [| $(a) <> $(b) |]+       newField :: Name -> BangType -> Q ([Type], Exp)+       newField x (_, fieldType) = genFoldMapField (varE t) fieldType baseConstraint deepConstraint fullConstraint+                                                   (varE x) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause pats (normalB body) []+genFoldMapClause baseConstraint deepConstraint fullConstraint _instanceType (RecC name fields) = do+   t <- newName "t"+   x <- newName "x"+   let body | null fields = [| mempty |]+            | otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields+       constraintsAndFields = map newField fields+       append a b = [| $(a) <> $(b) |]+       newField :: VarBangType -> Q ([Type], Exp)+       newField (fieldName, _, fieldType) = genFoldMapField (varE t) fieldType baseConstraint deepConstraint+                                                            fullConstraint (appE (varE fieldName) (varE x)) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP t, x `asP` recP name []] (normalB body) []+genFoldMapClause baseConstraint deepConstraint fullConstraint instanceType+                 (GadtC [name] fieldTypes (AppT (AppT resultType (VarT tyVar')) (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar' _tyVar) <- getQ+      putQ (Deriving tyConName tyVar' tyVar)+      genFoldMapClause (baseConstraint . substitute resultType instanceType)+                       (deepConstraint . substitute resultType instanceType)+                       (fullConstraint . substitute resultType instanceType)+                       instanceType (NormalC name fieldTypes)+genFoldMapClause baseConstraint deepConstraint fullConstraint instanceType+                 (RecGadtC [name] fields (AppT (AppT resultType (VarT tyVar')) (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar' _tyVar) <- getQ+      putQ (Deriving tyConName tyVar' tyVar)+      genFoldMapClause (baseConstraint . substitute resultType instanceType)+                       (deepConstraint . substitute resultType instanceType)+                       (fullConstraint . substitute resultType instanceType)+                       instanceType (RecC name fields)+genFoldMapClause baseConstraint deepConstraint fullConstraint instanceType (ForallC _vars _cxt con) =+   genFoldMapClause baseConstraint deepConstraint fullConstraint instanceType con++type GenTraverseFieldType = Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> (Q Type -> Q Type)+                            -> Q Exp -> (Q Exp -> Q Exp)+                            -> Q ([Type], Exp)++genTraverseClause :: GenTraverseFieldType -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> (Q Type -> Q Type)+                  -> Q Type -> Con+                  -> Q ([Type], Clause)+genTraverseClause genField baseConstraint deepConstraint fullConstraint _instanceType (NormalC name fieldTypes) =+   do t          <- newName "t"+      fieldNames <- replicateM (length fieldTypes) (newName "x")+      let pats = [varP t, parensP (conP name $ map varP fieldNames)]+          constraintsAndFields = zipWith newField fieldNames fieldTypes+          newFields = map (snd <$>) constraintsAndFields+          body | null fieldTypes = [| pure $(conE name) |]+               | otherwise = fst $ foldl apply (conE name, False) newFields+          apply (a, False) b = ([| $(a) <$> $(b) |], True)+          apply (a, True) b = ([| $(a) <*> $(b) |], True)+          newField :: Name -> BangType -> Q ([Type], Exp)+          newField x (_, fieldType) =+             genField (varE t) fieldType baseConstraint deepConstraint fullConstraint (varE x) id+      constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+      (,) constraints <$> clause pats (normalB body) []+genTraverseClause genField baseConstraint deepConstraint fullConstraint _instanceType (RecC name fields) = do+   f <- newName "f"+   x <- newName "x"+   let constraintsAndFields = map newNamedField fields+       body | null fields = [| pure $(conE name) |]+            | otherwise = fst (foldl apply (conE name, False) $ map (snd . snd <$>) constraintsAndFields)+       apply (a, False) b = ([| $(a) <$> $(b) |], True)+       apply (a, True) b = ([| $(a) <*> $(b) |], True)+       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))+       newNamedField (fieldName, _, fieldType) =+          ((,) fieldName <$>)+          <$> genField (varE f) fieldType baseConstraint deepConstraint fullConstraint+                               (appE (varE fieldName) (varE x)) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP f, x `asP` recP name []] (normalB body) []+genTraverseClause genField baseConstraint deepConstraint fullConstraint instanceType+                  (GadtC [name] fieldTypes (AppT (AppT resultType (VarT tyVar')) (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar' _tyVar) <- getQ+      putQ (Deriving tyConName tyVar' tyVar)+      genTraverseClause genField+                        (baseConstraint . substitute resultType instanceType)+                        (deepConstraint . substitute resultType instanceType)+                        (fullConstraint . substitute resultType instanceType)+                        instanceType (NormalC name fieldTypes)+genTraverseClause genField baseConstraint deepConstraint fullConstraint instanceType+                  (RecGadtC [name] fields (AppT (AppT resultType (VarT tyVar')) (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar' _tyVar) <- getQ+      putQ (Deriving tyConName tyVar' tyVar)+      genTraverseClause genField+                        (baseConstraint . substitute resultType instanceType)+                        (deepConstraint . substitute resultType instanceType)+                        (fullConstraint . substitute resultType instanceType)+                        instanceType (RecC name fields)+genTraverseClause genField baseConstraint deepConstraint fullConstraint instanceType (ForallC _vars _cxt con) =+   genTraverseClause genField baseConstraint deepConstraint fullConstraint instanceType con++genDeepmapField :: Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> (Q Type -> Q Type)+                -> Q Exp -> (Q Exp -> Q Exp)+                -> Q ([Type], Exp)+genDeepmapField trans fieldType baseConstraint deepConstraint fullConstraint fieldAccess wrap = do+   Just (Deriving _ typeVarN typeVar1) <- getQ+   case fieldType of+     AppT ty (AppT (AppT con v1) v2) | ty == VarT typeVar1, v1 == VarT typeVarN, v2 == VarT typeVarN ->+        (,) <$> ((:[]) <$> fullConstraint (pure con))+            <*> appE (wrap [| ($trans Transformation.Full.<$>) |]) fieldAccess+     AppT ty a | ty == VarT typeVar1 ->+        (,) <$> ((:[]) <$> baseConstraint (pure a))+            <*> (wrap (varE '(Transformation.$) `appE` trans) `appE` fieldAccess)+     AppT (AppT con v1) v2 | v1 == VarT typeVarN, v2 == VarT typeVar1 ->+        (,) <$> ((:[]) <$> deepConstraint (pure con))+            <*> appE (wrap [| Transformation.Deep.fmap $trans |]) fieldAccess+     AppT t1 t2 | t1 /= VarT typeVar1 ->+        genDeepmapField trans t2 baseConstraint deepConstraint fullConstraint fieldAccess (wrap . appE (varE '(<$>)))+     SigT ty _kind -> genDeepmapField trans ty baseConstraint deepConstraint fullConstraint fieldAccess wrap+     ParensT ty -> genDeepmapField trans ty baseConstraint deepConstraint fullConstraint fieldAccess wrap+     _ -> (,) [] <$> fieldAccess++genFoldMapField :: Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> (Q Type -> Q Type)+                -> Q Exp -> (Q Exp -> Q Exp)+                -> Q ([Type], Exp)+genFoldMapField trans fieldType baseConstraint deepConstraint fullConstraint fieldAccess wrap = do+   Just (Deriving _ typeVarN typeVar1) <- getQ+   case fieldType of+     AppT ty (AppT (AppT con v1) v2) | ty == VarT typeVar1, v1 == VarT typeVarN, v2 == VarT typeVarN ->+        (,) <$> ((:[]) <$> fullConstraint (pure con))+            <*> appE (wrap [| Transformation.Full.foldMap $trans |]) fieldAccess+     AppT ty a | ty == VarT typeVar1 ->+        (,) <$> ((:[]) <$> baseConstraint (pure a))+            <*> (wrap (varE '(.) `appE` varE 'getConst `appE` (varE '(Transformation.$) `appE` trans))+                 `appE` fieldAccess)+     AppT (AppT con v1) v2 | v1 == VarT typeVarN, v2 == VarT typeVar1 ->+        (,) <$> ((:[]) <$> deepConstraint (pure con))+            <*> appE (wrap [| Transformation.Deep.foldMap $trans |]) fieldAccess+     AppT t1 t2 | t1 /= VarT typeVar1 ->+        genFoldMapField trans t2 baseConstraint deepConstraint fullConstraint fieldAccess (wrap . appE (varE 'foldMap))+     SigT ty _kind -> genFoldMapField trans ty baseConstraint deepConstraint fullConstraint fieldAccess wrap+     ParensT ty -> genFoldMapField trans ty baseConstraint deepConstraint fullConstraint fieldAccess wrap+     _ -> (,) [] <$> [| mempty |]++genTraverseField :: GenTraverseFieldType+genTraverseField trans fieldType baseConstraint deepConstraint fullConstraint fieldAccess wrap = do+   Just (Deriving _ typeVarN typeVar1) <- getQ+   case fieldType of+     AppT ty (AppT (AppT con v1) v2) | ty == VarT typeVar1, v1 == VarT typeVarN, v2 == VarT typeVarN ->+        (,) <$> ((:[]) <$> fullConstraint (pure con))+            <*> appE (wrap [| Transformation.Full.traverse $trans |]) fieldAccess+     AppT ty a  | ty == VarT typeVar1 ->+        (,) <$> ((:[]) <$> baseConstraint (pure a))+            <*> (wrap (varE '(.) `appE` varE 'getCompose `appE` (varE '(Transformation.$) `appE` trans))+                 `appE` fieldAccess)+     AppT (AppT con v1) v2 | v1 == VarT typeVarN, v2 == VarT typeVar1 ->+        (,) <$> ((:[]) <$> deepConstraint (pure con))+            <*> appE (wrap [| Transformation.Deep.traverse $trans |]) fieldAccess+     AppT t1 t2 | t1 /= VarT typeVar1 -> genTraverseField trans t2 baseConstraint deepConstraint fullConstraint+                                                          fieldAccess (wrap . appE (varE 'traverse))+     SigT ty _kind -> genTraverseField trans ty baseConstraint deepConstraint fullConstraint fieldAccess wrap+     ParensT ty -> genTraverseField trans ty baseConstraint deepConstraint fullConstraint fieldAccess wrap+     _ -> (,) [] <$> [| pure $fieldAccess |]

@@ -0,0 +1,66 @@+{-# Language FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, 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+-- in the "Transformation.Shallow" moduleo perate only on the immediate children, while those from the+-- "Transformation.Deep" module exclude the argument node itself.++module Transformation.Full where++import qualified Data.Functor+import           Data.Functor.Compose (Compose(getCompose))+import           Data.Functor.Const (Const(getConst))+import qualified Data.Foldable+import qualified Data.Traversable+import qualified Rank2+import qualified Transformation+import           Transformation (Transformation, Domain, Codomain)+import {-# SOURCE #-} qualified Transformation.Deep as Deep++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))++-- | Like "Transformation.Deep".'Deep.Foldable' except the entire tree is also wrapped+class (Transformation t, Rank2.Foldable (g (Domain t))) => Foldable t g where+   foldMap :: (Codomain t ~ Const m, Monoid m) => t -> Domain t (g (Domain t) (Domain t)) -> m++-- | Like "Transformation.Deep".'Deep.Traversable' except it traverses an additional wrapper around the entire tree+class (Transformation t, Rank2.Traversable (g (Domain t))) => Traversable t g where+   traverse :: Codomain t ~ Compose m f => t -> Domain t (g (Domain t) (Domain t)) -> m (f (g f f))++-- | Alphabetical synonym for '<$>'+fmap :: Functor t g => t -> Domain t (g (Domain t) (Domain t)) -> Codomain t (g (Codomain t) (Codomain t))+fmap = (<$>)++-- | Default implementation for '<$>' that maps the wrapper and then the tree+mapDownDefault :: (Deep.Functor t g, t `Transformation.At` g (Domain t) (Domain t), Data.Functor.Functor (Codomain t))+               => t -> Domain t (g (Domain t) (Domain t)) -> Codomain t (g (Codomain t) (Codomain t))+mapDownDefault t x = (t Deep.<$>) Data.Functor.<$> (t Transformation.$ x)++-- | Default implementation for '<$>' that maps the tree and then the wrapper+mapUpDefault   :: (Deep.Functor t g, t `Transformation.At` g (Codomain t) (Codomain t), Data.Functor.Functor (Domain t))+               => t -> Domain t (g (Domain t) (Domain t)) -> Codomain t (g (Codomain t) (Codomain t))+mapUpDefault   t x = t Transformation.$ ((t Deep.<$>) Data.Functor.<$> x)++foldMapDownDefault, foldMapUpDefault :: (t `Transformation.At` g (Domain t) (Domain t), Deep.Foldable t g,+                                         Codomain t ~ Const m, Data.Foldable.Foldable (Domain t), Monoid m)+                                     => t -> Domain t (g (Domain t) (Domain t)) -> m+-- | Default implementation for 'foldMap' that folds the wrapper and then the tree+foldMapDownDefault t x = getConst (t Transformation.$ x) <> Data.Foldable.foldMap (Deep.foldMap t) x+-- | Default implementation for 'foldMap' that folds the tree and then the wrapper+foldMapUpDefault   t x = Data.Foldable.foldMap (Deep.foldMap t) x <> getConst (t Transformation.$ x)++-- | Default implementation for 'traverse' that traverses the wrapper and then the tree+traverseDownDefault :: (Deep.Traversable t g, t `Transformation.At` g (Domain t) (Domain t),+                        Codomain t ~ Compose m f, Data.Traversable.Traversable f, Monad m)+                    => t -> Domain t (g (Domain t) (Domain t)) -> m (f (g f f))+traverseDownDefault t x = getCompose (t Transformation.$ x) >>= Data.Traversable.traverse (Deep.traverse t)++-- | Default implementation for 'traverse' that traverses the tree and then the wrapper+traverseUpDefault   :: (Deep.Traversable t g, Codomain t ~ Compose m f, t `Transformation.At` g f f,+                        Data.Traversable.Traversable (Domain t), Monad m)+                    => t -> Domain t (g (Domain t) (Domain t)) -> m (f (g f f))+traverseUpDefault   t x = Data.Traversable.traverse (Deep.traverse t) x >>= getCompose . (t Transformation.$)

@@ -0,0 +1,79 @@+-- | This module exports the templates for automatic instance deriving of "Transformation.Full" type classes. The most+-- common way to use it would be+--+-- > import qualified Transformation.Full.TH+-- > data MyDataType f' f = ...+-- > $(Transformation.Full.TH.deriveUpFunctor (conT ''MyTransformation) (conT ''MyDataType))+--++{-# Language TemplateHaskell #-}++module Transformation.Full.TH (deriveDownFunctor, deriveDownFoldable, deriveDownTraversable,+                               deriveUpFunctor, deriveUpFoldable, deriveUpTraversable)+where++import Language.Haskell.TH++import qualified Transformation+import qualified Transformation.Deep+import qualified Transformation.Full++deriveDownFunctor :: Q Type -> Q Type -> Q [Dec]+deriveDownFunctor transformation node = do+   let domain = conT ''Transformation.Domain `appT` transformation+       deepConstraint = conT ''Transformation.Deep.Functor `appT` transformation `appT` node+       fullConstraint = conT ''Transformation.Full.Functor `appT` transformation `appT` node+       shallowConstraint = conT ''Transformation.At `appT` transformation `appT` (node `appT` domain `appT` domain)+   sequence [instanceD (cxt [deepConstraint, shallowConstraint])+             fullConstraint+             [funD '(Transformation.Full.<$>) [clause [] (normalB $ varE 'Transformation.Full.mapDownDefault) []]]]++deriveUpFunctor :: Q Type -> Q Type -> Q [Dec]+deriveUpFunctor transformation node = do+   let codomain = conT ''Transformation.Codomain `appT` transformation+       deepConstraint = conT ''Transformation.Deep.Functor `appT` transformation `appT` node+       fullConstraint = conT ''Transformation.Full.Functor `appT` transformation `appT` node+       shallowConstraint = conT ''Transformation.At `appT` transformation `appT` (node `appT` codomain `appT` codomain)+   sequence [instanceD (cxt [deepConstraint, shallowConstraint])+             fullConstraint+             [funD '(Transformation.Full.<$>) [clause [] (normalB $ varE 'Transformation.Full.mapUpDefault) []]]]++deriveDownFoldable :: Q Type -> Q Type -> Q [Dec]+deriveDownFoldable transformation node = do+   let domain = conT ''Transformation.Domain `appT` transformation+       deepConstraint = conT ''Transformation.Deep.Foldable `appT` transformation `appT` node+       fullConstraint = conT ''Transformation.Full.Foldable `appT` transformation `appT` node+       shallowConstraint = conT ''Transformation.At `appT` transformation `appT` (node `appT` domain `appT` domain)+   sequence [instanceD (cxt [deepConstraint, shallowConstraint])+             fullConstraint+             [funD 'Transformation.Full.foldMap [clause [] (normalB $ varE 'Transformation.Full.foldMapDownDefault) []]]]++deriveUpFoldable :: Q Type -> Q Type -> Q [Dec]+deriveUpFoldable transformation node = do+   let codomain = conT ''Transformation.Codomain `appT` transformation+       deepConstraint = conT ''Transformation.Deep.Foldable `appT` transformation `appT` node+       fullConstraint = conT ''Transformation.Full.Foldable `appT` transformation `appT` node+       shallowConstraint = conT ''Transformation.At `appT` transformation `appT` (node `appT` codomain `appT` codomain)+   sequence [instanceD (cxt [deepConstraint, shallowConstraint])+             fullConstraint+             [funD 'Transformation.Full.foldMap [clause [] (normalB $ varE 'Transformation.Full.foldMapUpDefault) []]]]++deriveDownTraversable :: Q Type -> Q Type -> Q [Dec]+deriveDownTraversable transformation node = do+   let domain = conT ''Transformation.Domain `appT` transformation+       deepConstraint = conT ''Transformation.Deep.Traversable `appT` transformation `appT` node+       fullConstraint = conT ''Transformation.Full.Traversable `appT` transformation `appT` node+       shallowConstraint = conT ''Transformation.At `appT` transformation `appT` (node `appT` domain `appT` domain)+   sequence [instanceD (cxt [deepConstraint, shallowConstraint])+             fullConstraint+             [funD 'Transformation.Full.traverse [clause [] (normalB $ varE 'Transformation.Full.traverseDownDefault) []]]]++deriveUpTraversable :: Q Type -> Q Type -> Q [Dec]+deriveUpTraversable transformation node = do+   let codomain = conT ''Transformation.Codomain `appT` transformation+       deepConstraint = conT ''Transformation.Deep.Traversable `appT` transformation `appT` node+       fullConstraint = conT ''Transformation.Full.Traversable `appT` transformation `appT` node+       shallowConstraint = conT ''Transformation.At `appT` transformation `appT` (node `appT` codomain `appT` codomain)+   sequence [instanceD (cxt [deepConstraint, shallowConstraint])+             fullConstraint+             [funD 'Transformation.Full.traverse [clause [] (normalB $ varE 'Transformation.Full.traverseUpDefault) []]]]

@@ -0,0 +1,55 @@+{-# Language FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeFamilies, UndecidableInstances #-}++-- | This module provides natural transformations 'Map', 'Fold', and 'Traversal', as well as three rank-2 functions+-- that wrap them in a convenient interface.++module Transformation.Rank2 where++import Data.Functor.Compose (Compose(Compose))+import Data.Functor.Const (Const(Const))+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+(<$>) f = (Deep.<$>) (Map f)++-- | Fold the containing functor of every node in the given tree.+foldMap :: (Deep.Foldable (Fold p m) g, Monoid m) => (forall a. p a -> m) -> g p p -> m+foldMap f = Deep.foldMap (Fold f)++-- | Traverse the containing functors of all nodes in the given tree.+traverse :: Deep.Traversable (Traversal p q m) g => (forall a. p a -> m (q a)) -> g p p -> m (g q q)+traverse f = Deep.traverse (Traversal f)++newtype Map p q = Map (forall x. p x -> q x)++newtype Fold p m = Fold (forall x. p x -> m)++newtype Traversal p q m = Traversal (forall x. p x -> m (q x))++instance Transformation (Map p q) where+   type Domain (Map p q) = p+   type Codomain (Map p q) = q++instance Transformation (Fold p m) where+   type Domain (Fold p m) = p+   type Codomain (Fold p m) = Const m++instance Transformation (Traversal p q m) where+   type Domain (Traversal p q m) = p+   type Codomain (Traversal p q m) = Compose m q++instance Transformation.At (Map p q) x where+   ($) (Map f) = f++instance Transformation.At (Fold p m) x where+   ($) (Fold f) = Const . f++instance Transformation.At (Traversal p q m) x where+   ($) (Traversal f) = Compose . f++instance (Deep.Functor (Map p q) g, Functor p) => Full.Functor (Map p q) g where+  (<$>) = Full.mapUpDefault

@@ -0,0 +1,41 @@+{-# Language DeriveDataTypeable, FlexibleInstances, KindSignatures, MultiParamTypeClasses, RankNTypes,+             StandaloneDeriving, TypeFamilies, UndecidableInstances #-}++-- | Type classes 'Functor', 'Foldable', and 'Traversable' that correspond to the standard type classes of the same+-- name. The [rank2classes](https://hackage.haskell.org/package/rank2classes) package provides the equivalent set+-- of classes for natural transformations. This module extends the functionality to unnatural transformations.++module Transformation.Shallow where++import Control.Applicative (Applicative, liftA2)+import Data.Functor.Compose (Compose)+import Data.Functor.Const (Const)+import qualified Rank2+import           Transformation (Transformation, Domain, Codomain)++import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd)++-- | Like Rank2.'Rank2.Functor' except it takes a 'Transformation' instead of a polymorphic function+class (Transformation t, Rank2.Functor g) => Functor t g where+   (<$>) :: t -> g (Domain t) -> g (Codomain t)++-- | Like Rank2.'Rank2.Foldable' except it takes a 'Transformation' instead of a polymorphic function+class (Transformation t, Rank2.Foldable g) => Foldable t g where+   foldMap :: (Codomain t ~ Const m, Monoid m) => t -> g (Domain t) -> m++-- | Like Rank2.'Rank2.Traversable' except it takes a 'Transformation' instead of a polymorphic function+class (Transformation t, Rank2.Traversable g) => Traversable t g where+   traverse :: Codomain t ~ Compose m f => t -> g (Domain t) -> m (g f)++instance (Functor t g, Functor t h) => Functor t (Rank2.Product g h) where+   t <$> Rank2.Pair left right = Rank2.Pair (t <$> left) (t <$> right)++instance (Foldable t g, Foldable t h, Codomain t ~ Const m, Monoid m) => Foldable t (Rank2.Product g h) where+   foldMap t (Rank2.Pair left right) = foldMap t left <> foldMap t right++instance (Traversable t g, Traversable t h, Codomain t ~ Compose m f, Applicative m) => Traversable t (Rank2.Product g h) where+   traverse t (Rank2.Pair left right) = liftA2 Rank2.Pair (traverse t left) (traverse t right)++-- | Alphabetical synonym for '<$>'+fmap :: Functor t g => t -> g (Domain t) -> g (Codomain t)+fmap = (<$>)

@@ -0,0 +1,293 @@+-- | This module exports the templates for automatic instance deriving of "Transformation.Shallow" type classes. The most+-- common way to use it would be+--+-- > import qualified Transformation.Shallow.TH+-- > data MyDataType f' f = ...+-- > $(Transformation.Shallow.TH.deriveFunctor ''MyDataType)+--++{-# Language TemplateHaskell #-}+-- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial++module Transformation.Shallow.TH (deriveAll, deriveFunctor, deriveFoldable, deriveTraversable)+where++import Control.Applicative (liftA2)+import Control.Monad (replicateM)+import Data.Functor.Compose (Compose(getCompose))+import Data.Functor.Const (Const(getConst))+import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid, (<>))+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (BangType, VarBangType, getQ, putQ)++import qualified Transformation+import qualified Transformation.Shallow+++data Deriving = Deriving { _constructor :: Name, _variable :: Name }++deriveAll :: Name -> Q [Dec]+deriveAll ty = foldr f (pure []) [deriveFunctor, deriveFoldable, deriveTraversable]+   where f derive rest = (<>) <$> derive ty <*> rest++deriveFunctor :: Name -> Q [Dec]+deriveFunctor typeName = do+   t <- varT <$> newName "t"+   (instanceType, cs) <- reifyConstructors typeName+   let shallowConstraint ty = conT ''Transformation.Shallow.Functor `appT` t `appT` ty+       baseConstraint ty = conT ''Transformation.At `appT` t `appT` ty+   (constraints, dec) <- genShallowmap shallowConstraint baseConstraint instanceType cs+   sequence [instanceD (cxt $ appT (conT ''Transformation.Transformation) t : map pure constraints)+                       (shallowConstraint instanceType)+                       [pure dec]]++deriveFoldable :: Name -> Q [Dec]+deriveFoldable typeName = do+   t <- varT <$> newName "t"+   m <- varT <$> newName "m"+   (instanceType, cs) <- reifyConstructors typeName+   let shallowConstraint ty = conT ''Transformation.Shallow.Foldable `appT` t `appT` ty+       baseConstraint ty = conT ''Transformation.At `appT` t `appT` ty+   (constraints, dec) <- genFoldMap shallowConstraint baseConstraint instanceType cs+   sequence [instanceD (cxt (appT (conT ''Transformation.Transformation) t :+                             appT (appT equalityT (conT ''Transformation.Codomain `appT` t))+                                  (conT ''Const `appT` m) :+                             appT (conT ''Monoid) m : map pure constraints))+                       (shallowConstraint instanceType)+                       [pure dec]]++deriveTraversable :: Name -> Q [Dec]+deriveTraversable typeName = do+   t <- varT <$> newName "t"+   m <- varT <$> newName "m"+   f <- varT <$> newName "f"+   (instanceType, cs) <- reifyConstructors typeName+   let shallowConstraint ty = conT ''Transformation.Shallow.Traversable `appT` t `appT` ty+       baseConstraint ty = conT ''Transformation.At `appT` t `appT` ty+   (constraints, dec) <- genTraverse shallowConstraint baseConstraint instanceType cs+   sequence [instanceD (cxt (appT (conT ''Transformation.Transformation) t :+                             appT (appT equalityT (conT ''Transformation.Codomain `appT` t))+                                  (conT ''Compose `appT` m `appT` f) :+                             appT (conT ''Applicative) m : map pure constraints))+                       (shallowConstraint instanceType)+                       [pure dec]]++substitute :: Type -> Q Type -> Q Type -> Q Type+substitute resultType = liftA2 substitute'+   where substitute' instanceType argumentType =+            substituteVars (substitutions resultType instanceType) argumentType+         substitutions (AppT t1 (VarT name1)) (AppT t2 (VarT name2)) = (name1, name2) : substitutions t1 t2+         substitutions _t1 _t2 = []+         substituteVars subs (VarT name) = VarT (fromMaybe name $ lookup name subs)+         substituteVars subs (AppT t1 t2) = AppT (substituteVars subs t1) (substituteVars subs t2)+         substituteVars _ t = t++reifyConstructors :: Name -> Q (TypeQ, [Con])+reifyConstructors ty = do+   (TyConI tyCon) <- reify ty+   (tyConName, tyVars, _kind, cs) <- case tyCon of+      DataD _ nm tyVars kind cs _   -> return (nm, tyVars, kind, cs)+      NewtypeD _ nm tyVars kind c _ -> return (nm, tyVars, kind, [c])+      _ -> fail "deriveApply: tyCon may not be a type synonym."++   let (KindedTV tyVar  (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars+       instanceType           = foldl apply (conT tyConName) (reverse $ drop 1 $ reverse tyVars)+       apply t (PlainTV name)    = appT t (varT name)+       apply t (KindedTV name _) = appT t (varT name)++   putQ (Deriving tyConName tyVar)+   return (instanceType, cs)++genShallowmap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)+genShallowmap shallowConstraint baseConstraint instanceType cs = do+   (constraints, clauses) <- unzip <$> mapM (genShallowmapClause shallowConstraint baseConstraint instanceType) cs+   return (concat constraints, FunD '(Transformation.Shallow.<$>) clauses)++genFoldMap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)+genFoldMap shallowConstraint baseConstraint instanceType cs = do+   (constraints, clauses) <- unzip <$> mapM (genFoldMapClause shallowConstraint baseConstraint instanceType) cs+   return (concat constraints, FunD 'Transformation.Shallow.foldMap clauses)++genTraverse :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)+genTraverse shallowConstraint baseConstraint instanceType cs = do+   (constraints, clauses) <- unzip+     <$> mapM (genTraverseClause genTraverseField shallowConstraint baseConstraint instanceType) cs+   return (concat constraints, FunD 'Transformation.Shallow.traverse clauses)++genShallowmapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)+genShallowmapClause shallowConstraint baseConstraint _instanceType (NormalC name fieldTypes) = do+   t          <- newName "t"+   fieldNames <- replicateM (length fieldTypes) (newName "x")+   let pats = [varP t, parensP (conP name $ map varP fieldNames)]+       constraintsAndFields = zipWith newField fieldNames fieldTypes+       newFields = map (snd <$>) constraintsAndFields+       body = normalB $ appsE $ conE name : newFields+       newField :: Name -> BangType -> Q ([Type], Exp)+       newField x (_, fieldType) = genShallowmapField (varE t) fieldType shallowConstraint baseConstraint (varE x) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause pats body []+genShallowmapClause shallowConstraint baseConstraint _instanceType (RecC name fields) = do+   t <- newName "t"+   x <- newName "x"+   let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields+       constraintsAndFields = map newNamedField fields+       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))+       newNamedField (fieldName, _, fieldType) =+          ((,) fieldName <$>)+          <$> genShallowmapField (varE t) fieldType shallowConstraint baseConstraint (appE (varE fieldName) (varE x)) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP t, x `asP` recP name []] body []+genShallowmapClause shallowConstraint baseConstraint instanceType+                    (GadtC [name] fieldTypes (AppT resultType (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genShallowmapClause (shallowConstraint . substitute resultType instanceType)+                       (baseConstraint . substitute resultType instanceType)+                       instanceType (NormalC name fieldTypes)+genShallowmapClause shallowConstraint baseConstraint instanceType+                    (RecGadtC [name] fields (AppT resultType (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genShallowmapClause (shallowConstraint . substitute resultType instanceType)+                       (baseConstraint . substitute resultType instanceType)+                       instanceType (RecC name fields)+genShallowmapClause shallowConstraint baseConstraint instanceType (ForallC _vars _cxt con) =+   genShallowmapClause shallowConstraint baseConstraint instanceType con++genFoldMapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)+genFoldMapClause shallowConstraint baseConstraint _instanceType (NormalC name fieldTypes) = do+   t          <- newName "t"+   fieldNames <- replicateM (length fieldTypes) (newName "x")+   let pats = [varP t, conP name (map varP fieldNames)]+       constraintsAndFields = zipWith newField fieldNames fieldTypes+       body | null fieldNames = [| mempty |]+            | otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields+       append a b = [| $(a) <> $(b) |]+       newField :: Name -> BangType -> Q ([Type], Exp)+       newField x (_, fieldType) = genFoldMapField (varE t) fieldType shallowConstraint baseConstraint (varE x) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause pats (normalB body) []+genFoldMapClause shallowConstraint baseConstraint _instanceType (RecC name fields) = do+   t <- newName "t"+   x <- newName "x"+   let body | null fields = [| mempty |]+            | otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields+       constraintsAndFields = map newField fields+       append a b = [| $(a) <> $(b) |]+       newField :: VarBangType -> Q ([Type], Exp)+       newField (fieldName, _, fieldType) =+          genFoldMapField (varE t) fieldType shallowConstraint baseConstraint (appE (varE fieldName) (varE x)) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP t, x `asP` recP name []] (normalB body) []+genFoldMapClause shallowConstraint baseConstraint instanceType+                 (GadtC [name] fieldTypes (AppT resultType (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genFoldMapClause (shallowConstraint . substitute resultType instanceType)+                       (baseConstraint . substitute resultType instanceType)+                       instanceType (NormalC name fieldTypes)+genFoldMapClause shallowConstraint baseConstraint instanceType+                 (RecGadtC [name] fields (AppT resultType (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genFoldMapClause (shallowConstraint . substitute resultType instanceType)+                       (baseConstraint . substitute resultType instanceType)+                       instanceType (RecC name fields)+genFoldMapClause shallowConstraint baseConstraint instanceType (ForallC _vars _cxt con) =+   genFoldMapClause shallowConstraint baseConstraint instanceType con++type GenTraverseFieldType = Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp)+                            -> Q ([Type], Exp)++genTraverseClause :: GenTraverseFieldType -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Con+                  -> Q ([Type], Clause)+genTraverseClause genField shallowConstraint baseConstraint _instanceType (NormalC name fieldTypes) = do+   t          <- newName "t"+   fieldNames <- replicateM (length fieldTypes) (newName "x")+   let pats = [varP t, parensP (conP name $ map varP fieldNames)]+       constraintsAndFields = zipWith newField fieldNames fieldTypes+       newFields = map (snd <$>) constraintsAndFields+       body | null fieldTypes = [| pure $(conE name) |]+            | otherwise = fst $ foldl apply (conE name, False) newFields+       apply (a, False) b = ([| $(a) <$> $(b) |], True)+       apply (a, True) b = ([| $(a) <*> $(b) |], True)+       newField :: Name -> BangType -> Q ([Type], Exp)+       newField x (_, fieldType) = genField (varE t) fieldType shallowConstraint baseConstraint (varE x) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause pats (normalB body) []+genTraverseClause genField shallowConstraint baseConstraint _instanceType (RecC name fields) = do+   f <- newName "f"+   x <- newName "x"+   let constraintsAndFields = map newNamedField fields+       body | null fields = [| pure $(conE name) |]+            | otherwise = fst (foldl apply (conE name, False) $ map (snd . snd <$>) constraintsAndFields)+       apply (a, False) b = ([| $(a) <$> $(b) |], True)+       apply (a, True) b = ([| $(a) <*> $(b) |], True)+       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))+       newNamedField (fieldName, _, fieldType) =+          ((,) fieldName <$>)+          <$> genField (varE f) fieldType shallowConstraint baseConstraint (appE (varE fieldName) (varE x)) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP f, x `asP` recP name []] (normalB body) []+genTraverseClause genField shallowConstraint baseConstraint instanceType+                  (GadtC [name] fieldTypes (AppT resultType (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genTraverseClause genField+        (shallowConstraint . substitute resultType instanceType)+        (baseConstraint . substitute resultType instanceType)+        instanceType (NormalC name fieldTypes)+genTraverseClause genField shallowConstraint baseConstraint instanceType+                  (RecGadtC [name] fields (AppT resultType (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genTraverseClause genField+                        (shallowConstraint . substitute resultType instanceType)+                        (baseConstraint . substitute resultType instanceType)+                        instanceType (RecC name fields)+genTraverseClause genField shallowConstraint baseConstraint instanceType (ForallC _vars _cxt con) =+   genTraverseClause genField shallowConstraint baseConstraint instanceType con++genShallowmapField :: Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp)+                -> Q ([Type], Exp)+genShallowmapField trans fieldType shallowConstraint baseConstraint fieldAccess wrap = do+   Just (Deriving _ typeVar) <- getQ+   case fieldType of+     AppT ty a | ty == VarT typeVar ->+        (,) <$> ((:[]) <$> baseConstraint (pure a))+            <*> (wrap (varE '(Transformation.$) `appE` trans) `appE` fieldAccess)+     AppT t1 t2 | t1 /= VarT typeVar ->+        genShallowmapField trans t2 shallowConstraint baseConstraint fieldAccess (wrap . appE (varE '(<$>)))+     SigT ty _kind -> genShallowmapField trans ty shallowConstraint baseConstraint fieldAccess wrap+     ParensT ty -> genShallowmapField trans ty shallowConstraint baseConstraint fieldAccess wrap+     _ -> (,) [] <$> fieldAccess++genFoldMapField :: Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp)+                -> Q ([Type], Exp)+genFoldMapField trans fieldType shallowConstraint baseConstraint fieldAccess wrap = do+   Just (Deriving _ typeVar) <- getQ+   case fieldType of+     AppT ty a | ty == VarT typeVar ->+        (,) <$> ((:[]) <$> baseConstraint (pure a))+            <*> (wrap (varE '(.) `appE` varE 'getConst `appE` (varE '(Transformation.$) `appE` trans))+                 `appE` fieldAccess)+     AppT t1 t2 | t1 /= VarT typeVar ->+                  genFoldMapField trans t2 shallowConstraint baseConstraint fieldAccess (wrap . appE (varE 'foldMap))+     SigT ty _kind -> genFoldMapField trans ty shallowConstraint baseConstraint fieldAccess wrap+     ParensT ty -> genFoldMapField trans ty shallowConstraint baseConstraint fieldAccess wrap+     _ -> (,) [] <$> [| mempty |]++genTraverseField :: GenTraverseFieldType+genTraverseField trans fieldType shallowConstraint baseConstraint fieldAccess wrap = do+   Just (Deriving _ typeVar) <- getQ+   case fieldType of+     AppT ty a  | ty == VarT typeVar ->+        (,) <$> ((:[]) <$> baseConstraint (pure a))+            <*> (wrap (varE '(.) `appE` varE 'getCompose `appE` (varE '(Transformation.$) `appE` trans))+                 `appE` fieldAccess)+     AppT t1 t2 | t1 /= VarT typeVar ->+        genTraverseField trans t2 shallowConstraint baseConstraint fieldAccess (wrap . appE (varE 'traverse))+     SigT ty _kind -> genTraverseField trans ty shallowConstraint baseConstraint fieldAccess wrap+     ParensT ty -> genTraverseField trans ty shallowConstraint baseConstraint fieldAccess wrap+     _ -> (,) [] <$> [| pure $fieldAccess |]

@@ -0,0 +1,8 @@+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"])

@@ -0,0 +1,439 @@+Deep transformations+====================++An abstract syntax tree of a realistic programming language will generally contain more than one node type. In other+ words, its type will involve several mutually recursive data types: the usual suspects would be expression,+ declaration, type, statement, and module.++This library, `deep-transformations`, provides a solution to the problem of traversing and transforming such+ heterogenous trees. It does this by generalizing the+ [`rank2classes`](http://github.com/blamario/grampa/tree/master/rank2classes) library and by replacing parametric+ polymorphism with ad-hoc polymorphism. The result is powerful enough to support a new embedding of attribute+ grammars, as shown below and in two+ [RepMin](http://github.com/blamario/grampa/blob/master/deep-transformations/test/RepMin.hs)+ [examples](http://github.com/blamario/grampa/blob/master/deep-transformations/test/RepMinAuto.hs)++This is not the only solution by far. The venerable [`multiplate`](http://hackage.haskell.org/package/multiplate) has+ long offered a very approachable way to traverse and fold heterogenous trees, without even depending on any extension+ to standard Haskell. Multiplate is not as expressive as the present library, but if it satisfies your needs go with+ it. If not, be aware that `deep-transformations` relies on quite a number of extensions:++~~~ {.haskell}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,+             StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}+module README where+~~~++It will also require several imports.++~~~ {.haskell}+import Control.Applicative+import Data.Coerce (coerce)+import Data.Functor.Const+import Data.Functor.Identity+import qualified Rank2+import Transformation (Transformation, At)+import qualified Transformation+import qualified Transformation.AG as AG+import qualified Transformation.Deep as Deep+import qualified Transformation.Full as Full+import qualified Transformation.Shallow as Shallow+~~~++Let us start with the same example handled by [Multiplate](https://wiki.haskell.org/Multiplate). It's a relatively+ simple set of two mutually recursive data types.++    data Expr = Con Int+              | Add Expr Expr+              | Mul Expr Expr+              | EVar Var+              | Let Decl Expr++    data Decl = Var := Expr+              | Seq Decl Decl++    type Var = String++This kind of tree is *not* something that `deep-transformations` can handle. Before you can use this library, you must+parameterize every data type and wrap every recursive field of every constructor as follows:++~~~ {.haskell}+data Expr d s = Con Int+              | Add (s (Expr d d)) (s (Expr d d))+              | Mul (s (Expr d d)) (s (Expr d d))+              | EVar Var+              | Let (s (Decl d d)) (s (Expr d d))++data Decl d s = Var := s (Expr d d)+              | Seq (s (Decl d d)) (s (Decl d d))++type Var = String+~~~++The parameters `d` and `s` stand for the *deep* and *shallow* type constructor. A typical occurrence of the tree will+ instantiate the same type for both parameters. While it may look complicated and annoying, this kind of+ parameterization carries benefits beyond this library's use. The parameters may vary from `Identity`, equivalent to+ the original simple formulation, via `(,) LexicalInfo` to store the source code position and white-space and comments+ for every node, or `[]` if you need some ambiguity, to attribute grammar semantics.++Now, let's declare all the class instances. First make the tree `Show`.++~~~ {.haskell}+deriving instance (Show (f (Expr f' f')), Show (f (Decl f' f'))) => Show (Expr f' f)+deriving instance (Show (f (Expr f' f')), Show (f (Decl f' f'))) => Show (Decl f' f)+~~~++The shallow parameter comes last so that every data type can have instances of+ [`rank2classes`](https://hackage.haskell.org/package/rank2classes). The instances below are written manually for+ exposition, but it would be easier to generate them automatically using the Template Haskell imports from+ [`Rank2.TH`](https://hackage.haskell.org/package/rank2classes/docs/Rank2-TH.html).++~~~ {.haskell}+instance Rank2.Functor (Decl f') where+  f <$> (v := e) = (v := f e)+  f <$> Seq x y  = Seq (f x) (f y)++instance Rank2.Functor (Expr f') where+  f <$> Con n   = Con n+  f <$> Add x y = Add (f x) (f y)+  f <$> Mul x y = Mul (f x) (f y)+  f <$> Let d e = Let (f d) (f e)+  f <$> EVar v  = EVar v++instance Rank2.Foldable (Decl f') where+  f `foldMap` (v := e) = f e+  f `foldMap` Seq x y  = f x <> f y++instance Rank2.Foldable (Expr f') where+  f `foldMap` Con n   = mempty+  f `foldMap` Add x y = f x <> f y+  f `foldMap` Mul x y = f x <> f y+  f `foldMap` Let d e = f d <> f e+  f `foldMap` EVar v  = mempty+~~~++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.++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+be generated automatically with Template Haskell functions from+[`Transformation.Deep.TH`](https://hackage.haskell.org/package/deep-transformations/docs/Transformation-Deep-TH.html).++~~~ {.haskell}+instance (Transformation t, Full.Functor t Decl, Full.Functor t Expr) => Deep.Functor t Decl where+  t <$> (v := e)   = (v := (t Full.<$> e))+  t <$> Seq x y = Seq (t Full.<$> x) (t Full.<$> y)++instance (Transformation t, Full.Functor t Decl, Full.Functor t Expr) => Deep.Functor t Expr where+  t <$> Con n   = Con n+  t <$> Add x y = Add (t Full.<$> x) (t Full.<$> y)+  t <$> Mul x y = Mul (t Full.<$> x) (t Full.<$> y)+  t <$> Let d e = Let (t Full.<$> d) (t Full.<$> e)+  t <$> EVar v  = EVar v++instance (Transformation t, Full.Foldable t Decl, Full.Foldable t Expr) => Deep.Foldable t Decl where+  t `foldMap` (v := e) = t `Full.foldMap` e+  t `foldMap` Seq x y  = t `Full.foldMap` x <> t `Full.foldMap` y++instance (Transformation t, Full.Foldable t Decl, Full.Foldable t Expr) => Deep.Foldable t Expr where+  t `foldMap` Con n   = mempty+  t `foldMap` Add x y = t `Full.foldMap` x <> t `Full.foldMap` y+  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+~~~++Once the above boilerplate code is written or generated, no further boilerplate need be written.++Generic Programing with deep-transformations+============================================++Folding+-------++Suppose we we want to get a list of all variables used in an expression. To do this we would declare the appropriate+ [`Transformation`](https://hackage.haskell.org/package/deep-transformations/docs/Transformation.html) instance for an+ arbitrary data type. We'll give this data type an evocative name.++~~~ {.haskell}+data GetVariables = GetVariables++instance Transformation GetVariables where+  type Domain GetVariables = Identity+  type Codomain GetVariables = Const [Var]+~~~++The `Transformation` instance for `GetVariables` converts the `Identity` wrapper of a given node into a constant list+ of variables contained within it. To do that, it must behave differently for `Expr` and for `Decl`:++~~~ {.haskell}+instance GetVariables `At` Expr Identity Identity where+  GetVariables $ Identity (EVar v) = Const [v]+  GetVariables $ x = mempty++instance GetVariables `At` Decl Identity Identity where+  GetVariables $ x = mempty+~~~++There is one last decision to make about our transformation: is it a pre-order or a post-order fold? In this case it+ doesn't matter, so let's pick pre-order:++~~~ {.haskell}+instance Full.Foldable GetVariables Decl where+  foldMap = Full.foldMapDownDefault++instance Full.Foldable GetVariables Expr where+  foldMap = Full.foldMapDownDefault+~~~++Now the transformation is ready. We'll try it on this example:++~~~ {.haskell}+e1 :: Expr Identity Identity+e1 = bin Let ("x" := Identity (Con 42)) (bin Add (EVar "x") (EVar "y"))+~~~++with the help of a little combinator to shorten the construction of binary nodes:++~~~ {.haskell}+bin f a b = f (Identity a) (Identity b)+~~~++Folding the entire expression tree is as simple as applying `Deep.foldMap` at its root:++~~~ {.haskell}+-- |+-- >>> Deep.foldMap GetVariables e1+-- ["x","y"]+~~~++Traversing+----------++Suppose we want to recursively evaluate constant expressions in the language. We define another data type with a+ `Transformation` instance for the purpose. This time `Domain` and `Codomain` are both `Identity`, since the+ simplification doesn't change the tree type.++~~~ {.haskell}+data ConstantFold = ConstantFold++instance Transformation ConstantFold where+  type Domain ConstantFold = Identity+  type Codomain ConstantFold = Identity++instance ConstantFold `At` Expr Identity Identity where+  ConstantFold $ Identity (Add (Identity (Con x)) (Identity (Con y))) = Identity (Con (x + y))+  ConstantFold $ Identity (Mul (Identity (Con x)) (Identity (Con y))) = Identity (Con (x * y))+  ConstantFold $ Identity x = Identity x++instance ConstantFold `At` Decl Identity Identity where+  ConstantFold $ Identity x = Identity x+~~~++This transformation has to work bottom-up, so we declare++~~~ {.haskell}+instance Full.Functor ConstantFold Decl where+  (<$>) = Full.mapUpDefault++instance Full.Functor ConstantFold Expr where+  (<$>) = Full.mapUpDefault+~~~++Let's build a declaration to test.++~~~ {.haskell}+d1 :: Decl Identity Identity+d1 = "y" := Identity (bin Add (bin Mul (Con 42) (Con 68)) (Con 7))+~~~++As we're keeping the tree this time, instead of `Deep.foldMap` we can use `Deep.fmap`:++~~~ {.haskell}+-- |+-- >>> Deep.fmap ConstantFold d1+-- "y" := Identity (Con 2863)+~~~++Attribute Grammars+------------------++All right, can we do something more complicated? How about inlining all constant let bindings? And while we're at it,+ removing all unused declarations - also known as dead code elimination?++When it comes to complex transformations like this, the best tool in compiler writer's belt is an attribute+ 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++type Sem = AG.Semantics DeadCodeEliminator++instance Transformation DeadCodeEliminator where+   type Domain DeadCodeEliminator = Identity+   type Codomain DeadCodeEliminator = AG.Semantics DeadCodeEliminator++instance Full.Functor DeadCodeEliminator Decl where+  (<$>) = AG.fullMapDefault runIdentity++instance Full.Functor DeadCodeEliminator Expr where+  (<$>) = AG.fullMapDefault runIdentity+~~~++We also need another bit of a boilerplate instance that can be automatically generated with Template Haskell functions+ from [`Rank2.TH`](https://hackage.haskell.org/package/rank2classes/docs/Rank2-TH.html):++~~~ {.haskell}+instance Rank2.Apply (Decl f') where+  (v := e1) <*> ~(_ := e2) = v := (Rank2.apply e1 e2)+  Seq x1 y1 <*> ~(Seq x2 y2) = Seq (Rank2.apply x1 x2) (Rank2.apply y1 y2)++instance Rank2.Apply (Expr f') where+  Con n <*> _  = Con n+  EVar v <*> _ = EVar v+  Let d1 e1 <*> ~(Let d2 e2) = Let (Rank2.apply d1 d2) (Rank2.apply e1 e2)+  Add x1 y1 <*> ~(Add x2 y2) = Add (Rank2.apply x1 x2) (Rank2.apply y1 y2)+  Mul x1 y1 <*> ~(Mul x2 y2) = Mul (Rank2.apply x1 x2) (Rank2.apply y1 y2)+~~~++### Attributes++Every type of node can have different inherited and synthesized attributes, so we need to declare what they are. Since+ we want to inline the constant bindings declared in outer scopes, we must keep track of all visible bindings. This+ kind of *environment* is a typical example of an inherited attribute. It is also the only attribute inherited by an+ expression.++~~~ {.haskell}+type Env = Var -> Maybe (Expr Identity Identity)+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])+~~~++A `Decl` needs to synthesize the environment of constant bindings it generates itself, as well as a modified+ declaration without useless assignments. To cover the case where the whole of synthesized declaration is useless, we+ need to wrap it in a `Maybe`.++~~~ {.haskell}+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+ eliminated. The simplified exression is our one synthesized attribute. The only other thing we need to know about an+ `Expr` is the list of variables it uses. We *could* make the used variable list its synthesized attribute, but it's+ easier to reuse the existing `GetVariables` transformation.++~~~ {.haskell}+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+ 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)+               -> (Inherited   t (g sem sem), g sem (Synthesized t))+               -> (Synthesized t (g sem sem), g sem (Inherited t))+~~~++### Expression rules++Let's see a few simple `attribution` rules first. The rules for leaf nodes can ignore their childrens' attributes+because they don't have any children.++~~~ {.haskell}+instance AG.Attribution DeadCodeEliminator Expr Identity Identity where+  attribution DeadCodeEliminator (Identity e@(EVar v)) (AG.Inherited env, _) =+    (AG.Synthesized (maybe e id $ env v), EVar v)+  attribution DeadCodeEliminator (Identity e@(Con n)) (AG.Inherited env, _) =+    (AG.Synthesized e, Con n)+~~~++The `Add` and `Mul` nodes' rules need only to pass their inheritance down and to re-join the synthesized child+expressions. Note that boilerplate code like this can be eliminated using the constructs from the+[`Transformation.AG.Generics`](https://hackage.haskell.org/package/deep-transformations/docs/Transformation-AG-Generics.html)+module.++~~~ {.haskell}+  attribution DeadCodeEliminator (Identity Add{}) (inh, (Add (AG.Synthesized e1') (AG.Synthesized e2'))) =+    (AG.Synthesized (bin Add e1' e2'),+     Add inh inh)+  attribution DeadCodeEliminator (Identity Mul{}) (inh, Mul (AG.Synthesized e1') (AG.Synthesized e2')) =+    (AG.Synthesized (bin Mul e1' e2'),+     Mul inh inh)+~~~++The only non-trivial rule is for the `Let` node. It needs to pass the list of variables used in its expression child+ as an inherited attribute of its declaration child. Furthermore, in case its declaration is useless the `Let` node+ should disappear from the synthesized expression.++~~~ {.haskell}+  attribution DeadCodeEliminator (Identity (Let _decl expr))+              (AG.Inherited env, (Let (AG.Synthesized ~(env', decl')) (AG.Synthesized expr'))) =+    (AG.Synthesized (maybe id (bin Let) decl' expr'),+     Let (AG.Inherited (env, Full.foldMap GetVariables expr)) (AG.Inherited $ \v-> env' v <|> env v))+~~~++### Declaration rules++The rules for `Decl` are a bit more involved.++~~~ {.haskell}+instance AG.Attribution DeadCodeEliminator Decl Identity Identity where+~~~++A single variable binding can be in three distinct situations. If the variable is not referenced at all, we can just+erase the declaration. If the variable is referenced but the value assigned to it is constant, we can again erase the+declaration and store the constant binding in the environment instead. Finally, if nothing else works we must preserve+the declaration.++~~~ {.haskell}+  attribution DeadCodeEliminator (Identity (v := e)) (AG.Inherited ~(env, used), (_ := AG.Synthesized e')) =+    (AG.Synthesized (if null (Deep.foldMap GetVariables e')+                     then (\var-> if var == v then Just e' else Nothing, Nothing)  -- constant binding+                     else (const Nothing, if v `elem` used+                                          then Just (v := Identity e')             -- used binding+                                          else Nothing)),                          -- unused binding+     v := AG.Inherited env)+~~~++The rule for a sequence of declarations is much simpler: we only need to combine the two synthesized environments into+their union and to reconstruct the simplified sequence from its simplified children. Note that the sequence becomes+unnecessary if either of its children disappears.++~~~ {.haskell}+  attribution DeadCodeEliminator (Identity Seq{}) (inh, (Seq (AG.Synthesized (env1, d1')) (AG.Synthesized (env2, d2')))) =+    (AG.Synthesized (\v-> env1 v <|> env2 v,+                     bin Seq <$> d1' <*> d2' <|> d1' <|> d2'),+     Seq inh inh)+~~~++### Test++Here is the attribute grammar finally in action:++~~~ {.haskell}+-- |+-- >>> let s = Full.fmap 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+-- Identity (Con 2905)+~~~

@@ -0,0 +1,109 @@+{-# Language FlexibleInstances, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, +             TypeFamilies, UndecidableInstances #-}++-- | The RepMin example - replicate a binary tree with all leaves replaced by the minimal leaf value.+module RepMin where++import Data.Functor.Identity+import qualified Rank2+import Transformation (Transformation(..))+import Transformation.AG (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' :: * -> *) (f :: * -> *) = 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.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 = Leaf++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 Transformation RepMin where+   type Domain RepMin = Identity+   type Codomain RepMin = AG.Semantics RepMin++-- | Inherited attributes' type+data InhRepMin = InhRepMin{global :: Int}+               deriving Show++-- | Synthesized attributes' type+data SynRepMin = SynRepMin{local :: Int,+                           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 a) Int = ()+type instance AG.Atts (Synthesized a) Int = Int++instance Full.Functor RepMin (Tree Int) where+  (<$>) = AG.fullMapDefault runIdentity+instance Full.Functor RepMin (Root Int) where+  (<$>) = AG.fullMapDefault runIdentity++-- | The semantics of the primitive 'Int' type must be defined manually.+instance Transformation.At RepMin Int where+   RepMin $ Identity n = Rank2.Arrow (const $ Synthesized n)++instance AG.Attribution RepMin (Root Int) Identity Identity where+   attribution RepMin self (inherited, Root root) = (Synthesized SynRepMin{local= local (syn root),+                                                                           tree= tree (syn root)},+                                                     Root{root= Inherited InhRepMin{global= local (syn root)}})++instance AG.Attribution RepMin (Tree Int) Identity Identity where+   attribution _ _ (inherited, Fork left right) = (Synthesized SynRepMin{local= local (syn left)+                                                                                `min` local (syn right),+                                                                         tree= tree (syn left) `fork` tree (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,+                                                                    tree= Leaf{leafValue= Identity $ global+                                                                                          $ inh inherited}},+                                              Leaf{leafValue= Inherited ()})++-- * Helper functions+fork l r = Fork (Identity l) (Identity r)+leaf = Leaf . Identity++-- | The example tree+exampleTree :: Root Int Identity Identity+exampleTree = Root (Identity $ leaf 7 `fork` (leaf 4 `fork` leaf 1) `fork` leaf 3)++-- |+-- >>> Rank2.apply (Full.fmap 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})}}}

@@ -0,0 +1,105 @@+{-# Language DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleInstances, MultiParamTypeClasses, RankNTypes,+             StandaloneDeriving, TemplateHaskell, TypeFamilies, UndecidableInstances #-}++-- | The RepMin example with automatic derivation of attributes.++module RepMinAuto where++import Data.Functor.Identity+import Data.Semigroup (Min(Min, getMin))+import GHC.Generics (Generic)+import qualified Rank2+import qualified Rank2.TH+import Transformation (Transformation(..))+import Transformation.AG (Inherited(..), Synthesized(..))+import qualified Transformation+import qualified Transformation.AG as AG+import qualified Transformation.AG.Generics as AG+import Transformation.AG.Generics (Auto(Auto))+import qualified Transformation.Deep as Deep+import qualified Transformation.Full as Full+import qualified Transformation.Deep.TH+import qualified Transformation.Shallow.TH++-- | tree data type+data Tree a (f' :: * -> *) (f :: * -> *) = 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)++$(concat <$>+  (mapM (\derive-> mconcat <$> mapM derive [''Tree, ''Root])+        [Rank2.TH.deriveFunctor, Rank2.TH.deriveFoldable, Rank2.TH.deriveTraversable, Rank2.TH.unsafeDeriveApply,+         Transformation.Shallow.TH.deriveAll, Transformation.Deep.TH.deriveAll]))++instance (Transformation t, Transformation.At t a, Transformation.At t (Tree a (Codomain t) (Codomain t)),+          Functor (Domain t)) => Full.Functor t (Tree a) where+   (<$>) = Full.mapUpDefault++-- | The transformation type. It will always appear wrapped in 'Auto' to enable automatic attribute derivation.+data RepMin = RepMin++-- | 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++-- | Inherited attributes' type+data InhRepMin = InhRepMin{global :: Int}+               deriving (Generic, Show)++-- | Synthesized attributes' types rely on the 'AG.Folded' and 'AG.Mapped' wrappers, whose rules can be automatically+-- | derived.+data SynRepMin g = SynRepMin{local :: AG.Folded (Min Int),+                             tree  :: AG.Mapped Identity (g Int Identity Identity)}+                   deriving Generic+deriving instance Show (g Int Identity Identity) => Show (SynRepMin g)++-- | Synthesized attributes' type for the integer leaf.+data SynRepLeaf = SynRepLeaf{local :: AG.Folded (Min Int),+                             tree :: AG.Mapped Identity Int}+                  deriving (Generic, Show)++type instance AG.Atts (Inherited (Auto RepMin)) (Tree Int f' f) = InhRepMin+type instance AG.Atts (Synthesized (Auto RepMin)) (Tree Int f' f) = SynRepMin Tree+type instance AG.Atts (Inherited (Auto RepMin)) (Root Int f' f) = ()+type instance AG.Atts (Synthesized (Auto RepMin)) (Root Int f' f) = SynRepMin Root++type instance AG.Atts (Inherited a) Int = InhRepMin+type instance AG.Atts (Synthesized a) Int = SynRepLeaf++instance Transformation.At (Auto RepMin) (Tree Int Sem Sem) where+   ($) = AG.applyDefault runIdentity+instance Transformation.At (Auto RepMin) (Root Int Sem Sem) where+   ($) = AG.applyDefault runIdentity++-- | 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+      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+   bequest (Auto RepMin) self inherited (Root (Synthesized SynRepMin{local= rootLocal})) =+      Root{root= Inherited InhRepMin{global= getMin (AG.getFolded rootLocal)}}++-- * Helper functions+fork l r = Fork (Identity l) (Identity r)+leaf = Leaf . Identity++-- | The example tree+exampleTree :: Root Int Identity Identity+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 ())+-- 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})})})}}