kan-extensions 5.1 → 5.2

raw patch · 9 files changed

+328/−62 lines, 9 filesdep +invariantdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: invariant

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• .gitignore +3/−0
• .travis.yml +37/−31
• CHANGELOG.markdown +11/−0
• kan-extensions.cabal +24/−17
• src/Control/Comonad/Density.hs +1/−1
• src/Control/Monad/Codensity.hs +49/−7
• src/Data/Functor/Coyoneda.hs +13/−6
• src/Data/Functor/Invariant/Day.hs +150/−0
• src/Data/Functor/Yoneda.hs +40/−0

@@ -30,3 +30,6 @@ cabal.project.local~ .HTF/ .ghc.environment.*+/default.nix+/shell.nix+/result

@@ -1,6 +1,6 @@ # This Travis job script has been generated by a script via #-#   runghc make_travis_yml_2.hs '-o' '.travis.yml' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-installed' 'cabal.project'+#   runghc make_travis_yml_2.hs '-o' '.travis.yml' '--ghc-head' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-unconstrained' 'cabal.project' # # For more information, see https://github.com/hvr/multi-ghc-travis #@@ -34,43 +34,40 @@    - rm -rfv $HOME/.cabal/packages/head.hackage -addons:-  apt:-    packages: &apt_packages-      - ghc-ppa-tools-      - alex-3.1.7-      - happy-1.19.5- matrix:   include:-    - compiler: "ghc-7.4.2"+    - compiler: "ghc-8.6.1"+      env: GHCHEAD=true+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}}+    - compiler: "ghc-8.4.3"     # env: TEST=--disable-tests BENCH=--disable-benchmarks-      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}}-    - compiler: "ghc-7.6.3"+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}+    - compiler: "ghc-8.2.2"     # env: TEST=--disable-tests BENCH=--disable-benchmarks-      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}-    - compiler: "ghc-7.8.4"+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}}+    - compiler: "ghc-8.0.2"     # env: TEST=--disable-tests BENCH=--disable-benchmarks-      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}}+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}}     - compiler: "ghc-7.10.3"     # env: TEST=--disable-tests BENCH=--disable-benchmarks-      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}}-    - compiler: "ghc-8.0.2"+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}}+    - compiler: "ghc-7.8.4"     # env: TEST=--disable-tests BENCH=--disable-benchmarks-      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}-    - compiler: "ghc-8.2.2"+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.8.4], sources: [hvr-ghc]}}+    - compiler: "ghc-7.6.3"     # env: TEST=--disable-tests BENCH=--disable-benchmarks-      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}-    - compiler: "ghc-8.4.1"-      env: GHCHEAD=true-      addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.6.3], sources: [hvr-ghc]}}+    - compiler: "ghc-7.4.2"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.4.2], sources: [hvr-ghc]}}     - compiler: "ghc-head"       env: GHCHEAD=true-      addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}}+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}}    allow_failures:-    - compiler: "ghc-8.4.1"     - compiler: "ghc-head"+    - compiler: "ghc-8.6.1"+ before_install:   - HC=${CC}   - HCPKG=${HC/ghc/ghc-pkg}@@ -87,7 +84,8 @@   - BENCH=${BENCH---enable-benchmarks}   - TEST=${TEST---enable-tests}   - HADDOCK=${HADDOCK-true}-  - INSTALLED=${INSTALLED-true}+  - UNCONSTRAINED=${UNCONSTRAINED-true}+  - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}   - GHCHEAD=${GHCHEAD-false}   - travis_retry cabal update -v   - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"@@ -95,7 +93,8 @@   # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage   - |     if $GHCHEAD; then-      sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config+      sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config+      for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done        echo 'repository head.hackage'                                                        >> ${HOME}/.cabal/config       echo '   url: http://head.hackage.haskell.org/'                                       >> ${HOME}/.cabal/config@@ -105,17 +104,22 @@       echo '              8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config       echo '   key-threshold: 3'                                                            >> ${HOME}/.cabal.config +      grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'+       cabal new-update head.hackage -v     fi   - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'   - "printf 'packages: \".\"\\n' > cabal.project"-  - cat cabal.project+  - touch cabal.project.local+  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"+  - cat cabal.project || true+  - cat cabal.project.local || true   - if [ -f "./configure.ac" ]; then       (cd "." && autoreconf -i);     fi   - rm -f cabal.project.freeze   - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all-  - rm -rf "."/.ghc.environment.* "."/dist+  - rm -rf .ghc.environment.* "."/dist   - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)  # Here starts the actual work to be performed for the package under test;@@ -127,8 +131,10 @@   - cd ${DISTDIR} || false   - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;   - "printf 'packages: kan-extensions-*/*.cabal\\n' > cabal.project"-  - cat cabal.project-+  - touch cabal.project.local+  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"+  - cat cabal.project || true+  - cat cabal.project.local || true    # build & run tests, build benchmarks   - cabal new-build -w ${HC} ${TEST} ${BENCH} all@@ -140,5 +146,5 @@   - rm -rf ./dist-newstyle   - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi -# REGENDATA ["-o",".travis.yml","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-installed","cabal.project"]+# REGENDATA ["-o",".travis.yml","--ghc-head","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-unconstrained","cabal.project"] # EOF

