Skip to content
Browse files

Moved semigroupoid instances from the comonad-transformers as we move…

…d them

into comonad.
  • Loading branch information...
1 parent e1f65e1 commit a68a6bc5fffb09a08b8c03b23bf334a2a654bdc5 @ekmett committed Oct 13, 2013
View
2 semigroupoids.cabal
@@ -59,7 +59,7 @@ library
base >= 4 && < 5,
containers >= 0.3 && < 0.6,
contravariant >= 0.2.0.1 && < 1,
- comonad == 3.* && < 4,
+ comonad >= 3.2 && < 4,
distributive >= 0.2.2 && < 1,
semigroups >= 0.8.3.1 && < 1,
transformers >= 0.2 && < 0.4
View
12 src/Data/Functor/Bind.hs
@@ -52,6 +52,9 @@ import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Comonad
+import Control.Comonad.Trans.Env
+import Control.Comonad.Trans.Store
+import Control.Comonad.Trans.Traced
import Control.Monad (ap)
import Control.Monad.Instances
import Control.Monad.Trans.Cont
@@ -239,6 +242,15 @@ instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where
instance Apply (ContT r m) where
ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g)
+instance (Semigroup e, Apply w) => Apply (EnvT e w) where
+ EnvT ef wf <.> EnvT ea wa = EnvT (ef <> ea) (wf <.> wa)
+
+instance (Apply w, Semigroup s) => Apply (StoreT s w) where
+ StoreT ff m <.> StoreT fa n = StoreT ((<*>) <$> ff <.> fa) (m <> n)
+
+instance Apply w => Apply (TracedT m w) where
+ TracedT wf <.> TracedT wa = TracedT (ap <$> wf <.> wa)
+
-- | Wrap an 'Applicative' to be used as a member of 'Apply'
newtype WrappedApplicative f a = WrapApplicative { unwrapApplicative :: f a }
View
19 src/Data/Functor/Extend.hs
@@ -21,7 +21,11 @@ module Data.Functor.Extend
import Prelude hiding (id, (.))
import Control.Category
+import Control.Comonad.Trans.Env
+import Control.Comonad.Trans.Store
+import Control.Comonad.Trans.Traced
import Control.Monad.Trans.Identity
+import Data.Functor.Coproduct
import Data.Functor.Identity
import Data.Semigroup
import Data.List (tails)
@@ -76,6 +80,21 @@ instance Extend Seq where
instance Extend Tree where
duplicated w@(Node _ as) = Node w (map duplicated as)
+instance (Extend f, Extend g) => Extend (Coproduct f g) where
+ extended f = Coproduct . coproduct
+ (Left . extended (f . Coproduct . Left))
+ (Right . extended (f . Coproduct . Right))
+
+instance Extend w => Extend (EnvT e w) where
+ duplicated (EnvT e wa) = EnvT e (extended (EnvT e) wa)
+
+instance Extend w => Extend (StoreT s w) where
+ duplicated (StoreT wf s) = StoreT (extended StoreT wf) s
+ extended f (StoreT wf s) = StoreT (extended (\wf' s' -> f (StoreT wf' s')) wf) s
+
+instance (Extend w, Semigroup m) => Extend (TracedT m w) where
+ extended f = TracedT . extended (\wf m -> f (TracedT (fmap (. (<>) m) wf))) . runTracedT
+
-- I can't fix the world
-- instance (Monoid m, Extend n) => Extend (ReaderT m n)
-- duplicate f m = f . mappend m
View
4 src/Data/Semigroup/Foldable.hs
@@ -23,6 +23,7 @@ import Data.Functor.Identity
import Data.Functor.Apply
import Data.Functor.Product
import Data.Functor.Compose
+import Data.Functor.Coproduct
import Data.Tree
import Data.List.NonEmpty (NonEmpty(..))
import Data.Traversable.Instances ()
@@ -52,6 +53,9 @@ instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where
instance (Foldable1 f, Foldable1 g) => Foldable1 (Product f g) where
foldMap1 f (Pair a b) = foldMap1 f a <> foldMap1 f b
+instance (Foldable1 f, Foldable1 g) => Foldable1 (Coproduct f g) where
+ foldMap1 f = coproduct (foldMap1 f) (foldMap1 f)
+
instance Foldable1 NonEmpty where
foldMap1 f (a :| []) = f a
foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs)
View
14 src/Data/Semigroup/Traversable.hs
@@ -16,16 +16,17 @@ module Data.Semigroup.Traversable
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.Functor.Coproduct
+import Data.Functor.Identity
+import Data.Functor.Product
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Semigroup hiding (Product)
import Data.Semigroup.Foldable
import Data.Traversable
import Data.Traversable.Instances ()
import Data.Tree
-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)
@@ -49,6 +50,11 @@ instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where
instance (Traversable1 f, Traversable1 g) => Traversable1 (Product f g) where
traverse1 f (Pair a b) = Pair <$> traverse1 f a <.> traverse1 f b
+instance (Traversable1 f, Traversable1 g) => Traversable1 (Coproduct f g) where
+ traverse1 f = coproduct
+ (fmap (Coproduct . Left) . traverse1 f)
+ (fmap (Coproduct . Right) . traverse1 f)
+
instance Traversable1 Tree where
traverse1 f (Node a []) = (`Node`[]) <$> f a
traverse1 f (Node a (x:xs)) = (\b (y:|ys) -> Node b (y:ys)) <$> f a <.> traverse1 (traverse1 f) (x :| xs)

0 comments on commit a68a6bc

Please sign in to comment.
Something went wrong with that request. Please try again.