Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merged the contents of semigroupoid-extras.
- Loading branch information
Showing
8 changed files
with
417 additions
and
4 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Original file line | Diff line number | Diff line change |
---|---|---|---|
@@ -0,0 +1,132 @@ | |||
{-# LANGUAGE GADTs #-} | |||
{-# LANGUAGE MultiParamTypeClasses #-} | |||
{-# LANGUAGE FunctionalDependencies #-} | |||
{-# LANGUAGE FlexibleInstances #-} | |||
{-# LANGUAGE FlexibleContexts #-} | |||
{-# LANGUAGE ScopedTypeVariables #-} | |||
{-# LANGUAGE UndecidableInstances #-} | |||
{-# LANGUAGE CPP #-} | |||
|
|||
#ifndef MIN_VERSION_comonad | |||
#define MIN_VERSION_comonad(x,y,z) 1 | |||
#endif | |||
|
|||
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 | |||
#if MIN_VERSION_comonad(3,0,3) | |||
{-# LANGUAGE Safe #-} | |||
#else | |||
{-# LANGUAGE Trustworthy #-} | |||
#endif | |||
#endif | |||
|
|||
module Data.Semifunctor | |||
( Semifunctor(..) | |||
, Bi(..) | |||
, (#) | |||
, semibimap | |||
, semifirst | |||
, semisecond | |||
, first | |||
, second | |||
, WrappedFunctor(..) | |||
, WrappedTraversable1(..) | |||
, module Control.Category | |||
, module Data.Semigroupoid | |||
, module Data.Semigroupoid.Ob | |||
, module Data.Semigroupoid.Product | |||
) where | |||
|
|||
import Control.Arrow hiding (first, second, left, right) | |||
import Control.Category | |||
import Control.Comonad | |||
import Control.Monad (liftM) | |||
import Data.Distributive | |||
import Data.Functor.Bind | |||
import Data.Functor.Extend | |||
import Data.Traversable | |||
import Data.Semigroup.Traversable | |||
import Data.Semigroupoid | |||
import Data.Semigroupoid.Dual | |||
import Data.Semigroupoid.Ob | |||
import Data.Semigroupoid.Product | |||
import Prelude hiding ((.),id, mapM) | |||
|
|||
-- | Semifunctors map objects to objects, and arrows to arrows preserving connectivity | |||
-- as normal functors, but do not purport to preserve identity arrows. We apply them | |||
-- to semigroupoids, because those don't even claim to offer identity arrows! | |||
class (Semigroupoid c, Semigroupoid d) => Semifunctor f c d | f c -> d, f d -> c where | |||
semimap :: c a b -> d (f a) (f b) | |||
|
|||
data WrappedFunctor f a = WrapFunctor { unwrapFunctor :: f a } | |||
|
|||
instance Functor f => Semifunctor (WrappedFunctor f) (->) (->) where | |||
semimap f = WrapFunctor . fmap f . unwrapFunctor | |||
|
|||
instance (Traversable f, Bind m, Monad m) => Semifunctor (WrappedFunctor f) (Kleisli m) (Kleisli m) where | |||
semimap (Kleisli f) = Kleisli $ liftM WrapFunctor . mapM f . unwrapFunctor | |||
|
|||
instance (Distributive f, Extend w) => Semifunctor (WrappedFunctor f) (Cokleisli w) (Cokleisli w) where | |||
semimap (Cokleisli w) = Cokleisli $ WrapFunctor . cotraverse w . fmap unwrapFunctor | |||
|
|||
data WrappedTraversable1 f a = WrapTraversable1 { unwrapTraversable1 :: f a } | |||
|
|||
instance (Traversable1 f, Bind m) => Semifunctor (WrappedTraversable1 f) (Kleisli m) (Kleisli m) where | |||
semimap (Kleisli f) = Kleisli $ fmap WrapTraversable1 . traverse1 f . unwrapTraversable1 | |||
|
|||
-- | Used to map a more traditional bifunctor into a semifunctor | |||
data Bi p a where | |||
Bi :: p a b -> Bi p (a,b) | |||
|
|||
instance Semifunctor f c d => Semifunctor f (Dual c) (Dual d) where | |||
semimap (Dual f) = Dual (semimap f) | |||
|
|||
(#) :: a -> b -> Bi (,) (a,b) | |||
a # b = Bi (a,b) | |||
|
|||
fstP :: Bi (,) (a, b) -> a | |||
fstP (Bi (a,_)) = a | |||
|
|||
sndP :: Bi (,) (a, b) -> b | |||
sndP (Bi (_,b)) = b | |||
|
|||
left :: a -> Bi Either (a,b) | |||
left = Bi . Left | |||
|
|||
right :: b -> Bi Either (a,b) | |||
right = Bi . Right | |||
|
|||
instance Semifunctor (Bi (,)) (Product (->) (->)) (->) where | |||
semimap (Pair l r) (Bi (a,b)) = l a # r b | |||
|
|||
instance Semifunctor (Bi Either) (Product (->) (->)) (->) where | |||
semimap (Pair l _) (Bi (Left a)) = Bi (Left (l a)) | |||
semimap (Pair _ r) (Bi (Right b)) = Bi (Right (r b)) | |||
|
|||
instance Bind m => Semifunctor (Bi (,)) (Product (Kleisli m) (Kleisli m)) (Kleisli m) where | |||
semimap (Pair l r) = Kleisli (\ (Bi (a, b)) -> (#) <$> runKleisli l a <.> runKleisli r b) | |||
|
|||
instance Bind m => Semifunctor (Bi Either) (Product (Kleisli m) (Kleisli m)) (Kleisli m) where | |||
semimap (Pair (Kleisli l0) (Kleisli r0)) = Kleisli (lr l0 r0) where | |||
lr :: Functor m => (a -> m c) -> (b -> m d) -> Bi Either (a,b) -> m (Bi Either (c,d)) | |||
lr l _ (Bi (Left a)) = left <$> l a | |||
lr _ r (Bi (Right b)) = right <$> r b | |||
|
|||
instance Extend w => Semifunctor (Bi (,)) (Product (Cokleisli w) (Cokleisli w)) (Cokleisli w) where | |||
semimap (Pair l r) = Cokleisli $ \p -> runCokleisli l (fstP <$> p) # runCokleisli r (sndP <$> p) | |||
|
|||
-- instance Extend w => Semifunctor (Bi Either)) (Product (Cokleisli w) (Cokleisli w)) (Cokleisli w) where | |||
|
|||
semibimap :: Semifunctor p (Product l r) cod => l a b -> r c d -> cod (p (a,c)) (p (b,d)) | |||
semibimap f g = semimap (Pair f g) | |||
|
|||
semifirst :: (Semifunctor p (Product l r) cod, Ob r c) => l a b -> cod (p (a,c)) (p (b,c)) | |||
semifirst f = semimap (Pair f semiid) | |||
|
|||
semisecond :: (Semifunctor p (Product l r) cod, Ob l a) => r b c -> cod (p (a,b)) (p (a,c)) | |||
semisecond f = semimap (Pair semiid f) | |||
|
|||
first :: (Semifunctor p (Product l r) cod, Category r) => l a b -> cod (p (a,c)) (p (b,c)) | |||
first f = semimap (Pair f id) | |||
|
|||
second :: (Semifunctor p (Product l r) cod, Category l) => r b c -> cod (p (a,b)) (p (a,c)) | |||
second f = semimap (Pair id f) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Original file line | Diff line number | Diff line change |
---|---|---|---|
@@ -0,0 +1,89 @@ | |||
{-# LANGUAGE GADTs #-} | |||
{-# LANGUAGE MultiParamTypeClasses #-} | |||
{-# LANGUAGE FlexibleContexts #-} | |||
{-# LANGUAGE FlexibleInstances #-} | |||
----------------------------------------------------------------------------- | |||
-- | | |||
-- Module : Data.Semifunctor.Associative | |||
-- Copyright : (C) 2011-2012 Edward Kmett, | |||
-- License : BSD-style (see the file LICENSE) | |||
-- | |||
-- Maintainer : Edward Kmett <ekmett@gmail.com> | |||
-- Stability : experimental | |||
-- Portability : MPTCs, GADTs | |||
-- | |||
---------------------------------------------------------------------------- | |||
module Data.Semifunctor.Associative where | |||
|
|||
import Prelude hiding ((.), id) | |||
import Control.Arrow | |||
import Control.Comonad | |||
import Data.Functor.Bind | |||
import Data.Functor.Extend | |||
import Data.Semifunctor | |||
-- import Data.Isomorphism | |||
|
|||
class Semifunctor p (Product k k) k => Associative k p where | |||
associate :: k (p(p(a,b),c)) (p(a,p(b,c))) | |||
|
|||
instance Associative (->) (Bi Either) where | |||
associate (Bi (Left (Bi (Left a)))) = Bi (Left a) | |||
associate (Bi (Left (Bi (Right b)))) = Bi (Right (Bi (Left b))) | |||
associate (Bi (Right c)) = Bi (Right (Bi (Right c))) | |||
|
|||
instance Associative (->) (Bi (,)) where | |||
associate (Bi (Bi (a,b),c)) = Bi(a, Bi(b, c)) | |||
|
|||
kleisliAssociate :: (Monad m, Semifunctor p (Product (Kleisli m) (Kleisli m)) (Kleisli m), Associative (->) p) => Kleisli m (p(p(a,b),c)) (p(a,p(b,c))) | |||
kleisliAssociate = Kleisli (return . associate) | |||
|
|||
instance (Bind m, Monad m) => Associative (Kleisli m) (Bi Either) where | |||
associate = kleisliAssociate | |||
|
|||
instance (Bind m, Monad m) => Associative (Kleisli m) (Bi (,)) where | |||
associate = kleisliAssociate | |||
|
|||
cokleisliAssociate :: (Comonad m, Semifunctor p (Product (Cokleisli m) (Cokleisli m)) (Cokleisli m), Associative (->) p) => Cokleisli m (p(p(a,b),c)) (p(a,p(b,c))) | |||
cokleisliAssociate = Cokleisli (associate . extract) | |||
|
|||
instance (Extend m, Comonad m) => Associative (Cokleisli m) (Bi (,)) where | |||
associate = cokleisliAssociate | |||
|
|||
-- instance Comonad m => Associative (Cokleisli m) (Bi Either) where associate = cokleisliAssociate | |||
|
|||
-- instance Disassociative k p => Associative (Dual k) p | |||
-- instance (Monad m, Semifunctor p (Product (Kleisli m) (Kleisli m) (Kleisli m), Associative (->) p) => Associative (Kleisli m) p) where associate = kleisliAssociate | |||
|
|||
class Semifunctor p (Product k k) k => Disassociative k p where | |||
disassociate :: k (p(a,p(b,c))) (p(p(a,b),c)) | |||
|
|||
instance Disassociative (->) (Bi Either) where | |||
disassociate (Bi (Left a)) = Bi (Left (Bi (Left a))) | |||
disassociate (Bi (Right (Bi (Left b)))) = Bi (Left (Bi (Right b))) | |||
disassociate (Bi (Right (Bi (Right b)))) = Bi (Right b) | |||
|
|||
instance Disassociative (->) (Bi (,)) where | |||
disassociate (Bi(a, Bi(b, c))) = Bi (Bi (a,b),c) | |||
|
|||
kleisliDisassociate :: (Monad m, Semifunctor p (Product (Kleisli m) (Kleisli m)) (Kleisli m), Disassociative (->) p) => Kleisli m (p(a,p(b,c))) (p(p(a,b),c)) | |||
kleisliDisassociate = Kleisli (return . disassociate) | |||
|
|||
instance (Bind m, Monad m) => Disassociative (Kleisli m) (Bi Either) where | |||
disassociate = kleisliDisassociate | |||
|
|||
instance (Bind m, Monad m) => Disassociative (Kleisli m) (Bi (,)) where | |||
disassociate = kleisliDisassociate | |||
|
|||
cokleisliDisassociate :: (Comonad m, Semifunctor p (Product (Cokleisli m) (Cokleisli m)) (Cokleisli m), Disassociative (->) p) => Cokleisli m (p(a,p(b,c))) (p(p(a,b),c)) | |||
cokleisliDisassociate = Cokleisli (disassociate . extract) | |||
|
|||
instance (Extend m, Comonad m) => Disassociative (Cokleisli m) (Bi (,)) where | |||
disassociate = cokleisliDisassociate | |||
|
|||
-- instance Associative k p => Disassociative (Dual k) p | |||
|
|||
-- instance (Associative k p, Disassociative k p) => Associative (Iso k) p where | |||
-- associate = Iso associate disassociate | |||
|
|||
--instance (Associative k p, Disassociative k p) => Disassociative (Iso k) p where | |||
-- disassociate = Iso disassociate associate |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Original file line | Diff line number | Diff line change |
---|---|---|---|
@@ -0,0 +1,84 @@ | |||
{-# LANGUAGE GADTs #-} | |||
{-# LANGUAGE MultiParamTypeClasses #-} | |||
{-# LANGUAGE FlexibleContexts #-} | |||
{-# LANGUAGE FlexibleInstances #-} | |||
{-# LANGUAGE CPP #-} | |||
#ifndef MIN_VERSION_comonad | |||
#define MIN_VERSION_comonad(x,y,z) 1 | |||
#endif | |||
|
|||
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 | |||
#if MIN_VERSION_comonad(3,0,3) | |||
{-# LANGUAGE Safe #-} | |||
#else | |||
{-# LANGUAGE Trustworthy #-} | |||
#endif | |||
#endif | |||
----------------------------------------------------------------------------- | |||
-- | | |||
-- Module : Data.Semifunctor.Braided | |||
-- Copyright : (C) 2011-2012 Edward Kmett, | |||
-- License : BSD-style (see the file LICENSE) | |||
-- | |||
-- Maintainer : Edward Kmett <ekmett@gmail.com> | |||
-- Stability : experimental | |||
-- Portability : MPTCs, GADTs | |||
-- | |||
---------------------------------------------------------------------------- | |||
module Data.Semifunctor.Braided | |||
( Braided(..) | |||
, kleisliBraid | |||
, cokleisliBraid | |||
, Symmetric | |||
, swap | |||
) where | |||
|
|||
import Prelude hiding ((.), id) | |||
import Control.Arrow | |||
import Control.Comonad | |||
import Data.Functor.Bind | |||
import Data.Functor.Extend | |||
import Data.Semifunctor | |||
import Data.Semifunctor.Associative | |||
-- import Data.Semigroupoid.Dual | |||
|
|||
class Associative k p => Braided k p where | |||
braid :: k (p(a,b)) (p(b,a)) | |||
|
|||
-- instance Braided k p => Braided (Dual k) p where braid = Dual braid | |||
|
|||
instance Braided (->) (Bi Either) where | |||
braid (Bi (Left a)) = Bi (Right a) | |||
braid (Bi (Right a)) = Bi (Left a) | |||
|
|||
instance Braided (->) (Bi (,)) where | |||
braid (Bi (a,b)) = Bi (b,a) | |||
|
|||
kleisliBraid :: (Monad m, Semifunctor p (Product (Kleisli m) (Kleisli m)) (Kleisli m), Braided (->) p) => Kleisli m (p(a,b)) (p(b,a)) | |||
kleisliBraid = Kleisli (return . braid) | |||
|
|||
instance (Bind m, Monad m) => Braided (Kleisli m) (Bi Either) where | |||
braid = kleisliBraid | |||
|
|||
instance (Bind m, Monad m) => Braided (Kleisli m) (Bi (,)) where | |||
braid = kleisliBraid | |||
|
|||
cokleisliBraid :: (Extend w, Comonad w, Semifunctor p (Product (Cokleisli w) (Cokleisli w)) (Cokleisli w), Braided (->) p) => | |||
Cokleisli w (p(a,b)) (p(b,a)) | |||
cokleisliBraid = Cokleisli (braid . extract) | |||
|
|||
instance (Extend w, Comonad w) => Braided (Cokleisli w) (Bi (,)) where | |||
braid = cokleisliBraid | |||
|
|||
-- instance Comonad w => Braided (Cokleisli w) (Bi Either) where braid = cokleisliBraid | |||
|
|||
class Braided k p => Symmetric k p | |||
instance Symmetric (->) (Bi Either) | |||
instance Symmetric (->) (Bi (,)) | |||
instance (Bind m, Monad m) => Symmetric (Kleisli m) (Bi Either) | |||
instance (Bind m, Monad m) => Symmetric (Kleisli m) (Bi (,)) | |||
instance (Extend w, Comonad w) => Symmetric (Cokleisli w) (Bi (,)) | |||
-- instance Comonad w => Symmetric (Cokleisli w) (Bi Either) | |||
|
|||
swap :: Symmetric k p => k (p(a,b)) (p(b,a)) | |||
swap = braid |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Original file line | Diff line number | Diff line change |
---|---|---|---|
@@ -0,0 +1,31 @@ | |||
{-# LANGUAGE GADTs, EmptyDataDecls #-} | |||
module Data.Semigroupoid.Coproduct | |||
( L, R, Coproduct(..), distributeDualCoproduct, factorDualCoproduct) where | |||
|
|||
import Data.Semigroupoid | |||
import Data.Semigroupoid.Dual | |||
import Data.Groupoid | |||
|
|||
data L a | |||
data R a | |||
|
|||
data Coproduct j k a b where | |||
L :: j a b -> Coproduct j k (L a) (L b) | |||
R :: k a b -> Coproduct j k (R a) (R b) | |||
|
|||
instance (Semigroupoid j, Semigroupoid k) => Semigroupoid (Coproduct j k) where | |||
L f `o` L g = L (f `o` g) | |||
R f `o` R g = R (f `o` g) | |||
_ `o` _ = error "GADT fail" | |||
|
|||
instance (Groupoid j, Groupoid k) => Groupoid (Coproduct j k) where | |||
inv (L f) = L (inv f) | |||
inv (R f) = R (inv f) | |||
|
|||
distributeDualCoproduct :: Dual (Coproduct j k) a b -> Coproduct (Dual j) (Dual k) a b | |||
distributeDualCoproduct (Dual (L l)) = L (Dual l) | |||
distributeDualCoproduct (Dual (R r)) = R (Dual r) | |||
|
|||
factorDualCoproduct :: Coproduct (Dual j) (Dual k) a b -> Dual (Coproduct j k) a b | |||
factorDualCoproduct (L (Dual l)) = Dual (L l) | |||
factorDualCoproduct (R (Dual r)) = Dual (R r) |
Oops, something went wrong.