packages feed

semigroupoids 3.0.0.2 → 3.0.1

raw patch · 29 files changed

+1333/−1286 lines, 29 files

Files

+ .ghci view
@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
+ .gitignore view
@@ -0,0 +1,2 @@+_darcs+dist
.travis.yml view
@@ -1,1 +1,8 @@ language: haskell+notifications:+  irc:+    channels:+      - "irc.freenode.org#haskell-lens"+    skip_join: true+    template:+      - "\x0313semigroupoids\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
+ .vim.custom view
@@ -0,0 +1,31 @@+" 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 <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" 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"
− Data/Functor/Alt.hs 
@@ -1,169 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Functor.Alt--- 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.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
− Data/Functor/Apply.hs 
@@ -1,30 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Functor.Apply--- 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.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
− Data/Functor/Bind.hs 
@@ -1,460 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Functor.Bind--- Copyright   :  (C) 2011 Edward Kmett,--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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.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)---- | 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 a 'Applicative', 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-  (>>-) = (>>=)
− Data/Functor/Bind/Trans.hs 
@@ -1,65 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Functor.Bind.Trans--- 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.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 >>-)
− Data/Functor/Extend.hs 
@@ -1,120 +0,0 @@--------------------------------------------------------------------------------- |--- 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-  ( -- * Extendable Functors-    -- $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-  -- |-  -- > 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 = 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 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'.
− Data/Functor/Plus.hs 
@@ -1,115 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Functor.Plus--- 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.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
− Data/Semigroup/Foldable.hs 
@@ -1,87 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Semigroup.Foldable--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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.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 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
− Data/Semigroup/Traversable.hs 
@@ -1,58 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Semigroup.Traversable--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  portable---------------------------------------------------------------------------------module Data.Semigroup.Traversable-  ( Traversable1(..)-  , foldMap1Default-  ) where--import Control.Applicative-import Control.Monad.Trans.Identity-import Data.Functor.Identity-import Data.Functor.Apply-import Data.Functor.Product-import Data.Functor.Compose-import Data.Semigroup.Foldable-import Data.Traversable-import Data.Traversable.Instances ()-import Data.Tree-import Data.List.NonEmpty (NonEmpty(..))-import Data.Semigroup hiding (Product)--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 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)
− Data/Semigroupoid.hs 
@@ -1,61 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Semigroupoid--- Copyright   :  (C) 2007-2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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 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)
− Data/Semigroupoid/Dual.hs 
@@ -1,27 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Semigroupoid.Dual--- Copyright   :  (C) 2007-2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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)
− Data/Semigroupoid/Static.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE CPP #-}-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)-
− Data/Traversable/Instances.hs 
@@ -1,16 +0,0 @@-{-# 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
semigroupoids.cabal view
@@ -1,6 +1,6 @@ name:          semigroupoids category:      Control, Comonads-version:       3.0.0.2+version:       3.0.1 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -12,7 +12,11 @@ copyright:     Copyright (C) 2011 Edward A. Kmett build-type:    Simple synopsis:      Haskell 98 semigroupoids: Category sans id-extra-source-files: .travis.yml+extra-source-files:+  .ghci+  .travis.yml+  .gitignore+  .vim.custom description:   Provides a wide array of semigroupoids and operations for working with semigroupds.   .@@ -57,6 +61,8 @@     contravariant >= 0.2.0.1 && < 0.3,     comonad       >= 3.0,     semigroups    >= 0.8.3.1++  hs-source-dirs: src    exposed-modules:     Data.Functor.Alt
+ src/Data/Functor/Alt.hs view
@@ -0,0 +1,169 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Alt+-- 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.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
+ src/Data/Functor/Apply.hs view
@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Apply+-- 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.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
+ src/Data/Functor/Bind.hs view
@@ -0,0 +1,460 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Bind+-- Copyright   :  (C) 2011 Edward Kmett,+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- 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.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)++-- | 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 a 'Applicative', 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+  (>>-) = (>>=)
+ src/Data/Functor/Bind/Trans.hs view
@@ -0,0 +1,65 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Bind.Trans+-- 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.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 >>-)
+ src/Data/Functor/Extend.hs view
@@ -0,0 +1,120 @@+-----------------------------------------------------------------------------+-- |+-- 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+  ( -- * Extendable Functors+    -- $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+  -- |+  -- > 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 = 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 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'.
+ src/Data/Functor/Plus.hs view
@@ -0,0 +1,115 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Plus+-- 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.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
+ src/Data/Semigroup/Foldable.hs view
@@ -0,0 +1,87 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Semigroup.Foldable+-- Copyright   :  (C) 2011 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- 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.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 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
+ src/Data/Semigroup/Traversable.hs view
@@ -0,0 +1,58 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Semigroup.Traversable+-- Copyright   :  (C) 2011 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+----------------------------------------------------------------------------+module Data.Semigroup.Traversable+  ( Traversable1(..)+  , foldMap1Default+  ) where++import Control.Applicative+import Control.Monad.Trans.Identity+import Data.Functor.Identity+import Data.Functor.Apply+import Data.Functor.Product+import Data.Functor.Compose+import Data.Semigroup.Foldable+import Data.Traversable+import Data.Traversable.Instances ()+import Data.Tree+import Data.List.NonEmpty (NonEmpty(..))+import Data.Semigroup hiding (Product)++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 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)
+ src/Data/Semigroupoid.hs view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Semigroupoid+-- Copyright   :  (C) 2007-2011 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- 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 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)
+ src/Data/Semigroupoid/Dual.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Semigroupoid.Dual+-- Copyright   :  (C) 2007-2011 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- 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)
+ src/Data/Semigroupoid/Static.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE CPP #-}+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)+
+ src/Data/Traversable/Instances.hs view
@@ -0,0 +1,16 @@+{-# 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