diff --git a/deep-transformations/deep-transformations.cabal b/deep-transformations/deep-transformations.cabal index 2e08945..e475ec3 100644 --- a/deep-transformations/deep-transformations.cabal +++ b/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: diff --git a/deep-transformations/src/Transformation/Deep.hs b/deep-transformations/src/Transformation/Deep.hs index df0093d..ede0a73 100644 --- a/deep-transformations/src/Transformation/Deep.hs +++ b/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,8 +36,8 @@ 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) = @@ -47,45 +45,50 @@ newtype Flip f g (d :: Type -> Type) (s :: Type -> Type) = -- | 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