packages feed

semigroupoid-extras 0.1 → 0.2

raw patch · 6 files changed

+237/−6 lines, 6 filesdep +comonaddep +distributive

Dependencies added: comonad, distributive

Files

+ Data/Semifunctor.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Data.Semifunctor +  ( Semifunctor(..)+  , Bi(..)+  , (#)+  , semibimap+  , semifirst+  , semisecond+  , first+  , second+  , WrappedFunctor(..)+  , WrappedTraversable1(..)+  , module Control.Category+  , module Data.Semigroupoid+  , module Data.Semigroupoid.Ob+  , module Data.Semigroupoid.Product+  ) where++import Control.Arrow hiding (first, second, left, right)+import Control.Category+import Control.Comonad+import Control.Monad (liftM)+import Data.Distributive+import Data.Functor.Bind+import Data.Traversable+import Data.Semigroup.Traversable+import Data.Semigroupoid+import Data.Semigroupoid.Dual+import Data.Semigroupoid.Ob+import Data.Semigroupoid.Product+import Prelude hiding ((.),id, mapM)++-- | Semifunctors map objects to objects, and arrows to arrows preserving connectivity+-- as normal functors, but do not purport to preserve identity arrows. We apply them+-- to semigroupoids, because those don't even claim to offer identity arrows!+class (Semigroupoid c, Semigroupoid d) => Semifunctor f c d | f c -> d, f d -> c where+  semimap :: c a b -> d (f a) (f b)++data WrappedFunctor f a = WrapFunctor { unwrapFunctor :: f a }++instance Functor f => Semifunctor (WrappedFunctor f) (->) (->) where+  semimap f = WrapFunctor . fmap f . unwrapFunctor++instance (Traversable f, Bind m, Monad m) => Semifunctor (WrappedFunctor f) (Kleisli m) (Kleisli m) where+  semimap (Kleisli f) = Kleisli $ liftM WrapFunctor . mapM f . unwrapFunctor++instance (Distributive f, Extend w) => Semifunctor (WrappedFunctor f) (Cokleisli w) (Cokleisli w) where+  semimap (Cokleisli w) = Cokleisli $ WrapFunctor . cotraverse w . fmap unwrapFunctor++data WrappedTraversable1 f a = WrapTraversable1 { unwrapTraversable1 :: f a } ++instance (Traversable1 f, Bind m) => Semifunctor (WrappedTraversable1 f) (Kleisli m) (Kleisli m) where+  semimap (Kleisli f) = Kleisli $ fmap WrapTraversable1 . traverse1 f . unwrapTraversable1++-- | Used to map a more traditional bifunctor into a semifunctor+data Bi p a where+  Bi :: p a b -> Bi p (a,b)++instance Semifunctor f c d => Semifunctor f (Dual c) (Dual d) where+  semimap (Dual f) = Dual (semimap f)++(#) :: a -> b -> Bi (,) (a,b)+a # b = Bi (a,b)++fstP :: Bi (,) (a, b) -> a+fstP (Bi (a,_)) = a++sndP :: Bi (,) (a, b) -> b+sndP (Bi (_,b)) = b++left :: a -> Bi Either (a,b)+left = Bi . Left ++right :: b -> Bi Either (a,b) +right = Bi . Right++instance Semifunctor (Bi (,)) (Product (->) (->)) (->) where+  semimap (Pair l r) (Bi (a,b)) = l a # r b++instance Semifunctor (Bi Either) (Product (->) (->)) (->) where+  semimap (Pair l _) (Bi (Left a)) = Bi (Left (l a))+  semimap (Pair _ r) (Bi (Right b)) = Bi (Right (r b))++instance Bind m => Semifunctor (Bi (,)) (Product (Kleisli m) (Kleisli m)) (Kleisli m) where+  semimap (Pair l r) = Kleisli (\ (Bi (a, b)) -> (#) <$> runKleisli l a <.> runKleisli r b)++instance Bind m => Semifunctor (Bi Either) (Product (Kleisli m) (Kleisli m)) (Kleisli m) where+  semimap (Pair (Kleisli l0) (Kleisli r0)) = Kleisli (lr l0 r0) where+    lr :: Functor m => (a -> m c) -> (b -> m d) -> Bi Either (a,b) -> m (Bi Either (c,d))+    lr l _ (Bi (Left a))  = left <$> l a+    lr _ r (Bi (Right b)) = right <$> r b++instance Extend w => Semifunctor (Bi (,)) (Product (Cokleisli w) (Cokleisli w)) (Cokleisli w) where+  semimap (Pair l r) = Cokleisli $ \p -> runCokleisli l (fstP <$> p) # runCokleisli r (sndP <$> p)++semibimap :: Semifunctor p (Product l r) cod => l a b -> r c d -> cod (p (a,c)) (p (b,d))+semibimap f g = semimap (Pair f g)++semifirst :: (Semifunctor p (Product l r) cod, Ob r c) => l a b -> cod (p (a,c)) (p (b,c))+semifirst f = semimap (Pair f semiid)++semisecond :: (Semifunctor p (Product l r) cod, Ob l a) => r b c -> cod (p (a,b)) (p (a,c))+semisecond f = semimap (Pair semiid f)++first :: (Semifunctor p (Product l r) cod, Category r) => l a b -> cod (p (a,c)) (p (b,c))+first f = semimap (Pair f id)++second :: (Semifunctor p (Product l r) cod, Category l) => r b c -> cod (p (a,b)) (p (a,c))+second f = semimap (Pair id f)
+ Data/Semifunctor/Associative.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, GADTs, ImplicitParams #-}+module Data.Semifunctor.Associative where++import Prelude hiding ((.), id)+import Control.Arrow+import Control.Comonad+import Data.Functor.Bind+import Data.Semifunctor+-- import Data.Semigroupoid.Dual+-- import Data.Semigroupoid.Product++-- instance Semifunctor p (Product x y) z => Semifunctor (DualSemibifunctor p) (Product (Dual x) (Dual y)) (Dual z) where++class Semifunctor p (Product k k) k => Associative k p where+  associate :: k (p(p(a,b),c)) (p(a,p(b,c)))++instance Associative (->) (Bi Either) where+  associate (Bi (Left (Bi (Left a)))) = Bi (Left a)+  associate (Bi (Left (Bi (Right b)))) = Bi (Right (Bi (Left b)))+  associate (Bi (Right c)) = Bi (Right (Bi (Right c)))++instance Associative (->) (Bi (,)) where+  associate (Bi (Bi (a,b),c)) = Bi(a, Bi(b, c))++kleisliAssociate :: (Monad m, Semifunctor p (Product (Kleisli m) (Kleisli m)) (Kleisli m), Associative (->) p) => Kleisli m (p(p(a,b),c)) (p(a,p(b,c)))+kleisliAssociate = Kleisli (return . associate)++instance (Bind m, Monad m) => Associative (Kleisli m) (Bi Either) where+  associate = kleisliAssociate++instance (Bind m, Monad m) => Associative (Kleisli m) (Bi (,)) where+  associate = kleisliAssociate++cokleisliAssociate :: (Comonad m, Semifunctor p (Product (Cokleisli m) (Cokleisli m)) (Cokleisli m), Associative (->) p) => Cokleisli m (p(p(a,b),c)) (p(a,p(b,c)))+cokleisliAssociate = Cokleisli (associate . extract)++instance Comonad m => Associative (Cokleisli m) (Bi (,)) where+  associate = cokleisliAssociate++-- instance Disassociative k p => Associative (Dual k) p+-- instance (Monad m, Semifunctor p (Product (Kleisli m) (Kleisli m) (Kleisli m), Associative (->) p) => Associative (Kleisli m) p) where associate = kleisliAssociate++class Semifunctor p (Product k k) k => Disassociative k p where+  disassociate :: k (p(a,p(b,c))) (p(p(a,b),c)) ++instance Disassociative (->) (Bi Either) where+  disassociate (Bi (Left a)) = Bi (Left (Bi (Left a)))+  disassociate (Bi (Right (Bi (Left b)))) = Bi (Left (Bi (Right b)))+  disassociate (Bi (Right (Bi (Right b)))) = Bi (Right b)++instance Disassociative (->) (Bi (,)) where+  disassociate (Bi(a, Bi(b, c))) = Bi (Bi (a,b),c)++kleisliDisassociate :: (Monad m, Semifunctor p (Product (Kleisli m) (Kleisli m)) (Kleisli m), Disassociative (->) p) => Kleisli m (p(a,p(b,c))) (p(p(a,b),c)) +kleisliDisassociate = Kleisli (return . disassociate)++instance (Bind m, Monad m) => Disassociative (Kleisli m) (Bi Either) where+  disassociate = kleisliDisassociate++instance (Bind m, Monad m) => Disassociative (Kleisli m) (Bi (,)) where+  disassociate = kleisliDisassociate++cokleisliDisassociate :: (Comonad m, Semifunctor p (Product (Cokleisli m) (Cokleisli m)) (Cokleisli m), Disassociative (->) p) => Cokleisli m (p(a,p(b,c))) (p(p(a,b),c)) +cokleisliDisassociate = Cokleisli (disassociate . extract)++instance Comonad m => Disassociative (Cokleisli m) (Bi (,)) where+  disassociate = cokleisliDisassociate++--  instance Associative k p => Disassociative (Dual k) p
Data/Semigroupoid/Coproduct.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE GADTs, EmptyDataDecls #-} module Data.Semigroupoid.Coproduct -  ( L, R, Coproduct(..) ) where+  ( L, R, Coproduct(..), distributeDualCoproduct, factorDualCoproduct) where  import Data.Semigroupoid+import Data.Semigroupoid.Dual  data L a data R a@@ -15,3 +16,11 @@   L f `o` L g = L (f `o` g)   R f `o` R g = R (f `o` g)   _ `o` _ = error "GADT fail"++distributeDualCoproduct :: Dual (Coproduct j k) a b -> Coproduct (Dual j) (Dual k) a b+distributeDualCoproduct (Dual (L l)) = L (Dual l)+distributeDualCoproduct (Dual (R r)) = R (Dual r)++factorDualCoproduct :: Coproduct (Dual j) (Dual k) a b -> Dual (Coproduct j k) a b+factorDualCoproduct (L (Dual l)) = Dual (L l)+factorDualCoproduct (R (Dual r)) = Dual (R r)
+ Data/Semigroupoid/Ob.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+module Data.Semigroupoid.Ob where++import Data.Semigroupoid+import Data.Semigroupoid.Product +import Data.Semigroupoid.Coproduct+import Control.Comonad+import Data.Functor.Bind+import Control.Arrow++class Semigroupoid k => Ob k a where+  semiid :: k a a++instance (Ob l a, Ob r b) => Ob (Product l r) (a,b) where+  semiid = Pair semiid semiid++instance (Ob l a, Semigroupoid r)  => Ob (Coproduct l r) (L a) where+  semiid = L semiid++instance (Semigroupoid l, Ob r a) => Ob (Coproduct l r) (R a) where+  semiid = R semiid++instance (Bind m, Monad m, Ob (->) a) => Ob (Kleisli m) a where+  semiid = Kleisli return++instance (Comonad w, Ob (->) a) => Ob (Cokleisli w) a where+  semiid = Cokleisli extract
Data/Semigroupoid/Product.hs view
@@ -1,10 +1,22 @@ {-# LANGUAGE GADTs #-}-module Data.Semigroupoid.Product where+module Data.Semigroupoid.Product +  ( Product(..)+  , distributeDualProduct+  , factorDualProduct+  ) where  import Data.Semigroupoid+import Data.Semigroupoid.Dual  data Product j k a b where   Pair :: j a b -> k a' b' -> Product j k (a,a') (b,b')  instance (Semigroupoid j, Semigroupoid k) => Semigroupoid (Product j k) where   Pair w x `o` Pair y z = Pair (w `o` y) (x `o` z)++distributeDualProduct :: Dual (Product j k) a b -> Product (Dual j) (Dual k) a b+distributeDualProduct (Dual (Pair l r)) = Pair (Dual l) (Dual r)++factorDualProduct :: Product (Dual j) (Dual k) a b -> Dual (Product j k) a b+factorDualProduct (Pair (Dual l) (Dual r)) = Dual (Pair l r)+
semigroupoid-extras.cabal view
@@ -1,6 +1,6 @@ name:          semigroupoid-extras category:      Control-version:       0.1+version:       0.2 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -10,8 +10,8 @@ homepage:      http://github.com/ekmett/semigroupoid-extras copyright:     Copyright (C) 2011 Edward A. Kmett build-type:    Simple-synopsis:      semigroupoid products and coproducts-description:   semigroupoid products and coproducts+synopsis:      Semigroupoids requiring Haskell extensions+description:   Semigroupoids and semigroupoid operations requiring Haskell extensions  source-repository head   type: git@@ -20,9 +20,14 @@ library   build-depends:      base >= 4 && < 4.4,-    semigroupoids >= 1.1 && < 1.2+    distributive >= 0.1 && < 0.2,+    semigroupoids >= 1.1 && < 1.2,+    comonad >= 1.0 && < 1.1    exposed-modules:+    Data.Semifunctor+    Data.Semifunctor.Associative+    Data.Semigroupoid.Ob     Data.Semigroupoid.Product     Data.Semigroupoid.Coproduct