semi-iso 0.3.0.0 → 0.4.0.0

raw patch · 3 files changed

+252/−84 lines, 3 filesdep +tuple-morphPVP ok

version bump matches the API change (PVP)

Dependencies added: tuple-morph

API changes (from Hackage documentation)

Files

• Control/Lens/SemiIso.hs +173/−74
• Data/SemiIsoFunctor.hs +76/−8
• semi-iso.cabal +3/−2

@@ -1,5 +1,8 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE FlexibleContexts #-} {- | Module      :  Control.Lens.SemiIso@@ -39,52 +42,63 @@     SemiIso',     ASemiIso,     ASemiIso',-    ++    -- * Patterns.+    pattern SemiIso,+     -- * Constructing semi-isos.     semiIso, -    -- * Transforming semi-isos.-    withSemiIso,-    attempt,-    attemptAp,-    attemptUn,-    attempt_,-    attemptAp_,-    attemptUn_,-     -- * Consuming semi-isos.-    fromSemi,     apply,     unapply,-    +    withSemiIso,+    viewSemiIso,+     -- * Common semi-isomorphisms and isomorphisms.     unit,     swapped,     associated,+    morphed,     constant,     exact,+    bifiltered, -    -- * Folds.-    foldlM1,-    foldrM1,-    unfoldlM,-    unfoldlM1,-    unfoldrM,-    unfoldrM1,+    -- * Semi-isos for numbers.+    _Negative, +    -- * Transforming semi-isos.+    rev,+    prod,+    elimFirst,+    elimSecond,+    attempt,+    attemptAp,+    attemptUn,+    attempt_,+    attemptAp_,+    attemptUn_,+     -- * Bidirectional folds.     bifoldr,     bifoldr1,     bifoldl,-    bifoldl1+    bifoldl1,++    bifoldr_,+    bifoldr1_,+    bifoldl_,+    bifoldl1_     ) where +import Control.Arrow import Control.Lens.Internal.SemiIso import Control.Lens.Iso import Data.Foldable import Data.Functor.Identity import Data.Profunctor.Exposed import Data.Traversable+import Data.Tuple.Morph  -- | A semi-isomorphism is a partial isomorphism with weakened laws. -- @@ -95,7 +109,8 @@ -- -- Every 'Prism' is a 'SemiIso'. -- Every 'Iso' is a 'Prism'.-type SemiIso s t a b = forall p f. (Exposed (Either String) p, Traversable f) => p a (f b) -> p s (f t)+type SemiIso s t a b = forall p f. (Exposed (Either String) p, Traversable f) +                     => p a (f b) -> p s (f t)  -- | Non-polymorphic variant of 'SemiIso'. type SemiIso' s a = SemiIso s s a a@@ -106,11 +121,23 @@ -- | When you see this as an argument to a function, it expects a 'SemiIso''. type ASemiIso' s a = ASemiIso s s a a +-- | A nice pattern synonym for SemiIso's. Gives you the two functions, just like+-- 'viewSemiIso' or 'fromSemiIso'.+pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))+ -- | Constructs a semi isomorphism from a pair of functions that can -- fail with an error message. semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b semiIso sa bt = merge . dimap sa (sequenceA . fmap bt) . expose +-- | Applies the 'SemiIso'.+apply :: ASemiIso s t a b -> s -> Either String a+apply (SemiIso sa _) = sa++-- | Applies the 'SemiIso' in the opposite direction.+unapply :: ASemiIso s t a b -> b -> Either String t+unapply (SemiIso _ bt) = bt+ -- | Extracts the two functions that characterize the 'SemiIso'. withSemiIso :: ASemiIso s t a b              -> ((s -> Either String a) -> (b -> Either String t) -> r) @@ -118,49 +145,9 @@ withSemiIso ai k = case ai (Retail Right (Right . Identity)) of                         Retail sa bt -> k sa (rmap (runIdentity . sequenceA) bt) --- | Transforms the semi-iso so that applying it in both directions never fails,--- but instead catches any errors and returns them as an @Either String a@.-attempt :: ASemiIso s t a b -> SemiIso s (Either String t) (Either String a) b-attempt = attemptAp . attemptUn---- | Transforms the semi-iso so that applying it in direction (->) never fails,--- but instead catches any errors and returns them as an @Either String a@.-attemptAp :: ASemiIso s t a b -> SemiIso s t (Either String a) b-attemptAp ai = withSemiIso ai $ \l r -> semiIso (Right . l) r---- | Transforms the semi-iso so that applying it in direction (<-) never fails,--- but instead catches any errors and returns them as an @Either String a@.-attemptUn :: ASemiIso s t a b -> SemiIso s (Either String t) a b-attemptUn ai = withSemiIso ai $ \l r -> semiIso l (Right . r)--discard :: Either a b -> Maybe b-discard = either (const Nothing) Just---- | Transforms the semi-iso like 'attempt', but ignores the error message.-attempt_ :: ASemiIso s t a b -> SemiIso s (Maybe t) (Maybe a) b-attempt_ ai = rmap (fmap discard) . attempt ai . lmap discard---- | Transforms the semi-iso like 'attemptAp', but ignores the error message.------ Very useful when you want to bifold using a prism.-attemptAp_ :: ASemiIso s t a b -> SemiIso s t (Maybe a) b-attemptAp_ ai = attemptAp ai . lmap discard---- | Transforms the semi-iso like 'attemptUn', but ignores the error message.-attemptUn_ :: ASemiIso s t a b -> SemiIso s (Maybe t) a b-attemptUn_ ai = rmap (fmap discard) . attemptUn ai---- | Applies the 'SemiIso'.-apply :: ASemiIso s t a b -> s -> Either String a-apply ai = withSemiIso ai $ \l _ -> l---- | Applies the 'SemiIso' in the opposite direction.-unapply :: ASemiIso s t a b -> b -> Either String t-unapply ai = withSemiIso ai $ \_ r -> r---- | Reverses a 'SemiIso'.-fromSemi :: ASemiIso s t a b -> SemiIso b a t s-fromSemi ai = withSemiIso ai $ \l r -> semiIso r l+-- | Extracts the two functions that characterize the 'SemiIso'.+viewSemiIso :: ASemiIso s t a b -> (s -> Either String a, b -> Either String t)+viewSemiIso ai = withSemiIso ai (,)  -- | A trivial isomorphism between a and (a, ()). unit :: Iso' a (a, ())@@ -170,6 +157,14 @@ associated :: Iso' (a, (b, c)) ((a, b), c) associated = iso (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c))) +-- | An isomorphism between two arbitrary nested tuples, as long the contained+-- types (ignoring units!) read from left to right are the same.+--+-- This is implemented using 'Data.Tuple.Morph.morph' from 'tuple-morph'.+morphed :: (HFoldable a, HUnfoldable a, HFoldable b, HUnfoldable b, Rep a ~ Rep b)+        => Iso' a b+morphed = iso morph morph+ -- | \-> Always returns the argument. -- -- \<- Maps everything to a @()@.@@ -192,6 +187,76 @@     g y | x == y    = Right ()         | otherwise = Left "exact: not equal" +-- | Like 'filtered' but checks the predicate in both ways.+bifiltered :: (a -> Bool) -> SemiIso' a a+bifiltered p = semiIso check check+  where check x | p x       = Right x+                | otherwise = Left "bifiltered: predicate failed"++-- | \-> Matches only negative numbers, turns it into a positive one.+--+-- \<- Matches only positive numbers, turns it into a negative one.+_Negative :: Real a => SemiIso' a a+_Negative = semiIso f g+  where+    f x | x < 0 = Right (-x)+        | otherwise = Left "_Negative: apply expected a negative number"+    g x | x >= 0 = Right (-x)+        | otherwise = Left "_Negative: unapply expected a positive number"++-- | Reverses a 'SemiIso'.+rev :: ASemiIso s t a b -> SemiIso b a t s+rev ai = withSemiIso ai $ \l r -> semiIso r l++-- | A product of SemiIso's.+prod :: ASemiIso s t a b -> ASemiIso s' t' a' b' +     -> SemiIso (s, s') (t, t') (a, a') (b, b')+prod (SemiIso sa bt) (SemiIso sa' bt') = semiIso+    (runKleisli (Kleisli sa *** Kleisli sa')) +    (runKleisli (Kleisli bt *** Kleisli bt'))++-- | In the non-polymorphic case uses an @SemiIso a ()@ to construct a+-- @SemiIso (a, b) b@, i.e. eliminates the first pair element.+elimFirst :: ASemiIso s' t' () () -> SemiIso (s', t) (t', t) t t+elimFirst ai = swapped . elimSecond ai++-- | In the non-polymorphic case uses an @SemiIso b ()@ to construct a+-- @SemiIso (a, b) a@, i.e. eliminates the second pair element.+elimSecond :: ASemiIso s' t' () () -> SemiIso (t, s') (t, t') t t+elimSecond ai = prod id ai . rev unit++-- | Transforms the semi-iso so that applying it in both directions never fails,+-- but instead catches any errors and returns them as an @Either String a@.+attempt :: ASemiIso s t a b -> SemiIso s (Either String t) (Either String a) b+attempt = attemptAp . attemptUn++-- | Transforms the semi-iso so that applying it in direction (->) never fails,+-- but instead catches any errors and returns them as an @Either String a@.+attemptAp :: ASemiIso s t a b -> SemiIso s t (Either String a) b+attemptAp (SemiIso sa bt) = semiIso (Right . sa) bt++-- | Transforms the semi-iso so that applying it in direction (<-) never fails,+-- but instead catches any errors and returns them as an @Either String a@.+attemptUn :: ASemiIso s t a b -> SemiIso s (Either String t) a b+attemptUn (SemiIso sa bt) = semiIso sa (Right . bt)++discard :: Either a b -> Maybe b+discard = either (const Nothing) Just++-- | Transforms the semi-iso like 'attempt', but ignores the error message.+attempt_ :: ASemiIso s t a b -> SemiIso s (Maybe t) (Maybe a) b+attempt_ ai = rmap (fmap discard) . attempt ai . lmap discard++-- | Transforms the semi-iso like 'attemptAp', but ignores the error message.+--+-- Very useful when you want to bifold using a prism.+attemptAp_ :: ASemiIso s t a b -> SemiIso s t (Maybe a) b+attemptAp_ ai = attemptAp ai . lmap discard++-- | Transforms the semi-iso like 'attemptUn', but ignores the error message.+attemptUn_ :: ASemiIso s t a b -> SemiIso s (Maybe t) a b+attemptUn_ ai = rmap (fmap discard) . attemptUn ai+ -- | Monadic counterpart of 'foldl1' (or non-empty list counterpart of 'foldlM'). foldlM1 :: Monad m => (a -> a -> m a) -> [a] -> m a foldlM1 f (x:xs) = foldlM f x xs@@ -243,13 +308,47 @@           Just (new_a, b) -> go new_a (b : bs)           Nothing -> return (a : bs) +-- | Constructs a bidirectional fold. Works with prisms.+--+-- \-> Right unfolds using the (->) part of the given semi-iso, until it fails.+--+-- \<- Right folds using the (<-) part of the given semi-iso.+bifoldr :: ASemiIso' a (b, a) -> SemiIso' a (a, [b])+bifoldr = bifoldr_ . attemptAp_++-- | Constructs a bidirectional fold. Works with prisms.+--+-- \-> Right unfolds using the (->) part of the given semi-iso, until it fails. +-- It should produce a non-empty list.+--+-- \<- Right folds a non-empty list using the (<-) part of the given semi-iso.+bifoldr1 :: ASemiIso' a (a, a) -> SemiIso' a [a]+bifoldr1 = bifoldr1_ . attemptAp_++-- | Constructs a bidirectional fold. Works with prisms.+--+-- \-> Left unfolds using the (->) part of the given semi-iso, until it fails.+--+-- \<- Left folds using the (<-) part of the given semi-iso.+bifoldl :: ASemiIso' a (a, b) -> SemiIso' a (a, [b])+bifoldl = bifoldl_ . attemptAp_++-- | Constructs a bidirectional fold. Works with prisms.+--+-- \-> Left unfolds using the (->) part of the given semi-iso, until it fails. +-- It should produce a non-empty list.+--+-- \<- Left folds a non-empty list using the (<-) part of the given semi-iso.+bifoldl1 :: ASemiIso' a (a, a) -> SemiIso' a [a]+bifoldl1 = bifoldl1_ . attemptAp_+ -- | Constructs a bidirectional fold. -- -- \-> Right unfolds using the (->) part of the given semi-iso. -- -- \<- Right folds using the (<-) part of the given semi-iso.-bifoldr :: ASemiIso a a (Maybe (b, a)) (b, a) -> SemiIso' a (a, [b])-bifoldr ai = semiIso (uf ai) (f ai)+bifoldr_ :: ASemiIso a a (Maybe (b, a)) (b, a) -> SemiIso' a (a, [b])+bifoldr_ ai = semiIso (uf ai) (f ai)   where     f = uncurry . foldrM . curry . unapply     uf = unfoldrM . apply@@ -257,11 +356,11 @@ -- | Constructs a bidirectional fold. -- -- \-> Right unfolds using the (->) part of the given semi-iso. It should--- produce an non-empty list.+-- produce a non-empty list. -- -- \<- Right folds a non-empty list using the (<-) part of the given semi-iso.-bifoldr1 :: ASemiIso a a (Maybe (a, a)) (a, a) -> SemiIso' a [a]-bifoldr1 ai = semiIso (uf ai) (f ai)+bifoldr1_ :: ASemiIso a a (Maybe (a, a)) (a, a) -> SemiIso' a [a]+bifoldr1_ ai = semiIso (uf ai) (f ai)   where     f = foldrM1 . curry . unapply     uf = unfoldrM1 . apply@@ -271,8 +370,8 @@ -- \-> Left unfolds using the (->) part of the given semi-iso. -- -- \<- Left folds using the (<-) part of the given semi-iso.-bifoldl :: ASemiIso a a (Maybe (a, b)) (a, b) -> SemiIso' a (a, [b])-bifoldl ai = semiIso (uf ai) (f ai)+bifoldl_ :: ASemiIso a a (Maybe (a, b)) (a, b) -> SemiIso' a (a, [b])+bifoldl_ ai = semiIso (uf ai) (f ai)   where     f = uncurry . foldlM . curry . unapply     uf = unfoldlM . apply@@ -280,11 +379,11 @@ -- | Constructs a bidirectional fold. -- -- \-> Left unfolds using the (->) part of the given semi-iso. It should--- produce an non-empty list.+-- produce a non-empty list. -- -- \<- Left folds a non-empty list using the (<-) part of the given semi-iso.-bifoldl1 :: ASemiIso a a (Maybe (a, a)) (a, a) -> SemiIso' a [a]-bifoldl1 ai = semiIso (uf ai) (f ai)+bifoldl1_ :: ASemiIso a a (Maybe (a, a)) (a, a) -> SemiIso' a [a]+bifoldl1_ ai = semiIso (uf ai) (f ai)   where     f = foldlM1 . curry . unapply     uf = unfoldlM1 . apply

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternSynonyms #-} {- | Module      :  Data.SemiIsoFunctor Description :  Functors from the category of semi-isomoprihsms to Hask.@@ -13,18 +15,19 @@ instantiated by both covariant (like Parser) and contravariant (like Printer)  functors. Therefore it can be used as a common interface to unify parsing and pretty printing.--Operator names are up to bikeshedding :) -} module Data.SemiIsoFunctor where  import Control.Lens.Cons import Control.Lens.Empty import Control.Lens.SemiIso+import Data.Tuple.Morph  infixl 3 /|/-infixl 4 /$/+infixl 4 /$/, ~$/, /$~, ~$~ infixl 5 /*/, /*, */+infixl 1 //=+infixr 1 =//  -- | A functor from the category of semi-isomorphisms to Hask. --@@ -42,18 +45,50 @@ class SemiIsoFunctor f where     -- | The contravariant map.     simap :: ASemiIso' a b -> f b -> f a-    simap = simapCo . fromSemi-    +    simap = simapCo . rev+     -- | The covariant map.     simapCo :: ASemiIso' a b -> f a -> f b-    simapCo = simap . fromSemi-    +    simapCo = simap . rev+     {-# MINIMAL simap | simapCo #-}  -- | A infix operator for 'simap'. (/$/) :: SemiIsoFunctor f => ASemiIso' a b -> f b -> f a (/$/) = simap +-- | > ai /$~ f = ai . morphed /$/ f+--+-- This operator handles all the hairy stuff with uncurried application:+-- it reassociates the argument tuple and removes unnecessary (or adds necessary)+-- units to match the function type. You don't have to use @/*@ and @*/@ with this+-- operator.+(/$~) :: (SemiIsoFunctor f, HFoldable b', HFoldable b,+          HUnfoldable b', HUnfoldable b, Rep b' ~ Rep b)+      => ASemiIso' a b' -> f b -> f a+-- TODO GHC 7.10: haddock doesn't work with pattern synynonyms yet+-- (SemiIso f g) /$~ h = semiIso f g . morphed /$/ h+ai /$~ h = withSemiIso ai $ \f g -> semiIso f g . morphed /$/ h++-- | > ai ~$/ f = morphed . ai /$/ f+(~$/) :: (SemiIsoFunctor f, HFoldable a', HFoldable a,+          HUnfoldable a', HUnfoldable a, Rep a' ~ Rep a)+      => ASemiIso' a' b -> f b -> f a+-- TODO GHC 7.10: haddock doesn't work with pattern synynonyms yet+--(SemiIso f g) ~$/ h = morphed . semiIso f g /$/ h+ai ~$/ h = withSemiIso ai $ \f g -> morphed . semiIso f g /$/ h++-- | > ai ~$~ f = morphed . ai . morphed /$/ f+(~$~) :: (SemiIsoFunctor f,+          HFoldable a, HUnfoldable a,+          HFoldable b, HUnfoldable b,+          HFoldable b', HUnfoldable b',+          Rep b' ~ Rep b, Rep b' ~ Rep a)+      => ASemiIso b' b' b' b' -> f b -> f a+-- TODO GHC 7.10: haddock doesn't work with pattern synynonyms yet+--(SemiIso f g) ~$~ h = morphed . semiIso f g . morphed /$/ h+ai ~$~ h = withSemiIso ai $ \f g -> morphed . semiIso f g . morphed /$/ h+ -- | Equivalent of 'Applicative' for 'SemiIsoFunctor'. -- -- However, this class implements uncurried application, unlike @@ -63,7 +98,15 @@ --  -- > TODO (they should be fine) class SemiIsoFunctor f => SemiIsoApply f where+    siunit :: f ()+    siunit = sipure id+     sipure :: ASemiIso' a () -> f a+    sipure ai = ai /$/ siunit++    sipureCo :: ASemiIso' () a -> f a+    sipureCo ai = ai `simapCo` siunit+     (/*/) :: f a -> f b -> f (a, b)      (/*)  :: f a -> f () -> f a@@ -72,7 +115,7 @@     (*/)  :: f () -> f b -> f b     f */ g = unit . swapped /$/ f /*/ g -    {-# MINIMAL sipure, (/*/) #-}+    {-# MINIMAL (siunit | sipure), (/*/) #-}  -- | Equivalent of 'Alternative' for 'SemiIsoFunctor'. --@@ -89,6 +132,31 @@     simany v = sisome v /|/ sipure _Empty      {-# MINIMAL siempty, (/|/) #-}++-- | An analogue of 'Monad' for 'SemiIsoFunctor'.+--+-- Because of the 'no throwing away' rule bind has to \"return\"+-- both @a@ and @b@.+class SemiIsoApply m => SemiIsoMonad m where+    (//=) :: m a -> (a -> m b) -> m (a, b)+    m //= f = swapped /$/ (f =// m)++    (=//) :: (b -> m a) -> m b -> m (a, b)+    f =// m = swapped /$/ (m //= f)++    {-# MINIMAL (//=) | (=//) #-}++-- | A SemiIsoMonad with fixed point operator.+class SemiIsoMonad m => SemiIsoFix m where+    sifix :: (a -> m a) -> m a+    sifix f = dup /$/ (f =//= f)+      where dup = semiIso (\a -> Right (a, a)) (Right . fst)++    -- | Fixed point combined with bind, it's so symmetric!+    (=//=) :: (a -> m b) -> (b -> m a) -> m (a, b)+    f =//= g = sifix (\(a, b) -> g b /*/ f a)++    {-# MINIMAL sifix | (=//=) #-}  -- | Equivalent of 'sequence'. --

@@ -1,5 +1,5 @@ name:                semi-iso-version:             0.3.0.0+version:             0.4.0.0 synopsis:            Weakened partial isomorphisms that work with lenses. description:         Semi-isomorphisms are partial isomorphisms with weakened iso laws.                      And they work with Iso and Prism from @lens@!@@ -24,5 +24,6 @@                        Control.Lens.Internal.SemiIso                        Data.SemiIsoFunctor                        Data.Profunctor.Exposed-  build-depends:       base >= 4 && < 5, profunctors, transformers, lens+  build-depends:       base >= 4 && < 5, profunctors, transformers, lens, tuple-morph   default-language:    Haskell2010+  ghc-options:         -Wall