diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,18 @@ +5.3.6 [2021.10.07] +------------------ +* Allow building with GHC 9.2. +* Allow building with `transformers-0.6.*`. +* Add `Alt` instance for `Identity`. +* Add `Conclude`, `Decide` and `Divise` type classes and instances. +* Add `(<.*>)`, `(<*.>)`, and `traverseMaybe` functions, which make it easier + to defined `Traversable1` instances for data types that have fields with a + combination of `Traversable` and `Traversable1` instances. +* Add `Semigroupoids.Do` module with overloads for use with `QualifiedDo`. +* Add `Apply`, `Alt`, `Plus`, `Bind` and `BindTrans` instances for the CPS + versions of `WriterT` and `RWST`. +* Add `psum` function to `Data.Functor.Plus`. +* Add `Categorical` data type. + 5.3.5 [2020.12.31] ------------------ * The build-type has been changed from `Custom` to `Simple`. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,15 +1,63 @@ semigroupoids -========== +============= [![Hackage](https://img.shields.io/hackage/v/semigroupoids.svg)](https://hackage.haskell.org/package/semigroupoids) [![Build Status](https://github.com/ekmett/semigroupoids/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/semigroupoids/actions?query=workflow%3AHaskell-CI) -A semigroupoid is a `Category` without `id`. +A semigroupoid is a `Category` without `id`. This package provides a range of +`id`-free versions of type classes, as well as some supporting functions and +data types. +Field Guide +----------- + +The diagram below describes the relationships between the type classes defined +in this package, and those from `base` (with some from `contravariant` as well). Thick-bordered +nodes correspond to type classes defined in this package; thin-bordered ones are +from elsewhere. Solid edges represent subclass relationships that actually +exist; dashed edges are those which _should_ exist in theory. + +![A diagram of the relationships between type classes defined in this package and elsewhere.](https://raw.github.com/ekmett/semigroupoids/master/img/classes.svg) + +We also provide the following table. This is structured in superclass order - +thus, for any type class `T`, all superclasses of `T` will be listed before `T` +in the table. + +|**Name**|**Location**|**Superclass of**|**Ideally superclass of**| +|--------|------------|-----------------|-------------------------| +|`Functor`|`base`|`Alt`, `Apply`, `Traversable`|| +|`Foldable`|`base`|`Traversable`, `Foldable1`|| +|`Bifunctor`|`base`|`Biapply`|| +|`Contravariant`|`base`|`Divise`, `Decide`|| +|`Semigroupoid`|`semigroupoids`||`Category`| +|`Alt`|`semigroupoids`|`Plus`|| +|`Apply`|`semigroupoids`|`Bind`|`Applicative`| +|`Traversable`|`base`|`Traversable1`|| +|`Foldable1`|`semigroupoids`|`Traversable1`|| +|`Biapply`|`semigroupoids`||| +|`Divise`|`semigroupoids`||`Divisible`| +|`Decide`|`semigroupoids`|`Conclude`|`Decidable`| +|`Category`|`base`|`Arrow`|| +|`Plus`|`semigroupoids`||`Alternative`| +|`Applicative`|`base`|`Alternative`, `Monad`|| +|`Bind`|`semigroupoids`||`Monad`| +|`Traversable1`|`semigroupoids`||| +|`Divisible`|`contravariant`||| +|`Conclude`|`semigroupoids`||`Decidable`| +|`Arrow`|`base`||| +|`Alternative`|`base`|`MonadPlus`|| +|`Monad`|`base`|`MonadPlus`|| +|`Decidable`|`contravariant`||| +|`MonadPlus`|`base`||| + +We omit some type class relationships from this diagram, as they are not +relevant for the purposes of this package. + Contact Information ------------------- Contributions and bug reports are welcome! -Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. +Please feel free to contact me through Github or on the #haskell IRC channel on +LiberaChat. -Edward Kmett diff --git a/img/classes.dot b/img/classes.dot new file mode 100644 --- /dev/null +++ b/img/classes.dot @@ -0,0 +1,52 @@ +digraph { + node[shape=box]; + functor [label="Functor"]; + foldable [label="Foldable"]; + traversable [label="Traversable"]; + apply [label="Apply", penwidth=2.0]; + bind [label="Bind", penwidth=2.0]; + applicative [label="Applicative"]; + alt [label="Alt", penwidth=2.0]; + plus [label="Plus", penwidth=2.0]; + alternative [label="Alternative"]; + monad [label="Monad"]; + monad_plus [label="MonadPlus"]; + foldable1 [label="Foldable1", penwidth=2.0]; + traversable1 [label="Traversable1", penwidth=2.0]; + bifunctor [label="Bifunctor"]; + biapply [label="Biapply", penwidth=2.0]; + contravariant [label="Contravariant"]; + divise [label="Divise", penwidth=2.0]; + decide [label="Decide", penwidth=2.0]; + divisible [label="Divisible"]; + decidable [label="Decidable"]; + conclude [label="Conclude", penwidth=2.0]; + semigroupoid [label="Semigroupoid", penwidth=2.0]; + category [label="Category"]; + arrow [label="Arrow"]; + functor -> apply; + functor -> alt; + apply -> bind; + apply -> applicative [style=dashed]; + alt -> plus; + plus -> alternative [style=dashed]; + applicative -> alternative; + applicative -> monad; + bind -> monad [style=dashed]; + monad -> monad_plus; + alternative -> monad_plus; + functor -> traversable; + foldable -> traversable; + foldable -> foldable1; + foldable1 -> traversable1; + traversable -> traversable1; + bifunctor -> biapply; + contravariant -> divise; + contravariant -> decide; + divise -> divisible [style=dashed]; + decide -> decidable [style=dashed]; + decide -> conclude; + conclude -> decidable [style=dashed]; + semigroupoid -> category [style=dashed]; + category -> arrow; +} diff --git a/img/classes.svg b/img/classes.svg new file mode 100644 --- /dev/null +++ b/img/classes.svg @@ -0,0 +1,306 @@ + + + + + + + + + +functor + +Functor + + + +traversable + +Traversable + + + +functor->traversable + + + + + +apply + +Apply + + + +functor->apply + + + + + +alt + +Alt + + + +functor->alt + + + + + +foldable + +Foldable + + + +foldable->traversable + + + + + +foldable1 + +Foldable1 + + + +foldable->foldable1 + + + + + +traversable1 + +Traversable1 + + + +traversable->traversable1 + + + + + +bind + +Bind + + + +apply->bind + + + + + +applicative + +Applicative + + + +apply->applicative + + + + + +monad + +Monad + + + +bind->monad + + + + + +alternative + +Alternative + + + +applicative->alternative + + + + + +applicative->monad + + + + + +plus + +Plus + + + +alt->plus + + + + + +plus->alternative + + + + + +monad_plus + +MonadPlus + + + +alternative->monad_plus + + + + + +monad->monad_plus + + + + + +foldable1->traversable1 + + + + + +bifunctor + +Bifunctor + + + +biapply + +Biapply + + + +bifunctor->biapply + + + + + +contravariant + +Contravariant + + + +divise + +Divise + + + +contravariant->divise + + + + + +decide + +Decide + + + +contravariant->decide + + + + + +divisible + +Divisible + + + +divise->divisible + + + + + +decidable + +Decidable + + + +decide->decidable + + + + + +conclude + +Conclude + + + +decide->conclude + + + + + +conclude->decidable + + + + + +semigroupoid + +Semigroupoid + + + +category + +Category + + + +semigroupoid->category + + + + + +arrow + +Arrow + + + +category->arrow + + + + + diff --git a/semigroupoids.cabal b/semigroupoids.cabal --- a/semigroupoids.cabal +++ b/semigroupoids.cabal @@ -1,8 +1,8 @@ name: semigroupoids category: Control, Comonads -version: 5.3.5 -license: BSD3 -cabal-version: >= 1.10 +version: 5.3.6 +license: BSD2 +cabal-version: 1.18 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -20,8 +20,9 @@ , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.3 - , GHC == 8.10.1 + , GHC == 8.8.4 + , GHC == 8.10.4 + , GHC == 9.0.1 build-type: Simple synopsis: Semigroupoids: Category sans id extra-source-files: @@ -29,6 +30,9 @@ .vim.custom README.markdown CHANGELOG.markdown + img/classes.dot +extra-doc-files: + img/classes.svg description: Provides a wide array of (semi)groupoids and operations for working with them. @@ -43,16 +47,14 @@ . Similarly many structures are nearly a comonad, but not quite, for instance lists provide a reasonable 'extend' operation in the form of 'tails', but do not always contain a value. . - Ideally the following relationships would hold: + We describe the relationships between the type classes defined in this package + and those from `base` (and some from `contravariant`) in the diagram below. + Thick-bordered nodes correspond to type classes defined in this package; + thin-bordered ones correspond to type classes from elsewhere. Solid edges + indicate a subclass relationship that actually exists; dashed edges indicate a + subclass relationship that /should/ exist, but currently doesn't. . - > Foldable ----> Traversable <--- Functor ------> Alt ---------> Plus Semigroupoid - > | | | | | - > v v v v v - > Foldable1 ---> Traversable1 Apply --------> Applicative -> Alternative Category - > | | | | - > v v v v - > Bind ---------> Monad -------> MonadPlus Arrow - > + <> . Apply, Bind, and Extend (not shown) give rise the Static, Kleisli and Cokleisli semigroupoids respectively. . @@ -130,8 +132,8 @@ base-orphans >= 0.8.4 && < 1, bifunctors >= 5.5.9 && < 6, template-haskell >= 0.2.5.0, - transformers >= 0.3 && < 0.6, - transformers-compat >= 0.5 && < 0.7 + transformers >= 0.3 && < 0.7, + transformers-compat >= 0.5 && < 0.8 if impl(ghc >= 7.0 && < 7.2) build-depends: generic-deriving >= 1.14 && < 1.15 @@ -139,6 +141,9 @@ if impl(ghc >= 7.2 && < 7.6) build-depends: ghc-prim + if !impl(ghc >= 7.10) + build-depends: void >= 0.4 && < 1 + if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.5 && < 1 @@ -174,6 +179,9 @@ Data.Functor.Bind Data.Functor.Bind.Class Data.Functor.Bind.Trans + Data.Functor.Contravariant.Conclude + Data.Functor.Contravariant.Decide + Data.Functor.Contravariant.Divise Data.Functor.Extend Data.Functor.Plus Data.Groupoid @@ -185,10 +193,14 @@ Data.Semigroup.Traversable Data.Semigroup.Traversable.Class Data.Semigroupoid + Data.Semigroupoid.Categorical Data.Semigroupoid.Dual Data.Semigroupoid.Ob Data.Semigroupoid.Static Data.Traversable.Instances + Semigroupoids.Do + other-modules: + Semigroupoids.Internal ghc-options: -Wall -fno-warn-warnings-deprecations diff --git a/src/Data/Functor/Alt.hs b/src/Data/Functor/Alt.hs --- a/src/Data/Functor/Alt.hs +++ b/src/Data/Functor/Alt.hs @@ -35,11 +35,14 @@ import Control.Exception (catch, SomeException) import Control.Monad import Control.Monad.Trans.Identity -import Control.Monad.Trans.Error import Control.Monad.Trans.Except -import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS +import qualified Control.Monad.Trans.Writer.CPS as CPS +import Semigroupoids.Internal +#endif 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 @@ -49,26 +52,38 @@ import Data.Functor.Apply import Data.Functor.Bind import Data.Functor.Compose +import Data.Functor.Identity (Identity (Identity)) import Data.Functor.Product import Data.Functor.Reverse import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Monoid as Monoid -import Data.Semigroup (Option(..), Semigroup(..)) +import Data.Semigroup (Semigroup(..)) import qualified Data.Semigroup as Semigroup -import Prelude (($),Either(..),Maybe(..),const,IO,Ord,(++),(.),either,seq,undefined) +import Prelude (($),Either(..),Maybe(..),const,IO,(++),(.),either,seq,undefined,repeat) import Unsafe.Coerce +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + +#if MIN_VERSION_base(4,8,0) +import Prelude (mappend) +#else +import Data.Monoid (mappend) +#endif + +#if !(MIN_VERSION_base(4,16,0)) +import Data.Semigroup (Option(..)) +#endif + #ifdef MIN_VERSION_containers import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import Data.Sequence (Seq) import qualified Data.Map as Map import Data.Map (Map) -# if MIN_VERSION_base(4,8,0) -import Prelude (mappend) -# else -import Data.Monoid (mappend) -# endif +import Prelude (Ord) #endif #if defined(MIN_VERSION_tagged) || (MIN_VERSION_base(4,7,0)) @@ -98,18 +113,20 @@ -- -- If extended to an 'Alternative' then '' should equal '<|>'. -- --- Ideally, an instance of 'Alt' also satisfies the \"left distributon\" law of +-- Ideally, an instance of 'Alt' also satisfies the \"left distribution\" law of -- MonadPlus with respect to '<.>': -- -- > <.> right-distributes over : (a b) <.> c = (a <.> c) (b <.> c) -- --- But 'Maybe', 'IO', @'Either' a@, @'ErrorT' e m@, and 'GHC.Conc.STM' satisfy the alternative --- \"left catch\" law instead: +-- 'IO', @'Either' a@, @'ExceptT' e m@ and 'GHC.Conc.STM' instead satisfy the +-- \"left catch\" law: -- -- > pure a b = pure a -- --- However, this variation cannot be stated purely in terms of the dependencies of 'Alt'. +-- 'Maybe' and 'Identity' satisfy both \"left distribution\" and \"left catch\". -- +-- These variations cannot be stated purely in terms of the dependencies of 'Alt'. +-- -- When and if MonadPlus is successfully refactored, this class should also -- be refactored to remove these instances. -- @@ -174,12 +191,22 @@ a _ = a -- | This instance does not actually satisfy the ('<.>') right distributive law --- It instead satisfies the "Left-Catch" law +-- It instead satisfies the \"left catch\" law instance Alt IO where m n = catch m (go n) where go :: x -> SomeException -> x go = const +-- | Choose the first option every time. While \'choose the last option\' every +-- time is also valid, this instance satisfies more laws. +-- +-- @since 5.3.6 +instance Alt Identity where + {-# INLINEABLE () #-} + m _ = m + some (Identity x) = Identity . repeat $ x + many (Identity x) = Identity . repeat $ x + instance Alt [] where () = (++) @@ -187,8 +214,10 @@ Nothing b = b a _ = a +#if !(MIN_VERSION_base(4,16,0)) instance Alt Option where () = (<|>) +#endif instance MonadPlus m => Alt (WrappedMonad m) where () = (<|>) @@ -231,6 +260,7 @@ Nothing -> b Just _ -> return v +#if !(MIN_VERSION_transformers(0,6,0)) instance (Bind f, Monad f) => Alt (ErrorT e f) where ErrorT m ErrorT n = ErrorT $ do a <- m @@ -238,6 +268,10 @@ Left _ -> n Right r -> return (Right r) +instance Apply f => Alt (ListT f) where + ListT a ListT b = ListT $ () <$> a <.> b +#endif + instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f) where ExceptT m ExceptT n = ExceptT $ do a <- m @@ -245,8 +279,6 @@ Left e -> liftM (either (Left . (<>) e) Right) n Right x -> return (Right x) -instance Apply f => Alt (ListT f) where - ListT a ListT b = ListT $ () <$> a <.> b instance Alt f => Alt (Strict.StateT e f) where Strict.StateT m Strict.StateT n = Strict.StateT $ \s -> m s n s @@ -260,11 +292,23 @@ instance Alt f => Alt (Lazy.WriterT w f) where Lazy.WriterT m Lazy.WriterT n = Lazy.WriterT $ m n +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Alt f) => Alt (CPS.WriterT w f) where + m n = mkWriterT $ \w -> unWriterT m w unWriterT n w +#endif + instance Alt f => Alt (Strict.RWST r w s f) where Strict.RWST m Strict.RWST n = Strict.RWST $ \r s -> m r s n r s instance Alt f => Alt (Lazy.RWST r w s f) where Lazy.RWST m Lazy.RWST n = Lazy.RWST $ \r s -> m r s n r s + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Alt f) => Alt (CPS.RWST r w s f) where + m n = mkRWST $ \r s w -> unRWST m r s w unRWST n r s w +#endif instance Alt f => Alt (Backwards f) where Backwards a Backwards b = Backwards (a b) 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 @@ -28,9 +28,11 @@ -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) + , (<.*>) + , (<*.>) ) where -import Control.Comonad +import Data.Functor import Data.Functor.Bind.Class infixl 4 <..> @@ -46,3 +48,12 @@ liftF3 f a b c = f <$> a <.> b <.> c {-# INLINE liftF3 #-} +#if !(MIN_VERSION_base(4,7,0)) + +infixl 4 $> + +-- | Replace the contents of a functor uniformly with a constant value. +($>) :: Functor f => f a -> b -> f b +($>) = flip (<$) + +#endif diff --git a/src/Data/Functor/Bind/Class.hs b/src/Data/Functor/Bind/Class.hs --- a/src/Data/Functor/Bind/Class.hs +++ b/src/Data/Functor/Bind/Class.hs @@ -37,6 +37,9 @@ -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) + , (<.*>) + , (<*.>) + , traverse1Maybe -- * Bindable functors , Bind(..) , apDefault @@ -53,12 +56,15 @@ import Control.Category import Control.Monad (ap) 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 +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS +import qualified Control.Monad.Trans.Writer.CPS as CPS +import Semigroupoids.Internal +#endif 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 @@ -80,13 +86,18 @@ import Data.Functor.Product as Functor import Data.Functor.Reverse import Data.Functor.Extend -import Data.List.NonEmpty +import Data.List.NonEmpty (NonEmpty) import Data.Semigroup as Semigroup import qualified Data.Monoid as Monoid import Data.Orphans () import Language.Haskell.TH (Q) import Prelude hiding (id, (.)) +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + #if MIN_VERSION_base(4,6,0) import Data.Ord (Down (..)) #else @@ -127,6 +138,10 @@ import GHC.Generics as Generics #endif +#if __GLASGOW_HASKELL__ < 710 +import Data.Traversable +#endif + #ifdef MIN_VERSION_comonad import Control.Comonad import Control.Comonad.Trans.Env @@ -272,10 +287,12 @@ (<. ) = (<* ) ( .>) = ( *>) +#if !(MIN_VERSION_base(4,16,0)) instance Apply Option where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) +#endif instance Apply Identity where (<.>) = (<*>) @@ -337,19 +354,21 @@ instance (Functor m, Monad m) => Apply (MaybeT m) where (<.>) = apDefault +#if !(MIN_VERSION_transformers(0,6,0)) -- ErrorT e is _not_ the same as Compose f (Either e) instance (Functor m, Monad m) => Apply (ErrorT e m) where (<.>) = apDefault +instance Apply m => Apply (ListT m) where + ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a +#endif + 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 -- | A @'Strict.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' instance (Apply m, Semigroup w) => Apply (Strict.WriterT w m) where @@ -361,6 +380,13 @@ Lazy.WriterT f <.> Lazy.WriterT a = Lazy.WriterT $ flap <$> f <.> a where flap ~(x,m) ~(y,n) = (x y, m <> n) +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Bind m) => Apply (CPS.WriterT w m) where + mf <.> mx = mkWriterT $ \w -> + unWriterT mf w >>- \(f, w') -> unWriterT (f <$> mx) w' +#endif + instance Bind m => Apply (Strict.StateT s m) where (<.>) = apDefault @@ -375,6 +401,13 @@ instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where (<.>) = apDefault +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Bind m) => Apply (CPS.RWST r w s m) where + mf <.> mx = mkRWST $ \ r s w -> + unRWST mf r s w >>- \(f, s', w') -> unRWST (f <$> mx) r s' w' +#endif + instance Apply (ContT r m) where ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g) @@ -415,15 +448,31 @@ -- | Transform an Apply into an Applicative by adding a unit. newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a } +-- | Apply a non-empty container of functions to a possibly-empty-with-unit container of values. +(<.*>) :: (Apply f) => f (a -> b) -> MaybeApply f a -> f b +ff <.*> MaybeApply (Left fa) = ff <.> fa +ff <.*> MaybeApply (Right a) = ($ a) <$> ff +infixl 4 <.*> + +-- | Apply a possibly-empty-with-unit container of functions to a non-empty container of values. +(<*.>) :: (Apply f) => MaybeApply f (a -> b) -> f a -> f b +MaybeApply (Left ff) <*.> fa = ff <.> fa +MaybeApply (Right f) <*.> fa = f <$> fa +infixl 4 <*.> + +-- | Traverse a 'Traversable' using 'Apply', getting the results back in a 'MaybeApply'. +traverse1Maybe :: (Traversable t, Apply f) => (a -> f b) -> t a -> MaybeApply f (t b) +traverse1Maybe f = traverse (MaybeApply . Left . f) + 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 (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)) @@ -576,8 +625,10 @@ instance Bind Maybe where (>>-) = (>>=) +#if !(MIN_VERSION_base(4,16,0)) instance Bind Option where (>>-) = (>>=) +#endif instance Bind Identity where (>>-) = (>>=) @@ -594,6 +645,7 @@ instance (Functor m, Monad m) => Bind (MaybeT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@ +#if !(MIN_VERSION_transformers(0,6,0)) instance (Apply m, Monad m) => Bind (ListT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @[]@ @@ -603,6 +655,7 @@ case a of Left l -> return (Left l) Right r -> runErrorT (k r) +#endif instance (Functor m, Monad m) => Bind (ExceptT e m) where m >>- k = ExceptT $ do @@ -628,6 +681,13 @@ Strict.runWriterT (k a) `returning` \ (b, w') -> (b, w <> w') +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Bind m) => Bind (CPS.WriterT w m) where + m >>- k = mkWriterT $ \ w -> + unWriterT m w >>- \(a, w') -> unWriterT (k a) w' +#endif + instance Bind m => Bind (Lazy.StateT s m) where m >>- k = Lazy.StateT $ \s -> Lazy.runStateT m s >>- \ ~(a, s') -> @@ -652,13 +712,15 @@ Strict.runRWST (k a) r s' `returning` \ (b, s'', w') -> (b, s'', w <> w') +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Bind m) => Bind (CPS.RWST r w s m) where + m >>- k = mkRWST $ \ r s w -> + unRWST m r s w >>- \(a, s', w') -> unRWST (k a) r s' w' +#endif + 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 - (>>-) = (>>=) --} #if MIN_VERSION_base(4,4,0) instance Bind Complex where diff --git a/src/Data/Functor/Bind/Trans.hs b/src/Data/Functor/Bind/Trans.hs --- a/src/Data/Functor/Bind/Trans.hs +++ b/src/Data/Functor/Bind/Trans.hs @@ -28,6 +28,10 @@ -- import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader -- import Control.Monad.Trans.List +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS +import qualified Control.Monad.Trans.Writer.CPS as CPS +#endif 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 @@ -57,6 +61,12 @@ instance Monoid w => BindTrans (Strict.WriterT w) where liftB = Strict.WriterT . fmap (\a -> (a, mempty)) +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance Monoid w => BindTrans (CPS.WriterT w) where + liftB = CPS.writerT . fmap (\a -> (a, mempty)) +#endif + instance BindTrans (Lazy.StateT s) where liftB m = Lazy.StateT $ \s -> fmap (\a -> (a, s)) m @@ -68,6 +78,12 @@ instance Monoid w => BindTrans (Strict.RWST r w s) where liftB m = Strict.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance Monoid w => BindTrans (CPS.RWST r w s) where + liftB m = CPS.rwsT $ \ _r s -> fmap (\a -> (a, s, mempty)) m +#endif instance BindTrans (ContT r) where liftB m = ContT (m >>-) diff --git a/src/Data/Functor/Contravariant/Conclude.hs b/src/Data/Functor/Contravariant/Conclude.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Contravariant/Conclude.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Contravariant.Conclude ( + Conclude(..) + , concluded + ) where + +import Control.Applicative.Backwards +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict + +import Data.Functor.Apply +import Data.Functor.Compose +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Decide +import Data.Functor.Contravariant.Divise +import Data.Functor.Contravariant.Divisible +import Data.Functor.Product +import Data.Functor.Reverse +import Data.Void + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.List +#endif + +#if MIN_VERSION_base(4,8,0) +import Data.Monoid (Alt(..)) +#else +import Control.Applicative +#endif + +#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) +import Data.Proxy +#endif + +#ifdef MIN_VERSION_StateVar +import Data.StateVar +#endif + +#if __GLASGOW_HASKELL__ >= 702 +#define GHC_GENERICS +import GHC.Generics +#endif + +-- | The contravariant analogue of 'Plus'. Adds on to 'Decide' the ability +-- to express a combinator that rejects all input, to act as the dead-end. +-- Essentially 'Decidable' without a superclass constraint on 'Divisible'. +-- +-- If one thinks of @f a@ as a consumer of @a@s, then 'conclude' defines +-- a consumer that cannot ever receive /any/ input. +-- +-- Conclude acts as an identity with 'decide', because any decision that +-- involves 'conclude' must necessarily /always/ pick the other option. +-- +-- That is, for, say, +-- +-- @ +-- 'decide' f x 'concluded' +-- @ +-- +-- @f@ is the deciding function that picks which of the inputs of @decide@ +-- to direct input to; in the situation above, @f@ must /always/ direct all +-- input to @x@, and never 'concluded'. +-- +-- Mathematically, a functor being an instance of 'Decide' means that it is +-- \"monoidal\" with respect to the contravariant "either-based" Day +-- convolution described in the documentation of 'Decide'. On top of +-- 'Decide', it adds a way to construct an \"identity\" @conclude@ where +-- @decide f x (conclude q) == x@, and @decide g (conclude r) y == y@. +-- +-- @since 5.3.6 +class Decide f => Conclude f where + -- | The consumer that cannot ever receive /any/ input. + conclude :: (a -> Void) -> f a + +-- | A potentially more meaningful form of 'conclude', the consumer that cannot +-- ever receive /any/ input. That is because it expects only input of type +-- 'Void', but such a type has no values. +-- +-- @ +-- 'concluded' = 'conclude' 'id' +-- @ +-- +-- @since 5.3.6 +concluded :: Conclude f => f Void +concluded = conclude id + +-- | @since 5.3.6 +instance Decidable f => Conclude (WrappedDivisible f) where + conclude f = WrapDivisible (lose f) + +-- | @since 5.3.6 +instance Conclude Comparison where conclude = lose + +-- | @since 5.3.6 +instance Conclude Equivalence where conclude = lose + +-- | @since 5.3.6 +instance Conclude Predicate where conclude = lose + +-- | @since 5.3.6 +instance Conclude (Op r) where + conclude f = Op $ absurd . f + +#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) +-- | @since 5.3.6 +instance Conclude Proxy where conclude = lose +#endif + +#ifdef MIN_VERSION_StateVar +-- | @since 5.3.6 +instance Conclude SettableStateVar where conclude = lose +#endif + +#if MIN_VERSION_base(4,8,0) +-- | @since 5.3.6 +instance Conclude f => Conclude (Alt f) where + conclude = Alt . conclude +#endif + +#ifdef GHC_GENERICS +-- | @since 5.3.6 +instance Conclude U1 where conclude = lose + +-- | @since 5.3.6 +instance Conclude f => Conclude (Rec1 f) where + conclude = Rec1 . conclude + +-- | @since 5.3.6 +instance Conclude f => Conclude (M1 i c f) where + conclude = M1 . conclude + +-- | @since 5.3.6 +instance (Conclude f, Conclude g) => Conclude (f :*: g) where + conclude f = conclude f :*: conclude f + +-- | @since 5.3.6 +instance (Apply f, Applicative f, Conclude g) => Conclude (f :.: g) where + conclude = Comp1 . pure . conclude +#endif + +-- | @since 5.3.6 +instance Conclude f => Conclude (Backwards f) where + conclude = Backwards . conclude + +-- | @since 5.3.6 +instance Conclude f => Conclude (IdentityT f) where + conclude = IdentityT . conclude + +-- | @since 5.3.6 +instance Conclude m => Conclude (ReaderT r m) where + conclude f = ReaderT $ \_ -> conclude f + +-- | @since 5.3.6 +instance Conclude m => Conclude (Lazy.RWST r w s m) where + conclude f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Strict.RWST r w s m) where + conclude f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (conclude f) + +#if !(MIN_VERSION_transformers(0,6,0)) +-- | @since 5.3.6 +instance (Divisible m, Divise m) => Conclude (ListT m) where + conclude _ = ListT conquer +#endif + +-- | @since 5.3.6 +instance (Divisible m, Divise m) => Conclude (MaybeT m) where + conclude _ = MaybeT conquer + +-- | @since 5.3.6 +instance Conclude m => Conclude (Lazy.StateT s m) where + conclude f = Lazy.StateT $ \_ -> contramap lazyFst (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Strict.StateT s m) where + conclude f = Strict.StateT $ \_ -> contramap fst (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Lazy.WriterT w m) where + conclude f = Lazy.WriterT $ contramap lazyFst (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Strict.WriterT w m) where + conclude f = Strict.WriterT $ contramap fst (conclude f) + +-- | @since 5.3.6 +instance (Apply f, Applicative f, Conclude g) => Conclude (Compose f g) where + conclude = Compose . pure . conclude + +-- | @since 5.3.6 +instance (Conclude f, Conclude g) => Conclude (Product f g) where + conclude f = Pair (conclude f) (conclude f) + +-- | @since 5.3.6 +instance Conclude f => Conclude (Reverse f) where + conclude = Reverse . conclude + +-- Helpers + +lazyFst :: (a, b) -> a +lazyFst ~(a, _) = a diff --git a/src/Data/Functor/Contravariant/Decide.hs b/src/Data/Functor/Contravariant/Decide.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Contravariant/Decide.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +#if MIN_VERSION_base(4,7,0) +{-# LANGUAGE EmptyCase #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Contravariant.Decide ( + Decide(..) + , decided + ) where + +import Control.Applicative.Backwards +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict + +import Data.Functor.Apply +import Data.Functor.Compose +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divise +import Data.Functor.Contravariant.Divisible +import Data.Functor.Product +import Data.Functor.Reverse + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Arrow +import Control.Monad.Trans.List +import Data.Either +#endif + +#if MIN_VERSION_base(4,8,0) +import Data.Monoid (Alt(..)) +#endif + +#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) +import Data.Proxy +#endif + +#ifdef MIN_VERSION_StateVar +import Data.StateVar +#endif + +#if __GLASGOW_HASKELL__ >= 702 +#define GHC_GENERICS +import GHC.Generics +#endif + +-- | The contravariant analogue of 'Alt'. +-- +-- If one thinks of @f a@ as a consumer of @a@s, then 'decide' allows one +-- to handle the consumption of a value by choosing to handle it via +-- exactly one of two independent consumers. It redirects the input +-- completely into one of two consumers. +-- +-- 'decide' takes the \"decision\" method and the two potential consumers, +-- and returns the wrapped/combined consumer. +-- +-- Mathematically, a functor being an instance of 'Decide' means that it is +-- \"semigroupoidal\" with respect to the contravariant \"either-based\" Day +-- convolution (@data EitherDay f g a = forall b c. EitherDay (f b) (g c) (a -> Either b c)@). +-- That is, it is possible to define a function @(f `EitherDay` f) a -> +-- f a@ in a way that is associative. +-- +-- @since 5.3.6 +class Contravariant f => Decide f where + -- | Takes the \"decision\" method and the two potential consumers, and + -- returns the wrapped/combined consumer. + decide :: (a -> Either b c) -> f b -> f c -> f a + +-- | For @'decided' x y@, the resulting @f ('Either' b c)@ will direct +-- 'Left's to be consumed by @x@, and 'Right's to be consumed by y. +-- +-- @since 5.3.6 +decided :: Decide f => f b -> f c -> f (Either b c) +decided = decide id + +-- | @since 5.3.6 +instance Decidable f => Decide (WrappedDivisible f) where + decide f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (choose f x y) + +-- | @since 5.3.6 +instance Decide Comparison where decide = choose + +-- | @since 5.3.6 +instance Decide Equivalence where decide = choose + +-- | @since 5.3.6 +instance Decide Predicate where decide = choose + +-- | Unlike 'Decidable', requires no constraint on @r@. +-- +-- @since 5.3.6 +instance Decide (Op r) where + decide f (Op g) (Op h) = Op $ either g h . f + +#if MIN_VERSION_base(4,8,0) +-- | @since 5.3.6 +instance Decide f => Decide (Alt f) where + decide f (Alt l) (Alt r) = Alt $ decide f l r +#endif + +#ifdef GHC_GENERICS +-- | @since 5.3.6 +instance Decide U1 where decide = choose + +-- | Has no 'Decidable' or 'Conclude' instance. +-- +-- @since 5.3.6 +#if MIN_VERSION_base(4,7,0) +instance Decide V1 where decide _ x = case x of {} +#else +instance Decide V1 where decide _ x = case x of !_ -> error "V1" +#endif + +-- | @since 5.3.6 +instance Decide f => Decide (Rec1 f) where + decide f (Rec1 l) (Rec1 r) = Rec1 $ decide f l r + +-- | @since 5.3.6 +instance Decide f => Decide (M1 i c f) where + decide f (M1 l) (M1 r) = M1 $ decide f l r + +-- | @since 5.3.6 +instance (Decide f, Decide g) => Decide (f :*: g) where + decide f (l1 :*: r1) (l2 :*: r2) = decide f l1 l2 :*: decide f r1 r2 + +-- | Unlike 'Decidable', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Decide g) => Decide (f :.: g) where + decide f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (decide f) l r) +#endif + +-- | @since 5.3.6 +instance Decide f => Decide (Backwards f) where + decide f (Backwards l) (Backwards r) = Backwards $ decide f l r + +-- | @since 5.3.6 +instance Decide f => Decide (IdentityT f) where + decide f (IdentityT l) (IdentityT r) = IdentityT $ decide f l r + +-- | @since 5.3.6 +instance Decide m => Decide (ReaderT r m) where + decide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> decide abc (rmb r) (rmc r) + +-- | @since 5.3.6 +instance Decide m => Decide (Lazy.RWST r w s m) where + decide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> + decide (\ ~(a, s', w) -> either (Left . betuple3 s' w) + (Right . betuple3 s' w) + (abc a)) + (rsmb r s) (rsmc r s) + +-- | @since 5.3.6 +instance Decide m => Decide (Strict.RWST r w s m) where + decide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> + decide (\(a, s', w) -> either (Left . betuple3 s' w) + (Right . betuple3 s' w) + (abc a)) + (rsmb r s) (rsmc r s) + +#if !(MIN_VERSION_transformers(0,6,0)) +-- | @since 5.3.6 +instance Divise m => Decide (ListT m) where + decide f (ListT l) (ListT r) = ListT $ divise ((lefts &&& rights) . map f) l r +#endif + +-- | @since 5.3.6 +instance Divise m => Decide (MaybeT m) where + decide f (MaybeT l) (MaybeT r) = MaybeT $ + divise ( maybe (Nothing, Nothing) + (either (\b -> (Just b, Nothing)) + (\c -> (Nothing, Just c)) . f) + ) l r + +-- | @since 5.3.6 +instance Decide m => Decide (Lazy.StateT s m) where + decide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> + decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) + (l s) (r s) + +-- | @since 5.3.6 +instance Decide m => Decide (Strict.StateT s m) where + decide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> + decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) + (l s) (r s) + +-- | @since 5.3.6 +instance Decide m => Decide (Lazy.WriterT w m) where + decide f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $ + decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r + +-- | @since 5.3.6 +instance Decide m => Decide (Strict.WriterT w m) where + decide f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $ + decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r + +-- | Unlike 'Decidable', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Decide g) => Decide (Compose f g) where + decide f (Compose l) (Compose r) = Compose (liftF2 (decide f) l r) + +-- | @since 5.3.6 +instance (Decide f, Decide g) => Decide (Product f g) where + decide f (Pair l1 r1) (Pair l2 r2) = Pair (decide f l1 l2) (decide f r1 r2) + +-- | @since 5.3.6 +instance Decide f => Decide (Reverse f) where + decide f (Reverse l) (Reverse r) = Reverse $ decide f l r + +betuple :: s -> a -> (a, s) +betuple s a = (a, s) + +betuple3 :: s -> w -> a -> (a, s, w) +betuple3 s w a = (a, s, w) + +#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) +-- | @since 5.3.6 +instance Decide Proxy where + decide _ Proxy Proxy = Proxy +#endif + +#ifdef MIN_VERSION_StateVar +-- | @since 5.3.6 +instance Decide SettableStateVar where + decide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of + Left b -> l b + Right c -> r c +#endif diff --git a/src/Data/Functor/Contravariant/Divise.hs b/src/Data/Functor/Contravariant/Divise.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Contravariant/Divise.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +#if MIN_VERSION_base(4,7,0) +{-# LANGUAGE EmptyCase #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Contravariant.Divise ( + Divise(..) + , divised + , WrappedDivisible(..) + ) where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Arrow +import Control.Monad.Trans.Except +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict + +import Data.Functor.Apply +import Data.Functor.Compose +import Data.Functor.Constant +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible +import Data.Functor.Product +import Data.Functor.Reverse + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + +#if MIN_VERSION_base(4,8,0) +import Data.Monoid (Alt(..)) +#else +import Data.Monoid (Monoid(..)) +#endif + +#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,12,0) +import Data.Semigroup (Semigroup(..)) +#endif + +#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) +import Data.Proxy +#endif + +#ifdef MIN_VERSION_StateVar +import Data.StateVar +#endif + +#if __GLASGOW_HASKELL__ >= 702 +#define GHC_GENERICS +import GHC.Generics +#endif + +-- | The contravariant analogue of 'Apply'; it is +-- 'Divisible' without 'conquer'. +-- +-- If one thinks of @f a@ as a consumer of @a@s, then 'divise' allows one +-- to handle the consumption of a value by splitting it between two +-- consumers that consume separate parts of @a@. +-- +-- 'divise' takes the \"splitting\" method and the two sub-consumers, and +-- returns the wrapped/combined consumer. +-- +-- All instances of 'Divisible' should be instances of 'Divise' with +-- @'divise' = 'divide'@. +-- +-- If a function is polymorphic over @'Divise' f@ (as opposed to @'Divisible' +-- f@), we can provide a stronger guarantee: namely, that any input consumed +-- will be passed to at least one sub-consumer. With @'Divisible' f@, said input +-- could potentially disappear into the void, as this is possible with +-- 'conquer'. +-- +-- Mathematically, a functor being an instance of 'Divise' means that it is +-- \"semigroupoidal\" with respect to the contravariant (tupling) Day +-- convolution. That is, it is possible to define a function @(f `Day` f) +-- a -> f a@ in a way that is associative. +-- +-- @since 5.3.6 +class Contravariant f => Divise f where + -- | Takes a \"splitting\" method and the two sub-consumers, and + -- returns the wrapped/combined consumer. + divise :: (a -> (b, c)) -> f b -> f c -> f a + +-- | Combine a consumer of @a@ with a consumer of @b@ to get a consumer of +-- @(a, b)@. +-- +-- @ +-- 'divised' = 'divise' 'id' +-- @ +-- +-- @since 5.3.6 +divised :: Divise f => f a -> f b -> f (a, b) +divised = divise id + +-- | Wrap a 'Divisible' to be used as a member of 'Divise' +-- +-- @since 5.3.6 +newtype WrappedDivisible f a = WrapDivisible { unwrapDivisible :: f a } + +-- | @since 5.3.6 +instance Contravariant f => Contravariant (WrappedDivisible f) where + contramap f (WrapDivisible a) = WrapDivisible (contramap f a) + +-- | @since 5.3.6 +instance Divisible f => Divise (WrappedDivisible f) where + divise f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divide f x y) + +#if MIN_VERSION_base(4,9,0) +-- | Unlike 'Divisible', requires only 'Semigroup' on @r@. +-- +-- @since 5.3.6 +instance Semigroup r => Divise (Op r) where + divise f (Op g) (Op h) = Op $ \a -> case f a of + (b, c) -> g b <> h c + +-- | Unlike 'Divisible', requires only 'Semigroup' on @m@. +-- +-- @since 5.3.6 +instance Semigroup m => Divise (Const m) where + divise _ (Const a) (Const b) = Const (a <> b) + +-- | Unlike 'Divisible', requires only 'Semigroup' on @m@. +-- +-- @since 5.3.6 +instance Semigroup m => Divise (Constant m) where + divise _ (Constant a) (Constant b) = Constant (a <> b) +#else +-- | @since 5.3.6 +instance Monoid r => Divise (Op r) where divise = divide + +-- | @since 5.3.6 +instance Monoid m => Divise (Const m) where divise = divide + +-- | @since 5.3.6 +instance Monoid m => Divise (Constant m) where divise = divide +#endif + +-- | @since 5.3.6 +instance Divise Comparison where divise = divide + +-- | @since 5.3.6 +instance Divise Equivalence where divise = divide + +-- | @since 5.3.6 +instance Divise Predicate where divise = divide + +#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) +-- | @since 5.3.6 +instance Divise Proxy where divise = divide +#endif + +#ifdef MIN_VERSION_StateVar +-- | @since 5.3.6 +instance Divise SettableStateVar where divise = divide +#endif + +#if MIN_VERSION_base(4,8,0) +-- | @since 5.3.6 +instance Divise f => Divise (Alt f) where + divise f (Alt l) (Alt r) = Alt $ divise f l r +#endif + +#ifdef GHC_GENERICS +-- | @since 5.3.6 +instance Divise U1 where divise = divide + +-- | Has no 'Divisible' instance. +-- +-- @since 5.3.6 +#if MIN_VERSION_base(4,7,0) +instance Divise V1 where divise _ x = case x of {} +#else +instance Divise V1 where divise _ !_ = error "V1" +#endif + +-- | @since 5.3.6 +instance Divise f => Divise (Rec1 f) where + divise f (Rec1 l) (Rec1 r) = Rec1 $ divise f l r + +-- | @since 5.3.6 +instance Divise f => Divise (M1 i c f) where + divise f (M1 l) (M1 r) = M1 $ divise f l r + +-- | @since 5.3.6 +instance (Divise f, Divise g) => Divise (f :*: g) where + divise f (l1 :*: r1) (l2 :*: r2) = divise f l1 l2 :*: divise f r1 r2 + +-- | Unlike 'Divisible', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Divise g) => Divise (f :.: g) where + divise f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (divise f) l r) +#endif + +-- | @since 5.3.6 +instance Divise f => Divise (Backwards f) where + divise f (Backwards l) (Backwards r) = Backwards $ divise f l r + +#if !(MIN_VERSION_transformers(0,6,0)) +-- | @since 5.3.6 +instance Divise m => Divise (ErrorT e m) where + divise f (ErrorT l) (ErrorT r) = ErrorT $ divise (funzip . fmap f) l r + +-- | @since 5.3.6 +instance Divise m => Divise (ListT m) where + divise f (ListT l) (ListT r) = ListT $ divise (funzip . map f) l r +#endif + +-- | @since 5.3.6 +instance Divise m => Divise (ExceptT e m) where + divise f (ExceptT l) (ExceptT r) = ExceptT $ divise (funzip . fmap f) l r + +-- | @since 5.3.6 +instance Divise f => Divise (IdentityT f) where + divise f (IdentityT l) (IdentityT r) = IdentityT $ divise f l r + +-- | @since 5.3.6 +instance Divise m => Divise (MaybeT m) where + divise f (MaybeT l) (MaybeT r) = MaybeT $ divise (funzip . fmap f) l r + +-- | @since 5.3.6 +instance Divise m => Divise (ReaderT r m) where + divise abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> divise abc (rmb r) (rmc r) + +-- | @since 5.3.6 +instance Divise m => Divise (Lazy.RWST r w s m) where + divise abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> + divise (\ ~(a, s', w) -> case abc a of + ~(b, c) -> ((b, s', w), (c, s', w))) + (rsmb r s) (rsmc r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Strict.RWST r w s m) where + divise abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> + divise (\(a, s', w) -> case abc a of + (b, c) -> ((b, s', w), (c, s', w))) + (rsmb r s) (rsmc r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Lazy.StateT s m) where + divise f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> + divise (lazyFanout f) (l s) (r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Strict.StateT s m) where + divise f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> + divise (strictFanout f) (l s) (r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Lazy.WriterT w m) where + divise f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $ + divise (lazyFanout f) l r + +-- | @since 5.3.6 +instance Divise m => Divise (Strict.WriterT w m) where + divise f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $ + divise (strictFanout f) l r + +-- | Unlike 'Divisible', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Divise g) => Divise (Compose f g) where + divise f (Compose l) (Compose r) = Compose (liftF2 (divise f) l r) + +-- | @since 5.3.6 +instance (Divise f, Divise g) => Divise (Product f g) where + divise f (Pair l1 r1) (Pair l2 r2) = Pair (divise f l1 l2) (divise f r1 r2) + +-- | @since 5.3.6 +instance Divise f => Divise (Reverse f) where + divise f (Reverse l) (Reverse r) = Reverse $ divise f l r + +-- Helpers + +lazyFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s)) +lazyFanout f ~(a, s) = case f a of + ~(b, c) -> ((b, s), (c, s)) + +strictFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s)) +strictFanout f (a, s) = case f a of + (b, c) -> ((b, s), (c, s)) + +funzip :: Functor f => f (a, b) -> (f a, f b) +funzip = fmap fst &&& fmap snd diff --git a/src/Data/Functor/Plus.hs b/src/Data/Functor/Plus.hs --- a/src/Data/Functor/Plus.hs +++ b/src/Data/Functor/Plus.hs @@ -16,6 +16,7 @@ ---------------------------------------------------------------------------- module Data.Functor.Plus ( Plus(..) + , psum , module Data.Functor.Alt ) where @@ -23,21 +24,23 @@ import Control.Applicative.Backwards import Control.Applicative.Lift import Control.Arrow --- import Control.Exception import Control.Monad import Control.Monad.Trans.Identity --- import Control.Monad.Trans.Cont -import Control.Monad.Trans.Error import Control.Monad.Trans.Except -import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS +import qualified Control.Monad.Trans.Writer.CPS as CPS +import Semigroupoids.Internal +#endif 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 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 Data.Foldable hiding (asum) import Data.Functor.Apply import Data.Functor.Alt import Data.Functor.Bind @@ -46,8 +49,13 @@ import Data.Functor.Reverse import qualified Data.Monoid as Monoid import Data.Semigroup hiding (Product) -import Prelude hiding (id, (.)) +import Prelude hiding (id, (.), foldr) +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + #ifdef MIN_VERSION_containers import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) @@ -78,10 +86,18 @@ -- > m zero = m -- -- If extended to an 'Alternative' then 'zero' should equal 'empty'. - class Alt f => Plus f where zero :: f a +-- | The sum of a collection of actions, generalizing 'concat'. +-- +-- >>> psum [Just "Hello", Nothing, Just "World"] +-- Just "Hello" +-- +-- @since 5.3.6 +psum :: (Foldable t, Plus f) => t (f a) -> f a +psum = foldr () zero + instance Plus Proxy where zero = Proxy @@ -106,8 +122,10 @@ instance Plus Maybe where zero = Nothing +#if !(MIN_VERSION_base(4,16,0)) instance Plus Option where zero = empty +#endif instance MonadPlus m => Plus (WrappedMonad m) where zero = empty @@ -143,15 +161,17 @@ instance (Bind f, Monad f) => Plus (MaybeT f) where zero = MaybeT $ return zero +#if !(MIN_VERSION_transformers(0,6,0)) instance (Bind f, Monad f, Error e) => Plus (ErrorT e f) where zero = ErrorT $ return $ Left noMsg -instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) where - zero = ExceptT $ return $ Left mempty - instance (Apply f, Applicative f) => Plus (ListT f) where zero = ListT $ pure [] +#endif +instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) where + zero = ExceptT $ return $ Left mempty + instance Plus f => Plus (Strict.StateT e f) where zero = Strict.StateT $ \_ -> zero @@ -164,11 +184,23 @@ instance Plus f => Plus (Lazy.WriterT w f) where zero = Lazy.WriterT zero +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Plus f) => Plus (CPS.WriterT w f) where + zero = mkWriterT $ const zero +#endif + instance Plus f => Plus (Strict.RWST r w s f) where zero = Strict.RWST $ \_ _ -> zero instance Plus f => Plus (Lazy.RWST r w s f) where zero = Lazy.RWST $ \_ _ -> zero + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Plus f) => Plus (CPS.RWST r w s f) where + zero = mkRWST $ \_ _ _ -> zero +#endif instance Plus f => Plus (Backwards f) where zero = Backwards zero 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 @@ -37,7 +37,7 @@ import Prelude hiding (foldr) -- $setup --- >>> import Data.List.NonEmpty +-- >>> import Data.List.NonEmpty (NonEmpty (..)) -- >>> import Data.Monoid (Monoid (..)) newtype JoinWith a = JoinWith {joinee :: (a -> a)} @@ -120,7 +120,7 @@ foldrM1 f = go . toNonEmpty where g = (=<<) . f - + go (e:|es) = case es of [] -> return e diff --git a/src/Data/Semigroup/Foldable/Class.hs b/src/Data/Semigroup/Foldable/Class.hs --- a/src/Data/Semigroup/Foldable/Class.hs +++ b/src/Data/Semigroup/Foldable/Class.hs @@ -73,7 +73,7 @@ foldMap1 :: Semigroup m => (a -> m) -> t a -> m toNonEmpty :: t a -> NonEmpty a - foldMap1 f = maybe (error "foldMap1") id . getOption . foldMap (Option . Just . f) + foldMap1 f = maybe (error "foldMap1") id . getOptionCompat . foldMap (optionCompat . Just . f) fold1 = foldMap1 id toNonEmpty = foldMap1 (:|[]) @@ -131,7 +131,9 @@ {-# 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) + bifoldMap1 f g = maybe (error "bifoldMap1") id + . getOptionCompat + . bifoldMap (optionCompat . Just . f) (optionCompat . Just . g) {-# INLINE bifoldMap1 #-} instance Bifoldable1 Arg where @@ -244,8 +246,7 @@ foldMap1 f (Functor.InR y) = foldMap1 f y instance Foldable1 NonEmpty where - foldMap1 f (a :| []) = f a - foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs) + foldMap1 f (a :| as) = foldr (\b g x -> f x <> g b) f as a toNonEmpty = id instance Foldable1 ((,) a) where @@ -254,3 +255,32 @@ instance Foldable1 g => Foldable1 (Joker g a) where foldMap1 g = foldMap1 g . runJoker {-# INLINE foldMap1 #-} + +-- The default implementations of foldMap1 and bifoldMap1 above require the use +-- of a Maybe type with the following Monoid instance: +-- +-- instance Semigroup a => Monoid (Maybe a) where ... +-- +-- Unfortunately, Maybe has only had such an instance since base-4.11. Prior +-- to that, its Monoid instance had an instance context of Monoid a, which is +-- too strong. To compensate, we use CPP to define an OptionCompat type +-- synonym, which is an alias for Maybe on recent versions of base and an alias +-- for Data.Semigroup.Option on older versions of base. We don't want to use +-- Option on recent versions of base, as it has been removed. +#if MIN_VERSION_base(4,11,0) +type OptionCompat = Maybe + +optionCompat :: Maybe a -> OptionCompat a +optionCompat = id + +getOptionCompat :: OptionCompat a -> Maybe a +getOptionCompat = id +#else +type OptionCompat = Option + +optionCompat :: Maybe a -> OptionCompat a +optionCompat = Option + +getOptionCompat :: OptionCompat a -> Maybe a +getOptionCompat = getOption +#endif 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 @@ -16,6 +16,10 @@ ---------------------------------------------------------------------------- module Data.Semigroup.Traversable ( Traversable1(..) + -- * Defining Traversable1 instances + -- $traversable1instances + , traverse1Maybe + -- * Default superclass instance helpers , foldMap1Default ) where @@ -24,6 +28,20 @@ import Data.Semigroup #endif import Data.Semigroup.Traversable.Class +import Data.Functor.Bind.Class +-- | Default implementation of 'foldMap1' given an implementation of 'Traversable1'. foldMap1Default :: (Traversable1 f, Semigroup m) => (a -> m) -> f a -> m foldMap1Default f = getConst . traverse1 (Const . f) + +-- $traversable1instances +-- Defining 'Traversable1' instances for types with both 'Traversable1' and 'Traversable' +-- substructures can be done with 'traverse1Maybe', '(<*.>)', and '(<.*>)'. +-- +-- > data Foo a = Foo (Maybe a) (Maybe a) a [a] +-- > deriving (Functor, Traversable, Foldable) +-- > instance Traversable1 Foo where +-- > traverse1 f (Foo ma ma' a as) = Foo <$> traverseMaybe ma <*> traverseMaybe ma' <*.> f a <.*> traverseMaybe as +-- > instance Foldable1 Foo where +-- > foldMap1 = foldMap1Default + diff --git a/src/Data/Semigroup/Traversable/Class.hs b/src/Data/Semigroup/Traversable/Class.hs --- a/src/Data/Semigroup/Traversable/Class.hs +++ b/src/Data/Semigroup/Traversable/Class.hs @@ -226,8 +226,7 @@ #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) + traverse1 f (a :| as) = foldr (\b g x -> (\a' (b':| bs') -> a' :| b': bs') <$> f x <.> g b) (fmap (:|[]) . f) as a instance Traversable1 ((,) a) where traverse1 f (a, b) = (,) a <$> f b diff --git a/src/Data/Semigroupoid/Categorical.hs b/src/Data/Semigroupoid/Categorical.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroupoid/Categorical.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Koz Ross +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Koz Ross +-- Stability : Experimental +-- Portability : GHC only +-- +-- Provides a way to attach an identity to any semigroupoid. +---------------------------------------------------------------------------- +module Data.Semigroupoid.Categorical ( + Categorical(..), + runCategorical + ) where + +import Control.Category (Category (id, (.))) +import Data.Semigroupoid (Semigroupoid (o)) +import Prelude () + +-- | Attaches an identity. +-- +-- @since 5.3.6 +data Categorical s a b where + Id :: Categorical s a a + Embed :: s a b -> Categorical s a b + +-- | @since 5.3.6 +instance (Semigroupoid s) => Semigroupoid (Categorical s) where + Id `o` y = y + x `o` Id = x + Embed x `o` Embed y = Embed (x `o` y) + +-- | @since 5.3.6 +instance (Semigroupoid s) => Category (Categorical s) where + id = Id + (.) = o + +-- | @since 5.3.6 +runCategorical :: (a ~ b => r) -> (s a b -> r) -> Categorical s a b -> r +runCategorical r _ Id = r +runCategorical _ f (Embed x) = f x diff --git a/src/Semigroupoids/Do.hs b/src/Semigroupoids/Do.hs new file mode 100644 --- /dev/null +++ b/src/Semigroupoids/Do.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +#if __GLASGOW_HASKELL__ == 708 +{-# OPTIONS_GHC -fno-warn-amp #-} +#endif + +{-| + +This module re-exports operators from "Data.Functor.Apply" and +"Data.Functor.Bind", but under the same +names as their 'Applicative' and 'Monad' counterparts. This makes it convenient +to use do-notation on a type that is a 'Bind' but not a monad (or an 'Apply' +but not an 'Applicative' with @ApplicativeDo@), either using the +@QualifiedDo@ extension or the more traditional @RebindableSyntax@. + +@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE QualifiedDo #-} + +foo :: Apply f => f a -> f b -> f (a, b) +foo as bs = Semi.do + a <- as + b <- bs + pure (a, b) + + +bar :: Bind m => (a -> b -> m c) -> m a -> m b -> m c +bar f as bs = Semi.do + a <- as + b <- bs + f a b +@ + +-} +module Semigroupoids.Do + ( fmap + , (<*) + , (*>) + , (<*>) + , (>>) + , (>>=) + , join + , pure + , return + , fail + ) +where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (pure) +import Prelude (String, fmap, return) +#else +import Prelude (String, fmap, pure, return) +#endif +import Data.Functor.Apply (Apply, (<.), (.>), (<.>)) +import Data.Functor.Bind (Bind, (>>-), join) +import Data.Functor.Plus (Plus, zero) + +-- | @since 5.3.6 +(<*) :: Apply f => f a -> f b -> f a +(<*) = (<.) + +-- | @since 5.3.6 +(*>) :: Apply f => f a -> f b -> f b +(*>) = (.>) + +-- | @since 5.3.6 +(<*>) :: Apply f => f (a -> b) -> f a -> f b +(<*>) = (<.>) + +-- | @since 5.3.6 +(>>) :: Bind m => m a -> m b -> m b +(>>) = (.>) + +-- | @since 5.3.6 +(>>=) :: Bind m => m a -> (a -> m b) -> m b +(>>=) = (>>-) + +-- | = Important note +-- +-- This /ignores/ whatever 'String' you give it. It is a bad idea to use 'fail' +-- as a form of labelled error; instead, it should only be defaulted to when a +-- pattern match fails. +-- +-- @since 5.3.6 +fail :: + (Plus m) => + String -> + m a +fail _ = zero diff --git a/src/Semigroupoids/Internal.hs b/src/Semigroupoids/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Semigroupoids/Internal.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +module Semigroupoids.Internal where + +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS +import qualified Control.Monad.Trans.Writer.CPS as CPS +import Unsafe.Coerce (unsafeCoerce) +#endif + +-- This is designed to avoid both https://hub.darcs.net/ross/transformers/issue/67 +-- and also the unnecessary Monoid constraints that the CPS versions of WriterT +-- and RWST require. + +#if MIN_VERSION_transformers(0,5,6) +mkWriterT :: (w -> m (a, w)) -> CPS.WriterT w m a +mkWriterT = unsafeCoerce + +unWriterT :: CPS.WriterT w m a -> w -> m (a, w) +unWriterT = unsafeCoerce + +mkRWST :: (r -> s -> w -> m (a, s, w)) -> CPS.RWST r w s m a +mkRWST = unsafeCoerce + +unRWST :: CPS.RWST r w s m a -> r -> s -> w -> m (a, s, w) +unRWST = unsafeCoerce +#endif