@@ -1,3 +1,14 @@+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.

@@ -1,6 +1,6 @@ name:          kan-extensions category:      Data Structures, Monads, Comonads, Functors-version:       5.1+version:       5.2 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -19,7 +19,8 @@              , GHC == 7.10.3              , GHC == 8.0.2              , GHC == 8.2.2-             , GHC == 8.4.1+             , GHC == 8.4.3+             , GHC == 8.6.1  extra-source-files:   .travis.yml@@ -50,21 +51,21 @@     TypeFamilies    build-depends:-    adjunctions   >= 4.2     && < 5,-    array         >= 0.3.0.2 && < 0.6,-    base          >= 4.4     && < 5,-    comonad       >= 4       && < 6,-    containers    >= 0.4     && < 0.6,-    contravariant >= 1       && < 2,-    distributive  >= 0.2.2   && < 1,-    fail          >= 4.9     && < 5,-    free          >= 4       && < 6,-    mtl           >= 2.0.1   && < 2.3,-    profunctors   >= 5       && < 6,-    semigroupoids >= 4       && < 6,-    tagged        >= 0.7.2   && < 1,-    transformers  >= 0.2     && < 0.6,-    transformers-compat >= 0.3 && <0.6+    adjunctions         >= 4.2     && < 5,+    array               >= 0.3.0.2 && < 0.6,+    base                >= 4.4     && < 5,+    comonad             >= 4       && < 6,+    containers          >= 0.4     && < 0.7,+    contravariant       >= 1       && < 2,+    distributive        >= 0.2.2   && < 1,+    invariant           >= 0.1     && < 1,+    free                >= 4       && < 6,+    mtl                 >= 2.0.1   && < 2.3,+    profunctors         >= 5       && < 6,+    semigroupoids       >= 4       && < 6,+    tagged              >= 0.7.2   && < 1,+    transformers        >= 0.2     && < 0.6,+    transformers-compat >= 0.3     && < 0.7    exposed-modules:     Control.Comonad.Density@@ -75,6 +76,7 @@     Data.Functor.Contravariant.Coyoneda     Data.Functor.Day     Data.Functor.Day.Curried+    Data.Functor.Invariant.Day     Data.Functor.Kan.Lan     Data.Functor.Kan.Ran     Data.Functor.Yoneda@@ -82,6 +84,11 @@    ghc-options: -Wall +  if impl(ghc >= 7.10)+    ghc-options: -fno-warn-trustworthy-safe+   -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0   if impl(ghc >= 8.0)     ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+  else+    build-depends: fail >= 4.9 && < 5

@@ -19,7 +19,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

@@ -1,17 +1,21 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif-#if __GLASGOW_HASKELL__ >= 708+#if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 802) {-# LANGUAGE DeriveDataTypeable #-} #endif+#if __GLASGOW_HASKELL__ >= 802+{-# LANGUAGE TypeInType #-}+#endif  ----------------------------------------------------------------------------- -- |@@ -30,6 +34,7 @@   , codensityToAdjunction, adjunctionToCodensity   , codensityToRan, ranToCodensity   , codensityToComposedRep, composedRepToCodensity+  , wrapCodensity   , improve   ) where @@ -46,9 +51,12 @@ import Data.Functor.Kan.Ran import Data.Functor.Plus import Data.Functor.Rep-#if __GLASGOW_HASKELL__ >= 708+#if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 800) import Data.Typeable #endif+#if __GLASGOW_HASKELL__ >= 802+import GHC.Exts (TYPE)+#endif  -- | -- @'Codensity' f@ is the Monad generated by taking the right Kan extension@@ -61,34 +69,57 @@ -- Voigtländer for more information about this type. -- -- <https://www.janis-voigtlaender.eu/papers/AsymptoticImprovementOfComputationsOverFreeMonads.pdf>+#if __GLASGOW_HASKELL__ >= 802+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.+#else newtype Codensity m a = Codensity+#endif   { runCodensity :: forall b. (a -> m b) -> m b   }-#if __GLASGOW_HASKELL__ >= 708+#if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 800)     deriving Typeable #endif +#if __GLASGOW_HASKELL__ >= 802+instance Functor (Codensity (k :: j -> TYPE rep)) where+#else instance Functor (Codensity k) where-  fmap f (Codensity m) = Codensity (\k -> m (k . f))+#endif+  fmap f (Codensity m) = Codensity (\k -> m (\x -> k (f x)))   {-# INLINE fmap #-} +#if __GLASGOW_HASKELL__ >= 802+instance Apply (Codensity (f :: k -> TYPE rep)) where+#else instance Apply (Codensity f) where+#endif   (<.>) = (<*>)   {-# INLINE (<.>) #-} +#if __GLASGOW_HASKELL__ >= 802+instance Applicative (Codensity (f :: k -> TYPE rep)) where+#else instance Applicative (Codensity f) where+#endif   pure x = Codensity (\k -> k x)   {-# INLINE pure #-}-  Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (bfr . ab)))+  Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (\x -> bfr (ab x))))   {-# INLINE (<*>) #-} +#if __GLASGOW_HASKELL__ >= 802+instance Monad (Codensity (f :: k -> TYPE rep)) where+#else instance Monad (Codensity f) where+#endif   return = pure   {-# INLINE return #-}   m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c))   {-# INLINE (>>=) #-} -instance (Fail.MonadFail f) => Fail.MonadFail (Codensity f) where+instance Fail.MonadFail f => Fail.MonadFail (Codensity f) where   fail msg = Codensity $ \ _ -> Fail.fail msg   {-# INLINE fail #-} @@ -241,3 +272,14 @@ 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 ()))

