git.iko.soy/semi-iso-optics
on master help sign in
Add category instances for ReifiedSemiIso'.
67c1554Paweł Nowak
Control/Category/Reader.hs+2−1
compare with master
unifiedsplit
@@ -16,6 +16,7 @@ module Control.Category.Reader (
16 ) where
16 ) where
17
17
18import Control.Category
18import Control.Category
19+import Control.Category.Structures
19import Control.SIArrow
20import Control.SIArrow
20import Prelude hiding (id, (.))
21import Prelude hiding (id, (.))
21
22
@@ -34,7 +35,7 @@ instance Products cat => Products (ReaderCT env cat) where
34instance Coproducts cat => Coproducts (ReaderCT env cat) where
35instance Coproducts cat => Coproducts (ReaderCT env cat) where
35 ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
36 ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
36
37
37−instance CategoryPlus cat => CategoryPlus (ReaderCT env cat) where
38+instance CatPlus cat => CatPlus (ReaderCT env cat) where
38 cempty = clift cempty
39 cempty = clift cempty
39 ReaderCT f /+/ ReaderCT g = ReaderCT $ \x -> f x /+/ g x
40 ReaderCT f /+/ ReaderCT g = ReaderCT $ \x -> f x /+/ g x
40
41
Control/Lens/SemiIso.hs+28−7
@@ -97,9 +97,9 @@ module Control.Lens.SemiIso (
97 bifoldl1_
97 bifoldl1_
98 ) where
98 ) where
99
99
100−import Prelude hiding (id, (.))
101−import Control.Arrow
100+import Control.Arrow (Kleisli(..))
102import Control.Category
101import Control.Category
102+import Control.Category.Structures
103import Control.Lens.Internal.SemiIso
103import Control.Lens.Internal.SemiIso
104import Control.Lens.Iso
104import Control.Lens.Iso
105import Data.Foldable
105import Data.Foldable
@@ -107,6 +107,7 @@ import Data.Functor.Identity
107import Data.Profunctor.Exposed
107import Data.Profunctor.Exposed
108import Data.Traversable
108import Data.Traversable
109import Data.Tuple.Morph
109import Data.Tuple.Morph
110+import Prelude hiding (id, (.))
110
111
111-- | A semi-isomorphism is a partial isomorphism with weakened laws.
112-- | A semi-isomorphism is a partial isomorphism with weakened laws.
112--
113--
@@ -140,11 +141,7 @@ instance Category ReifiedSemiIso' where
140 id = ReifiedSemiIso' id
141 id = ReifiedSemiIso' id
141 ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
142 ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
142
143
143−-- | This in an __/incomplete/__ instance, 'arr' and '(&&&)' are undefined.
144−instance Arrow ReifiedSemiIso' where
144+instance Products ReifiedSemiIso' where
145− arr = undefined
146− (&&&) = undefined
147−
148 -- TODO: pattern synonyms dont work here for some reason
145 -- TODO: pattern synonyms dont work here for some reason
149 first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
146 first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
150 ReifiedSemiIso' $ cloneSemiIso $
147 ReifiedSemiIso' $ cloneSemiIso $
@@ -161,6 +158,30 @@ instance Arrow ReifiedSemiIso' where
161 semiIso (runKleisli $ Kleisli f *** Kleisli f')
158 semiIso (runKleisli $ Kleisli f *** Kleisli f')
162 (runKleisli $ Kleisli g *** Kleisli g')
159 (runKleisli $ Kleisli g *** Kleisli g')
163
160
161+instance Coproducts ReifiedSemiIso' where
162+ left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
163+ ReifiedSemiIso' $ cloneSemiIso $
164+ semiIso (runKleisli $ left $ Kleisli f)
165+ (runKleisli $ left $ Kleisli g)
166+
167+ right (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
168+ ReifiedSemiIso' $ cloneSemiIso $
169+ semiIso (runKleisli $ right $ Kleisli f)
170+ (runKleisli $ right $ Kleisli g)
171+
172+ ReifiedSemiIso' ai +++ ReifiedSemiIso' ai' = ReifiedSemiIso' $
173+ withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
174+ semiIso (runKleisli $ Kleisli f +++ Kleisli f')
175+ (runKleisli $ Kleisli g +++ Kleisli g')
176+
177+instance CatPlus ReifiedSemiIso' where
178+ cempty = ReifiedSemiIso' $ alwaysFailing "cempty"
179+
180+ ReifiedSemiIso' ai /+/ ReifiedSemiIso' ai' = ReifiedSemiIso' $
181+ withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
182+ semiIso (runKleisli $ Kleisli f /+/ Kleisli f')
183+ (runKleisli $ Kleisli g /+/ Kleisli g')
184+
164-- | Constructs a semi isomorphism from a pair of functions that can
185-- | Constructs a semi isomorphism from a pair of functions that can
165-- fail with an error message.
186-- fail with an error message.
166semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
187semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
Control/SIArrow.hs+3
@@ -44,6 +44,9 @@ class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
44instance MonadPlus m => SIArrow (Kleisli m) where
44instance MonadPlus m => SIArrow (Kleisli m) where
45 siarr ai = Kleisli $ either fail return . apply ai
45 siarr ai = Kleisli $ either fail return . apply ai
46
46
47+instance SIArrow ReifiedSemiIso' where
48+ siarr = reifySemiIso
49+
47(^>>) :: SIArrow cat => ASemiIso' a b -> cat b c -> cat a c
50(^>>) :: SIArrow cat => ASemiIso' a b -> cat b c -> cat a c
48f ^>> a = a . siarr f
51f ^>> a = a . siarr f
49
52