Changed the definitions of Deep.Product, Sum, and Only

deep-transformations/deep-transformations.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                deep-transformations
-version:             0.2.3
+version:             0.3
 synopsis:            Deep natural and unnatural tree transformations, including attribute grammars
 description:
 

deep-transformations/src/Transformation/Deep.hs

@@ -8,18 +8,16 @@
 
 module Transformation.Deep where
 
-import Control.Applicative (Applicative, liftA2)
 import Data.Data (Data, Typeable)
-import Data.Functor.Compose (Compose, getCompose)
+import Data.Functor.Compose (Compose)
 import Data.Functor.Const (Const)
 import qualified Control.Applicative as Rank1
 import qualified Data.Foldable as Rank1
 import qualified Data.Functor as Rank1
 import qualified Data.Traversable as Rank1
-import qualified Data.Functor
 import Data.Kind (Type)
 import qualified Rank2
-import           Transformation (Transformation, At, Domain, Codomain, ($))
+import           Transformation (Transformation, Domain, Codomain)
 import qualified Transformation.Full as Full
 
 import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd)
@@ -38,54 +36,59 @@ class (Transformation t, Rank2.Traversable (g (Domain t))) => Traversable t g wh
    traverse :: Codomain t ~ Compose m f => t -> g (Domain t) (Domain t) -> m (g f f)
 
 -- | A tuple of only one element
-newtype Only a (d :: Type -> Type) (s :: Type -> Type) =
-   Only {fromOnly :: s a} deriving (Eq, Ord, Show, Data, Typeable)
+newtype Only g (d :: Type -> Type) (s :: Type -> Type) =
+   Only {fromOnly :: s (g d d)}
 
 -- | A nested parametric type represented as a rank-2 type
 newtype Flip f g (d :: Type -> Type) (s :: Type -> Type) =
    Flip {unFlip :: f (s (g d d))}
 
 -- | Like 'Data.Functor.Product.Product' for data types with two type constructor parameters
 data Product g h (d :: Type -> Type) (s :: Type -> Type) =
-   Pair{fst :: s (g d d),
-        snd :: s (h d d)}
+   Pair{fst :: g d s,
+        snd :: h d s}
 
 -- | Like 'Data.Functor.Sum.Sum' for data types with two type constructor parameters
 data Sum g h (d :: Type -> Type) (s :: Type -> Type) =
-   InL (s (g d d))
-   | InR (s (h d d))
+   InL (g d s)
+   | InR (h d s)
 
 -- Instances
 
-instance Rank2.Functor (Only a d) where
+instance Rank2.Functor (Only g d) where
    f <$> Only x = Only (f x)
 
-instance Rank2.Foldable (Only a d) where
+instance Rank2.Foldable (Only g d) where
    foldMap f (Only x) = f x
 
-instance Rank2.Traversable (Only a d) where
+instance Rank2.Traversable (Only g d) where
    traverse f (Only x) = Only Rank1.<$> f x
 
-instance Rank2.Apply (Only a d) where
+instance Rank2.Apply (Only g d) where
    Only f <*> Only x = Only (Rank2.apply f x)
    liftA2 f (Only x) (Only y) = Only (f x y)
 
-instance Rank2.Applicative (Only a d) where
+instance Rank2.Applicative (Only g d) where
    pure f = Only f
 
-instance Rank2.DistributiveTraversable (Only a d)
+instance Rank2.DistributiveTraversable (Only g d)
 
-instance Rank2.Distributive (Only a d) where
+instance Rank2.Distributive (Only g d) where
    cotraverse w f = Only (w (Rank1.fmap fromOnly f))
 
-instance t `At` a => Functor t (Only a) where
-   t <$> Only x = Only (t Transformation.$ x)
+instance Full.Functor t g => Functor t (Only g) where
+   t <$> Only x = Only (t Full.<$> x)
 
-instance t `At` a => Foldable t (Only a) where
-   foldMap t (Only x) = Rank1.getConst (t Transformation.$ x)
+instance Full.Foldable t g => Foldable t (Only g) where
+   foldMap t (Only x) = Full.foldMap t x
 
-instance (t `At` a, Codomain t ~ Compose m f, Rank1.Functor m) => Traversable t (Only a) where
-   traverse t (Only x) = Only Rank1.<$> getCompose (t Transformation.$ x)
+instance (Full.Traversable t g, Codomain t ~ Compose m f, Rank1.Functor m) => Traversable t (Only g) where
+   traverse t (Only x) = Only Rank1.<$> Full.traverse t x
+
+deriving instance (Typeable s, Typeable d, Typeable g, Data (s (g d d))) => Data (Only g d s)
+deriving instance Eq (s (g d d)) => Eq (Only g d s)
+deriving instance Ord (s (g d d)) => Ord (Only g d s)
+deriving instance Show (s (g d d)) => Show (Only g d s)
 
 instance Rank1.Functor f => Rank2.Functor (Flip f g d) where
    f <$> Flip x = Flip (f Rank1.<$> x)
