packages feed

semigroupoids 4.5 → 5

raw patch · 23 files changed

+1203/−1131 lines, 23 filesdep +bifunctorsdep +taggeddep ~basedep ~comonadsetup-changed

Dependencies added: bifunctors, tagged

Dependency ranges changed: base, comonad

Files

.travis.yml view
@@ -1,9 +1,8 @@-# NB: don't set `language: haskell` here--# See also https://github.com/hvr/multi-ghc-travis for more information env:- # we have to use CABALVER=1.16 for GHC<7.6 as well, as there's- # no package for earlier cabal versions in the PPA+ - GHCVER=7.0.1 CABALVER=1.16+ - GHCVER=7.0.4 CABALVER=1.16+ - GHCVER=7.2.2 CABALVER=1.16+ - GHCVER=7.4.2 CABALVER=1.16  - GHCVER=7.6.3 CABALVER=1.16  - GHCVER=7.8.4 CABALVER=1.18  - GHCVER=7.10.1 CABALVER=1.22@@ -11,10 +10,11 @@  matrix:   allow_failures:+   - env: GHCVER=7.0.1 CABALVER=1.16+   - env: GHCVER=7.0.4 CABALVER=1.16+   - env: GHCVER=7.2.2 CABALVER=1.16    - env: GHCVER=head CABALVER=1.22 -# Note: the distinction between `before_install` and `install` is not-#       important. before_install:  - travis_retry sudo add-apt-repository -y ppa:hvr/ghc  - travis_retry sudo apt-get update@@ -24,27 +24,20 @@  install:  - travis_retry cabal update- - cabal install --only-dependencies+ - git clone https://github.com/ekmett/bifunctors.git+ - cd bifunctors+ - cabal install+ - cd ..+ - cabal install --enable-tests --only-dependencies -# Here starts the actual work to be performed for the package under-# test; any command which exits with a non-zero exit code causes the-# build to fail. script:- # -v2 provides useful information for debugging- - cabal configure -v2-- # this builds all libraries and executables- # (including tests/benchmarks)+ - cabal configure -v2 --enable-tests  - cabal build-- # tests that a source-distribution can be generated  - cabal sdist-- # check that the generated source-distribution can be built & installed  - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;    cd dist/;    if [ -f "$SRC_TGZ" ]; then-      cabal install --force-reinstalls "$SRC_TGZ";+      cabal install "$SRC_TGZ";    else       echo "expected '$SRC_TGZ' not found";       exit 1;@@ -56,4 +49,4 @@       - "irc.freenode.org#haskell-lens"     skip_join: true     template:-      - "\x0313semigroupoids\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"+      - "\x0313semigroupoids\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f"
Setup.lhs view
@@ -5,15 +5,14 @@  import Data.List ( nub ) import Data.Version ( showVersion )-import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag) import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )-import Distribution.Text ( display )-import Distribution.Verbosity ( Verbosity, normal )+import Distribution.Verbosity ( Verbosity ) import System.FilePath ( (</>) )  main :: IO ()@@ -22,16 +21,8 @@      generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi      buildHook simpleUserHooks pkg lbi hooks flags   , postHaddock = \args flags pkg lbi -> do-     -- copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")]      postHaddock simpleUserHooks args flags pkg lbi   }--haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath-haddockOutputDir flags pkg = destDir where-  baseDir = case haddockDistPref flags of-    NoFlag -> "."-    Flag x -> x-  destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)  generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () generateBuildModule verbosity pkg lbi = do
semigroupoids.cabal view
@@ -1,6 +1,6 @@ name:          semigroupoids category:      Control, Comonads-version:       4.5+version:       5 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -11,6 +11,7 @@ bug-reports:   http://github.com/ekmett/semigroupoids/issues copyright:     Copyright (C) 2011-2015 Edward A. Kmett build-type:    Custom+tested-with:   GHC==7.0.1, GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 synopsis:      Semigroupoids: Category sans id extra-source-files:   .ghci@@ -101,11 +102,19 @@   default: True   manual: True -+flag tagged+  description:+    You can disable the use of the `tagged` package using `-f-tagged`.+    .+    Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.+  default: True+  manual: True+   library   build-depends:-    base                >= 4.6     && < 5,+    base                >= 4       && < 5,     base-orphans        >= 0.3     && < 1,+    bifunctors          >= 5       && < 6,     semigroups          >= 0.8.3.1 && < 1,     transformers        >= 0.2     && < 0.6,     transformers-compat >= 0.3     && < 0.5@@ -120,29 +129,33 @@     build-depends: distributive >= 0.2.2 && < 1    if flag(comonad)-    build-depends: comonad      >= 4     && < 5+    build-depends: comonad >= 4.2.6 && < 5 +  if flag(tagged)+    build-depends: tagged >= 0.7.3 && < 1+   hs-source-dirs: src    exposed-modules:+    Data.Bifunctor.Apply     Data.Functor.Alt     Data.Functor.Apply     Data.Functor.Bind+    Data.Functor.Bind.Class     Data.Functor.Bind.Trans     Data.Functor.Extend     Data.Functor.Plus     Data.Groupoid     Data.Isomorphism-    Data.Semifunctor-    Data.Semifunctor.Associative-    Data.Semifunctor.Braided+    Data.Semigroup.Bifoldable+    Data.Semigroup.Bitraversable     Data.Semigroup.Foldable+    Data.Semigroup.Foldable.Class     Data.Semigroup.Traversable+    Data.Semigroup.Traversable.Class     Data.Semigroupoid-    Data.Semigroupoid.Coproduct     Data.Semigroupoid.Dual     Data.Semigroupoid.Ob-    Data.Semigroupoid.Product     Data.Semigroupoid.Static     Data.Traversable.Instances @@ -158,8 +171,8 @@     buildable: False   else     build-depends:-      base    >= 4.6   && < 5,+      base    >= 4.4 && < 5,       doctest >= 0.9.1 && < 0.10,-      directory      >= 1.0,+      directory >= 1.0,       filepath
+ src/Data/Bifunctor/Apply.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2011-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+----------------------------------------------------------------------------+module Data.Bifunctor.Apply (+  -- * Biappliable bifunctors+    Bifunctor(..)+  , Biapply(..)+  , (<<$>>)+  , (<<..>>)+  , bilift2+  , bilift3+  ) where++import Data.Functor.Bind.Class+import Data.Biapplicative++infixl 4 <<..>>++(<<..>>) :: Biapply p => p a c -> p (a -> b) (c -> d) -> p b d+(<<..>>) = bilift2 (flip id) (flip id)+{-# INLINE (<<..>>) #-}++-- | Lift binary functions+bilift2 :: Biapply w => (a -> b -> c) -> (d -> e -> f) -> w a d -> w b e -> w c f+bilift2 f g a b = bimap f g <<$>> a <<.>> b+{-# INLINE bilift2 #-}++-- | Lift ternary functions+bilift3 :: Biapply w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h+bilift3 f g a b c = bimap f g <<$>> a <<.>> b <<.>> c+{-# INLINE bilift3 #-}
src/Data/Functor/Apply.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- |--- Module      :  Data.Functor.Apply -- Copyright   :  (C) 2011-2015 Edward Kmett -- License     :  BSD-style (see the file LICENSE) --@@ -29,4 +28,23 @@   , MaybeApply(..)   ) where -import Data.Functor.Bind+import Control.Comonad+import Data.Functor.Bind.Class++infixl 4 <..>++-- | A variant of '<.>' with the arguments reversed.+(<..>) :: Apply w => w a -> w (a -> b) -> w b+(<..>) = liftF2 (flip id)+{-# INLINE (<..>) #-}++-- | Lift a binary function into a comonad with zipping+liftF2 :: Apply w => (a -> b -> c) -> w a -> w b -> w c+liftF2 f a b = f <$> a <.> b+{-# INLINE liftF2 #-}++-- | Lift a ternary function into a comonad with zipping+liftF3 :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d+liftF3 f a b c = f <$> a <.> b <.> c+{-# INLINE liftF3 #-}+
src/Data/Functor/Bind.hs view
@@ -24,9 +24,6 @@ -- Stability   :  provisional -- Portability :  portable ----- NB: The definitions exported through "Data.Functor.Apply" need to be--- included here because otherwise the instances for the transformers package--- have orphaned heads. ---------------------------------------------------------------------------- module Data.Functor.Bind (   -- * Functors@@ -50,365 +47,10 @@   , returning   ) where --- import _everything_-import Control.Applicative-import Control.Applicative.Backwards-import Control.Applicative.Lift-import Control.Arrow-import Control.Category-import Control.Monad (ap)-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707-import Control.Monad.Instances ()-#endif-import Control.Monad.Trans.Cont-import Control.Monad.Trans.Error-import Control.Monad.Trans.Except-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Reader-import Control.Monad.Trans.List-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import qualified Control.Monad.Trans.RWS.Strict as Strict-import qualified Control.Monad.Trans.State.Strict as Strict-import qualified Control.Monad.Trans.Writer.Strict as Strict-import Data.Functor.Compose-import Data.Functor.Constant-import Data.Functor.Identity-import Data.Functor.Product-import Data.Functor.Reverse-import Data.Functor.Extend-import Data.List.NonEmpty-import Data.Semigroup hiding (Product)-import Prelude hiding (id, (.))---#ifdef MIN_VERSION_containers-import qualified Data.IntMap as IntMap-import Data.IntMap (IntMap)-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Sequence (Seq)-import Data.Tree (Tree)-#endif--#ifdef MIN_VERSION_comonad-import Control.Comonad-import Control.Comonad.Trans.Env-import Control.Comonad.Trans.Store-import Control.Comonad.Trans.Traced-#else-($>) :: Functor f => f a -> b -> f b-($>) = flip (<$)-#endif--infixl 1 >>--infixr 1 -<<-infixl 4 <.>, <., .>, <..>---- | A strong lax semi-monoidal endofunctor.--- This is equivalent to an 'Applicative' without 'pure'.------ Laws:------ > associative composition: (.) <$> u <.> v <.> w = u <.> (v <.> w)-class Functor f => Apply f where-  (<.>) :: f (a -> b) -> f a -> f b--  -- | > a  .> b = const id <$> a <.> b-  (.>) :: f a -> f b -> f b-  a .> b = const id <$> a <.> b--  -- | > a <. b = const <$> a <.> b-  (<.) :: f a -> f b -> f a-  a <. b = const <$> a <.> b--instance Apply f => Apply (Backwards f) where-  Backwards f <.> Backwards a = Backwards (a <..> f)--instance (Apply f, Apply g) => Apply (Compose f g) where-  Compose f <.> Compose x = Compose ((<.>) <$> f <.> x)--instance Semigroup f => Apply (Constant f) where-  Constant a <.> Constant b = Constant (a <> b)-  Constant a <.  Constant b = Constant (a <> b)-  Constant a  .> Constant b = Constant (a <> b)--instance Apply f => Apply (Lift f) where-  Pure f  <.> Pure x  = Pure (f x)-  Pure f  <.> Other y = Other (f <$> y)-  Other f <.> Pure x  = Other (($ x) <$> f)-  Other f <.> Other y = Other (f <.> y)--instance (Apply f, Apply g) => Apply (Product f g) where-  Pair f g <.> Pair x y = Pair (f <.> x) (g <.> y)--instance Apply f => Apply (Reverse f) where-  Reverse a <.> Reverse b = Reverse (a <.> b)--instance Semigroup m => Apply ((,)m) where-  (m, f) <.> (n, a) = (m <> n, f a)-  (m, a) <.  (n, _) = (m <> n, a)-  (m, _)  .> (n, b) = (m <> n, b)--instance Apply NonEmpty where-  (<.>) = ap--instance Apply (Either a) where-  Left a  <.> _       = Left a-  Right _ <.> Left a  = Left a-  Right f <.> Right b = Right (f b)--  Left a  <.  _       = Left a-  Right _ <.  Left a  = Left a-  Right a <.  Right _ = Right a--  Left a   .> _       = Left a-  Right _  .> Left a  = Left a-  Right _  .> Right b = Right b--instance Semigroup m => Apply (Const m) where-  Const m <.> Const n = Const (m <> n)-  Const m <.  Const n = Const (m <> n)-  Const m  .> Const n = Const (m <> n)--instance Apply ((->)m) where-  (<.>) = (<*>)-  (<. ) = (<* )-  ( .>) = ( *>)--instance Apply ZipList where-  (<.>) = (<*>)-  (<. ) = (<* )-  ( .>) = ( *>)--instance Apply [] where-  (<.>) = (<*>)-  (<. ) = (<* )-  ( .>) = ( *>)--instance Apply IO where-  (<.>) = (<*>)-  (<. ) = (<* )-  ( .>) = ( *>)--instance Apply Maybe where-  (<.>) = (<*>)-  (<. ) = (<* )-  ( .>) = ( *>)--instance Apply Option where-  (<.>) = (<*>)-  (<. ) = (<* )-  ( .>) = ( *>)--instance Apply Identity where-  (<.>) = (<*>)-  (<. ) = (<* )-  ( .>) = ( *>)--instance Apply w => Apply (IdentityT w) where-  IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb)--instance Monad m => Apply (WrappedMonad m) where-  (<.>) = (<*>)-  (<. ) = (<* )-  ( .>) = ( *>)--instance Arrow a => Apply (WrappedArrow a b) where-  (<.>) = (<*>)-  (<. ) = (<* )-  ( .>) = ( *>)--#ifdef MIN_VERSION_containers--- | A Map is not 'Applicative', but it is an instance of 'Apply'-instance Ord k => Apply (Map k) where-  (<.>) = Map.intersectionWith id-  (<. ) = Map.intersectionWith const-  ( .>) = Map.intersectionWith (const id)---- | An IntMap is not 'Applicative', but it is an instance of 'Apply'-instance Apply IntMap where-  (<.>) = IntMap.intersectionWith id-  (<. ) = IntMap.intersectionWith const-  ( .>) = IntMap.intersectionWith (const id)--instance Apply Seq where-  (<.>) = ap--instance Apply Tree where-  (<.>) = (<*>)-  (<. ) = (<* )-  ( .>) = ( *>)-#endif---- MaybeT is _not_ the same as Compose f Maybe-instance (Functor m, Monad m) => Apply (MaybeT m) where-  (<.>) = apDefault---- ErrorT e is _not_ the same as Compose f (Either e)-instance (Functor m, Monad m) => Apply (ErrorT e m) where-  (<.>) = apDefault--instance (Functor m, Monad m) => Apply (ExceptT e m) where-  (<.>) = apDefault--instance Apply m => Apply (ReaderT e m) where-  ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e--instance Apply m => Apply (ListT m) where-  ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a---- unfortunately, WriterT has its wrapped product in the wrong order to just use (<.>) instead of flap-instance (Apply m, Semigroup w) => Apply (Strict.WriterT w m) where-  Strict.WriterT f <.> Strict.WriterT a = Strict.WriterT $ flap <$> f <.> a where-    flap (x,m) (y,n) = (x y, m <> n)--instance (Apply m, Semigroup w) => Apply (Lazy.WriterT w m) where-  Lazy.WriterT f <.> Lazy.WriterT a = Lazy.WriterT $ flap <$> f <.> a where-    flap ~(x,m) ~(y,n) = (x y, m <> n)--instance Bind m => Apply (Strict.StateT s m) where-  (<.>) = apDefault--instance Bind m => Apply (Lazy.StateT s m) where-  (<.>) = apDefault--instance (Bind m, Semigroup w) => Apply (Strict.RWST r w s m) where-  (<.>) = apDefault--instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where-  (<.>) = apDefault--instance Apply (ContT r m) where-  ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g)--#ifdef MIN_VERSION_comonad-instance (Semigroup e, Apply w) => Apply (EnvT e w) where-  EnvT ef wf <.> EnvT ea wa = EnvT (ef <> ea) (wf <.> wa)--instance (Apply w, Semigroup s) => Apply (StoreT s w) where-  StoreT ff m <.> StoreT fa n = StoreT ((<*>) <$> ff <.> fa) (m <> n)--instance Apply w => Apply (TracedT m w) where-  TracedT wf <.> TracedT wa = TracedT (ap <$> wf <.> wa)-#endif---- | Wrap an 'Applicative' to be used as a member of 'Apply'-newtype WrappedApplicative f a = WrapApplicative { unwrapApplicative :: f a }--instance Functor f => Functor (WrappedApplicative f) where-  fmap f (WrapApplicative a) = WrapApplicative (f <$> a)--instance Applicative f => Apply (WrappedApplicative f) where-  WrapApplicative f <.> WrapApplicative a = WrapApplicative (f <*> a)-  WrapApplicative a <.  WrapApplicative b = WrapApplicative (a <*  b)-  WrapApplicative a  .> WrapApplicative b = WrapApplicative (a  *> b)--instance Applicative f => Applicative (WrappedApplicative f) where-  pure = WrapApplicative . pure-  WrapApplicative f <*> WrapApplicative a = WrapApplicative (f <*> a)-  WrapApplicative a <*  WrapApplicative b = WrapApplicative (a <*  b)-  WrapApplicative a  *> WrapApplicative b = WrapApplicative (a  *> b)--instance Alternative f => Alternative (WrappedApplicative f) where-  empty = WrapApplicative empty-  WrapApplicative a <|> WrapApplicative b = WrapApplicative (a <|> b)---- | Transform a Apply into an Applicative by adding a unit.-newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a }--instance Functor f => Functor (MaybeApply f) where-  fmap f (MaybeApply (Right a)) = MaybeApply (Right (f     a ))-  fmap f (MaybeApply (Left fa)) = MaybeApply (Left  (f <$> fa))--instance Apply f => Apply (MaybeApply f) where-  MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f        a ))-  MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left  (f    <$> fa))-  MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left  (($a) <$> ff))-  MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left  (ff   <.> fa))--  MaybeApply a         <. MaybeApply (Right _) = MaybeApply a-  MaybeApply (Right a) <. MaybeApply (Left fb) = MaybeApply (Left (a  <$ fb))-  MaybeApply (Left fa) <. MaybeApply (Left fb) = MaybeApply (Left (fa <. fb))--  MaybeApply (Right _) .> MaybeApply b = MaybeApply b-  MaybeApply (Left fa) .> MaybeApply (Right b) = MaybeApply (Left (fa $> b ))-  MaybeApply (Left fa) .> MaybeApply (Left fb) = MaybeApply (Left (fa .> fb))--instance Apply f => Applicative (MaybeApply f) where-  pure a = MaybeApply (Right a)-  (<*>) = (<.>)-  (<* ) = (<. )-  ( *>) = ( .>)---- | A variant of '<.>' with the arguments reversed.-(<..>) :: Apply w => w a -> w (a -> b) -> w b-(<..>) = liftF2 (flip id)-{-# INLINE (<..>) #-}---- | Lift a binary function into a comonad with zipping-liftF2 :: Apply w => (a -> b -> c) -> w a -> w b -> w c-liftF2 f a b = f <$> a <.> b-{-# INLINE liftF2 #-}---- | Lift a ternary function into a comonad with zipping-liftF3 :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d-liftF3 f a b c = f <$> a <.> b <.> c-{-# INLINE liftF3 #-}--instance Extend f => Extend (MaybeApply f) where-  duplicated w@(MaybeApply Right{}) = MaybeApply (Right w)-  duplicated (MaybeApply (Left fa)) = MaybeApply (Left (extended (MaybeApply . Left) fa))--#ifdef MIN_VERSION_comonad-instance Comonad f => Comonad (MaybeApply f) where-  duplicate w@(MaybeApply Right{}) = MaybeApply (Right w)-  duplicate (MaybeApply (Left fa)) = MaybeApply (Left (extend (MaybeApply . Left) fa))-  extract (MaybeApply (Left fa)) = extract fa-  extract (MaybeApply (Right a)) = a--instance Apply (Cokleisli w a) where-  Cokleisli f <.> Cokleisli a = Cokleisli (\w -> (f w) (a w))-#endif---- | A 'Monad' sans 'return'.------ Minimal definition: Either 'join' or '>>-'------ If defining both, then the following laws (the default definitions) must hold:------ > join = (>>- id)--- > m >>- f = join (fmap f m)------ Laws:------ > induced definition of <.>: f <.> x = f >>- (<$> x)------ Finally, there are two associativity conditions:------ > associativity of (>>-):    (m >>- f) >>- g == m >>- (\x -> f x >>- g)--- > associativity of join:     join . join = join . fmap join------ These can both be seen as special cases of the constraint that------ > associativity of (->-): (f ->- g) ->- h = f ->- (g ->- h)-----class Apply m => Bind m where-  (>>-) :: m a -> (a -> m b) -> m b-  m >>- f = join (fmap f m)--  join :: m (m a) -> m a-  join = (>>- id)--#if __GLASGOW_HASKELL__ >= 708-  {-# MINIMAL (>>-) | join #-}-#endif+import Data.Functor.Apply+import Data.Functor.Bind.Class -returning :: Functor f => f a -> (a -> b) -> f b-returning = flip fmap+infixr 1 -<<, -<-, ->-  (-<<) :: Bind m => (a -> m b) -> m a -> m b (-<<) = flip (>>-)@@ -419,125 +61,4 @@ (-<-) :: Bind m => (b -> m c) -> (a -> m b) -> a -> m c g -<- f = \a -> f a >>- g -apDefault :: Bind f => f (a -> b) -> f a -> f b-apDefault f x = f >>- \f' -> f' <$> x -instance Semigroup m => Bind ((,)m) where-  ~(m, a) >>- f = let (n, b) = f a in (m <> n, b)--instance Bind (Either a) where-  Left a  >>- _ = Left a-  Right a >>- f = f a--instance (Bind f, Bind g) => Bind (Product f g) where-  Pair m n >>- f = Pair (m >>- fstP . f) (n >>- sndP . f) where-    fstP (Pair a _) = a-    sndP (Pair _ b) = b--instance Bind ((->)m) where-  f >>- g = \e -> g (f e) e--instance Bind [] where-  (>>-) = (>>=)--instance Bind NonEmpty where-  (>>-) = (>>=)--instance Bind IO where-  (>>-) = (>>=)--instance Bind Maybe where-  (>>-) = (>>=)--instance Bind Option where-  (>>-) = (>>=)--instance Bind Identity where-  (>>-) = (>>=)--instance Bind m => Bind (IdentityT m) where-  IdentityT m >>- f = IdentityT (m >>- runIdentityT . f)--instance Monad m => Bind (WrappedMonad m) where-  WrapMonad m >>- f = WrapMonad $ m >>= unwrapMonad . f--instance (Functor m, Monad m) => Bind (MaybeT m) where-  (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@--instance (Apply m, Monad m) => Bind (ListT m) where-  (>>-) = (>>=) -- distributive law requires Monad to inject @[]@--instance (Functor m, Monad m) => Bind (ErrorT e m) where-  m >>- k = ErrorT $ do-    a <- runErrorT m-    case a of-      Left l -> return (Left l)-      Right r -> runErrorT (k r)--instance (Functor m, Monad m) => Bind (ExceptT e m) where-  m >>- k = ExceptT $ do-    a <- runExceptT m-    case a of-      Left l -> return (Left l)-      Right r -> runExceptT (k r)--instance Bind m => Bind (ReaderT e m) where-  ReaderT m >>- f = ReaderT $ \e -> m e >>- \x -> runReaderT (f x) e--instance (Bind m, Semigroup w) => Bind (Lazy.WriterT w m) where-  m >>- k = Lazy.WriterT $-    Lazy.runWriterT m >>- \ ~(a, w) ->-    Lazy.runWriterT (k a) `returning` \ ~(b, w') ->-      (b, w <> w')--instance (Bind m, Semigroup w) => Bind (Strict.WriterT w m) where-  m >>- k = Strict.WriterT $-    Strict.runWriterT m >>- \ (a, w) ->-    Strict.runWriterT (k a) `returning` \ (b, w') ->-      (b, w <> w')--instance Bind m => Bind (Lazy.StateT s m) where-  m >>- k = Lazy.StateT $ \s ->-    Lazy.runStateT m s >>- \ ~(a, s') ->-    Lazy.runStateT (k a) s'--instance Bind m => Bind (Strict.StateT s m) where-  m >>- k = Strict.StateT $ \s ->-    Strict.runStateT m s >>- \ ~(a, s') ->-    Strict.runStateT (k a) s'--instance (Bind m, Semigroup w) => Bind (Lazy.RWST r w s m) where-  m >>- k = Lazy.RWST $ \r s ->-    Lazy.runRWST m r s >>- \ ~(a, s', w) ->-    Lazy.runRWST (k a) r s' `returning` \ ~(b, s'', w') ->-      (b, s'', w <> w')--instance (Bind m, Semigroup w) => Bind (Strict.RWST r w s m) where-  m >>- k = Strict.RWST $ \r s ->-    Strict.runRWST m r s >>- \ (a, s', w) ->-    Strict.runRWST (k a) r s' `returning` \ (b, s'', w') ->-      (b, s'', w <> w')--instance Bind (ContT r m) where-  m >>- k = ContT $ \c -> runContT m $ \a -> runContT (k a) c--{--instance ArrowApply a => Bind (WrappedArrow a b) where-  (>>-) = (>>=)--}--#ifdef MIN_VERSION_containers--- | A 'Map' is not a 'Monad', but it is an instance of 'Bind'-instance Ord k => Bind (Map k) where-  m >>- f = Map.mapMaybeWithKey (\k -> Map.lookup k . f) m---- | An 'IntMap' is not a 'Monad', but it is an instance of 'Bind'-instance Bind IntMap where-  m >>- f = IntMap.mapMaybeWithKey (\k -> IntMap.lookup k . f) m--instance Bind Seq where-  (>>-) = (>>=)--instance Bind Tree where-  (>>-) = (>>=)-#endif
+ src/Data/Functor/Bind/Class.hs view
@@ -0,0 +1,615 @@+{-# LANGUAGE CPP #-}++#ifndef MIN_VERSION_semigroups+#define MIN_VERSION_semigroups(x,y,z) 1+#endif++#ifdef MIN_VERSION_comonad+#if __GLASGOW_HASKELL__ >= 707 && (MIN_VERSION_comonad(3,0,3))+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+#else+{-# LANGUAGE Trustworthy #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710+{-# OPTIONS_GHC -fno-warn-amp #-}+#endif++{-# OPTIONS_GHC -fno-warn-deprecations #-}++-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2011-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module is used to resolve the cyclic we get from defining these+-- classes here rather than in a package upstream. Otherwise we'd get+-- orphaned heads for many instances on the types in @transformers@ and @bifunctors@.+----------------------------------------------------------------------------+module Data.Functor.Bind.Class (+  -- * Applyable functors+    Apply(..)+  -- * Wrappers+  , WrappedApplicative(..)+  , MaybeApply(..)+  -- * Bindable functors+  , Bind(..)+  , apDefault+  , returning+  -- * Biappliable bifunctors+  , Biapply(..)+  ) where++import Data.Semigroup+import Data.Tagged+import Control.Applicative+import Control.Applicative.Backwards+import Control.Applicative.Lift+import Control.Arrow+import Control.Category+import Control.Monad (ap)+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707+import Control.Monad.Instances ()+#endif+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Error+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.List+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Strict as Strict+import Data.Biapplicative+import Data.Bifunctor.Biff+import Data.Bifunctor.Clown+import Data.Bifunctor.Flip+import Data.Bifunctor.Joker+import Data.Bifunctor.Join+import Data.Bifunctor.Product as Bifunctor+import Data.Bifunctor.Tannen+import Data.Bifunctor.Wrapped+import Data.Functor.Compose+import Data.Functor.Constant+import Data.Functor.Identity+import Data.Functor.Product as Functor+import Data.Functor.Reverse+import Data.Functor.Extend+import Data.List.NonEmpty+import Prelude hiding (id, (.))++#ifdef MIN_VERSION_containers+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Sequence (Seq)+import Data.Tree (Tree)+#endif++#ifdef MIN_VERSION_comonad+import Control.Comonad+import Control.Comonad.Trans.Env+import Control.Comonad.Trans.Store+import Control.Comonad.Trans.Traced+#else+($>) :: Functor f => f a -> b -> f b+($>) = flip (<$)+#endif++infixl 1 >>-+infixl 4 <.>, <., .>++-- | A strong lax semi-monoidal endofunctor.+-- This is equivalent to an 'Applicative' without 'pure'.+--+-- Laws:+--+-- > associative composition: (.) <$> u <.> v <.> w = u <.> (v <.> w)+class Functor f => Apply f where+  (<.>) :: f (a -> b) -> f a -> f b++  -- | > a  .> b = const id <$> a <.> b+  (.>) :: f a -> f b -> f b+  a .> b = const id <$> a <.> b++  -- | > a <. b = const <$> a <.> b+  (<.) :: f a -> f b -> f a+  a <. b = const <$> a <.> b++instance Apply f => Apply (Backwards f) where+  Backwards f <.> Backwards a = Backwards (flip id <$> a <.> f)++instance (Apply f, Apply g) => Apply (Compose f g) where+  Compose f <.> Compose x = Compose ((<.>) <$> f <.> x)++instance Semigroup f => Apply (Constant f) where+  Constant a <.> Constant b = Constant (a <> b)+  Constant a <.  Constant b = Constant (a <> b)+  Constant a  .> Constant b = Constant (a <> b)++instance Apply f => Apply (Lift f) where+  Pure f  <.> Pure x  = Pure (f x)+  Pure f  <.> Other y = Other (f <$> y)+  Other f <.> Pure x  = Other (($ x) <$> f)+  Other f <.> Other y = Other (f <.> y)++instance (Apply f, Apply g) => Apply (Functor.Product f g) where+  Functor.Pair f g <.> Functor.Pair x y = Functor.Pair (f <.> x) (g <.> y)++instance Apply f => Apply (Reverse f) where+  Reverse a <.> Reverse b = Reverse (a <.> b)++instance Semigroup m => Apply ((,)m) where+  (m, f) <.> (n, a) = (m <> n, f a)+  (m, a) <.  (n, _) = (m <> n, a)+  (m, _)  .> (n, b) = (m <> n, b)++instance Apply NonEmpty where+  (<.>) = ap++instance Apply (Either a) where+  Left a  <.> _       = Left a+  Right _ <.> Left a  = Left a+  Right f <.> Right b = Right (f b)++  Left a  <.  _       = Left a+  Right _ <.  Left a  = Left a+  Right a <.  Right _ = Right a++  Left a   .> _       = Left a+  Right _  .> Left a  = Left a+  Right _  .> Right b = Right b++instance Semigroup m => Apply (Const m) where+  Const m <.> Const n = Const (m <> n)+  Const m <.  Const n = Const (m <> n)+  Const m  .> Const n = Const (m <> n)++instance Apply ((->)m) where+  (<.>) = (<*>)+  (<. ) = (<* )+  ( .>) = ( *>)++instance Apply ZipList where+  (<.>) = (<*>)+  (<. ) = (<* )+  ( .>) = ( *>)++instance Apply [] where+  (<.>) = (<*>)+  (<. ) = (<* )+  ( .>) = ( *>)++instance Apply IO where+  (<.>) = (<*>)+  (<. ) = (<* )+  ( .>) = ( *>)++instance Apply Maybe where+  (<.>) = (<*>)+  (<. ) = (<* )+  ( .>) = ( *>)++instance Apply Option where+  (<.>) = (<*>)+  (<. ) = (<* )+  ( .>) = ( *>)++instance Apply Identity where+  (<.>) = (<*>)+  (<. ) = (<* )+  ( .>) = ( *>)++instance Apply w => Apply (IdentityT w) where+  IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb)++instance Monad m => Apply (WrappedMonad m) where+  (<.>) = (<*>)+  (<. ) = (<* )+  ( .>) = ( *>)++instance Arrow a => Apply (WrappedArrow a b) where+  (<.>) = (<*>)+  (<. ) = (<* )+  ( .>) = ( *>)++#ifdef MIN_VERSION_containers+-- | A Map is not 'Applicative', but it is an instance of 'Apply'+instance Ord k => Apply (Map k) where+  (<.>) = Map.intersectionWith id+  (<. ) = Map.intersectionWith const+  ( .>) = Map.intersectionWith (const id)++-- | An IntMap is not 'Applicative', but it is an instance of 'Apply'+instance Apply IntMap where+  (<.>) = IntMap.intersectionWith id+  (<. ) = IntMap.intersectionWith const+  ( .>) = IntMap.intersectionWith (const id)++instance Apply Seq where+  (<.>) = ap++instance Apply Tree where+  (<.>) = (<*>)+  (<. ) = (<* )+  ( .>) = ( *>)+#endif++-- MaybeT is _not_ the same as Compose f Maybe+instance (Functor m, Monad m) => Apply (MaybeT m) where+  (<.>) = apDefault++-- ErrorT e is _not_ the same as Compose f (Either e)+instance (Functor m, Monad m) => Apply (ErrorT e m) where+  (<.>) = apDefault++instance (Functor m, Monad m) => Apply (ExceptT e m) where+  (<.>) = apDefault++instance Apply m => Apply (ReaderT e m) where+  ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e++instance Apply m => Apply (ListT m) where+  ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a++-- unfortunately, WriterT has its wrapped product in the wrong order to just use (<.>) instead of flap+instance (Apply m, Semigroup w) => Apply (Strict.WriterT w m) where+  Strict.WriterT f <.> Strict.WriterT a = Strict.WriterT $ flap <$> f <.> a where+    flap (x,m) (y,n) = (x y, m <> n)++instance (Apply m, Semigroup w) => Apply (Lazy.WriterT w m) where+  Lazy.WriterT f <.> Lazy.WriterT a = Lazy.WriterT $ flap <$> f <.> a where+    flap ~(x,m) ~(y,n) = (x y, m <> n)++instance Bind m => Apply (Strict.StateT s m) where+  (<.>) = apDefault++instance Bind m => Apply (Lazy.StateT s m) where+  (<.>) = apDefault++instance (Bind m, Semigroup w) => Apply (Strict.RWST r w s m) where+  (<.>) = apDefault++instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where+  (<.>) = apDefault++instance Apply (ContT r m) where+  ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g)++#ifdef MIN_VERSION_comonad+instance (Semigroup e, Apply w) => Apply (EnvT e w) where+  EnvT ef wf <.> EnvT ea wa = EnvT (ef <> ea) (wf <.> wa)++instance (Apply w, Semigroup s) => Apply (StoreT s w) where+  StoreT ff m <.> StoreT fa n = StoreT ((<*>) <$> ff <.> fa) (m <> n)++instance Apply w => Apply (TracedT m w) where+  TracedT wf <.> TracedT wa = TracedT (ap <$> wf <.> wa)+#endif++-- | Wrap an 'Applicative' to be used as a member of 'Apply'+newtype WrappedApplicative f a = WrapApplicative { unwrapApplicative :: f a }++instance Functor f => Functor (WrappedApplicative f) where+  fmap f (WrapApplicative a) = WrapApplicative (f <$> a)++instance Applicative f => Apply (WrappedApplicative f) where+  WrapApplicative f <.> WrapApplicative a = WrapApplicative (f <*> a)+  WrapApplicative a <.  WrapApplicative b = WrapApplicative (a <*  b)+  WrapApplicative a  .> WrapApplicative b = WrapApplicative (a  *> b)++instance Applicative f => Applicative (WrappedApplicative f) where+  pure = WrapApplicative . pure+  WrapApplicative f <*> WrapApplicative a = WrapApplicative (f <*> a)+  WrapApplicative a <*  WrapApplicative b = WrapApplicative (a <*  b)+  WrapApplicative a  *> WrapApplicative b = WrapApplicative (a  *> b)++instance Alternative f => Alternative (WrappedApplicative f) where+  empty = WrapApplicative empty+  WrapApplicative a <|> WrapApplicative b = WrapApplicative (a <|> b)++-- | Transform a Apply into an Applicative by adding a unit.+newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a }++instance Functor f => Functor (MaybeApply f) where+  fmap f (MaybeApply (Right a)) = MaybeApply (Right (f     a ))+  fmap f (MaybeApply (Left fa)) = MaybeApply (Left  (f <$> fa))++instance Apply f => Apply (MaybeApply f) where+  MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f        a ))+  MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left  (f    <$> fa))+  MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left  (($a) <$> ff))+  MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left  (ff   <.> fa))++  MaybeApply a         <. MaybeApply (Right _) = MaybeApply a+  MaybeApply (Right a) <. MaybeApply (Left fb) = MaybeApply (Left (a  <$ fb))+  MaybeApply (Left fa) <. MaybeApply (Left fb) = MaybeApply (Left (fa <. fb))++  MaybeApply (Right _) .> MaybeApply b = MaybeApply b+  MaybeApply (Left fa) .> MaybeApply (Right b) = MaybeApply (Left (fa $> b ))+  MaybeApply (Left fa) .> MaybeApply (Left fb) = MaybeApply (Left (fa .> fb))++instance Apply f => Applicative (MaybeApply f) where+  pure a = MaybeApply (Right a)+  (<*>) = (<.>)+  (<* ) = (<. )+  ( *>) = ( .>)++instance Extend f => Extend (MaybeApply f) where+  duplicated w@(MaybeApply Right{}) = MaybeApply (Right w)+  duplicated (MaybeApply (Left fa)) = MaybeApply (Left (extended (MaybeApply . Left) fa))++#ifdef MIN_VERSION_comonad+instance Comonad f => Comonad (MaybeApply f) where+  duplicate w@(MaybeApply Right{}) = MaybeApply (Right w)+  duplicate (MaybeApply (Left fa)) = MaybeApply (Left (extend (MaybeApply . Left) fa))+  extract (MaybeApply (Left fa)) = extract fa+  extract (MaybeApply (Right a)) = a++instance Apply (Cokleisli w a) where+  Cokleisli f <.> Cokleisli a = Cokleisli (\w -> (f w) (a w))+#endif++-- | A 'Monad' sans 'return'.+--+-- Minimal definition: Either 'join' or '>>-'+--+-- If defining both, then the following laws (the default definitions) must hold:+--+-- > join = (>>- id)+-- > m >>- f = join (fmap f m)+--+-- Laws:+--+-- > induced definition of <.>: f <.> x = f >>- (<$> x)+--+-- Finally, there are two associativity conditions:+--+-- > associativity of (>>-):    (m >>- f) >>- g == m >>- (\x -> f x >>- g)+-- > associativity of join:     join . join = join . fmap join+--+-- These can both be seen as special cases of the constraint that+--+-- > associativity of (->-): (f ->- g) ->- h = f ->- (g ->- h)+--++class Apply m => Bind m where+  (>>-) :: m a -> (a -> m b) -> m b+  m >>- f = join (fmap f m)++  join :: m (m a) -> m a+  join = (>>- id)++#if __GLASGOW_HASKELL__ >= 708+  {-# MINIMAL (>>-) | join #-}+#endif++returning :: Functor f => f a -> (a -> b) -> f b+returning = flip fmap++apDefault :: Bind f => f (a -> b) -> f a -> f b+apDefault f x = f >>- \f' -> f' <$> x++instance Semigroup m => Bind ((,)m) where+  ~(m, a) >>- f = let (n, b) = f a in (m <> n, b)++instance Bind (Either a) where+  Left a  >>- _ = Left a+  Right a >>- f = f a++instance (Bind f, Bind g) => Bind (Functor.Product f g) where+  Functor.Pair m n >>- f = Functor.Pair (m >>- fstP . f) (n >>- sndP . f) where+    fstP (Functor.Pair a _) = a+    sndP (Functor.Pair _ b) = b++instance Bind ((->)m) where+  f >>- g = \e -> g (f e) e++instance Bind [] where+  (>>-) = (>>=)++instance Bind NonEmpty where+  (>>-) = (>>=)++instance Bind IO where+  (>>-) = (>>=)++instance Bind Maybe where+  (>>-) = (>>=)++instance Bind Option where+  (>>-) = (>>=)++instance Bind Identity where+  (>>-) = (>>=)++instance Bind m => Bind (IdentityT m) where+  IdentityT m >>- f = IdentityT (m >>- runIdentityT . f)++instance Monad m => Bind (WrappedMonad m) where+  WrapMonad m >>- f = WrapMonad $ m >>= unwrapMonad . f++instance (Functor m, Monad m) => Bind (MaybeT m) where+  (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@++instance (Apply m, Monad m) => Bind (ListT m) where+  (>>-) = (>>=) -- distributive law requires Monad to inject @[]@++instance (Functor m, Monad m) => Bind (ErrorT e m) where+  m >>- k = ErrorT $ do+    a <- runErrorT m+    case a of+      Left l -> return (Left l)+      Right r -> runErrorT (k r)++instance (Functor m, Monad m) => Bind (ExceptT e m) where+  m >>- k = ExceptT $ do+    a <- runExceptT m+    case a of+      Left l -> return (Left l)+      Right r -> runExceptT (k r)++instance Bind m => Bind (ReaderT e m) where+  ReaderT m >>- f = ReaderT $ \e -> m e >>- \x -> runReaderT (f x) e++instance (Bind m, Semigroup w) => Bind (Lazy.WriterT w m) where+  m >>- k = Lazy.WriterT $+    Lazy.runWriterT m >>- \ ~(a, w) ->+    Lazy.runWriterT (k a) `returning` \ ~(b, w') ->+      (b, w <> w')++instance (Bind m, Semigroup w) => Bind (Strict.WriterT w m) where+  m >>- k = Strict.WriterT $+    Strict.runWriterT m >>- \ (a, w) ->+    Strict.runWriterT (k a) `returning` \ (b, w') ->+      (b, w <> w')++instance Bind m => Bind (Lazy.StateT s m) where+  m >>- k = Lazy.StateT $ \s ->+    Lazy.runStateT m s >>- \ ~(a, s') ->+    Lazy.runStateT (k a) s'++instance Bind m => Bind (Strict.StateT s m) where+  m >>- k = Strict.StateT $ \s ->+    Strict.runStateT m s >>- \ ~(a, s') ->+    Strict.runStateT (k a) s'++instance (Bind m, Semigroup w) => Bind (Lazy.RWST r w s m) where+  m >>- k = Lazy.RWST $ \r s ->+    Lazy.runRWST m r s >>- \ ~(a, s', w) ->+    Lazy.runRWST (k a) r s' `returning` \ ~(b, s'', w') ->+      (b, s'', w <> w')++instance (Bind m, Semigroup w) => Bind (Strict.RWST r w s m) where+  m >>- k = Strict.RWST $ \r s ->+    Strict.runRWST m r s >>- \ (a, s', w) ->+    Strict.runRWST (k a) r s' `returning` \ (b, s'', w') ->+      (b, s'', w <> w')++instance Bind (ContT r m) where+  m >>- k = ContT $ \c -> runContT m $ \a -> runContT (k a) c++{-+instance ArrowApply a => Bind (WrappedArrow a b) where+  (>>-) = (>>=)+-}++#ifdef MIN_VERSION_containers+-- | A 'Map' is not a 'Monad', but it is an instance of 'Bind'+instance Ord k => Bind (Map k) where+  m >>- f = Map.mapMaybeWithKey (\k -> Map.lookup k . f) m++-- | An 'IntMap' is not a 'Monad', but it is an instance of 'Bind'+instance Bind IntMap where+  m >>- f = IntMap.mapMaybeWithKey (\k -> IntMap.lookup k . f) m++instance Bind Seq where+  (>>-) = (>>=)++instance Bind Tree where+  (>>-) = (>>=)+#endif++infixl 4 <<.>>, <<., .>>++class Bifunctor p => Biapply p where+  (<<.>>) :: p (a -> b) (c -> d) -> p a c -> p b d++  -- |+  -- @+  -- a '.>' b ≡ 'const' 'id' '<$>' a '<.>' b+  -- @+  (.>>) :: p a b -> p c d -> p c d+  a .>> b = bimap (const id) (const id) <<$>> a <<.>> b+  {-# INLINE (.>>) #-}++  -- |+  -- @+  -- a '<.' b ≡ 'const' '<$>' a '<.>' b+  -- @+  (<<.) :: p a b -> p c d -> p a b+  a <<. b = bimap const const <<$>> a <<.>> b+  {-# INLINE (<<.) #-}++instance Biapply (,) where+  (f, g) <<.>> (a, b) = (f a, g b)+  {-# INLINE (<<.>>) #-}++#if MIN_VERSION_semigroups(0,16,2)+instance Biapply Arg where+  Arg f g <<.>> Arg a b = Arg (f a) (g b)+  {-# INLINE (<<.>>) #-}+#endif++instance Semigroup x => Biapply ((,,) x) where+  (x, f, g) <<.>> (x', a, b) = (x <> x', f a, g b)+  {-# INLINE (<<.>>) #-}++instance (Semigroup x, Semigroup y) => Biapply ((,,,) x y) where+  (x, y, f, g) <<.>> (x', y', a, b) = (x <> x', y <> y', f a, g b)+  {-# INLINE (<<.>>) #-}++instance (Semigroup x, Semigroup y, Semigroup z) => Biapply ((,,,,) x y z) where+  (x, y, z, f, g) <<.>> (x', y', z', a, b) = (x <> x', y <> y', z <> z', f a, g b)+  {-# INLINE (<<.>>) #-}++instance Biapply Const where+  Const f <<.>> Const x = Const (f x)+  {-# INLINE (<<.>>) #-}++instance Biapply Tagged where+  Tagged f <<.>> Tagged x = Tagged (f x)+  {-# INLINE (<<.>>) #-}++instance (Biapply p, Apply f, Apply g) => Biapply (Biff p f g) where+  Biff fg <<.>> Biff xy = Biff (bimap (<.>) (<.>) fg <<.>> xy)+  {-# INLINE (<<.>>) #-}++instance Apply f => Biapply (Clown f) where+  Clown fg <<.>> Clown xy = Clown (fg <.> xy)+  {-# INLINE (<<.>>) #-}++instance Biapply p => Biapply (Flip p) where+  Flip fg <<.>> Flip xy = Flip (fg <<.>> xy)+  {-# INLINE (<<.>>) #-}++instance Apply g => Biapply (Joker g) where+  Joker fg <<.>> Joker xy = Joker (fg <.> xy)+  {-# INLINE (<<.>>) #-}++-- orphan mess+instance Biapply p => Apply (Join p) where+  Join f <.> Join a = Join (f <<.>> a)+  {-# INLINE (<.>) #-}+  Join a .> Join b = Join (a .>> b)+  {-# INLINE (.>) #-}+  Join a <. Join b = Join (a <<. b)+  {-# INLINE (<.) #-}++instance (Biapply p, Biapply q) => Biapply (Bifunctor.Product p q) where+  Bifunctor.Pair w x <<.>> Bifunctor.Pair y z = Bifunctor.Pair (w <<.>> y) (x <<.>> z)+  {-# INLINE (<<.>>) #-}++instance (Apply f, Biapply p) => Biapply (Tannen f p) where+  Tannen fg <<.>> Tannen xy = Tannen ((<<.>>) <$> fg <.> xy)+  {-# INLINE (<<.>>) #-}++instance Biapply p => Biapply (WrappedBifunctor p) where+  WrapBifunctor fg <<.>> WrapBifunctor xy = WrapBifunctor (fg <<.>> xy)+  {-# INLINE (<<.>>) #-}+
src/Data/Groupoid.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE PolyKinds, Trustworthy #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif  ----------------------------------------------------------------------------- -- |
src/Data/Isomorphism.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE Trustworthy, PolyKinds #-}-+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2011-2015 Edward Kmett@@ -15,9 +17,9 @@   ( Iso(..)   ) where +import Control.Category import Data.Semigroupoid import Data.Groupoid-import Control.Category import Prelude ()  data Iso k a b = Iso { embed :: k a b, project :: k b a }
− src/Data/Semifunctor.hs 
@@ -1,154 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE CPP #-}--#ifdef MIN_VERSION_comonad-#if MIN_VERSION_comonad(3,0,3)-{-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif-#else-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Copyright   :  (C) 2011-2015 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  polykinds----------------------------------------------------------------------------------module Data.Semifunctor-  ( Semifunctor(..)-  , Bi(..)-  , (#)-  , semibimap-  , semifirst-  , semisecond-  , first-  , second-  , WrappedFunctor(..)-  , WrappedTraversable1(..)-  , module Control.Category-  , module Data.Semigroupoid-  , module Data.Semigroupoid.Ob-  , module Data.Semigroupoid.Product-  ) where--import Control.Arrow hiding (first, second, left, right)-import Control.Category-import Control.Monad (liftM)-import Data.Functor.Bind-import Data.Traversable-import Data.Semigroup.Traversable-import Data.Semigroupoid-import Data.Semigroupoid.Dual-import Data.Semigroupoid.Ob-import Data.Semigroupoid.Product-import Prelude hiding ((.),id, mapM)--#ifdef MIN_VERSION_comonad-import Control.Comonad-import Data.Functor.Extend-#ifdef MIN_VERSION_distributive-import Data.Distributive-#endif-#endif---- | Semifunctors map objects to objects, and arrows to arrows preserving connectivity--- as normal functors, but do not purport to preserve identity arrows. We apply them--- to semigroupoids, because those don't even claim to offer identity arrows!-class (Semigroupoid c, Semigroupoid d) => Semifunctor f c d | f c -> d, f d -> c where-  semimap :: c a b -> d (f a) (f b)--data WrappedFunctor f a = WrapFunctor { unwrapFunctor :: f a }--instance Functor f => Semifunctor (WrappedFunctor f) (->) (->) where-  semimap f = WrapFunctor . fmap f . unwrapFunctor--instance (Traversable f, Bind m, Monad m) => Semifunctor (WrappedFunctor f) (Kleisli m) (Kleisli m) where-  semimap (Kleisli f) = Kleisli $ liftM WrapFunctor . mapM f . unwrapFunctor--#if defined(MIN_VERSION_distributive) && defined(MIN_VERSION_comonad)-instance (Distributive f, Extend w) => Semifunctor (WrappedFunctor f) (Cokleisli w) (Cokleisli w) where-  semimap (Cokleisli w) = Cokleisli $ WrapFunctor . cotraverse w . fmap unwrapFunctor-#endif--data WrappedTraversable1 f a = WrapTraversable1 { unwrapTraversable1 :: f a }--instance (Traversable1 f, Bind m) => Semifunctor (WrappedTraversable1 f) (Kleisli m) (Kleisli m) where-  semimap (Kleisli f) = Kleisli $ fmap WrapTraversable1 . traverse1 f . unwrapTraversable1---- | Used to map a more traditional bifunctor into a semifunctor-data Bi p a where-  Bi :: p a b -> Bi p '(a,b)--instance Semifunctor f c d => Semifunctor f (Dual c) (Dual d) where-  semimap (Dual f) = Dual (semimap f)--(#) :: a -> b -> Bi (,) '(a,b)-a # b = Bi (a,b)--#ifdef MIN_VERSION_comonad-fstP :: Bi (,) '(a, b) -> a-fstP (Bi (a,_)) = a--sndP :: Bi (,) '(a, b) -> b-sndP (Bi (_,b)) = b-#endif--left :: a -> Bi Either '(a,b)-left = Bi . Left--right :: b -> Bi Either '(a,b)-right = Bi . Right--instance Semifunctor (Bi (,)) (Product (->) (->)) (->) where-  semimap (Pair l r) (Bi (a,b)) = l a # r b--instance Semifunctor (Bi Either) (Product (->) (->)) (->) where-  semimap (Pair l _) (Bi (Left a)) = Bi (Left (l a))-  semimap (Pair _ r) (Bi (Right b)) = Bi (Right (r b))--instance Bind m => Semifunctor (Bi (,)) (Product (Kleisli m) (Kleisli m)) (Kleisli m) where-  semimap (Pair l r) = Kleisli (\ (Bi (a, b)) -> (#) <$> runKleisli l a <.> runKleisli r b)--instance Bind m => Semifunctor (Bi Either) (Product (Kleisli m) (Kleisli m)) (Kleisli m) where-  semimap (Pair (Kleisli l0) (Kleisli r0)) = Kleisli (lr l0 r0) where-    lr :: Functor m => (a -> m c) -> (b -> m d) -> Bi Either '(a,b) -> m (Bi Either '(c,d))-    lr l _ (Bi (Left a))  = left <$> l a-    lr _ r (Bi (Right b)) = right <$> r b--#ifdef MIN_VERSION_comonad-instance Extend w => Semifunctor (Bi (,)) (Product (Cokleisli w) (Cokleisli w)) (Cokleisli w) where-  semimap (Pair l r) = Cokleisli $ \p -> runCokleisli l (fstP <$> p) # runCokleisli r (sndP <$> p)---- instance Extend w => Semifunctor (Bi Either)) (Product (Cokleisli w) (Cokleisli w)) (Cokleisli w) where-#endif--semibimap :: Semifunctor p (Product l r) cod => l a b -> r c d -> cod (p '(a,c)) (p '(b,d))-semibimap f g = semimap (Pair f g)--semifirst :: (Semifunctor p (Product l r) cod, Ob r c) => l a b -> cod (p '(a,c)) (p '(b,c))-semifirst f = semimap (Pair f semiid)--semisecond :: (Semifunctor p (Product l r) cod, Ob l a) => r b c -> cod (p '(a,b)) (p '(a,c))-semisecond f = semimap (Pair semiid f)--first :: (Semifunctor p (Product l r) cod, Category r) => l a b -> cod (p '(a,c)) (p '(b,c))-first f = semimap (Pair f id)--second :: (Semifunctor p (Product l r) cod, Category l) => r b c -> cod (p '(a,b)) (p '(a,c))-second f = semimap (Pair id f)
− src/Data/Semifunctor/Associative.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Copyright   :  (C) 2011-2015 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  experimental--- Portability :  MPTCs, GADTs---------------------------------------------------------------------------------module Data.Semifunctor.Associative where--import Prelude hiding ((.), id)-import Control.Arrow-import Data.Functor.Bind-import Data.Semifunctor--- import Data.Isomorphism--#ifdef MIN_VERSION_comonad-import Data.Functor.Extend-import Control.Comonad-#endif--class Semifunctor p (Product k k) k => Associative k p where-  associate :: k (p '(p '(a,b) ,c)) (p '(a, p '(b,c)))--instance Associative (->) (Bi Either) where-  associate (Bi (Left (Bi (Left a)))) = Bi (Left a)-  associate (Bi (Left (Bi (Right b)))) = Bi (Right (Bi (Left b)))-  associate (Bi (Right c)) = Bi (Right (Bi (Right c)))--instance Associative (->) (Bi (,)) where-  associate (Bi (Bi (a,b),c)) = Bi(a, Bi(b, c))--kleisliAssociate :: (Monad m, Semifunctor p (Product (Kleisli m) (Kleisli m)) (Kleisli m), Associative (->) p) => Kleisli m (p '(p '(a,b),c)) (p '(a,p '(b,c)))-kleisliAssociate = Kleisli (return . associate)--instance (Bind m, Monad m) => Associative (Kleisli m) (Bi Either) where-  associate = kleisliAssociate--instance (Bind m, Monad m) => Associative (Kleisli m) (Bi (,)) where-  associate = kleisliAssociate--#ifdef MIN_VERSION_comonad-cokleisliAssociate :: (Comonad m, Semifunctor p (Product (Cokleisli m) (Cokleisli m)) (Cokleisli m), Associative (->) p) => Cokleisli m (p '(p '(a,b),c)) (p '(a,p '(b,c)))-cokleisliAssociate = Cokleisli (associate . extract)--instance (Extend m, Comonad m) => Associative (Cokleisli m) (Bi (,)) where-  associate = cokleisliAssociate---- instance Comonad m => Associative (Cokleisli m) (Bi Either) where associate = cokleisliAssociate-#endif---- instance Disassociative k p => Associative (Dual k) p--- instance (Monad m, Semifunctor p (Product (Kleisli m) (Kleisli m) (Kleisli m), Associative (->) p) => Associative (Kleisli m) p) where associate = kleisliAssociate--class Semifunctor p (Product k k) k => Disassociative k p where-  disassociate :: k (p '(a,p '(b,c))) (p '(p '(a,b),c))--instance Disassociative (->) (Bi Either) where-  disassociate (Bi (Left a)) = Bi (Left (Bi (Left a)))-  disassociate (Bi (Right (Bi (Left b)))) = Bi (Left (Bi (Right b)))-  disassociate (Bi (Right (Bi (Right b)))) = Bi (Right b)--instance Disassociative (->) (Bi (,)) where-  disassociate (Bi(a, Bi(b, c))) = Bi (Bi (a,b),c)--kleisliDisassociate :: (Monad m, Semifunctor p (Product (Kleisli m) (Kleisli m)) (Kleisli m), Disassociative (->) p) => Kleisli m (p '(a,p '(b,c))) (p '(p '(a,b),c))-kleisliDisassociate = Kleisli (return . disassociate)--instance (Bind m, Monad m) => Disassociative (Kleisli m) (Bi Either) where-  disassociate = kleisliDisassociate--instance (Bind m, Monad m) => Disassociative (Kleisli m) (Bi (,)) where-  disassociate = kleisliDisassociate--#ifdef MIN_VERSION_comonad-cokleisliDisassociate :: (Comonad m, Semifunctor p (Product (Cokleisli m) (Cokleisli m)) (Cokleisli m), Disassociative (->) p) => Cokleisli m (p '(a,p '(b,c))) (p '(p '(a,b),c))-cokleisliDisassociate = Cokleisli (disassociate . extract)--instance (Extend m, Comonad m) => Disassociative (Cokleisli m) (Bi (,)) where-  disassociate = cokleisliDisassociate-#endif----  instance Associative k p => Disassociative (Dual k) p---- instance (Associative k p, Disassociative k p) => Associative (Iso k) p where---  associate = Iso associate disassociate----instance (Associative k p, Disassociative k p) => Disassociative (Iso k) p where---  disassociate = Iso disassociate associate
− src/Data/Semifunctor/Braided.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE DataKinds #-}--#ifdef MIN_VERSION_comonad-#if MIN_VERSION_comonad(3,0,3)-{-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif-#else-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Copyright   :  (C) 2011-2015 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  experimental--- Portability :  MPTCs, GADTs---------------------------------------------------------------------------------module Data.Semifunctor.Braided-  ( Braided(..)-  , kleisliBraid-#ifdef MIN_VERSION_comonad-  , cokleisliBraid-#endif-  , Symmetric-  , swap-  ) where--import Prelude hiding ((.), id)-import Control.Arrow-import Data.Functor.Bind-import Data.Semifunctor-import Data.Semifunctor.Associative--- import Data.Semigroupoid.Dual--#ifdef MIN_VERSION_comonad-import Control.Comonad-import Data.Functor.Extend-#endif--class Associative k p => Braided k p where-  braid :: k (p '(a,b)) (p '(b,a))---- instance Braided k p => Braided (Dual k) p where braid = Dual braid--instance Braided (->) (Bi Either) where-  braid (Bi (Left a)) = Bi (Right a)-  braid (Bi (Right a)) = Bi (Left a)--instance Braided (->) (Bi (,)) where-  braid (Bi (a,b)) = Bi (b,a)--kleisliBraid :: (Monad m, Semifunctor p (Product (Kleisli m) (Kleisli m)) (Kleisli m), Braided (->) p) => Kleisli m (p '(a,b)) (p '(b,a))-kleisliBraid = Kleisli (return . braid)--instance (Bind m, Monad m) => Braided (Kleisli m) (Bi Either) where-  braid = kleisliBraid--instance (Bind m, Monad m) => Braided (Kleisli m) (Bi (,)) where-  braid = kleisliBraid--#ifdef MIN_VERSION_comonad-cokleisliBraid :: (Extend w, Comonad w, Semifunctor p (Product (Cokleisli w) (Cokleisli w)) (Cokleisli w), Braided (->) p) =>-                  Cokleisli w (p '(a,b)) (p '(b,a))-cokleisliBraid = Cokleisli (braid . extract)--instance (Extend w, Comonad w) => Braided (Cokleisli w) (Bi (,)) where-  braid = cokleisliBraid---- instance Comonad w => Braided (Cokleisli w) (Bi Either) where braid = cokleisliBraid-#endif--class Braided k p => Symmetric k p-instance Symmetric (->) (Bi Either)-instance Symmetric (->) (Bi (,))-instance (Bind m, Monad m) => Symmetric (Kleisli m) (Bi Either)-instance (Bind m, Monad m) => Symmetric (Kleisli m) (Bi (,))-#ifdef MIN_VERSION_comonad-instance (Extend w, Comonad w) => Symmetric (Cokleisli w) (Bi (,))--- instance Comonad w => Symmetric (Cokleisli w) (Bi Either)-#endif--swap :: Symmetric k p => k (p '(a,b)) (p '(b,a))-swap = braid
+ src/Data/Semigroup/Bifoldable.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2011-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+----------------------------------------------------------------------------+module Data.Semigroup.Bifoldable+  ( Bifoldable1(..)+  , bitraverse1_+  , bifor1_+  , bisequenceA1_+  , bifoldMapDefault1+  ) where++import Control.Applicative+import Data.Bifoldable+import Data.Functor.Apply+import Data.Semigroup+import Data.Semigroup.Foldable.Class+import Prelude hiding (foldr)++newtype Act f a = Act { getAct :: f a }++instance Apply f => Semigroup (Act f a) where+  Act a <> Act b = Act (a .> b)+  {-# INLINE (<>) #-}++instance Functor f => Functor (Act f) where+  fmap f (Act a) = Act (f <$> a)+  {-# INLINE fmap #-}+  b <$ Act a = Act (b <$ a)+  {-# INLINE (<$) #-}++bitraverse1_ :: (Bifoldable1 t, Apply f) => (a -> f b) -> (c -> f d) -> t a c -> f ()+bitraverse1_ f g t = getAct (bifoldMap1 (Act . ignore . f) (Act . ignore . g) t)+{-# INLINE bitraverse1_ #-}++bifor1_ :: (Bifoldable1 t, Apply f) => t a c -> (a -> f b) -> (c -> f d) -> f ()+bifor1_ t f g = bitraverse1_ f g t+{-# INLINE bifor1_ #-}++ignore :: Functor f => f a -> f ()+ignore = (() <$)+{-# INLINE ignore #-}++bisequenceA1_ :: (Bifoldable1 t, Apply f) => t (f a) (f b) -> f ()+bisequenceA1_ t = getAct (bifoldMap1 (Act . ignore) (Act . ignore) t)+{-# INLINE bisequenceA1_ #-}++-- | Usable default for foldMap, but only if you define bifoldMap1 yourself+bifoldMapDefault1 :: (Bifoldable1 t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m+bifoldMapDefault1 f g = unwrapMonoid . bifoldMap (WrapMonoid . f) (WrapMonoid . g)+{-# INLINE bifoldMapDefault1 #-}
+ src/Data/Semigroup/Bitraversable.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2011-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+----------------------------------------------------------------------------+module Data.Semigroup.Bitraversable+  ( Bitraversable1(..)+  , bifoldMap1Default+  ) where++import Control.Applicative+import Data.Semigroup+import Data.Semigroup.Traversable.Class++bifoldMap1Default :: (Bitraversable1 t, Semigroup m) => (a -> m) -> (b -> m) -> t a b -> m+bifoldMap1Default f g = getConst . bitraverse1 (Const . f) (Const . g)+{-# INLINE bifoldMap1Default #-}
src/Data/Semigroup/Foldable.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2011-2015 Edward Kmett@@ -20,80 +19,16 @@   , asum1   ) where -import Control.Applicative.Backwards-import Control.Applicative.Lift-import Control.Monad.Trans.Identity import Data.Foldable import Data.Functor.Alt (Alt(..)) import Data.Functor.Apply-import Data.Functor.Compose-import Data.Functor.Identity-import Data.Functor.Product-import Data.Functor.Reverse-import Data.Functor.Sum-import Data.List.NonEmpty (NonEmpty(..)) import Data.Traversable.Instances () import Data.Semigroup hiding (Product, Sum)+import Data.Semigroup.Foldable.Class import Prelude hiding (foldr) -#ifdef MIN_VERSION_containers-import Data.Tree-#endif--#ifdef MIN_VERSION_comonad-import Data.Functor.Coproduct-#endif--class Foldable t => Foldable1 t where-  fold1 :: Semigroup m => t m -> m-  foldMap1 :: Semigroup m => (a -> m) -> t a -> m--  foldMap1 f = maybe (error "foldMap1") id . getOption . foldMap (Option . Just . f)-  fold1 = foldMap1 id--#ifdef MIN_VERSION_containers-instance Foldable1 Tree where-  foldMap1 f (Node a []) = f a-  foldMap1 f (Node a (x:xs)) = f a <> foldMap1 (foldMap1 f) (x :| xs)-#endif--instance Foldable1 Identity where-  foldMap1 f = f . runIdentity--instance Foldable1 m => Foldable1 (IdentityT m) where-  foldMap1 f = foldMap1 f . runIdentityT--instance Foldable1 f => Foldable1 (Backwards f) where-  foldMap1 f = foldMap1 f . forwards--instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where-  foldMap1 f = foldMap1 (foldMap1 f) . getCompose--instance Foldable1 f => Foldable1 (Lift f) where-  foldMap1 f (Pure x)  = f x-  foldMap1 f (Other y) = foldMap1 f y--instance (Foldable1 f, Foldable1 g) => Foldable1 (Product f g) where-  foldMap1 f (Pair a b) = foldMap1 f a <> foldMap1 f b--instance Foldable1 f => Foldable1 (Reverse f) where-  foldMap1 f = getDual . foldMap1 (Dual . f) . getReverse--instance (Foldable1 f, Foldable1 g) => Foldable1 (Sum f g) where-  foldMap1 f (InL x) = foldMap1 f x-  foldMap1 f (InR y) = foldMap1 f y--#ifdef MIN_VERSION_comonad-instance (Foldable1 f, Foldable1 g) => Foldable1 (Coproduct f g) where-  foldMap1 f = coproduct (foldMap1 f) (foldMap1 f)-#endif--instance Foldable1 NonEmpty where-  foldMap1 f (a :| []) = f a-  foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs)--instance Foldable1 ((,) a) where-  foldMap1 f (_, x) = f x+-- $setup+-- >>> import Data.List.NonEmpty  newtype JoinWith a = JoinWith {joinee :: (a -> a)}
+ src/Data/Semigroup/Foldable/Class.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE CPP #-}++#ifndef MIN_VERSION_semigroups+#define MIN_VERSION_semigroups(x,y,z) 0+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2011-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+----------------------------------------------------------------------------+module Data.Semigroup.Foldable.Class+  ( Foldable1(..)+  , Bifoldable1(..)+  ) where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Applicative.Lift+import Control.Monad.Trans.Identity+import Data.Bifoldable+import Data.Bifunctor.Biff+import Data.Bifunctor.Clown+import Data.Bifunctor.Flip+import Data.Bifunctor.Join+import Data.Bifunctor.Product as Bifunctor+import Data.Bifunctor.Joker+import Data.Bifunctor.Tannen+import Data.Bifunctor.Wrapped+import Data.Foldable+import Data.Functor.Compose++#ifdef MIN_VERSION_comonad+import Data.Functor.Coproduct+#endif++import Data.Functor.Identity+import Data.Functor.Product as Functor+import Data.Functor.Reverse+import Data.Functor.Sum+import Data.List.NonEmpty (NonEmpty(..))+import Data.Tagged+import Data.Traversable.Instances ()++#ifdef MIN_VERSION_containers+import Data.Tree+#endif++import Data.Semigroup hiding (Product, Sum)+import Prelude hiding (foldr)++class Foldable t => Foldable1 t where+  fold1 :: Semigroup m => t m -> m+  foldMap1 :: Semigroup m => (a -> m) -> t a -> m++  foldMap1 f = maybe (error "foldMap1") id . getOption . foldMap (Option . Just . f)+  fold1 = foldMap1 id++class Bifoldable t => Bifoldable1 t where+  bifold1 :: Semigroup m => t m m -> m+  bifold1 = bifoldMap1 id id+  {-# INLINE bifold1 #-}++  bifoldMap1 :: Semigroup m => (a -> m) -> (b -> m) -> t a b -> m+  bifoldMap1 f g = maybe (error "bifoldMap1") id . getOption . bifoldMap (Option . Just . f) (Option . Just . g)+  {-# INLINE bifoldMap1 #-}++#if MIN_VERSION_semigroups(0,16,2)+instance Bifoldable1 Arg where+  bifoldMap1 f g (Arg a b) = f a <> g b+#endif++instance Bifoldable1 Either where+  bifoldMap1 f _ (Left a) = f a+  bifoldMap1 _ g (Right b) = g b+  {-# INLINE bifoldMap1 #-}++instance Bifoldable1 (,) where+  bifoldMap1 f g (a, b) = f a <> g b+  {-# INLINE bifoldMap1 #-}++instance Bifoldable1 ((,,) x) where+  bifoldMap1 f g (_,a,b) = f a <> g b+  {-# INLINE bifoldMap1 #-}++instance Bifoldable1 ((,,,) x y) where+  bifoldMap1 f g (_,_,a,b) = f a <> g b+  {-# INLINE bifoldMap1 #-}++instance Bifoldable1 ((,,,,) x y z) where+  bifoldMap1 f g (_,_,_,a,b) = f a <> g b+  {-# INLINE bifoldMap1 #-}++instance Bifoldable1 Const where+  bifoldMap1 f _ (Const a) = f a+  {-# INLINE bifoldMap1 #-}++instance Bifoldable1 Tagged where+  bifoldMap1 _ g (Tagged b) = g b+  {-# INLINE bifoldMap1 #-}++instance (Bifoldable1 p, Foldable1 f, Foldable1 g) => Bifoldable1 (Biff p f g) where+  bifoldMap1 f g = bifoldMap1 (foldMap1 f) (foldMap1 g) . runBiff+  {-# INLINE bifoldMap1 #-}++instance Foldable1 f => Bifoldable1 (Clown f) where+  bifoldMap1 f _ = foldMap1 f . runClown+  {-# INLINE bifoldMap1 #-}++instance Bifoldable1 p => Bifoldable1 (Flip p) where+  bifoldMap1 f g = bifoldMap1 g f . runFlip+  {-# INLINE bifoldMap1 #-}++instance Bifoldable1 p => Foldable1 (Join p) where+  foldMap1 f (Join a) = bifoldMap1 f f a+  {-# INLINE foldMap1 #-}++instance Foldable1 g => Bifoldable1 (Joker g) where+  bifoldMap1 _ g = foldMap1 g . runJoker+  {-# INLINE bifoldMap1 #-}++instance (Bifoldable1 f, Bifoldable1 g) => Bifoldable1 (Bifunctor.Product f g) where+  bifoldMap1 f g (Bifunctor.Pair x y) = bifoldMap1 f g x <> bifoldMap1 f g y+  {-# INLINE bifoldMap1 #-}++instance (Foldable1 f, Bifoldable1 p) => Bifoldable1 (Tannen f p) where+  bifoldMap1 f g = foldMap1 (bifoldMap1 f g) . runTannen+  {-# INLINE bifoldMap1 #-}++instance Bifoldable1 p => Bifoldable1 (WrappedBifunctor p) where+  bifoldMap1 f g = bifoldMap1 f g . unwrapBifunctor+  {-# INLINE bifoldMap1 #-}++#ifdef MIN_VERSION_containers+instance Foldable1 Tree where+  foldMap1 f (Node a []) = f a+  foldMap1 f (Node a (x:xs)) = f a <> foldMap1 (foldMap1 f) (x :| xs)+#endif++instance Foldable1 Identity where+  foldMap1 f = f . runIdentity++instance Foldable1 m => Foldable1 (IdentityT m) where+  foldMap1 f = foldMap1 f . runIdentityT++instance Foldable1 f => Foldable1 (Backwards f) where+  foldMap1 f = foldMap1 f . forwards++instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where+  foldMap1 f = foldMap1 (foldMap1 f) . getCompose++instance Foldable1 f => Foldable1 (Lift f) where+  foldMap1 f (Pure x)  = f x+  foldMap1 f (Other y) = foldMap1 f y++instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Product f g) where+  foldMap1 f (Functor.Pair a b) = foldMap1 f a <> foldMap1 f b++instance Foldable1 f => Foldable1 (Reverse f) where+  foldMap1 f = getDual . foldMap1 (Dual . f) . getReverse++instance (Foldable1 f, Foldable1 g) => Foldable1 (Sum f g) where+  foldMap1 f (InL x) = foldMap1 f x+  foldMap1 f (InR y) = foldMap1 f y++#ifdef MIN_VERSION_comonad+instance (Foldable1 f, Foldable1 g) => Foldable1 (Coproduct f g) where+  foldMap1 f = coproduct (foldMap1 f) (foldMap1 f)+#endif++instance Foldable1 NonEmpty where+  foldMap1 f (a :| []) = f a+  foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs)++instance Foldable1 ((,) a) where+  foldMap1 f (_, x) = f x++instance Foldable1 g => Foldable1 (Joker g a) where+  foldMap1 g = foldMap1 g . runJoker+  {-# INLINE foldMap1 #-}
src/Data/Semigroup/Traversable.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2011-2015 Edward Kmett@@ -15,85 +14,8 @@   ) where  import Control.Applicative-import Control.Applicative.Backwards-import Control.Applicative.Lift-import Control.Monad.Trans.Identity-import Data.Functor.Apply-import Data.Functor.Compose-import Data.Functor.Identity-import Data.Functor.Product-import Data.Functor.Reverse-import Data.Functor.Sum-import Data.List.NonEmpty (NonEmpty(..))-import Data.Semigroup hiding (Product, Sum)-import Data.Semigroup.Foldable-import Data.Traversable-import Data.Traversable.Instances ()--#ifdef MIN_VERSION_containers-import Data.Tree-#endif--#ifdef MIN_VERSION_comonad-import Data.Functor.Coproduct-#endif--class (Foldable1 t, Traversable t) => Traversable1 t where-  traverse1 :: Apply f => (a -> f b) -> t a -> f (t b)-  sequence1 :: Apply f => t (f b) -> f (t b)--  sequence1 = traverse1 id-  traverse1 f = sequence1 . fmap f--#if __GLASGOW_HASKELL__ >= 708-  {-# MINIMAL traverse1 | sequence1 #-}-#endif+import Data.Semigroup+import Data.Semigroup.Traversable.Class  foldMap1Default :: (Traversable1 f, Semigroup m) => (a -> m) -> f a -> m foldMap1Default f = getConst . traverse1 (Const . f)--instance Traversable1 Identity where-  traverse1 f = fmap Identity . f . runIdentity--instance Traversable1 f => Traversable1 (IdentityT f) where-  traverse1 f = fmap IdentityT . traverse1 f . runIdentityT--instance Traversable1 f => Traversable1 (Backwards f) where-  traverse1 f = fmap Backwards . traverse1 f . forwards--instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where-  traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose--instance Traversable1 f => Traversable1 (Lift f) where-  traverse1 f (Pure x)  = Pure <$> f x-  traverse1 f (Other y) = Other <$> traverse1 f y--instance (Traversable1 f, Traversable1 g) => Traversable1 (Product f g) where-  traverse1 f (Pair a b) = Pair <$> traverse1 f a <.> traverse1 f b--instance Traversable1 f => Traversable1 (Reverse f) where-  traverse1 f = fmap Reverse . forwards . traverse1 (Backwards . f) . getReverse--instance (Traversable1 f, Traversable1 g) => Traversable1 (Sum f g) where-  traverse1 f (InL x) = InL <$> traverse1 f x-  traverse1 f (InR y) = InR <$> traverse1 f y--#ifdef MIN_VERSION_comonad-instance (Traversable1 f, Traversable1 g) => Traversable1 (Coproduct f g) where-  traverse1 f = coproduct-    (fmap (Coproduct . Left) . traverse1 f)-    (fmap (Coproduct . Right) . traverse1 f)-#endif--#ifdef MIN_VERSION_containers-instance Traversable1 Tree where-  traverse1 f (Node a []) = (`Node`[]) <$> f a-  traverse1 f (Node a (x:xs)) = (\b (y:|ys) -> Node b (y:ys)) <$> f a <.> traverse1 (traverse1 f) (x :| xs)-#endif--instance Traversable1 NonEmpty where-  traverse1 f (a :| []) = (:|[]) <$> f a-  traverse1 f (a :| (b: bs)) = (\a' (b':| bs') -> a' :| b': bs') <$> f a <.> traverse1 f (b :| bs)--instance Traversable1 ((,) a) where-  traverse1 f (a, b) = (,) a <$> f b
+ src/Data/Semigroup/Traversable/Class.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2011-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+----------------------------------------------------------------------------+module Data.Semigroup.Traversable.Class+  ( Bitraversable1(..)+  , Traversable1(..)+  ) where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Applicative.Lift+import Control.Monad.Trans.Identity+import Data.Bitraversable+import Data.Bifunctor+import Data.Bifunctor.Biff+import Data.Bifunctor.Clown+import Data.Bifunctor.Flip+import Data.Bifunctor.Joker+import Data.Bifunctor.Join+import Data.Bifunctor.Product as Bifunctor+import Data.Bifunctor.Tannen+import Data.Bifunctor.Wrapped+import Data.Functor.Apply+import Data.Functor.Compose++#ifdef MIN_VERSION_comonad+import Data.Functor.Coproduct as Functor+#endif++import Data.Functor.Identity+import Data.Functor.Product as Functor+import Data.Functor.Reverse+import Data.Functor.Sum as Functor+import Data.List.NonEmpty (NonEmpty(..))+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Bifoldable+import Data.Tagged+import Data.Traversable+import Data.Traversable.Instances ()++#ifdef MIN_VERSION_containers+import Data.Tree+#endif++class (Bifoldable1 t, Bitraversable t) => Bitraversable1 t where+  bitraverse1 :: Apply f => (a -> f b) -> (c -> f d) -> t a c -> f (t b d)+  bitraverse1 f g  = bisequence1 . bimap f g+  {-# INLINE bitraverse1 #-}++  bisequence1 :: Apply f => t (f a) (f b) -> f (t a b)+  bisequence1 = bitraverse1 id id+  {-# INLINE bisequence1 #-}++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+  {-# MINIMAL bitraverse1 | bisequence1 #-}+#endif++#if MIN_VERSION_semigroups(0,16,2)+instance Bitraversable1 Arg where+  bitraverse1 f g (Arg a b) = Arg <$> f a <.> g b+#endif++instance Bitraversable1 Either where+  bitraverse1 f _ (Left a) = Left <$> f a+  bitraverse1 _ g (Right b) = Right <$> g b+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 (,) where+  bitraverse1 f g (a, b) = (,) <$> f a <.> g b+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 ((,,) x) where+  bitraverse1 f g (x, a, b) = (,,) x <$> f a <.> g b+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 ((,,,) x y) where+  bitraverse1 f g (x, y, a, b) = (,,,) x y <$> f a <.> g b+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 ((,,,,) x y z) where+  bitraverse1 f g (x, y, z, a, b) = (,,,,) x y z <$> f a <.> g b+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 Const where+  bitraverse1 f _ (Const a) = Const <$> f a+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 Tagged where+  bitraverse1 _ g (Tagged b) = Tagged <$> g b+  {-# INLINE bitraverse1 #-}++instance (Bitraversable1 p, Traversable1 f, Traversable1 g) => Bitraversable1 (Biff p f g) where+  bitraverse1 f g = fmap Biff . bitraverse1 (traverse1 f) (traverse1 g) . runBiff+  {-# INLINE bitraverse1 #-}++instance Traversable1 f => Bitraversable1 (Clown f) where+  bitraverse1 f _ = fmap Clown . traverse1 f . runClown+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 p => Bitraversable1 (Flip p) where+  bitraverse1 f g = fmap Flip . bitraverse1 g f . runFlip+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 p => Traversable1 (Join p) where+  traverse1 f (Join a) = fmap Join (bitraverse1 f f a)+  {-# INLINE traverse1 #-}+  sequence1 (Join a) = fmap Join (bisequence1 a)+  {-# INLINE sequence1 #-}++instance Traversable1 g => Bitraversable1 (Joker g) where+  bitraverse1 _ g = fmap Joker . traverse1 g . runJoker+  {-# INLINE bitraverse1 #-}++instance (Bitraversable1 f, Bitraversable1 g) => Bitraversable1 (Bifunctor.Product f g) where+  bitraverse1 f g (Bifunctor.Pair x y) = Bifunctor.Pair <$> bitraverse1 f g x <.> bitraverse1 f g y+  {-# INLINE bitraverse1 #-}++instance (Traversable1 f, Bitraversable1 p) => Bitraversable1 (Tannen f p) where+  bitraverse1 f g = fmap Tannen . traverse1 (bitraverse1 f g) . runTannen+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 p => Bitraversable1 (WrappedBifunctor p) where+  bitraverse1 f g = fmap WrapBifunctor . bitraverse1 f g . unwrapBifunctor+  {-# INLINE bitraverse1 #-}++class (Foldable1 t, Traversable t) => Traversable1 t where+  traverse1 :: Apply f => (a -> f b) -> t a -> f (t b)+  sequence1 :: Apply f => t (f b) -> f (t b)++  sequence1 = traverse1 id+  traverse1 f = sequence1 . fmap f++#if __GLASGOW_HASKELL__ >= 708+  {-# MINIMAL traverse1 | sequence1 #-}+#endif++instance Traversable1 Identity where+  traverse1 f = fmap Identity . f . runIdentity++instance Traversable1 f => Traversable1 (IdentityT f) where+  traverse1 f = fmap IdentityT . traverse1 f . runIdentityT++instance Traversable1 f => Traversable1 (Backwards f) where+  traverse1 f = fmap Backwards . traverse1 f . forwards++instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where+  traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose++instance Traversable1 f => Traversable1 (Lift f) where+  traverse1 f (Pure x)  = Pure <$> f x+  traverse1 f (Other y) = Other <$> traverse1 f y++instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Product f g) where+  traverse1 f (Functor.Pair a b) = Functor.Pair <$> traverse1 f a <.> traverse1 f b++instance Traversable1 f => Traversable1 (Reverse f) where+  traverse1 f = fmap Reverse . forwards . traverse1 (Backwards . f) . getReverse++instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Sum f g) where+  traverse1 f (Functor.InL x) = Functor.InL <$> traverse1 f x+  traverse1 f (Functor.InR y) = Functor.InR <$> traverse1 f y++#ifdef MIN_VERSION_comonad+instance (Traversable1 f, Traversable1 g) => Traversable1 (Coproduct f g) where+  traverse1 f = coproduct+    (fmap (Coproduct . Left) . traverse1 f)+    (fmap (Coproduct . Right) . traverse1 f)+#endif++#ifdef MIN_VERSION_containers+instance Traversable1 Tree where+  traverse1 f (Node a []) = (`Node`[]) <$> f a+  traverse1 f (Node a (x:xs)) = (\b (y:|ys) -> Node b (y:ys)) <$> f a <.> traverse1 (traverse1 f) (x :| xs)+#endif++instance Traversable1 NonEmpty where+  traverse1 f (a :| []) = (:|[]) <$> f a+  traverse1 f (a :| (b: bs)) = (\a' (b':| bs') -> a' :| b': bs') <$> f a <.> traverse1 f (b :| bs)++instance Traversable1 ((,) a) where+  traverse1 f (a, b) = (,) a <$> f b++instance Traversable1 g => Traversable1 (Joker g a) where+  traverse1 g = fmap Joker . traverse1 g . runJoker+  {-# INLINE traverse1 #-}
src/Data/Semigroupoid.hs view
@@ -1,16 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PolyKinds #-}-#ifdef MIN_VERSION_comonad-#if __GLASGOW_HASKELL__ >= 707 && (MIN_VERSION_comonad(3,0,3)) {-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif-#else-{-# LANGUAGE Trustworthy #-}-#endif-- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Semigroupoid
− src/Data/Semigroupoid/Coproduct.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE CPP, GADTs, EmptyDataDecls, PolyKinds, DataKinds #-}--------------------------------------------------------------------------------- |--- Copyright   :  (C) 2011-2015 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  portable----------------------------------------------------------------------------------module Data.Semigroupoid.Coproduct-  ( Coproduct(..), distributeDualCoproduct, factorDualCoproduct) where--import Data.Semigroupoid-import Data.Semigroupoid.Dual-import Data.Groupoid--data Coproduct j k a b where-  L :: j a b -> Coproduct j k (Left a) (Left b)-  R :: k a b -> Coproduct j k (Right a) (Right b)--instance (Semigroupoid j, Semigroupoid k) => Semigroupoid (Coproduct j k) where-  L f `o` L g = L (f `o` g)-  R f `o` R g = R (f `o` g)-  _ `o` _ = error "GADT fail"--instance (Groupoid j, Groupoid k) => Groupoid (Coproduct j k) where-  inv (L f) = L (inv f)-  inv (R f) = R (inv f)--distributeDualCoproduct :: Dual (Coproduct j k) a b -> Coproduct (Dual j) (Dual k) a b-distributeDualCoproduct (Dual (L l)) = L (Dual l)-distributeDualCoproduct (Dual (R r)) = R (Dual r)--factorDualCoproduct :: Coproduct (Dual j) (Dual k) a b -> Dual (Coproduct j k) a b-factorDualCoproduct (L (Dual l)) = Dual (L l)-factorDualCoproduct (R (Dual r)) = Dual (R r)
src/Data/Semigroupoid/Dual.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}+#endif ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2007-2015 Edward Kmett
src/Data/Semigroupoid/Ob.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2011-2015 Edward Kmett@@ -17,8 +18,6 @@ module Data.Semigroupoid.Ob where  import Data.Semigroupoid-import Data.Semigroupoid.Product-import Data.Semigroupoid.Coproduct import Data.Functor.Bind import Control.Arrow @@ -31,18 +30,8 @@ class Semigroupoid k => Ob k a where   semiid :: k a a -instance (Ob l a, Ob r b) => Ob (Product l r) '(a,b) where-  semiid = Pair semiid semiid--instance (Ob l a, Semigroupoid r)  => Ob (Coproduct l r) (Left a) where-  semiid = L semiid--instance (Semigroupoid l, Ob r a) => Ob (Coproduct l r) (Right a) where-  semiid = R semiid- instance (Bind m, Monad m) => Ob (Kleisli m) a where   semiid = Kleisli return-  #ifdef MIN_VERSION_comonad instance (Extend w, Comonad w) => Ob (Cokleisli w) a where
− src/Data/Semigroupoid/Product.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE GADTs, PolyKinds, DataKinds #-}--------------------------------------------------------------------------------- |--- Copyright   :  (C) 2011-2015 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  polykinds----------------------------------------------------------------------------------module Data.Semigroupoid.Product-  ( Product(..)-  , distributeDualProduct-  , factorDualProduct-  ) where--import Data.Semigroupoid-import Data.Semigroupoid.Dual-import Data.Groupoid--data Product j k a b where-  Pair :: j a b -> k a' b' -> Product j k '(a,a') '(b,b')--instance (Semigroupoid j, Semigroupoid k) => Semigroupoid (Product j k) where-  Pair w x `o` Pair y z = Pair (w `o` y) (x `o` z)--instance (Groupoid j, Groupoid k) => Groupoid (Product j k) where-  inv (Pair w x) = Pair (inv w) (inv x)--distributeDualProduct :: Dual (Product j k) a b -> Product (Dual j) (Dual k) a b-distributeDualProduct (Dual (Pair l r)) = Pair (Dual l) (Dual r)--factorDualProduct :: Product (Dual j) (Dual k) a b -> Dual (Product j k) a b-factorDualProduct (Pair (Dual l) (Dual r)) = Dual (Pair l r)-