kan-extensions 3.7 → 5.2.8

raw patch · 22 files changed

Files

• .ghci +0/−1
• .gitignore +22/−0
• .travis.yml +0/−8
• CHANGELOG.markdown +124/−0
• LICENSE +1/−1
• README.markdown +1/−1
• kan-extensions.cabal +38/−28
• src/Control/Comonad/Density.hs +7/−6
• src/Control/Monad/Co.hs +37/−33
• src/Control/Monad/Codensity.hs +98/−46
• src/Data/Functor/Contravariant/Coyoneda.hs +17/−17
• src/Data/Functor/Contravariant/Day.hs +192/−0
• src/Data/Functor/Contravariant/Yoneda.hs +9/−17
• src/Data/Functor/Coyoneda.hs +95/−85
• src/Data/Functor/Day.hs +201/−0
• src/Data/Functor/Day/Curried.hs +140/−0
• src/Data/Functor/Invariant/Day.hs +150/−0
• src/Data/Functor/Kan/Lan.hs +6/−5
• src/Data/Functor/Kan/Lift.hs +0/−151
• src/Data/Functor/Kan/Ran.hs +17/−18
• src/Data/Functor/Kan/Rift.hs +0/−191
• src/Data/Functor/Yoneda.hs +72/−82

@@ -1,1 +0,0 @@-:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h

@@ -1,4 +1,5 @@ dist+dist-newstyle docs wiki TAGS@@ -11,3 +12,24 @@ *.hi *~ *#+.stack-work/+cabal-dev+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+.cabal-sandbox/+cabal.sandbox.config+*.prof+*.aux+*.hp+*.eventlog+cabal.project.local+cabal.project.local~+.HTF/+.ghc.environment.*+/default.nix+/shell.nix+/result

@@ -1,8 +0,0 @@-language: haskell-notifications:-  irc:-    channels:-      - "irc.freenode.org#haskell-lens"-    skip_join: true-    template:-      - "\x0313kan-extensions\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"

@@ -1,3 +1,127 @@+5.2.8 [2026.01.10]+------------------+* Add `MonadThrow` instance for `Codensity`.+* Remove unused `array`, `containers`, and `tagged` dependencies.++5.2.7 [2025.06.17]+------------------+* Make the implementations of `(.>)` and `(*>)` for `Data.Functor.Yoneda` more+  stack-efficient.++5.2.6 [2024.05.04]+------------------+* Drop support for GHC 8.2 and earlier.+* Generalize instances in `Control.Monad.Codensity` to be of the form:++  ```hs+  instance (f ~~ f', MonadFail f') => MonadFail (Codensity (f :: k -> TYPE rep))+  ```++  This avoids having to constrain `k ~ Type` and `rep ~ LiftedRep`, which could potentially harm type inference.+* Explicitly implement `liftA2` in the `Applicative` instance for `Data.Functor.Day.Curried`.+* Add an `Adjunction` instance for `Data.Functor.Day`.+* Add `Adjunction` and `Divisible` instances for `Data.Functor.Contravariant.Day`.+* Add an `Apply` instance for `Data.Functor.Day.Curried`.++5.2.5 [2022.06.26]+------------------+* Only require a `Functor` constraint in the `Eq` and `Ord` instances for+  `Coyoneda` when building against `transformers-0.4.*`.++5.2.4 [2022.05.07]+------------------+* Allow building with `transformers-0.6.*` and `mtl-2.3.*`.++5.2.3 [2021.07.27]+------------------+* Add `shift` and `reset` to `Control.Monad.Codensity`.++5.2.2 [2021.02.17]+------------------+* Add `hoistCoyoneda` to `Data.Functor.Contravariant.Coyoneda`.++5.2.1 [2020.10.01]+------------------+* Allow building with GHC 9.0.++5.2 [2018.07.03]+----------------+* Make `Codensity` levity polymorphic.+* Add the `Data.Functor.Invariant.Day` module, which combines the covariant and+  contravariant versions of `Day`. As a result, `kan-extensions` now depends on+  the `invariant` package.+* Add a `wrapCodensity` function.+* More efficient `Eq1`, `Ord1`, and `Adjunction` instances for `Coyoneda`.+* Add `INLINE` pragmas on more functions.+* Allow building with `containers-0.6`.++5.1 [2018.01.28]+----------------+* Make `Density`, `Codensity`, `Kan` and `Lan` polykinded.+* Add `Eq1`, `Ord1`, `Read1` and `Show1` instances for `Coyoneda` and `Yoneda`.+* Change contexts of `Eq` and `Ord` instances of `Coyoneda` and `Yoneda`+  (and the `Show` instance for `Coyoneda`) to require lifted class instances,+  e.g. `Eq1 f, Eq a`.+* Allow `free-5`.++5.0.2+-----+* Added `hoistCoyoneda`++5.0.1+-----+* Removed some redundant constraints++5+-----+* Move `Data.Functor.Kan.Rift` to `Data.Functor.Day.Curried`++4.2.3+-----+* Builds clean on GHC 7.10++4.2.2+-----+* `semigroupoids` 5 support++4.2.1+---+* Add `liftRift` and `lowerRift`++4.2+---+* Remove pointed dependency++4.1.1+---+* Added `Applicative` instance for `Day`+* Added `Typeable` instance for `Codensity`++4.1.0.1+----+* Added `tagged` dependency++4.1+---+* Moved co- and contra- variant `Day` convolution from `contravariant` to here. Day convolution is intimately connected to `Rift`.++4.0.3+-----+* Added `liftCoT0M`, `liftCoT1M`, `diter` and `dctrlM` for using `CoT w m` to model a state machine with states in `w` and effects in `m`.++4.0.2+-----+* Made fixes necessary to work around changes in `ImpredicativeTypes` for GHC 7.8.1rc2++4.0.1+-----+* Bug fix so we can compile on GHC 7.4++4.0+---+* Removed `keys` dependency+* Now compatible with `adjunctions` 4.0+ 3.7 --- * Moved all the `Yoneda` variants around again.

@@ -1,4 +1,4 @@-Copyright 2008-2013 Edward Kmett+Copyright 2008-2016 Edward Kmett  All rights reserved. 

