@@ -50,6 +50,10 @@ module Control.Lens.SemiIso (
5050 semiIso,
5151 cloneSemiIso,
5252
53+ -- * Reified semi-isos.
54+ ReifiedSemiIso'(..),
55+ reifySemiIso,
56+
5357 -- * Consuming semi-isos.
5458 apply,
5559 unapply,
@@ -71,7 +75,6 @@ module Control.Lens.SemiIso (
7175
7276 -- * Transforming semi-isos.
7377 rev,
74− prod,
7578 elimFirst,
7679 elimSecond,
7780 attempt,
@@ -93,7 +96,9 @@ module Control.Lens.SemiIso (
9396 bifoldl1_
9497 ) where
9598
99+import Prelude hiding (id, (.))
96100import Control.Arrow
101+import Control.Category
97102import Control.Lens.Internal.SemiIso
98103import Control.Lens.Iso
99104import Data.Foldable
@@ -127,6 +132,34 @@ type ASemiIso' s a = ASemiIso s s a a
127132-- 'viewSemiIso' or 'fromSemiIso'.
128133pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
129134
135+-- | A semi-iso stored in a container.
136+newtype ReifiedSemiIso' s a = ReifiedSemiIso' { runSemiIso :: SemiIso' s a }
137+
138+instance Category ReifiedSemiIso' where
139+ id = ReifiedSemiIso' id
140+ ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
141+
142+-- | This in an __/incomplete/__ instance, 'arr' and '(&&&)' are undefined.
143+instance Arrow ReifiedSemiIso' where
144+ arr = undefined
145+ (&&&) = undefined
146+
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)
152+
153+ second (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
154+ ReifiedSemiIso' $ cloneSemiIso $
155+ semiIso (runKleisli $ second $ Kleisli f)
156+ (runKleisli $ second $ Kleisli g)
157+
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')
162+
130163-- | Constructs a semi isomorphism from a pair of functions that can
131164-- fail with an error message.
132165semiIso :: (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
155188viewSemiIso :: ASemiIso s t a b -> (s -> Either String a, b -> Either String t)
156189viewSemiIso ai = withSemiIso ai (,)
157190
191+-- | Reifies a semi-iso.
192+reifySemiIso :: ASemiIso' s a -> ReifiedSemiIso' s a
193+reifySemiIso ai = ReifiedSemiIso' $ cloneSemiIso ai
194+
158195-- | A trivial isomorphism between a and (a, ()).
159196unit :: Iso' a (a, ())
160197unit = iso (, ()) fst
@@ -218,22 +255,15 @@ _Negative = semiIso f g
218255rev :: ASemiIso s t a b -> SemiIso b a t s
219256rev ai = withSemiIso ai $ \l r -> semiIso r l
220257
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'))
227−
228−-- | In the non-polymorphic case uses an @SemiIso a ()@ to construct a
229−-- @SemiIso (a, b) b@, i.e. eliminates the first pair element.
230−elimFirst :: ASemiIso s' t' () () -> SemiIso (s', t) (t', t) t t
258+-- | Uses an @SemiIso' a ()@ to construct a @SemiIso' (a, b) b@,
259+-- i.e. eliminates the first pair element.
260+elimFirst :: ASemiIso' s () -> SemiIso' (s, t) t
231261elimFirst ai = swapped . elimSecond ai
232262
233−-- | In the non-polymorphic case uses an @SemiIso b ()@ to construct a
234−-- @SemiIso (a, b) a@, i.e. eliminates the second pair element.
235−elimSecond :: ASemiIso s' t' () () -> SemiIso (t, s') (t, t') t t
236−elimSecond ai = prod id ai . rev unit
263+-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
264+-- i.e. eliminates the second pair element.
265+elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
266+elimSecond ai = runSemiIso (id *** reifySemiIso ai) . rev unit
237267
238268-- | Transforms the semi-iso so that applying it in both directions never fails,
239269-- but instead catches any errors and returns them as an @Either String a@.