diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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" diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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 diff --git a/semigroupoids.cabal b/semigroupoids.cabal --- a/semigroupoids.cabal +++ b/semigroupoids.cabal @@ -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 diff --git a/src/Data/Bifunctor/Apply.hs b/src/Data/Bifunctor/Apply.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/Apply.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 #-} diff --git a/src/Data/Functor/Apply.hs b/src/Data/Functor/Apply.hs --- a/src/Data/Functor/Apply.hs +++ b/src/Data/Functor/Apply.hs @@ -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 #-} + diff --git a/src/Data/Functor/Bind.hs b/src/Data/Functor/Bind.hs --- a/src/Data/Functor/Bind.hs +++ b/src/Data/Functor/Bind.hs @@ -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 diff --git a/src/Data/Functor/Bind/Class.hs b/src/Data/Functor/Bind/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Bind/Class.hs @@ -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 +-- 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 (<<.>>) #-} + diff --git a/src/Data/Groupoid.hs b/src/Data/Groupoid.hs --- a/src/Data/Groupoid.hs +++ b/src/Data/Groupoid.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE PolyKinds, Trustworthy #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/src/Data/Isomorphism.hs b/src/Data/Isomorphism.hs --- a/src/Data/Isomorphism.hs +++ b/src/Data/Isomorphism.hs @@ -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 } diff --git a/src/Data/Semifunctor.hs b/src/Data/Semifunctor.hs deleted file mode 100644 --- a/src/Data/Semifunctor.hs +++ /dev/null @@ -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 --- 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) diff --git a/src/Data/Semifunctor/Associative.hs b/src/Data/Semifunctor/Associative.hs deleted file mode 100644 --- a/src/Data/Semifunctor/Associative.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Semifunctor/Braided.hs b/src/Data/Semifunctor/Braided.hs deleted file mode 100644 --- a/src/Data/Semifunctor/Braided.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Semigroup/Bifoldable.hs b/src/Data/Semigroup/Bifoldable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Bifoldable.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 #-} diff --git a/src/Data/Semigroup/Bitraversable.hs b/src/Data/Semigroup/Bitraversable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Bitraversable.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 #-} diff --git a/src/Data/Semigroup/Foldable.hs b/src/Data/Semigroup/Foldable.hs --- a/src/Data/Semigroup/Foldable.hs +++ b/src/Data/Semigroup/Foldable.hs @@ -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)} diff --git a/src/Data/Semigroup/Foldable/Class.hs b/src/Data/Semigroup/Foldable/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Foldable/Class.hs @@ -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 +-- 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 #-} diff --git a/src/Data/Semigroup/Traversable.hs b/src/Data/Semigroup/Traversable.hs --- a/src/Data/Semigroup/Traversable.hs +++ b/src/Data/Semigroup/Traversable.hs @@ -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 diff --git a/src/Data/Semigroup/Traversable/Class.hs b/src/Data/Semigroup/Traversable/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Traversable/Class.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 #-} diff --git a/src/Data/Semigroupoid.hs b/src/Data/Semigroupoid.hs --- a/src/Data/Semigroupoid.hs +++ b/src/Data/Semigroupoid.hs @@ -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 diff --git a/src/Data/Semigroupoid/Coproduct.hs b/src/Data/Semigroupoid/Coproduct.hs deleted file mode 100644 --- a/src/Data/Semigroupoid/Coproduct.hs +++ /dev/null @@ -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 --- 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) diff --git a/src/Data/Semigroupoid/Dual.hs b/src/Data/Semigroupoid/Dual.hs --- a/src/Data/Semigroupoid/Dual.hs +++ b/src/Data/Semigroupoid/Dual.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} +#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2007-2015 Edward Kmett diff --git a/src/Data/Semigroupoid/Ob.hs b/src/Data/Semigroupoid/Ob.hs --- a/src/Data/Semigroupoid/Ob.hs +++ b/src/Data/Semigroupoid/Ob.hs @@ -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 diff --git a/src/Data/Semigroupoid/Product.hs b/src/Data/Semigroupoid/Product.hs deleted file mode 100644 --- a/src/Data/Semigroupoid/Product.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE GADTs, PolyKinds, DataKinds #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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) -