git.iko.soy/semi-iso-optics
on master help sign in
Moves classes to Control.Category.Structures.
commitf0d5d26b21890916eff8e0caf00f1bbd9db09d8e authorPaweł Nowak <pawel834@gmail.com> dateThu 11 Dec 2014, 16:18 (12 years ago) parent1dc6707
2 files changed+62−48
compare with master
unifiedsplit
Control/Category/Structures.hs+60 Control/SIArrow.hs+2−48
Control/Category/Structures.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{- |
4+Module : Control.Category.Structures
5+Description : Structures in a category.
6+Copyright : (c) Paweł Nowak
7+License : MIT
8+
9+Maintainer : Paweł Nowak <pawel834@gmail.com>
10+Stability : experimental
11+
12+-}
13+module Control.Category.Structures where
14+
15+import Control.Arrow (Kleisli(..))
16+import qualified Control.Arrow as BadArrow
17+import Control.Category
18+import Control.Monad
19+import Prelude hiding (id, (.))
20+
21+infixl 3 ***
22+infixl 2 +++
23+infixl 3 /+/
24+
25+class Category cat => Products cat where
26+ first :: cat a b -> cat (a, c) (b, c)
27+ first a = a *** id
28+
29+ second :: cat a b -> cat (c, a) (c, b)
30+ second a = id *** a
31+
32+ (***) :: cat a b -> cat c d -> cat (a, c) (b, d)
33+ a *** b = first a >>> second b
34+
35+instance Monad m => Products (Kleisli m) where
36+ (***) = (BadArrow.***)
37+
38+class Category cat => Coproducts cat where
39+ left :: cat a b -> cat (Either a c) (Either b c)
40+ left a = a +++ id
41+
42+ right :: cat a b -> cat (Either c a) (Either c b)
43+ right a = id +++ a
44+
45+ (+++) :: cat a b -> cat c d -> cat (Either a c) (Either b d)
46+ a +++ b = left a >>> right b
47+
48+instance Monad m => Coproducts (Kleisli m) where
49+ (+++) = (BadArrow.+++)
50+
51+class Category cat => CatPlus cat where
52+ cempty :: cat a b
53+ (/+/) :: cat a b -> cat a b -> cat a b
54+
55+instance MonadPlus m => CatPlus (Kleisli m) where
56+ cempty = BadArrow.zeroArrow
57+ (/+/) = (BadArrow.<+>)
58+
59+class CategoryTrans t where
60+ clift :: Category cat => cat a b -> t cat a b
Control/SIArrow.hs+2−48
@@ -1,5 +1,4 @@
11{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE PatternSynonyms #-}
32{-# LANGUAGE ConstraintKinds #-}
43{- |
54Module : Control.SIArrow
@@ -10,15 +9,12 @@ License : MIT
109Maintainer : Paweł Nowak <pawel834@gmail.com>
1110Stability : experimental
1211
13−It can be instantiated by both covariant (like Parser) and contravariant
14−(like Printer) functors. Therefore it can be used as a common interface to unify
15−parsing and pretty printing.
1612-}
1713module Control.SIArrow where
1814
1915import Control.Arrow (Kleisli(..))
20−import qualified Control.Arrow as BadArrow
2116import Control.Category
17+import Control.Category.Structures
2218import Control.Lens.Cons
2319import Control.Lens.Empty
2420import Control.Lens.SemiIso
@@ -26,9 +22,6 @@ import Control.Monad
2622import Data.Tuple.Morph
2723import Prelude hiding (id, (.))
2824
29−infixr 3 ***
30−infixr 2 +++
31−infixl 3 /+/
3225infixr 1 ^>>, >>^
3326infixr 1 ^<<, <<^
3427infixl 4 /$/, /$~, ~$/, ~$~
@@ -36,31 +29,7 @@ infixl 5 /*/, */, /*
3629
3730-- Categories.
3831
39−class Category cat => Products cat where
40− first :: cat a b -> cat (a, c) (b, c)
41− first a = a *** id
42−
43− second :: cat a b -> cat (c, a) (c, b)
44− second a = id *** a
45−
46− (***) :: cat a b -> cat c d -> cat (a, c) (b, d)
47− a *** b = first a >>> second b
48−
49−class Category cat => Coproducts cat where
50− left :: cat a b -> cat (Either a c) (Either b c)
51− left a = a +++ id
52−
53− right :: cat a b -> cat (Either c a) (Either c b)
54− right a = id +++ a
55−
56− (+++) :: cat a b -> cat c d -> cat (Either a c) (Either b d)
57− a +++ b = left a >>> right b
58−
59−class Category cat => CategoryPlus cat where
60− cempty :: cat a b
61− (/+/) :: cat a b -> cat a b -> cat a b
62−
63−class (Products cat, Coproducts cat, CategoryPlus cat) => SIArrow cat where
32+class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
6433 siarr :: ASemiIso' a b -> cat a b
6534
6635 sipure :: ASemiIso' b a -> cat a b
@@ -72,21 +41,6 @@ class (Products cat, Coproducts cat, CategoryPlus cat) => SIArrow cat where
7241 simany :: cat () b -> cat () [b]
7342 simany v = sisome v /+/ sipure _Empty
7443
75−class CategoryTrans t where
76− clift :: Category cat => cat a b -> t cat a b
77−
78−-- Kleisli instances.
79−
80−instance Monad m => Products (Kleisli m) where
81− (***) = (BadArrow.***)
82−
83−instance Monad m => Coproducts (Kleisli m) where
84− (+++) = (BadArrow.+++)
85−
86−instance MonadPlus m => CategoryPlus (Kleisli m) where
87− cempty = BadArrow.zeroArrow
88− (/+/) = (BadArrow.<+>)
89−
9044instance MonadPlus m => SIArrow (Kleisli m) where
9145 siarr ai = Kleisli $ either fail return . apply ai
9246