@@ -1,5 +1,7 @@
11{-# LANGUAGE Rank2Types #-}
22{-# LANGUAGE TupleSections #-}
3+{-# LANGUAGE ViewPatterns #-}
4+{-# LANGUAGE PatternSynonyms #-}
35{-# LANGUAGE FlexibleContexts #-}
46{- |
57Module : Control.Lens.SemiIso
@@ -39,24 +41,19 @@ module Control.Lens.SemiIso (
3941 SemiIso',
4042 ASemiIso,
4143 ASemiIso',
42−
44+
45+ -- * Patterns.
46+ pattern SemiIso,
47+
4348 -- * Constructing semi-isos.
4449 semiIso,
4550
46− -- * Transforming semi-isos.
47− withSemiIso,
48− attempt,
49− attemptAp,
50− attemptUn,
51− attempt_,
52− attemptAp_,
53− attemptUn_,
54−
5551 -- * Consuming semi-isos.
56− fromSemi,
5752 apply,
5853 unapply,
59−
54+ withSemiIso,
55+ viewSemiIso,
56+
6057 -- * Common semi-isomorphisms and isomorphisms.
6158 unit,
6259 swapped,
@@ -64,6 +61,22 @@ module Control.Lens.SemiIso (
6461 constant,
6562 exact,
6663
64+ -- * Semi-isos for numbers.
65+ _Negative,
66+ _Positive,
67+
68+ -- * Transforming semi-isos.
69+ rev,
70+ prod,
71+ elimFirst,
72+ elimSecond,
73+ attempt,
74+ attemptAp,
75+ attemptUn,
76+ attempt_,
77+ attemptAp_,
78+ attemptUn_,
79+
6780 -- * Folds.
6881 foldlM1,
6982 foldrM1,
@@ -79,6 +92,7 @@ module Control.Lens.SemiIso (
7992 bifoldl1
8093 ) where
8194
95+import Control.Arrow
8296import Control.Lens.Internal.SemiIso
8397import Control.Lens.Iso
8498import Data.Foldable
@@ -95,7 +109,8 @@ import Data.Traversable
95109--
96110-- Every 'Prism' is a 'SemiIso'.
97111-- Every 'Iso' is a 'Prism'.
98−type SemiIso s t a b = forall p f. (Exposed (Either String) p, Traversable f) => p a (f b) -> p s (f t)
112+type SemiIso s t a b = forall p f. (Exposed (Either String) p, Traversable f)
113+ => p a (f b) -> p s (f t)
99114
100115-- | Non-polymorphic variant of 'SemiIso'.
101116type SemiIso' s a = SemiIso s s a a
@@ -106,11 +121,23 @@ type ASemiIso s t a b = Retail a b a (Identity b) -> Retail a b s (Identity t)
106121-- | When you see this as an argument to a function, it expects a 'SemiIso''.
107122type ASemiIso' s a = ASemiIso s s a a
108123
124+-- | A nice pattern synonym for SemiIso's. Gives you the two functions, just like
125+-- 'viewSemiIso' or 'fromSemiIso'.
126+pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
127+
109128-- | Constructs a semi isomorphism from a pair of functions that can
110129-- fail with an error message.
111130semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
112131semiIso sa bt = merge . dimap sa (sequenceA . fmap bt) . expose
113132
133+-- | Applies the 'SemiIso'.
134+apply :: ASemiIso s t a b -> s -> Either String a
135+apply (SemiIso sa _) = sa
136+
137+-- | Applies the 'SemiIso' in the opposite direction.
138+unapply :: ASemiIso s t a b -> b -> Either String t
139+unapply (SemiIso _ bt) = bt
140+
114141-- | Extracts the two functions that characterize the 'SemiIso'.
115142withSemiIso :: ASemiIso s t a b
116143 -> ((s -> Either String a) -> (b -> Either String t) -> r)
@@ -118,49 +145,9 @@ withSemiIso :: ASemiIso s t a b
118145withSemiIso ai k = case ai (Retail Right (Right . Identity)) of
119146 Retail sa bt -> k sa (rmap (runIdentity . sequenceA) bt)
120147
121−-- | Transforms the semi-iso so that applying it in both directions never fails,
122−-- but instead catches any errors and returns them as an @Either String a@.
123−attempt :: ASemiIso s t a b -> SemiIso s (Either String t) (Either String a) b
124−attempt = attemptAp . attemptUn
125−
126−-- | Transforms the semi-iso so that applying it in direction (->) never fails,
127−-- but instead catches any errors and returns them as an @Either String a@.
128−attemptAp :: ASemiIso s t a b -> SemiIso s t (Either String a) b
129−attemptAp ai = withSemiIso ai $ \l r -> semiIso (Right . l) r
130−
131−-- | Transforms the semi-iso so that applying it in direction (<-) never fails,
132−-- but instead catches any errors and returns them as an @Either String a@.
133−attemptUn :: ASemiIso s t a b -> SemiIso s (Either String t) a b
134−attemptUn ai = withSemiIso ai $ \l r -> semiIso l (Right . r)
135−
136−discard :: Either a b -> Maybe b
137−discard = either (const Nothing) Just
138−
139−-- | Transforms the semi-iso like 'attempt', but ignores the error message.
140−attempt_ :: ASemiIso s t a b -> SemiIso s (Maybe t) (Maybe a) b
141−attempt_ ai = rmap (fmap discard) . attempt ai . lmap discard
142−
143−-- | Transforms the semi-iso like 'attemptAp', but ignores the error message.
144−--
145−-- Very useful when you want to bifold using a prism.
146−attemptAp_ :: ASemiIso s t a b -> SemiIso s t (Maybe a) b
147−attemptAp_ ai = attemptAp ai . lmap discard
148−
149−-- | Transforms the semi-iso like 'attemptUn', but ignores the error message.
150−attemptUn_ :: ASemiIso s t a b -> SemiIso s (Maybe t) a b
151−attemptUn_ ai = rmap (fmap discard) . attemptUn ai
152−
153−-- | Applies the 'SemiIso'.
154−apply :: ASemiIso s t a b -> s -> Either String a
155−apply ai = withSemiIso ai $ \l _ -> l
156−
157−-- | Applies the 'SemiIso' in the opposite direction.
158−unapply :: ASemiIso s t a b -> b -> Either String t
159−unapply ai = withSemiIso ai $ \_ r -> r
160−
161−-- | Reverses a 'SemiIso'.
162−fromSemi :: ASemiIso s t a b -> SemiIso b a t s
163−fromSemi ai = withSemiIso ai $ \l r -> semiIso r l
148+-- | Extracts the two functions that characterize the 'SemiIso'.
149+viewSemiIso :: ASemiIso s t a b -> (s -> Either String a, b -> Either String t)
150+viewSemiIso ai = withSemiIso ai (,)
164151
165152-- | A trivial isomorphism between a and (a, ()).
166153unit :: Iso' a (a, ())
@@ -192,6 +179,65 @@ exact x = semiIso f g
192179 g y | x == y = Right ()
193180 | otherwise = Left "exact: not equal"
194181
182+_Negative :: Num a => SemiIso' a a
183+_Negative = undefined
184+
185+_Positive :: Num a => SemiIso' a a
186+_Positive = undefined
187+
188+-- | Reverses a 'SemiIso'.
189+rev :: ASemiIso s t a b -> SemiIso b a t s
190+rev ai = withSemiIso ai $ \l r -> semiIso r l
191+
192+-- | A product of SemiIso's.
193+prod :: ASemiIso s t a b -> ASemiIso s' t' a' b'
194+ -> SemiIso (s, s') (t, t') (a, a') (b, b')
195+prod (SemiIso sa bt) (SemiIso sa' bt') = semiIso
196+ (runKleisli (Kleisli sa *** Kleisli sa'))
197+ (runKleisli (Kleisli bt *** Kleisli bt'))
198+
199+-- | In the non-polymorphic case uses an @SemiIso a ()@ to construct a
200+-- @SemiIso (a, b) b@, i.e. eliminates the first pair element.
201+elimFirst :: ASemiIso s' t' () () -> SemiIso (s', t) (t', t) t t
202+elimFirst ai = swapped . elimSecond ai
203+
204+-- | In the non-polymorphic case uses an @SemiIso b ()@ to construct a
205+-- @SemiIso (a, b) a@, i.e. eliminates the second pair element.
206+elimSecond :: ASemiIso s' t' () () -> SemiIso (t, s') (t, t') t t
207+elimSecond ai = prod id ai . rev unit
208+
209+-- | Transforms the semi-iso so that applying it in both directions never fails,
210+-- but instead catches any errors and returns them as an @Either String a@.
211+attempt :: ASemiIso s t a b -> SemiIso s (Either String t) (Either String a) b
212+attempt = attemptAp . attemptUn
213+
214+-- | Transforms the semi-iso so that applying it in direction (->) never fails,
215+-- but instead catches any errors and returns them as an @Either String a@.
216+attemptAp :: ASemiIso s t a b -> SemiIso s t (Either String a) b
217+attemptAp (SemiIso sa bt) = semiIso (Right . sa) bt
218+
219+-- | Transforms the semi-iso so that applying it in direction (<-) never fails,
220+-- but instead catches any errors and returns them as an @Either String a@.
221+attemptUn :: ASemiIso s t a b -> SemiIso s (Either String t) a b
222+attemptUn (SemiIso sa bt) = semiIso sa (Right . bt)
223+
224+discard :: Either a b -> Maybe b
225+discard = either (const Nothing) Just
226+
227+-- | Transforms the semi-iso like 'attempt', but ignores the error message.
228+attempt_ :: ASemiIso s t a b -> SemiIso s (Maybe t) (Maybe a) b
229+attempt_ ai = rmap (fmap discard) . attempt ai . lmap discard
230+
231+-- | Transforms the semi-iso like 'attemptAp', but ignores the error message.
232+--
233+-- Very useful when you want to bifold using a prism.
234+attemptAp_ :: ASemiIso s t a b -> SemiIso s t (Maybe a) b
235+attemptAp_ ai = attemptAp ai . lmap discard
236+
237+-- | Transforms the semi-iso like 'attemptUn', but ignores the error message.
238+attemptUn_ :: ASemiIso s t a b -> SemiIso s (Maybe t) a b
239+attemptUn_ ai = rmap (fmap discard) . attemptUn ai
240+
195241-- | Monadic counterpart of 'foldl1' (or non-empty list counterpart of 'foldlM').
196242foldlM1 :: Monad m => (a -> a -> m a) -> [a] -> m a
197243foldlM1 f (x:xs) = foldlM f x xs