@@ -77,9 +77,11 @@ -- @ 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+{-# INLINE lanToCoyoneda #-}  -- {-# RULES "coyonedaToLan/lanToCoyoneda=id" coyonedaToLan . lanToCoyoneda = id #-} -- {-# RULES "lanToCoyoneda/coyonedaToLan=id" lanToCoyoneda . coyonedaToLan = id #-}@@ -262,20 +264,24 @@   {-# INLINE readsPrec #-} #endif -instance (Functor f, Eq1 f) => Eq1 (Coyoneda f) where #if LIFTED_FUNCTOR_CLASSES-  liftEq eq = \x y -> liftEq eq (lowerCoyoneda x) (lowerCoyoneda y)+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 #-} #else+instance (Functor f, Eq1 f) => Eq1 (Coyoneda f) where   eq1 = eq1 `on` lowerCoyoneda   {-# INLINE eq1 #-} #endif -instance (Functor f, Ord1 f) => Ord1 (Coyoneda f) where #if LIFTED_FUNCTOR_CLASSES-  liftCompare cmp = \x y -> liftCompare cmp (lowerCoyoneda x) (lowerCoyoneda y)+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 #-} #else+instance (Functor f, Ord1 f) => Ord1 (Coyoneda f) where   compare1 = compare1 `on` lowerCoyoneda   {-# INLINE compare1 #-} #endif@@ -289,9 +295,9 @@   {-# 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\"@@ -345,3 +351,4 @@ -- 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,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

@@ -83,10 +83,13 @@ -- @ 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 #-} +-- TODO: coerce -- {-# RULES "lower/lift=id" liftYoneda . lowerYoneda = id #-} -- {-# RULES "lift/lower=id" lowerYoneda . liftYoneda = id #-} @@ -98,46 +101,61 @@ -- @ 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)+{-# INLINE ranToYoneda #-}  -- {-# 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))+  {-# INLINE fmap #-}  instance Apply f => Apply (Yoneda f) where   Yoneda m <.> Yoneda n = Yoneda (\f -> m (f .) <.> n id)+  {-# 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)+  {-# 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+  {-# INLINE foldMap1 #-}  instance Traversable f => Traversable (Yoneda f) where   traverse f = fmap liftYoneda . traverse f . lowerYoneda+  {-# INLINE traverse #-}  instance Traversable1 f => Traversable1 (Yoneda f) where   traverse1 f = fmap liftYoneda . traverse1 f . lowerYoneda+  {-# INLINE traverse1 #-}  instance Distributive f => Distributive (Yoneda f) where   collect f = liftYoneda . collect (lowerYoneda . f)+  {-# 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 #if LIFTED_FUNCTOR_CLASSES@@ -184,22 +202,28 @@ instance Eq1 f => Eq1 (Yoneda f) where #if LIFTED_FUNCTOR_CLASSES   liftEq eq = liftEq eq `on1` lowerYoneda+  {-# INLINE liftEq #-} #else   eq1 = eq1 `on1` lowerYoneda+  {-# INLINE eq1 #-} #endif  instance Ord1 f => Ord1 (Yoneda f) where #if LIFTED_FUNCTOR_CLASSES   liftCompare cmp = liftCompare cmp `on1` lowerYoneda+  {-# INLINE liftCompare #-} #else   compare1 = compare1 `on1` lowerYoneda+  {-# INLINE compare1 #-} #endif  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@@ -223,42 +247,58 @@  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 #if __GLASGOW_HASKELL__ < 710   return a = Yoneda (\f -> return (f a))+  {-# INLINE return #-} #endif   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 #-}