diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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) +~~~ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/deep-transformations.cabal b/deep-transformations.cabal new file mode 100644 --- /dev/null +++ b/deep-transformations.cabal @@ -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 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 diff --git a/src/Transformation.hs b/src/Transformation.hs new file mode 100644 --- /dev/null +++ b/src/Transformation.hs @@ -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) diff --git a/src/Transformation/AG.hs b/src/Transformation/AG.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/AG.hs @@ -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 #-} diff --git a/src/Transformation/AG/Generics.hs b/src/Transformation/AG/Generics.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/AG/Generics.hs @@ -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)) diff --git a/src/Transformation/Deep.hs b/src/Transformation/Deep.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/Deep.hs @@ -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 = (<$>) diff --git a/src/Transformation/Deep.hs-boot b/src/Transformation/Deep.hs-boot new file mode 100644 --- /dev/null +++ b/src/Transformation/Deep.hs-boot @@ -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) diff --git a/src/Transformation/Deep/TH.hs b/src/Transformation/Deep/TH.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/Deep/TH.hs @@ -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 |] diff --git a/src/Transformation/Full.hs b/src/Transformation/Full.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/Full.hs @@ -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.$) diff --git a/src/Transformation/Full/TH.hs b/src/Transformation/Full/TH.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/Full/TH.hs @@ -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) []]]] diff --git a/src/Transformation/Rank2.hs b/src/Transformation/Rank2.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/Rank2.hs @@ -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 diff --git a/src/Transformation/Shallow.hs b/src/Transformation/Shallow.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/Shallow.hs @@ -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 = (<$>) diff --git a/src/Transformation/Shallow/TH.hs b/src/Transformation/Shallow/TH.hs new file mode 100644 --- /dev/null +++ b/src/Transformation/Shallow/TH.hs @@ -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 |] diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -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"]) diff --git a/test/README.lhs b/test/README.lhs new file mode 100644 --- /dev/null +++ b/test/README.lhs @@ -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) +~~~ diff --git a/test/RepMin.hs b/test/RepMin.hs new file mode 100644 --- /dev/null +++ b/test/RepMin.hs @@ -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})}}} diff --git a/test/RepMinAuto.hs b/test/RepMinAuto.hs new file mode 100644 --- /dev/null +++ b/test/RepMinAuto.hs @@ -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})})})}}