@@ -50,6 +50,10 @@ module Control.Lens.SemiIso (
51 cloneSemiIso,
51 cloneSemiIso,
53+ -- * Reified semi-isos.
53 -- * Consuming semi-isos.
57 -- * Consuming semi-isos.
@@ -71,7 +75,6 @@ module Control.Lens.SemiIso (
72 -- * Transforming semi-isos.
76 -- * Transforming semi-isos.
75 elimFirst,
78 elimFirst,
76 elimSecond,
79 elimSecond,
@@ -93,7 +96,9 @@ module Control.Lens.SemiIso (
99+import Prelude hiding (id, (.))
96import Control.Arrow
100import Control.Arrow
101+import Control.Category
97import Control.Lens.Internal.SemiIso
102import Control.Lens.Internal.SemiIso
98import Control.Lens.Iso
103import Control.Lens.Iso
99import Data.Foldable
104import Data.Foldable
@@ -127,6 +132,34 @@ type ASemiIso' s a = ASemiIso s s a a
127-- 'viewSemiIso' or 'fromSemiIso'.
132-- 'viewSemiIso' or 'fromSemiIso'.
128pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
133pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
135+-- | A semi-iso stored in a container.
136+newtype ReifiedSemiIso' s a = ReifiedSemiIso' { runSemiIso :: SemiIso' s a }
138+instance Category ReifiedSemiIso' where
139+ id = ReifiedSemiIso' id
140+ ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
142+-- | This in an __/incomplete/__ instance, 'arr' and '(&&&)' are undefined.
143+instance Arrow ReifiedSemiIso' where
147+ -- TODO: pattern synonyms dont work here for some reason
148+ first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
149+ ReifiedSemiIso' $ cloneSemiIso $
150+ semiIso (runKleisli $ first $ Kleisli f)
151+ (runKleisli $ first $ Kleisli g)
153+ second (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
154+ ReifiedSemiIso' $ cloneSemiIso $
155+ semiIso (runKleisli $ second $ Kleisli f)
156+ (runKleisli $ second $ Kleisli g)
158+ ReifiedSemiIso' ai *** ReifiedSemiIso' ai' = ReifiedSemiIso' $
159+ withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
160+ semiIso (runKleisli $ Kleisli f *** Kleisli f')
161+ (runKleisli $ Kleisli g *** Kleisli g')
130-- | Constructs a semi isomorphism from a pair of functions that can
163-- | Constructs a semi isomorphism from a pair of functions that can
131-- fail with an error message.
164-- fail with an error message.
132semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
165semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
@@ -155,6 +188,10 @@ withSemiIso ai k = case ai (Retail Right (Right . Identity)) of
155viewSemiIso :: ASemiIso s t a b -> (s -> Either String a, b -> Either String t)
188viewSemiIso :: ASemiIso s t a b -> (s -> Either String a, b -> Either String t)
156viewSemiIso ai = withSemiIso ai (,)
189viewSemiIso ai = withSemiIso ai (,)
191+-- | Reifies a semi-iso.
192+reifySemiIso :: ASemiIso' s a -> ReifiedSemiIso' s a
193+reifySemiIso ai = ReifiedSemiIso' $ cloneSemiIso ai
158-- | A trivial isomorphism between a and (a, ()).
195-- | A trivial isomorphism between a and (a, ()).
159unit :: Iso' a (a, ())
196unit :: Iso' a (a, ())
160unit = iso (, ()) fst
197unit = iso (, ()) fst
@@ -218,22 +255,15 @@ _Negative = semiIso f g
218rev :: ASemiIso s t a b -> SemiIso b a t s
255rev :: ASemiIso s t a b -> SemiIso b a t s
219rev ai = withSemiIso ai $ \l r -> semiIso r l
256rev ai = withSemiIso ai $ \l r -> semiIso r l
221−-- | A product of SemiIso's.
222−prod :: ASemiIso s t a b -> ASemiIso s' t' a' b'
223− -> SemiIso (s, s') (t, t') (a, a') (b, b')
224−prod (SemiIso sa bt) (SemiIso sa' bt') = semiIso
225− (runKleisli (Kleisli sa *** Kleisli sa'))
226− (runKleisli (Kleisli bt *** Kleisli bt'))
228−-- | In the non-polymorphic case uses an @SemiIso a ()@ to construct a
258+-- | Uses an @SemiIso' a ()@ to construct a @SemiIso' (a, b) b@,
229−-- @SemiIso (a, b) b@, i.e. eliminates the first pair element.
259+-- i.e. eliminates the first pair element.
230−elimFirst :: ASemiIso s' t' () () -> SemiIso (s', t) (t', t) t t
260+elimFirst :: ASemiIso' s () -> SemiIso' (s, t) t
231elimFirst ai = swapped . elimSecond ai
261elimFirst ai = swapped . elimSecond ai
233−-- | In the non-polymorphic case uses an @SemiIso b ()@ to construct a
263+-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
234−-- @SemiIso (a, b) a@, i.e. eliminates the second pair element.
264+-- i.e. eliminates the second pair element.
235−elimSecond :: ASemiIso s' t' () () -> SemiIso (t, s') (t, t') t t
265+elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
236−elimSecond ai = prod id ai . rev unit
266+elimSecond ai = runSemiIso (id *** reifySemiIso ai) . rev unit
238-- | Transforms the semi-iso so that applying it in both directions never fails,
268-- | Transforms the semi-iso so that applying it in both directions never fails,
239-- but instead catches any errors and returns them as an @Either String a@.
269-- but instead catches any errors and returns them as an @Either String a@.