Browse files

3.0, duplicate [] bugfix, migrated Data.Functor.Extend from comonad.

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

0 comments on commit 77b2326

Please sign in to comment.