packages feed

deep-transformations 0.4.0.1 → 0.4.1

raw patch · 15 files changed

+263/−40 lines, 15 filesdep +tastydep +tasty-hunitdep ~basedep ~rank2classesdep ~template-haskell

Dependencies added: tasty, tasty-hunit

Dependency ranges changed: base, rank2classes, template-haskell

Files

CHANGELOG.md view
@@ -1,5 +1,13 @@ # Revision history for deep-transformations +## 0.4.1 -- 2026-11-08++* Fixed issue #32, Template Haskell error for data types not using the deep functor+* Added `Full.Inward`/`Outward` newtype `Transformation` modifiers+* Added `foldMapInward`, `foldMapOutward`, `traverseInward`,  and `traverseOutward`+* Added `AG.knitLeaf` and the overlappable `AG.Knit t \`Transformation.At\`` instance+* Added `instance (t1, t2) \`AG.At\` Deep.Const2 a`+ ## 0.4.0.1 -- 2025-11-09  * Presenting the `doctests` component as a testsuite to Cabal instead of a sublibrary because of issues with Haddock
README.md view
@@ -314,7 +314,6 @@  instance AG.Attribution DeadCodeEliminator where    type Origin DeadCodeEliminator = Identity-   unwrap DeadCodeEliminator = runIdentity ~~~  We also need another bit of a boilerplate instance that can be automatically generated with Template Haskell functions
deep-transformations.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                deep-transformations-version:             0.4.0.1+version:             0.4.1 synopsis:            Deep natural and unnatural tree transformations, including attribute grammars description: @@ -40,7 +40,7 @@   ghc-options:         -Wall   build-depends:        base >= 4.11 && < 5, rank2classes >= 1.5.5 && < 1.6,                         transformers >= 0.5 && < 0.7,-                        template-haskell >= 2.11 && < 2.24, generic-lens >= 1.2 && < 2.4+                        template-haskell >= 2.11 && < 2.25, generic-lens >= 1.2 && < 2.4   default-language:     Haskell2010  test-suite doctests@@ -53,3 +53,11 @@   ghc-options:         -threaded -pgmL markdown-unlit   build-depends:       base, rank2classes, deep-transformations   build-tool-depends:  markdown-unlit:markdown-unlit >= 0.5 && < 0.6++test-suite TH+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  default-language:    Haskell2010+  main-is:             Issue32.hs+  build-depends:       base, rank2classes, deep-transformations,+                       tasty < 2, tasty-hunit < 1
src/Transformation/AG.hs view
@@ -1,5 +1,6 @@ {-# Language FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes,-             MultiParamTypeClasses, NamedFieldPuns, RankNTypes, ScopedTypeVariables, StandaloneDeriving,+             MultiParamTypeClasses, NamedFieldPuns, QuantifiedConstraints,+             RankNTypes, ScopedTypeVariables, StandaloneDeriving,              TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}  -- | An attribute grammar is a particular kind of 'Transformation' that assigns attributes to nodes in a@@ -8,12 +9,13 @@  module Transformation.AG where +import Data.Foldable1 as Foldable1 import Data.Kind (Type) import Unsafe.Coerce (unsafeCoerce)  import qualified Rank2 import Transformation (Transformation, Codomain)-import Transformation.Deep (Const2)+import Transformation.Deep (Const2(Const2)) import qualified Transformation import qualified Transformation.Deep as Deep import qualified Transformation.Full as Full@@ -65,8 +67,6 @@ -- attribute individually with a 'Transformation.AG.Generics.SynthesizedField' instance. class Attribution t where    type Origin t :: Type -> Type-   -- | Unwrap the value from the original attribution domain-   unwrap :: t -> Origin t x -> x  class Attribution t => At t g where    -- | The attribution rule for a given transformation and node.@@ -75,24 +75,55 @@                -> (Inherited   t (g sem sem), g sem (Synthesized t))                -> (Synthesized t (g sem sem), g sem (Inherited t)) +-- | Turns an `Attribution` into a `Transformation` newtype Knit t = Knit t  instance Attribution t => Transformation (Knit t) where    type Domain (Knit t) = Origin t    type Codomain (Knit t) = Semantics t -instance (t `At` g, Rank2.Apply (g sem), Rank2.Traversable (g sem), sem ~ Semantics t) =>+instance {-# OVERLAPS #-}+         (t `At` g, Rank2.Apply (g sem), Rank2.Traversable (g sem), sem ~ Semantics t, Foldable1 (Origin t)) =>          Knit t `Transformation.At` g sem sem where-   Knit t $ x = knit (attribution t x) (unwrap t x)+   Knit t $ x = knit (attribution t x) (Foldable1.head x) +-- | A leaf node, /i.e./ a node whose type is not of the @g deep shallow@ shape, carries no children and therefore+-- needs no knot tying. Its attribution is given by the @t `At` Const2 a@ instance.+instance {-# OVERLAPPABLE #-} (t `At` Const2 a, NodeConstructor a ~ Const2 a,+                               Functor (Origin t), Foldable1 (Origin t)) =>+         Knit t `Transformation.At` a where+   Knit t $ x = knitLeaf t x+ instance (t `At` g, Rank2.Apply (g (Semantics t)), Rank2.Traversable (g (Semantics t)),-          Functor (Origin t), Rank2.Functor (g (Origin t)), Deep.Functor (Knit t) g) =>+          Foldable1 (Origin t), Functor (Origin t), Rank2.Functor (g (Origin t)), Deep.Functor (Knit t) g) =>          Full.Functor (Knit t) g where    (<$>) = Full.mapUpDefault --- | Transformation wrapper that keeps all the original tree nodes alongside their attributes+instance (Attribution t1, Attribution t2, Origin t1 ~ Origin t2) => Attribution (t1, t2) where+  type Origin (t1, t2) = Origin t1++type instance Atts (Inherited (t1, t2)) g = (Atts (Inherited t1) g, Atts (Inherited t2) g)+type instance Atts (Synthesized (t1, t2)) g = (Atts (Synthesized t1) g, Atts (Synthesized t2) g)++instance {-# OVERLAPPABLE #-} (t1 `At` g, t2 `At` g, Origin t1 ~ Origin t2, forall sem. Rank2.Apply (g sem)) =>+  (t1, t2) `At` g where+  attribution (t1, t2) x (Inherited (i1, i2), s) = (Synthesized (s1, s2), Rank2.liftA2 pairInh i1' i2')+    where (Synthesized s1, i1') = attribution t1 x (Inherited i1, Synthesized . fst . syn Rank2.<$> s)+          (Synthesized s2, i2') = attribution t2 x (Inherited i2, Synthesized . snd . syn Rank2.<$> s)+          pairInh (Inherited inh1) (Inherited inh2) = Inherited (inh1, inh2)++-- | A 'Const2' leaf node has no children to bequeath the inherited attributes to, so the pair of attributions needs+-- no 'Rank2.Apply' instance and in turn no @Semigroup a@ constraint.+instance {-# OVERLAPS #-} (t1 `At` Const2 a, t2 `At` Const2 a, Origin t1 ~ Origin t2) =>+  (t1, t2) `At` Const2 a where+  attribution (t1, t2) x (Inherited (i1, i2), Const2 leaf) = (Synthesized (s1, s2), Const2 leaf)+    where Synthesized s1 = fst (attribution t1 x (Inherited i1, Const2 leaf))+          Synthesized s2 = fst (attribution t2 x (Inherited i2, Const2 leaf))++-- | Attribution wrapper that keeps all the original tree nodes alongside their attributes in a `Kept` node newtype Keep t = Keep t deriving (Attribution) +-- | The synthesized attributes of a `Keep`-wrapped attribution data Kept t a = Kept{inherited   :: Atts (Inherited t) (NodeConstructor a),                      synthesized :: Atts (Synthesized t) (NodeConstructor a),                      original    :: Origin t a}@@ -127,3 +158,13 @@    where knit' inherited = synthesized             where (synthesized, chInh) = r (inherited, chSyn)                   chSyn = chSem Rank2.<*> chInh++-- | The counterpart of 'knit' for a /leaf node/, a node whose type @a@ is not of the @g deep shallow@ shape. Such a+-- node is wrapped in 'Const2' to be given its attributes, and as it has no children there is no knot to tie.+knitLeaf :: forall t a sem. (t `At` Const2 a, NodeConstructor a ~ Const2 a, sem ~ Semantics t,+                             Functor (Origin t), Foldable1 (Origin t))+         => t -> Origin t a -> sem a+knitLeaf t x = Rank2.Arrow knitLeaf'+   where knitLeaf' (Inherited inherited) = Synthesized (syn synthesized)+            where synthesized :: Synthesized t (Const2 a sem sem)+                  synthesized = fst $ attribution t (Const2 <$> x) (Inherited inherited, Const2 $ Foldable1.head x)
src/Transformation/AG/Dimorphic.hs view
@@ -7,7 +7,8 @@  module Transformation.AG.Dimorphic where -import Data.Data (Data, Typeable)+import Data.Data (Data)+import Data.Foldable1 as Foldable1 import Data.Functor.Const (Const(..)) import Data.Kind (Type) import Data.Semigroup (Semigroup(..))@@ -31,7 +32,7 @@    inh :: a,    -- | synthesized    syn :: b}-   deriving (Data, Typeable, Show)+   deriving (Data, Show)  instance (Semigroup a, Semigroup b) => Semigroup (Atts a b) where    Atts i1 s1 <> Atts i2 s2 = Atts (i1 <> i2) (s1 <> s2)@@ -52,8 +53,6 @@    type Origin t :: Type -> Type    type Inherited t :: Type    type Synthesized t :: Type-   -- | Unwrap the value from the original attribution domain-   unwrap :: t -> Origin t x -> x  -- | The core type class for defining the attribute grammar. The instances of this class typically have a form like --@@ -72,13 +71,13 @@  instance {-# overlappable #-} (Attribution t, p ~ Origin t, a ~ Inherited t, b ~ Synthesized t,                                q ~ Semantics a b, Rank2.Foldable (g q), Rank2.Functor (g q),-                               Monoid a, Monoid b, Foldable p, At t g) =>+                               Monoid a, Monoid b, Foldable1 p, At t g) =>                               T t `Transformation.At` g (Semantics a b) (Semantics a b) where-   T t $ x = knit (attribution t x) (unwrap t x)+   T t $ x = knit (attribution t x) (Foldable1.head x)    {-# INLINE ($) #-}  instance (Attribution t, At t g, p ~ Origin t, a ~ Inherited t, b ~ Synthesized t, q ~ Semantics a b,-          Monoid a, Monoid b, Foldable p, Functor p,+          Monoid a, Monoid b, Foldable1 p, Functor p,           Rank2.Foldable (g q), Rank2.Functor (g p), Rank2.Functor (g q), Deep.Functor (T t) g) =>          Full.Functor (T t) g where    (<$>) = Full.mapUpDefault@@ -97,7 +96,6 @@  instance (Attribution t, Foldable (Origin t)) => AG.Attribution (Auto t) where    type Origin (Auto t) = Origin t-   unwrap _ = foldr1 const  type instance AG.Atts (AG.Inherited (Auto t)) g = Inherited t type instance AG.Atts (AG.Synthesized (Auto t)) g = Synthesized t@@ -109,4 +107,4 @@       where result = attribution t x Atts{inh=AG.inh inherited, syn=Rank2.foldMap AG.syn chSyn}             chInh = uniformInheritance Rank2.<$> foldr const (error "Missing node") x             uniformInheritance :: forall p a. p a -> AG.Inherited (Auto t) a-            uniformInheritance = const $ AG.Inherited (AG.inh inherited)+            uniformInheritance = const $ AG.Inherited (inh result)
src/Transformation/AG/Generics.hs view
@@ -22,6 +22,7 @@                                    foldedField, mappedField, passDown, bequestDefault) where +import Data.Foldable1 as Foldable1 import Data.Functor.Compose (Compose(..)) import Data.Functor.Const (Const(..)) import Data.Kind (Type)@@ -45,7 +46,6 @@  instance Attribution t => Attribution (Auto t) where    type Origin (Auto t) = Origin t-   unwrap (Auto t) = unwrap t  instance {-# overlappable #-} (Attribution t, Bequether (Auto t) g, Synthesizer (Auto t) g) =>                               Auto t `At` g where@@ -79,7 +79,7 @@                      -> g sem (Synthesized t)           -- ^ synthesized attributes                      -> result -instance {-# overlappable #-} (Attribution t, a ~ Atts (Inherited (Auto t)) g,+instance {-# overlappable #-} (Attribution t, Foldable1 (Origin t), a ~ Atts (Inherited (Auto t)) g,                                forall deep. Shallow.Functor (PassDown (Auto t) deep a) (g deep)) =>                               Bequether (Auto t) g where    bequest = bequestDefault@@ -230,10 +230,10 @@ -- | The default 'bequest' method definition relies on generics to automatically pass down all same-named inherited -- attributes. bequestDefault :: forall t g sem.-                  (Attribution t, Shallow.Functor (PassDown t sem (Atts (Inherited t) g)) (g sem))+                  (Attribution t, Foldable1 (Origin t), Shallow.Functor (PassDown t sem (Atts (Inherited t) g)) (g sem))                => t -> Origin t (g sem sem) -> Atts (Inherited t) g -> g sem (Synthesized t)                -> g sem (Inherited t)-bequestDefault t local inheritance _synthesized = passDown @t inheritance (unwrap t local :: g sem sem)+bequestDefault _t local inheritance _synthesized = passDown @t inheritance (Foldable1.head local :: g sem sem)  -- | Pass down the given record of inherited fields to child nodes. passDown :: forall t g shallow deep atts. (Shallow.Functor (PassDown t shallow atts) (g deep)) =>
src/Transformation/Deep.hs view
@@ -1,5 +1,6 @@-{-# Language Haskell2010, DeriveDataTypeable, FlexibleInstances, KindSignatures, MultiParamTypeClasses, RankNTypes,-             GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}+{-# Language Haskell2010, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,+             GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, RankNTypes,+             StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}  -- | Type classes 'Functor', 'Foldable', and 'Traversable' that correspond to the standard type classes of the same -- name, but applying the given transformation to every descendant of the given tree node. The corresponding classes@@ -9,7 +10,7 @@ module Transformation.Deep where  import Data.Data (Data, Typeable)-import Data.Functor.Compose (Compose)+import Data.Functor.Compose (Compose(getCompose)) import Data.Functor.Const (Const) import qualified Control.Applicative as Rank1 import qualified Data.Foldable as Rank1@@ -18,8 +19,10 @@ import Data.Kind (Type) import Data.String (IsString) import qualified Rank2-import           Transformation (Transformation, Domain, Codomain)+import           Transformation (Transformation, At, Domain, Codomain)+import qualified Transformation import qualified Transformation.Full as Full+import qualified Transformation.Shallow as Shallow  import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd) @@ -62,6 +65,39 @@  -- Instances +instance Rank2.Functor (Const2 a d) where+   _ <$> Const2 x = Const2 x++instance Rank2.Foldable (Const2 a d) where+   foldMap _ _ = mempty++instance Rank2.Traversable (Const2 a d) where+   traverse _ (Const2 x) = Rank1.pure (Const2 x)++instance Semigroup a => Rank2.Apply (Const2 a d) where+   Const2 x <*> Const2 y = Const2 (x <> y)++instance Monoid a => Rank2.Applicative (Const2 a d) where+   pure _ = Const2 mempty++instance Transformation t => Shallow.Functor t (Const2 a d) where+   _ <$> Const2 x = Const2 x++instance Transformation t => Shallow.Foldable t (Const2 a d) where+   foldMap _ _ = mempty++instance (Transformation t, Codomain t ~ Compose m f, Rank1.Applicative m) => Shallow.Traversable t (Const2 a d) where+   traverse _ (Const2 x) = Rank1.pure (Const2 x)++instance Transformation t => Functor t (Const2 a) where+   _ <$> Const2 x = Const2 x++instance Transformation t => Foldable t (Const2 a) where+   foldMap _ _ = mempty++instance (Transformation t, Codomain t ~ Compose m f, Rank1.Applicative m) => Traversable t (Const2 a) where+   traverse _ (Const2 x) = Rank1.pure (Const2 x)+ instance Rank2.Functor (Only g d) where    f <$> Only x = Only (f x) @@ -83,6 +119,16 @@ instance Rank2.Distributive (Only g d) where    cotraverse w f = Only (w (Rank1.fmap fromOnly f)) +instance (Transformation t, t `At` g d d) => Shallow.Functor t (Only g d) where+   t <$> Only x = Only (t Transformation.$ x)++instance (Transformation t, Codomain t ~ Rank1.Const m, t `At` g d d) => Shallow.Foldable t (Only g d) where+   foldMap t (Only x) = Rank1.getConst $ t Transformation.$ x++instance (Transformation t, Codomain t ~ Compose m f, Rank1.Functor m, t `At` g d d) =>+   Shallow.Traversable t (Only g d) where+   traverse t (Only x) = Only Rank1.<$> getCompose (t Transformation.$ x)+ instance Full.Functor t g => Functor t (Only g) where    t <$> Only x = Only (t Full.<$> x) @@ -178,6 +224,19 @@ instance (Rank2.Traversable (g d), Rank2.Traversable (h d)) => Rank2.Traversable (Sum g h d) where    traverse f (InL left) = InL Rank1.<$> Rank2.traverse f left    traverse f (InR right) = InR Rank1.<$> Rank2.traverse f right++instance (Shallow.Functor t (g d), Shallow.Functor t (h d)) => Shallow.Functor t (Sum g h d) where+   t <$> InL left = InL (t Shallow.<$> left)+   t <$> InR right = InR (t Shallow.<$> right)++instance (Shallow.Foldable t (g d), Shallow.Foldable t (h d)) => Shallow.Foldable t (Sum g h d) where+   foldMap t (InL left) = Shallow.foldMap t left+   foldMap t (InR right) = Shallow.foldMap t right++instance (Shallow.Traversable t (g d), Shallow.Traversable t (h d),+          Codomain t ~ Compose m f, Rank1.Functor m) => Shallow.Traversable t (Sum g h d) where+   traverse t (InL left) = InL Rank1.<$> Shallow.traverse t left+   traverse t (InR right) = InR Rank1.<$> Shallow.traverse t right  instance (Functor t g, Functor t h) => Functor t (Sum g h) where    t <$> InL left = InL (t <$> left)
src/Transformation/Deep/TH.hs view
@@ -109,12 +109,12 @@    tyVars' <- traverse reifyTVKindSynonyms tyVars #if MIN_VERSION_template_haskell(2,17,0)    let (KindedTV tyVar _ (AppT (AppT ArrowT StarT) StarT) :-        KindedTV tyVar' _ (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars'+        KindedTV tyVar' _ _ : _) = reverse tyVars'        apply t (PlainTV name _)    = appT t (varT name)        apply t (KindedTV name _ _) = appT t (varT name) #else    let (KindedTV tyVar  (AppT (AppT ArrowT StarT) StarT) :-        KindedTV tyVar' (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars'+        KindedTV tyVar' _ : _) = reverse tyVars'        apply t (PlainTV name)    = appT t (varT name)        apply t (KindedTV name _) = appT t (varT name) #endif
src/Transformation/Full.hs view
@@ -1,5 +1,6 @@ {-# Language FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# Language QuantifiedConstraints, RankNTypes, TypeFamilies, TypeOperators #-}+{-# Language UndecidableInstances #-}  -- | 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@@ -37,6 +38,56 @@ -- | 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))++-- | Transformation modifier that applies the transformation first to the tree and then to the wrapper+newtype Inward t = Inward t++-- | Transformation modifier that applies the transformation first to the wrapper and then to the tree+newtype Outward t = Outward t++instance Transformation t => Transformation (Inward t) where+  type Domain (Inward t) = Domain t+  type Codomain (Inward t) = Codomain t++instance Transformation t => Transformation (Outward t) where+  type Domain (Outward t) = Domain t+  type Codomain (Outward t) = Codomain t++instance t `Transformation.At` a => Inward t `Transformation.At` a where+  Inward t $ a = t Transformation.$ a++instance t `Transformation.At` a => Outward t `Transformation.At` a where+  Outward t $ a = t Transformation.$ a++instance (Deep.Functor (Inward t) g, t `Transformation.At` g (Codomain t) (Codomain t),+          Data.Functor.Functor (Domain t), Rank2.Functor (g (Domain t))) =>+         Functor (Inward t) g where+  (<$>) = mapUpDefault++instance (Deep.Functor (Outward t) g, t `Transformation.At` g (Domain t) (Domain t),+          Data.Functor.Functor (Codomain t), Rank2.Functor (g (Domain t))) =>+         Functor (Outward t) g where+  (<$>) = mapDownDefault++instance (Deep.Foldable (Inward t) g, t `Transformation.At` g (Domain t) (Domain t),+          Rank2.Foldable (g (Domain t)), Codomain t ~ Const m, Data.Foldable.Foldable (Domain t), Monoid m) =>+         Foldable (Inward t) g where+  foldMap = foldMapUpDefault++instance (Deep.Foldable (Outward t) g, t `Transformation.At` g (Domain t) (Domain t),+          Rank2.Foldable (g (Domain t)), Codomain t ~ Const m, Data.Foldable.Foldable (Domain t), Monoid m) =>+         Foldable (Outward t) g where+  foldMap = foldMapDownDefault++instance (Deep.Traversable (Inward t) g, Codomain t ~ Compose m f, t `Transformation.At` g f f,+          Rank2.Traversable (g (Domain t)), Data.Traversable.Traversable (Domain t), Monad m) =>+         Traversable (Inward t) g where+  traverse = traverseUpDefault++instance (Deep.Traversable (Outward t) g, Codomain t ~ Compose m f, t `Transformation.At` g (Domain t) (Domain t),+          Rank2.Traversable (g (Domain t)), Data.Traversable.Traversable f, Monad m) =>+         Traversable (Outward t) g where+  traverse = traverseDownDefault  -- | Alphabetical synonym for '<$>' fmap :: Functor t g => t -> Domain t (g (Domain t) (Domain t)) -> Codomain t (g (Codomain t) (Codomain t))
src/Transformation/Rank2.hs view
@@ -11,6 +11,7 @@ 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@@ -21,9 +22,26 @@ foldMap :: (Deep.Foldable (Fold p m) g, Monoid m) => (forall a. p a -> m) -> g p p -> m foldMap f = Deep.foldMap (Fold f) +-- | Fold the containing functor of every node in the given tree inward from the leaves to the root.+foldMapInward :: (Deep.Foldable (Full.Inward (Fold p m)) g, Monoid m) => (forall a. p a -> m) -> g p p -> m+foldMapInward f = Deep.foldMap $ Full.Inward $ Fold f++-- | Fold the containing functor of every node in the given tree outward from the root to the leaves.+foldMapOutward :: (Deep.Foldable (Full.Outward (Fold p m)) g, Monoid m) => (forall a. p a -> m) -> g p p -> m+foldMapOutward f = Deep.foldMap $ Full.Outward $ 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)++-- | Traverse the containing functors of all nodes in the given tree inward from the leaves to the root.+traverseInward :: Deep.Traversable (Full.Inward (Traversal p q m)) g => (forall a. p a -> m (q a)) -> g p p -> m (g q q)+traverseInward f = Deep.traverse $ Full.Inward $ Traversal f++-- | Traverse the containing functors of all nodes in the given tree outward from the root to the leaves.+traverseOutward :: Deep.Traversable (Full.Outward (Traversal p q m)) g+                => (forall a. p a -> m (q a)) -> g p p -> m (g q q)+traverseOutward f = Deep.traverse $ Full.Outward $ Traversal f  newtype Map (p :: Type -> Type) (q :: Type -> Type) = Map (forall x. p x -> q x)
+ test/Issue32.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}+{-# LANGUAGE KindSignatures, PolyKinds, StandaloneDeriving, TypeFamilies, TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}++--module Issue32 where++import Data.Functor.Compose+import Data.Functor.Identity+import Data.Kind (Type)+import Data.Void+import qualified Rank2.TH+import qualified Transformation.Deep+import qualified Transformation.Deep.TH+import qualified Transformation.Rank2++import Test.Tasty (TestTree, defaultMain)+import Test.Tasty.HUnit (testCase, assertEqual)++data Param d s = Param+  { key :: s String,+    val :: s String+  }++deriving instance Eq (s String) => Eq (Param d s)+deriving instance Show (s String) => Show (Param d s)++Rank2.TH.deriveFunctor ''Param+Rank2.TH.deriveFoldable ''Param+Rank2.TH.deriveTraversable ''Param+Transformation.Deep.TH.deriveFunctor ''Param+Transformation.Deep.TH.deriveFoldable ''Param+Transformation.Deep.TH.deriveTraversable ''Param++param :: Param x Identity+param = Param {key = Identity "Hello", val = Identity "World"}++test :: TestTree+test = testCase "Issue #32" $ do+  print param+  assertEqual ""+    (Just param)+    (Transformation.Deep.traverse (Transformation.Rank2.Map (Compose . Just)) param)++main = defaultMain test
test/README.lhs view
@@ -314,7 +314,6 @@  instance AG.Attribution DeadCodeEliminator where    type Origin DeadCodeEliminator = Identity-   unwrap DeadCodeEliminator = runIdentity ~~~  We also need another bit of a boilerplate instance that can be automatically generated with Template Haskell functions
test/RepMin.hs view
@@ -67,7 +67,6 @@  instance Attribution RepMin where    type Origin RepMin = Identity-   unwrap RepMin = runIdentity  -- | Inherited attributes' type data InhRepMin = InhRepMin{global :: Int}@@ -86,9 +85,9 @@ type instance AG.Atts (Inherited RepMin) (Deep.Const2 Int) = () type instance AG.Atts (Synthesized RepMin) (Deep.Const2 Int) = Int --- | The semantics of the primitive 'Int' type must be defined manually.-instance Transformation.At (AG.Knit RepMin) Int where-   _ $ Identity n = Rank2.Arrow (const $ Synthesized n)+-- | The synthesized attributes of the leaf 'Int' are the number itself, and there are no inherited attributes.+instance AG.At RepMin (Deep.Const2 Int) where+   attribution RepMin self (inherited, Deep.Const2 n) = (Synthesized n, Deep.Const2 n)  instance AG.At RepMin (Root Int) where    attribution RepMin self (inherited, Root root) = (Synthesized SynRepMin{local= local (syn root),
test/RepMinAuto.hs view
@@ -46,7 +46,6 @@  instance Attribution RepMin where    type Origin RepMin = Identity-   unwrap RepMin = runIdentity     -- | Inherited attributes' type data InhRepMin = InhRepMin{global :: Int}
test/RepMinKeepAG.hs view
@@ -67,7 +67,6 @@  instance AG.Attribution RepMin where    type Origin RepMin = Identity-   unwrap RepMin = runIdentity  -- | Inherited attributes' type data InhRepMin = InhRepMin{global :: Int} deriving Show@@ -83,9 +82,9 @@ type instance AG.Atts (Inherited RepMin) (Deep.Const2 Int) = InhRepMin type instance AG.Atts (Synthesized RepMin) (Deep.Const2 Int) = Int --- | The semantics of the primitive 'Int' type must be defined manually.-instance Transformation.At (AG.Knit (AG.Keep RepMin)) Int where-   _ $ Identity n = Rank2.Arrow (\(Inherited i)-> Synthesized $ AG.Kept i n (Identity $ Deep.Const2 n))+-- | The synthesized attributes of the leaf 'Int' are the number itself, and there are no inherited attributes.+instance RepMin `At` Deep.Const2 Int where+   attribution RepMin self (inherited, Deep.Const2 n) = (Synthesized n, Deep.Const2 n)  instance RepMin `At` Root Int where    attribution RepMin self (inherited, Root root) = (Synthesized SynRepMin{local= local (syn root)},