semigroupoids 1.3.4 → 3.0
raw patch · 5 files changed
+193/−72 lines, 5 filesdep ~comonad
Dependency ranges changed: comonad
Files
- Data/Functor/Bind.hs +43/−48
- Data/Functor/Extend.hs +122/−0
- Data/Semigroupoid.hs +6/−5
- Data/Semigroupoid/Static.hs +13/−11
- semigroupoids.cabal +9/−8
Data/Functor/Bind.hs view
@@ -9,15 +9,15 @@ -- Stability : provisional -- Portability : portable ----- NB: The definitions exported through "Data.Functor.Apply" need to be +-- 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 ( +module Data.Functor.Bind ( -- * Functors Functor(..) , (<$>) -- :: Functor f => (a -> b) -> f a -> f b- , ( $>) -- :: Functor f => f a -> b -> f b + , ( $>) -- :: Functor f => f a -> b -> f b -- * Applyable functors , Apply(..) , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b@@ -57,6 +57,7 @@ import Data.Functor.Compose import Data.Functor.Identity import Data.Functor.Product+import Data.Functor.Extend import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import qualified Data.Map as Map@@ -69,17 +70,13 @@ infixl 1 >>- infixr 1 -<<-infixl 4 <.>, <., .>, <..>, $>---- | TODO: move into Data.Functor-($>) :: Functor f => f a -> b -> f b-($>) = flip (<$)+infixl 4 <.>, <., .>, <..> --- | A strong lax semi-monoidal endofunctor. +-- | A strong lax semi-monoidal endofunctor. -- This is equivalent to an 'Applicative' without 'pure'.--- --- Laws: --+-- Laws:+-- -- > associative composition: (.) <$> u <.> v <.> w = u <.> (v <.> w) class Functor f => Apply f where (<.>) :: f (a -> b) -> f a -> f b@@ -93,14 +90,14 @@ a <. b = const <$> a <.> b instance (Apply f, Apply g) => Apply (Compose f g) where- Compose f <.> Compose x = Compose ((<.>) <$> f <.> x) + Compose f <.> Compose x = Compose ((<.>) <$> f <.> x) instance (Apply f, Apply g) => Apply (Product f g) where Pair f g <.> Pair x y = Pair (f <.> x) (g <.> y) instance Semigroup m => Apply ((,)m) where (m, f) <.> (n, a) = (m <> n, f a)- (m, a) <. (n, _) = (m <> n, a) + (m, a) <. (n, _) = (m <> n, a) (m, _) .> (n, b) = (m <> n, b) instance Apply NonEmpty where@@ -151,7 +148,7 @@ instance Apply Option where (<.>) = (<*>)- (<. ) = (<* ) + (<. ) = (<* ) ( .>) = ( *>) instance Apply Identity where@@ -163,12 +160,12 @@ IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb) instance Monad m => Apply (WrappedMonad m) where- (<.>) = (<*>) + (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Arrow a => Apply (WrappedArrow a b) where- (<.>) = (<*>) + (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) @@ -188,9 +185,9 @@ (<.>) = ap instance Apply Tree where- (<.>) = (<*>) - (<. ) = (<* ) - ( .>) = ( *>) + (<.>) = (<*>)+ (<. ) = (<* )+ ( .>) = ( *>) -- MaybeT is _not_ the same as Compose f Maybe instance (Bind m, Monad m) => Apply (MaybeT m) where@@ -201,7 +198,7 @@ (<.>) = apDefault instance Apply m => Apply (ReaderT e m) where- ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e + ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e instance Apply m => Apply (ListT m) where ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a@@ -214,7 +211,7 @@ 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 @@ -231,7 +228,7 @@ ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g) -- | Wrap an 'Applicative' to be used as a member of 'Apply'-newtype WrappedApplicative f a = WrapApplicative { unwrapApplicative :: f a } +newtype WrappedApplicative f a = WrapApplicative { unwrapApplicative :: f a } instance Functor f => Functor (WrappedApplicative f) where fmap f (WrapApplicative a) = WrapApplicative (f <$> a)@@ -271,7 +268,7 @@ 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) (<*>) = (<.>)@@ -294,18 +291,20 @@ {-# INLINE liftF3 #-} instance Extend f => Extend (MaybeApply f) where- duplicate w@(MaybeApply Right{}) = MaybeApply (Right w)- duplicate (MaybeApply (Left fa)) = MaybeApply (Left (extend (MaybeApply . Left) fa))+ duplicated w@(MaybeApply Right{}) = MaybeApply (Right w)+ duplicated (MaybeApply (Left fa)) = MaybeApply (Left (extended (MaybeApply . Left) fa)) 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)) --- | A 'Monad' sans 'return'. --- +-- | A 'Monad' sans 'return'.+-- -- Minimal definition: Either 'join' or '>>-' -- -- If defining both, then the following laws (the default definitions) must hold:@@ -316,9 +315,9 @@ -- 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 --@@ -354,7 +353,7 @@ instance Bind (Either a) where Left a >>- _ = Left a- Right a >>- f = f 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@@ -362,7 +361,7 @@ sndP (Pair _ b) = b instance Bind ((->)m) where- f >>- g = \e -> g (f e) e + f >>- g = \e -> g (f e) e instance Bind [] where (>>-) = (>>=)@@ -386,7 +385,7 @@ IdentityT m >>- f = IdentityT (m >>- runIdentityT . f) instance Monad m => Bind (WrappedMonad m) where- WrapMonad m >>- f = WrapMonad $ m >>= unwrapMonad . f + WrapMonad m >>- f = WrapMonad $ m >>= unwrapMonad . f instance (Bind m, Monad m) => Bind (MaybeT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@@@ -396,7 +395,7 @@ instance (Bind m, Monad m) => Bind (ErrorT e m) where m >>- k = ErrorT $ do- a <- runErrorT m + a <- runErrorT m case a of Left l -> return (Left l) Right r -> runErrorT (k r)@@ -406,36 +405,36 @@ 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') -> + 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') -> + 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 -> + 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 -> + 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 -> + m >>- k = Lazy.RWST $ \r s -> Lazy.runRWST m r s >>- \ ~(a, s', w) ->- Lazy.runRWST (k a) r s' `returning` \ ~(b, 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 -> + m >>- k = Strict.RWST $ \r s -> Strict.runRWST m r s >>- \ (a, s', w) ->- Strict.runRWST (k a) r s' `returning` \ (b, s'', w') -> + Strict.runRWST (k a) r s' `returning` \ (b, s'', w') -> (b, s'', w <> w') instance Bind (ContT r m) where@@ -459,7 +458,3 @@ instance Bind Tree where (>>-) = (>>=)--instance (Comonad w, Apply w) => ArrowLoop (Cokleisli w) where- loop (Cokleisli f) = Cokleisli (fst . wfix . extend f') where- f' wa wb = f ((,) <$> wa <.> (snd <$> wb))
+ Data/Functor/Extend.hs view
@@ -0,0 +1,122 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Extend+-- Copyright : (C) 2011 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Functor.Extend+ ( -- * $definition+ Extend(..)+ ) where++import Prelude hiding (id, (.))+import Control.Category+import Control.Monad.Trans.Identity+import Data.Functor.Identity+import Data.Semigroup+import Data.List (tails)+import Data.List.NonEmpty (NonEmpty(..), toList)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Tree++class Functor w => Extend w where+ -- |+ -- > duplicate = extend id+ -- > fmap (fmap f) . duplicate = duplicate . fmap f+ duplicated :: w a -> w (w a)+ -- |+ -- > extend f = fmap f . duplicate+ extended :: (w a -> b) -> w a -> w b++ extended f = fmap f . duplicated+ duplicated = extended id++-- * Extends for Prelude types:+--+-- Instances: While Data.Functor.Extend.Instances would be symmetric+-- to the definition of Control.Monad.Instances in base, the reason+-- the latter exists is because of Haskell 98 specifying the types+-- @'Either' a@, @((,)m)@ and @((->)e)@ and the class Monad without+-- having the foresight to require or allow instances between them.+--+-- Here Haskell 98 says nothing about Extend, so we can include the+-- instances directly avoiding the wart of orphan instances.++instance Extend [] where+ duplicated = init . tails++instance Extend Maybe where+ duplicated Nothing = Nothing+ duplicated j = Just j++instance Extend (Either a) where+ duplicated (Left a) = Left a+ duplicated r = Right r++instance Extend ((,)e) where+ duplicated p = (fst p, p)++instance Semigroup m => Extend ((->)m) where+ duplicated f m = f . (<>) m++instance Extend Seq where+ duplicated = Seq.tails++instance Extend Tree where+ duplicated w@(Node _ as) = Node w (map duplicated as)++-- I can't fix the world+-- instance (Monoid m, Extend n) => Extend (ReaderT m n)+-- duplicate f m = f . mappend m++-- * Extends for types from 'transformers'.+--+-- This isn't really a transformer, so i have no compunction about including the instance here.+--+-- TODO: Petition to move Data.Functor.Identity into base+instance Extend Identity where+ duplicated = Identity++-- Provided to avoid an orphan instance. Not proposed to standardize.+-- If Extend moved to base, consider moving instance into transformers?+instance Extend w => Extend (IdentityT w) where+ extended f (IdentityT m) = IdentityT (extended (f . IdentityT) m)++instance Extend NonEmpty where+ extended f w@ ~(_ :| aas) = f w :| case aas of+ [] -> []+ (a:as) -> toList (extended f (a :| as))++{- $definition++There are two ways to define an 'Extend' instance:++I. Provide definitions for 'extend'+satisfying this law:++> extended f . extended g = extended (f . extended g)++II. Alternately, you may choose to provide definitions for 'duplicate'+satisfying this laws:++> duplicated . duplicated = fmap duplicated . duplicated++These are both equivalent to the statement that (->-) is associative++> (f ->- g) ->- h = f ->- (g ->- h)++You may of course, choose to define both 'duplicate' /and/ 'extend'.+In that case you must also satisfy these laws:++> extended f = fmap f . duplicated+> duplicated = extended id++These are the default definitions of 'extended' and 'duplicated'.++-}
Data/Semigroupoid.hs view
@@ -8,10 +8,10 @@ -- Stability : provisional -- Portability : portable ----- A semigroupoid satisfies all of the requirements to be a Category except +-- A semigroupoid satisfies all of the requirements to be a Category except -- for the existence of identity arrows. -----------------------------------------------------------------------------module Data.Semigroupoid +module Data.Semigroupoid ( Semigroupoid(..) , WrappedCategory(..) , Semi(..)@@ -19,6 +19,7 @@ import Control.Arrow import Data.Functor.Bind+import Data.Functor.Extend import Data.Functor.Contravariant import Control.Comonad import Data.Semigroup@@ -30,18 +31,18 @@ o :: c j k -> c i j -> c i k instance Semigroupoid (->) where- o = (.) + o = (.) instance Bind m => Semigroupoid (Kleisli m) where Kleisli g `o` Kleisli f = Kleisli $ \a -> f a >>- g instance Extend w => Semigroupoid (Cokleisli w) where- Cokleisli f `o` Cokleisli g = Cokleisli $ f . extend g+ Cokleisli f `o` Cokleisli g = Cokleisli $ f . extended g instance Semigroupoid Op where Op f `o` Op g = Op (g `o` f) -newtype WrappedCategory k a b = WrapCategory { unwrapCategory :: k a b } +newtype WrappedCategory k a b = WrapCategory { unwrapCategory :: k a b } instance Category k => Semigroupoid (WrappedCategory k) where WrapCategory f `o` WrapCategory g = WrapCategory (f . g)
Data/Semigroupoid/Static.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-module Data.Semigroupoid.Static +module Data.Semigroupoid.Static ( Static(..) ) where @@ -7,19 +7,20 @@ import Control.Applicative import Control.Category import Control.Comonad-import Control.Monad.Instances+import Control.Monad.Instances () import Control.Monad (ap) import Data.Functor.Apply import Data.Functor.Plus+import Data.Functor.Extend import Data.Semigroup import Data.Semigroupoid import Prelude hiding ((.), id) -#ifdef LANGUAGE_DeriveDataTypeable +#ifdef LANGUAGE_DeriveDataTypeable import Data.Typeable #endif -newtype Static f a b = Static { runStatic :: f (a -> b) } +newtype Static f a b = Static { runStatic :: f (a -> b) } #ifdef LANGUAGE_DeriveDataTypeable deriving (Typeable) #endif@@ -37,13 +38,14 @@ zero = Static zero instance Applicative f => Applicative (Static f a) where- pure = Static . pure . const + pure = Static . pure . const Static f <*> Static g = Static (ap <$> f <*> g) instance (Extend f, Semigroup a) => Extend (Static f a) where- extend f = Static . extend (\wf m -> f (Static (fmap (. (<>) m) wf))) . runStatic+ extended f = Static . extended (\wf m -> f (Static (fmap (. (<>) m) wf))) . runStatic -instance (Comonad f, Semigroup a, Monoid a) => Comonad (Static f a) where+instance (Comonad f, Monoid a) => Comonad (Static f a) where+ extend f = Static . extend (\wf m -> f (Static (fmap (. mappend m) wf))) . runStatic extract (Static g) = extract g mempty instance Apply f => Semigroupoid (Static f) where@@ -54,15 +56,15 @@ Static f . Static g = Static ((.) <$> f <*> g) instance Applicative f => Arrow (Static f) where- arr = Static . pure - first (Static g) = Static (first <$> g) - second (Static g) = Static (second <$> g) + arr = Static . pure+ first (Static g) = Static (first <$> g)+ second (Static g) = Static (second <$> g) Static g *** Static h = Static ((***) <$> g <*> h) Static g &&& Static h = Static ((&&&) <$> g <*> h) instance Alternative f => ArrowZero (Static f) where zeroArrow = Static empty- + instance Alternative f => ArrowPlus (Static f) where Static f <+> Static g = Static (f <|> g)
semigroupoids.cabal view
@@ -1,6 +1,6 @@ name: semigroupoids category: Control, Comonads-version: 1.3.4+version: 3.0 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE@@ -55,16 +55,17 @@ transformers >= 0.2 && < 0.4, containers >= 0.3 && < 0.6, contravariant >= 0.2.0.1 && < 0.3,- comonad >= 1.1.1.5 && < 1.2,+ comonad >= 3.0 && < 3.1, semigroups >= 0.8.3.1 && < 0.9 exposed-modules:- Data.Functor.Alt,- Data.Functor.Apply,- Data.Functor.Bind,- Data.Functor.Bind.Trans,- Data.Functor.Plus,- Data.Semigroup.Foldable,+ Data.Functor.Alt+ Data.Functor.Apply+ Data.Functor.Bind+ Data.Functor.Bind.Trans+ Data.Functor.Plus+ Data.Functor.Extend+ Data.Semigroup.Foldable Data.Semigroup.Traversable Data.Semigroupoid Data.Semigroupoid.Dual