Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

initialized

  • Loading branch information...
commit e772b6693d1ae21899dfc5caf532f452d14db46d 0 parents
Edward Kmett authored
2  .gitignore
... ... @@ -0,0 +1,2 @@
  1 +_darcs
  2 +dist
50 Control/Comonad/Density.hs
... ... @@ -0,0 +1,50 @@
  1 +{-# LANGUAGE MultiParamTypeClasses, GADTs #-}
  2 +-----------------------------------------------------------------------------
  3 +-- |
  4 +-- Module : Control.Comonad.Density
  5 +-- Copyright : (C) 2008-2011 Edward Kmett
  6 +-- License : BSD-style (see the file LICENSE)
  7 +--
  8 +-- Maintainer : Edward Kmett <ekmett@gmail.com>
  9 +-- Stability : experimental
  10 +-- Portability : non-portable (GADTs, MPTCs)
  11 +--
  12 +-- The density comonad for a functor. aka the comonad generated by a functor
  13 +-- The ''density'' term dates back to Dubuc''s 1974 thesis. The term
  14 +-- ''monad genererated by a functor'' dates back to 1972 in Street''s
  15 +-- ''Formal Theory of Monads''.
  16 +----------------------------------------------------------------------------
  17 +module Control.Comonad.Density
  18 + ( DensityT(..)
  19 + , liftDensityT
  20 + , densityTToAdjunction, adjunctionToDensityT
  21 + ) where
  22 +
  23 +import Control.Comonad
  24 +import Control.Comonad.Trans.Class
  25 +import Data.Functor.Adjunction
  26 +
  27 +data DensityT k a where
  28 + DensityT :: (k b -> a) -> k b -> DensityT k a
  29 +
  30 +instance Functor (DensityT f) where
  31 + fmap f (DensityT g h) = DensityT (f . g) h
  32 +
  33 +instance Extend (DensityT f) where
  34 + duplicate (DensityT f ws) = DensityT (DensityT f) ws
  35 +
  36 +instance Comonad (DensityT f) where
  37 + extract (DensityT f a) = f a
  38 +
  39 +instance ComonadTrans DensityT where
  40 + lower (DensityT f c) = extend f c
  41 +
  42 +-- | The natural isomorphism between a comonad w and the comonad generated by w (forwards).
  43 +liftDensityT :: Comonad w => w a -> DensityT w a
  44 +liftDensityT = DensityT extract
  45 +
  46 +densityTToAdjunction :: Adjunction f g => DensityT f a -> f (g a)
  47 +densityTToAdjunction (DensityT f v) = fmap (leftAdjunct f) v
  48 +
  49 +adjunctionToDensityT :: Adjunction f g => f (g a) -> DensityT f a
  50 +adjunctionToDensityT = DensityT counit
62 Control/Monad/Codensity.hs
... ... @@ -0,0 +1,62 @@
  1 +{-# LANGUAGE Rank2Types #-}
  2 +-----------------------------------------------------------------------------
  3 +-- |
  4 +-- Module : Control.Monad.Codensity
  5 +-- Copyright : (C) 2008-2011 Edward Kmett
  6 +-- License : BSD-style (see the file LICENSE)
  7 +--
  8 +-- Maintainer : Edward Kmett <ekmett@gmail.com>
  9 +-- Stability : provisional
  10 +-- Portability : non-portable (rank-2 polymorphism)
  11 +--
  12 +----------------------------------------------------------------------------
  13 +module Control.Monad.Codensity
  14 + ( CodensityT(..)
  15 + , lowerCodensityT
  16 + , codensityTToAdjunction
  17 + , adjunctionToCodensityT
  18 + ) where
  19 +
  20 +import Control.Applicative
  21 +import Control.Monad (ap)
  22 +import Data.Functor.Adjunction
  23 +import Data.Functor.Apply
  24 +import Control.Monad.Trans.Class
  25 +import Control.Monad.IO.Class
  26 +
  27 +{-
  28 +type Codensity = CodensityT Identity
  29 +codensity :: (forall b. (a -> b) -> b) -> Codensity a
  30 +runCodensity :: Codensity a -> (a -> b) -> a
  31 +-}
  32 +
  33 +newtype CodensityT m a = CodensityT { runCodensityT :: forall b. (a -> m b) -> m b }
  34 +
  35 +instance Functor (CodensityT k) where
  36 + fmap f (CodensityT m) = CodensityT (\k -> m (k . f))
  37 +
  38 +instance Apply (CodensityT f) where
  39 + (<.>) = ap
  40 +
  41 +instance Applicative (CodensityT f) where
  42 + pure x = CodensityT (\k -> k x)
  43 + (<*>) = ap
  44 +
  45 +instance Monad (CodensityT f) where
  46 + return x = CodensityT (\k -> k x)
  47 + m >>= k = CodensityT (\c -> runCodensityT m (\a -> runCodensityT (k a) c))
  48 +
  49 +instance MonadIO m => MonadIO (CodensityT m) where
  50 + liftIO = lift . liftIO
  51 +
  52 +instance MonadTrans CodensityT where
  53 + lift m = CodensityT (m >>=)
  54 +
  55 +lowerCodensityT :: Monad m => CodensityT m a -> m a
  56 +lowerCodensityT a = runCodensityT a return
  57 +
  58 +codensityTToAdjunction :: Adjunction f g => CodensityT g a -> g (f a)
  59 +codensityTToAdjunction r = runCodensityT r unit
  60 +
  61 +adjunctionToCodensityT :: Adjunction f g => g (f a) -> CodensityT g a
  62 +adjunctionToCodensityT f = CodensityT (\a -> fmap (rightAdjunct a) f)
81 Data/Functor/KanExtension.hs
... ... @@ -0,0 +1,81 @@
  1 +{-# LANGUAGE Rank2Types, GADTs #-}
  2 +-------------------------------------------------------------------------------------------
  3 +-- |
  4 +-- Module : Data.Functor.KanExtension
  5 +-- Copyright : 2008-2011 Edward Kmett
  6 +-- License : BSD
  7 +--
  8 +-- Maintainer : Edward Kmett <ekmett@gmail.com>
  9 +-- Stability : experimental
  10 +-- Portability : rank 2 types
  11 +--
  12 +-------------------------------------------------------------------------------------------
  13 +module Data.Functor.KanExtension where
  14 +
  15 +import Data.Functor.Identity
  16 +import Data.Functor.Adjunction
  17 +import Data.Functor.Composition
  18 +
  19 +newtype Ran g h a = Ran { runRan :: forall b. (a -> g b) -> h b }
  20 +
  21 +instance Functor (Ran g h) where
  22 + fmap f m = Ran (\k -> runRan m (k . f))
  23 +
  24 +-- | 'toRan' and 'fromRan' witness a higher kinded adjunction. from @(`'Compose'` g)@ to @'Ran' g@
  25 +toRan :: (Composition compose, Functor k) => (forall a. compose k g a -> h a) -> k b -> Ran g h b
  26 +toRan s t = Ran (s . compose . flip fmap t)
  27 +
  28 +fromRan :: Composition compose => (forall a. k a -> Ran g h a) -> compose k g b -> h b
  29 +fromRan s = flip runRan id . s . decompose
  30 +
  31 +composeRan :: Composition compose => Ran f (Ran g h) a -> Ran (compose f g) h a
  32 +composeRan r = Ran (\f -> runRan (runRan r (decompose . f)) id)
  33 +
  34 +decomposeRan :: (Composition compose, Functor f) => Ran (compose f g) h a -> Ran f (Ran g h) a
  35 +decomposeRan r = Ran (\f -> Ran (\g -> runRan r (compose . fmap g . f)))
  36 +
  37 +adjointToRan :: Adjunction f g => f a -> Ran g Identity a
  38 +adjointToRan f = Ran (\a -> Identity $ rightAdjunct a f)
  39 +
  40 +ranToAdjoint :: Adjunction f g => Ran g Identity a -> f a
  41 +ranToAdjoint r = runIdentity (runRan r unit)
  42 +
  43 +ranToComposedAdjoint :: (Composition compose, Adjunction f g) => Ran g h a -> compose h f a
  44 +ranToComposedAdjoint r = compose (runRan r unit)
  45 +
  46 +composedAdjointToRan :: (Composition compose, Adjunction f g, Functor h) => compose h f a -> Ran g h a
  47 +composedAdjointToRan f = Ran (\a -> fmap (rightAdjunct a) (decompose f))
  48 +
  49 +data Lan g h a where
  50 + Lan :: (g b -> a) -> h b -> Lan g h a
  51 +
  52 +-- 'fromLan' and 'toLan' witness a (higher kinded) adjunction between @'Lan' g@ and @(`Compose` g)@
  53 +toLan :: (Composition compose, Functor f) => (forall a. h a -> compose f g a) -> Lan g h b -> f b
  54 +toLan s (Lan f v) = fmap f . decompose $ s v
  55 +
  56 +fromLan :: (Composition compose) => (forall a. Lan g h a -> f a) -> h b -> compose f g b
  57 +fromLan s = compose . s . Lan id
  58 +
  59 +instance Functor (Lan f g) where
  60 + fmap f (Lan g h) = Lan (f . g) h
  61 +
  62 +adjointToLan :: Adjunction f g => g a -> Lan f Identity a
  63 +adjointToLan = Lan counit . Identity
  64 +
  65 +lanToAdjoint :: Adjunction f g => Lan f Identity a -> g a
  66 +lanToAdjoint (Lan f v) = leftAdjunct f (runIdentity v)
  67 +
  68 +-- | 'lanToComposedAdjoint' and 'composedAdjointToLan' witness the natural isomorphism between @Lan f h@ and @Compose h g@ given @f -| g@
  69 +lanToComposedAdjoint :: (Composition compose, Functor h, Adjunction f g) => Lan f h a -> compose h g a
  70 +lanToComposedAdjoint (Lan f v) = compose (fmap (leftAdjunct f) v)
  71 +
  72 +composedAdjointToLan :: Composition compose => Adjunction f g => compose h g a -> Lan f h a
  73 +composedAdjointToLan = Lan counit . decompose
  74 +
  75 +-- | 'composeLan' and 'decomposeLan' witness the natural isomorphism from @Lan f (Lan g h)@ and @Lan (f `o` g) h@
  76 +composeLan :: (Composition compose, Functor f) => Lan f (Lan g h) a -> Lan (compose f g) h a
  77 +composeLan (Lan f (Lan g h)) = Lan (f . fmap g . decompose) h
  78 +
  79 +decomposeLan :: Composition compose => Lan (compose f g) h a -> Lan f (Lan g h) a
  80 +decomposeLan (Lan f h) = Lan (f . compose) (Lan id h)
  81 +
205 Data/Functor/Yoneda.hs
... ... @@ -0,0 +1,205 @@
  1 +{-# LANGUAGE TypeFamilies, CPP, Rank2Types, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-}
  2 +-----------------------------------------------------------------------------
  3 +-- |
  4 +-- Module : Data.Functor.Yoneda
  5 +-- Copyright : (C) 2011 Edward Kmett
  6 +-- License : BSD-style (see the file LICENSE)
  7 +--
  8 +-- Maintainer : Edward Kmett <ekmett@gmail.com>
  9 +-- Stability : provisional
  10 +-- Portability : MPTCs, fundeps
  11 +--
  12 +----------------------------------------------------------------------------
  13 +
  14 +module Data.Functor.Yoneda
  15 + ( Yoneda
  16 + , yoneda
  17 + , runYoneda
  18 + , liftYoneda
  19 + , lowerYoneda
  20 + , YonedaT(..)
  21 + , liftYonedaT
  22 + , lowerYonedaT
  23 + , maxF, minF, maxM, minM
  24 + ) where
  25 +
  26 +import Control.Applicative
  27 +import Control.Monad (MonadPlus(..), liftM)
  28 +import Control.Monad.Fix
  29 +import Control.Monad.Representable
  30 +import Control.Monad.Trans.Class
  31 +import Control.Comonad
  32 +import Control.Comonad.Trans.Class
  33 +import Data.Distributive
  34 +import Data.Foldable
  35 +import Data.Function (on)
  36 +import Data.Functor.Plus
  37 +import Data.Functor.Identity
  38 +import Data.Functor.Bind
  39 +import Data.Functor.Adjunction
  40 +import Data.Key
  41 +-- import Data.Semigroup
  42 +import Data.Semigroup.Foldable
  43 +import Data.Semigroup.Traversable
  44 +import Data.Traversable
  45 +import Text.Read hiding (lift)
  46 +import Prelude hiding (sequence, lookup)
  47 +
  48 +type Yoneda = YonedaT Identity
  49 +
  50 +yoneda :: (forall b. (a -> b) -> b) -> Yoneda a
  51 +yoneda f = YonedaT (Identity . f)
  52 +{-# INLINE yoneda #-}
  53 +
  54 +runYoneda :: Yoneda a -> (a -> b) -> b
  55 +runYoneda (YonedaT f) = runIdentity . f
  56 +{-# INLINE runYoneda #-}
  57 +
  58 +liftYoneda :: a -> Yoneda a
  59 +liftYoneda a = YonedaT (\f -> Identity (f a))
  60 +{-# INLINE liftYoneda #-}
  61 +
  62 +lowerYoneda :: Yoneda a -> a
  63 +lowerYoneda m = runIdentity (runYonedaT m id)
  64 +{-# INLINE lowerYoneda #-}
  65 +
  66 +newtype YonedaT f a = YonedaT { runYonedaT :: forall b. (a -> b) -> f b }
  67 +
  68 +liftYonedaT :: Functor f => f a -> YonedaT f a
  69 +liftYonedaT a = YonedaT (\f -> fmap f a)
  70 +
  71 +lowerYonedaT :: YonedaT f a -> f a
  72 +lowerYonedaT (YonedaT f) = f id
  73 +
  74 +{-# RULES "lower/lift=id" liftYonedaT . lowerYonedaT = id #-}
  75 +{-# RULES "lift/lower=id" lowerYonedaT . liftYonedaT = id #-}
  76 +
  77 +instance Functor (YonedaT f) where
  78 + fmap f m = YonedaT (\k -> runYonedaT m (k . f))
  79 +
  80 +type instance Key (YonedaT f) = Key f
  81 +
  82 +instance Keyed f => Keyed (YonedaT f) where
  83 + mapWithKey f = liftYonedaT . mapWithKey f . lowerYonedaT
  84 +
  85 +instance Apply f => Apply (YonedaT f) where
  86 + YonedaT m <.> YonedaT n = YonedaT (\f -> m (f .) <.> n id)
  87 +
  88 +instance Applicative f => Applicative (YonedaT f) where
  89 + pure a = YonedaT (\f -> pure (f a))
  90 + YonedaT m <*> YonedaT n = YonedaT (\f -> m (f .) <*> n id)
  91 +
  92 +instance Foldable f => Foldable (YonedaT f) where
  93 + foldMap f = foldMap f . lowerYonedaT
  94 +
  95 +instance Foldable1 f => Foldable1 (YonedaT f) where
  96 + foldMap1 f = foldMap1 f . lowerYonedaT
  97 +
  98 +instance FoldableWithKey f => FoldableWithKey (YonedaT f) where
  99 + foldMapWithKey f = foldMapWithKey f . lowerYonedaT
  100 +
  101 +instance FoldableWithKey1 f => FoldableWithKey1 (YonedaT f) where
  102 + foldMapWithKey1 f = foldMapWithKey1 f . lowerYonedaT
  103 +
  104 +instance Traversable f => Traversable (YonedaT f) where
  105 + traverse f = fmap liftYonedaT . traverse f . lowerYonedaT
  106 +
  107 +instance TraversableWithKey f => TraversableWithKey (YonedaT f) where
  108 + traverseWithKey f = fmap liftYonedaT . traverseWithKey f . lowerYonedaT
  109 +
  110 +instance Traversable1 f => Traversable1 (YonedaT f) where
  111 + traverse1 f = fmap liftYonedaT . traverse1 f . lowerYonedaT
  112 +
  113 +instance TraversableWithKey1 f => TraversableWithKey1 (YonedaT f) where
  114 + traverseWithKey1 f = fmap liftYonedaT . traverseWithKey1 f . lowerYonedaT
  115 +
  116 +instance Distributive f => Distributive (YonedaT f) where
  117 + collect f = liftYonedaT . collect (lowerYonedaT . f)
  118 +
  119 +instance Index f => Index (YonedaT f) where
  120 + index = index . lowerYonedaT
  121 +
  122 +instance Lookup f => Lookup (YonedaT f) where
  123 + lookup i = lookup i . lowerYonedaT
  124 +
  125 +instance Representable g => Representable (YonedaT g) where
  126 + tabulate = liftYonedaT . tabulate
  127 +
  128 +instance Adjunction f g => Adjunction (YonedaT f) (YonedaT g) where
  129 + unit = liftYonedaT . fmap liftYonedaT . unit
  130 + counit (YonedaT m) = counit (m lowerYonedaT)
  131 +
  132 +-- instance Show1 f => Show1 (YonedaT f) where
  133 +instance Show (f a) => Show (YonedaT f a) where
  134 + showsPrec d (YonedaT f) = showParen (d > 10) $
  135 + showString "liftYonedaT " . showsPrec 11 (f id)
  136 +
  137 +-- instance Read1 f => Read1 (YonedaT f) where
  138 +#ifdef __GLASGOW_HASKELL__
  139 +instance (Functor f, Read (f a)) => Read (YonedaT f a) where
  140 + readPrec = parens $ prec 10 $ do
  141 + Ident "liftYonedaT" <- lexP
  142 + liftYonedaT <$> step readPrec
  143 +#endif
  144 +
  145 +instance Eq (f a) => Eq (YonedaT f a) where
  146 + (==) = (==) `on` lowerYonedaT
  147 +
  148 +instance Ord (f a) => Ord (YonedaT f a) where
  149 + compare = compare `on` lowerYonedaT
  150 +
  151 +maxF :: (Functor f, Ord (f a)) => YonedaT f a -> YonedaT f a -> YonedaT f a
  152 +YonedaT f `maxF` YonedaT g = liftYonedaT $ f id `max` g id
  153 +-- {-# RULES "max/maxF" max = maxF #-}
  154 +{-# INLINE maxF #-}
  155 +
  156 +minF :: (Functor f, Ord (f a)) => YonedaT f a -> YonedaT f a -> YonedaT f a
  157 +YonedaT f `minF` YonedaT g = liftYonedaT $ f id `max` g id
  158 +-- {-# RULES "min/minF" min = minF #-}
  159 +{-# INLINE minF #-}
  160 +
  161 +maxM :: (Monad m, Ord (m a)) => YonedaT m a -> YonedaT m a -> YonedaT m a
  162 +YonedaT f `maxM` YonedaT g = lift $ f id `max` g id
  163 +-- {-# RULES "max/maxM" max = maxM #-}
  164 +{-# INLINE maxM #-}
  165 +
  166 +minM :: (Monad m, Ord (m a)) => YonedaT m a -> YonedaT m a -> YonedaT m a
  167 +YonedaT f `minM` YonedaT g = lift $ f id `min` g id
  168 +-- {-# RULES "min/minM" min = minM #-}
  169 +{-# INLINE minM #-}
  170 +
  171 +instance Alt f => Alt (YonedaT f) where
  172 + YonedaT f <!> YonedaT g = YonedaT (\k -> f k <!> g k)
  173 +
  174 +instance Plus f => Plus (YonedaT f) where
  175 + zero = YonedaT $ const zero
  176 +
  177 +instance Alternative f => Alternative (YonedaT f) where
  178 + empty = YonedaT $ const empty
  179 + YonedaT f <|> YonedaT g = YonedaT (\k -> f k <|> g k)
  180 +
  181 +instance Bind m => Bind (YonedaT m) where
  182 + YonedaT m >>- k = YonedaT (\f -> m id >>- \a -> runYonedaT (k a) f)
  183 +
  184 +instance Monad m => Monad (YonedaT m) where
  185 + return a = YonedaT (\f -> return (f a))
  186 + YonedaT m >>= k = YonedaT (\f -> m id >>= \a -> runYonedaT (k a) f)
  187 +
  188 +instance MonadFix m => MonadFix (YonedaT m) where
  189 + mfix f = lift $ mfix (lowerYonedaT . f)
  190 +
  191 +instance MonadPlus m => MonadPlus (YonedaT m) where
  192 + mzero = YonedaT (const mzero)
  193 + YonedaT f `mplus` YonedaT g = YonedaT (\k -> f k `mplus` g k)
  194 +
  195 +instance MonadTrans YonedaT where
  196 + lift a = YonedaT (\f -> liftM f a)
  197 +
  198 +instance Extend w => Extend (YonedaT w) where
  199 + extend k (YonedaT m) = YonedaT (\f -> extend (f . k . liftYonedaT) (m id))
  200 +
  201 +instance Comonad w => Comonad (YonedaT w) where
  202 + extract = extract . lowerYonedaT
  203 +
  204 +instance ComonadTrans YonedaT where
  205 + lower = lowerYonedaT
169 Data/Functor/Yoneda/Contravariant.hs
... ... @@ -0,0 +1,169 @@
  1 +{-# LANGUAGE CPP, GADTs, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances, TypeFamilies #-}
  2 +-----------------------------------------------------------------------------
  3 +-- |
  4 +-- Module : Data.Functor.Yoneda.Contravariant
  5 +-- Copyright : (C) 2011 Edward Kmett
  6 +-- License : BSD-style (see the file LICENSE)
  7 +--
  8 +-- Maintainer : Edward Kmett <ekmett@gmail.com>
  9 +-- Stability : provisional
  10 +-- Portability : GADTs, MPTCs, fundeps
  11 +--
  12 +----------------------------------------------------------------------------
  13 +module Data.Functor.Yoneda.Contravariant
  14 + ( Yoneda
  15 + , yoneda
  16 + , liftYoneda
  17 + , lowerYoneda
  18 + , liftYonedaT
  19 + , lowerYonedaT
  20 + , lowerM
  21 + , YonedaT(..)
  22 + ) where
  23 +
  24 +import Control.Applicative
  25 +import Control.Monad (MonadPlus(..), liftM)
  26 +import Control.Monad.Fix
  27 +import Control.Monad.Representable
  28 +import Control.Monad.Trans.Class
  29 +import Control.Comonad
  30 +import Control.Comonad.Trans.Class
  31 +import Data.Distributive
  32 +import Data.Function (on)
  33 +import Data.Functor.Bind
  34 +import Data.Functor.Plus
  35 +import Data.Functor.Identity
  36 +import Data.Functor.Adjunction
  37 +import Data.Key
  38 +import Prelude hiding (sequence)
  39 +import Text.Read hiding (lift)
  40 +
  41 +type Yoneda = YonedaT Identity
  42 +
  43 +-- | The contravariant Yoneda lemma applied to a covariant functor
  44 +data YonedaT f a where
  45 + YonedaT :: (b -> a) -> f b -> YonedaT f a
  46 +
  47 +yoneda :: (b -> a) -> b -> Yoneda a
  48 +yoneda f = YonedaT f . Identity
  49 +
  50 +liftYoneda :: a -> Yoneda a
  51 +liftYoneda = YonedaT id . Identity
  52 +
  53 +lowerYoneda :: Yoneda a -> a
  54 +lowerYoneda (YonedaT f (Identity a)) = f a
  55 +
  56 +liftYonedaT :: f a -> YonedaT f a
  57 +liftYonedaT = YonedaT id
  58 +
  59 +lowerYonedaT :: Functor f => YonedaT f a -> f a
  60 +lowerYonedaT (YonedaT f m) = fmap f m
  61 +
  62 +lowerM :: Monad f => YonedaT f a -> f a
  63 +lowerM (YonedaT f m) = liftM f m
  64 +
  65 +instance Functor (YonedaT f) where
  66 + fmap f (YonedaT g v) = YonedaT (f . g) v
  67 +
  68 +type instance Key (YonedaT f) = Key f
  69 +
  70 +instance Keyed f => Keyed (YonedaT f) where
  71 + mapWithKey f (YonedaT k a) = YonedaT id $ mapWithKey (\x -> f x . k) a
  72 +
  73 +instance Apply f => Apply (YonedaT f) where
  74 + m <.> n = liftYonedaT $ lowerYonedaT m <.> lowerYonedaT n
  75 +
  76 +instance Applicative f => Applicative (YonedaT f) where
  77 + pure = liftYonedaT . pure
  78 + m <*> n = liftYonedaT $ lowerYonedaT m <*> lowerYonedaT n
  79 +
  80 +instance Alternative f => Alternative (YonedaT f) where
  81 + empty = liftYonedaT empty
  82 + m <|> n = liftYonedaT $ lowerYonedaT m <|> lowerYonedaT n
  83 +
  84 +instance Alt f => Alt (YonedaT f) where
  85 + m <!> n = liftYonedaT $ lowerYonedaT m <!> lowerYonedaT n
  86 +
  87 +instance Plus f => Plus (YonedaT f) where
  88 + zero = liftYonedaT zero
  89 +
  90 +instance Bind m => Bind (YonedaT m) where
  91 + YonedaT f v >>- k = liftYonedaT (v >>- lowerYonedaT . k . f)
  92 +
  93 +instance Monad m => Monad (YonedaT m) where
  94 + return = YonedaT id . return
  95 + YonedaT f v >>= k = lift (v >>= lowerM . k . f)
  96 +
  97 +instance MonadTrans YonedaT where
  98 + lift = YonedaT id
  99 +
  100 +instance MonadFix f => MonadFix (YonedaT f) where
  101 + mfix f = lift $ mfix (lowerM . f)
  102 +
  103 +instance MonadPlus f => MonadPlus (YonedaT f) where
  104 + mzero = lift mzero
  105 + m `mplus` n = lift $ lowerM m `mplus` lowerM n
  106 +
  107 +instance (Functor f, Index f) => Index (YonedaT f) where
  108 + index = index . lowerYonedaT
  109 +
  110 +instance Representable f => Representable (YonedaT f) where
  111 + tabulate = liftYonedaT . tabulate
  112 +
  113 +instance Extend w => Extend (YonedaT w) where
  114 + extend k (YonedaT f v) = YonedaT id $ extend (k . YonedaT f) v
  115 +
  116 +instance Comonad w => Comonad (YonedaT w) where
  117 + extract (YonedaT f v) = f (extract v)
  118 +
  119 +instance ComonadTrans YonedaT where
  120 + lower (YonedaT f a) = fmap f a
  121 +
  122 +instance Foldable f => Foldable (YonedaT f) where
  123 + foldMap f (YonedaT k a) = foldMap (f . k) a
  124 +
  125 +instance FoldableWithKey f => FoldableWithKey (YonedaT f) where
  126 + foldMapWithKey f (YonedaT k a) = foldMapWithKey (\x -> f x . k) a
  127 +
  128 +instance Foldable1 f => Foldable1 (YonedaT f) where
  129 + foldMap1 f (YonedaT k a) = foldMap1 (f . k) a
  130 +
  131 +instance FoldableWithKey1 f => FoldableWithKey1 (YonedaT f) where
  132 + foldMapWithKey1 f (YonedaT k a) = foldMapWithKey1 (\x -> f x . k) a
  133 +
  134 +instance Traversable f => Traversable (YonedaT f) where
  135 + traverse f (YonedaT k a) = YonedaT id <$> traverse (f . k) a
  136 +
  137 +instance Traversable1 f => Traversable1 (YonedaT f) where
  138 + traverse1 f (YonedaT k a) = YonedaT id <$> traverse1 (f . k) a
  139 +
  140 +instance TraversableWithKey f => TraversableWithKey (YonedaT f) where
  141 + traverseWithKey f (YonedaT k a) = YonedaT id <$> traverseWithKey (\x -> f x . k) a
  142 +
  143 +instance TraversableWithKey1 f => TraversableWithKey1 (YonedaT f) where
  144 + traverseWithKey1 f (YonedaT k a) = YonedaT id <$> traverseWithKey1 (\x -> f x . k) a
  145 +
  146 +instance Distributive f => Distributive (YonedaT f) where
  147 + collect f = liftYonedaT . collect (lowerYonedaT . f)
  148 +
  149 +instance (Functor f, Show (f a)) => Show (YonedaT f a) where
  150 + showsPrec d (YonedaT f a) = showParen (d > 10) $
  151 + showString "liftYonedaT " . showsPrec 11 (fmap f a)
  152 +
  153 +#ifdef __GLASGOW_HASKELL__
  154 +instance (Functor f, Read (f a)) => Read (YonedaT f a) where
  155 + readPrec = parens $ prec 10 $ do
  156 + Ident "liftYonedaT" <- lexP
  157 + liftYonedaT <$> step readPrec
  158 +#endif
  159 +
  160 +instance (Functor f, Eq (f a)) => Eq (YonedaT f a) where
  161 + (==) = (==) `on` lowerYonedaT
  162 +
  163 +instance (Functor f, Ord (f a)) => Ord (YonedaT f a) where
  164 + compare = compare `on` lowerYonedaT
  165 +
  166 +instance Adjunction f g => Adjunction (YonedaT f) (YonedaT g) where
  167 + unit = liftYonedaT . fmap liftYonedaT . unit
  168 + counit = counit . fmap lowerYonedaT . lowerYonedaT
  169 +
30 LICENSE
... ... @@ -0,0 +1,30 @@
  1 +Copyright 2011 Edward Kmett
  2 +
  3 +All rights reserved.
  4 +
  5 +Redistribution and use in source and binary forms, with or without
  6 +modification, are permitted provided that the following conditions
  7 +are met:
  8 +
  9 +1. Redistributions of source code must retain the above copyright
  10 + notice, this list of conditions and the following disclaimer.
  11 +
  12 +2. Redistributions in binary form must reproduce the above copyright
  13 + notice, this list of conditions and the following disclaimer in the
  14 + documentation and/or other materials provided with the distribution.
  15 +
  16 +3. Neither the name of the author nor the names of his contributors
  17 + may be used to endorse or promote products derived from this software
  18 + without specific prior written permission.
  19 +
  20 +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
  21 +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  22 +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  23 +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
  24 +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  25 +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  26 +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  27 +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  28 +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
  29 +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  30 +POSSIBILITY OF SUCH DAMAGE.
7 Setup.lhs
... ... @@ -0,0 +1,7 @@
  1 +#!/usr/bin/runhaskell
  2 +> module Main (main) where
  3 +
  4 +> import Distribution.Simple
  5 +
  6 +> main :: IO ()
  7 +> main = defaultMain
45 kan-extensions.cabal
... ... @@ -0,0 +1,45 @@
  1 +name: kan-extensions
  2 +category: Data Structures, Monads, Comonads, Functors
  3 +version: 0.1
  4 +license: BSD3
  5 +cabal-version: >= 1.6
  6 +license-file: LICENSE
  7 +author: Edward A. Kmett
  8 +maintainer: Edward A. Kmett <ekmett@gmail.com>
  9 +stability: provisional
  10 +homepage: http://github.com/ekmett/adjunctions/
  11 +copyright: Copyright (C) 2011 Edward A. Kmett
  12 +synopsis: Kan extensions, the Yoneda lemma, and (co)density (co)monads
  13 +description: Kan extensions, the Yoneda lemma, and (co)density (co)monads
  14 +build-type: Simple
  15 +
  16 +source-repository head
  17 + type: git
  18 + location: git://github.com/ekmett/adjunctions.git
  19 +
  20 +library
  21 + build-depends:
  22 + adjunctions >= 0.7 && < 0.8,
  23 + array >= 0.3.0.2 && < 0.4,
  24 + base >= 4 && < 4.4,
  25 + comonad >= 1.0 && < 1.1,
  26 + comonad-transformers >= 1.5.1 && < 1.6,
  27 + containers >= 0.4 && < 0.5,
  28 + contravariant >= 0.1.2 && < 0.2,
  29 + distributive >= 0.1.1 && < 0.2,
  30 + keys >= 0.1.0 && < 0.2,
  31 + mtl >= 2.0.1.0 && < 2.1,
  32 + representable-functors >= 0.1 && < 0.2,
  33 + semigroups >= 0.3.4 && < 0.4,
  34 + semigroupoids >= 1.1.1 && < 1.2.0,
  35 + transformers >= 0.2.0 && < 0.3
  36 +
  37 + exposed-modules:
  38 + Control.Comonad.Density
  39 + Control.Monad.Codensity
  40 + Data.Functor.KanExtension
  41 + Data.Functor.Yoneda
  42 + Data.Functor.Yoneda.Contravariant
  43 +
  44 + ghc-options: -Wall
  45 +

0 comments on commit e772b66

Please sign in to comment.
Something went wrong with that request. Please try again.