@@ -1,7 +1,7 @@ kan-extensions ============== -[![Build Status](https://secure.travis-ci.org/ekmett/kan-extensions.png?branch=master)](http://travis-ci.org/ekmett/kan-extensions)+[![Hackage](https://img.shields.io/hackage/v/kan-extensions.svg)](https://hackage.haskell.org/package/kan-extensions) [![Build Status](https://github.com/ekmett/kan-extensions/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/kan-extensions/actions?query=workflow%3AHaskell-CI)  This package provides tools for working with various Kan extensions and Kan lifts in Haskell. 

@@ -1,30 +1,40 @@ name:          kan-extensions category:      Data Structures, Monads, Comonads, Functors-version:       3.7+version:       5.2.8 license:       BSD3-cabal-version: >= 1.6+cabal-version: >= 1.10 license-file:  LICENSE author:        Edward A. Kmett maintainer:    Edward A. Kmett <ekmett@gmail.com> stability:     provisional homepage:      http://github.com/ekmett/kan-extensions/ bug-reports:   http://github.com/ekmett/kan-extensions/issues-copyright:     Copyright (C) 2008-2013 Edward A. Kmett-synopsis:      Kan extensions, Kan lifts, various forms of the Yoneda lemma, and (co)density (co)monads-description:   Kan extensions, Kan lifts, various forms of the Yoneda lemma, and (co)density (co)monads+copyright:     Copyright (C) 2008-2016 Edward A. Kmett+synopsis:      Kan extensions, Kan lifts, the Yoneda lemma, and (co)density (co)monads+description:   Kan extensions, Kan lifts, various forms of the Yoneda lemma, and (co)density (co)monads. build-type:    Simple+tested-with:   GHC == 8.4.4+             , GHC == 8.6.5+             , GHC == 8.8.4+             , GHC == 8.10.7+             , GHC == 9.0.2+             , GHC == 9.2.8+             , GHC == 9.4.8+             , GHC == 9.6.7+             , GHC == 9.8.4+             , GHC == 9.10.3+             , GHC == 9.12.2+             , GHC == 9.14.1  extra-source-files:-  .travis.yml   .gitignore-  .ghci   .vim.custom   CHANGELOG.markdown   README.markdown  source-repository head   type: git-  location: git://github.com/ekmett/kan-extensions.git+  location: https://github.com/ekmett/kan-extensions.git  library   hs-source-dirs: src@@ -40,36 +50,36 @@     TypeFamilies    build-depends:-    adjunctions            >= 3.0.0.1 && < 4,-    array                  >= 0.3.0.2 && < 0.5,-    base                   >= 4       && < 5,-    comonad                >= 3       && < 4,-    comonad-transformers   >= 3       && < 4,-    comonads-fd            >= 3       && < 4,-    containers             >= 0.4     && < 0.6,-    contravariant          >= 0.2.0.1 && < 1,-    distributive           >= 0.2.2   && < 1,-    free                   >= 3       && < 4,-    keys                   >= 3       && < 4,-    mtl                    >= 2.0.1   && < 2.2,-    pointed                >= 3       && < 4,-    representable-functors >= 3.0.0.1 && < 4,-    semigroupoids          >= 3       && < 4,-    speculation            >= 1.4.1   && < 2,-    transformers           >= 0.2     && < 0.4+    adjunctions         >= 4.2     && < 5,+    base                >= 4.11    && < 5,+    comonad             >= 4       && < 6,+    contravariant       >= 1       && < 2,+    distributive        >= 0.2.2   && < 1,+    exceptions          >= 0.10    && < 0.11,+    invariant           >= 0.1     && < 1,+    free                >= 4       && < 6,+    mtl                 >= 2.2.1   && < 2.4,+    profunctors         >= 5       && < 6,+    semigroupoids       >= 5.2.2   && < 7,+    transformers        >= 0.5     && < 0.7    exposed-modules:     Control.Comonad.Density     Control.Monad.Co     Control.Monad.Codensity+    Data.Functor.Contravariant.Day     Data.Functor.Contravariant.Yoneda     Data.Functor.Contravariant.Coyoneda+    Data.Functor.Day+    Data.Functor.Day.Curried+    Data.Functor.Invariant.Day     Data.Functor.Kan.Lan-    Data.Functor.Kan.Lift     Data.Functor.Kan.Ran-    Data.Functor.Kan.Rift     Data.Functor.Yoneda     Data.Functor.Coyoneda -  ghc-options: -Wall+  ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wno-trustworthy-safe+  if !impl(ghc >= 8.8)+    ghc-options: -Wnoncanonical-monadfail-instances +  default-language: Haskell2010

@@ -1,12 +1,11 @@-{-# LANGUAGE MultiParamTypeClasses, GADTs #-} {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Comonad.Density--- Copyright   :  (C) 2008-2011 Edward Kmett+-- Copyright   :  (C) 2008-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -15,7 +14,7 @@ -- -- 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+-- 'Monad' generated by a 'Functor' dates back to 1972 in Street''s -- ''Formal Theory of Monads''. -- -- The left Kan extension of a 'Functor' along itself (@'Lan' f f@) forms a 'Comonad'. This is@@ -28,7 +27,9 @@   , densityToLan, lanToDensity   ) where +#if !(MIN_VERSION_base(4,18,0)) import Control.Applicative+#endif import Control.Comonad import Control.Comonad.Trans.Class import Data.Functor.Apply

@@ -3,16 +3,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-#ifndef MIN_VERSION_speculation-#define MIN_VERSION_speculation(x,y,z) 1-#endif+{-# LANGUAGE PolyKinds #-} ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2011 Edward Kmett+-- Copyright   :  (C) 2011-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -32,7 +26,7 @@ -- which is a 'Monad' in @Hask^op@ to a 'Monad' in 'Hask'. -- -- For any @r@, the 'Contravariant' functor / presheaf @(-> r)@ :: Hask^op -> Hask is adjoint to the \"same\"--- 'Contravariant' functor @(-> r) :: Hask -> Hask^op@. So we can sandwhich a+-- 'Contravariant' functor @(-> r) :: Hask -> Hask^op@. So we can sandwich a -- Monad in Hask^op in the middle to obtain @w (a -> r-) -> r+@, and then take a coend over -- @r@ to obtain @forall r. w (a -> r) -> r@. This gives rise to 'Co'. If we observe that -- we didn't care what the choices we made for @r@ were to finish this construction, we can@@ -50,35 +44,31 @@   -- * Monad Transformers from Comonads   , CoT(..)   -- * Klesili from CoKleisli-  , liftCoT0, lowerCoT0, lowerCo0-  , liftCoT1, lowerCoT1, lowerCo1+  , liftCoT0, liftCoT0M, lowerCoT0, lowerCo0+  , liftCoT1, liftCoT1M, lowerCoT1, lowerCo1+  , diter, dctrlM   , posW, peekW, peeksW   , askW, asksW, traceW   )where -import Control.Applicative import Control.Comonad+import Control.Comonad.Cofree+import Control.Comonad.Density 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.Comonad.Traced.Class as Traced+import Control.Monad ((<=<), liftM)+import Control.Monad.Error.Class+import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class+import Control.Monad.Identity (Identity(..)) import Control.Monad.Reader.Class as Reader import Control.Monad.State.Class-import Control.Monad.Error.Class+import Control.Monad.Trans.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)-#if !(MIN_VERSION_speculation(1,5,0))-  specByM' f g a = CoT (\k -> specBy' f g (extract k) a)-#endif- type Co w = CoT w Identity  co :: Functor w => (forall r. w (a -> r) -> r) -> Co w a@@ -89,8 +79,7 @@  -- | -- @--- 'CoT' w m a ~ 'Data.Functor.KanLift.Rift' w m a--- 'Co' w a ~ 'Data.Functor.KanLift.Rift' w 'Identity' a+-- 'Co' w a ~ 'Data.Functor.Kan.Rift.Rift' w 'Identity' a -- @ newtype CoT w m a = CoT { runCoT :: forall r. w (a -> m r) -> m r } @@ -108,9 +97,12 @@   mf <*> ma = mf >>= \f -> fmap f ma  instance Comonad w => Monad (CoT w m) where-  return a = CoT (`extract` a)+  return = pure   CoT k >>= f = CoT (k . extend (\wa a -> runCoT (f a) wa)) +instance (Comonad w, Fail.MonadFail m) => Fail.MonadFail (CoT w m) where+  fail msg = CoT $ \ _ -> Fail.fail msg+ instance Comonad w => MonadTrans (CoT w) where   lift m = CoT (extract . fmap (m >>=)) @@ -135,23 +127,35 @@ 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 :: ComonadStore s w => CoT w m s posW = liftCoT0 pos -peekW :: (ComonadStore s w, Monad m) => s -> CoT w m ()+peekW :: ComonadStore s w => s -> CoT w m () peekW s = liftCoT1 (peek s) -peeksW :: (ComonadStore s w, Monad m) => (s -> s) -> CoT w m ()+peeksW :: ComonadStore s w => (s -> s) -> CoT w m () peeksW f = liftCoT1 (peeks f) -askW :: (ComonadEnv e w, Monad m) => CoT w m e+askW :: ComonadEnv e w => CoT w m e askW = liftCoT0 (Env.ask) -asksW :: (ComonadEnv e w, Monad m) => (e -> a) -> CoT w m a+asksW :: ComonadEnv e w => (e -> a) -> CoT w m a asksW f = liftCoT0 (Env.asks f) -traceW :: (ComonadTraced e w, Monad m) => e -> CoT w m ()+traceW :: ComonadTraced e w => e -> CoT w m () traceW e = liftCoT1 (Traced.trace e)++liftCoT0M :: (Comonad w, Monad m) => (forall a. w a -> m s) -> CoT w m s+liftCoT0M f = CoT (\wa -> extract wa =<< f wa)++liftCoT1M :: Monad m => (forall a. w a -> m a) -> CoT w m ()+liftCoT1M f = CoT (($ ()) <=< f)++diter :: Functor f => a -> (a -> f a) -> Density (Cofree f) a+diter x y = liftDensity . coiter y $ x++dctrlM :: Monad m => (forall a. w a -> m (w a)) -> CoT (Density w) m ()+dctrlM k = liftCoT1M (\(Density w a) -> liftM w (k a))  instance (Comonad w, MonadReader e m) => MonadReader e (CoT w m) where   ask = lift Reader.ask

@@ -1,19 +1,21 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-} #endif -#ifndef MIN_VERSION_speculation-#define MIN_VERSION_speculation(x,y,z) 1-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Codensity--- Copyright   :  (C) 2008-2013 Edward Kmett+-- Copyright   :  (C) 2008-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -27,13 +29,17 @@   , codensityToAdjunction, adjunctionToCodensity   , codensityToRan, ranToCodensity   , codensityToComposedRep, composedRepToCodensity+  , wrapCodensity   , improve+  -- ** Delimited continuations+  , reset+  , shift   ) where  import Control.Applicative-import Control.Concurrent.Speculation-import Control.Concurrent.Speculation.Class-import Control.Monad (ap, MonadPlus(..))+import Control.Monad (MonadPlus(..))+import Control.Monad.Catch (MonadThrow(..))+import qualified Control.Monad.Fail as Fail import Control.Monad.Free import Control.Monad.IO.Class import Control.Monad.Reader.Class@@ -43,8 +49,9 @@ import Data.Functor.Apply import Data.Functor.Kan.Ran import Data.Functor.Plus-import Data.Functor.Representable-import Data.Key+import Data.Functor.Rep+import Data.Type.Equality (type (~~))+import GHC.Exts (TYPE)  -- | -- @'Codensity' f@ is the Monad generated by taking the right Kan extension@@ -54,42 +61,52 @@ -- repeated applications of @(>>=)@. -- -- See \"Asymptotic Improvement of Computations over Free Monads\" by Janis--- Voightländer for more information about this type.+-- Voigtländer for more information about this type. ----- <http://www.iai.uni-bonn.de/~jv/mpc08.pdf>-newtype Codensity m a = Codensity+-- <https://www.janis-voigtlaender.eu/papers/AsymptoticImprovementOfComputationsOverFreeMonads.pdf>+newtype Codensity (m :: k -> TYPE rep) a = Codensity+-- Note: we *could* generalize @a@ to @TYPE repa@, but the 'Functor'+-- instance wouldn't carry that, so it doesn't really seem worth+-- the complication.   { runCodensity :: forall b. (a -> m b) -> m b   } -instance MonadSpec (Codensity m) where-  specByM f g a = Codensity $ \k -> specBy f g k a-  {-# INLINE specByM #-}-#if !(MIN_VERSION_speculation(1,5,0))-  specByM' f g a = Codensity $ \k -> specBy' f g k a-  {-# INLINE specByM' #-}-#endif--instance Functor (Codensity k) where-  fmap f (Codensity m) = Codensity (\k -> m (k . f))+instance Functor (Codensity (k :: j -> TYPE rep)) where+  fmap f (Codensity m) = Codensity (\k -> m (\x -> k (f x)))   {-# INLINE fmap #-} -instance Apply (Codensity f) where-  (<.>) = ap+instance Apply (Codensity (f :: k -> TYPE rep)) where+  (<.>) = (<*>)   {-# INLINE (<.>) #-} -instance Applicative (Codensity f) where+instance Applicative (Codensity (f :: k -> TYPE rep)) where   pure x = Codensity (\k -> k x)   {-# INLINE pure #-}-  (<*>) = ap+  Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (\x -> bfr (ab x))))   {-# INLINE (<*>) #-} -instance Monad (Codensity f) where-  return x = Codensity (\k -> k x)+instance Monad (Codensity (f :: k -> TYPE rep)) where+  return = pure   {-# INLINE return #-}   m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c))   {-# INLINE (>>=) #-} -instance MonadIO m => MonadIO (Codensity m) where+-- Writing instances like+-- instance MonadFail f => MonadFail (Codensity f)+-- leads to some hidden flexible instances. Haddock will show things like+--+-- MonadFail f => MonadFail (Codensity * LiftedRep f)+--+-- Since FlexibleInstances are bad for inference, we avoid them when+-- we can by carefully pushing kind constraints to the left.++instance (f ~~ f', Fail.MonadFail f')+  => Fail.MonadFail (Codensity (f :: k -> TYPE rep)) where+  fail msg = Codensity $ \ _ -> Fail.fail msg+  {-# INLINE fail #-}++instance (m ~~ m', MonadIO m')+  => MonadIO (Codensity (m :: k -> TYPE rep)) where   liftIO = lift . liftIO   {-# INLINE liftIO #-} @@ -97,11 +114,12 @@   lift m = Codensity (m >>=)   {-# INLINE lift #-} -instance Alt v => Alt (Codensity v) where+instance (v ~~ v', Alt v')+  => Alt (Codensity (v :: k -> TYPE rep)) where   Codensity m <!> Codensity n = Codensity (\k -> m k <!> n k)   {-# INLINE (<!>) #-} -instance Plus v => Plus (Codensity v) where+instance (v ~~ v', Plus v') => Plus (Codensity (v :: k -> TYPE rep)) where   zero = Codensity (const zero)   {-# INLINE zero #-} @@ -115,24 +133,25 @@   mplus = (<!>) -} -instance Alternative v => Alternative (Codensity v) where+instance (v ~~ v', Alternative v')+  => Alternative (Codensity (v :: k -> TYPE rep)) where   empty = Codensity (\_ -> empty)   {-# INLINE empty #-}   Codensity m <|> Codensity n = Codensity (\k -> m k <|> n k)   {-# INLINE (<|>) #-} -instance MonadPlus v => MonadPlus (Codensity v) where-  mzero = Codensity (\_ -> mzero)-  {-# INLINE mzero #-}-  Codensity m `mplus` Codensity n = Codensity (\k -> m k `mplus` n k)-  {-# INLINE mplus #-}+instance (v ~~ v', Alternative v')+   => MonadPlus (Codensity (v :: k -> TYPE rep)) +instance MonadThrow m => MonadThrow (Codensity m) where+  throwM = lift . throwM+ -- | -- This serves as the *left*-inverse (retraction) of 'lift'. -- -- -- @--- 'lowerCodensity . lift' ≡ 'id'+-- 'lowerCodensity' . 'lift' ≡ 'id' -- @ -- -- In general this is not a full 2-sided inverse, merely a retraction, as@@ -141,8 +160,8 @@ -- e.g. @'Codensity' ((->) s)) a ~ forall r. (a -> s -> r) -> s -> r@ -- could support a full complement of @'MonadState' s@ actions, while @(->) s@ -- is limited to @'MonadReader' s@ actions.-lowerCodensity :: Monad m => Codensity m a -> m a-lowerCodensity a = runCodensity a return+lowerCodensity :: Applicative f => Codensity f a -> f a+lowerCodensity a = runCodensity a pure {-# INLINE lowerCodensity #-}  -- | The 'Codensity' monad of a right adjoint is isomorphic to the@@ -173,7 +192,7 @@ -- codensityToComposedRep = 'ranToComposedRep' . 'codensityToRan' -- @ -codensityToComposedRep :: Representable u => Codensity u a -> u (Key u, a)+codensityToComposedRep :: Representable u => Codensity u a -> u (Rep u, a) codensityToComposedRep (Codensity f) = f (\a -> tabulate $ \e -> (e, a)) {-# INLINE codensityToComposedRep #-} @@ -182,7 +201,7 @@ -- @ -- 'composedRepToCodensity' = 'ranToCodensity' . 'composedRepToRan' -- @-composedRepToCodensity :: Representable u => u (Key u, a) -> Codensity u a+composedRepToCodensity :: Representable u => u (Rep u, a) -> Codensity u a composedRepToCodensity hfa = Codensity $ \k -> fmap (\(e, a) -> index (k a) e) hfa {-# INLINE composedRepToCodensity #-} @@ -201,16 +220,25 @@ ranToCodensity (Ran m) = Codensity m {-# INLINE ranToCodensity #-} -instance (Functor f, MonadFree f m) => MonadFree f (Codensity m) where+instance (m ~~ m', Functor f, MonadFree f m')+  => MonadFree f (Codensity (m :: k -> TYPE rep)) where   wrap t = Codensity (\h -> wrap (fmap (\p -> runCodensity p h) t))   {-# INLINE wrap #-} -instance MonadReader r m => MonadState r (Codensity m) where+instance (m ~~ m', MonadReader r m')+  => MonadState r (Codensity (m :: k -> TYPE rep)) where   get = Codensity (ask >>=)   {-# INLINE get #-}   put s = Codensity (\k -> local (const s) (k ()))   {-# INLINE put #-} +instance (m ~~ m', MonadReader r m')+  => MonadReader r (Codensity (m :: k -> TYPE rep)) where+  ask = Codensity (ask >>=)+  {-# INLINE ask #-}+  local f m = Codensity $ \c -> ask >>= \r -> local f . runCodensity m $ local (const r) . c+  {-# INLINE local #-}+ -- | Right associate all binds in a computation that generates a free monad -- -- This can improve the asymptotic efficiency of the result, while preserving@@ -223,3 +251,27 @@ improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a improve m = lowerCodensity m {-# INLINE improve #-}+++-- | Wrap the remainder of the 'Codensity' action using the given+-- function.+--+-- This function can be used to register cleanup actions that will be+-- executed at the end.  Example:+--+-- > wrapCodensity (`finally` putStrLn "Done.")+wrapCodensity :: (forall a. m a -> m a) -> Codensity m ()+wrapCodensity f = Codensity (\k -> f (k ()))++-- | @'reset' m@ delimits the continuation of any 'shift' inside @m@.+--+-- * @'reset' ('return' m) = 'return' m@+reset :: Monad m => Codensity m a -> Codensity m a+reset = lift . lowerCodensity++-- | @'shift' f@ captures the continuation up to the nearest enclosing+-- 'reset' and passes it to @f@:+--+-- * @'reset' ('shift' f >>= k) = 'reset' (f ('lowerCodensity' . k))@+shift :: Applicative m => (forall b. (a -> m b) -> Codensity m b) -> Codensity m a+shift f = Codensity $ lowerCodensity . f

@@ -1,16 +1,13 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-}-#endif  ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2013 Edward Kmett+-- Copyright   :  (C) 2013-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -24,14 +21,14 @@   ( Coyoneda(..)   , liftCoyoneda   , lowerCoyoneda+  , hoistCoyoneda   ) where  import Control.Arrow import Data.Functor.Contravariant import Data.Functor.Contravariant.Adjunction-import Data.Functor.Contravariant.Representable+import Data.Functor.Contravariant.Rep -type instance Value (Coyoneda f) = Value f  -- | A 'Contravariant' functor (aka presheaf) suitable for Yoneda reduction. --@@ -43,17 +40,14 @@   contramap f (Coyoneda g m) = Coyoneda (g.f) m   {-# INLINE contramap #-} -instance Valued f => Valued (Coyoneda f) where-  contramapWithValue beav (Coyoneda ac fc) = Coyoneda (left ac . beav) (contramapWithValue id fc)-  {-# INLINE contramapWithValue #-}--instance Coindexed f => Coindexed (Coyoneda f) where-  coindex (Coyoneda ab fb) a = coindex fb (ab a)-  {-# INLINE coindex #-}- instance Representable f => Representable (Coyoneda f) where-  contrarep = liftCoyoneda . contrarep-  {-# INLINE contrarep #-}+  type Rep (Coyoneda f) = Rep f+  tabulate = liftCoyoneda . tabulate+  {-# INLINE tabulate #-}+  index (Coyoneda ab fb) a = index fb (ab a)+  {-# INLINE index #-}+  contramapWithRep beav (Coyoneda ac fc) = Coyoneda (left ac . beav) (contramapWithRep id fc)+  {-# INLINE contramapWithRep #-}  instance Adjunction f g => Adjunction (Coyoneda f) (Coyoneda g) where   leftAdjunct f = liftCoyoneda . leftAdjunct (lowerCoyoneda . f)@@ -75,3 +69,9 @@ lowerCoyoneda :: Contravariant f => Coyoneda f a -> f a lowerCoyoneda (Coyoneda f m) = contramap f m {-# INLINE lowerCoyoneda #-}++-- | Lift a natural transformation from @f@ to @g@ to a natural transformation+-- from @Coyoneda f@ to @Coyoneda g@.+hoistCoyoneda :: (forall a. f a -> g a) -> (Coyoneda f b -> Coyoneda g b)+hoistCoyoneda f (Coyoneda g x) = Coyoneda g (f x)+{-# INLINE hoistCoyoneda #-}

@@ -0,0 +1,192 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE KindSignatures #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2013-2016 Edward Kmett, Gershom Bazerman and Derek Elkins+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- The Day convolution of two contravariant functors is a contravariant+-- functor.+--+-- <http://ncatlab.org/nlab/show/Day+convolution>+----------------------------------------------------------------------------++module Data.Functor.Contravariant.Day+  ( Day(..)+  , day+  , runDay+  , assoc, disassoc+  , swapped+  , intro1, intro2+  , day1, day2+  , diag+  , trans1, trans2+  ) where++import Control.Arrow ((***))+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Rep+import Data.Functor.Contravariant.Adjunction+import Data.Functor.Contravariant.Divisible+import Data.Proxy+import Data.Tuple (swap)++-- | The Day convolution of two contravariant functors.+data Day f g a = forall b c. Day (f b) (g c) (a -> (b, c))++-- | Construct the Day convolution+--+-- @+-- 'day1' ('day' f g) = f+-- 'day2' ('day' f g) = g+-- @+day :: f a -> g b -> Day f g (a, b)+day fa gb = Day fa gb id++instance Contravariant (Day f g) where+  contramap f (Day fb gc abc) = Day fb gc (abc . f)++instance (Divisible f, Divisible g) => Divisible (Day f g) where+  divide h (Day f g l) (Day f' g' r) = Day (divided f f') (divided g g') (intertwine . (l *** r) . h)+    where intertwine ((a, b), (c, d)) = ((a, c), (b, d))+  conquer = Day conquer conquer (\a -> (a, a))++instance (Representable f, Representable g) => Representable (Day f g) where+  type Rep (Day f g) = (Rep f, Rep g)++  tabulate a2fg = Day (tabulate fst) (tabulate snd) $ \a -> let b = a2fg a in (b,b)++  index (Day fb gc abc) a = case abc a of+    (b, c) -> (index fb b, index gc c)+  {-# INLINE index #-}++  contramapWithRep d2eafg (Day fb gc abc) = Day (contramapWithRep id fb) (contramapWithRep id gc) $ \d -> case d2eafg d of+    Left a -> case abc a of+      (b, c) -> (Left b, Left c)+    Right (vf, vg) -> (Right vf, Right vg)+  {-# INLINE tabulate #-}++instance (Adjunction f u, Adjunction f' u') => Adjunction (Day f f') (Day u u') where+  unit a = Day (unit a) (unit a) (\(Day f f' g) -> (contramap (fst . g) f, contramap (snd . g) f'))+  counit a = Day (counit a) (counit a) (\(Day u u' g) -> (contramap (fst . g) u, contramap (snd . g) u'))++-- | Break apart the Day convolution of two contravariant functors.+runDay :: (Contravariant f, Contravariant g) => Day f g a -> (f a, g a)+runDay (Day fb gc abc) =+  ( contramap (fst . abc) fb+  , contramap (snd . abc) gc+  )++-- | Day convolution provides a monoidal product. The associativity+-- of this monoid is witnessed by 'assoc' and 'disassoc'.+--+-- @+-- 'assoc' . 'disassoc' = 'id'+-- 'disassoc' . 'assoc' = 'id'+-- 'contramap' f '.' 'assoc' = 'assoc' '.' 'contramap' f+-- @+assoc :: Day f (Day g h) a -> Day (Day f g) h a+assoc (Day fb (Day gd he cde) abc) = Day (Day fb gd id) he $ \a ->+  case cde <$> abc a of+    (b, (d, e)) -> ((b, d), e)++-- | Day convolution provides a monoidal product. The associativity+-- of this monoid is witnessed by 'assoc' and 'disassoc'.+--+-- @+-- 'assoc' . 'disassoc' = 'id'+-- 'disassoc' . 'assoc' = 'id'+-- 'contramap' f '.' 'disassoc' = 'disassoc' '.' 'contramap' f+-- @+disassoc :: Day (Day f g) h a -> Day f (Day g h) a+disassoc (Day (Day fd ge bde) hc abc) = Day fd (Day ge hc id) $ \a ->+  case abc a of+    (b, c) -> case bde b of+      (d, e) -> (d, (e, c))++-- | The monoid for Day convolution /in Haskell/ is symmetric.+--+-- @+-- 'contramap' f '.' 'swapped' = 'swapped' '.' 'contramap' f+-- @+swapped :: Day f g a -> Day g f a+swapped (Day fb gc abc) = Day gc fb (swap . abc)++-- | Proxy serves as the unit of Day convolution.+--+-- @+-- 'day1' '.' 'intro1' = 'id'+-- 'contramap' f '.' 'intro1' = 'intro1' '.' 'contramap' f+-- @+intro1 :: f a -> Day Proxy f a+intro1 fa = Day Proxy fa $ \a -> ((),a)++-- | Proxy serves as the unit of Day convolution.+--+-- @+-- 'day2' '.' 'intro2' = 'id'+-- 'contramap' f '.' 'intro2' = 'intro2' '.' 'contramap' f+-- @+intro2 :: f a -> Day f Proxy a+intro2 fa = Day fa Proxy $ \a -> (a,())++-- | In Haskell we can do general purpose elimination, but in a more general setting+-- it is only possible to eliminate the unit.+--+-- @+-- 'day1' '.' 'intro1' = 'id'+-- 'day1' = 'fst' '.' 'runDay'+-- 'contramap' f '.' 'day1' = 'day1' '.' 'contramap' f+-- @+day1 :: Contravariant f => Day f g a -> f a+day1 (Day fb _ abc) = contramap (fst . abc) fb++-- | In Haskell we can do general purpose elimination, but in a more general setting+-- it is only possible to eliminate the unit.+-- @+-- 'day2' '.' 'intro2' = 'id'+-- 'day2' = 'snd' '.' 'runDay'+-- 'contramap' f '.' 'day2' = 'day2' '.' 'contramap' f+-- @+day2 :: Contravariant g => Day f g a -> g a+day2 (Day _ gc abc) = contramap (snd . abc) gc++-- | Diagonalize the Day convolution:+--+-- @+-- 'day1' '.' 'diag' = 'id'+-- 'day2' '.' 'diag' = 'id'+-- 'runDay' '.' 'diag' = \a -> (a,a)+-- 'contramap' f . 'diag' = 'diag' . 'contramap' f+-- @++diag :: f a -> Day f f a+diag fa = Day fa fa $ \a -> (a,a)++-- | Apply a natural transformation to the left-hand side of a Day convolution.+--+-- This respects the naturality of the natural transformation you supplied:+--+-- @+-- 'contramap' f '.' 'trans1' fg = 'trans1' fg '.' 'contramap' f+-- @+trans1 :: (forall x. f x -> g x) -> Day f h a -> Day g h a+trans1 fg (Day fb hc abc) = Day (fg fb) hc abc++-- | Apply a natural transformation to the right-hand side of a Day convolution.+--+-- This respects the naturality of the natural transformation you supplied:+--+-- @+-- 'contramap' f '.' 'trans2' fg = 'trans2' fg '.' 'contramap' f+-- @+trans2 :: (forall x. g x -> h x) -> Day f g a -> Day f h a+trans2 gh (Day fb gc abc) = Day fb (gh gc) abc

@@ -1,15 +1,12 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UndecidableInstances #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2013 Edward Kmett+-- Copyright   :  (C) 2013-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -24,7 +21,7 @@  import Data.Functor.Contravariant import Data.Functor.Contravariant.Adjunction-import Data.Functor.Contravariant.Representable+import Data.Functor.Contravariant.Rep  -- | Yoneda embedding for a presheaf newtype Yoneda f a = Yoneda { runYoneda :: forall r. (r -> a) -> f r }@@ -48,19 +45,14 @@   contramap ab (Yoneda m) = Yoneda (m . fmap ab)   {-# INLINE contramap #-} -type instance Value (Yoneda f) = Value f--instance Valued f => Valued (Yoneda f) where-  contramapWithValue beav = liftYoneda . contramapWithValue beav . lowerYoneda-  {-# INLINE contramapWithValue #-}--instance Coindexed f => Coindexed (Yoneda f) where-  coindex m a = coindex (lowerYoneda m) a-  {-# INLINE coindex #-}- instance Representable f => Representable (Yoneda f) where-  contrarep = liftYoneda . contrarep-  {-# INLINE contrarep #-}+  type Rep (Yoneda f) = Rep f+  tabulate = liftYoneda . tabulate+  {-# INLINE tabulate #-}+  index m a = index (lowerYoneda m) a+  {-# INLINE index #-}+  contramapWithRep beav = liftYoneda . contramapWithRep beav . lowerYoneda+  {-# INLINE contramapWithRep #-}  instance Adjunction f g => Adjunction (Yoneda f) (Yoneda g) where   leftAdjunct f = liftYoneda . leftAdjunct (lowerYoneda . f)

@@ -1,52 +1,46 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif  ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2011-2013 Edward Kmett+-- Copyright   :  (C) 2011-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com> -- Stability   :  provisional -- Portability :  GADTs, MPTCs, fundeps --+-- @'Coyoneda' f@ is the "free functor" over @f@. -- The co-Yoneda lemma for a covariant 'Functor' @f@ states that @'Coyoneda' f@ -- is naturally isomorphic to @f@. ---------------------------------------------------------------------------- module Data.Functor.Coyoneda   ( Coyoneda(..)-  , liftCoyoneda, lowerCoyoneda, lowerM+  , liftCoyoneda, lowerCoyoneda, lowerM, hoistCoyoneda   -- * as a Left Kan extension   , coyonedaToLan, lanToCoyoneda-  -- * as a Left Kan lift-  , coyonedaToLift, liftToCoyoneda   ) where -import Control.Applicative+import Control.Applicative as A 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.Adjunction import Data.Functor.Bind+import Data.Functor.Classes import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Kan.Lan-import Data.Functor.Kan.Lift import Data.Functor.Plus-import Data.Functor.Representable-import Data.Key+import Data.Functor.Rep import Data.Foldable import Data.Traversable import Data.Semigroup.Foldable@@ -61,68 +55,81 @@  -- | @Coyoneda f@ is the left Kan extension of @f@ along the 'Identity' functor. --+-- @Coyoneda f@ is always a functor, even if @f@ is not. In this case, it+-- is called the /free functor over @f@/. Note the following categorical fine+-- print: If @f@ is not a functor, @Coyoneda f@ is actually not the left Kan+-- extension of @f@ along the 'Identity' functor, but along the inclusion+-- functor from the discrete subcategory of /Hask/ which contains only identity+-- functions as morphisms to the full category /Hask/. (This is because @f@,+-- not being a proper functor, can only be interpreted as a categorical functor+-- by restricting the source category to only contain identities.)+-- -- @ -- 'coyonedaToLan' . 'lanToCoyoneda' ≡ 'id' -- 'lanToCoyoneda' . 'coyonedaToLan' ≡ 'id' -- @ coyonedaToLan :: Coyoneda f a -> Lan Identity f a coyonedaToLan (Coyoneda ba fb) = Lan (ba . runIdentity) fb+{-# INLINE coyonedaToLan #-}  lanToCoyoneda :: Lan Identity f a -> Coyoneda f a lanToCoyoneda (Lan iba fb) = Coyoneda (iba . Identity) fb--{-# RULES "coyonedaToLan/lanToCoyoneda=id" coyonedaToLan . lanToCoyoneda = id #-}-{-# RULES "lanToCoyoneda/coyonedaToLan=id" lanToCoyoneda . coyonedaToLan = id #-}---- | @'Coyoneda' f@ is the left Kan lift of @f@ along the 'Identity' functor.------ @--- 'coyonedaToLift' . 'liftToCoyoneda' ≡ 'id'--- 'liftToCoyoneda' . 'coyonedaToLift' ≡ 'id'--- @-coyonedaToLift :: Coyoneda f a -> Lift Identity f a-coyonedaToLift (Coyoneda ba fb) = Lift $ \ f2iz -> ba <$> runIdentity (f2iz fb)--liftToCoyoneda :: Functor f => Lift Identity f a -> Coyoneda f a-liftToCoyoneda (Lift m) = Coyoneda id (m Identity)+{-# INLINE lanToCoyoneda #-} -{-# RULES "coyonedaToLift/liftToCoyoneda=id" coyonedaToLift . liftToCoyoneda = id #-}-{-# RULES "liftToCoyoneda/coyonedaToLift=id" liftToCoyoneda . coyonedaToLift = id #-}+-- {-# RULES "coyonedaToLan/lanToCoyoneda=id" coyonedaToLan . lanToCoyoneda = id #-}+-- {-# RULES "lanToCoyoneda/coyonedaToLan=id" lanToCoyoneda . coyonedaToLan = id #-}  instance Functor (Coyoneda f) where   fmap f (Coyoneda g v) = Coyoneda (f . g) v   {-# INLINE fmap #-} -type instance Key (Coyoneda f) = Key f--instance Keyed f => Keyed (Coyoneda f) where-  mapWithKey f (Coyoneda k a) = Coyoneda id $ mapWithKey (\x -> f x . k) a-  {-# INLINE mapWithKey #-}- instance Apply f => Apply (Coyoneda f) where-  m <.> n = liftCoyoneda $ lowerCoyoneda m <.> lowerCoyoneda n+  Coyoneda mf m <.> Coyoneda nf n =+    liftCoyoneda $ (\mres nres -> mf mres (nf nres)) <$> m <.> n   {-# INLINE (<.>) #-}+  Coyoneda _ m .> Coyoneda g n = Coyoneda g (m .> n)+  {-# INLINE (.>) #-}+  Coyoneda f m <. Coyoneda _ n = Coyoneda f (m <. n)+  {-# INLINE (<.) #-}  instance Applicative f => Applicative (Coyoneda f) where   pure = liftCoyoneda . pure   {-# INLINE pure #-}-  m <*> n = liftCoyoneda $ lowerCoyoneda m <*> lowerCoyoneda n+  Coyoneda mf m <*> Coyoneda nf n =+    liftCoyoneda $ (\mres nres -> mf mres (nf nres)) <$> m <*> n   {-# INLINE (<*>) #-}--instance Zip f => Zip (Coyoneda f) where-  zipWith f m n = liftCoyoneda $ zipWith f (lowerCoyoneda m) (lowerCoyoneda n)-  {-# INLINE zipWith #-}--instance ZipWithKey f => ZipWithKey (Coyoneda f) where-  zipWithKey f m n = liftCoyoneda $ zipWithKey f (lowerCoyoneda m) (lowerCoyoneda n)-  {-# INLINE zipWithKey #-}+  Coyoneda _ m *> Coyoneda g n = Coyoneda g (m *> n)+  {-# INLINE (*>) #-}+  Coyoneda f m <* Coyoneda _ n = Coyoneda f (m <* n)+  {-# INLINE (<*) #-}  instance Alternative f => Alternative (Coyoneda f) where   empty = liftCoyoneda empty   {-# INLINE empty #-}   m <|> n = liftCoyoneda $ lowerCoyoneda m <|> lowerCoyoneda n   {-# INLINE (<|>) #-}+  some = liftCoyoneda . A.some . lowerCoyoneda+  {-# INLINE some #-}+  many = liftCoyoneda . A.many . lowerCoyoneda+  {-# INLINE many #-} +{-+-- These are slightly optimized versions of the *default*+-- `some` and `many` definitions for `Coyoneda`. I don't+-- know if it's worth the clutter to expose them.+someDefault (Coyoneda vf vb) = liftCoyoneda some_v+  where+    many_v = some_v <|> pure []+    some_v = (:) . vf <$> vb <*> many_v+{-# INLINE someDefault #-}++manyDefault (Coyoneda vf vb) = liftCoyoneda many_v+  where+    many_v = some_v <|> pure []+    some_v = (:) . vf <$> vb <*> many_v+{-# INLINE many #-}+-}+ instance Alt f => Alt (Coyoneda f) where   m <!> n = liftCoyoneda $ lowerCoyoneda m <!> lowerCoyoneda n   {-# INLINE (<!>) #-}@@ -136,8 +143,9 @@   {-# INLINE (>>-) #-}  instance Monad m => Monad (Coyoneda m) where-  return = Coyoneda id . return-  {-# INLINE return #-}+  (>>) = (*>)+  {-# INLINE (>>) #-}+   Coyoneda f v >>= k = lift (v >>= lowerM . k . f)   {-# INLINE (>>=) #-} @@ -155,17 +163,12 @@   m `mplus` n = lift $ lowerM m `mplus` lowerM n   {-# INLINE mplus #-} -instance (Functor f, Lookup f) => Lookup (Coyoneda f) where-  lookup k f = lookup k (lowerCoyoneda f)-  {-# INLINE lookup #-}--instance (Functor f, Indexable f) => Indexable (Coyoneda f) where-  index = index . lowerCoyoneda-  {-# INLINE index #-}- instance Representable f => Representable (Coyoneda f) where+  type Rep (Coyoneda f) = Rep f   tabulate = liftCoyoneda . tabulate   {-# INLINE tabulate #-}+  index = index . lowerCoyoneda+  {-# INLINE index #-}  instance Extend w => Extend (Coyoneda w) where   extended k (Coyoneda f v) = Coyoneda id $ extended (k . Coyoneda f) v@@ -185,18 +188,10 @@   foldMap f (Coyoneda k a) = foldMap (f . k) a   {-# INLINE foldMap #-} -instance FoldableWithKey f => FoldableWithKey (Coyoneda f) where-  foldMapWithKey f (Coyoneda k a) = foldMapWithKey (\x -> f x . k) a-  {-# INLINE foldMapWithKey #-}- instance Foldable1 f => Foldable1 (Coyoneda f) where   foldMap1 f (Coyoneda k a) = foldMap1 (f . k) a   {-# INLINE foldMap1 #-} -instance FoldableWithKey1 f => FoldableWithKey1 (Coyoneda f) where-  foldMapWithKey1 f (Coyoneda k a) = foldMapWithKey1 (\x -> f x . k) a-  {-# INLINE foldMapWithKey1 #-}- instance Traversable f => Traversable (Coyoneda f) where   traverse f (Coyoneda k a) = Coyoneda id <$> traverse (f . k) a   {-# INLINE traverse #-}@@ -205,46 +200,55 @@   traverse1 f (Coyoneda k a) = Coyoneda id <$> traverse1 (f . k) a   {-# INLINE traverse1 #-} -instance TraversableWithKey f => TraversableWithKey (Coyoneda f) where-  traverseWithKey f (Coyoneda k a) = Coyoneda id <$> traverseWithKey (\x -> f x . k) a-  {-# INLINE traverseWithKey #-}--instance TraversableWithKey1 f => TraversableWithKey1 (Coyoneda f) where-  traverseWithKey1 f (Coyoneda k a) = Coyoneda id <$> traverseWithKey1 (\x -> f x . k) a-  {-# INLINE traverseWithKey1 #-}- instance Distributive f => Distributive (Coyoneda f) where   collect f = liftCoyoneda . collect (lowerCoyoneda . f)   {-# INLINE collect #-} -instance (Functor f, Show (f a)) => Show (Coyoneda f a) where-  showsPrec d (Coyoneda f a) = showParen (d > 10) $-    showString "liftCoyoneda " . showsPrec 11 (fmap f a)+instance (Functor f, Show1 f) => Show1 (Coyoneda f) where+  liftShowsPrec sp sl d (Coyoneda f a) =+    showsUnaryWith (liftShowsPrec sp sl) "liftCoyoneda" d (fmap f a)+  {-# INLINE liftShowsPrec #-}++instance (Read1 f) => Read1 (Coyoneda f) where+  liftReadsPrec rp rl = readsData $+    readsUnaryWith (liftReadsPrec rp rl) "liftCoyoneda" liftCoyoneda+  {-# INLINE liftReadsPrec #-}++instance (Functor f, Show1 f, Show a) => Show (Coyoneda f a) where+  showsPrec = showsPrec1   {-# INLINE showsPrec #-} -#ifdef __GLASGOW_HASKELL__-instance (Functor f, Read (f a)) => Read (Coyoneda f a) where+instance Read (f a) => Read (Coyoneda f a) where   readPrec = parens $ prec 10 $ do     Ident "liftCoyoneda" <- lexP     liftCoyoneda <$> step readPrec   {-# INLINE readPrec #-}-#endif -instance (Functor f, Eq (f a)) => Eq (Coyoneda f a) where-  (==) = (==) `on` lowerCoyoneda+instance Eq1 f => Eq1 (Coyoneda f) where+  liftEq eq (Coyoneda f xs) (Coyoneda g ys) =+    liftEq (\x y -> eq (f x) (g y)) xs ys+  {-# INLINE liftEq #-}++instance Ord1 f => Ord1 (Coyoneda f) where+  liftCompare cmp (Coyoneda f xs) (Coyoneda g ys) =+    liftCompare (\x y -> cmp (f x) (g y)) xs ys+  {-# INLINE liftCompare #-}++instance (Eq1 f, Eq a) => Eq (Coyoneda f a) where+  (==) = eq1   {-# INLINE (==) #-} -instance (Functor f, Ord (f a)) => Ord (Coyoneda f a) where-  compare = compare `on` lowerCoyoneda+instance (Ord1 f, Ord a) => Ord (Coyoneda f a) where+  compare = compare1   {-# INLINE compare #-}  instance Adjunction f g => Adjunction (Coyoneda f) (Coyoneda g) where-  unit = liftCoyoneda . fmap liftCoyoneda . unit+  unit = liftCoyoneda . leftAdjunct liftCoyoneda   {-# INLINE unit #-}-  counit = counit . fmap lowerCoyoneda . lowerCoyoneda+  counit = rightAdjunct lowerCoyoneda . lowerCoyoneda   {-# INLINE counit #-} --- | Yoneda "expansion"+-- | Yoneda \"expansion\" -- -- @ -- 'liftCoyoneda' . 'lowerCoyoneda' ≡ 'id'@@ -290,3 +294,9 @@ lowerM :: Monad f => Coyoneda f a -> f a lowerM (Coyoneda f m) = liftM f m {-# INLINE lowerM #-}++-- | Lift a natural transformation from @f@ to @g@ to a natural transformation+-- from @Coyoneda f@ to @Coyoneda g@.+hoistCoyoneda :: (forall a. f a -> g a) -> (Coyoneda f b -> Coyoneda g b)+hoistCoyoneda f (Coyoneda g x) = Coyoneda g (f x)+{-# INLINE hoistCoyoneda #-}

@@ -0,0 +1,201 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2014-2016 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- Eitan Chatav first introduced me to this construction+--+-- The Day convolution of two covariant functors is a covariant functor.+--+-- Day convolution is usually defined in terms of contravariant functors,+-- however, it just needs a monoidal category, and Hask^op is also monoidal.+--+-- Day convolution can be used to nicely describe monoidal functors as monoid+-- objects w.r.t this product.+--+-- <http://ncatlab.org/nlab/show/Day+convolution>+----------------------------------------------------------------------------++module Data.Functor.Day+  ( Day(..)+  , day+  , dap+  , assoc, disassoc+  , swapped+  , intro1, intro2+  , elim1, elim2+  , trans1, trans2+  , cayley, dayley+  ) where++import Control.Applicative+import Control.Category+import Control.Comonad+import Control.Comonad.Trans.Class+import Data.Distributive+import Data.Profunctor.Cayley (Cayley(..))+import Data.Profunctor.Composition (Procompose(..))+import Data.Functor.Adjunction+import Data.Functor.Identity+import Data.Functor.Rep+import Prelude hiding (id,(.))++-- | The Day convolution of two covariant functors.+data Day f g a = forall b c. Day (f b) (g c) (b -> c -> a)++-- | Construct the Day convolution+day :: f (a -> b) -> g a -> Day f g b+day fa gb = Day fa gb id++instance Functor (Day f g) where+  fmap f (Day fb gc bca) = Day fb gc $ \b c -> f (bca b c)++instance (Applicative f, Applicative g) => Applicative (Day f g) where+  pure x = Day (pure ()) (pure ()) (\_ _ -> x)+  (Day fa fb u) <*> (Day gc gd v) =+    Day ((,) <$> fa <*> gc) ((,) <$> fb <*> gd)+        (\(a,c) (b,d) -> u a b (v c d))++instance (Representable f, Representable g) => Distributive (Day f g) where+  distribute f = Day (tabulate id) (tabulate id) $ \x y ->+    fmap (\(Day m n o) -> o (index m x) (index n y)) f++  collect g f = Day (tabulate id) (tabulate id) $ \x y ->+    fmap (\q -> case g q of Day m n o -> o (index m x) (index n y)) f++instance (Representable f, Representable g) => Representable (Day f g) where+  type Rep (Day f g) = (Rep f, Rep g)+  tabulate f = Day (tabulate id) (tabulate id) (curry f)+  index (Day m n o) (x,y) = o (index m x) (index n y)++instance (Adjunction f u, Adjunction f' u') => Adjunction (Day f f') (Day u u') where+  unit a = Day (unit ()) (unit ()) (\f f' -> Day f f' (\() () -> a))+  counit (Day f f' h) = case h a a' of Day u u' g -> g (indexAdjunction u f_) (indexAdjunction u' f_')+    where+      (a, f_) = splitL f+      (a', f_') = splitL f'++instance (Comonad f, Comonad g) => Comonad (Day f g) where+  extract (Day fb gc bca) = bca (extract fb) (extract gc)+  duplicate (Day fb gc bca) = Day (duplicate fb) (duplicate gc) (\fb' gc' -> Day fb' gc' bca)++instance (ComonadApply f, ComonadApply g) => ComonadApply (Day f g) where+  Day fa fb u <@> Day gc gd v =+    Day ((,) <$> fa <@> gc) ((,) <$> fb <@> gd)+        (\(a,c) (b,d) -> u a b (v c d))++instance Comonad f => ComonadTrans (Day f) where+  lower (Day fb gc bca) = bca (extract fb) <$> gc++-- | Day convolution provides a monoidal product. The associativity+-- of this monoid is witnessed by 'assoc' and 'disassoc'.+--+-- @+-- 'assoc' . 'disassoc' = 'id'+-- 'disassoc' . 'assoc' = 'id'+-- 'fmap' f '.' 'assoc' = 'assoc' '.' 'fmap' f+-- @+assoc :: Day f (Day g h) a -> Day (Day f g) h a+assoc (Day fb (Day gd he dec) bca) = Day (Day fb gd (,)) he $+  \ (b,d) e -> bca b (dec d e)++-- | Day convolution provides a monoidal product. The associativity+-- of this monoid is witnessed by 'assoc' and 'disassoc'.+--+-- @+-- 'assoc' . 'disassoc' = 'id'+-- 'disassoc' . 'assoc' = 'id'+-- 'fmap' f '.' 'disassoc' = 'disassoc' '.' 'fmap' f+-- @+disassoc :: Day (Day f g) h a -> Day f (Day g h) a+disassoc (Day (Day fb gc bce) hd eda) = Day fb (Day gc hd (,)) $ \ b (c,d) ->+  eda (bce b c) d++-- | The monoid for 'Day' convolution on the cartesian monoidal structure is symmetric.+--+-- @+-- 'fmap' f '.' 'swapped' = 'swapped' '.' 'fmap' f+-- @+swapped :: Day f g a -> Day g f a+swapped (Day fb gc abc) = Day gc fb (flip abc)++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro1' '.' 'elim1' = 'id'+-- 'elim1' '.' 'intro1' = 'id'+-- @+intro1 :: f a -> Day Identity f a+intro1 fa = Day (Identity ()) fa $ \_ a -> a++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro2' '.' 'elim2' = 'id'+-- 'elim2' '.' 'intro2' = 'id'+-- @+intro2 :: f a -> Day f Identity a+intro2 fa = Day fa (Identity ()) const++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro1' '.' 'elim1' = 'id'+-- 'elim1' '.' 'intro1' = 'id'+-- @+elim1 :: Functor f => Day Identity f a -> f a+elim1 (Day (Identity b) fc bca) = bca b <$> fc++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro2' '.' 'elim2' = 'id'+-- 'elim2' '.' 'intro2' = 'id'+-- @+elim2 :: Functor f => Day f Identity a -> f a+elim2 (Day fb (Identity c) bca) = flip bca c <$> fb++-- | Collapse via a monoidal functor.+--+-- @+-- 'dap' ('day' f g) = f '<*>' g+-- @+dap :: Applicative f => Day f f a -> f a+dap (Day fb fc abc) = liftA2 abc fb fc++-- | Apply a natural transformation to the left-hand side of a Day convolution.+--+-- This respects the naturality of the natural transformation you supplied:+--+-- @+-- 'fmap' f '.' 'trans1' fg = 'trans1' fg '.' 'fmap' f+-- @+trans1 :: (forall x. f x -> g x) -> Day f h a -> Day g h a+trans1 fg (Day fb hc bca) = Day (fg fb) hc bca++-- | Apply a natural transformation to the right-hand side of a Day convolution.+--+-- This respects the naturality of the natural transformation you supplied:+--+-- @+-- 'fmap' f '.' 'trans2' fg = 'trans2' fg '.' 'fmap' f+-- @+trans2 :: (forall x. g x -> h x) -> Day f g a -> Day f h a+trans2 gh (Day fb gc bca) = Day fb (gh gc) bca++cayley :: Procompose (Cayley f p) (Cayley g q) a b -> Cayley (Day f g) (Procompose p q) a b+cayley (Procompose (Cayley p) (Cayley q)) = Cayley $ Day p q Procompose++-- | Proposition 4.1 from Pastro and Street+dayley :: Category p => Procompose (Cayley f p) (Cayley g p) a b -> Cayley (Day f g) p a b+dayley (Procompose (Cayley p) (Cayley q)) = Cayley $ Day p q (.)

@@ -0,0 +1,140 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+-------------------------------------------------------------------------------------------+-- |+-- Copyright 	: 2013-2016 Edward Kmett and Dan Doel+-- License	: BSD+--+-- Maintainer	: Edward Kmett <ekmett@gmail.com>+-- Stability	: experimental+-- Portability	: rank N types+--+-- @'Day' f -| 'Curried' f@+--+-- @'Day' f ~ 'Compose' f@ when f preserves colimits / is a left adjoint. (Due in part to the+-- strength of all functors in Hask.)+--+-- So by the uniqueness of adjoints, when f is a left adjoint, @'Curried' f ~ 'Rift' f@+-------------------------------------------------------------------------------------------+module Data.Functor.Day.Curried+  (+  -- * Right Kan lifts+    Curried(..)+  , toCurried, fromCurried, applied, unapplied+  , adjointToCurried, curriedToAdjoint+  , composedAdjointToCurried, curriedToComposedAdjoint+  , liftCurried, lowerCurried, rap+  ) where++import qualified Control.Applicative as App+import Data.Functor.Adjunction+import Data.Functor.Day+import Data.Functor.Identity+import Data.Functor.Apply++newtype Curried g h a =+  Curried { runCurried :: forall r. g (a -> r) -> h r }++instance Functor g => Functor (Curried g h) where+  fmap f (Curried g) = Curried (g . fmap (.f))+  {-# INLINE fmap #-}++instance (Functor g, g ~ h) => Apply (Curried g h) where+  Curried mf <.> Curried ma = Curried (ma . mf . fmap (.))+  {-# INLINE (<.>) #-}+  liftF2 f (Curried g) (Curried ma) = Curried (ma . g . fmap (\p q -> p . f q))+  {-# INLINE liftF2 #-}++instance (Functor g, g ~ h) => App.Applicative (Curried g h) where+  pure a = Curried (fmap ($ a))+  {-# INLINE pure #-}+  Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))+  {-# INLINE (<*>) #-}+  liftA2 f (Curried g) (Curried ma) = Curried (ma . g . fmap (\p q -> p . f q))+  {-# INLINE liftA2 #-}++-- | The natural isomorphism between @f@ and @Curried f f@.+-- @+-- 'lowerCurried' '.' 'liftCurried' ≡ 'id'+-- 'liftCurried' '.' 'lowerCurried' ≡ 'id'+-- @+--+-- @+-- 'lowerCurried' ('liftCurried' x)     -- definition+-- 'lowerCurried' ('Curried' ('<*>' x))   -- definition+-- ('<*>' x) ('pure' 'id')          -- beta reduction+-- 'pure' 'id' '<*>' x              -- Applicative identity law+-- x+-- @+liftCurried :: Applicative f => f a -> Curried f f a+liftCurried fa = Curried (<*> fa)+{-# INLINE liftCurried #-}++-- | Lower 'Curried' by applying 'pure' 'id' to the continuation.+--+-- See 'liftCurried'.+lowerCurried :: Applicative f => Curried f g a -> g a+lowerCurried (Curried f) = f (pure id)+{-# INLINE lowerCurried #-}++-- | Indexed applicative composition of right Kan lifts.+rap :: Functor f => Curried f g (a -> b) -> Curried g h a -> Curried f h b+rap (Curried mf) (Curried ma) = Curried (ma . mf . fmap (.))+{-# INLINE rap #-}++-- | This is the counit of the @Day f -| Curried f@ adjunction+applied :: Functor f => Day f (Curried f g) a -> g a+applied (Day fb (Curried fg) bca) = fg (bca <$> fb)+{-# INLINE applied #-}++-- | This is the unit of the @Day f -| Curried f@ adjunction+unapplied :: g a -> Curried f (Day f g) a+unapplied ga = Curried $ \ fab -> Day fab ga id+{-# INLINE unapplied #-}++-- | The universal property of 'Curried'+toCurried :: (forall x. Day g k x -> h x) -> k a -> Curried g h a+toCurried h ka = Curried $ \gar -> h (Day gar ka id)+{-# INLINE toCurried #-}++-- |+-- @+-- 'toCurried' . 'fromCurried' ≡ 'id'+-- 'fromCurried' . 'toCurried' ≡ 'id'+-- @+fromCurried :: Functor f => (forall a. k a -> Curried f h a) -> Day f k b -> h b+fromCurried f (Day fc kd cdb) = runCurried (f kd) (cdb <$> fc)+{-# INLINE fromCurried #-}++-- | @Curried f Identity a@ is isomorphic to the right adjoint to @f@ if one exists.+--+-- @+-- 'adjointToCurried' . 'curriedToAdjoint' ≡ 'id'+-- 'curriedToAdjoint' . 'adjointToCurried' ≡ 'id'+-- @+adjointToCurried :: Adjunction f u => u a -> Curried f Identity a+adjointToCurried ua = Curried (Identity . rightAdjunct (<$> ua))+{-# INLINE adjointToCurried #-}++-- | @Curried f Identity a@ is isomorphic to the right adjoint to @f@ if one exists.+curriedToAdjoint :: Adjunction f u => Curried f Identity a -> u a+curriedToAdjoint (Curried m) = leftAdjunct (runIdentity . m) id+{-# INLINE curriedToAdjoint #-}++-- | @Curried f h a@ is isomorphic to the post-composition of the right adjoint of @f@ onto @h@ if such a right adjoint exists.+--+-- @+-- 'curriedToComposedAdjoint' . 'composedAdjointToCurried' ≡ 'id'+-- 'composedAdjointToCurried' . 'curriedToComposedAdjoint' ≡ 'id'+-- @++curriedToComposedAdjoint :: Adjunction f u => Curried f h a -> u (h a)+curriedToComposedAdjoint (Curried m) = leftAdjunct m id+{-# INLINE curriedToComposedAdjoint #-}++-- | @Curried f h a@ is isomorphic to the post-composition of the right adjoint of @f@ onto @h@ if such a right adjoint exists.+composedAdjointToCurried :: (Functor h, Adjunction f u) => u (h a) -> Curried f h a+composedAdjointToCurried uha = Curried $ rightAdjunct (\b -> fmap b <$> uha)+{-# INLINE composedAdjointToCurried #-}+

@@ -0,0 +1,150 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes                #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2018 Brian Mckenna+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- The Day convolution of two invariant functors is an invariant+-- functor.+--+-- <http://ncatlab.org/nlab/show/Day+convolution>+----------------------------------------------------------------------------++module Data.Functor.Invariant.Day+  ( Day(..)+  , day+  , assoc, disassoc+  , swapped+  , intro1, intro2+  , elim1, elim2+  , trans1, trans2+  , toContravariant, toCovariant+  ) where++import qualified Data.Functor.Contravariant.Day as Contravariant+import qualified Data.Functor.Day               as Covariant+import           Data.Functor.Identity+import           Data.Functor.Invariant++-- | The Day convolution of two invariant functors.+data Day f g a = forall b c. Day (f b) (g c) (b -> c -> a) (a -> (b, c))++instance Invariant (Day f g) where+  invmap f g (Day fb gc bca abc) = Day fb gc ((f .) . bca) (abc . g)++-- | Construct the Day convolution+day :: f a -> g b -> Day f g (a, b)+day fa gb = Day fa gb (,) id++-- | Day convolution provides a monoidal product. The associativity+-- of this monoid is witnessed by 'assoc' and 'disassoc'.+--+-- @+-- 'assoc' . 'disassoc' = 'id'+-- 'disassoc' . 'assoc' = 'id'+-- 'invmap' f g '.' 'assoc' = 'assoc' '.' 'invmap' f g+-- @+assoc :: Day f (Day g h) a -> Day (Day f g) h a+assoc (Day fb (Day gd he dec cde) bca abc) = flip (Day (Day fb gd (,) id) he) f g+  where+    f a =+      let (b,c) = abc a+          (d,e) = cde c+      in ((b,d),e)+    g (b,d) e =+      bca b (dec d e)++-- | Day convolution provides a monoidal product. The associativity+-- of this monoid is witnessed by 'assoc' and 'disassoc'.+--+-- @+-- 'assoc' . 'disassoc' = 'id'+-- 'disassoc' . 'assoc' = 'id'+-- 'invmap' f g '.' 'disassoc' = 'disassoc' '.' 'invmap' f g+-- @+disassoc :: Day (Day f g) h a -> Day f (Day g h) a+disassoc (Day (Day fb gc deb bde) hd bca abc) = Day fb (Day gc hd (,) id) f g+  where+    f e (d,c) =+      bca (deb e d) c+    g a =+      let (b,c) = abc a+          (d,e) = bde b+      in (d,(e,c))++-- | The monoid for 'Day' convolution on the cartesian monoidal structure is symmetric.+--+-- @+-- 'invmap' f g '.' 'swapped' = 'swapped' '.' 'invmap' f g+-- @+swapped :: Day f g a -> Day g f a+swapped (Day fb gc bca abc) = Day gc fb (flip bca) (\a -> let (b, c) = abc a in (c, b))++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro1' '.' 'elim1' = 'id'+-- 'elim1' '.' 'intro1' = 'id'+-- @+intro1 :: f a -> Day Identity f a+intro1 fa = Day (Identity ()) fa (\_ a -> a) ((,) ())++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro2' '.' 'elim2' = 'id'+-- 'elim2' '.' 'intro2' = 'id'+-- @+intro2 :: f a -> Day f Identity a+intro2 fa = Day fa (Identity ()) const (flip (,) ())++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro1' '.' 'elim1' = 'id'+-- 'elim1' '.' 'intro1' = 'id'+-- @+elim1 :: Invariant f => Day Identity f a -> f a+elim1 (Day (Identity b) fc bca abc) = invmap (bca b) (snd . abc) fc++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro2' '.' 'elim2' = 'id'+-- 'elim2' '.' 'intro2' = 'id'+-- @+elim2 :: Invariant f => Day f Identity a -> f a+elim2 (Day fb (Identity c) bca abc) = invmap (flip bca c) (fst . abc) fb++-- | Apply a natural transformation to the left-hand side of a Day convolution.+--+-- This respects the naturality of the natural transformation you supplied:+--+-- @+-- 'invmap' f g '.' 'trans1' fg = 'trans1' fg '.' 'invmap' f g+-- @+trans1 :: (forall x. f x -> g x) -> Day f h a -> Day g h a+trans1 fg (Day fb hc bca abc) = Day (fg fb) hc bca abc++-- | Apply a natural transformation to the right-hand side of a Day convolution.+--+-- This respects the naturality of the natural transformation you supplied:+--+-- @+-- 'invmap' f g '.' 'trans2' fg = 'trans2' fg '.' 'invmap' f g+-- @+trans2 :: (forall x. g x -> h x) -> Day f g a -> Day f h a+trans2 gh (Day fb gc bca abc) = Day fb (gh gc) bca abc++-- | Drop the covariant part of the Day convolution.+toContravariant :: Day f g a -> Contravariant.Day f g a+toContravariant (Day fb gc _ abc) = Contravariant.Day fb gc abc++-- | Drop the contravariant part of the Day convolution.+toCovariant :: Day f g a -> Covariant.Day f g a+toCovariant (Day fb gc bca _) = Covariant.Day fb gc bca

@@ -1,11 +1,10 @@-{-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE PolyKinds #-} ------------------------------------------------------------------------------------------- -- |--- Copyright 	: 2008-2013 Edward Kmett+-- Copyright 	: 2008-2016 Edward Kmett -- License	: BSD -- -- Maintainer	: Edward Kmett <ekmett@gmail.com>@@ -25,7 +24,9 @@   , composedAdjointToLan, lanToComposedAdjoint   ) where +#if !(MIN_VERSION_base(4,18,0)) import Control.Applicative+#endif import Data.Functor.Adjunction import Data.Functor.Apply import Data.Functor.Composition

@@ -1,151 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif----------------------------------------------------------------------------------------------- |--- Copyright 	: 2013 Edward Kmett and Dan Doel--- License	: BSD------ Maintainer	: Edward Kmett <ekmett@gmail.com>--- Stability	: experimental--- Portability	: rank N types------ Left Kan lifts for functors over Hask, wherever they exist.------ <http://ncatlab.org/nlab/show/Kan+lift>---------------------------------------------------------------------------------------------module Data.Functor.Kan.Lift-  (-  -- * Left Kan lifts-    Lift(..)-  , toLift, fromLift, glift-  , composeLift, decomposeLift-  , adjointToLift, liftToAdjoint-  , liftToComposedAdjoint, composedAdjointToLift-  , repToLift, liftToRep-  , liftToComposedRep, composedRepToLift-  ) where--import Data.Copointed-import Data.Functor.Adjunction-import Data.Functor.Composition-import Data.Functor.Compose-import Data.Functor.Identity-import Data.Functor.Representable-import Data.Key---- * Left Kan Lift---- |--- > f => g . Lift g f--- > (forall z. f => g . z) -> Lift g f => z -- couniversal------ Here we use the universal property directly as how we extract from our definition of 'Lift'.-newtype Lift g f a = Lift { runLift :: forall z. Functor z => (forall x. f x -> g (z x)) -> z a }--instance Functor (Lift g h) where-  fmap f (Lift g) = Lift (fmap f . g)-  {-# INLINE fmap #-}--instance (Functor g, g ~ h) => Copointed (Lift g h) where-  copoint x = runIdentity (runLift x (fmap Identity))-  {-# INLINE copoint #-}---- |------ @f => g ('Lift' g f a)@-glift :: Adjunction l g => k a -> g (Lift g k a)-glift = leftAdjunct (\lka -> Lift (\k2gz -> rightAdjunct k2gz lka))-{-# INLINE glift #-}---- | The universal property of 'Lift'-toLift :: Functor z => (forall a. f a -> g (z a)) -> Lift g f b -> z b-toLift = flip runLift-{-# INLINE toLift #-}---- | When the adjunction exists------ @--- 'fromLift' . 'toLift' ≡ 'id'--- 'toLift' . 'fromLift' ≡ 'id'--- @-fromLift :: Adjunction l u => (forall a. Lift u f a -> z a) -> f b -> u (z b)-fromLift f = fmap f . glift-{-# INLINE fromLift #-}---- |------ @--- 'composeLift' . 'decomposeLift' = 'id'--- 'decomposeLift' . 'composeLift' = 'id'--- @-composeLift :: (Composition compose, Functor f, Functor g) => Lift f (Lift g h) a -> Lift (compose g f) h a-composeLift (Lift m) = Lift $ \h -> m $ decompose . toLift (fmap Compose . decompose . h)-{-# INLINE composeLift #-}--decomposeLift :: (Composition compose, Adjunction l g) => Lift (compose g f) h a -> Lift f (Lift g h) a-decomposeLift (Lift m) = Lift $ \h -> m (compose . fmap h . glift)-{-# INLINE decomposeLift #-}---- | @Lift u Identity a@ is isomorphic to the left adjoint to @u@ if one exists.------ @--- 'adjointToLift' . 'liftToAdjoint' ≡ 'id'--- 'liftToAdjoint' . 'adjointToLift' ≡ 'id'--- @-adjointToLift :: Adjunction f u => f a -> Lift u Identity a-adjointToLift fa = Lift $ \k -> rightAdjunct (k . Identity) fa-{-# INLINE adjointToLift #-}----- | @Lift u Identity a@ is isomorphic to the left adjoint to @u@ if one exists.-liftToAdjoint :: Adjunction f u => Lift u Identity a -> f a-liftToAdjoint = toLift (unit . runIdentity)-{-# INLINE liftToAdjoint #-}---- |------ @--- 'repToLift' . 'liftToRep' ≡ 'id'--- 'liftToRep' . 'repToLift' ≡ 'id'--- @-repToLift :: Representable u => Key u -> a -> Lift u Identity a-repToLift e a = Lift $ \k -> index (k (Identity a)) e-{-# INLINE repToLift #-}--liftToRep :: Representable u => Lift u Identity a -> (Key u, a)-liftToRep (Lift m) = m $ \(Identity a) -> tabulate $ \e -> (e, a)-{-# INLINE liftToRep #-}---- | @Lift u h a@ is isomorphic to the post-composition of the left adjoint of @u@ onto @h@ if such a left adjoint exists.------ @--- 'liftToComposedAdjoint' . 'composedAdjointToLift' ≡ 'id'--- 'composedAdjointToLift' . 'liftToComposedAdjoint' ≡ 'id'--- @-liftToComposedAdjoint :: (Adjunction f u, Functor h) => Lift u h a -> f (h a)-liftToComposedAdjoint (Lift m) = decompose $ m (leftAdjunct Compose)-{-# INLINE liftToComposedAdjoint #-}---- | @Lift u h a@ is isomorphic to the post-composition of the left adjoint of @u@ onto @h@ if such a left adjoint exists.-composedAdjointToLift :: Adjunction f u => f (h a) -> Lift u h a-composedAdjointToLift = rightAdjunct glift-{-# INLINE composedAdjointToLift #-}---- |------ @--- 'liftToComposedRep' . 'composedRepToLift' ≡ 'id'--- 'composedRepToLift' . 'liftToComposedRep' ≡ 'id'--- @-liftToComposedRep :: (Functor h, Representable u) => Lift u h a -> (Key u, h a)-liftToComposedRep (Lift m) = decompose $ m $ \h -> tabulate $ \e -> Compose (e, h)-{-# INLINE liftToComposedRep #-}--composedRepToLift :: Representable u => Key u -> h a -> Lift u h a-composedRepToLift e ha = Lift $ \h2uz -> index (h2uz ha) e-{-# INLINE composedRepToLift #-}

@@ -1,11 +1,9 @@ {-# LANGUAGE Rank2Types, GADTs #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-}-#endif ------------------------------------------------------------------------------------------- -- |--- Copyright 	: 2008-2013 Edward Kmett+-- Copyright 	: 2008-2016 Edward Kmett -- License	: BSD -- -- Maintainer	: Edward Kmett <ekmett@gmail.com>@@ -29,8 +27,7 @@ import Data.Functor.Adjunction import Data.Functor.Composition import Data.Functor.Identity-import Data.Functor.Representable-import Data.Key+import Data.Functor.Rep  -- | The right Kan extension of a 'Functor' h along a 'Functor' g. --@@ -38,8 +35,8 @@ -- the definition in of a right Kan extension in terms of an End, but we can derive an equivalent definition -- from the universal property. ----- Given a 'Functor' @h : C -> D@ and a 'Functor' @g : C -> C'@, we want to find extend @h@ /back/ along @g@--- to give @Ran g h : C' -> C@, such that the natural transformation @'gran' :: Ran g h (g a) -> h a@ exists.+-- Given a 'Functor' @h : C -> D@ and a 'Functor' @g : C -> C'@, we want to extend @h@ /back/ along @g@+-- to give @Ran g h : C' -> D@, such that the natural transformation @'gran' :: Ran g h (g a) -> h a@ exists. -- -- In some sense this is trying to approximate the inverse of @g@ by using one of -- its adjoints, because if the adjoint and the inverse both exist, they match!@@ -53,7 +50,7 @@ -- -- The Right Kan extension is unique (up to isomorphism) by taking this as its universal property. ----- That is to say given any @K : C' -> C@ such that we have a natural transformation from @k.g@ to @h@+-- That is to say given any @K : C' -> D@ such that we have a natural transformation from @k.g@ to @h@ -- @(forall x. k (g x) -> h x)@ there exists a canonical natural transformation from @k@ to @Ran g h@. -- @(forall x. k x -> Ran g h x)@. --@@ -68,17 +65,19 @@ -- @ -- ranIso1 :: Ran g f x -> Ran' g f x -- ranIso1 (Ran e) = Ran' e id+-- @ --+-- @ -- ranIso2 :: Ran' g f x -> Ran g f x--- ranIso2 (Ran' h z) = Ran $ \k -> h (k <$> z)+-- ranIso2 (Ran' h z) = Ran $ \\k -> h (k \<$\> z) -- @ -- -- @ -- ranIso2 (ranIso1 (Ran e)) ≡ -- by definition -- ranIso2 (Ran' e id) ≡       -- by definition--- Ran $ \k -> e (k <$> id)    -- by definition--- Ran $ \k -> e (k . id)      -- f . id = f--- Ran $ \k -> e k             -- eta reduction+-- Ran $ \\k -> e (k \<$\> id)    -- by definition+-- Ran $ \\k -> e (k . id)      -- f . id = f+-- Ran $ \\k -> e k             -- eta reduction -- Ran e -- @ --@@ -101,7 +100,7 @@ -- 'fromRan' . 'toRan' ≡ 'id' -- @ fromRan :: (forall a. k a -> Ran g h a) -> k (g b) -> h b-fromRan s = flip runRan id . s+fromRan s kgb = runRan (s kgb) id {-# INLINE fromRan #-}  -- |@@ -150,18 +149,18 @@ gran (Ran f) = f id {-# INLINE gran #-} -repToRan :: Representable u => Key u -> a -> Ran u Identity a+repToRan :: Representable u => Rep u -> a -> Ran u Identity a repToRan e a = Ran $ \k -> Identity $ index (k a) e {-# INLINE repToRan #-} -ranToRep :: Representable u => Ran u Identity a -> (Key u, a)+ranToRep :: Representable u => Ran u Identity a -> (Rep u, a) ranToRep (Ran f) = runIdentity $ f (\a -> tabulate $ \e -> (e, a)) {-# INLINE ranToRep #-} -ranToComposedRep :: Representable u => Ran u h a -> h (Key u, a)+ranToComposedRep :: Representable u => Ran u h a -> h (Rep u, a) ranToComposedRep (Ran f) = f (\a -> tabulate $ \e -> (e, a)) {-# INLINE ranToComposedRep #-} -composedRepToRan :: (Representable u, Functor h) => h (Key u, a) -> Ran u h a+composedRepToRan :: (Representable u, Functor h) => h (Rep u, a) -> Ran u h a composedRepToRan hfa = Ran $ \k -> fmap (\(e, a) -> index (k a) e) hfa {-# INLINE composedRepToRan #-}

@@ -1,191 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif----------------------------------------------------------------------------------------------- |--- Copyright 	: 2013 Edward Kmett and Dan Doel--- License	: BSD------ Maintainer	: Edward Kmett <ekmett@gmail.com>--- Stability	: experimental--- Portability	: rank N types------ Right and Left Kan lifts for functors over Hask, where they exist.------ <http://ncatlab.org/nlab/show/Kan+lift>---------------------------------------------------------------------------------------------module Data.Functor.Kan.Rift-  (-  -- * Right Kan lifts-    Rift(..)-  , toRift, fromRift, grift-  , composeRift, decomposeRift-  , adjointToRift, riftToAdjoint-  , composedAdjointToRift, riftToComposedAdjoint-  , rap-  ) where--import Control.Applicative-import Data.Functor.Adjunction-import Data.Functor.Composition-import Data.Functor.Identity-import Data.Pointed---- * Right Kan Lift---- |------ @g . 'Rift' g f => f@------ This could alternately be defined directly from the (co)universal propertly--- in which case, we'd get 'toRift' = 'UniversalRift', but then the usage would--- suffer.------ @--- data 'UniversalRift' g f a = forall z. 'Functor' z =>---      'UniversalRift' (forall x. g (z x) -> f x) (z a)--- @------ We can witness the isomorphism between Rift and UniversalRift using:------ @--- riftIso1 :: Functor g => UniversalRift g f a -> Rift g f a--- riftIso1 (UniversalRift h z) = Rift $ \g -> h $ fmap (\k -> k <$> z) g--- @------ @--- riftIso2 :: Rift g f a -> UniversalRift g f a--- riftIso2 (Rift e) = UniversalRift e id--- @------ @--- riftIso1 (riftIso2 (Rift h)) =--- riftIso1 (UniversalRift h id) =          -- by definition--- Rift $ \g -> h $ fmap (\k -> k <$> id) g -- by definition--- Rift $ \g -> h $ fmap id g               -- <$> = (.) and (.id)--- Rift $ \g -> h g                         -- by functor law--- Rift h                                   -- eta reduction--- @------ The other direction is left as an exercise for the reader.------ There are several monads that we can form from @Rift@.------ When @g@ is corepresentable (e.g. is a right adjoint) then there exists @x@ such that @g ~ (->) x@, then it follows that------ @--- Rift g g a ~--- forall r. (x -> a -> r) -> x -> r ~--- forall r. (a -> x -> r) -> x -> r ~--- forall r. (a -> g r) -> g r ~--- Codensity g r--- @------ When @f@ is a left adjoint, so that @f -| g@ then------ @--- Rift f f a ~--- forall r. f (a -> r) -> f r ~--- forall r. (a -> r) -> g (f r) ~--- forall r. (a -> r) -> Adjoint f g r ~--- Yoneda (Adjoint f g r)--- @------ An alternative way to view that is to note that whenever @f@ is a left adjoint then @f -| 'Rift' f 'Identity'@, and since @'Rift' f f@ is isomorphic to @'Rift' f 'Identity' (f a)@, this is the 'Monad' formed by the adjunction.------ @'Rift' w f ~ 'Control.Monad.Co.CoT' w f@ can be a 'Monad' for any 'Comonad' @w@.------ @'Rift' 'Identity' m@ can be a 'Monad' for any 'Monad' @m@, as it is isomorphic to @'Yoneda' m@.--newtype Rift g h a =-  Rift { runRift :: forall r. g (a -> r) -> h r }--instance Functor g => Functor (Rift g h) where-  fmap f (Rift g) = Rift (g . fmap (.f))-  {-# INLINE fmap #-}--instance (Functor g, g ~ h) => Pointed (Rift g h) where-  point a = Rift (fmap ($a))-  {-# INLINE point #-}--instance (Functor g, g ~ h) => Applicative (Rift g h) where-  pure a = Rift (fmap ($a))-  {-# INLINE pure #-}-  Rift mf <*> Rift ma = Rift (ma . mf . fmap (.))-  {-# INLINE (<*>) #-}---- | Indexed applicative composition of right Kan lifts.-rap :: Functor f => Rift f g (a -> b) -> Rift g h a -> Rift f h b-rap (Rift mf) (Rift ma) = Rift (ma . mf . fmap (.))-{-# INLINE rap #-}--grift :: Adjunction f u => f (Rift f k a) -> k a-grift = rightAdjunct (\r -> leftAdjunct (runRift r) id)-{-# INLINE grift #-}---- | The universal property of 'Rift'-toRift :: (Functor g, Functor k) => (forall x. g (k x) -> h x) -> k a -> Rift g h a-toRift h z = Rift $ \g -> h $ fmap (<$> z) g-{-# INLINE toRift #-}---- |--- When @f -| u@, then @f -| Rift f Identity@ and------ @--- 'toRift' . 'fromRift' ≡ 'id'--- 'fromRift' . 'toRift' ≡ 'id'--- @-fromRift :: Adjunction f u => (forall a. k a -> Rift f h a) -> f (k b) -> h b-fromRift f = grift . fmap f-{-# INLINE fromRift #-}---- | @Rift f Identity a@ is isomorphic to the right adjoint to @f@ if one exists.------ @--- 'adjointToRift' . 'riftToAdjoint' ≡ 'id'--- 'riftToAdjoint' . 'adjointToRift' ≡ 'id'--- @-adjointToRift :: Adjunction f u => u a -> Rift f Identity a-adjointToRift ua = Rift (Identity . rightAdjunct (<$> ua))-{-# INLINE adjointToRift #-}---- | @Rift f Identity a@ is isomorphic to the right adjoint to @f@ if one exists.-riftToAdjoint :: Adjunction f u => Rift f Identity a -> u a-riftToAdjoint (Rift m) = leftAdjunct (runIdentity . m) id-{-# INLINE riftToAdjoint #-}---- |------ @--- 'composeRift' . 'decomposeRift' ≡ 'id'--- 'decomposeRift' . 'composeRift' ≡ 'id'--- @-composeRift :: (Composition compose, Adjunction g u) => Rift f (Rift g h) a -> Rift (compose g f) h a-composeRift (Rift f) = Rift (grift . fmap f . decompose)-{-# INLINE composeRift #-}--decomposeRift :: (Composition compose, Functor f, Functor g) => Rift (compose g f) h a -> Rift f (Rift g h) a-decomposeRift (Rift f) = Rift $ \far -> Rift (f . compose . fmap (\rs -> fmap (rs.) far))-{-# INLINE decomposeRift #-}----- | @Rift f h a@ is isomorphic to the post-composition of the right adjoint of @f@ onto @h@ if such a right adjoint exists.------ @--- 'riftToComposedAdjoint' . 'composedAdjointToRift' ≡ 'id'--- 'composedAdjointToRift' . 'riftToComposedAdjoint' ≡ 'id'--- @--riftToComposedAdjoint :: Adjunction f u => Rift f h a -> u (h a)-riftToComposedAdjoint (Rift m) = leftAdjunct m id-{-# INLINE riftToComposedAdjoint #-}---- | @Rift f h a@ is isomorphic to the post-composition of the right adjoint of @f@ onto @h@ if such a right adjoint exists.-composedAdjointToRift :: (Functor h, Adjunction f u) => u (h a) -> Rift f h a-composedAdjointToRift uha = Rift $ rightAdjunct (\b -> fmap b <$> uha)-{-# INLINE composedAdjointToRift #-}-

@@ -1,21 +1,15 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif -#ifndef MIN_VERSION_speculation-#define MIN_VERSION_speculation(x,y,z) 1-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.Functor.Yoneda--- Copyright   :  (C) 2011-2013 Edward Kmett+-- Copyright   :  (C) 2011-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -36,8 +30,6 @@   , maxF, minF, maxM, minM   -- * as a right Kan extension   , yonedaToRan, ranToYoneda-  -- * as a right Kan lift-  , yonedaToRift, riftToYoneda   ) where  import Control.Applicative@@ -47,34 +39,22 @@ import Control.Monad.Trans.Class import Control.Comonad import Control.Comonad.Trans.Class-import Control.Concurrent.Speculation-import Control.Concurrent.Speculation.Class import Data.Distributive import Data.Foldable-import Data.Function (on) import Data.Functor.Adjunction import Data.Functor.Bind+import Data.Functor.Classes import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Kan.Ran-import Data.Functor.Kan.Rift import Data.Functor.Plus-import Data.Functor.Representable-import Data.Key+import Data.Functor.Rep import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Traversable import Text.Read hiding (lift) import Prelude hiding (sequence, lookup, zipWith) -instance Monad m => MonadSpec (Yoneda m) where-  specByM f g a = Yoneda $ \k -> specBy f g (return . k) a-  {-# INLINE specByM #-}-#if !(MIN_VERSION_speculation(1,5,0))-  specByM' f g a = Yoneda $ \k -> specBy' f g (return . k) a-  {-# INLINE specByM' #-}-#endif- -- | @Yoneda f a@ can be viewed as the partial application of 'fmap' to its second argument. newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b } @@ -99,12 +79,15 @@ -- @ liftYoneda :: Functor f => f a -> Yoneda f a liftYoneda a = Yoneda (\f -> fmap f a)+{-# INLINE liftYoneda #-}  lowerYoneda :: Yoneda f a -> f a lowerYoneda (Yoneda f) = f id+{-# INLINE lowerYoneda #-} -{-# RULES "lower/lift=id" liftYoneda . lowerYoneda = id #-}-{-# RULES "lift/lower=id" lowerYoneda . liftYoneda = id #-}+-- TODO: coerce+-- {-# RULES "lower/lift=id" liftYoneda . lowerYoneda = id #-}+-- {-# RULES "lift/lower=id" lowerYoneda . liftYoneda = id #-}  -- | @Yoneda f@ can be viewed as the right Kan extension of @f@ along the 'Identity' functor. --@@ -114,110 +97,103 @@ -- @ yonedaToRan :: Yoneda f a -> Ran Identity f a yonedaToRan (Yoneda m) = Ran (m . fmap runIdentity)+{-# INLINE yonedaToRan #-}  ranToYoneda :: Ran Identity f a -> Yoneda f a ranToYoneda (Ran m) = Yoneda (m . fmap Identity)--{-# RULES "yonedaToRan/ranToYoneda=id" yonedaToRan . ranToYoneda = id #-}-{-# RULES "ranToYoneda/yonedaToRan=id" ranToYoneda . yonedaToRan = id #-}---- | @Yoneda f@ can be viewed as the right Kan lift of @f@ along the 'Identity' functor.------ @--- 'yonedaToRift' . 'riftToYoneda' ≡ 'id'--- 'riftToYoneda' . 'yonedaToRift' ≡ 'id'--- @-yonedaToRift :: Yoneda f a -> Rift Identity f a-yonedaToRift m = Rift (runYoneda m . runIdentity)-{-# INLINE yonedaToRift #-}--riftToYoneda :: Rift Identity f a -> Yoneda f a-riftToYoneda m = Yoneda (runRift m . Identity)-{-# INLINE riftToYoneda #-}+{-# INLINE ranToYoneda #-} -{-# RULES "yonedaToRift/riftToYoneda=id" yonedaToRift . riftToYoneda = id #-}-{-# RULES "riftToYoneda/yonedaToRift=id" riftToYoneda . yonedaToRift = id #-}+-- {-# RULES "yonedaToRan/ranToYoneda=id" yonedaToRan . ranToYoneda = id #-}+-- {-# RULES "ranToYoneda/yonedaToRan=id" ranToYoneda . yonedaToRan = 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+  {-# INLINE fmap #-}  instance Apply f => Apply (Yoneda f) where   Yoneda m <.> Yoneda n = Yoneda (\f -> m (f .) <.> n id)+  {-# INLINE (<.>) #-}+  Yoneda m .> Yoneda n = Yoneda (\f -> m id .> n f)+  {-# INLINE (.>) #-}  instance Applicative f => Applicative (Yoneda f) where   pure a = Yoneda (\f -> pure (f a))+  {-# INLINE pure #-}   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)+  {-# INLINE (<*>) #-}+  Yoneda m *> Yoneda n = Yoneda (\f -> m id *> n f)+  {-# INLINE (*>) #-}  instance Foldable f => Foldable (Yoneda f) where   foldMap f = foldMap f . lowerYoneda+  {-# INLINE foldMap #-}  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+  {-# INLINE foldMap1 #-}  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+  {-# INLINE traverse #-}  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+  {-# INLINE traverse1 #-}  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+  {-# INLINE collect #-}  instance Representable g => Representable (Yoneda g) where+  type Rep (Yoneda g) = Rep g   tabulate = liftYoneda . tabulate+  {-# INLINE tabulate #-}+  index = index . lowerYoneda+  {-# INLINE index #-}  instance Adjunction f g => Adjunction (Yoneda f) (Yoneda g) where   unit = liftYoneda . fmap liftYoneda . unit+  {-# INLINE unit #-}   counit (Yoneda m) = counit (m lowerYoneda)+  {-# INLINE counit #-} --- instance Show1 f => Show1 (Yoneda f) where+instance Show1 f => Show1 (Yoneda f) where+  liftShowsPrec sp sl d (Yoneda f) =+    showsUnaryWith (liftShowsPrec sp sl) "liftYoneda" d (f id)++instance (Read1 f, Functor f) => Read1 (Yoneda f) where+  liftReadsPrec rp rl = readsData $+    readsUnaryWith (liftReadsPrec rp rl) "liftYoneda" liftYoneda+ 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+infixl 0 `on1`+on1 :: (g a -> g b -> c) -> (forall x. f x -> g x) -> f a -> f b -> c+(.*.) `on1` f = \x y -> f x .*. f y -instance Ord (f a) => Ord (Yoneda f a) where-  compare = compare `on` lowerYoneda+instance Eq1 f => Eq1 (Yoneda f) where+  liftEq eq = liftEq eq `on1` lowerYoneda+  {-# INLINE liftEq #-} +instance Ord1 f => Ord1 (Yoneda f) where+  liftCompare cmp = liftCompare cmp `on1` lowerYoneda+  {-# INLINE liftCompare #-}++instance (Eq1 f, Eq a) => Eq (Yoneda f a) where+  (==) = eq1+  {-# INLINE (==) #-}++instance (Ord1 f, Ord a) => Ord (Yoneda f a) where+  compare = compare1+  {-# INLINE compare #-}+ 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 #-}@@ -240,40 +216,54 @@  instance Alt f => Alt (Yoneda f) where   Yoneda f <!> Yoneda g = Yoneda (\k -> f k <!> g k)+  {-# INLINE (<!>) #-}  instance Plus f => Plus (Yoneda f) where   zero = Yoneda $ const zero+  {-# INLINE zero #-}  instance Alternative f => Alternative (Yoneda f) where   empty = Yoneda $ const empty+  {-# INLINE empty #-}   Yoneda f <|> Yoneda g = Yoneda (\k -> f k <|> g k)+  {-# INLINE (<|>) #-}  instance Bind m => Bind (Yoneda m) where   Yoneda m >>- k = Yoneda (\f -> m id >>- \a -> runYoneda (k a) f)+  {-# INLINE (>>-) #-}  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)+  {-# INLINE (>>=) #-}  instance MonadFix m => MonadFix (Yoneda m) where   mfix f = lift $ mfix (lowerYoneda . f)+  {-# INLINE mfix #-}  instance MonadPlus m => MonadPlus (Yoneda m) where   mzero = Yoneda (const mzero)+  {-# INLINE mzero #-}   Yoneda f `mplus` Yoneda g = Yoneda (\k -> f k `mplus` g k)+  {-# INLINE mplus #-}  instance MonadTrans Yoneda where   lift a = Yoneda (\f -> liftM f a)+  {-# INLINE lift #-}  instance (Functor f, MonadFree f m) => MonadFree f (Yoneda m) where   wrap = lift . wrap . fmap lowerYoneda+  {-# INLINE wrap #-}  instance Extend w => Extend (Yoneda w) where   extended k (Yoneda m) = Yoneda (\f -> extended (f . k . liftYoneda) (m id))+  {-# INLINE extended #-}  instance Comonad w => Comonad (Yoneda w) where   extend k (Yoneda m) = Yoneda (\f -> extend (f . k . liftYoneda) (m id))+  {-# INLINE extend #-}   extract = extract . lowerYoneda+  {-# INLINE extract #-}  instance ComonadTrans Yoneda where   lower = lowerYoneda+  {-# INLINE lower #-}