kan-extensions 2.7 → 3.0
raw patch · 15 files changed
+859/−850 lines, 15 filesdep ~adjunctionsdep ~comonaddep ~comonad-transformers
Dependency ranges changed: adjunctions, comonad, comonad-transformers, comonads-fd, free, keys, representable-functors, semigroupoids
Files
- Control/Comonad/Density.hs +0/−61
- Control/Monad/Co.hs +0/−139
- Control/Monad/Codensity.hs +0/−89
- Control/Monad/Free/Church.hs +0/−99
- Data/Functor/KanExtension.hs +0/−92
- Data/Functor/Yoneda.hs +0/−190
- Data/Functor/Yoneda/Contravariant.hs +0/−166
- kan-extensions.cabal +16/−14
- src/Control/Comonad/Density.hs +63/−0
- src/Control/Monad/Co.hs +140/−0
- src/Control/Monad/Codensity.hs +89/−0
- src/Control/Monad/Free/Church.hs +99/−0
- src/Data/Functor/KanExtension.hs +92/−0
- src/Data/Functor/Yoneda.hs +192/−0
- src/Data/Functor/Yoneda/Contravariant.hs +168/−0
− Control/Comonad/Density.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GADTs #-}--------------------------------------------------------------------------------- |--- Module : Control.Comonad.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 density comonad for a functor. aka the comonad generated by a functor--- The ''density'' 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.Density- ( Density(..)- , liftDensity- , densityToAdjunction, adjunctionToDensity- ) where--import Control.Applicative-import Control.Comonad-import Control.Comonad.Trans.Class-import Data.Functor.Apply-import Data.Functor.Adjunction--data Density k a where- Density :: (k b -> a) -> k b -> Density k a--instance Functor (Density f) where- fmap f (Density g h) = Density (f . g) h--instance Extend (Density f) where- duplicate (Density f ws) = Density (Density f) ws--instance Comonad (Density f) where- extract (Density f a) = f a--instance ComonadTrans Density where- lower (Density f c) = extend f c--instance Apply f => Apply (Density f) where- Density kxf x <.> Density kya y =- Density (\k -> kxf (fmap fst k) (kya (fmap snd k))) ((,) <$> x <.> y)--instance Applicative f => Applicative (Density f) where- pure a = Density (const a) (pure ())- Density kxf x <*> Density kya y =- Density (\k -> kxf (fmap fst k) (kya (fmap snd k))) (liftA2 (,) x y)---- | The natural isomorphism between a comonad w and the comonad generated by w (forwards).-liftDensity :: Comonad w => w a -> Density w a-liftDensity = Density extract--densityToAdjunction :: Adjunction f g => Density f a -> f (g a)-densityToAdjunction (Density f v) = fmap (leftAdjunct f) v--adjunctionToDensity :: Adjunction f g => f (g a) -> Density f a-adjunctionToDensity = Density counit
− Control/Monad/Co.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE Rank2Types- , FlexibleInstances- , FlexibleContexts- , UndecidableInstances- , MultiParamTypeClasses #-}--------------------------------------------------------------------------------- |--- Module : Control.Monad.Co--- Copyright : (C) 2011 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : non-portable (rank-2 polymorphism)------ Monads from Comonads------ http://comonad.com/reader/2011/monads-from-comonads/---------------------------------------------------------------------------------module Control.Monad.Co- (- -- * Monads from Comonads- Co, co, runCo- -- * Monad Transformers from Comonads- , CoT(..)- -- * Klesili from CoKleisli- , liftCoT0, lowerCoT0, lowerCo0- , liftCoT1, lowerCoT1, lowerCo1- , posW, peekW, peeksW- , askW, asksW, traceW- )where--import Control.Applicative-import Control.Comonad-import Control.Comonad.Env.Class as Env-import Control.Comonad.Traced.Class as Traced-import Control.Comonad.Store.Class-import Control.Monad.Trans.Class-import Control.Monad.IO.Class-import Control.Monad.Reader.Class as Reader-import Control.Monad.State.Class-import Control.Monad.Error.Class-import Control.Monad.Writer.Class as Writer-import Control.Monad.Identity-import Data.Functor.Bind-import Control.Concurrent.Speculation-import Control.Concurrent.Speculation.Class--instance Comonad w => MonadSpec (CoT w m) where- specByM f g a = CoT (\k -> specBy f g (extract k) a)- specByM' f g a = CoT (\k -> specBy' f g (extract k) a)--type Co w = CoT w Identity--co :: Functor w => (forall r. w (a -> r) -> r) -> Co w a-co f = CoT (Identity . f . fmap (fmap runIdentity))--runCo :: Functor w => Co w a -> w (a -> r) -> r-runCo m = runIdentity . runCoT m . fmap (fmap Identity)--newtype CoT w m a = CoT { runCoT :: forall r. w (a -> m r) -> m r }--instance Functor w => Functor (CoT w m) where- fmap f (CoT w) = CoT (w . fmap (. f))--instance Extend w => Apply (CoT w m) where- mf <.> ma = mf >>- \f -> fmap f ma--instance Extend w => Bind (CoT w m) where- CoT k >>- f = CoT (k . extend (\wa a -> runCoT (f a) wa))--instance Comonad w => Applicative (CoT w m) where- pure a = CoT (`extract` a)- mf <*> ma = mf >>= \f -> fmap f ma--instance Comonad w => Monad (CoT w m) where- return a = CoT (`extract` a)- CoT k >>= f = CoT (k . extend (\wa a -> runCoT (f a) wa))--instance Comonad w => MonadTrans (CoT w) where- lift m = CoT (extract . fmap (m >>=))--instance (Comonad w, MonadIO m) => MonadIO (CoT w m) where- liftIO = lift . liftIO--liftCoT0 :: Comonad w => (forall a. w a -> s) -> CoT w m s-liftCoT0 f = CoT (extract <*> f)--lowerCoT0 :: (Functor w, Monad m) => CoT w m s -> w a -> m s-lowerCoT0 m = runCoT m . (return <$)--lowerCo0 :: Functor w => Co w s -> w a -> s-lowerCo0 m = runIdentity . runCoT m . (return <$)--liftCoT1 :: (forall a. w a -> a) -> CoT w m ()-liftCoT1 f = CoT (`f` ())--lowerCoT1 :: (Functor w, Monad m) => CoT w m () -> w a -> m a-lowerCoT1 m = runCoT m . fmap (const . return)--lowerCo1 :: Functor w => Co w () -> w a -> a-lowerCo1 m = runIdentity . runCoT m . fmap (const . return)--posW :: (ComonadStore s w, Monad m) => CoT w m s-posW = liftCoT0 pos--peekW :: (ComonadStore s w, Monad m) => s -> CoT w m ()-peekW s = liftCoT1 (peek s)--peeksW :: (ComonadStore s w, Monad m) => (s -> s) -> CoT w m ()-peeksW f = liftCoT1 (peeks f)--askW :: (ComonadEnv e w, Monad m) => CoT w m e-askW = liftCoT0 (Env.ask)--asksW :: (ComonadEnv e w, Monad m) => (e -> a) -> CoT w m a-asksW f = liftCoT0 (Env.asks f)--traceW :: (ComonadTraced e w, Monad m) => e -> CoT w m ()-traceW e = liftCoT1 (Traced.trace e)--instance (Comonad w, MonadReader e m) => MonadReader e (CoT w m) where- ask = lift Reader.ask- local f m = CoT (local f . runCoT m)--instance (Comonad w, MonadState s m) => MonadState s (CoT w m) where- get = lift get- put = lift . put--instance (Comonad w, MonadWriter e m) => MonadWriter e (CoT w m) where- tell = lift . tell- pass m = CoT (pass . runCoT m . fmap aug) where- aug f (a,e) = liftM (\r -> (r,e)) (f a)- listen = error "Control.Monad.Co.listen: TODO"--instance (Comonad w, MonadError e m) => MonadError e (CoT w m) where- throwError = lift . throwError- catchError = error "Control.Monad.Co.catchError: TODO"
− Control/Monad/Codensity.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE Rank2Types, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module : Control.Monad.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.Codensity- ( Codensity(..)- , lowerCodensity- , codensityToAdjunction- , adjunctionToCodensity- , improve- ) where--import Control.Applicative-import Control.Monad.Reader.Class-import Control.Monad.State.Class-import Control.Monad.Free.Class-import Control.Monad.Free-import Control.Monad (ap, MonadPlus(..))-import Data.Functor.Adjunction-import Data.Functor.Apply-import Control.Monad.Trans.Class-import Control.Monad.IO.Class-import Control.Concurrent.Speculation-import Control.Concurrent.Speculation.Class--newtype Codensity m a = Codensity { runCodensity :: forall b. (a -> m b) -> m b }--instance MonadSpec (Codensity m) where- specByM f g a = Codensity $ \k -> specBy f g k a- specByM' f g a = Codensity $ \k -> specBy' f g k a--instance Functor (Codensity k) where- fmap f (Codensity m) = Codensity (\k -> m (k . f))--instance Apply (Codensity f) where- (<.>) = ap--instance Applicative (Codensity f) where- pure x = Codensity (\k -> k x)- (<*>) = ap--instance Monad (Codensity f) where- return x = Codensity (\k -> k x)- m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c))--instance MonadIO m => MonadIO (Codensity m) where- liftIO = lift . liftIO --instance MonadTrans Codensity where- lift m = Codensity (m >>=)--instance Alternative v => Alternative (Codensity v) where- empty = Codensity (\_ -> empty)- Codensity m <|> Codensity n = Codensity (\k -> m k <|> n k)--instance MonadPlus v => MonadPlus (Codensity v) where- mzero = Codensity (\_ -> mzero)- Codensity m `mplus` Codensity n = Codensity (\k -> m k `mplus` n k)--lowerCodensity :: Monad m => Codensity m a -> m a-lowerCodensity a = runCodensity a return--codensityToAdjunction :: Adjunction f g => Codensity g a -> g (f a)-codensityToAdjunction r = runCodensity r unit--adjunctionToCodensity :: Adjunction f g => g (f a) -> Codensity g a-adjunctionToCodensity f = Codensity (\a -> fmap (rightAdjunct a) f)--instance (Functor f, MonadFree f m) => MonadFree f (Codensity m) where- wrap t = Codensity (\h -> wrap (fmap (\p -> runCodensity p h) t))--instance MonadReader r m => MonadState r (Codensity m) where- get = Codensity (ask >>=)- put s = Codensity (\k -> local (const s) (k ()))---- | Right associate all binds in a computation that generates a free monad--- This can improve the asymptotic efficiency of the result, while preserving--- semantics.-improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a-improve m = lowerCodensity m-
− Control/Monad/Free/Church.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE Rank2Types, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module : Control.Monad.Free.Church--- Copyright : (C) 2011 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : non-portable (rank-2 polymorphism)------ Free Monads for Less------ http://comonad.com/reader/2011/free-monads-for-less-2/---------------------------------------------------------------------------------module Control.Monad.Free.Church- ( F(..)- , improve- , fromF- , toF- , liftF- , retract- ) where--import Control.Applicative-import Control.Monad-import Control.Monad.Free hiding (liftF, retract)-import Control.Monad.Reader.Class-import Control.Monad.Writer.Class-import Control.Monad.Cont.Class-import Control.Monad.Trans.Class-import Control.Monad.State.Class-import Control.Concurrent.Speculation-import Control.Concurrent.Speculation.Class--instance MonadSpec (F f) where- specByM f g a = F (\k _ -> specBy f g k a)- specByM' f g a = F (\k _ -> specBy' f g k a)--newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r }--instance Functor (F f) where- fmap f (F g) = F (\kp -> g (kp . f))--instance Applicative (F f) where- pure a = F (\kp _ -> kp a)- F f <*> F g = F (\kp kf -> f (\a -> g (\b -> kp (a b)) kf) kf)--instance Alternative f => Alternative (F f) where- empty = F (\_ kf -> kf empty)- F f <|> F g = F (\kp kf -> kf (pure (f kp kf) <|> pure (g kp kf)))--instance Monad (F f) where- return a = F (\kp _ -> kp a)- F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf)--instance MonadPlus f => MonadPlus (F f) where- mzero = F (\_ kf -> kf mzero)- F f `mplus` F g = F (\kp kf -> kf (return (f kp kf) `mplus` return (g kp kf)))--instance MonadTrans F where- lift f = F (\kp kf -> kf (liftM kp f))--instance Functor f => MonadFree f (F f) where- wrap f = F (\kp kf -> kf (fmap (\ (F m) -> m kp kf) f))--instance MonadState s m => MonadState s (F m) where- get = lift get- put = lift . put--instance MonadReader e m => MonadReader e (F m) where- ask = lift ask - local f = lift . local f . retract--instance MonadWriter w m => MonadWriter w (F m) where- tell = lift . tell- pass = lift . pass . retract- listen = lift . listen . retract--instance MonadCont m => MonadCont (F m) where- callCC f = lift $ callCC (retract . f . fmap lift)--liftF :: Functor f => f a -> F f a-liftF f = F (\kp kf -> kf (fmap kp f))--retract :: Monad m => F m a -> m a-retract (F m) = m return join--fromF :: MonadFree f m => F f a -> m a-fromF (F m) = m return wrap--toF :: Functor f => Free f a -> F f a-toF xs = F (\kp kf -> go kp kf xs) where- go kp _ (Pure a) = kp a- go kp kf (Free fma) = kf (fmap (go kp kf) fma)--improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a-improve m = fromF m
− Data/Functor/KanExtension.hs
@@ -1,92 +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-import Data.Functor.Apply-import Control.Applicative--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--instance (Functor g, Apply h) => Apply (Lan g h) where- Lan kxf x <.> Lan kya y =- Lan (\k -> kxf (fmap fst k) (kya (fmap snd k))) ((,) <$> x <.> y)--instance (Functor g, Applicative h) => Applicative (Lan g h) where- pure a = Lan (const a) (pure ())- Lan kxf x <*> Lan kya y =- Lan (\k -> kxf (fmap fst k) (kya (fmap snd k))) (liftA2 (,) x y)--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,190 +0,0 @@-{-# LANGUAGE TypeFamilies, CPP, Rank2Types, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances, FlexibleInstances #-}--------------------------------------------------------------------------------- |--- 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(..)- , liftYoneda- , lowerYoneda- , maxF, minF, maxM, minM- ) where--import Control.Applicative-import Control.Monad (MonadPlus(..), liftM)-import Control.Monad.Fix-import Control.Monad.Free.Class-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.Plus-import Data.Functor.Bind-import Data.Functor.Adjunction-import Data.Functor.Representable-import Data.Key-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.Traversable-import Text.Read hiding (lift)-import Prelude hiding (sequence, lookup, zipWith)--newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b } --liftYoneda :: Functor f => f a -> Yoneda f a -liftYoneda a = Yoneda (\f -> fmap f a)--lowerYoneda :: Yoneda f a -> f a -lowerYoneda (Yoneda f) = f id--{-# RULES "lower/lift=id" liftYoneda . lowerYoneda = id #-}-{-# RULES "lift/lower=id" lowerYoneda . liftYoneda = id #-}--instance Functor (Yoneda f) where- fmap f m = Yoneda (\k -> runYoneda m (k . f))--type instance Key (Yoneda f) = Key f--instance Keyed f => Keyed (Yoneda f) where- mapWithKey f = liftYoneda . mapWithKey f . lowerYoneda --instance Apply f => Apply (Yoneda f) where- Yoneda m <.> Yoneda n = Yoneda (\f -> m (f .) <.> n id)- -instance Applicative f => Applicative (Yoneda f) where- pure a = Yoneda (\f -> pure (f a))- Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)--instance Zip f => Zip (Yoneda f) where- zipWith f (Yoneda m) (Yoneda n) = liftYoneda $ zipWith f (m id) (n id)--instance ZipWithKey f => ZipWithKey (Yoneda f) where- zipWithKey f (Yoneda m) (Yoneda n) = liftYoneda $ zipWithKey f (m id) (n id)--instance Foldable f => Foldable (Yoneda f) where- foldMap f = foldMap f . lowerYoneda--instance Foldable1 f => Foldable1 (Yoneda f) where- foldMap1 f = foldMap1 f . lowerYoneda--instance FoldableWithKey f => FoldableWithKey (Yoneda f) where- foldMapWithKey f = foldMapWithKey f . lowerYoneda--instance FoldableWithKey1 f => FoldableWithKey1 (Yoneda f) where- foldMapWithKey1 f = foldMapWithKey1 f . lowerYoneda--instance Traversable f => Traversable (Yoneda f) where- traverse f = fmap liftYoneda . traverse f . lowerYoneda--instance TraversableWithKey f => TraversableWithKey (Yoneda f) where- traverseWithKey f = fmap liftYoneda . traverseWithKey f . lowerYoneda--instance Traversable1 f => Traversable1 (Yoneda f) where- traverse1 f = fmap liftYoneda . traverse1 f . lowerYoneda--instance TraversableWithKey1 f => TraversableWithKey1 (Yoneda f) where- traverseWithKey1 f = fmap liftYoneda . traverseWithKey1 f . lowerYoneda--instance Distributive f => Distributive (Yoneda f) where- collect f = liftYoneda . collect (lowerYoneda . f)--instance Indexable f => Indexable (Yoneda f) where- index = index . lowerYoneda--instance Lookup f => Lookup (Yoneda f) where- lookup i = lookup i . lowerYoneda--instance Representable g => Representable (Yoneda g) where- tabulate = liftYoneda . tabulate--instance Adjunction f g => Adjunction (Yoneda f) (Yoneda g) where- unit = liftYoneda . fmap liftYoneda . unit- counit (Yoneda m) = counit (m lowerYoneda)---- instance Show1 f => Show1 (Yoneda f) where-instance Show (f a) => Show (Yoneda f a) where- showsPrec d (Yoneda f) = showParen (d > 10) $- showString "liftYoneda " . showsPrec 11 (f id)---- instance Read1 f => Read1 (Yoneda f) where-#ifdef __GLASGOW_HASKELL__-instance (Functor f, Read (f a)) => Read (Yoneda f a) where- readPrec = parens $ prec 10 $ do- Ident "liftYoneda" <- lexP- liftYoneda <$> step readPrec-#endif--instance Eq (f a) => Eq (Yoneda f a) where- (==) = (==) `on` lowerYoneda--instance Ord (f a) => Ord (Yoneda f a) where- compare = compare `on` lowerYoneda--maxF :: (Functor f, Ord (f a)) => Yoneda f a -> Yoneda f a -> Yoneda f a-Yoneda f `maxF` Yoneda g = liftYoneda $ f id `max` g id--- {-# RULES "max/maxF" max = maxF #-}-{-# INLINE maxF #-}--minF :: (Functor f, Ord (f a)) => Yoneda f a -> Yoneda f a -> Yoneda f a-Yoneda f `minF` Yoneda g = liftYoneda $ f id `max` g id--- {-# RULES "min/minF" min = minF #-}-{-# INLINE minF #-}--maxM :: (Monad m, Ord (m a)) => Yoneda m a -> Yoneda m a -> Yoneda m a-Yoneda f `maxM` Yoneda g = lift $ f id `max` g id--- {-# RULES "max/maxM" max = maxM #-}-{-# INLINE maxM #-}--minM :: (Monad m, Ord (m a)) => Yoneda m a -> Yoneda m a -> Yoneda m a-Yoneda f `minM` Yoneda g = lift $ f id `min` g id--- {-# RULES "min/minM" min = minM #-}-{-# INLINE minM #-}--instance Alt f => Alt (Yoneda f) where- Yoneda f <!> Yoneda g = Yoneda (\k -> f k <!> g k)--instance Plus f => Plus (Yoneda f) where- zero = Yoneda $ const zero--instance Alternative f => Alternative (Yoneda f) where- empty = Yoneda $ const empty- Yoneda f <|> Yoneda g = Yoneda (\k -> f k <|> g k)--instance Bind m => Bind (Yoneda m) where- Yoneda m >>- k = Yoneda (\f -> m id >>- \a -> runYoneda (k a) f)- -instance Monad m => Monad (Yoneda m) where- return a = Yoneda (\f -> return (f a))- Yoneda m >>= k = Yoneda (\f -> m id >>= \a -> runYoneda (k a) f)--instance MonadFix m => MonadFix (Yoneda m) where- mfix f = lift $ mfix (lowerYoneda . f)--instance MonadPlus m => MonadPlus (Yoneda m) where- mzero = Yoneda (const mzero)- Yoneda f `mplus` Yoneda g = Yoneda (\k -> f k `mplus` g k)--instance MonadTrans Yoneda where- lift a = Yoneda (\f -> liftM f a)--instance (Functor f, MonadFree f m) => MonadFree f (Yoneda m) where- wrap = lift . wrap . fmap lowerYoneda--instance Extend w => Extend (Yoneda w) where- extend k (Yoneda m) = Yoneda (\f -> extend (f . k . liftYoneda) (m id))--instance Comonad w => Comonad (Yoneda w) where- extract = extract . lowerYoneda --instance ComonadTrans Yoneda where- lower = lowerYoneda
− Data/Functor/Yoneda/Contravariant.hs
@@ -1,166 +0,0 @@-{-# LANGUAGE CPP, GADTs, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances, TypeFamilies #-}--------------------------------------------------------------------------------- |--- 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(..)- , liftYoneda- , lowerYoneda- , lowerM- ) 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.Function (on)-import Data.Functor.Bind-import Data.Functor.Plus-import Data.Functor.Adjunction-import Data.Functor.Representable-import Data.Key-import Data.Foldable-import Data.Traversable-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Prelude hiding (sequence, lookup, zipWith)-import Text.Read hiding (lift)---- | The contravariant Yoneda lemma applied to a covariant functor-data Yoneda f a where- Yoneda :: (b -> a) -> f b -> Yoneda f a--liftYoneda :: f a -> Yoneda f a -liftYoneda = Yoneda id--lowerYoneda :: Functor f => Yoneda f a -> f a-lowerYoneda (Yoneda f m) = fmap f m--lowerM :: Monad f => Yoneda f a -> f a -lowerM (Yoneda f m) = liftM f m--instance Functor (Yoneda f) where- fmap f (Yoneda g v) = Yoneda (f . g) v--type instance Key (Yoneda f) = Key f--instance Keyed f => Keyed (Yoneda f) where- mapWithKey f (Yoneda k a) = Yoneda id $ mapWithKey (\x -> f x . k) a--instance Apply f => Apply (Yoneda f) where- m <.> n = liftYoneda $ lowerYoneda m <.> lowerYoneda n--instance Applicative f => Applicative (Yoneda f) where- pure = liftYoneda . pure- m <*> n = liftYoneda $ lowerYoneda m <*> lowerYoneda n--instance Zip f => Zip (Yoneda f) where- zipWith f m n = liftYoneda $ zipWith f (lowerYoneda m) (lowerYoneda n)--instance ZipWithKey f => ZipWithKey (Yoneda f) where- zipWithKey f m n = liftYoneda $ zipWithKey f (lowerYoneda m) (lowerYoneda n)--instance Alternative f => Alternative (Yoneda f) where- empty = liftYoneda empty - m <|> n = liftYoneda $ lowerYoneda m <|> lowerYoneda n--instance Alt f => Alt (Yoneda f) where- m <!> n = liftYoneda $ lowerYoneda m <!> lowerYoneda n--instance Plus f => Plus (Yoneda f) where- zero = liftYoneda zero--instance Bind m => Bind (Yoneda m) where- Yoneda f v >>- k = liftYoneda (v >>- lowerYoneda . k . f)--instance Monad m => Monad (Yoneda m) where- return = Yoneda id . return- Yoneda f v >>= k = lift (v >>= lowerM . k . f)--instance MonadTrans Yoneda where- lift = Yoneda id--instance MonadFix f => MonadFix (Yoneda f) where- mfix f = lift $ mfix (lowerM . f)--instance MonadPlus f => MonadPlus (Yoneda f) where- mzero = lift mzero- m `mplus` n = lift $ lowerM m `mplus` lowerM n--instance (Functor f, Lookup f) => Lookup (Yoneda f) where- lookup k f = lookup k (lowerYoneda f)--instance (Functor f, Indexable f) => Indexable (Yoneda f) where- index = index . lowerYoneda--instance Representable f => Representable (Yoneda f) where- tabulate = liftYoneda . tabulate--instance Extend w => Extend (Yoneda w) where- extend k (Yoneda f v) = Yoneda id $ extend (k . Yoneda f) v--instance Comonad w => Comonad (Yoneda w) where- extract (Yoneda f v) = f (extract v)--instance ComonadTrans Yoneda where- lower (Yoneda f a) = fmap f a--instance Foldable f => Foldable (Yoneda f) where- foldMap f (Yoneda k a) = foldMap (f . k) a--instance FoldableWithKey f => FoldableWithKey (Yoneda f) where- foldMapWithKey f (Yoneda k a) = foldMapWithKey (\x -> f x . k) a--instance Foldable1 f => Foldable1 (Yoneda f) where- foldMap1 f (Yoneda k a) = foldMap1 (f . k) a--instance FoldableWithKey1 f => FoldableWithKey1 (Yoneda f) where- foldMapWithKey1 f (Yoneda k a) = foldMapWithKey1 (\x -> f x . k) a--instance Traversable f => Traversable (Yoneda f) where- traverse f (Yoneda k a) = Yoneda id <$> traverse (f . k) a--instance Traversable1 f => Traversable1 (Yoneda f) where- traverse1 f (Yoneda k a) = Yoneda id <$> traverse1 (f . k) a--instance TraversableWithKey f => TraversableWithKey (Yoneda f) where- traverseWithKey f (Yoneda k a) = Yoneda id <$> traverseWithKey (\x -> f x . k) a--instance TraversableWithKey1 f => TraversableWithKey1 (Yoneda f) where- traverseWithKey1 f (Yoneda k a) = Yoneda id <$> traverseWithKey1 (\x -> f x . k) a--instance Distributive f => Distributive (Yoneda f) where- collect f = liftYoneda . collect (lowerYoneda . f)--instance (Functor f, Show (f a)) => Show (Yoneda f a) where- showsPrec d (Yoneda f a) = showParen (d > 10) $- showString "liftYoneda " . showsPrec 11 (fmap f a)--#ifdef __GLASGOW_HASKELL__-instance (Functor f, Read (f a)) => Read (Yoneda f a) where- readPrec = parens $ prec 10 $ do- Ident "liftYoneda" <- lexP- liftYoneda <$> step readPrec-#endif--instance (Functor f, Eq (f a)) => Eq (Yoneda f a) where- (==) = (==) `on` lowerYoneda--instance (Functor f, Ord (f a)) => Ord (Yoneda f a) where- compare = compare `on` lowerYoneda--instance Adjunction f g => Adjunction (Yoneda f) (Yoneda g) where- unit = liftYoneda . fmap liftYoneda . unit- counit = counit . fmap lowerYoneda . lowerYoneda-
kan-extensions.cabal view
@@ -1,6 +1,6 @@ name: kan-extensions category: Data Structures, Monads, Comonads, Functors-version: 2.7+version: 3.0 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE@@ -9,7 +9,7 @@ stability: provisional homepage: http://github.com/ekmett/kan-extensions/ bug-reports: http://github.com/ekmett/kan-extensions/issues-copyright: Copyright (C) 2011 Edward A. Kmett+copyright: Copyright (C) 2011-2012 Edward A. Kmett synopsis: Kan extensions, the Yoneda lemma, and (co)density (co)monads description: Kan extensions, the Yoneda lemma, and (co)density (co)monads build-type: Simple@@ -21,6 +21,8 @@ location: git://github.com/ekmett/kan-extensions.git library+ hs-source-dirs: src+ other-extensions: CPP MultiParamTypeClasses@@ -32,22 +34,22 @@ TypeFamilies build-depends:+ adjunctions == 3.0.*, array >= 0.3.0.2 && < 0.5,- base >= 4 && < 5,- comonad >= 1.1.1.5 && < 1.2,+ base == 4.*,+ comonad == 3.0.*,+ comonad-transformers == 3.0.*,+ comonads-fd == 3.0.*, containers >= 0.4 && < 0.6,- transformers >= 0.2 && < 0.4,- mtl >= 2.0.1 && < 2.2,- semigroupoids >= 1.3.1.2 && < 1.4, contravariant >= 0.2.0.1 && < 0.3, distributive >= 0.2.2 && < 0.3,- comonad-transformers >= 2.1.1.1 && < 2.2,- comonads-fd >= 2.1.1.1 && < 2.2,- keys >= 2.2 && < 2.3,- free >= 2.2 && < 2.3,- adjunctions >= 2.5 && < 2.6,- representable-functors >= 2.5 && < 2.6,- speculation >= 1.4.1 && < 1.5+ free == 3.0.*,+ keys == 3.0.*,+ mtl >= 2.0.1 && < 2.2,+ representable-functors == 3.0.*,+ semigroupoids == 3.0.*,+ speculation >= 1.4.1 && < 1.5,+ transformers >= 0.2 && < 0.4 exposed-modules: Control.Comonad.Density
+ src/Control/Comonad/Density.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE MultiParamTypeClasses, GADTs #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Comonad.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 density comonad for a functor. aka the comonad generated by a functor+-- The ''density'' 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.Density+ ( Density(..)+ , liftDensity+ , densityToAdjunction, adjunctionToDensity+ ) where++import Control.Applicative+import Control.Comonad+import Control.Comonad.Trans.Class+import Data.Functor.Apply+import Data.Functor.Adjunction+import Data.Functor.Extend++data Density k a where+ Density :: (k b -> a) -> k b -> Density k a++instance Functor (Density f) where+ fmap f (Density g h) = Density (f . g) h++instance Extend (Density f) where+ duplicated (Density f ws) = Density (Density f) ws++instance Comonad (Density f) where+ duplicate (Density f ws) = Density (Density f) ws+ extract (Density f a) = f a++instance ComonadTrans Density where+ lower (Density f c) = extend f c++instance Apply f => Apply (Density f) where+ Density kxf x <.> Density kya y =+ Density (\k -> kxf (fmap fst k) (kya (fmap snd k))) ((,) <$> x <.> y)++instance Applicative f => Applicative (Density f) where+ pure a = Density (const a) (pure ())+ Density kxf x <*> Density kya y =+ Density (\k -> kxf (fmap fst k) (kya (fmap snd k))) (liftA2 (,) x y)++-- | The natural isomorphism between a comonad w and the comonad generated by w (forwards).+liftDensity :: Comonad w => w a -> Density w a+liftDensity = Density extract++densityToAdjunction :: Adjunction f g => Density f a -> f (g a)+densityToAdjunction (Density f v) = fmap (leftAdjunct f) v++adjunctionToDensity :: Adjunction f g => f (g a) -> Density f a+adjunctionToDensity = Density counit
+ src/Control/Monad/Co.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Co+-- Copyright : (C) 2011 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : non-portable (rank-2 polymorphism)+--+-- Monads from Comonads+--+-- http://comonad.com/reader/2011/monads-from-comonads/+--+----------------------------------------------------------------------------+module Control.Monad.Co+ (+ -- * Monads from Comonads+ Co, co, runCo+ -- * Monad Transformers from Comonads+ , CoT(..)+ -- * Klesili from CoKleisli+ , liftCoT0, lowerCoT0, lowerCo0+ , liftCoT1, lowerCoT1, lowerCo1+ , posW, peekW, peeksW+ , askW, asksW, traceW+ )where++import Control.Applicative+import Control.Comonad+import Control.Comonad.Env.Class as Env+import Control.Comonad.Traced.Class as Traced+import Control.Comonad.Store.Class+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Control.Monad.Reader.Class as Reader+import Control.Monad.State.Class+import Control.Monad.Error.Class+import Control.Monad.Writer.Class as Writer+import Control.Monad.Identity+import Data.Functor.Bind+import Data.Functor.Extend+import Control.Concurrent.Speculation+import Control.Concurrent.Speculation.Class++instance Comonad w => MonadSpec (CoT w m) where+ specByM f g a = CoT (\k -> specBy f g (extract k) a)+ specByM' f g a = CoT (\k -> specBy' f g (extract k) a)++type Co w = CoT w Identity++co :: Functor w => (forall r. w (a -> r) -> r) -> Co w a+co f = CoT (Identity . f . fmap (fmap runIdentity))++runCo :: Functor w => Co w a -> w (a -> r) -> r+runCo m = runIdentity . runCoT m . fmap (fmap Identity)++newtype CoT w m a = CoT { runCoT :: forall r. w (a -> m r) -> m r }++instance Functor w => Functor (CoT w m) where+ fmap f (CoT w) = CoT (w . fmap (. f))++instance Extend w => Apply (CoT w m) where+ mf <.> ma = mf >>- \f -> fmap f ma++instance Extend w => Bind (CoT w m) where+ CoT k >>- f = CoT (k . extended (\wa a -> runCoT (f a) wa))++instance Comonad w => Applicative (CoT w m) where+ pure a = CoT (`extract` a)+ mf <*> ma = mf >>= \f -> fmap f ma++instance Comonad w => Monad (CoT w m) where+ return a = CoT (`extract` a)+ CoT k >>= f = CoT (k . extend (\wa a -> runCoT (f a) wa))++instance Comonad w => MonadTrans (CoT w) where+ lift m = CoT (extract . fmap (m >>=))++instance (Comonad w, MonadIO m) => MonadIO (CoT w m) where+ liftIO = lift . liftIO++liftCoT0 :: Comonad w => (forall a. w a -> s) -> CoT w m s+liftCoT0 f = CoT (extract <*> f)++lowerCoT0 :: (Functor w, Monad m) => CoT w m s -> w a -> m s+lowerCoT0 m = runCoT m . (return <$)++lowerCo0 :: Functor w => Co w s -> w a -> s+lowerCo0 m = runIdentity . runCoT m . (return <$)++liftCoT1 :: (forall a. w a -> a) -> CoT w m ()+liftCoT1 f = CoT (`f` ())++lowerCoT1 :: (Functor w, Monad m) => CoT w m () -> w a -> m a+lowerCoT1 m = runCoT m . fmap (const . return)++lowerCo1 :: Functor w => Co w () -> w a -> a+lowerCo1 m = runIdentity . runCoT m . fmap (const . return)++posW :: (ComonadStore s w, Monad m) => CoT w m s+posW = liftCoT0 pos++peekW :: (ComonadStore s w, Monad m) => s -> CoT w m ()+peekW s = liftCoT1 (peek s)++peeksW :: (ComonadStore s w, Monad m) => (s -> s) -> CoT w m ()+peeksW f = liftCoT1 (peeks f)++askW :: (ComonadEnv e w, Monad m) => CoT w m e+askW = liftCoT0 (Env.ask)++asksW :: (ComonadEnv e w, Monad m) => (e -> a) -> CoT w m a+asksW f = liftCoT0 (Env.asks f)++traceW :: (ComonadTraced e w, Monad m) => e -> CoT w m ()+traceW e = liftCoT1 (Traced.trace e)++instance (Comonad w, MonadReader e m) => MonadReader e (CoT w m) where+ ask = lift Reader.ask+ local f m = CoT (local f . runCoT m)++instance (Comonad w, MonadState s m) => MonadState s (CoT w m) where+ get = lift get+ put = lift . put++instance (Comonad w, MonadWriter e m) => MonadWriter e (CoT w m) where+ tell = lift . tell+ pass m = CoT (pass . runCoT m . fmap aug) where+ aug f (a,e) = liftM (\r -> (r,e)) (f a)+ listen = error "Control.Monad.Co.listen: TODO"++instance (Comonad w, MonadError e m) => MonadError e (CoT w m) where+ throwError = lift . throwError+ catchError = error "Control.Monad.Co.catchError: TODO"
+ src/Control/Monad/Codensity.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE Rank2Types, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.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.Codensity+ ( Codensity(..)+ , lowerCodensity+ , codensityToAdjunction+ , adjunctionToCodensity+ , improve+ ) where++import Control.Applicative+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Free.Class+import Control.Monad.Free+import Control.Monad (ap, MonadPlus(..))+import Data.Functor.Adjunction+import Data.Functor.Apply+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Control.Concurrent.Speculation+import Control.Concurrent.Speculation.Class++newtype Codensity m a = Codensity { runCodensity :: forall b. (a -> m b) -> m b }++instance MonadSpec (Codensity m) where+ specByM f g a = Codensity $ \k -> specBy f g k a+ specByM' f g a = Codensity $ \k -> specBy' f g k a++instance Functor (Codensity k) where+ fmap f (Codensity m) = Codensity (\k -> m (k . f))++instance Apply (Codensity f) where+ (<.>) = ap++instance Applicative (Codensity f) where+ pure x = Codensity (\k -> k x)+ (<*>) = ap++instance Monad (Codensity f) where+ return x = Codensity (\k -> k x)+ m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c))++instance MonadIO m => MonadIO (Codensity m) where+ liftIO = lift . liftIO ++instance MonadTrans Codensity where+ lift m = Codensity (m >>=)++instance Alternative v => Alternative (Codensity v) where+ empty = Codensity (\_ -> empty)+ Codensity m <|> Codensity n = Codensity (\k -> m k <|> n k)++instance MonadPlus v => MonadPlus (Codensity v) where+ mzero = Codensity (\_ -> mzero)+ Codensity m `mplus` Codensity n = Codensity (\k -> m k `mplus` n k)++lowerCodensity :: Monad m => Codensity m a -> m a+lowerCodensity a = runCodensity a return++codensityToAdjunction :: Adjunction f g => Codensity g a -> g (f a)+codensityToAdjunction r = runCodensity r unit++adjunctionToCodensity :: Adjunction f g => g (f a) -> Codensity g a+adjunctionToCodensity f = Codensity (\a -> fmap (rightAdjunct a) f)++instance (Functor f, MonadFree f m) => MonadFree f (Codensity m) where+ wrap t = Codensity (\h -> wrap (fmap (\p -> runCodensity p h) t))++instance MonadReader r m => MonadState r (Codensity m) where+ get = Codensity (ask >>=)+ put s = Codensity (\k -> local (const s) (k ()))++-- | Right associate all binds in a computation that generates a free monad+-- This can improve the asymptotic efficiency of the result, while preserving+-- semantics.+improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a+improve m = lowerCodensity m+
+ src/Control/Monad/Free/Church.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE Rank2Types, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Free.Church+-- Copyright : (C) 2011 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : non-portable (rank-2 polymorphism)+--+-- Free Monads for Less+--+-- http://comonad.com/reader/2011/free-monads-for-less-2/+--+----------------------------------------------------------------------------+module Control.Monad.Free.Church+ ( F(..)+ , improve+ , fromF+ , toF+ , liftF+ , retract+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Free hiding (liftF, retract)+import Control.Monad.Reader.Class+import Control.Monad.Writer.Class+import Control.Monad.Cont.Class+import Control.Monad.Trans.Class+import Control.Monad.State.Class+import Control.Concurrent.Speculation+import Control.Concurrent.Speculation.Class++instance MonadSpec (F f) where+ specByM f g a = F (\k _ -> specBy f g k a)+ specByM' f g a = F (\k _ -> specBy' f g k a)++newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r }++instance Functor (F f) where+ fmap f (F g) = F (\kp -> g (kp . f))++instance Applicative (F f) where+ pure a = F (\kp _ -> kp a)+ F f <*> F g = F (\kp kf -> f (\a -> g (\b -> kp (a b)) kf) kf)++instance Alternative f => Alternative (F f) where+ empty = F (\_ kf -> kf empty)+ F f <|> F g = F (\kp kf -> kf (pure (f kp kf) <|> pure (g kp kf)))++instance Monad (F f) where+ return a = F (\kp _ -> kp a)+ F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf)++instance MonadPlus f => MonadPlus (F f) where+ mzero = F (\_ kf -> kf mzero)+ F f `mplus` F g = F (\kp kf -> kf (return (f kp kf) `mplus` return (g kp kf)))++instance MonadTrans F where+ lift f = F (\kp kf -> kf (liftM kp f))++instance Functor f => MonadFree f (F f) where+ wrap f = F (\kp kf -> kf (fmap (\ (F m) -> m kp kf) f))++instance MonadState s m => MonadState s (F m) where+ get = lift get+ put = lift . put++instance MonadReader e m => MonadReader e (F m) where+ ask = lift ask + local f = lift . local f . retract++instance MonadWriter w m => MonadWriter w (F m) where+ tell = lift . tell+ pass = lift . pass . retract+ listen = lift . listen . retract++instance MonadCont m => MonadCont (F m) where+ callCC f = lift $ callCC (retract . f . fmap lift)++liftF :: Functor f => f a -> F f a+liftF f = F (\kp kf -> kf (fmap kp f))++retract :: Monad m => F m a -> m a+retract (F m) = m return join++fromF :: MonadFree f m => F f a -> m a+fromF (F m) = m return wrap++toF :: Functor f => Free f a -> F f a+toF xs = F (\kp kf -> go kp kf xs) where+ go kp _ (Pure a) = kp a+ go kp kf (Free fma) = kf (fmap (go kp kf) fma)++improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a+improve m = fromF m
+ src/Data/Functor/KanExtension.hs view
@@ -0,0 +1,92 @@+{-# 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+import Data.Functor.Apply+import Control.Applicative++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++instance (Functor g, Apply h) => Apply (Lan g h) where+ Lan kxf x <.> Lan kya y =+ Lan (\k -> kxf (fmap fst k) (kya (fmap snd k))) ((,) <$> x <.> y)++instance (Functor g, Applicative h) => Applicative (Lan g h) where+ pure a = Lan (const a) (pure ())+ Lan kxf x <*> Lan kya y =+ Lan (\k -> kxf (fmap fst k) (kya (fmap snd k))) (liftA2 (,) x y)++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)+
+ src/Data/Functor/Yoneda.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE TypeFamilies, CPP, Rank2Types, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances, FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- 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(..)+ , liftYoneda+ , lowerYoneda+ , maxF, minF, maxM, minM+ ) where++import Control.Applicative+import Control.Monad (MonadPlus(..), liftM)+import Control.Monad.Fix+import Control.Monad.Free.Class+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.Plus+import Data.Functor.Bind+import Data.Functor.Extend+import Data.Functor.Adjunction+import Data.Functor.Representable+import Data.Key+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Traversable+import Text.Read hiding (lift)+import Prelude hiding (sequence, lookup, zipWith)++newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }++liftYoneda :: Functor f => f a -> Yoneda f a+liftYoneda a = Yoneda (\f -> fmap f a)++lowerYoneda :: Yoneda f a -> f a+lowerYoneda (Yoneda f) = f id++{-# RULES "lower/lift=id" liftYoneda . lowerYoneda = id #-}+{-# RULES "lift/lower=id" lowerYoneda . liftYoneda = id #-}++instance Functor (Yoneda f) where+ fmap f m = Yoneda (\k -> runYoneda m (k . f))++type instance Key (Yoneda f) = Key f++instance Keyed f => Keyed (Yoneda f) where+ mapWithKey f = liftYoneda . mapWithKey f . lowerYoneda++instance Apply f => Apply (Yoneda f) where+ Yoneda m <.> Yoneda n = Yoneda (\f -> m (f .) <.> n id)++instance Applicative f => Applicative (Yoneda f) where+ pure a = Yoneda (\f -> pure (f a))+ Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)++instance Zip f => Zip (Yoneda f) where+ zipWith f (Yoneda m) (Yoneda n) = liftYoneda $ zipWith f (m id) (n id)++instance ZipWithKey f => ZipWithKey (Yoneda f) where+ zipWithKey f (Yoneda m) (Yoneda n) = liftYoneda $ zipWithKey f (m id) (n id)++instance Foldable f => Foldable (Yoneda f) where+ foldMap f = foldMap f . lowerYoneda++instance Foldable1 f => Foldable1 (Yoneda f) where+ foldMap1 f = foldMap1 f . lowerYoneda++instance FoldableWithKey f => FoldableWithKey (Yoneda f) where+ foldMapWithKey f = foldMapWithKey f . lowerYoneda++instance FoldableWithKey1 f => FoldableWithKey1 (Yoneda f) where+ foldMapWithKey1 f = foldMapWithKey1 f . lowerYoneda++instance Traversable f => Traversable (Yoneda f) where+ traverse f = fmap liftYoneda . traverse f . lowerYoneda++instance TraversableWithKey f => TraversableWithKey (Yoneda f) where+ traverseWithKey f = fmap liftYoneda . traverseWithKey f . lowerYoneda++instance Traversable1 f => Traversable1 (Yoneda f) where+ traverse1 f = fmap liftYoneda . traverse1 f . lowerYoneda++instance TraversableWithKey1 f => TraversableWithKey1 (Yoneda f) where+ traverseWithKey1 f = fmap liftYoneda . traverseWithKey1 f . lowerYoneda++instance Distributive f => Distributive (Yoneda f) where+ collect f = liftYoneda . collect (lowerYoneda . f)++instance Indexable f => Indexable (Yoneda f) where+ index = index . lowerYoneda++instance Lookup f => Lookup (Yoneda f) where+ lookup i = lookup i . lowerYoneda++instance Representable g => Representable (Yoneda g) where+ tabulate = liftYoneda . tabulate++instance Adjunction f g => Adjunction (Yoneda f) (Yoneda g) where+ unit = liftYoneda . fmap liftYoneda . unit+ counit (Yoneda m) = counit (m lowerYoneda)++-- instance Show1 f => Show1 (Yoneda f) where+instance Show (f a) => Show (Yoneda f a) where+ showsPrec d (Yoneda f) = showParen (d > 10) $+ showString "liftYoneda " . showsPrec 11 (f id)++-- instance Read1 f => Read1 (Yoneda f) where+#ifdef __GLASGOW_HASKELL__+instance (Functor f, Read (f a)) => Read (Yoneda f a) where+ readPrec = parens $ prec 10 $ do+ Ident "liftYoneda" <- lexP+ liftYoneda <$> step readPrec+#endif++instance Eq (f a) => Eq (Yoneda f a) where+ (==) = (==) `on` lowerYoneda++instance Ord (f a) => Ord (Yoneda f a) where+ compare = compare `on` lowerYoneda++maxF :: (Functor f, Ord (f a)) => Yoneda f a -> Yoneda f a -> Yoneda f a+Yoneda f `maxF` Yoneda g = liftYoneda $ f id `max` g id+-- {-# RULES "max/maxF" max = maxF #-}+{-# INLINE maxF #-}++minF :: (Functor f, Ord (f a)) => Yoneda f a -> Yoneda f a -> Yoneda f a+Yoneda f `minF` Yoneda g = liftYoneda $ f id `max` g id+-- {-# RULES "min/minF" min = minF #-}+{-# INLINE minF #-}++maxM :: (Monad m, Ord (m a)) => Yoneda m a -> Yoneda m a -> Yoneda m a+Yoneda f `maxM` Yoneda g = lift $ f id `max` g id+-- {-# RULES "max/maxM" max = maxM #-}+{-# INLINE maxM #-}++minM :: (Monad m, Ord (m a)) => Yoneda m a -> Yoneda m a -> Yoneda m a+Yoneda f `minM` Yoneda g = lift $ f id `min` g id+-- {-# RULES "min/minM" min = minM #-}+{-# INLINE minM #-}++instance Alt f => Alt (Yoneda f) where+ Yoneda f <!> Yoneda g = Yoneda (\k -> f k <!> g k)++instance Plus f => Plus (Yoneda f) where+ zero = Yoneda $ const zero++instance Alternative f => Alternative (Yoneda f) where+ empty = Yoneda $ const empty+ Yoneda f <|> Yoneda g = Yoneda (\k -> f k <|> g k)++instance Bind m => Bind (Yoneda m) where+ Yoneda m >>- k = Yoneda (\f -> m id >>- \a -> runYoneda (k a) f)++instance Monad m => Monad (Yoneda m) where+ return a = Yoneda (\f -> return (f a))+ Yoneda m >>= k = Yoneda (\f -> m id >>= \a -> runYoneda (k a) f)++instance MonadFix m => MonadFix (Yoneda m) where+ mfix f = lift $ mfix (lowerYoneda . f)++instance MonadPlus m => MonadPlus (Yoneda m) where+ mzero = Yoneda (const mzero)+ Yoneda f `mplus` Yoneda g = Yoneda (\k -> f k `mplus` g k)++instance MonadTrans Yoneda where+ lift a = Yoneda (\f -> liftM f a)++instance (Functor f, MonadFree f m) => MonadFree f (Yoneda m) where+ wrap = lift . wrap . fmap lowerYoneda++instance Extend w => Extend (Yoneda w) where+ extended k (Yoneda m) = Yoneda (\f -> extended (f . k . liftYoneda) (m id))++instance Comonad w => Comonad (Yoneda w) where+ extend k (Yoneda m) = Yoneda (\f -> extend (f . k . liftYoneda) (m id))+ extract = extract . lowerYoneda++instance ComonadTrans Yoneda where+ lower = lowerYoneda
+ src/Data/Functor/Yoneda/Contravariant.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE CPP, GADTs, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances, TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- 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(..)+ , liftYoneda+ , lowerYoneda+ , lowerM+ ) 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.Function (on)+import Data.Functor.Bind+import Data.Functor.Extend+import Data.Functor.Plus+import Data.Functor.Adjunction+import Data.Functor.Representable+import Data.Key+import Data.Foldable+import Data.Traversable+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Prelude hiding (sequence, lookup, zipWith)+import Text.Read hiding (lift)++-- | The contravariant Yoneda lemma applied to a covariant functor+data Yoneda f a where+ Yoneda :: (b -> a) -> f b -> Yoneda f a++liftYoneda :: f a -> Yoneda f a +liftYoneda = Yoneda id++lowerYoneda :: Functor f => Yoneda f a -> f a+lowerYoneda (Yoneda f m) = fmap f m++lowerM :: Monad f => Yoneda f a -> f a +lowerM (Yoneda f m) = liftM f m++instance Functor (Yoneda f) where+ fmap f (Yoneda g v) = Yoneda (f . g) v++type instance Key (Yoneda f) = Key f++instance Keyed f => Keyed (Yoneda f) where+ mapWithKey f (Yoneda k a) = Yoneda id $ mapWithKey (\x -> f x . k) a++instance Apply f => Apply (Yoneda f) where+ m <.> n = liftYoneda $ lowerYoneda m <.> lowerYoneda n++instance Applicative f => Applicative (Yoneda f) where+ pure = liftYoneda . pure+ m <*> n = liftYoneda $ lowerYoneda m <*> lowerYoneda n++instance Zip f => Zip (Yoneda f) where+ zipWith f m n = liftYoneda $ zipWith f (lowerYoneda m) (lowerYoneda n)++instance ZipWithKey f => ZipWithKey (Yoneda f) where+ zipWithKey f m n = liftYoneda $ zipWithKey f (lowerYoneda m) (lowerYoneda n)++instance Alternative f => Alternative (Yoneda f) where+ empty = liftYoneda empty + m <|> n = liftYoneda $ lowerYoneda m <|> lowerYoneda n++instance Alt f => Alt (Yoneda f) where+ m <!> n = liftYoneda $ lowerYoneda m <!> lowerYoneda n++instance Plus f => Plus (Yoneda f) where+ zero = liftYoneda zero++instance Bind m => Bind (Yoneda m) where+ Yoneda f v >>- k = liftYoneda (v >>- lowerYoneda . k . f)++instance Monad m => Monad (Yoneda m) where+ return = Yoneda id . return+ Yoneda f v >>= k = lift (v >>= lowerM . k . f)++instance MonadTrans Yoneda where+ lift = Yoneda id++instance MonadFix f => MonadFix (Yoneda f) where+ mfix f = lift $ mfix (lowerM . f)++instance MonadPlus f => MonadPlus (Yoneda f) where+ mzero = lift mzero+ m `mplus` n = lift $ lowerM m `mplus` lowerM n++instance (Functor f, Lookup f) => Lookup (Yoneda f) where+ lookup k f = lookup k (lowerYoneda f)++instance (Functor f, Indexable f) => Indexable (Yoneda f) where+ index = index . lowerYoneda++instance Representable f => Representable (Yoneda f) where+ tabulate = liftYoneda . tabulate++instance Extend w => Extend (Yoneda w) where+ extended k (Yoneda f v) = Yoneda id $ extended (k . Yoneda f) v++instance Comonad w => Comonad (Yoneda w) where+ extend k (Yoneda f v) = Yoneda id $ extend (k . Yoneda f) v+ extract (Yoneda f v) = f (extract v)++instance ComonadTrans Yoneda where+ lower (Yoneda f a) = fmap f a++instance Foldable f => Foldable (Yoneda f) where+ foldMap f (Yoneda k a) = foldMap (f . k) a++instance FoldableWithKey f => FoldableWithKey (Yoneda f) where+ foldMapWithKey f (Yoneda k a) = foldMapWithKey (\x -> f x . k) a++instance Foldable1 f => Foldable1 (Yoneda f) where+ foldMap1 f (Yoneda k a) = foldMap1 (f . k) a++instance FoldableWithKey1 f => FoldableWithKey1 (Yoneda f) where+ foldMapWithKey1 f (Yoneda k a) = foldMapWithKey1 (\x -> f x . k) a++instance Traversable f => Traversable (Yoneda f) where+ traverse f (Yoneda k a) = Yoneda id <$> traverse (f . k) a++instance Traversable1 f => Traversable1 (Yoneda f) where+ traverse1 f (Yoneda k a) = Yoneda id <$> traverse1 (f . k) a++instance TraversableWithKey f => TraversableWithKey (Yoneda f) where+ traverseWithKey f (Yoneda k a) = Yoneda id <$> traverseWithKey (\x -> f x . k) a++instance TraversableWithKey1 f => TraversableWithKey1 (Yoneda f) where+ traverseWithKey1 f (Yoneda k a) = Yoneda id <$> traverseWithKey1 (\x -> f x . k) a++instance Distributive f => Distributive (Yoneda f) where+ collect f = liftYoneda . collect (lowerYoneda . f)++instance (Functor f, Show (f a)) => Show (Yoneda f a) where+ showsPrec d (Yoneda f a) = showParen (d > 10) $+ showString "liftYoneda " . showsPrec 11 (fmap f a)++#ifdef __GLASGOW_HASKELL__+instance (Functor f, Read (f a)) => Read (Yoneda f a) where+ readPrec = parens $ prec 10 $ do+ Ident "liftYoneda" <- lexP+ liftYoneda <$> step readPrec+#endif++instance (Functor f, Eq (f a)) => Eq (Yoneda f a) where+ (==) = (==) `on` lowerYoneda++instance (Functor f, Ord (f a)) => Ord (Yoneda f a) where+ compare = compare `on` lowerYoneda++instance Adjunction f g => Adjunction (Yoneda f) (Yoneda g) where+ unit = liftYoneda . fmap liftYoneda . unit+ counit = counit . fmap lowerYoneda . lowerYoneda+