@@ -105,7 +108,7 @@ instance Rank1.Traversable f => Rank2.Traversable (Flip f g d) where
 instance (Rank1.Functor f, Full.Functor t g) => Functor t (Flip f g) where
    t <$> Flip x = Flip ((t Full.<$>) Rank1.<$> x)
 
-instance (Rank1.Traversable f, Full.Traversable t g, Codomain t ~ Compose m f, Applicative m) =>
+instance (Rank1.Traversable f, Full.Traversable t g, Codomain t ~ Compose m f, Rank1.Applicative m) =>
          Traversable t (Flip f g) where
    traverse t (Flip x) = Flip Rank1.<$> Rank1.traverse (Full.traverse t) x
 
@@ -115,77 +118,78 @@ deriving instance Eq (f (s (g d d))) => Eq (Flip f g d s)
 deriving instance Ord (f (s (g d d))) => Ord (Flip f g d s)
 deriving instance Show (f (s (g d d))) => Show (Flip f g d s)
 
-instance Rank2.Functor (Product g h p) where
-   f <$> ~(Pair left right) = Pair (f left) (f right)
+instance (Rank2.Functor (g d), Rank2.Functor (h d)) => Rank2.Functor (Product g h d) where
+   f <$> (Pair left right) = Pair (f Rank2.<$> left) (f Rank2.<$> 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.Apply (g d), Rank2.Apply (h d)) => Rank2.Apply (Product g h d) where
+   Pair g1 h1 <*> ~(Pair g2 h2) = Pair (g1 Rank2.<*> g2) (h1 Rank2.<*> h2)
+   liftA2 f (Pair g1 h1) ~(Pair g2 h2) = Pair (Rank2.liftA2 f g1 g2) (Rank2.liftA2 f h1 h2)
+   liftA3 f (Pair g1 h1) ~(Pair g2 h2) ~(Pair g3 h3) = Pair (Rank2.liftA3 f g1 g2 g3) (Rank2.liftA3 f h1 h2 h3)
 
-instance Rank2.Applicative (Product g h p) where
-   pure f = Pair f f
+instance (Rank2.Applicative (g d), Rank2.Applicative (h d)) => Rank2.Applicative (Product g h d) where
+   pure f = Pair (Rank2.pure f) (Rank2.pure f)
 
-instance Rank2.Foldable (Product g h p) where
-   foldMap f ~(Pair g h) = f g `mappend` f h
+instance (Rank2.Foldable (g d), Rank2.Foldable (h d)) => Rank2.Foldable (Product g h d) where
+   foldMap f (Pair g h) = Rank2.foldMap f g `mappend` Rank2.foldMap f h
 
-instance Rank2.Traversable (Product g h p) where
-   traverse f ~(Pair g h) = liftA2 Pair (f g) (f h)
+instance (Rank2.Traversable (g d), Rank2.Traversable (h d)) => Rank2.Traversable (Product g h d) where
+   traverse f (Pair g h) = Rank1.liftA2 Pair (Rank2.traverse f g) (Rank2.traverse f h)
 
-instance Rank2.DistributiveTraversable (Product g h p)
+instance (Rank2.Distributive (g d), Rank2.Distributive (h d)) => Rank2.DistributiveTraversable (Product g h d)
 
