git.iko.soy/semi-iso-optics
on master help sign in
Add category instances for ReifiedSemiIso'.
commit67c1554771ff5348dd185d1c3920482175858c6e authorPaweł Nowak <pawel834@gmail.com> dateThu 11 Dec 2014, 16:26 (12 years ago) parentf0d5d26
3 files changed+33−8
compare with master
unifiedsplit
Control/Category/Reader.hs+2−1 Control/Lens/SemiIso.hs+28−7 Control/SIArrow.hs+3
Control/Category/Reader.hs+2−1
@@ -16,6 +16,7 @@ module Control.Category.Reader (
1616 ) where
1717
1818import Control.Category
19+import Control.Category.Structures
1920import Control.SIArrow
2021import Prelude hiding (id, (.))
2122
@@ -34,7 +35,7 @@ instance Products cat => Products (ReaderCT env cat) where
3435instance Coproducts cat => Coproducts (ReaderCT env cat) where
3536 ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
3637
37−instance CategoryPlus cat => CategoryPlus (ReaderCT env cat) where
38+instance CatPlus cat => CatPlus (ReaderCT env cat) where
3839 cempty = clift cempty
3940 ReaderCT f /+/ ReaderCT g = ReaderCT $ \x -> f x /+/ g x
4041
Control/Lens/SemiIso.hs+28−7
@@ -97,9 +97,9 @@ module Control.Lens.SemiIso (
9797 bifoldl1_
9898 ) where
9999
100−import Prelude hiding (id, (.))
101−import Control.Arrow
100+import Control.Arrow (Kleisli(..))
102101import Control.Category
102+import Control.Category.Structures
103103import Control.Lens.Internal.SemiIso
104104import Control.Lens.Iso
105105import Data.Foldable
@@ -107,6 +107,7 @@ import Data.Functor.Identity
107107import Data.Profunctor.Exposed
108108import Data.Traversable
109109import Data.Tuple.Morph
110+import Prelude hiding (id, (.))
110111
111112-- | A semi-isomorphism is a partial isomorphism with weakened laws.
112113--
@@ -140,11 +141,7 @@ instance Category ReifiedSemiIso' where
140141 id = ReifiedSemiIso' id
141142 ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
142143
143−-- | This in an __/incomplete/__ instance, 'arr' and '(&&&)' are undefined.
144−instance Arrow ReifiedSemiIso' where
145− arr = undefined
146− (&&&) = undefined
147−
144+instance Products ReifiedSemiIso' where
148145 -- TODO: pattern synonyms dont work here for some reason
149146 first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
150147 ReifiedSemiIso' $ cloneSemiIso $
@@ -161,6 +158,30 @@ instance Arrow ReifiedSemiIso' where
161158 semiIso (runKleisli $ Kleisli f *** Kleisli f')
162159 (runKleisli $ Kleisli g *** Kleisli g')
163160
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+
164185-- | Constructs a semi isomorphism from a pair of functions that can
165186-- fail with an error message.
166187semiIso :: (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
4444instance MonadPlus m => SIArrow (Kleisli m) where
4545 siarr ai = Kleisli $ either fail return . apply ai
4646
47+instance SIArrow ReifiedSemiIso' where
48+ siarr = reifySemiIso
49+
4750(^>>) :: SIArrow cat => ASemiIso' a b -> cat b c -> cat a c
4851f ^>> a = a . siarr f
4952