diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,30 @@ +Copyright (c) 2022 Tony Morris + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of QFPL nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/alignment.cabal b/alignment.cabal new file mode 100644 --- /dev/null +++ b/alignment.cabal @@ -0,0 +1,39 @@ +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: alignment +version: 0.1.0.0 +synopsis: Zip-alignment +description: + <> + . + Zipping with alignment +license: BSD3 +license-file: LICENCE +author: Tony Morris +maintainer: Tony Morris +copyright: Copyright (C) 2022 Tony Morris +category: Data +build-type: Simple +extra-source-files: changelog.md +cabal-version: >=1.10 +homepage: https://github.com/system-f/alignment +bug-reports: https://github.com/system-f/alignment/issues +tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 + +source-repository head + type: git + location: git@github.com:system-f/alignment.git + +library + exposed-modules: Data.Alignment + + build-depends: base >= 4.8 && < 6 + , bifunctors >= 5 && < 6 + , lens >= 4.15 && < 6 + , semigroupoids >= 5.1 && < 5.4 + , transformers >= 0.5.0 && < 5.5 + , assoc >= 1 && < 2 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,4 @@ +0.1.0.0 + +* This change log starts. +* The initial version of alignment. diff --git a/src/Data/Alignment.hs b/src/Data/Alignment.hs new file mode 100644 --- /dev/null +++ b/src/Data/Alignment.hs @@ -0,0 +1,584 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Alignment( +-- * Types + This(..) +-- * Type-classes +, Semialign(..) +, Align(..) +-- * Optics +, these +, those +, allThese +, allThese1 +, allThese2 +, allThose +, allThoseA +, allThoseA' +, allThoseB +, allThoseB' +, allTheseThoseA +, allTheseThoseB +) where + +import Control.Applicative + ( Applicative(liftA2, pure, (<*>)), (<$>), ZipList(ZipList) ) +import Control.Category ( Category((.)) ) +import Control.Lens + ( Identity(Identity), + _Just, + _Left, + _Right, + over, + Field1(_1), + Field2(_2), + Lens, + Lens', + Traversal' ) +import Data.Bifoldable ( Bifoldable(bifoldMap) ) +import Data.Bifunctor ( Bifunctor(bimap) ) +import Data.Bifunctor.Swap ( Swap(..) ) +import Data.Bitraversable ( Bitraversable(..) ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Bool ( (&&) ) +import Data.Either ( Either(..) ) +import Data.Eq ( Eq((==)) ) +import Data.Foldable ( Foldable(foldMap) ) +import Data.Functor ( Functor(fmap) ) +import Data.Functor.Apply ( Apply((<.>), liftF2) ) +import qualified Data.List.NonEmpty as NonEmpty(cons, toList) +import Data.Maybe ( Maybe(..) ) +import Data.Monoid ( (<>), Monoid(mempty) ) +import Data.Ord ( Ord(compare) ) +import Data.Semigroup ( Semigroup ) +import Data.Traversable ( Traversable(traverse) ) +import GHC.Show ( Show(showsPrec) ) +import Data.Functor.Classes + ( compare1, + eq1, + showsPrec1, + showsUnaryWith, + Eq1(..), + Ord1(..), + Show1(..) ) + +data This f a b = + This + (f (a, b)) + (Maybe (Either (NonEmpty a) (NonEmpty b))) + +instance (Eq1 f, Eq a, Eq b) => Eq (This f a b) where + This t1 r1 == This t2 r2 = + t1 `eq1` t2 && r1 == r2 + +instance (Eq1 f, Eq a) => Eq1 (This f a) where + liftEq f (This t1 r1) (This t2 r2) = + liftEq (liftEq f) t1 t2 && liftEq (liftEq (liftEq f)) r1 r2 + +instance (Ord1 f, Ord a, Ord b) => Ord (This f a b) where + This t1 r1 `compare` This t2 r2 = + t1 `compare1` t2 <> r1 `compare` r2 + +instance (Ord1 f, Ord a) => Ord1 (This f a) where + liftCompare f (This t1 r1) (This t2 r2) = + liftCompare (liftCompare f) t1 t2 <> liftCompare (liftCompare (liftCompare f)) r1 r2 + +instance (Show1 f, Show a, Show b) => Show (This f a b) where + showsPrec d (This t r) = + showsUnaryWith showsPrec1 "This" d t . (" " <>) . showsPrec1 d r + +instance (Show1 f, Show a) => Show1 (This f a) where + liftShowsPrec sp sl d (This t r) = + let showsPrecFt = liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl) + showsPrecFr = liftShowsPrec (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) (liftShowList (liftShowsPrec sp sl) (liftShowList sp sl)) + in showsUnaryWith showsPrecFt "This" d t . (" " <>) . showsPrecFr d r + +instance Functor f => Bifunctor (This f) where + bimap f g (This t r) = + This (fmap (bimap f g) t) (fmap (bimap (fmap f) (fmap g)) r) + +instance Foldable f => Bifoldable (This f) where + bifoldMap f g (This t r) = + foldMap (bifoldMap f g) t <> foldMap (bifoldMap (foldMap f) (foldMap g)) r + +instance Traversable f => Bitraversable (This f) where + bitraverse f g (This t r) = + This <$> traverse (bitraverse f g) t <*> traverse (bitraverse (traverse f) (traverse g)) r + +instance Functor f => Functor (This f a) where + fmap = + bimap (\x -> x) + +-- | +-- +-- >>> This [("a", id), ("c", id)] Nothing <.> This [("A", "B"), ("C", "D")] Nothing +-- This [("aA","B"),("aC","D"),("cA","B"),("cC","D")] Nothing +-- >>> This [("a", id), ("c", id)] Nothing <.> This [("A", "B"), ("C", "D")] (Just (Left ("x":|[]))) +-- This [("aA","B"),("aC","D"),("cA","B"),("cC","D")] Nothing +-- >>> This [("abc", reverse), ("cde", reverse)] Nothing <.> This [("ABC", "DEF"), ("GHI", "JKL")] Nothing +-- This [("abcABC","FED"),("abcGHI","LKJ"),("cdeABC","FED"),("cdeGHI","LKJ")] Nothing +-- >>> This [("abc", reverse), ("cde", reverse)] Nothing <.> This [("ABC", "DEF"), ("GHI", "JKL")] (Just (Left ("xyz":|[]))) +-- This [("abcABC","FED"),("abcGHI","LKJ"),("cdeABC","FED"),("cdeGHI","LKJ")] Nothing +-- >>> This [("abc", reverse), ("cde", reverse)] Nothing <.> This [("ABC", "DEF"), ("GHI", "JKL")] (Just (Right ("xyz":|[]))) +-- This [("abcABC","FED"),("abcGHI","LKJ"),("cdeABC","FED"),("cdeGHI","LKJ")] Nothing +-- >>> This [("abc", reverse), ("cde", reverse)] (Just (Left ("stu":|[]))) <.> This [("ABC", "DEF"), ("GHI", "JKL")] Nothing +-- This [("abcABC","FED"),("abcGHI","LKJ"),("cdeABC","FED"),("cdeGHI","LKJ")] Nothing +-- >>> This [("abc", reverse), ("cde", reverse)] (Just (Right (id:|[reverse]))) <.> This [("ABC", "DEF"), ("GHI", "JKL")] Nothing +-- This [("abcABC","FED"),("abcGHI","LKJ"),("cdeABC","FED"),("cdeGHI","LKJ")] Nothing +-- >>> This [("abc", reverse), ("cde", reverse)] (Just (Left ("stu":|[]))) <.> This [("ABC", "DEF"), ("GHI", "JKL")] (Just (Left ("xyz":|[]))) +-- This [("abcABC","FED"),("abcGHI","LKJ"),("cdeABC","FED"),("cdeGHI","LKJ")] Just (Left ("stu" :| [])) +-- >>> This [("abc", reverse), ("cde", reverse)] (Just (Left ("stu":|[]))) <.> This [("ABC", "DEF"), ("GHI", "JKL")] (Just (Right ("xyz":|[]))) +-- This [("abcABC","FED"),("abcGHI","LKJ"),("cdeABC","FED"),("cdeGHI","LKJ")] Just (Left ("stu" :| [])) +-- >>> This [("abc", reverse), ("cde", reverse)] (Just (Right (id:|[reverse]))) <.> This [("ABC", "DEF"), ("GHI", "JKL")] (Just (Left ("xyz":|[]))) +-- This [("abcABC","FED"),("abcGHI","LKJ"),("cdeABC","FED"),("cdeGHI","LKJ")] Just (Left ("xyz" :| [])) +-- >>> This [("abc", reverse), ("cde", reverse)] (Just (Left ("stu":|[]))) <.> This [("ABC", "DEF"), ("GHI", "JKL")] (Just (Right ("xyz":|[]))) +-- This [("abcABC","FED"),("abcGHI","LKJ"),("cdeABC","FED"),("cdeGHI","LKJ")] Just (Left ("stu" :| [])) +instance (Semigroup a, Apply f) => Apply (This f a) where + This t1 r1 <.> This t2 r2 = + This (liftF2 (<.>) t1 t2) (liftF2 (liftF2 (<.>)) r1 r2) + +instance (Monoid a, Applicative f) => Applicative (This f a) where + pure a = + This (pure (mempty, a)) (pure (pure (pure a))) + This t1 r1 <*> This t2 r2 = + This (liftA2 (<*>) t1 t2) (liftF2 (liftF2 (<*>)) r1 r2) + +-- | +-- +-- >>> swap (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [('x',"abc"),('y',"def")] Nothing +-- >>> swap (This [("abc", 'x'), ("def", 'y')] (Just (Left ("a":|[])))) +-- This [('x',"abc"),('y',"def")] Just (Right ("a" :| [])) +-- >>> swap (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|[])))) +-- This [('x',"abc"),('y',"def")] Just (Left ('a' :| "")) +instance Functor f => Swap (This f) where + swap (This t r) = + This (fmap swap t) (fmap swap r) + +class Functor f => Semialign f where + align :: + f a + -> f b + -> This f a b + +-- | +-- +-- >>> align "abc" "def" +-- This [('a','d'),('b','e'),('c','f')] Nothing +-- >>> align "abc" "defghi" +-- This [('a','d'),('b','e'),('c','f')] Just (Right ('g' :| "hi")) +-- >>> align "abcdef" "ghi" +-- This [('a','g'),('b','h'),('c','i')] Just (Left ('d' :| "ef")) +instance Semialign [] where + align (a:as) (b:bs) = + let This t r = align as bs + in This ((a,b):t) r + align (a:as) [] = + This [] (Just (Left (a :| as))) + align [] (b:bs) = + This [] (Just (Right (b :| bs))) + align [] [] = + This [] Nothing + +-- | +-- +-- >>> align (Just "x") (Just "y") +-- This (Just ("x","y")) Nothing +-- >>> align (Just "x") (Nothing :: Maybe String) +-- This Nothing Just (Left ("x" :| [])) +-- >>> align (Nothing :: Maybe String) (Just "y") +-- This Nothing Just (Right ("y" :| [])) +instance Semialign Maybe where + align (Just a) (Just b) = + This (Just (a, b)) Nothing + align (Just a) Nothing = + This Nothing (Just (Left (a :| []))) + align Nothing (Just b) = + This Nothing (Just (Right (b :| []))) + align Nothing Nothing = + This Nothing Nothing + +-- | +-- +-- >>> align (Identity "x") (Identity "y") +-- This (Identity ("x","y")) Nothing +instance Semialign Identity where + align (Identity a) (Identity b) = + This (Identity (a, b)) Nothing + +-- | +-- +-- >>> align ('a':|"bc") ('g':|"hi") +-- This (('a','g') :| [('b','h'),('c','i')]) Nothing +-- >>> align ('a':|"bc") ('g':|"hijkl") +-- This (('a','g') :| [('b','h'),('c','i')]) Just (Right ('j' :| "kl")) +-- >>> align ('a':|"bcdef") ('g':|"hi") +-- This (('a','g') :| [('b','h'),('c','i')]) Just (Left ('d' :| "ef")) +instance Semialign NonEmpty where + align (h1:|[]) (h2:|[]) = + This ((h1, h2):|[]) Nothing + align (h1:|i1:r1) (h2:|[]) = + This ((h1, h2):|[]) (Just (Left (i1:|r1))) + align (h1:|[]) (h2:|i2:r2) = + This ((h1, h2):|[]) (Just (Right (i2:|r2))) + align (h1:|i1:r1) (h2:|i2:r2) = + let This t r = align (i1:|r1) (i2:|r2) + in This ((h1, h2) `NonEmpty.cons` t) r + +instance Semialign ZipList where + align (ZipList a) (ZipList b) = + over these ZipList (align a b) + +class Semialign f => Align f where + nil :: + f a + +instance Align [] where + nil = + [] + +instance Align Maybe where + nil = + Nothing + +instance Align ZipList where + nil = + ZipList [] + +-- | +-- +-- >>> This [("abc", 's'), ("def", 't')] Nothing <> This [("ghi", 'u'), ("jkl", 'v')] Nothing +-- This [("abc",'s'),("def",'t'),("ghi",'u'),("jkl",'v')] Nothing +-- >>> This [("abc", 's'), ("def", 't')] Nothing <> This [("ghi", 'u'), ("jkl", 'v')] (Just (Left ("mno":|["pqr"]))) +-- This [("abc",'s'),("def",'t'),("ghi",'u'),("jkl",'v')] Just (Left ("mno" :| ["pqr"])) +-- >>> This [("abc", 's'), ("def", 't')] Nothing <> This [("ghi", 'u'), ("jkl", 'v')] (Just (Right ('o':|"pqr"))) +-- This [("abc",'s'),("def",'t'),("ghi",'u'),("jkl",'v')] Just (Right ('o' :| "pqr")) +-- >>> This [("abc", 's'), ("def", 't')] (Just (Left ("mno":|["pqr"]))) <> This [("ghi", 'u'), ("jkl", 'v')] Nothing +-- This [("abc",'s'),("def",'t'),("ghi",'u'),("jkl",'v')] Just (Left ("mno" :| ["pqr"])) +-- >>> This [("abc", 's'), ("def", 't')] (Just (Right ('o':|"pqr"))) <> This [("ghi", 'u'), ("jkl", 'v')] Nothing +-- This [("abc",'s'),("def",'t'),("ghi",'u'),("jkl",'v')] Just (Right ('o' :| "pqr")) +-- >>> This [("abc", 's'), ("def", 't')] (Just (Left ("mno":|["pqr"]))) <> This [("ghi", 'u'), ("jkl", 'v')] (Just (Left ("ccddee":|["ffgghh"]))) +-- This [("abc",'s'),("def",'t'),("ghi",'u'),("jkl",'v')] Just (Left ("mno" :| ["pqr","ccddee","ffgghh"])) +-- >>> This [("abc", 's'), ("def", 't')] (Just (Left ("mno":|["pqr"]))) <> This [("ghi", 'u'), ("jkl", 'v')] (Just (Right ('c':|"ddeeff"))) +-- This [("abc",'s'),("def",'t'),("ghi",'u'),("jkl",'v'),("mno",'c'),("pqr",'d')] Just (Right ('d' :| "eeff")) +-- >>> This [("abc", 's'), ("def", 't')] (Just (Right ('x':|"yyzz"))) <> This [("ghi", 'u'), ("jkl", 'v')] (Just (Right ('c':|"ddeeff"))) +-- This [("abc",'s'),("def",'t'),("ghi",'u'),("jkl",'v')] Just (Right ('x' :| "yyzzcddeeff")) +-- >>> This [("abc", 's'), ("def", 't')] (Just (Right ('x':|"yyzz"))) <> This [("ghi", 'u'), ("jkl", 'v')] (Just (Left ("cc":|["ddeeff"]))) +-- This [("abc",'s'),("def",'t'),("ghi",'u'),("jkl",'v'),("cc",'x'),("ddeeff",'y')] Just (Right ('y' :| "zz")) +instance Semigroup (This [] a b) where + This t1 (Just (Left as1)) <> This t2 (Just (Left as2)) = + This (t1 <> t2) (Just (Left (as1 <> as2))) + This t1 (Just (Left as1)) <> This t2 (Just (Right bs2)) = + over these (\x -> t1 <> t2 <> NonEmpty.toList x) (align as1 bs2) + This t1 (Just (Left as1)) <> This t2 Nothing = + This (t1 <> t2) (Just (Left as1)) + This t1 (Just (Right bs1)) <> This t2 (Just (Right bs2)) = + This (t1 <> t2) (Just (Right (bs1 <> bs2))) + This t1 (Just (Right bs1)) <> This t2 (Just (Left as2)) = + over these (\x -> t1 <> t2 <> NonEmpty.toList x) (align as2 bs1) + This t1 (Just (Right bs1)) <> This t2 Nothing = + This (t1 <> t2) (Just (Right bs1)) + This t1 Nothing <> This t2 (Just (Left as2)) = + This (t1 <> t2) (Just (Left as2)) + This t1 Nothing <> This t2 (Just (Right bs2)) = + This (t1 <> t2) (Just (Right bs2)) + This t1 Nothing <> This t2 Nothing = + This (t1 <> t2) Nothing + +instance Semigroup (This NonEmpty a b) where + This t1 (Just (Left as1)) <> This t2 (Just (Left as2)) = + This (t1 <> t2) (Just (Left (as1 <> as2))) + This t1 (Just (Left as1)) <> This t2 (Just (Right bs2)) = + over these (\x -> t1 <> t2 <> x) (align as1 bs2) + This t1 (Just (Left as1)) <> This t2 Nothing = + This (t1 <> t2) (Just (Left as1)) + This t1 (Just (Right bs1)) <> This t2 (Just (Right bs2)) = + This (t1 <> t2) (Just (Right (bs1 <> bs2))) + This t1 (Just (Right bs1)) <> This t2 (Just (Left as2)) = + over these (\x -> t1 <> t2 <> x) (align as2 bs1) + This t1 (Just (Right bs1)) <> This t2 Nothing = + This (t1 <> t2) (Just (Right bs1)) + This t1 Nothing <> This t2 (Just (Left as2)) = + This (t1 <> t2) (Just (Left as2)) + This t1 Nothing <> This t2 (Just (Right bs2)) = + This (t1 <> t2) (Just (Right bs2)) + This t1 Nothing <> This t2 Nothing = + This (t1 <> t2) Nothing + +instance Monoid (This [] a b) where + mempty = + This mempty Nothing + +-- | +-- +-- >>> over these reverse (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("def",'y'),("abc",'x')] Nothing +-- >>> over these reverse (This [("abc", 'x'), ("def", 'y')] (Just (Left ("ghi":|["jkl"])))) +-- This [("def",'y'),("abc",'x')] Just (Left ("ghi" :| ["jkl"])) +these :: + Lens + (This f a b) + (This f' a b) + (f (a, b)) + (f' (a, b)) +these f (This t r) = + fmap (\t' -> This t' r) (f t) + +-- | +-- +-- >>> over those (fmap (bimap (fmap reverse) (fmap Data.Char.toUpper))) (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("abc",'x'),("def",'y')] Nothing +-- >>> over those (fmap (bimap (fmap reverse) (fmap Data.Char.toUpper))) (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("abc",'x'),("def",'y')] Just (Left ("cba" :| ["fed"])) +-- >>> over those (fmap (bimap (fmap reverse) (fmap Data.Char.toUpper))) (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- This [("abc",'x'),("def",'y')] Just (Right ('A' :| "BCDE")) +-- >>> Control.Lens.view those (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Nothing +-- >>> Control.Lens.view those (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Just (Left ("abc" :| ["def"])) +-- >>> Control.Lens.view those (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- Just (Right ('a' :| "bcde")) +those :: + Lens' + (This f a b) + (Maybe (Either (NonEmpty a) (NonEmpty b))) +those f (This t r) = + fmap (\r' -> This t r') (f r) + +-- | +-- +-- >>> over allThese (bimap reverse Data.Char.toUpper) (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("cba",'X'),("fed",'Y')] Nothing +-- >>> over allThese (bimap reverse Data.Char.toUpper) (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("cba",'X'),("fed",'Y')] Just (Left ("abc" :| ["def"])) +-- >>> over allThese (bimap reverse Data.Char.toUpper) (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- This [("cba",'X'),("fed",'Y')] Just (Right ('a' :| "bcde")) +-- >>> Control.Lens.preview allThese (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Just ("abc",'x') +-- >>> Control.Lens.preview allThese (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Just ("abc",'x') +-- >>> Control.Lens.preview allThese (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- Just ("abc",'x') +allThese :: + Traversable f => + Traversal' + (This f a b) + (a, b) +allThese = + these . traverse + +-- | +-- +-- >>> over allThese1 reverse (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("cba",'x'),("fed",'y')] Nothing +-- >>> over allThese1 reverse (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("cba",'x'),("fed",'y')] Just (Left ("abc" :| ["def"])) +-- >>> over allThese1 reverse (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- This [("cba",'x'),("fed",'y')] Just (Right ('a' :| "bcde")) +-- >>> Control.Lens.preview allThese1 (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Just "abc" +-- >>> Control.Lens.preview allThese1 (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Just "abc" +-- >>> Control.Lens.preview allThese1 (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- Just "abc" +allThese1 :: + Traversable f => + Traversal' + (This f a b) + a +allThese1 = + allThese . _1 + +-- | +-- +-- >>> over allThese2 Data.Char.toUpper (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("abc",'X'),("def",'Y')] Nothing +-- >>> over allThese2 Data.Char.toUpper (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("abc",'X'),("def",'Y')] Just (Left ("abc" :| ["def"])) +-- >>> over allThese2 Data.Char.toUpper (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- This [("abc",'X'),("def",'Y')] Just (Right ('a' :| "bcde")) +-- >>> Control.Lens.preview allThese2 (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Just 'x' +-- >>> Control.Lens.preview allThese2 (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Just 'x' +-- >>> Control.Lens.preview allThese2 (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- Just 'x' +allThese2 :: + Traversable f => + Traversal' + (This f a b) + b +allThese2 = + allThese . _2 + +-- | +-- +-- >>> over allThose (bimap (fmap reverse) (fmap Data.Char.toUpper)) (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("abc",'x'),("def",'y')] Nothing +-- >>> over allThose (bimap (fmap reverse) (fmap Data.Char.toUpper)) (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("abc",'x'),("def",'y')] Just (Left ("cba" :| ["fed"])) +-- >>> over allThose (bimap (fmap reverse) (fmap Data.Char.toUpper)) (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- This [("abc",'x'),("def",'y')] Just (Right ('A' :| "BCDE")) +-- >>> Control.Lens.preview allThose (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Nothing +-- >>> Control.Lens.preview allThose (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Just (Left ("abc" :| ["def"])) +-- >>> Control.Lens.preview allThose (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- Just (Right ('a' :| "bcde")) +allThose :: + Traversal' + (This f a b) + (Either (NonEmpty a) (NonEmpty b)) +allThose = + those . _Just + +-- | +-- +-- >>> over allThoseA (fmap reverse) (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("abc",'x'),("def",'y')] Nothing +-- >>> over allThoseA (fmap reverse) (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("abc",'x'),("def",'y')] Just (Left ("cba" :| ["fed"])) +-- >>> over allThoseA (fmap reverse) (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- This [("abc",'x'),("def",'y')] Just (Right ('a' :| "bcde")) +-- >>> Control.Lens.preview allThoseA (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Nothing +-- >>> Control.Lens.preview allThoseA (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Just ("abc" :| ["def"]) +-- >>> Control.Lens.preview allThoseA (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- Nothing +allThoseA :: + Traversal' + (This f a b) + (NonEmpty a) +allThoseA = + allThose . _Left + +-- | +-- +-- >>> over allThoseA' reverse (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("abc",'x'),("def",'y')] Nothing +-- >>> over allThoseA' reverse (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("abc",'x'),("def",'y')] Just (Left ("cba" :| ["fed"])) +-- >>> over allThoseA' reverse (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- This [("abc",'x'),("def",'y')] Just (Right ('a' :| "bcde")) +-- >>> Control.Lens.preview allThoseA' (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Nothing +-- >>> Control.Lens.preview allThoseA' (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Just "abc" +-- >>> Control.Lens.preview allThoseA' (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- Nothing +allThoseA' :: + Traversable f => + Traversal' + (This f a b) + a +allThoseA' = + allThoseA . traverse + +-- | +-- +-- >>> over allThoseB (fmap Data.Char.toUpper) (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("abc",'x'),("def",'y')] Nothing +-- >>> over allThoseB (fmap Data.Char.toUpper) (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("abc",'x'),("def",'y')] Just (Left ("abc" :| ["def"])) +-- >>> over allThoseB (fmap Data.Char.toUpper) (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- This [("abc",'x'),("def",'y')] Just (Right ('A' :| "BCDE")) +-- >>> Control.Lens.preview allThoseB (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Nothing +-- >>> Control.Lens.preview allThoseB (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Nothing +-- >>> Control.Lens.preview allThoseB (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- Just ('a' :| "bcde") +allThoseB :: + Traversal' + (This f a b) + (NonEmpty b) +allThoseB = + allThose . _Right + +-- | +-- +-- >>> over allThoseB' Data.Char.toUpper (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("abc",'x'),("def",'y')] Nothing +-- >>> over allThoseB' Data.Char.toUpper (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("abc",'x'),("def",'y')] Just (Left ("abc" :| ["def"])) +-- >>> over allThoseB' Data.Char.toUpper (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- This [("abc",'x'),("def",'y')] Just (Right ('A' :| "BCDE")) +-- >>> Control.Lens.preview allThoseB' (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Nothing +-- >>> Control.Lens.preview allThoseB' (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Nothing +-- >>> Control.Lens.preview allThoseB' (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- Just 'a' +allThoseB' :: + Traversable f => + Traversal' + (This f a b) + b +allThoseB' = + allThoseB . traverse + +-- | +-- +-- >>> over allTheseThoseA (fmap Data.Char.toUpper) (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("ABC",'x'),("DEF",'y')] Nothing +-- >>> over allTheseThoseA (fmap Data.Char.toUpper) (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("ABC",'x'),("DEF",'y')] Just (Left ("ABC" :| ["DEF"])) +-- >>> over allTheseThoseA (fmap Data.Char.toUpper) (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- This [("ABC",'x'),("DEF",'y')] Just (Right ('a' :| "bcde")) +-- >>> Control.Lens.preview allTheseThoseA (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Just "abc" +-- >>> Control.Lens.preview allTheseThoseA (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Just "abc" +-- >>> Control.Lens.preview allTheseThoseA (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- Just "abc" +allTheseThoseA :: + Traversable f => + Traversal' + (This f a b) + a +allTheseThoseA f (This t r) = + let th = + case r of + Nothing -> + pure Nothing + Just (Left as) -> + Just . Left <$> traverse f as + Just (Right bs) -> + pure (Just (Right bs)) + in This <$> + traverse (\(a, b) -> (, b) <$> f a) t <*> th + +-- | +-- +-- >>> over allTheseThoseB Data.Char.toUpper (This [("abc", 'x'), ("def", 'y')] Nothing) +-- This [("abc",'X'),("def",'Y')] Nothing +-- >>> over allTheseThoseB Data.Char.toUpper (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("abc",'X'),("def",'Y')] Just (Left ("abc" :| ["def"])) +-- >>> over allTheseThoseB Data.Char.toUpper (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- This [("abc",'X'),("def",'Y')] Just (Right ('A' :| "BCDE")) +-- >>> Control.Lens.preview allTheseThoseB (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Just 'x' +-- >>> Control.Lens.preview allTheseThoseB (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Just 'x' +-- >>> Control.Lens.preview allTheseThoseB (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) +-- Just 'x' +allTheseThoseB :: + Traversable f => + Traversal' + (This f a b) + b +allTheseThoseB f (This t r) = + let th = + case r of + Nothing -> + pure Nothing + Just (Left as) -> + pure (Just (Left as)) + Just (Right bs) -> + Just . Right <$> traverse f bs + in This <$> + traverse (\(a, b) -> (a ,) <$> f b) t <*> th