semigroupoids-4.0/0000755000000000000000000000000012226604144012435 5ustar0000000000000000semigroupoids-4.0/.ghci0000644000000000000000000000012512226604144013346 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h semigroupoids-4.0/.gitignore0000644000000000000000000000010412226604144014420 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# semigroupoids-4.0/.travis.yml0000644000000000000000000000034212226604144014545 0ustar0000000000000000language: haskell notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313semigroupoids\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" semigroupoids-4.0/.vim.custom0000644000000000000000000000137712226604144014552 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" semigroupoids-4.0/LICENSE0000644000000000000000000000236412226604144013447 0ustar0000000000000000Copyright 2011-2013 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. semigroupoids-4.0/semigroupoids.cabal0000644000000000000000000000715312226604144016320 0ustar0000000000000000name: semigroupoids category: Control, Comonads version: 4.0 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/semigroupoids bug-reports: http://github.com/ekmett/semigroupoids/issues copyright: Copyright (C) 2011-2013 Edward A. Kmett build-type: Simple synopsis: Semigroupoids: Category sans id extra-source-files: .ghci .travis.yml .gitignore .vim.custom description: Provides a wide array of (semi)groupoids and operations for working with them. . A 'Semigroupoid' is a 'Category' without the requirement of identity arrows for every object in the category. . A 'Category' is any 'Semigroupoid' for which the Yoneda lemma holds. . When working with comonads you often have the @\<*\>@ portion of an @Applicative@, but not the @pure@. This was captured in Uustalu and Vene's \"Essence of Dataflow Programming\" in the form of the @ComonadZip@ class in the days before @Applicative@. Apply provides a weaker invariant, but for the comonads used for data flow programming (found in the streams package), this invariant is preserved. Applicative function composition forms a semigroupoid. . 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: . > Traversable <---- Foldable <--- Functor ------> Alt ---------> Plus Semigroupoid > | | | | | > v v v v v > Traversable1 <--- Foldable1 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. . This lets us remove many of the restrictions from various monad transformers as in many cases the binding operation or @\<*\>@ operation does not require them. . Finally, to work with these weaker structures it is beneficial to have containers that can provide stronger guarantees about their contents, so versions of 'Traversable' and 'Foldable' that can be folded with just a 'Semigroup' are added. source-repository head type: git location: git://github.com/ekmett/semigroupoids.git library build-depends: base >= 4 && < 5, containers >= 0.3 && < 0.6, contravariant >= 0.2.0.1 && < 1, comonad >= 4 && < 5, distributive >= 0.2.2 && < 1, semigroups >= 0.8.3.1 && < 1, transformers >= 0.2 && < 0.4 hs-source-dirs: src exposed-modules: Data.Functor.Alt Data.Functor.Apply Data.Functor.Bind Data.Functor.Bind.Trans Data.Functor.Extend Data.Functor.Plus Data.Groupoid Data.Isomorphism Data.Semifunctor Data.Semifunctor.Associative Data.Semifunctor.Braided Data.Semigroup.Foldable Data.Semigroup.Traversable Data.Semigroupoid Data.Semigroupoid.Coproduct Data.Semigroupoid.Dual Data.Semigroupoid.Ob Data.Semigroupoid.Product Data.Semigroupoid.Static Data.Traversable.Instances ghc-options: -Wall semigroupoids-4.0/Setup.lhs0000644000000000000000000000016512226604144014247 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain semigroupoids-4.0/src/0000755000000000000000000000000012226604144013224 5ustar0000000000000000semigroupoids-4.0/src/Data/0000755000000000000000000000000012226604144014075 5ustar0000000000000000semigroupoids-4.0/src/Data/Groupoid.hs0000644000000000000000000000101512226604144016216 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif module Data.Groupoid ( Groupoid(..) ) where import Data.Semigroupoid import Data.Semigroupoid.Dual -- | semigroupoid with inverses. This technically should be a category with inverses, except we need to use Ob to define the valid objects for the category class Semigroupoid k => Groupoid k where inv :: k a b -> k b a instance Groupoid k => Groupoid (Dual k) where inv (Dual k) = Dual (inv k) semigroupoids-4.0/src/Data/Isomorphism.hs0000644000000000000000000000113012226604144016735 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif module Data.Isomorphism ( Iso(..) ) where 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 } instance Semigroupoid k => Semigroupoid (Iso k) where Iso f g `o` Iso h i = Iso (f `o` h) (i `o` g) instance Semigroupoid k => Groupoid (Iso k) where inv (Iso f g) = Iso g f instance Category k => Category (Iso k) where Iso f g . Iso h i = Iso (f . h) (i . g) id = Iso id id semigroupoids-4.0/src/Data/Semifunctor.hs0000644000000000000000000001106212226604144016727 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} #ifndef MIN_VERSION_comonad #define MIN_VERSION_comonad(x,y,z) 1 #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 #if MIN_VERSION_comonad(3,0,3) {-# LANGUAGE Safe #-} #else {-# LANGUAGE Trustworthy #-} #endif #endif 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.Comonad import Control.Monad (liftM) import Data.Distributive import Data.Functor.Bind import Data.Functor.Extend 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) -- | 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 instance (Distributive f, Extend w) => Semifunctor (WrappedFunctor f) (Cokleisli w) (Cokleisli w) where semimap (Cokleisli w) = Cokleisli $ WrapFunctor . cotraverse w . fmap unwrapFunctor 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) fstP :: Bi (,) (a, b) -> a fstP (Bi (a,_)) = a sndP :: Bi (,) (a, b) -> b sndP (Bi (_,b)) = b 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 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 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) semigroupoids-4.0/src/Data/Semigroupoid.hs0000644000000000000000000000422112226604144017076 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 #if __GLASGOW_HASKELL__ >= 707 && (MIN_VERSION_comonad(3,0,3)) {-# LANGUAGE Safe #-} #else {-# LANGUAGE Trustworthy #-} #endif #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Semigroupoid -- Copyright : (C) 2007-2011 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- A semigroupoid satisfies all of the requirements to be a Category except -- for the existence of identity arrows. ---------------------------------------------------------------------------- module Data.Semigroupoid ( Semigroupoid(..) , WrappedCategory(..) , Semi(..) ) where import Control.Arrow import Data.Functor.Bind import Data.Functor.Extend import Data.Functor.Contravariant import Control.Comonad import Data.Semigroup import Control.Category import Prelude hiding (id, (.)) -- | 'Control.Category.Category' sans 'Control.Category.id' class Semigroupoid c where o :: c j k -> c i j -> c i k instance Semigroupoid (->) where o = (.) -- | instance Semigroupoid (,) where o (_,k) (i,_) = (i,k) 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 . 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 } instance Category k => Semigroupoid (WrappedCategory k) where WrapCategory f `o` WrapCategory g = WrapCategory (f . g) instance Category k => Category (WrappedCategory k) where id = WrapCategory id WrapCategory f . WrapCategory g = WrapCategory (f . g) newtype Semi m a b = Semi { getSemi :: m } instance Semigroup m => Semigroupoid (Semi m) where Semi m `o` Semi n = Semi (m <> n) instance Monoid m => Category (Semi m) where id = Semi mempty Semi m . Semi n = Semi (m `mappend` n) semigroupoids-4.0/src/Data/Functor/0000755000000000000000000000000012226604144015515 5ustar0000000000000000semigroupoids-4.0/src/Data/Functor/Alt.hs0000644000000000000000000001222212226604144016570 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Alt -- Copyright : (C) 2011 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Alt ( Alt(..) , module Data.Functor.Apply ) where import Control.Applicative hiding (some, many) import Control.Arrow import Control.Exception (catch, SomeException) import Control.Monad import Control.Monad.Trans.Identity import Control.Monad.Trans.Error import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader 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.Functor.Apply import Data.Functor.Bind import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import Data.Semigroup import Data.List.NonEmpty (NonEmpty(..)) import Data.Sequence (Seq) import qualified Data.Map as Map import Data.Map (Map) import Prelude (($),Either(..),Maybe(..),const,IO,Ord,(++)) infixl 3 -- | Laws: -- -- > is associative: (a b) c = a (b c) -- > <$> left-distributes over : f <$> (a b) = (f <$> a) (f <$> b) -- -- If extended to an 'Alternative' then '' should equal '<|>'. -- -- Ideally, an instance of 'Alt' also satisfies the \"left distributon\" 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 'STM' satisfy the alternative -- \"left catch\" law instead: -- -- > pure a b = pure a -- -- However, this variation 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. -- -- The right distributive law should extend in the cases where the a 'Bind' or 'Monad' is -- provided to yield variations of the right distributive law: -- -- > (m n) >>- f = (m >>- f) (m >>- f) -- > (m n) >>= f = (m >>= f) (m >>= f) class Functor f => Alt f where -- | @(<|>)@ without a required @empty@ () :: f a -> f a -> f a some :: Applicative f => f a -> f [a] some v = some_v where many_v = some_v pure [] some_v = (:) <$> v <*> many_v many :: Applicative f => f a -> f [a] many v = many_v where many_v = some_v pure [] some_v = (:) <$> v <*> many_v instance Alt (Either a) where Left _ b = b a _ = a -- | This instance does not actually satisfy the (<.>) right distributive 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 instance Alt [] where () = (++) instance Alt Maybe where Nothing b = b a _ = a instance Alt Option where () = (<|>) instance MonadPlus m => Alt (WrappedMonad m) where () = (<|>) instance ArrowPlus a => Alt (WrappedArrow a b) where () = (<|>) instance Ord k => Alt (Map k) where () = Map.union instance Alt IntMap where () = IntMap.union instance Alt Seq where () = mappend instance Alt NonEmpty where (a :| as) ~(b :| bs) = a :| (as ++ b : bs) instance Alternative f => Alt (WrappedApplicative f) where WrapApplicative a WrapApplicative b = WrapApplicative (a <|> b) instance Alt f => Alt (IdentityT f) where IdentityT a IdentityT b = IdentityT (a b) instance Alt f => Alt (ReaderT e f) where ReaderT a ReaderT b = ReaderT $ \e -> a e b e instance (Bind f, Monad f) => Alt (MaybeT f) where MaybeT a MaybeT b = MaybeT $ do v <- a case v of Nothing -> b Just _ -> return v instance (Bind f, Monad f) => Alt (ErrorT e f) where ErrorT m ErrorT n = ErrorT $ do a <- m case a of Left _ -> n Right r -> return (Right r) 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 instance Alt f => Alt (Lazy.StateT e f) where Lazy.StateT m Lazy.StateT n = Lazy.StateT $ \s -> m s n s instance Alt f => Alt (Strict.WriterT w f) where Strict.WriterT m Strict.WriterT n = Strict.WriterT $ m n instance Alt f => Alt (Lazy.WriterT w f) where Lazy.WriterT m Lazy.WriterT n = Lazy.WriterT $ m n 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 semigroupoids-4.0/src/Data/Functor/Apply.hs0000644000000000000000000000203212226604144017133 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Apply -- Copyright : (C) 2011 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Apply ( -- * Functors Functor(..) , (<$>) -- :: Functor f => (a -> b) -> f a -> f b , ( $>) -- :: Functor f => f a -> b -> f b -- * Apply - a strong lax semimonoidal endofunctor , Apply(..) , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b , liftF2 -- :: Apply w => (a -> b -> c) -> w a -> w b -> w c , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) ) where import Data.Functor.Bind semigroupoids-4.0/src/Data/Functor/Bind.hs0000644000000000000000000003472412226604144016737 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef MIN_VERSION_comonad #define MIN_VERSION_comonad(x,y,z) 1 #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 #if __GLASGOW_HASKELL__ >= 707 && (MIN_VERSION_comonad(3,0,3)) {-# LANGUAGE Safe #-} #else {-# LANGUAGE Trustworthy #-} #endif #endif {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Bind -- Copyright : (C) 2011 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- 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 Functor(..) , (<$>) -- :: Functor f => (a -> b) -> f a -> f b , ( $>) -- :: Functor f => f a -> b -> f b -- * Applyable functors , Apply(..) , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b , liftF2 -- :: Apply w => (a -> b -> c) -> w a -> w b -> w c , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) -- * Bindable functors , Bind(..) , (-<<) , (-<-) , (->-) , apDefault , returning ) where -- import _everything_ import Control.Applicative import Control.Arrow import Control.Category import Control.Comonad import Control.Comonad.Trans.Env import Control.Comonad.Trans.Store import Control.Comonad.Trans.Traced import Control.Monad (ap) import Control.Monad.Instances import Control.Monad.Trans.Cont import Control.Monad.Trans.Error 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.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 import Data.Map (Map) import Data.List.NonEmpty import Data.Semigroup hiding (Product) import Data.Sequence (Seq) import Data.Tree (Tree) import Prelude hiding (id, (.)) 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 g) => Apply (Compose f g) where 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, _) .> (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 (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) -- | 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 (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) -- MaybeT is _not_ the same as Compose f Maybe instance (Bind m, Monad m) => Apply (MaybeT m) where (<.>) = apDefault -- ErrorT e is _not_ the same as Compose f (Either e) instance (Bind m, Monad m) => Apply (ErrorT 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) 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) -- | 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)) 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'. -- -- 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) returning :: Functor f => f a -> (a -> b) -> f b returning = flip fmap (-<<) :: Bind m => (a -> m b) -> m a -> m b (-<<) = flip (>>-) (->-) :: Bind m => (a -> m b) -> (b -> m c) -> a -> m c f ->- g = \a -> f a >>- g (-<-) :: 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 (Bind m, Monad m) => Bind (MaybeT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@ instance (Bind m, Monad m) => Bind (ListT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @[]@ instance (Bind 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 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 (>>-) = (>>=) -} -- | 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 (>>-) = (>>=) semigroupoids-4.0/src/Data/Functor/Extend.hs0000644000000000000000000001072712226604144017307 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Extend -- Copyright : (C) 2011 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Extend ( -- * Extendable Functors -- $definition Extend(..) ) where import Prelude hiding (id, (.)) import Control.Category import Control.Comonad.Trans.Env import Control.Comonad.Trans.Store import Control.Comonad.Trans.Traced import Control.Monad.Trans.Identity import Data.Functor.Coproduct 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 -- | -- > duplicated = extended id -- > fmap (fmap f) . duplicated = duplicated . fmap f duplicated :: w a -> w (w a) -- | -- > extended f = fmap f . duplicated 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 l = Seq.take (Seq.length l) (Seq.tails l) instance Extend Tree where duplicated w@(Node _ as) = Node w (map duplicated as) instance (Extend f, Extend g) => Extend (Coproduct f g) where extended f = Coproduct . coproduct (Left . extended (f . Coproduct . Left)) (Right . extended (f . Coproduct . Right)) instance Extend w => Extend (EnvT e w) where duplicated (EnvT e wa) = EnvT e (extended (EnvT e) wa) instance Extend w => Extend (StoreT s w) where duplicated (StoreT wf s) = StoreT (extended StoreT wf) s extended f (StoreT wf s) = StoreT (extended (\wf' s' -> f (StoreT wf' s')) wf) s instance (Extend w, Semigroup m) => Extend (TracedT m w) where extended f = TracedT . extended (\wf m -> f (TracedT (fmap (. (<>) m) wf))) . runTracedT -- 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 law: -- -- > 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'. semigroupoids-4.0/src/Data/Functor/Plus.hs0000644000000000000000000000613512226604144017001 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Plus -- Copyright : (C) 2011 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Plus ( Plus(..) , module Data.Functor.Alt ) where import Control.Applicative hiding (some, many) 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.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader 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.Functor.Apply import Data.Functor.Alt import Data.Functor.Bind import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import Data.Semigroup import Data.Sequence (Seq) import qualified Data.Map as Map import Data.Map (Map) import Prelude hiding (id, (.)) -- | Laws: -- -- > zero m = m -- > m zero = m -- -- If extended to an 'Alternative' then 'zero' should equal 'empty'. class Alt f => Plus f where zero :: f a instance Plus IO where zero = error "zero" instance Plus [] where zero = [] instance Plus Maybe where zero = Nothing instance Plus Option where zero = empty instance MonadPlus m => Plus (WrappedMonad m) where zero = empty instance ArrowPlus a => Plus (WrappedArrow a b) where zero = empty instance Ord k => Plus (Map k) where zero = Map.empty instance Plus IntMap where zero = IntMap.empty instance Plus Seq where zero = mempty instance Alternative f => Plus (WrappedApplicative f) where zero = empty instance Plus f => Plus (IdentityT f) where zero = IdentityT zero instance Plus f => Plus (ReaderT e f) where zero = ReaderT $ \_ -> zero instance (Bind f, Monad f) => Plus (MaybeT f) where zero = MaybeT $ return zero instance (Bind f, Monad f, Error e) => Plus (ErrorT e f) where zero = ErrorT $ return $ Left noMsg instance (Apply f, Applicative f) => Plus (ListT f) where zero = ListT $ pure [] instance (Plus f) => Plus (Strict.StateT e f) where zero = Strict.StateT $ \_ -> zero instance (Plus f) => Plus (Lazy.StateT e f) where zero = Lazy.StateT $ \_ -> zero instance Plus f => Plus (Strict.WriterT w f) where zero = Strict.WriterT zero instance Plus f => Plus (Lazy.WriterT w f) where zero = Lazy.WriterT zero 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 semigroupoids-4.0/src/Data/Functor/Bind/0000755000000000000000000000000012226604144016371 5ustar0000000000000000semigroupoids-4.0/src/Data/Functor/Bind/Trans.hs0000644000000000000000000000434412226604144020021 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Bind.Trans -- Copyright : (C) 2011 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Bind.Trans ( BindTrans(..) ) where -- import _everything_ import Control.Category import Control.Monad.Instances import Control.Monad.Trans.Class import Control.Monad.Trans.Cont -- import Control.Monad.Trans.Error 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.Bind import Data.Semigroup hiding (Product) import Prelude hiding (id, (.)) -- | A subset of monad transformers can transform any 'Bind' as well. class MonadTrans t => BindTrans t where liftB :: Bind b => b a -> t b a instance BindTrans IdentityT where liftB = IdentityT instance BindTrans (ReaderT e) where liftB = ReaderT . const instance (Semigroup w, Monoid w) => BindTrans (Lazy.WriterT w) where liftB = Lazy.WriterT . fmap (\a -> (a, mempty)) instance (Semigroup w, Monoid w) => BindTrans (Strict.WriterT w) where liftB = Strict.WriterT . fmap (\a -> (a, mempty)) instance BindTrans (Lazy.StateT s) where liftB m = Lazy.StateT $ \s -> fmap (\a -> (a, s)) m instance BindTrans (Strict.StateT s) where liftB m = Strict.StateT $ \s -> fmap (\a -> (a, s)) m instance (Semigroup w, Monoid w) => BindTrans (Lazy.RWST r w s) where liftB m = Lazy.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m instance (Semigroup w, Monoid w) => BindTrans (Strict.RWST r w s) where liftB m = Strict.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m instance BindTrans (ContT r) where liftB m = ContT (m >>-) semigroupoids-4.0/src/Data/Semifunctor/0000755000000000000000000000000012226604144016373 5ustar0000000000000000semigroupoids-4.0/src/Data/Semifunctor/Associative.hs0000644000000000000000000000731212226604144021204 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Semifunctor.Associative -- Copyright : (C) 2011-2012 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 Control.Comonad import Data.Functor.Bind import Data.Functor.Extend import Data.Semifunctor -- import Data.Isomorphism 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 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 -- 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 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 -- 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 semigroupoids-4.0/src/Data/Semifunctor/Braided.hs0000644000000000000000000000514012226604144020261 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} #ifndef MIN_VERSION_comonad #define MIN_VERSION_comonad(x,y,z) 1 #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 #if MIN_VERSION_comonad(3,0,3) {-# LANGUAGE Safe #-} #else {-# LANGUAGE Trustworthy #-} #endif #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Semifunctor.Braided -- Copyright : (C) 2011-2012 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : MPTCs, GADTs -- ---------------------------------------------------------------------------- module Data.Semifunctor.Braided ( Braided(..) , kleisliBraid , cokleisliBraid , Symmetric , swap ) where import Prelude hiding ((.), id) import Control.Arrow import Control.Comonad import Data.Functor.Bind import Data.Functor.Extend import Data.Semifunctor import Data.Semifunctor.Associative -- import Data.Semigroupoid.Dual 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 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 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 (,)) instance (Extend w, Comonad w) => Symmetric (Cokleisli w) (Bi (,)) -- instance Comonad w => Symmetric (Cokleisli w) (Bi Either) swap :: Symmetric k p => k (p(a,b)) (p(b,a)) swap = braid semigroupoids-4.0/src/Data/Semigroup/0000755000000000000000000000000012226604144016047 5ustar0000000000000000semigroupoids-4.0/src/Data/Semigroup/Foldable.hs0000644000000000000000000000554412226604144020123 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Semigroup.Foldable -- Copyright : (C) 2011 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Semigroup.Foldable ( Foldable1(..) , traverse1_ , for1_ , sequenceA1_ , foldMapDefault1 ) where import Control.Monad.Trans.Identity import Data.Foldable import Data.Functor.Identity import Data.Functor.Apply import Data.Functor.Product import Data.Functor.Compose import Data.Functor.Coproduct import Data.Tree import Data.List.NonEmpty (NonEmpty(..)) import Data.Traversable.Instances () import Data.Semigroup hiding (Product) 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 instance Foldable1 Tree where foldMap1 f (Node a []) = f a foldMap1 f (Node a (x:xs)) = f a <> foldMap1 (foldMap1 f) (x :| xs) instance Foldable1 Identity where foldMap1 f = f . runIdentity instance Foldable1 m => Foldable1 (IdentityT m) where foldMap1 f = foldMap1 f . runIdentityT instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where foldMap1 f = foldMap1 (foldMap1 f) . getCompose 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 g) => Foldable1 (Coproduct f g) where foldMap1 f = coproduct (foldMap1 f) (foldMap1 f) instance Foldable1 NonEmpty where foldMap1 f (a :| []) = f a foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs) newtype Act f a = Act { getAct :: f a } instance Apply f => Semigroup (Act f a) where Act a <> Act b = Act (a .> b) instance Functor f => Functor (Act f) where fmap f (Act a) = Act (f <$> a) b <$ Act a = Act (b <$ a) traverse1_ :: (Foldable1 t, Apply f) => (a -> f b) -> t a -> f () traverse1_ f t = () <$ getAct (foldMap1 (Act . f) t) {-# INLINE traverse1_ #-} for1_ :: (Foldable1 t, Apply f) => t a -> (a -> f b) -> f () for1_ = flip traverse1_ {-# INLINE for1_ #-} sequenceA1_ :: (Foldable1 t, Apply f) => t (f a) -> f () sequenceA1_ t = () <$ getAct (foldMap1 Act t) {-# INLINE sequenceA1_ #-} -- | Usable default for foldMap, but only if you define foldMap1 yourself foldMapDefault1 :: (Foldable1 t, Monoid m) => (a -> m) -> t a -> m foldMapDefault1 f = unwrapMonoid . foldMap (WrapMonoid . f) {-# INLINE foldMapDefault1 #-} -- toStream :: Foldable1 t => t a -> Stream a -- concat1 :: Foldable1 t => t (Stream a) -> Stream a -- concatMap1 :: Foldable1 t => (a -> Stream b) -> t a -> Stream b semigroupoids-4.0/src/Data/Semigroup/Traversable.hs0000644000000000000000000000437612226604144020667 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Semigroup.Traversable -- Copyright : (C) 2011 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Semigroup.Traversable ( Traversable1(..) , foldMap1Default ) where import Control.Applicative import Control.Monad.Trans.Identity import Data.Functor.Apply import Data.Functor.Compose import Data.Functor.Coproduct import Data.Functor.Identity import Data.Functor.Product import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup hiding (Product) import Data.Semigroup.Foldable import Data.Traversable import Data.Traversable.Instances () import Data.Tree 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 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 g) => Traversable1 (Compose f g) where traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose 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 g) => Traversable1 (Coproduct f g) where traverse1 f = coproduct (fmap (Coproduct . Left) . traverse1 f) (fmap (Coproduct . Right) . traverse1 f) 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) 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) semigroupoids-4.0/src/Data/Semigroupoid/0000755000000000000000000000000012226604144016543 5ustar0000000000000000semigroupoids-4.0/src/Data/Semigroupoid/Coproduct.hs0000644000000000000000000000176212226604144021047 0ustar0000000000000000{-# LANGUAGE GADTs, EmptyDataDecls #-} module Data.Semigroupoid.Coproduct ( L, R, Coproduct(..), distributeDualCoproduct, factorDualCoproduct) where import Data.Semigroupoid import Data.Semigroupoid.Dual import Data.Groupoid data L a data R a data Coproduct j k a b where L :: j a b -> Coproduct j k (L a) (L b) R :: k a b -> Coproduct j k (R a) (R 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) semigroupoids-4.0/src/Data/Semigroupoid/Dual.hs0000644000000000000000000000155712226604144017774 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Semigroupoid.Dual -- Copyright : (C) 2007-2011 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- A semigroupoid satisfies all of the requirements to be a Category except -- for the existence of identity arrows. ---------------------------------------------------------------------------- module Data.Semigroupoid.Dual (Dual(..)) where import Data.Semigroupoid import Control.Category import Prelude () newtype Dual k a b = Dual { getDual :: k b a } instance Semigroupoid k => Semigroupoid (Dual k) where Dual f `o` Dual g = Dual (g `o` f) instance Category k => Category (Dual k) where id = Dual id Dual f . Dual g = Dual (g . f) semigroupoids-4.0/src/Data/Semigroupoid/Ob.hs0000644000000000000000000000241512226604144017441 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Semigroup.Ob -- Copyright : (C) 2011-2012 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable (flexible MPTCs) -- ---------------------------------------------------------------------------- module Data.Semigroupoid.Ob where import Data.Semigroupoid import Data.Semigroupoid.Product import Data.Semigroupoid.Coproduct import Control.Comonad import Data.Functor.Bind import Data.Functor.Extend import Control.Arrow 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) (L a) where semiid = L semiid instance (Semigroupoid l, Ob r a) => Ob (Coproduct l r) (R a) where semiid = R semiid instance (Bind m, Monad m) => Ob (Kleisli m) a where semiid = Kleisli return instance (Extend w, Comonad w) => Ob (Cokleisli w) a where semiid = Cokleisli extract instance Ob (->) a where semiid = id semigroupoids-4.0/src/Data/Semigroupoid/Product.hs0000644000000000000000000000146012226604144020520 0ustar0000000000000000{-# LANGUAGE GADTs #-} 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) semigroupoids-4.0/src/Data/Semigroupoid/Static.hs0000644000000000000000000000471512226604144020335 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 #if __GLASGOW_HASKELL__ >= 707 && (MIN_VERSION_comonad(3,0,3)) {-# LANGUAGE Safe #-} #else {-# LANGUAGE Trustworthy #-} #endif #endif module Data.Semigroupoid.Static ( Static(..) ) where import Control.Arrow import Control.Applicative import Control.Category import Control.Comonad 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 import Data.Typeable #endif newtype Static f a b = Static { runStatic :: f (a -> b) } #ifdef LANGUAGE_DeriveDataTypeable deriving (Typeable) #endif instance Functor f => Functor (Static f a) where fmap f = Static . fmap (f .) . runStatic instance Apply f => Apply (Static f a) where Static f <.> Static g = Static (ap <$> f <.> g) instance Alt f => Alt (Static f a) where Static f Static g = Static (f g) instance Plus f => Plus (Static f a) where zero = Static zero instance Applicative f => Applicative (Static f a) where pure = Static . pure . const Static f <*> Static g = Static (ap <$> f <*> g) instance (Extend f, Semigroup a) => Extend (Static f a) where extended f = Static . extended (\wf m -> f (Static (fmap (. (<>) m) wf))) . runStatic 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 Static f `o` Static g = Static ((.) <$> f <.> g) instance Applicative f => Category (Static f) where id = Static (pure id) 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) 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) instance Applicative f => ArrowChoice (Static f) where left (Static g) = Static (left <$> g) right (Static g) = Static (right <$> g) Static g +++ Static h = Static ((+++) <$> g <*> h) Static g ||| Static h = Static ((|||) <$> g <*> h) semigroupoids-4.0/src/Data/Traversable/0000755000000000000000000000000012226604144016347 5ustar0000000000000000semigroupoids-4.0/src/Data/Traversable/Instances.hs0000644000000000000000000000102012226604144020623 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Placeholders for missing instances of Traversable, until base catches up and adds them {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Traversable.Instances where #if !(MIN_VERSION_transformers(0,3,0)) import Control.Monad.Trans.Identity import Data.Foldable import Data.Traversable instance Foldable m => Foldable (IdentityT m) where foldMap f = foldMap f . runIdentityT instance Traversable m => Traversable (IdentityT m) where traverse f = fmap IdentityT . traverse f . runIdentityT #endif