git.iko.soy/semi-iso-optics
on master help sign in
Transition to optics (#6)

* Moved stuff to base Arrows * Removed semigroupoids

commitde16c6d8941ce98ea4fbfb963226ad07297f5777 authoriko <ilyakooo0@gmail.com> dateSat 11 Jul 2026, 05:01 (3 months ago) parent74954e5
6 files changed+30−135
unifiedsplit
package.yaml−1 src/Control/Category/Reader.hs+9−5 src/Control/Category/Structures.hs+1−88 src/Control/Lens/SemiIso.hs+12−11 src/Control/SIArrow.hs+7−29 src/Data/Profunctor/Exposed.hs+1−1
package.yaml−1
@@ -21,7 +21,6 @@ dependencies:
2121- base >= 4.7 && < 5
2222- profunctors
2323- lens
24−- semigroupoids
2524
2625library:
2726 source-dirs: src
src/Control/Category/Reader.hs+9−5
@@ -15,6 +15,7 @@ module Control.Category.Reader (
1515 ReaderCT(..)
1616 ) where
1717
18+import Control.Arrow
1819import Control.Category
1920import Control.Category.Structures
2021import Control.Lens.Iso
@@ -31,15 +32,18 @@ instance Category cat => Category (ReaderCT env cat) where
3132 id = clift id
3233 ReaderCT f . ReaderCT g = ReaderCT $ \x -> f x . g x
3334
34−instance Products cat => Products (ReaderCT env cat) where
35+instance Arrow cat => Arrow (ReaderCT env cat) where
36+ arr f = ReaderCT $ \_ -> arr f
3537 ReaderCT f *** ReaderCT g = ReaderCT $ \x -> f x *** g x
3638
37−instance Coproducts cat => Coproducts (ReaderCT env cat) where
39+instance ArrowChoice cat => ArrowChoice (ReaderCT env cat) where
3840 ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
3941
40−instance CatPlus cat => CatPlus (ReaderCT env cat) where
41− cempty = clift cempty
42− ReaderCT f /+/ ReaderCT g = ReaderCT $ \x -> f x /+/ g x
42+instance ArrowZero cat => ArrowZero (ReaderCT env cat) where
43+ zeroArrow = clift zeroArrow
44+
45+instance ArrowPlus cat => ArrowPlus (ReaderCT env cat) where
46+ ReaderCT f <+> ReaderCT g = ReaderCT $ \x -> f x <+> g x
4347
4448instance SIArrow cat => SIArrow (ReaderCT env cat) where
4549 siarr = clift . siarr
src/Control/Category/Structures.hs+1−88
@@ -16,99 +16,12 @@ way then "Control.Arrow".
1616Unfortunately names in this module clash with "Control.Arrow".
1717-}
1818module Control.Category.Structures
19− ( Products(..)
20− , Coproducts(..)
21− , CatPlus(..)
22− , CatTrans(..)
19+ ( CatTrans(..)
2320 ) where
2421
25−import Control.Arrow (Kleisli(..))
26−import qualified Control.Arrow as BadArrow
2722import Control.Category
28−import Control.Monad
29−import Data.Semigroupoid.Dual
3023import Prelude hiding (id, (.))
3124
32−infixl 3 ***
33−infixl 2 +++
34−infixl 3 /+/
35−
36−-- | A category with finite products.
37−class Category cat => Products cat where
38− -- | Send the first component of the input through the argument arrow, and copy the rest unchanged to the output.
39− --
40− -- @first a@ is equal to @a *** id@.
41− first :: cat a b -> cat (a, c) (b, c)
42− first a = a *** id
43−
44− -- | A mirror image of 'first'.
45− --
46− -- @second a@ is equal to @id *** a@.
47− second :: cat a b -> cat (c, a) (c, b)
48− second a = id *** a
49−
50− -- | A product of two arrows.
51− -- Split the input between the two argument arrows and combine their output.
52− (***) :: cat a b -> cat c d -> cat (a, c) (b, d)
53− a *** b = first a >>> second b
54−
55− {-# MINIMAL (***) | first, second #-}
56−
57−instance Monad m => Products (Kleisli m) where
58− (***) = (BadArrow.***)
59−
60−instance Products cat => Products (Dual cat) where
61− Dual f *** Dual g = Dual $ second g >>> first f
62−
63−instance Products (->) where
64− (***) = (BadArrow.***)
65−
66−-- | A category with finite coproducts.
67−class Category cat => Coproducts cat where
68− -- | Feed marked inputs through the argument arrow, passing the rest through unchanged to the output.
69− --
70− -- @left a@ is equal to @a +++ id@.
71− left :: cat a b -> cat (Either a c) (Either b c)
72− left a = a +++ id
73−
74− -- | A mirror image of left.
75− --
76− -- @right a@ is equal to @id +++ a@.
77− right :: cat a b -> cat (Either c a) (Either c b)
78− right a = id +++ a
79−
80− -- | A coproduct of two arrows.
81− -- Split the input between the two argument arrows, retagging and merging their outputs.
82− (+++) :: cat a b -> cat c d -> cat (Either a c) (Either b d)
83− a +++ b = left a >>> right b
84−
85− {-# MINIMAL (+++) | left, right #-}
86−
87−instance Monad m => Coproducts (Kleisli m) where
88− (+++) = (BadArrow.+++)
89−
90−instance Coproducts cat => Coproducts (Dual cat) where
91− Dual f +++ Dual g = Dual $ right g >>> left f
92−
93−instance Coproducts (->) where
94− (+++) = (BadArrow.+++)
95−
96−-- | A category @cat@ is a CatPlus when @cat a b@ is a monoid for all a, b.
97−class Category cat => CatPlus cat where
98− -- | The identity of '/+/'.
99− cempty :: cat a b
100− -- | An associative operation on arrows.
101− (/+/) :: cat a b -> cat a b -> cat a b
102−
103− {-# MINIMAL cempty, (/+/) #-}
104−
105−instance MonadPlus m => CatPlus (Kleisli m) where
106− cempty = BadArrow.zeroArrow
107− (/+/) = (BadArrow.<+>)
108−
109−instance CatPlus cat => CatPlus (Dual cat) where
110− cempty = Dual cempty
111− Dual f /+/ Dual g = Dual $ f /+/ g
11225
11326-- | A category transformer.
11427class CatTrans t where
src/Control/Lens/SemiIso.hs+12−11
@@ -100,9 +100,8 @@ module Control.Lens.SemiIso (
100100 bifoldl1_
101101 ) where
102102
103−import Control.Arrow (Kleisli(..))
103+import Control.Arrow
104104import Control.Category
105−import Control.Category.Structures
106105import Control.Lens.Internal.SemiIso
107106import Control.Lens.Iso
108107import Control.Tuple.Morph
@@ -148,7 +147,8 @@ instance Category ReifiedSemiIso' where
148147 id = ReifiedSemiIso' id
149148 ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
150149
151−instance Products ReifiedSemiIso' where
150+instance Arrow ReifiedSemiIso' where
151+ arr f = ReifiedSemiIso' $ semiIso (Right . f) (const $ Left "oh no")
152152 -- TODO: pattern synonyms dont work here for some reason
153153 first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
154154 ReifiedSemiIso' $ cloneSemiIso $
@@ -165,7 +165,7 @@ instance Products ReifiedSemiIso' where
165165 semiIso (runKleisli $ Kleisli f *** Kleisli f')
166166 (runKleisli $ Kleisli g *** Kleisli g')
167167
168−instance Coproducts ReifiedSemiIso' where
168+instance ArrowChoice ReifiedSemiIso' where
169169 left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
170170 ReifiedSemiIso' $ cloneSemiIso $
171171 semiIso (runKleisli $ left $ Kleisli f)
@@ -181,18 +181,19 @@ instance Coproducts ReifiedSemiIso' where
181181 semiIso (runKleisli $ Kleisli f +++ Kleisli f')
182182 (runKleisli $ Kleisli g +++ Kleisli g')
183183
184−instance CatPlus ReifiedSemiIso' where
185− cempty = ReifiedSemiIso' $ alwaysFailing "cempty"
184+instance ArrowZero ReifiedSemiIso' where
185+ zeroArrow = ReifiedSemiIso' $ alwaysFailing "zeroArrow"
186186
187− ReifiedSemiIso' ai /+/ ReifiedSemiIso' ai' = ReifiedSemiIso' $
187+instance ArrowPlus ReifiedSemiIso' where
188+ ReifiedSemiIso' ai <+> ReifiedSemiIso' ai' = ReifiedSemiIso' $
188189 withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
189− semiIso (runKleisli $ Kleisli f /+/ Kleisli f')
190− (runKleisli $ Kleisli g /+/ Kleisli g')
190+ semiIso (runKleisli $ Kleisli f <+> Kleisli f')
191+ (runKleisli $ Kleisli g <+> Kleisli g')
191192
192193-- | Constructs a semi isomorphism from a pair of functions that can
193194-- fail with an error message.
194195semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
195−semiIso sa bt = merge . dimap sa (sequenceA . fmap bt) . expose
196+semiIso sa bt = merge . dimap sa (traverse bt) . expose
196197
197198-- | Clones a semi-iso.
198199cloneSemiIso :: ASemiIso s t a b -> SemiIso s t a b
@@ -307,7 +308,7 @@ elimFirst ai = swapped . elimSecond ai
307308-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
308309-- i.e. eliminates the second pair element.
309310elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
310−elimSecond ai = runSemiIso (id *** reifySemiIso ai) . rev unit
311+elimSecond ai = runSemiIso (second $ reifySemiIso ai) . rev unit
311312
312313-- | Transforms the semi-iso so that applying it in both directions never fails,
313314-- but instead catches any errors and returns them as an @Either String a@.
src/Control/SIArrow.hs+7−29
@@ -33,20 +33,18 @@ module Control.SIArrow (
3333 sireplicate_
3434 ) where
3535
36−import Control.Arrow (Kleisli(..))
36+import Control.Arrow
3737import Control.Category
38−import Control.Category.Structures
3938import Control.Lens.Cons
4039import Control.Lens.Empty
4140import Control.Lens.Iso
4241import Control.Lens.SemiIso
4342import Control.Monad
4443import Control.Tuple.Morph
45−import Data.Semigroupoid.Dual
4644import Prelude hiding (id, (.))
4745
48−infixr 1 ^>>, ^<<, #>>, #<<
49−infixr 1 >>^, <<^, >>#, <<#
46+infixr 1 #>>, #<<
47+infixr 1 >>#, <<#
5048infixl 4 /$/, /$~
5149infixl 5 /*/, */, /*
5250infixl 3 /?/
@@ -59,7 +57,7 @@ infixl 3 /?/
5957--
6058-- The category @cat@ should contain @SemiIso@ as a sort of
6159-- \"subcategory of pure computations\".
62−class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
60+class (Arrow cat, ArrowChoice cat, ArrowPlus cat) => SIArrow cat where
6361 -- | Allows you to lift a SemiIso into @cat@. The resulting arrow should be
6462 -- in some sense minimal or \"pure\", similiar to 'pure', 'return' and
6563 -- 'arr' from "Control.Category".
@@ -87,7 +85,7 @@ class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
8785
8886 -- | @simany v@ repeats @v@ as long as possible.
8987 simany :: cat () b -> cat () [b]
90− simany v = sisome v /+/ sipure _Empty
88+ simany v = sisome v <+> sipure _Empty
9189
9290 {-# MINIMAL (siarr | sipure), sibind #-}
9391
@@ -95,32 +93,12 @@ instance MonadPlus m => SIArrow (Kleisli m) where
9593 siarr ai = Kleisli $ either fail return . apply ai
9694 sibind ai = Kleisli $ \a -> either fail (($ a) . runKleisli) $ apply ai a
9795
98−instance SIArrow cat => SIArrow (Dual cat) where
99− siarr = Dual . sipure
100− sibind ai = Dual $ sibind (iso id getDual . rev ai . iso getDual id)
101−
10296instance SIArrow ReifiedSemiIso' where
10397 siarr = reifySemiIso
10498 sibind ai = ReifiedSemiIso' $
10599 semiIso (\a -> apply ai a >>= flip apply a . runSemiIso)
106100 (\b -> unapply ai b >>= flip unapply b . runSemiIso)
107101
108−-- | Composes a SemiIso with an arrow.
109−(^>>) :: SIArrow cat => ASemiIso' a b -> cat b c -> cat a c
110−f ^>> a = a . siarr f
111−
112−-- | Composes an arrow with a SemiIso.
113−(>>^) :: SIArrow cat => cat a b -> ASemiIso' b c -> cat a c
114−a >>^ f = siarr f . a
115−
116−-- | Composes a SemiIso with an arrow, backwards.
117−(^<<) :: SIArrow cat => ASemiIso' b c -> cat a b -> cat a c
118−f ^<< a = siarr f . a
119−
120−-- | Composes an arrow with a SemiIso, backwards.
121−(<<^) :: SIArrow cat => cat b c -> ASemiIso' a b -> cat a c
122−a <<^ f = a . siarr f
123−
124102-- | Composes a reversed SemiIso with an arrow.
125103(#>>) :: SIArrow cat => ASemiIso' b a -> cat b c -> cat a c
126104f #>> a = a . sipure f
@@ -171,7 +149,7 @@ ai /$<~> h = cloneSemiIso ai . reorderMorphed /$/ h
171149--
172150-- The uncurried analogue of '<*>'.
173151(/*/) :: SIArrow cat => cat () b -> cat () c -> cat () (b, c)
174−a /*/ b = unit ^>> (a *** b)
152+a /*/ b = siarr unit >>> (a *** b)
175153
176154-- | The product of two arrows, where the second one has no input and no output
177155-- (but can have side effects), with duplicate units removed. Side effect are
@@ -195,7 +173,7 @@ sifail = siarr . alwaysFailing
195173
196174-- | Provides an error message in the case of failure.
197175(/?/) :: SIArrow cat => cat a b -> String -> cat a b
198−f /?/ msg = f /+/ sifail msg
176+f /?/ msg = f <+> sifail msg
199177
200178-- | Equivalent of 'sequence'.
201179sisequence :: SIArrow cat => [cat () a] -> cat () [a]
src/Data/Profunctor/Exposed.hs+1−1
@@ -1,5 +1,5 @@
11{-# LANGUAGE FunctionalDependencies #-}
2−{-# LANGUAGE MultiParamTypeClasses #-}
2+
33{- |
44Module : Data.Profunctor.Exposed
55Description : Exposes Kleisli category structure beneath a profunctor.