git.iko.soy/semi-iso-optics
on master help sign in
Transition to optics (#6)
de16c6diko
package.yaml−1
unifiedsplit
@@ -21,7 +21,6 @@ dependencies:
21- base >= 4.7 && < 5
21- base >= 4.7 && < 5
22- profunctors
22- profunctors
23- lens
23- lens
24−- semigroupoids
25
24
26library:
25library:
27 source-dirs: src
26 source-dirs: src
src/Control/Category/Reader.hs+9−5
@@ -15,6 +15,7 @@ module Control.Category.Reader (
15 ReaderCT(..)
15 ReaderCT(..)
16 ) where
16 ) where
17
17
18+import Control.Arrow
18import Control.Category
19import Control.Category
19import Control.Category.Structures
20import Control.Category.Structures
20import Control.Lens.Iso
21import Control.Lens.Iso
@@ -31,15 +32,18 @@ instance Category cat => Category (ReaderCT env cat) where
31 id = clift id
32 id = clift id
32 ReaderCT f . ReaderCT g = ReaderCT $ \x -> f x . g x
33 ReaderCT f . ReaderCT g = ReaderCT $ \x -> f x . g x
33
34
34−instance Products cat => Products (ReaderCT env cat) where
35+instance Arrow cat => Arrow (ReaderCT env cat) where
36+ arr f = ReaderCT $ \_ -> arr f
35 ReaderCT f *** ReaderCT g = ReaderCT $ \x -> f x *** g x
37 ReaderCT f *** ReaderCT g = ReaderCT $ \x -> f x *** g x
36
38
37−instance Coproducts cat => Coproducts (ReaderCT env cat) where
39+instance ArrowChoice cat => ArrowChoice (ReaderCT env cat) where
38 ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
40 ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
39
41
40−instance CatPlus cat => CatPlus (ReaderCT env cat) where
42+instance ArrowZero cat => ArrowZero (ReaderCT env cat) where
41− cempty = clift cempty
43+ zeroArrow = clift zeroArrow
44+
45+instance ArrowPlus cat => ArrowPlus (ReaderCT env cat) where
42− ReaderCT f /+/ ReaderCT g = ReaderCT $ \x -> f x /+/ g x
46+ ReaderCT f <+> ReaderCT g = ReaderCT $ \x -> f x <+> g x
43
47
44instance SIArrow cat => SIArrow (ReaderCT env cat) where
48instance SIArrow cat => SIArrow (ReaderCT env cat) where
45 siarr = clift . siarr
49 siarr = clift . siarr
src/Control/Category/Structures.hs+1−88
@@ -16,99 +16,12 @@ way then "Control.Arrow".
16Unfortunately names in this module clash with "Control.Arrow".
16Unfortunately names in this module clash with "Control.Arrow".
17-}
17-}
18module Control.Category.Structures
18module Control.Category.Structures
19− ( Products(..)
20− , Coproducts(..)
21− , CatPlus(..)
22− , CatTrans(..)
19+ ( CatTrans(..)
23 ) where
20 ) where
24
21
25−import Control.Arrow (Kleisli(..))
26−import qualified Control.Arrow as BadArrow
27import Control.Category
22import Control.Category
28−import Control.Monad
29−import Data.Semigroupoid.Dual
30import Prelude hiding (id, (.))
23import Prelude hiding (id, (.))
31
24
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
112
25
113-- | A category transformer.
26-- | A category transformer.
114class CatTrans t where
27class CatTrans t where
src/Control/Lens/SemiIso.hs+12−11
@@ -100,9 +100,8 @@ module Control.Lens.SemiIso (
100 bifoldl1_
100 bifoldl1_
101 ) where
101 ) where
102
102
103−import Control.Arrow (Kleisli(..))
103+import Control.Arrow
104import Control.Category
104import Control.Category
105−import Control.Category.Structures
106import Control.Lens.Internal.SemiIso
105import Control.Lens.Internal.SemiIso
107import Control.Lens.Iso
106import Control.Lens.Iso
108import Control.Tuple.Morph
107import Control.Tuple.Morph
@@ -148,7 +147,8 @@ instance Category ReifiedSemiIso' where
148 id = ReifiedSemiIso' id
147 id = ReifiedSemiIso' id
149 ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
148 ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
150
149
151−instance Products ReifiedSemiIso' where
150+instance Arrow ReifiedSemiIso' where
151+ arr f = ReifiedSemiIso' $ semiIso (Right . f) (const $ Left "oh no")
152 -- TODO: pattern synonyms dont work here for some reason
152 -- TODO: pattern synonyms dont work here for some reason
153 first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
153 first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
154 ReifiedSemiIso' $ cloneSemiIso $
154 ReifiedSemiIso' $ cloneSemiIso $
@@ -165,7 +165,7 @@ instance Products ReifiedSemiIso' where
165 semiIso (runKleisli $ Kleisli f *** Kleisli f')
165 semiIso (runKleisli $ Kleisli f *** Kleisli f')
166 (runKleisli $ Kleisli g *** Kleisli g')
166 (runKleisli $ Kleisli g *** Kleisli g')
167
167
168−instance Coproducts ReifiedSemiIso' where
168+instance ArrowChoice ReifiedSemiIso' where
169 left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
169 left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
170 ReifiedSemiIso' $ cloneSemiIso $
170 ReifiedSemiIso' $ cloneSemiIso $
171 semiIso (runKleisli $ left $ Kleisli f)
171 semiIso (runKleisli $ left $ Kleisli f)
@@ -181,18 +181,19 @@ instance Coproducts ReifiedSemiIso' where
181 semiIso (runKleisli $ Kleisli f +++ Kleisli f')
181 semiIso (runKleisli $ Kleisli f +++ Kleisli f')
182 (runKleisli $ Kleisli g +++ Kleisli g')
182 (runKleisli $ Kleisli g +++ Kleisli g')
183
183
184−instance CatPlus ReifiedSemiIso' where
184+instance ArrowZero ReifiedSemiIso' where
185− cempty = ReifiedSemiIso' $ alwaysFailing "cempty"
185+ zeroArrow = ReifiedSemiIso' $ alwaysFailing "zeroArrow"
186
186
187+instance ArrowPlus ReifiedSemiIso' where
187− ReifiedSemiIso' ai /+/ ReifiedSemiIso' ai' = ReifiedSemiIso' $
188+ ReifiedSemiIso' ai <+> ReifiedSemiIso' ai' = ReifiedSemiIso' $
188 withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
189 withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
189− semiIso (runKleisli $ Kleisli f /+/ Kleisli f')
190+ semiIso (runKleisli $ Kleisli f <+> Kleisli f')
190− (runKleisli $ Kleisli g /+/ Kleisli g')
191+ (runKleisli $ Kleisli g <+> Kleisli g')
191
192
192-- | Constructs a semi isomorphism from a pair of functions that can
193-- | Constructs a semi isomorphism from a pair of functions that can
193-- fail with an error message.
194-- fail with an error message.
194semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
195semiIso :: (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
196
197
197-- | Clones a semi-iso.
198-- | Clones a semi-iso.
198cloneSemiIso :: ASemiIso s t a b -> SemiIso s t a b
199cloneSemiIso :: ASemiIso s t a b -> SemiIso s t a b
@@ -307,7 +308,7 @@ elimFirst ai = swapped . elimSecond ai
307-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
308-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
308-- i.e. eliminates the second pair element.
309-- i.e. eliminates the second pair element.
309elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
310elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
310−elimSecond ai = runSemiIso (id *** reifySemiIso ai) . rev unit
311+elimSecond ai = runSemiIso (second $ reifySemiIso ai) . rev unit
311
312
312-- | Transforms the semi-iso so that applying it in both directions never fails,
313-- | Transforms the semi-iso so that applying it in both directions never fails,
313-- but instead catches any errors and returns them as an @Either String a@.
314-- 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 (
33 sireplicate_
33 sireplicate_
34 ) where
34 ) where
35
35
36−import Control.Arrow (Kleisli(..))
36+import Control.Arrow
37import Control.Category
37import Control.Category
38−import Control.Category.Structures
39import Control.Lens.Cons
38import Control.Lens.Cons
40import Control.Lens.Empty
39import Control.Lens.Empty
41import Control.Lens.Iso
40import Control.Lens.Iso
42import Control.Lens.SemiIso
41import Control.Lens.SemiIso
43import Control.Monad
42import Control.Monad
44import Control.Tuple.Morph
43import Control.Tuple.Morph
45−import Data.Semigroupoid.Dual
46import Prelude hiding (id, (.))
44import Prelude hiding (id, (.))
47
45
48−infixr 1 ^>>, ^<<, #>>, #<<
46+infixr 1 #>>, #<<
49−infixr 1 >>^, <<^, >>#, <<#
47+infixr 1 >>#, <<#
50infixl 4 /$/, /$~
48infixl 4 /$/, /$~
51infixl 5 /*/, */, /*
49infixl 5 /*/, */, /*
52infixl 3 /?/
50infixl 3 /?/
@@ -59,7 +57,7 @@ infixl 3 /?/
59--
57--
60-- The category @cat@ should contain @SemiIso@ as a sort of
58-- The category @cat@ should contain @SemiIso@ as a sort of
61-- \"subcategory of pure computations\".
59-- \"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
63 -- | Allows you to lift a SemiIso into @cat@. The resulting arrow should be
61 -- | Allows you to lift a SemiIso into @cat@. The resulting arrow should be
64 -- in some sense minimal or \"pure\", similiar to 'pure', 'return' and
62 -- in some sense minimal or \"pure\", similiar to 'pure', 'return' and
65 -- 'arr' from "Control.Category".
63 -- 'arr' from "Control.Category".
@@ -87,7 +85,7 @@ class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
87
85
88 -- | @simany v@ repeats @v@ as long as possible.
86 -- | @simany v@ repeats @v@ as long as possible.
89 simany :: cat () b -> cat () [b]
87 simany :: cat () b -> cat () [b]
90− simany v = sisome v /+/ sipure _Empty
88+ simany v = sisome v <+> sipure _Empty
91
89
92 {-# MINIMAL (siarr | sipure), sibind #-}
90 {-# MINIMAL (siarr | sipure), sibind #-}
93
91
@@ -95,32 +93,12 @@ instance MonadPlus m => SIArrow (Kleisli m) where
95 siarr ai = Kleisli $ either fail return . apply ai
93 siarr ai = Kleisli $ either fail return . apply ai
96 sibind ai = Kleisli $ \a -> either fail (($ a) . runKleisli) $ apply ai a
94 sibind ai = Kleisli $ \a -> either fail (($ a) . runKleisli) $ apply ai a
97
95
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−
102instance SIArrow ReifiedSemiIso' where
96instance SIArrow ReifiedSemiIso' where
103 siarr = reifySemiIso
97 siarr = reifySemiIso
104 sibind ai = ReifiedSemiIso' $
98 sibind ai = ReifiedSemiIso' $
105 semiIso (\a -> apply ai a >>= flip apply a . runSemiIso)
99 semiIso (\a -> apply ai a >>= flip apply a . runSemiIso)
106 (\b -> unapply ai b >>= flip unapply b . runSemiIso)
100 (\b -> unapply ai b >>= flip unapply b . runSemiIso)
107
101
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−
124-- | Composes a reversed SemiIso with an arrow.
102-- | Composes a reversed SemiIso with an arrow.
125(#>>) :: SIArrow cat => ASemiIso' b a -> cat b c -> cat a c
103(#>>) :: SIArrow cat => ASemiIso' b a -> cat b c -> cat a c
126f #>> a = a . sipure f
104f #>> a = a . sipure f
@@ -171,7 +149,7 @@ ai /$<~> h = cloneSemiIso ai . reorderMorphed /$/ h
171--
149--
172-- The uncurried analogue of '<*>'.
150-- The uncurried analogue of '<*>'.
173(/*/) :: SIArrow cat => cat () b -> cat () c -> cat () (b, c)
151(/*/) :: SIArrow cat => cat () b -> cat () c -> cat () (b, c)
174−a /*/ b = unit ^>> (a *** b)
152+a /*/ b = siarr unit >>> (a *** b)
175
153
176-- | The product of two arrows, where the second one has no input and no output
154-- | The product of two arrows, where the second one has no input and no output
177-- (but can have side effects), with duplicate units removed. Side effect are
155-- (but can have side effects), with duplicate units removed. Side effect are
@@ -195,7 +173,7 @@ sifail = siarr . alwaysFailing
195
173
196-- | Provides an error message in the case of failure.
174-- | Provides an error message in the case of failure.
197(/?/) :: SIArrow cat => cat a b -> String -> cat a b
175(/?/) :: SIArrow cat => cat a b -> String -> cat a b
198−f /?/ msg = f /+/ sifail msg
176+f /?/ msg = f <+> sifail msg
199
177
200-- | Equivalent of 'sequence'.
178-- | Equivalent of 'sequence'.
201sisequence :: SIArrow cat => [cat () a] -> cat () [a]
179sisequence :: SIArrow cat => [cat () a] -> cat () [a]
src/Data/Profunctor/Exposed.hs+1−1
@@ -1,5 +1,5 @@
1{-# LANGUAGE FunctionalDependencies #-}
1{-# LANGUAGE FunctionalDependencies #-}
2−{-# LANGUAGE MultiParamTypeClasses #-}
2+
3{- |
3{- |
4Module : Data.Profunctor.Exposed
4Module : Data.Profunctor.Exposed
5Description : Exposes Kleisli category structure beneath a profunctor.
5Description : Exposes Kleisli category structure beneath a profunctor.