packages feed

adjunctions 0.6.0 → 0.7.0

raw patch · 9 files changed

+31/−598 lines, 9 filesdep +arraydep +containersdep +keysdep ~comonad-transformersdep ~semigroupoids

Dependencies added: array, containers, keys, mtl, representable-functors, semigroups

Dependency ranges changed: comonad-transformers, semigroupoids

Files

− Control/Comonad/Trans/Density.hs 
@@ -1,50 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GADTs #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Comonad.Trans.Density--- Copyright   :  (C) 2008-2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  experimental--- Portability :  non-portable (GADTs, MPTCs)------ The densityT comonad for a functor. aka the comonad generated by a functor--- The ''densityT'' term dates back to Dubuc''s 1974 thesis. The term --- ''monad genererated by a functor'' dates back to 1972 in Street''s --- ''Formal Theory of Monads''.------------------------------------------------------------------------------module Control.Comonad.Trans.Density-  ( DensityT(..)-  , liftDensityT-  , densityTToAdjunction, adjunctionToDensityT-  ) where--import Control.Comonad-import Control.Comonad.Trans.Class-import Data.Functor.Adjunction--data DensityT k a where-  DensityT :: (k b -> a) -> k b -> DensityT k a--instance Functor (DensityT f) where-  fmap f (DensityT g h) = DensityT (f . g) h--instance Extend (DensityT f) where-  duplicate (DensityT f ws) = DensityT (DensityT f) ws--instance Comonad (DensityT f) where-  extract (DensityT f a) = f a--instance ComonadTrans DensityT where-  lower (DensityT f c) = extend f c-  --- | The natural isomorphism between a comonad w and the comonad generated by w (forwards).-liftDensityT :: Comonad w => w a -> DensityT w a-liftDensityT = DensityT extract --densityTToAdjunction :: Adjunction f g => DensityT f a -> f (g a)-densityTToAdjunction (DensityT f v) = fmap (leftAdjunct f) v--adjunctionToDensityT :: Adjunction f g => f (g a) -> DensityT f a-adjunctionToDensityT = DensityT counit
− Control/Monad/Trans/Codensity.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE Rank2Types #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Trans.Codensity--- Copyright   :  (C) 2008-2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  non-portable (rank-2 polymorphism)---------------------------------------------------------------------------------module Control.Monad.Trans.Codensity-  ( CodensityT(..)-  , lowerCodensityT-  , codensityTToAdjunction-  , adjunctionToCodensityT-  ) where--import Control.Applicative-import Control.Monad (ap)-import Data.Functor.Adjunction-import Data.Functor.Apply-import Control.Monad.Trans.Class--{--type Codensity = CodensityT Identity-codensity :: (forall b. (a -> b) -> b) -> Codensity a-runCodensity :: Codensity a -> (a -> b) -> a--}--newtype CodensityT m a = CodensityT { runCodensityT :: forall b. (a -> m b) -> m b }--instance Functor (CodensityT k) where-  fmap f (CodensityT m) = CodensityT (\k -> m (k . f))--instance Apply (CodensityT f) where-  (<.>) = ap--instance Applicative (CodensityT f) where-  pure x = CodensityT (\k -> k x)-  (<*>) = ap--instance Monad (CodensityT f) where-  return x = CodensityT (\k -> k x)-  m >>= k = CodensityT (\c -> runCodensityT m (\a -> runCodensityT (k a) c))--{--instance MonadIO m => MonadIO (CodensityT m) where-  liftIO = liftCodensityT . liftIO --}--instance MonadTrans CodensityT where-  lift m = CodensityT (m >>=)--lowerCodensityT :: Monad m => CodensityT m a -> m a-lowerCodensityT a = runCodensityT a return--codensityTToAdjunction :: Adjunction f g => CodensityT g a -> g (f a)-codensityTToAdjunction r = runCodensityT r unit--adjunctionToCodensityT :: Adjunction f g => g (f a) -> CodensityT g a-adjunctionToCodensityT f = CodensityT (\a -> fmap (rightAdjunct a) f)
Data/Functor/Adjunction.hs view
@@ -13,29 +13,27 @@ ------------------------------------------------------------------------------------------- module Data.Functor.Adjunction    ( Adjunction(..)-  , distributeAdjunct-  , Representation(..)-  , repAdjunction+  , tabulateAdjunction+  , indexAdjunction   ) where -import Control.Applicative import Control.Monad.Instances () import Control.Monad.Trans.Identity +import Control.Monad.Representable import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer import Control.Comonad.Trans.Env+import Control.Comonad.Trans.Traced -import Data.Distributive 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, Distributive g) => Adjunction f g | f -> g, g -> f where+class (Functor f, Representable g) => Adjunction f g | f -> g, g -> f where   unit :: a -> g (f a)   counit :: f (g a) -> a   leftAdjunct :: (f a -> b) -> a -> g b@@ -46,12 +44,12 @@   leftAdjunct f = fmap f . unit   rightAdjunct f = counit . fmap f --- | Every right adjoint is representable by its left adjoint applied to unit --- Consequently, we use the isomorphism from ((->) f ()) ~ g to distribute--- the right adjoint over any other functor.-distributeAdjunct :: (Adjunction f g, Functor w) => w (g a) -> g (w a)-distributeAdjunct wg = leftAdjunct (\a -> fmap (\b -> rightAdjunct (const b) a) wg) ()+tabulateAdjunction :: Adjunction f g => (f () -> b) -> g b+tabulateAdjunction f = leftAdjunct f () +indexAdjunction :: Adjunction f g => g b -> f a -> b+indexAdjunction = rightAdjunct . const+ instance Adjunction ((,)e) ((->)e) where   leftAdjunct f a e = f (e, a)   rightAdjunct f ~(e, a) = f a e@@ -65,20 +63,13 @@   counit = rightAdjunct runIdentityT . runIdentityT  instance Adjunction w m => Adjunction (EnvT e w) (ReaderT e m) where-  unit a = ReaderT $ \e -> EnvT e <$> unit a+  unit = ReaderT . flip fmap EnvT . flip leftAdjunct   counit (EnvT e w) = counit $ fmap (flip runReaderT e) w +instance Adjunction m w => Adjunction (WriterT s m) (TracedT s w) where+  unit = TracedT . leftAdjunct (\ma s -> WriterT (fmap (\a -> (a, s)) ma)) +  -- counit (WriterT mwas) = + 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--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-  }
− Data/Functor/Composition.hs 
@@ -1,14 +0,0 @@-module Data.Functor.Composition -  ( Composition(..) ) where--import Data.Functor.Compose-  --- | We often need to distinguish between various forms of Functor-like composition in Haskell in order to please the type system.--- This lets us work with these representations uniformly.-class Composition compose where-  decompose :: compose f g x -> f (g x)-  compose :: f (g x) -> compose f g x--instance Composition Compose where-  decompose = getCompose-  compose = Compose
− Data/Functor/KanExtension.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE Rank2Types, GADTs #-}----------------------------------------------------------------------------------------------- |--- Module	: Data.Functor.KanExtension--- Copyright 	: 2008-2011 Edward Kmett--- License	: BSD------ Maintainer	: Edward Kmett <ekmett@gmail.com>--- Stability	: experimental--- Portability	: rank 2 types------------------------------------------------------------------------------------------------module Data.Functor.KanExtension where--import Data.Functor.Identity-import Data.Functor.Adjunction-import Data.Functor.Composition--newtype Ran g h a = Ran { runRan :: forall b. (a -> g b) -> h b }--instance Functor (Ran g h) where-  fmap f m = Ran (\k -> runRan m (k . f))- --- | 'toRan' and 'fromRan' witness a higher kinded adjunction. from @(`'Compose'` g)@ to @'Ran' g@-toRan :: (Composition compose, Functor k) => (forall a. compose k g a -> h a) -> k b -> Ran g h b-toRan s t = Ran (s . compose . flip fmap t)--fromRan :: Composition compose => (forall a. k a -> Ran g h a) -> compose k g b -> h b-fromRan s = flip runRan id . s . decompose--composeRan :: Composition compose => Ran f (Ran g h) a -> Ran (compose f g) h a-composeRan r = Ran (\f -> runRan (runRan r (decompose . f)) id)--decomposeRan :: (Composition compose, Functor f) => Ran (compose f g) h a -> Ran f (Ran g h) a-decomposeRan r = Ran (\f -> Ran (\g -> runRan r (compose . fmap g . f)))--adjointToRan :: Adjunction f g => f a -> Ran g Identity a-adjointToRan f = Ran (\a -> Identity $ rightAdjunct a f)--ranToAdjoint :: Adjunction f g => Ran g Identity a -> f a-ranToAdjoint r = runIdentity (runRan r unit)--ranToComposedAdjoint :: (Composition compose, Adjunction f g) => Ran g h a -> compose h f a-ranToComposedAdjoint r = compose (runRan r unit)--composedAdjointToRan :: (Composition compose, Adjunction f g, Functor h) => compose h f a -> Ran g h a-composedAdjointToRan f = Ran (\a -> fmap (rightAdjunct a) (decompose f))--data Lan g h a where-  Lan :: (g b -> a) -> h b -> Lan g h a---- 'fromLan' and 'toLan' witness a (higher kinded) adjunction between @'Lan' g@ and @(`Compose` g)@-toLan :: (Composition compose, Functor f) => (forall a. h a -> compose f g a) -> Lan g h b -> f b-toLan s (Lan f v) = fmap f . decompose $ s v--fromLan :: (Composition compose) => (forall a. Lan g h a -> f a) -> h b -> compose f g b-fromLan s = compose . s . Lan id--instance Functor (Lan f g) where-  fmap f (Lan g h) = Lan (f . g) h--adjointToLan :: Adjunction f g => g a -> Lan f Identity a-adjointToLan = Lan counit . Identity--lanToAdjoint :: Adjunction f g => Lan f Identity a -> g a-lanToAdjoint (Lan f v) = leftAdjunct f (runIdentity v)---- | 'lanToComposedAdjoint' and 'composedAdjointToLan' witness the natural isomorphism between @Lan f h@ and @Compose h g@ given @f -| g@-lanToComposedAdjoint :: (Composition compose, Functor h, Adjunction f g) => Lan f h a -> compose h g a-lanToComposedAdjoint (Lan f v) = compose (fmap (leftAdjunct f) v)--composedAdjointToLan :: Composition compose => Adjunction f g => compose h g a -> Lan f h a-composedAdjointToLan = Lan counit . decompose---- | 'composeLan' and 'decomposeLan' witness the natural isomorphism from @Lan f (Lan g h)@ and @Lan (f `o` g) h@-composeLan :: (Composition compose, Functor f) => Lan f (Lan g h) a -> Lan (compose f g) h a-composeLan (Lan f (Lan g h)) = Lan (f . fmap g . decompose) h--decomposeLan :: Composition compose => Lan (compose f g) h a -> Lan f (Lan g h) a-decomposeLan (Lan f h) = Lan (f . compose) (Lan id h)-
− Data/Functor/Yoneda.hs 
@@ -1,166 +0,0 @@-{-# LANGUAGE CPP, Rank2Types, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Functor.Yoneda--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  MPTCs, fundeps----------------------------------------------------------------------------------module Data.Functor.Yoneda-  ( Yoneda-  , yoneda-  , runYoneda-  , liftYoneda-  , lowerYoneda-  , YonedaT(..)-  , liftYonedaT-  , lowerYonedaT-  , maxF, minF, maxM, minM-  ) where--import Prelude hiding (sequence)-import Control.Applicative-import Control.Monad (MonadPlus(..), liftM)-import Control.Monad.Fix-import Control.Monad.Trans.Class-import Control.Comonad-import Control.Comonad.Trans.Class-import Data.Distributive-import Data.Foldable-import Data.Function (on)-import Data.Functor.Apply-import Data.Functor.Plus-import Data.Functor.Identity-import Data.Functor.Adjunction-import Data.Traversable-import Text.Read hiding (lift)--type Yoneda = YonedaT Identity --yoneda :: (forall b. (a -> b) -> b) -> Yoneda a-yoneda f = YonedaT (Identity . f)-{-# INLINE yoneda #-}--runYoneda :: Yoneda a -> (a -> b) -> b-runYoneda (YonedaT f) = runIdentity . f-{-# INLINE runYoneda #-}--liftYoneda :: a -> Yoneda a-liftYoneda a = YonedaT (\f -> Identity (f a))-{-# INLINE liftYoneda #-}--lowerYoneda :: Yoneda a -> a-lowerYoneda m = runIdentity (runYonedaT m id)-{-# INLINE lowerYoneda #-}--newtype YonedaT f a = YonedaT { runYonedaT :: forall b. (a -> b) -> f b } --liftYonedaT :: Functor f => f a -> YonedaT f a -liftYonedaT a = YonedaT (\f -> fmap f a)--lowerYonedaT :: YonedaT f a -> f a -lowerYonedaT (YonedaT f) = f id--{-# RULES "lower/lift=id" liftYonedaT . lowerYonedaT = id #-}-{-# RULES "lift/lower=id" lowerYonedaT . liftYonedaT = id #-}--instance Functor (YonedaT f) where-  fmap f m = YonedaT (\k -> runYonedaT m (k . f))--instance Apply f => Apply (YonedaT f) where-  YonedaT m <.> YonedaT n = YonedaT (\f -> m (f .) <.> n id)-  -instance Applicative f => Applicative (YonedaT f) where-  pure a = YonedaT (\f -> pure (f a))-  YonedaT m <*> YonedaT n = YonedaT (\f -> m (f .) <*> n id)--instance Foldable f => Foldable (YonedaT f) where-  foldMap f = foldMap f . lowerYonedaT---- a traversable isntance with a function in it!-instance Traversable f => Traversable (YonedaT f) where-  traverse f = fmap liftYonedaT . traverse f . lowerYonedaT--instance Distributive f => Distributive (YonedaT f) where-  collect f = liftYonedaT . collect (lowerYonedaT . f)--instance Adjunction f g => Adjunction (YonedaT f) (YonedaT g) where-  unit = liftYonedaT . fmap liftYonedaT . unit-  counit (YonedaT m) = counit (m lowerYonedaT)---- instance Show1 f => Show1 (YonedaT f) where-instance Show (f a) => Show (YonedaT f a) where-  showsPrec d (YonedaT f) = showParen (d > 10) $-    showString "liftYonedaT " . showsPrec 11 (f id)---- instance Read1 f => Read1 (YonedaT f) where-#ifdef __GLASGOW_HASKELL__-instance (Functor f, Read (f a)) => Read (YonedaT f a) where-  readPrec = parens $ prec 10 $ do-     Ident "liftYonedaT" <- lexP-     liftYonedaT <$> step readPrec-#endif--instance Eq (f a) => Eq (YonedaT f a) where-  (==) = (==) `on` lowerYonedaT--instance Ord (f a) => Ord (YonedaT f a) where-  compare = compare `on` lowerYonedaT--maxF :: (Functor f, Ord (f a)) => YonedaT f a -> YonedaT f a -> YonedaT f a-YonedaT f `maxF` YonedaT g = liftYonedaT $ f id `max` g id--- {-# RULES "max/maxF" max = maxF #-}-{-# INLINE maxF #-}--minF :: (Functor f, Ord (f a)) => YonedaT f a -> YonedaT f a -> YonedaT f a-YonedaT f `minF` YonedaT g = liftYonedaT $ f id `max` g id--- {-# RULES "min/minF" min = minF #-}-{-# INLINE minF #-}--maxM :: (Monad m, Ord (m a)) => YonedaT m a -> YonedaT m a -> YonedaT m a-YonedaT f `maxM` YonedaT g = lift $ f id `max` g id--- {-# RULES "max/maxM" max = maxM #-}-{-# INLINE maxM #-}--minM :: (Monad m, Ord (m a)) => YonedaT m a -> YonedaT m a -> YonedaT m a-YonedaT f `minM` YonedaT g = lift $ f id `min` g id--- {-# RULES "min/minM" min = minM #-}-{-# INLINE minM #-}--instance Alt f => Alt (YonedaT f) where-  YonedaT f <!> YonedaT g = YonedaT (\k -> f k <!> g k)--instance Plus f => Plus (YonedaT f) where-  zero = YonedaT $ const zero--instance Alternative f => Alternative (YonedaT f) where-  empty = YonedaT $ const empty-  YonedaT f <|> YonedaT g = YonedaT (\k -> f k <|> g k)-  -instance Monad m => Monad (YonedaT m) where-  return a = YonedaT (\f -> return (f a))-  YonedaT m >>= k = YonedaT (\f -> m id >>= \a -> runYonedaT (k a) f)--instance MonadFix m => MonadFix (YonedaT m) where-  mfix f = lift $ mfix (lowerYonedaT . f)--instance MonadPlus m => MonadPlus (YonedaT m) where-  mzero = YonedaT (const mzero)-  YonedaT f `mplus` YonedaT g = YonedaT (\k -> f k `mplus` g k)--instance MonadTrans YonedaT where-  lift a = YonedaT (\f -> liftM f a)--instance Extend w => Extend (YonedaT w) where-  extend k (YonedaT m) = YonedaT (\f -> extend (f . k . liftYonedaT) (m id))--instance Comonad w => Comonad (YonedaT w) where-  extract = extract . lowerYonedaT --instance ComonadTrans YonedaT where-  lower = lowerYonedaT
− Data/Functor/Yoneda/Contravariant.hs 
@@ -1,135 +0,0 @@-{-# LANGUAGE CPP, GADTs, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Functor.Yoneda.Contravariant--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  GADTs, MPTCs, fundeps---------------------------------------------------------------------------------module Data.Functor.Yoneda.Contravariant-  ( Yoneda-  , yoneda-  , liftYoneda-  , lowerYoneda-  , liftYonedaT-  , lowerYonedaT-  , lowerM-  , YonedaT(..)-  ) where--import Control.Applicative-import Control.Monad (MonadPlus(..), liftM)-import Control.Monad.Fix-import Control.Monad.Trans.Class-import Control.Comonad-import Control.Comonad.Trans.Class-import Data.Distributive-import Data.Foldable-import Data.Function (on)-import Data.Functor.Apply-import Data.Functor.Plus-import Data.Functor.Identity-import Data.Functor.Adjunction-import Data.Traversable-import Prelude hiding (sequence)-import Text.Read hiding (lift)--type Yoneda = YonedaT Identity---- | The contravariant Yoneda lemma applied to a covariant functor-data YonedaT f a where-  YonedaT :: (b -> a) -> f b -> YonedaT f a--yoneda :: (b -> a) -> b -> Yoneda a-yoneda f = YonedaT f . Identity--liftYoneda :: a -> Yoneda a -liftYoneda = YonedaT id . Identity--lowerYoneda :: Yoneda a -> a-lowerYoneda (YonedaT f (Identity a)) = f a--liftYonedaT :: f a -> YonedaT f a -liftYonedaT = YonedaT id--lowerYonedaT :: Functor f => YonedaT f a -> f a-lowerYonedaT (YonedaT f m) = fmap f m--lowerM :: Monad f => YonedaT f a -> f a -lowerM (YonedaT f m) = liftM f m---instance Functor (YonedaT f) where-  fmap f (YonedaT g v) = YonedaT (f . g) v--instance Applicative f => Applicative (YonedaT f) where-  pure = liftYonedaT . pure-  m <*> n = liftYonedaT $ lowerYonedaT m <*> lowerYonedaT n--instance Alternative f => Alternative (YonedaT f) where-  empty = liftYonedaT empty -  m <|> n = liftYonedaT $ lowerYonedaT m <|> lowerYonedaT n--instance Alt f => Alt (YonedaT f) where-  m <!> n = liftYonedaT $ lowerYonedaT m <!> lowerYonedaT n--instance Plus f => Plus (YonedaT f) where-  zero = liftYonedaT zero--instance Monad m => Monad (YonedaT m) where-  return = YonedaT id . return-  YonedaT f v >>= k = lift (v >>= lowerM . k . f)--instance MonadTrans YonedaT where-  lift = YonedaT id--instance MonadFix f => MonadFix (YonedaT f) where-  mfix f = lift $ mfix (lowerM . f)--instance MonadPlus f => MonadPlus (YonedaT f) where-  mzero = lift mzero-  m `mplus` n = lift $ lowerM m `mplus` lowerM n--instance Extend w => Extend (YonedaT w) where-  extend k (YonedaT f v) = YonedaT id $ extend (k . YonedaT f) v--instance Comonad w => Comonad (YonedaT w) where-  extract (YonedaT f v) = f (extract v)--instance ComonadTrans YonedaT where-  lower (YonedaT f a) = fmap f a--instance (Foldable f, Functor f) => Foldable (YonedaT f) where-  foldMap f (YonedaT k a) = foldMap (f . k) a--instance Traversable f => Traversable (YonedaT f) where-  traverse f (YonedaT k a) = YonedaT id <$> traverse (f . k) a--instance Distributive f => Distributive (YonedaT f) where-  collect f = liftYonedaT . collect (lowerYonedaT . f)--instance (Functor f, Show (f a)) => Show (YonedaT f a) where-  showsPrec d (YonedaT f a) = showParen (d > 10) $-    showString "liftYonedaT " . showsPrec 11 (fmap f a)--#ifdef __GLASGOW_HASKELL__-instance (Functor f, Read (f a)) => Read (YonedaT f a) where-  readPrec = parens $ prec 10 $ do-    Ident "liftYonedaT" <- lexP-    liftYonedaT <$> step readPrec-#endif--instance (Functor f, Eq (f a)) => Eq (YonedaT f a) where-  (==) = (==) `on` lowerYonedaT--instance (Functor f, Ord (f a)) => Ord (YonedaT f a) where-  compare = compare `on` lowerYonedaT--instance Adjunction f g => Adjunction (YonedaT f) (YonedaT g) where-  unit = liftYonedaT . fmap liftYonedaT . unit-  counit = counit . fmap lowerYonedaT . lowerYonedaT-
− Data/Functor/Zap.hs 
@@ -1,50 +0,0 @@-{-# 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
adjunctions.cabal view
@@ -1,6 +1,6 @@ name:          adjunctions category:      Data Structures, Adjunctions-version:       0.6.0+version:       0.7.0 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -19,27 +19,28 @@  library   build-depends: +    array >= 0.3.0.2 && < 0.4,     base >= 4 && < 4.4,-    contravariant >= 0.1.2 && < 0.2,     comonad >= 1.0 && < 1.1,+    comonad-transformers >= 1.5.1 && < 1.6,+    containers >= 0.4 && < 0.5,+    contravariant >= 0.1.2 && < 0.2,     distributive >= 0.1.1 && < 0.2,-    semigroupoids >= 1.1.0 && < 1.2.0,-    comonad-transformers >= 1.5 && < 1.6,+    keys >= 0.1.0.1 && < 0.2,+    mtl >= 2.0.1.0 && < 2.1,+    representable-functors >= 0.1.0.1 && < 0.2,+    semigroups >= 0.3.4 && < 0.4,+    semigroupoids >= 1.1.1 && < 1.2.0,     transformers >= 0.2.0 && < 0.3    exposed-modules:+    Data.Functor.Adjunction+    Data.Functor.Contravariant.Adjunction+     Control.Comonad.Trans.Adjoint-    Control.Comonad.Trans.Density     Control.Monad.Trans.Adjoint-    Control.Monad.Trans.Codensity     Control.Monad.Trans.Conts     Control.Monad.Trans.Contravariant.Adjoint-    Data.Functor.Adjunction-    Data.Functor.Composition-    Data.Functor.Contravariant.Adjunction-    Data.Functor.Zap-    Data.Functor.Yoneda-    Data.Functor.Yoneda.Contravariant-    Data.Functor.KanExtension -  ghc-options: -Wall +  ghc-options: -Wall+