these 0.7.6 → 0.8
raw patch · 11 files changed
+487/−270 lines, 11 filesdep +assocdep ~QuickCheck
Dependencies added: assoc
Dependency ranges changed: QuickCheck
Files
- CHANGELOG.md +13/−0
- Control/Monad/Chronicle/Class.hs +3/−2
- Control/Monad/Trans/Chronicle.hs +2/−1
- Data/Align.hs +56/−13
- Data/Align/Indexed.hs +11/−12
- Data/Align/Key.hs +1/−1
- Data/These.hs +64/−235
- Data/These/Combinators.hs +247/−0
- Data/These/Lens.hs +73/−0
- test/Tests.hs +12/−4
- these.cabal +5/−2
CHANGELOG.md view
@@ -1,3 +1,16 @@+# 0.8.0++- Split `align` and `alignWith` into own class: `Semialign`.+- `ialign` has default implementation+- Add `Semialign` `NonEmpty` and `Identity` instances+- Add `Swap` and `Assoc` instances (type classes from `assoc` package)+- Move optics into `Data.These.Lens` module,+ and and some combinators `Data.These.Combinators`.+ Also some combinators are renamed, so naming is now consistent.+ As the result `Data.These` has very minimal exports.+- Change type of `partitionThese` (nested pairs to triple)+- Add `partitionHereThere :: [These a b] -> ([a],[b])`+ # 0.7.6 - Tigthen lower bounds
Control/Monad/Chronicle/Class.hs view
@@ -19,6 +19,7 @@ ) where import Data.These+import Data.These.Combinators import Control.Applicative import Control.Monad.Trans.Chronicle (ChronicleT, runChronicle) import qualified Control.Monad.Trans.Chronicle as Ch@@ -97,13 +98,13 @@ dictate c = These c () confess c = This c memento (This c) = That (Left c)- memento m = mapThat Right m+ memento m = mapThere Right m absolve x (This _) = That x absolve _ (That x) = That x absolve _ (These _ x) = That x condemn (These c _) = This c condemn m = m- retcon = mapThis+ retcon = mapHere chronicle = id instance (Semigroup c, Monad m) => MonadChronicle c (ChronicleT c m) where
Control/Monad/Trans/Chronicle.hs view
@@ -37,6 +37,7 @@ import Control.Monad.RWS.Class import Prelude import Data.These+import Data.These.Combinators (mapHere) -- -------------------------------------------------------------------------- -- | A chronicle monad parameterized by the output type @c@.@@ -208,5 +209,5 @@ -- -- Equivalent to 'censor' for the 'Writer' monad. retcon :: (Semigroup c, Monad m) => (c -> c) -> ChronicleT c m a -> ChronicleT c m a-retcon f m = ChronicleT $ mapThis f `liftM` runChronicleT m+retcon f m = ChronicleT $ mapHere f `liftM` runChronicleT m
Data/Align.hs view
@@ -6,7 +6,8 @@ -- shapes, plus traversal of (bi)foldable (bi)functors through said -- functors. module Data.Align (- Align(..)+ Semialign (..)+ , Align(..) -- * Specialized aligns , malign, salign, padZip, padZipWith , lpadZip, lpadZipWith@@ -36,6 +37,7 @@ import Data.Functor.Product (Product (..)) import Data.Hashable (Hashable (..)) import Data.HashMap.Strict (HashMap)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (catMaybes) import Data.Semigroup (Semigroup (..)) import Data.Sequence (Seq)@@ -64,8 +66,8 @@ import qualified Data.IntMap.Lazy as IntMap #if MIN_VERSION_containers(0,5,9)-import qualified Data.Map.Merge.Lazy as Map import qualified Data.IntMap.Merge.Lazy as IntMap+import qualified Data.Map.Merge.Lazy as Map #endif -- containers <0.5@@ -94,17 +96,15 @@ -- Maybe (These b c) ~ (a -> Maybe b, a -> Maybe c))@. This insight -- is due to rwbarton. ----- Minimal definition: @nil@ and either @align@ or @alignWith@.+-- Minimal definition: either @align@ or @alignWith@. -- -- == Laws: -- -- @--- (\`align` nil) = fmap This--- (nil \`align`) = fmap That -- join align = fmap (join These) -- align (f \<$> x) (g \<$> y) = bimap f g \<$> align x y -- alignWith f a b = f \<$> align a b--- align (align x y) z = fmap assoc (align x (align y z))+-- align x (align y z) = fmap assoc (align (align x y) z) -- @ -- -- /Note:/ @'join' f x = f x x@@@ -118,11 +118,7 @@ -- = mapMaybe justHere (toList (align x y)) -- @ ---class (Functor f) => Align f where- -- | An empty strucutre. @'align'@ing with @'nil'@ will produce a structure with- -- the same shape and elements as the other input, modulo @'This'@ or @'That'@.- nil :: f a-+class Functor f => Semialign f where -- | Analogous to @'zip'@, combines two structures by taking the union of -- their shapes and using @'These'@ to hold the elements. align :: f a -> f b -> f (These a b)@@ -134,9 +130,23 @@ alignWith f a b = f <$> align a b #if __GLASGOW_HASKELL__ >= 707- {-# MINIMAL nil , (align | alignWith) #-}+ {-# MINIMAL align | alignWith #-} #endif +-- | A unit of 'align'.+--+-- == Laws:+--+-- @+-- (\`align` nil) = fmap This+-- (nil \`align`) = fmap That+-- @+--+class Semialign f => Align f where+ -- | An empty structure. @'align'@ing with @'nil'@ will produce a structure with+ -- the same shape and elements as the other input, modulo @'This'@ or @'That'@.+ nil :: f a+ {-# RULES "align nil nil" align nil nil = nil@@ -147,9 +157,14 @@ #-} +-------------------------------------------------------------------------------+-- Instances+------------------------------------------------------------------------------- instance Align Maybe where nil = Nothing++instance Semialign Maybe where align Nothing Nothing = Nothing align (Just a) Nothing = Just (This a) align Nothing (Just b) = Just (That b)@@ -157,17 +172,26 @@ instance Align [] where nil = []++instance Semialign [] where align xs [] = This <$> xs align [] ys = That <$> ys align (x:xs) (y:ys) = These x y : align xs ys +-- @since 0.8+instance Semialign NonEmpty where+ align (x :| xs) (y :| ys) = These x y :| align xs ys+ instance Align ZipList where nil = ZipList []- align (ZipList xs) (ZipList ys) = ZipList (align xs ys) +instance Semialign ZipList where+ alignWith f (ZipList xs) (ZipList ys) = ZipList (alignWith f xs ys)+ instance Align Seq where nil = Seq.empty +instance Semialign Seq where align xs ys = case compare xn yn of EQ -> Seq.zipWith fc xs ys LT -> case Seq.splitAt xn ys of@@ -192,6 +216,8 @@ instance (Ord k) => Align (Map k) where nil = Map.empty++instance (Ord k) => Semialign (Map k) where #if MIN_VERSION_containers(0,5,9) alignWith f = Map.merge (Map.mapMissing (\_ x -> f (This x))) (Map.mapMissing (\_ y -> f (That y)))@@ -206,6 +232,8 @@ instance Align IntMap where nil = IntMap.empty++instance Semialign IntMap where #if MIN_VERSION_containers(0,5,9) alignWith f = IntMap.merge (IntMap.mapMissing (\_ x -> f (This x))) (IntMap.mapMissing (\_ y -> f (That y)))@@ -218,13 +246,22 @@ merge _ _ = oops "Align IntMap: merge" #endif +-- @since 0.8+instance Semialign Identity where+ alignWith f (Identity a) (Identity b) = Identity (f (These a b))+ instance (Align f, Align g) => Align (Product f g) where nil = Pair nil nil++instance (Semialign f, Semialign g) => Semialign (Product f g) where align (Pair a b) (Pair c d) = Pair (align a c) (align b d)+ alignWith f (Pair a b) (Pair c d) = Pair (alignWith f a c) (alignWith f b d) -- Based on the Data.Vector.Fusion.Stream.Monadic zipWith implementation instance Monad m => Align (Stream m) where nil = Stream.empty++instance Monad m => Semialign (Stream m) where #if MIN_VERSION_vector(0,11,0) alignWith f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing, False)@@ -254,12 +291,16 @@ #if MIN_VERSION_vector(0,11,0) instance Monad m => Align (Bundle m v) where nil = Bundle.empty++instance Monad m => Semialign (Bundle m v) where alignWith f Bundle{sElems = sa, sSize = na} Bundle{sElems = sb, sSize = nb} = Bundle.fromStream (alignWith f sa sb) (Bundle.larger na nb) #endif instance Align V.Vector where nil = Data.Vector.Generic.empty++instance Semialign V.Vector where alignWith = alignVectorWith alignVectorWith :: (Vector v a, Vector v b, Vector v c)@@ -268,6 +309,8 @@ instance (Eq k, Hashable k) => Align (HashMap k) where nil = HashMap.empty++instance (Eq k, Hashable k) => Semialign (HashMap k) where align m n = HashMap.unionWith merge (HashMap.map This m) (HashMap.map That n) where merge (This a) (That b) = These a b merge _ _ = oops "Align HashMap: merge"
Data/Align/Indexed.hs view
@@ -10,7 +10,7 @@ AlignWithIndex (..), ) where -import Control.Lens (FunctorWithIndex)+import Control.Lens (FunctorWithIndex (imap)) import Data.Vector.Instances () import Data.Align@@ -25,20 +25,19 @@ import Data.Sequence (Seq) import Data.Vector (Vector) -import qualified Data.Align.Key as Key- -- | Keyed version of 'Align'. -- -- @since 0.7.6-class (FunctorWithIndex i f, Align f) => AlignWithIndex i f | f -> i where+class (FunctorWithIndex i f, Semialign f) => AlignWithIndex i f | f -> i where -- | Analogous to @'alignWith'@, but also provides an index. ialign :: (i -> These a b -> c) -> f a -> f b -> f c+ ialign f a b = imap f (align a b) -instance AlignWithIndex () Maybe where ialign = Key.alignWithKey-instance AlignWithIndex Int [] where ialign = Key.alignWithKey-instance AlignWithIndex Int ZipList where ialign = Key.alignWithKey-instance AlignWithIndex Int Seq where ialign = Key.alignWithKey-instance AlignWithIndex Int IntMap where ialign = Key.alignWithKey-instance Ord k => AlignWithIndex k (Map k) where ialign = Key.alignWithKey-instance (Eq k, Hashable k) => AlignWithIndex k (HashMap k) where ialign = Key.alignWithKey-instance AlignWithIndex Int Vector where ialign = Key.alignWithKey+instance AlignWithIndex () Maybe+instance AlignWithIndex Int []+instance AlignWithIndex Int ZipList+instance AlignWithIndex Int Seq+instance AlignWithIndex Int IntMap+instance Ord k => AlignWithIndex k (Map k)+instance (Eq k, Hashable k) => AlignWithIndex k (HashMap k)+instance AlignWithIndex Int Vector
Data/Align/Key.hs view
@@ -26,7 +26,7 @@ -- | Keyed version of 'Align'. -- -- @since 0.7.1-class (Keyed f, Align f) => AlignWithKey f where+class (Keyed f, Semialign f) => AlignWithKey f where -- | Analogous to @'alignWith'@, but also provides an index. alignWithKey :: (Key f -> These a b -> c) -> f a -> f b -> f c alignWithKey f a b = mapWithKey f (align a b)
Data/These.hs view
@@ -14,59 +14,26 @@ , mergeThese , mergeTheseWith - -- * Traversals- , here, there-- -- * Half selections- , justHere- , justThere-- -- * Prisms- , _This, _That, _These-- -- * Case selections- , justThis- , justThat- , justThese-- , catThis- , catThat- , catThese-+ -- * Partition , partitionThese-- -- * Case predicates- , isThis- , isThat- , isThese-- -- * Map operations- , mapThese- , mapThis- , mapThat-- , bitraverseThese-- -- * Associativity and commutativity- , swap- , assoc- , reassoc+ , partitionHereThere ) where import Prelude () import Prelude.Compat import Control.DeepSeq (NFData (..))-import Control.Lens (Prism', Swapped (..), iso, prism)+import Control.Lens (Swapped (..), iso) import Data.Aeson (FromJSON (..), ToJSON (..), (.=)) import Data.Bifoldable (Bifoldable (..)) import Data.Bifunctor (Bifunctor (..))+import Data.Bifunctor.Assoc (Assoc (..))+import Data.Bifunctor.Swap (Swap (..)) import Data.Binary (Binary (..)) import Data.Bitraversable (Bitraversable (..)) import Data.Data (Data, Typeable) import Data.Functor.Bind (Apply (..), Bind (..)) import Data.Hashable (Hashable (..))-import Data.Maybe (isJust, mapMaybe) import Data.Semigroup (Semigroup (..)) import Data.Semigroup.Bifoldable (Bifoldable1 (..)) import Data.Semigroup.Bitraversable (Bitraversable1 (..))@@ -100,6 +67,10 @@ data These a b = This a | That b | These a b deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +-------------------------------------------------------------------------------+-- Eliminators+-------------------------------------------------------------------------------+ -- | Case analysis for the 'These' type. these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c these l _ _ (This a) = l a@@ -108,215 +79,71 @@ -- | Takes two default values and produces a tuple. fromThese :: a -> b -> These a b -> (a, b)-fromThese _ x (This a ) = (a, x)-fromThese a _ (That x ) = (a, x)-fromThese _ _ (These a x) = (a, x)+fromThese x y = these (`pair` y) (x `pair`) pair where+ pair = (,) -- | Coalesce with the provided operation. mergeThese :: (a -> a -> a) -> These a a -> a mergeThese = these id id --- | BiMap and coalesce results with the provided operation.+-- | 'bimap' and coalesce results with the provided operation. mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c-mergeTheseWith f g op t = mergeThese op $ mapThese f g t---- | A 'Control.Lens.Traversal' of the first half of a 'These', suitable for use with "Control.Lens".------ @--- 'here' :: 'Control.Lens.Traversal' ('These' a t) ('These' b t) a b--- @------ >>> over here show (That 1)--- That 1------ >>> over here show (These 'a' 2)--- These "'a'" 2----here :: (Applicative f) => (a -> f b) -> These a t -> f (These b t)-here f (This x) = This <$> f x-here f (These x y) = flip These y <$> f x-here _ (That x) = pure (That x)---- | A 'Control.Lens.Traversal' of the second half of a 'These', suitable for use with "Control.Lens".------ @--- 'there' :: 'Control.Lens.Traversal' ('These' t b) ('These' t b) a b--- @------ >>> over there show (That 1)--- That "1"------ >>> over there show (These 'a' 2)--- These 'a' "2"----there :: (Applicative f) => (a -> f b) -> These t a -> f (These t b)-there _ (This x) = pure (This x)-there f (These x y) = These x <$> f y-there f (That x) = That <$> f x---- | @'justHere' = 'Control.Lens.preview' 'here'@------ >>> justHere (This 'x')--- Just 'x'------ >>> justHere (That 'y')--- Nothing------ >>> justHere (These 'x' 'y')--- Just 'x'----justHere :: These a b -> Maybe a-justHere (This a) = Just a-justHere (That _) = Nothing-justHere (These a _) = Just a---- | @'justThere' = 'Control.Lens.preview' 'there'@------ >>> justThere (This 'x')--- Nothing------ >>> justThere (That 'y')--- Just 'y'------ >>> justThere (These 'x' 'y')--- Just 'y'----justThere :: These a b -> Maybe b-justThere (This _) = Nothing-justThere (That b) = Just b-justThere (These _ b) = Just b---- | A 'Control.Lens.Prism'' selecting the 'This' constructor.------ /Note:/ cannot change type.-_This :: Prism' (These a b) a-_This = prism This (these Right (Left . That) (\x y -> Left $ These x y))---- | A 'Control.Lens.Prism'' selecting the 'That' constructor.------ /Note:/ cannot change type.-_That :: Prism' (These a b) b-_That = prism That (these (Left . This) Right (\x y -> Left $ These x y))---- | A 'Control.Lens.Prism'' selecting the 'These' constructor. 'These' names are ridiculous!------ /Note:/ cannot change type.-_These :: Prism' (These a b) (a, b)-_These = prism (uncurry These) (these (Left . This) (Left . That) (\x y -> Right (x, y)))----- | @'justThis' = 'Control.Lens.preview' '_This'@-justThis :: These a b -> Maybe a-justThis (This a) = Just a-justThis _ = Nothing---- | @'justThat' = 'Control.Lens.preview' '_That'@-justThat :: These a b -> Maybe b-justThat (That x) = Just x-justThat _ = Nothing---- | @'justThese' = 'Control.Lens.preview' '_These'@-justThese :: These a b -> Maybe (a, b)-justThese (These a x) = Just (a, x)-justThese _ = Nothing---isThis, isThat, isThese :: These a b -> Bool--- | @'isThis' = 'isJust' . 'justThis'@-isThis = isJust . justThis---- | @'isThat' = 'isJust' . 'justThat'@-isThat = isJust . justThat---- | @'isThese' = 'isJust' . 'justThese'@-isThese = isJust . justThese---- | 'Bifunctor' map.-mapThese :: (a -> c) -> (b -> d) -> These a b -> These c d-mapThese f _ (This a ) = This (f a)-mapThese _ g (That x) = That (g x)-mapThese f g (These a x) = These (f a) (g x)---- | 'Bitraversable'.------ @since 0.7.5-bitraverseThese :: Applicative f => (a -> f c) -> (b -> f d) -> These a b -> f (These c d)-bitraverseThese f _ (This x) = This <$> f x-bitraverseThese _ g (That x) = That <$> g x-bitraverseThese f g (These x y) = These <$> f x <*> g y---- | @'mapThis' = 'Control.Lens.over' 'here'@-mapThis :: (a -> c) -> These a b -> These c b-mapThis f = mapThese f id---- | @'mapThat' = 'Control.Lens.over' 'there'@-mapThat :: (b -> d) -> These a b -> These a d-mapThat f = mapThese id f---- | Select all 'This' constructors from a list.-catThis :: [These a b] -> [a]-catThis = mapMaybe justThis---- | Select all 'That' constructors from a list.-catThat :: [These a b] -> [b]-catThat = mapMaybe justThat+mergeTheseWith f g op t = mergeThese op $ bimap f g t --- | Select all 'These' constructors from a list.-catThese :: [These a b] -> [(a, b)]-catThese = mapMaybe justThese+-------------------------------------------------------------------------------+-- Partitioning+------------------------------------------------------------------------------- -- | Select each constructor and partition them into separate lists.-partitionThese :: [These a b] -> ( [(a, b)], ([a], [b]) )-partitionThese [] = ([], ([], []))-partitionThese (These x y:xs) = first ((x, y):) $ partitionThese xs-partitionThese (This x :xs) = second (first (x:)) $ partitionThese xs-partitionThese (That y:xs) = second (second (y:)) $ partitionThese xs---- | 'These' is commutative.------ @--- 'swap' . 'swap' = 'id'--- @------ @since 0.7.6-swap :: These a b -> These b a-swap (This a) = That a-swap (That b) = This b-swap (These a b) = These b a---- | 'These' is associative.------ @--- 'assoc' . 'reassoc' = 'id'--- 'reassoc' . 'assoc' = 'id'--- @------ @since 0.7.6-assoc :: These a (These b c) -> These (These a b) c-assoc (This a) = This (This a)-assoc (That (This b)) = This (That b)-assoc (That (That c)) = That c-assoc (That (These b c)) = These (That b) c-assoc (These a (This b)) = This (These a b)-assoc (These a (That c)) = These (This a) c-assoc (These a (These b c)) = These (These a b) c+partitionThese :: [These a b] -> ([a], [b], [(a, b)])+partitionThese [] = ([], [], [])+partitionThese (t:ts) = case t of+ This x -> (x : xs, ys, xys)+ That y -> ( xs, y : ys, xys)+ These x y -> ( xs, ys, (x,y) : xys)+ where+ ~(xs,ys,xys) = partitionThese ts --- | 'These is associative. See 'assoc'.+-- | Select 'here' and 'there' elements and partition them into separate lists. ----- @since 0.7.6-reassoc :: These (These a b) c -> These a (These b c)-reassoc (This (This a)) = This a-reassoc (This (That b)) = That (This b)-reassoc (That c) = That (That c)-reassoc (These (That b) c) = That (These b c)-reassoc (This (These a b)) = These a (This b)-reassoc (These (This a) c) = These a (That c)-reassoc (These (These a b) c) = These a (These b c)+-- @since 0.8+partitionHereThere :: [These a b] -> ([a], [b])+partitionHereThere [] = ([], [])+partitionHereThere (t:ts) = case t of+ This x -> (x : xs, ys)+ That y -> ( xs, y : ys)+ These x y -> (x : xs, y : ys)+ where+ ~(xs,ys) = partitionHereThere ts ------------------------------------------------------------------------------- -- Instances ------------------------------------------------------------------------------- +-- | @since 0.8+instance Swap These where+ swap (This a) = That a+ swap (That b) = This b+ swap (These a b) = These b a++-- | @since 0.8+instance Assoc These where+ assoc (This (This a)) = This a+ assoc (This (That b)) = That (This b)+ assoc (That c) = That (That c)+ assoc (These (That b) c) = That (These b c)+ assoc (This (These a b)) = These a (This b)+ assoc (These (This a) c) = These a (That c)+ assoc (These (These a b) c) = These a (These b c)++ unassoc (This a) = This (This a)+ unassoc (That (This b)) = This (That b)+ unassoc (That (That c)) = That c+ unassoc (That (These b c)) = These (That b) c+ unassoc (These a (This b)) = This (These a b)+ unassoc (These a (That c)) = These (This a) c+ unassoc (These a (These b c)) = These (These a b) c+ instance (Semigroup a, Semigroup b) => Semigroup (These a b) where This a <> This b = This (a <> b) This a <> That y = These a y@@ -347,9 +174,9 @@ sequenceA (These a x) = These a <$> x instance Bifunctor These where- bimap = mapThese- first = mapThis- second = mapThat+ bimap f _ (This a ) = This (f a)+ bimap _ g (That x) = That (g x)+ bimap f g (These a x) = These (f a) (g x) instance Bifoldable These where bifold = these id id mappend@@ -360,7 +187,9 @@ bifold1 = these id id (<>) instance Bitraversable These where- bitraverse = bitraverseThese+ bitraverse f _ (This x) = This <$> f x+ bitraverse _ g (That x) = That <$> g x+ bitraverse f g (These x y) = These <$> f x <*> g y instance Bitraversable1 These where bitraverse1 f _ (This x) = This <$> f x
+ Data/These/Combinators.hs view
@@ -0,0 +1,247 @@+-- | This module provides+--+-- * specialised versions of class members e.g. 'bitraverseThese'+-- * non-lens variants of "Data.These.Lens" things, e.g 'justHere'+module Data.These.Combinators (+ -- * Specialised combinators+ -- ** Bifunctor+ bimapThese,+ mapHere,+ mapThere,+ -- ** Bitraversable+ bitraverseThese,+ -- ** Associativity and commutativity+ swapThese,+ assocThese,+ unassocThese,++ -- * Other operations+ -- ** preview+ --+ -- |+ -- @+ -- 'justThis' = 'Control.Lens.preview' '_This'+ -- 'justThat' = 'Control.Lens.preview' '_That'+ -- 'justThese' = 'Control.Lens.preview' '_These'+ -- 'justHere' = 'Control.Lens.preview' 'here'+ -- 'justThere' = 'Control.Lens.preview' 'there'+ -- @+ justThis,+ justThat,+ justThese,+ justHere,+ justThere,++ -- ** toListOf+ --+ -- |+ -- @+ -- 'catThis' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_This')+ -- 'catThat' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_That')+ -- 'catThese' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_These')+ -- 'catHere' = 'Control.Lens.toListOf' ('Control.Lens.folded' . 'here')+ -- 'catThere' = 'Control.Lens.toListOf' ('Control.Lens.folded' . 'there')+ -- @+ catThis,+ catThat,+ catThese,+ catHere,+ catThere,++ -- * is / has+ --+ -- |+ -- @+ -- 'isThis' = 'Control.Lens.Extra.is' '_This'+ -- 'isThat' = 'Control.Lens.Extra.is' '_That'+ -- 'isThese' = 'Control.Lens.Extra.is' '_These'+ -- 'hasHere' = 'Control.Lens.has' 'here'+ -- 'hasThere' = 'Control.Lens.has' 'there'+ -- @+ isThis,+ isThat,+ isThese,+ hasHere,+ hasThere,++ -- * over / map+ --+ -- @+ -- 'mapThis' = 'Control.Lens.over' '_This'+ -- 'mapThat' = 'Control.Lens.over' '_That'+ -- 'mapThese' = 'Control.Lens.over' '_These'+ -- 'mapHere' = 'Control.Lens.over' 'here'+ -- 'mapThere' = 'Control.Lens.over' 'there'+ -- @+ mapThis,+ mapThat,+ mapThese,+ ) where++import Prelude ()+import Prelude.Compat++import Data.Bifunctor (bimap, first, second)+import Data.Bifunctor.Assoc (assoc, unassoc)+import Data.Bifunctor.Swap (swap)+import Data.Bitraversable (bitraverse)+import Data.Maybe (isJust, mapMaybe)+import Data.These++-------------------------------------------------------------------------------+-- bifunctors+-------------------------------------------------------------------------------++-- | 'Bifunctor' 'bimap'.+bimapThese :: (a -> c) -> (b -> d) -> These a b -> These c d+bimapThese = bimap++-- | @'mapThis' = 'Control.Lens.over' 'here'@+mapHere :: (a -> c) -> These a b -> These c b+mapHere = first++-- | @'mapThere' = 'Control.Lens.over' 'there'@+mapThere :: (b -> d) -> These a b -> These a d+mapThere = second++-- | 'Bitraversable' 'bitraverse'.+bitraverseThese :: Applicative f => (a -> f c) -> (b -> f d) -> These a b -> f (These c d)+bitraverseThese = bitraverse++-------------------------------------------------------------------------------+-- assoc+-------------------------------------------------------------------------------++-- | 'These' is commutative.+--+-- @+-- 'swapThese' . 'swapThese' = 'id'+-- @+--+-- @since 0.8+swapThese :: These a b -> These b a+swapThese = swap++-- | 'These' is associative.+--+-- @+-- 'assocThese' . 'unassocThese' = 'id'+-- 'unassocThese' . 'assocThese' = 'id'+-- @+--+-- @since 0.8+assocThese :: These (These a b) c -> These a (These b c)+assocThese = assoc++-- | 'These is associative. See 'assocThese'.+--+-- @since 0.8+unassocThese :: These a (These b c) -> These (These a b) c+unassocThese = unassoc++-------------------------------------------------------------------------------+-- preview+-------------------------------------------------------------------------------++-- |+--+-- >>> justHere (This 'x')+-- Just 'x'+--+-- >>> justHere (That 'y')+-- Nothing+--+-- >>> justHere (These 'x' 'y')+-- Just 'x'+--+justHere :: These a b -> Maybe a+justHere (This a) = Just a+justHere (That _) = Nothing+justHere (These a _) = Just a++-- |+--+-- >>> justThere (This 'x')+-- Nothing+--+-- >>> justThere (That 'y')+-- Just 'y'+--+-- >>> justThere (These 'x' 'y')+-- Just 'y'+--+justThere :: These a b -> Maybe b+justThere (This _) = Nothing+justThere (That b) = Just b+justThere (These _ b) = Just b++justThis :: These a b -> Maybe a+justThis (This a) = Just a+justThis _ = Nothing++justThat :: These a b -> Maybe b+justThat (That x) = Just x+justThat _ = Nothing++justThese :: These a b -> Maybe (a, b)+justThese (These a x) = Just (a, x)+justThese _ = Nothing++-------------------------------------------------------------------------------+-- toListOf+-------------------------------------------------------------------------------++-- | Select all 'This' constructors from a list.+catThis :: [These a b] -> [a]+catThis = mapMaybe justThis++-- | Select all 'That' constructors from a list.+catThat :: [These a b] -> [b]+catThat = mapMaybe justThat++-- | Select all 'These' constructors from a list.+catThese :: [These a b] -> [(a, b)]+catThese = mapMaybe justThese++catHere :: [These a b] -> [a]+catHere = mapMaybe justHere++catThere :: [These a b] -> [b]+catThere = mapMaybe justThere++-------------------------------------------------------------------------------+-- is+-------------------------------------------------------------------------------++isThis, isThat, isThese :: These a b -> Bool+-- | @'isThis' = 'isJust' . 'justThis'@+isThis = isJust . justThis++-- | @'isThat' = 'isJust' . 'justThat'@+isThat = isJust . justThat++-- | @'isThese' = 'isJust' . 'justThese'@+isThese = isJust . justThese++hasHere, hasThere :: These a b -> Bool+-- | @'hasHere' = 'isJust' . 'justHere'@+hasHere = isJust . justHere++-- | @'hasThere' = 'isJust' . 'jusThere'@+hasThere = isJust . justThere++-------------------------------------------------------------------------------+-- over / map+-------------------------------------------------------------------------------++mapThis :: (a -> a) -> These a b -> These a b+mapThis f (This x) = This (f x)+mapThis _ y = y++mapThat :: (b -> b) -> These a b -> These a b+mapThat f (That x) = That (f x)+mapThat _ y = y++mapThese :: ((a, b) -> (a, b)) -> These a b -> These a b+mapThese f (These x y) = uncurry These (curry f x y)+mapThese _ z = z
+ Data/These/Lens.hs view
@@ -0,0 +1,73 @@+module Data.These.Lens (+ -- * Traversals+ here, there,++ -- * Prisms+ _This, _That, _These,+ ) where++import Prelude ()+import Prelude.Compat++import Control.Lens (Prism', prism)+import Data.These++-------------------------------------------------------------------------------+-- Traversals+-------------------------------------------------------------------------------++-- | A 'Control.Lens.Traversal' of the first half of a 'These', suitable for use with "Control.Lens".+--+-- @+-- 'here' :: 'Control.Lens.Traversal' ('These' a t) ('These' b t) a b+-- @+--+-- >>> over here show (That 1)+-- That 1+--+-- >>> over here show (These 'a' 2)+-- These "'a'" 2+--+here :: (Applicative f) => (a -> f b) -> These a t -> f (These b t)+here f (This x) = This <$> f x+here f (These x y) = flip These y <$> f x+here _ (That x) = pure (That x)++-- | A 'Control.Lens.Traversal' of the second half of a 'These', suitable for use with "Control.Lens".+--+-- @+-- 'there' :: 'Control.Lens.Traversal' ('These' t b) ('These' t b) a b+-- @+--+-- >>> over there show (That 1)+-- That "1"+--+-- >>> over there show (These 'a' 2)+-- These 'a' "2"+--+there :: (Applicative f) => (a -> f b) -> These t a -> f (These t b)+there _ (This x) = pure (This x)+there f (These x y) = These x <$> f y+there f (That x) = That <$> f x++-------------------------------------------------------------------------------+-- Prisms+-------------------------------------------------------------------------------++-- | A 'Control.Lens.Prism'' selecting the 'This' constructor.+--+-- /Note:/ cannot change type.+_This :: Prism' (These a b) a+_This = prism This (these Right (Left . That) (\x y -> Left $ These x y))++-- | A 'Control.Lens.Prism'' selecting the 'That' constructor.+--+-- /Note:/ cannot change type.+_That :: Prism' (These a b) b+_That = prism That (these (Left . This) Right (\x y -> Left $ These x y))++-- | A 'Control.Lens.Prism'' selecting the 'These' constructor. 'These' names are ridiculous!+--+-- /Note:/ cannot change type.+_These :: Prism' (These a b) (a, b)+_These = prism (uncurry These) (these (Left . This) (Left . That) (\x y -> Right (x, y)))
test/Tests.hs view
@@ -46,6 +46,8 @@ import Data.Align.Indexed import Data.Align.Key import Data.These+import Data.These.Combinators+import Data.These.Lens -- For old GHC to work data Proxy (a :: * -> *) = Proxy@@ -188,8 +190,8 @@ dataAlignLaws :: forall (f :: * -> *). ( Align f, Foldable f , Eq (f (These Int Int)) , Show (f (These Int Int))- , Eq (f (These (These Int Int) Int))- , Show (f (These (These Int Int) Int))+ , Eq (f (These Int (These Int Int)))+ , Show (f (These Int (These Int Int))) , CoArbitrary (These Int Int) , Arbitrary (f Int) , Eq (f Int)@@ -225,10 +227,10 @@ alignWith f xs ys === (f <$> align xs ys) assocProp :: f Int -> f Int -> f Int -> Property- assocProp xs ys zs = rhs === lhs+ assocProp xs ys zs = lhs === fmap assocThese rhs where rhs = (xs `align` ys) `align` zs- lhs = fmap assoc $ xs `align` (ys `align` zs)+ lhs = xs `align` (ys `align` zs) alignToListProp :: f Int -> f Int -> Property alignToListProp xs ys =@@ -252,6 +254,8 @@ instance Ord k => Align (WrongMap k) where nil = WM Map.empty++instance Ord k => Semialign (WrongMap k) where align (WM x) (WM y) | Map.null y = WM $ This <$> x | Map.null x = WM $ That <$> y@@ -276,6 +280,7 @@ instance Ord k => Align (WeirdMap k) where nil = WeirdMap Map.empty +instance Ord k => Semialign (WeirdMap k) where alignWith f (WeirdMap x) (WeirdMap y) = WeirdMap $ Map.fromList $ alignWith g (Map.toList x) (Map.toList y) where@@ -290,6 +295,8 @@ {- instance Monoid a => Align (Const a) where nil = Const mempty++instance Monoid a => Semialign (Const a) where align (Const a) (Const b) = Const (mappend a b) -} @@ -304,6 +311,7 @@ instance Align R where nil = Nest [] +instance Semialign R where align (Nest ass) (Nest bss) | null ass = That <$> Nest bss | null bss = This <$> Nest ass
these.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: these-version: 0.7.6+version: 0.8 synopsis: An either-or-both data type & a generalized 'zip with padding' typeclass @@ -49,10 +49,13 @@ Data.Align.Key Data.Functor.These Data.These+ Data.These.Lens+ Data.These.Combinators -- ghc boot libs build-depends:- base >=4.5.1.0 && <4.13+ assoc >=1 && <1.1+ , base >=4.5.1.0 && <4.13 , binary >=0.5.1.0 && <0.10 , containers >=0.4.2.1 && <0.7 , deepseq >=1.3.0.0 && <1.5