git.iko.soy/semi-iso-optics
on master help sign in
Moves classes to Control.Category.Structures.
f0d5d26Paweł Nowak
Control/Category/Structures.hsnew file+60
compare with master
unifiedsplit
@@ -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 @@
1{-# LANGUAGE TypeFamilies #-}
1{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE PatternSynonyms #-}
3{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
4{- |
3{- |
5Module : Control.SIArrow
4Module : Control.SIArrow
@@ -10,15 +9,12 @@ License : MIT
10Maintainer : Paweł Nowak <pawel834@gmail.com>
9Maintainer : Paweł Nowak <pawel834@gmail.com>
11Stability : experimental
10Stability : experimental
12
11
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.
16-}
12-}
17module Control.SIArrow where
13module Control.SIArrow where
18
14
19import Control.Arrow (Kleisli(..))
15import Control.Arrow (Kleisli(..))
20−import qualified Control.Arrow as BadArrow
21import Control.Category
16import Control.Category
17+import Control.Category.Structures
22import Control.Lens.Cons
18import Control.Lens.Cons
23import Control.Lens.Empty
19import Control.Lens.Empty
24import Control.Lens.SemiIso
20import Control.Lens.SemiIso
@@ -26,9 +22,6 @@ import Control.Monad
26import Data.Tuple.Morph
22import Data.Tuple.Morph
27import Prelude hiding (id, (.))
23import Prelude hiding (id, (.))
28
24
29−infixr 3 ***
30−infixr 2 +++
31−infixl 3 /+/
32infixr 1 ^>>, >>^
25infixr 1 ^>>, >>^
33infixr 1 ^<<, <<^
26infixr 1 ^<<, <<^
34infixl 4 /$/, /$~, ~$/, ~$~
27infixl 4 /$/, /$~, ~$/, ~$~
@@ -36,31 +29,7 @@ infixl 5 /*/, */, /*
36
29
37-- Categories.
30-- Categories.
38
31
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
64 siarr :: ASemiIso' a b -> cat a b
33 siarr :: ASemiIso' a b -> cat a b
65
34
66 sipure :: ASemiIso' b a -> cat a b
35 sipure :: ASemiIso' b a -> cat a b
@@ -72,21 +41,6 @@ class (Products cat, Coproducts cat, CategoryPlus cat) => SIArrow cat where
72 simany :: cat () b -> cat () [b]
41 simany :: cat () b -> cat () [b]
73 simany v = sisome v /+/ sipure _Empty
42 simany v = sisome v /+/ sipure _Empty
74
43
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−
90instance MonadPlus m => SIArrow (Kleisli m) where
44instance MonadPlus m => SIArrow (Kleisli m) where
91 siarr ai = Kleisli $ either fail return . apply ai
45 siarr ai = Kleisli $ either fail return . apply ai
92
46