adjunctions 0.1 → 0.2

raw patch · 4 files changed

+167/−4 lines, 4 filesdep +contravariantPVP ok

version bump matches the API change (PVP)

Dependencies added: contravariant

API changes (from Hackage documentation)

Files

• Data/Functor/Adjunction.hs +41/−3
• Data/Functor/Contravariant/Adjunction.hs +72/−0
• Data/Functor/Zap.hs +50/−0
• adjunctions.cabal +4/−1

@@ -1,12 +1,31 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}+{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, ImplicitParams #-}++-------------------------------------------------------------------------------------------+-- |+-- Module	: Data.Functor.Adjunction+-- Copyright 	: 2008-2011 Edward Kmett+-- License	: BSD+--+-- Maintainer	: Edward Kmett <ekmett@gmail.com>+-- Stability	: experimental+-- Portability	: rank 2 types, MPTCs, fundeps+--+------------------------------------------------------------------------------------------- module Data.Functor.Adjunction    ( Adjunction(..)+  , Representation(..)+  , repAdjunction   ) where  import Control.Monad.Instances () import Control.Monad.Trans.Identity import Data.Functor.Identity+import Data.Functor.Compose+import qualified Data.Functor.Contravariant.Adjunction as C+import qualified Data.Functor.Contravariant.Compose as C +-- | An adjunction between Hask and Hask.+-- -- > rightAdjunct unit = id -- > leftAdjunct counit = id  class (Functor f, Functor g) => Adjunction f g | f -> g, g -> f where@@ -29,5 +48,24 @@   rightAdjunct f = runIdentity . f . runIdentity  instance Adjunction f g => Adjunction (IdentityT f) (IdentityT g) where-  unit = IdentityT . fmap IdentityT . unit-  counit = counit . fmap runIdentityT . runIdentityT+  unit = IdentityT . leftAdjunct IdentityT+  counit = rightAdjunct runIdentityT . runIdentityT++instance (Adjunction f g, Adjunction f' g') => Adjunction (Compose f' f) (Compose g g') where+  unit = Compose . leftAdjunct (leftAdjunct Compose) +  counit = rightAdjunct (rightAdjunct getCompose) . getCompose++instance (C.Adjunction f g, C.DualAdjunction f' g') => Adjunction (C.Compose f' f) (C.Compose g g') where+  unit = C.Compose . C.leftAdjunct (C.leftAdjunctOp C.Compose)+  counit = C.rightAdjunctOp (C.rightAdjunct C.getCompose) . C.getCompose++data Representation f x = Representation+  { rep :: forall a. (x -> a) -> f a+  , unrep :: forall a. f a -> x -> a+  }+ +repAdjunction :: Adjunction f g => Representation g (f ())+repAdjunction = Representation +  { rep = flip leftAdjunct ()+  , unrep = rightAdjunct . const+  }

@@ -0,0 +1,72 @@+{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}+module Data.Functor.Contravariant.Adjunction +  ( Adjunction(..)+  , DualAdjunction(..)+  , Representation(..)+  , repAdjunction, repFlippedAdjunction+  ) where++import Control.Monad.Instances ()+import Data.Functor.Contravariant++-- | An adjunction from Hask^op to Hask+-- +-- > Op (f a) b ~ Hask a (g b)+--+-- > rightAdjunct unit = id+-- > leftAdjunct counit = id+class (Contravariant f, Contravariant g) => Adjunction f g | f -> g, g -> f where+  unit :: a -> g (f a) -- monad in Hask+  counit :: a -> f (g a) -- comonad in Hask^op+  leftAdjunct  :: (b -> f a) -> a -> g b +  rightAdjunct :: (a -> g b) -> b -> f a+  unit = leftAdjunct id +  counit = rightAdjunct id+  leftAdjunct f = contramap f . unit +  rightAdjunct f = contramap f . counit++-- | This adjunction gives rise to the Cont monad+instance Adjunction (Op r) (Op r) where+  unit a = Op (\k -> getOp k a)+  counit = unit++-- | This gives rise to the Cont Bool monad+instance Adjunction Predicate Predicate where+  unit a = Predicate (\k -> getPredicate k a)+  counit = unit++-- | A representation of a contravariant functor+data Representation f x = Representation+  { rep :: forall a. (a -> x) -> f a+  , unrep :: forall a. f a -> (a -> x)+  }+ +-- | Represent a contravariant functor that has a left adjoint+repAdjunction :: Adjunction f g => Representation g (f ())+repAdjunction = Representation +  { rep = flip leftAdjunct () +  , unrep = rightAdjunct . const+  }++repFlippedAdjunction :: Adjunction f g => Representation f (g ()) +repFlippedAdjunction = Representation +  { rep = flip rightAdjunct () +  , unrep = leftAdjunct . const+  }++-- | An adjunction from Hask to Hask^op+-- +-- >  Hask (f a) b ~ Op a (g b)+--+-- > rightAdjunct unit = id+-- > leftAdjunct counit = id+class (Contravariant f, Contravariant g) => DualAdjunction f g | f -> g, g -> f where+  unitOp :: g (f a) -> a+  counitOp :: f (g a) -> a+  leftAdjunctOp :: (f a -> b) -> g b -> a+  rightAdjunctOp :: (g b -> a) -> f a -> b++  unitOp = leftAdjunctOp id+  counitOp = rightAdjunctOp id+  leftAdjunctOp f = unitOp . contramap f+  rightAdjunctOp f = counitOp . contramap f

@@ -0,0 +1,50 @@+{-# LANGUAGE Rank2Types, MultiParamTypeClasses #-}+-------------------------------------------------------------------------------------------+-- |+-- Module	: Data.Functor.Zap+-- Copyright 	: 2008-2011 Edward Kmett+-- License	: BSD3+--+-- Maintainer	: Edward Kmett <ekmett@gmail.com>+-- Stability	: experimental+-- Portability	: rank-2 types, MPTCs+--+-------------------------------------------------------------------------------------------++module Data.Functor.Zap+	( Zap(..), zap, flipZap, zapAdjunction, composeZap+        , Bizap(..), bizap, flipBizap, bizapProductSum+	) where++import Data.Functor.Compose+import Data.Functor.Adjunction++newtype Zap f g = Zap { zapWith :: forall a b c. (a -> b -> c) -> f a -> g b -> c }++zap :: Zap f g -> f (a -> b) -> g a -> b+zap z = zapWith z id++flipZap :: Zap f g -> Zap g f +flipZap (Zap z) = Zap $ \f a b -> z (flip f) b a++strength :: Functor f => a -> f b -> f (a, b)+strength = fmap . (,)++zapAdjunction :: Adjunction f g => Zap g f +zapAdjunction = Zap $ \f a b -> uncurry (flip f) $ rightAdjunct (uncurry (flip strength)) $ strength a b ++composeZap :: Zap f g -> Zap h i -> Zap (Compose f h) (Compose g i) +composeZap (Zap u) (Zap v) = Zap $ \f (Compose a) (Compose b) -> u (v f) a b++newtype Bizap p q = Bizap { bizapWith :: forall a b c d e.  (a -> c -> e) -> (b -> d -> e) -> p a b -> q c d -> e }++bizap :: Bizap p q -> p (a -> c) (b -> c) -> q a b -> c+bizap z = bizapWith z id id++flipBizap :: Bizap p q -> Bizap q p+flipBizap (Bizap z) = Bizap $ \f g a b -> z (flip f) (flip g) b a++bizapProductSum :: Bizap (,) Either+bizapProductSum = Bizap go where+  go l _ (f,_) (Left a) = l f a+  go _ r (_,g) (Right b) = r g b 

@@ -1,6 +1,6 @@ name:          adjunctions category:      Data Structures, Adjunctions-version:       0.1+version:       0.2 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -20,10 +20,13 @@ library   build-depends:      base >= 4 && < 4.4,+    contravariant >= 0.1.2 && < 0.2,     transformers >= 0.2.0 && < 0.3    exposed-modules:     Control.Monad.Trans.Adjoint     Data.Functor.Adjunction+    Data.Functor.Contravariant.Adjunction+    Data.Functor.Zap    ghc-options: -Wall