-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 (Rank2.Distributive (g d), Rank2.Distributive (h d)) => Rank2.Distributive (Product g h d) where
+   cotraverse w f = Pair{fst= Rank2.cotraverse w (fst Rank1.<$> f),
+                         snd= Rank2.cotraverse w (snd Rank1.<$> 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 (Functor t g, Functor t h) => Functor t (Product g h) where
+   t <$> Pair left right = Pair (t <$> left) (t <$> right)
 
-instance (Full.Traversable t g, Full.Traversable t h, Codomain t ~ Compose m f, Applicative m) =>
+instance (Traversable t g, Traversable t h, Codomain t ~ Compose m f, Rank1.Applicative m) =>
          Traversable t (Product g h) where
-   traverse t (Pair left right) = liftA2 Pair (Full.traverse t left) (Full.traverse t right)
+   traverse t (Pair left right) = Rank1.liftA2 Pair (traverse t left) (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)
-deriving instance (Eq (s (g d d)), Eq (s (h d d))) => Eq (Product g h d s)
-deriving instance (Ord (s (g d d)), Ord (s (h d d))) => Ord (Product g h d s)
+deriving instance (Typeable d, Typeable s, Typeable g1, Typeable g2,
+                   Data (g1 d s), Data (g2 d s)) => Data (Product g1 g2 d s)
+deriving instance (Show (g1 d s), Show (g2 d s)) => Show (Product g1 g2 d s)
+deriving instance (Eq (g d s), Eq (h d s)) => Eq (Product g h d s)
+deriving instance (Ord (g d s), Ord (h d s)) => Ord (Product g h d s)
 
-instance Rank2.Functor (Sum g h p) where
-   f <$> InL left = InL (f left)
-   f <$> InR right = InR (f right)
+instance (Rank2.Functor (g d), Rank2.Functor (h d)) => Rank2.Functor (Sum g h d) where
+   f <$> InL left = InL (f Rank2.<$> left)
+   f <$> InR right = InR (f Rank2.<$> right)
 
-instance Rank2.Foldable (Sum g h p) where
-   foldMap f (InL left) = f left
-   foldMap f (InR right) = f right
+instance (Rank2.Foldable (g d), Rank2.Foldable (h d)) => Rank2.Foldable (Sum g h d) where
+   foldMap f (InL left) = Rank2.foldMap f left
+   foldMap f (InR right) = Rank2.foldMap f right
 
-instance Rank2.Traversable (Sum g h p) where
-   traverse f (InL left) = InL Rank1.<$> f left
-   traverse f (InR right) = InR Rank1.<$> f right
+instance (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 (Full.Functor t g, Full.Functor t h) => Functor t (Sum g h) where
-   t <$> InL left = InL (t Full.<$> left)
-   t <$> InR right = InR (t Full.<$> right)
+instance (Functor t g, Functor t h) => Functor t (Sum g h) where
+   t <$> InL left = InL (t <$> left)
+   t <$> InR right = InR (t <$> right)
 
-instance (Full.Foldable t g, Full.Foldable t h, Codomain t ~ Const m) => Foldable t (Sum g h) where
-   foldMap t (InL left) = Full.foldMap t left
-   foldMap t (InR right) = Full.foldMap t right
+instance (Foldable t g, Foldable t h, Codomain t ~ Const m) => Foldable t (Sum g h) where
+   foldMap t (InL left) = foldMap t left
+   foldMap t (InR right) = foldMap t right
 
-instance (Full.Traversable t g, Full.Traversable t h, Codomain t ~ Compose m f, Applicative m) =>
+instance (Traversable t g, Traversable t h, Codomain t ~ Compose m f, Rank1.Applicative m) =>
          Traversable t (Sum g h) where
-   traverse t (InL left) = InL Rank1.<$> Full.traverse t left
-   traverse t (InR right) = InR Rank1.<$> Full.traverse t right
+   traverse t (InL left) = InL Rank1.<$> traverse t left
+   traverse t (InR right) = InR Rank1.<$> traverse t right
 
-deriving instance (Typeable p, Typeable q, Typeable g1, Typeable g2,
-                   Data (q (g1 p p)), Data (q (g2 p p))) => Data (Sum g1 g2 p q)
-deriving instance (Show (q (g1 p p)), Show (q (g2 p p))) => Show (Sum g1 g2 p q)
-deriving instance (Eq (s (g d d)), Eq (s (h d d))) => Eq (Sum g h d s)
-deriving instance (Ord (s (g d d)), Ord (s (h d d))) => Ord (Sum g h d s)
+deriving instance (Typeable d, Typeable s, Typeable g1, Typeable g2,
+                   Data (g1 d s), Data (g2 d s)) => Data (Sum g1 g2 d s)
+deriving instance (Show (g1 d s), Show (g2 d s)) => Show (Sum g1 g2 d s)
+deriving instance (Eq (g d s), Eq (h d s)) => Eq (Sum g h d s)
+deriving instance (Ord (g d s), Ord (h d s)) => Ord (Sum g h d s)
 
 -- | Alphabetical synonym for '<$>'
 fmap :: Functor t g => t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)
 fmap = (<$>)
 
 -- | Equivalent of 'Data.Either.either'
-eitherFromSum :: Sum g h d s -> Either (s (g d d)) (s (h d d))
+eitherFromSum :: Sum g h d s -> Either (g d s) (h d s)
 eitherFromSum (InL left) = Left left
 eitherFromSum (InR right) = Right right