diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,4 +1,4 @@ -Copyright (c) 2022 Tony Morris +Copyright (c) 2022-2025 Tony Morris All rights reserved. diff --git a/alignment.cabal b/alignment.cabal --- a/alignment.cabal +++ b/alignment.cabal @@ -1,28 +1,28 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: alignment -version: 0.1.0.4 +version: 0.1.0.5 synopsis: Zip-alignment description: - <> - . Zipping with alignment + . + <> license: BSD3 license-file: LICENCE author: Tony Morris maintainer: Tony Morris -copyright: Copyright (C) 2022 Tony Morris +copyright: Copyright (C) 2022-2025 Tony Morris category: Data build-type: Simple extra-source-files: changelog.md cabal-version: >=1.10 -homepage: https://gitlab.com/system-f/alignment -bug-reports: https://gitlab.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 +homepage: https://gitlab.com/system-f/alignment/code +bug-reports: https://gitlab.com/system-f/alignment/code/issues +tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1, GHC == 9.4.8 source-repository head type: git - location: git@gitlab.com:system-f/alignment.git + location: git@gitlab.com:system-f/code/alignment.git library exposed-modules: Data.Alignment diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +0.1.0.5 + +* Remove optics `allThoseA'` and `allThoseB'` +* Add optics `allTheseThoseA1` and `allTheseThoseB1` +* Instances for `Bifoldable1` and `Bitraversable1` +* Minor code improvements + 0.1.0.4 * Bump versions diff --git a/src/Data/Alignment.hs b/src/Data/Alignment.hs --- a/src/Data/Alignment.hs +++ b/src/Data/Alignment.hs @@ -2,6 +2,8 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use fmap" #-} module Data.Alignment( -- * Types @@ -17,18 +19,18 @@ , allThese2 , allThose , allThoseA -, allThoseA' , allThoseAOr , allThoseB -, allThoseB' , allThoseBOr , allTheseThoseA +, allTheseThoseA1 , allTheseThoseB +, allTheseThoseB1 ) where import Control.Applicative ( Applicative(liftA2, pure, (<*>)), (<$>), ZipList(ZipList) ) -import Control.Category ( Category((.)) ) +import Control.Category ( Category((.), id) ) import Control.Lens ( Identity(Identity), _Just, @@ -39,14 +41,16 @@ Field2(_2), Lens, Lens', - Traversal' ) + Traversal, + Traversal', + Traversal1 ) 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.Either ( Either(..), either ) import Data.Eq ( Eq((==)) ) import Data.Foldable ( Foldable(foldMap) ) import Data.Functor ( Functor(fmap), (<$) ) @@ -60,10 +64,14 @@ Ord1(..), Show1(..) ) import qualified Data.List.NonEmpty as NonEmpty(cons, toList) -import Data.Maybe ( Maybe(..) ) +import Data.Maybe ( Maybe(..), maybe ) import Data.Monoid ( (<>), Monoid(mempty) ) import Data.Ord ( Ord(compare) ) import Data.Semigroup ( Semigroup ) +import Data.Semigroup.Bifoldable ( Bifoldable1(bifoldMap1) ) +import Data.Semigroup.Bitraversable ( Bitraversable1(bitraverse1) ) +import Data.Semigroup.Foldable ( Foldable1(foldMap1) ) +import Data.Semigroup.Traversable ( Traversable1(traverse1) ) import Data.Traversable ( Traversable(traverse) ) import GHC.Show ( Show(showsPrec) ) @@ -109,13 +117,28 @@ bifoldMap f g (This t r) = foldMap (bifoldMap f g) t <> foldMap (bifoldMap (foldMap f) (foldMap g)) r +instance Foldable1 f => Bifoldable1 (This f) where + bifoldMap1 f g (This t r) = + let x = + foldMap1 (bifoldMap1 f g) t + in maybe x (either (foldMap1 f) (foldMap1 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 Traversable1 f => Bitraversable1 (This f) where + bitraverse1 f g (This t r) = + let x = + This <$> traverse1 (bitraverse1 f g) t + in maybe + ((\k -> k Nothing) <$> x) + (\q -> x <.> either (fmap (Just . Left) . traverse1 f) (fmap (Just . Right) . traverse1 g) q) + r + instance Functor f => Functor (This f a) where fmap = - bimap (\x -> x) + bimap id -- | -- @@ -169,7 +192,7 @@ -> f b -> This f a b align = - alignWith (\x -> x) (\x -> x) (\x -> x) + alignWith id id id alignWith :: ((a, b) -> (c, d)) -> (a -> c) @@ -352,7 +375,7 @@ (f (a, b)) (f' (a, b)) these f (This t r) = - fmap (\t' -> This t' r) (f t) + fmap (`This` r) (f t) -- | -- @@ -373,7 +396,7 @@ (This f a b) (Maybe (Either (NonEmpty a) (NonEmpty b))) those f (This t r) = - fmap (\r' -> This t r') (f r) + fmap (This t) (f r) -- | -- @@ -485,40 +508,18 @@ -- | -- --- >>> over allThoseA' reverse (This [("abc", 'x'), ("def", 'y')] Nothing) +-- >>> over allThoseAOr 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")))) +-- >>> over allThoseAOr reverse (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- This [("abc",'x'),("def",'y')] Just (Left ("def" :| ["abc"])) +-- >>> over allThoseAOr 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 allThoseBOr reverse (This [("abc", 'x'), ("def", 'y')] Nothing) --- This [("abc",'x'),("def",'y')] Nothing --- >>> over allThoseBOr reverse (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) --- This [("abc",'x'),("def",'y')] Just (Left ("abc" :| ["def"])) --- >>> over allThoseBOr reverse (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) --- This [("abc",'x'),("def",'y')] Just (Right ('e' :| "dcba")) --- >>> Control.Lens.preview allThoseBOr (This [("abc", 'x'), ("def", 'y')] Nothing) --- Just "" --- >>> Control.Lens.preview allThoseBOr (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- >>> Control.Lens.preview allThoseAOr (This [("abc", 'x'), ("def", 'y')] Nothing) +-- Just [] +-- >>> Control.Lens.preview allThoseAOr (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) +-- Just ["abc","def"] +-- >>> Control.Lens.preview allThoseAOr (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) -- Nothing --- >>> Control.Lens.preview allThoseBOr (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) --- Just "abcde" allThoseAOr :: Traversal' (This f a b) @@ -530,7 +531,7 @@ allThoseAOr f (This t (Just (Left a))) = let lst [] = Nothing lst (x:y) = Just (x:|y) - in This t <$> (fmap Left . lst <$> f (NonEmpty.toList a)) + in This t . fmap Left . lst <$> f (NonEmpty.toList a) -- | -- @@ -555,28 +556,6 @@ -- | -- --- >>> 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 allThoseBOr reverse (This [("abc", 'x'), ("def", 'y')] Nothing) -- This [("abc",'x'),("def",'y')] Nothing -- >>> over allThoseBOr reverse (This [("abc", 'x'), ("def", 'y')] (Just (Left ("abc":|["def"])))) @@ -598,7 +577,7 @@ allThoseBOr f (This t (Just (Right b))) = let lst [] = Nothing lst (x:y) = Just (x:|y) - in This t <$> (fmap Right . lst <$> f (NonEmpty.toList b)) + in This t . fmap Right . lst <$> f (NonEmpty.toList b) allThoseBOr _ th@(This _ (Just (Left _))) = pure th @@ -618,9 +597,11 @@ -- Just "abc" allTheseThoseA :: Traversable f => - Traversal' + Traversal (This f a b) + (This f a' b) a + a' allTheseThoseA f (This t r) = let th = case r of @@ -633,6 +614,23 @@ in This <$> traverse (\(a, b) -> (, b) <$> f a) t <*> th +allTheseThoseA1 :: + Traversable1 f => + Traversal1 + (This f a b) + (This f a' b) + a + a' +allTheseThoseA1 f (This t r) = + let x = This <$> traverse1 (\(a, b) -> (, b) <$> f a) t + in maybe + ((\k -> k Nothing) <$> x) + ( + either + ((\p -> (\k -> k . Just . Left) <$> x <.> p) . traverse1 f) + (\z -> (\k -> k (Just (Right z))) <$> x)) + r + -- | -- -- >>> over allTheseThoseB Data.Char.toUpper (This [("abc", 'x'), ("def", 'y')] Nothing) @@ -649,9 +647,11 @@ -- Just 'x' allTheseThoseB :: Traversable f => - Traversal' + Traversal (This f a b) + (This f a b') b + b' allTheseThoseB f (This t r) = let th = case r of @@ -663,3 +663,19 @@ Just . Right <$> traverse f bs in This <$> traverse (\(a, b) -> (a ,) <$> f b) t <*> th + +allTheseThoseB1 :: + Traversable1 f => + Traversal1 + (This f a b) + (This f a b') + b + b' +allTheseThoseB1 f (This t r) = + let x = This <$> traverse1 (\(a, b) -> (a ,) <$> f b) t + in maybe + ((\k -> k Nothing) <$> x) + (either + (\z -> (\k -> k (Just (Left z))) <$> x) + ((\p -> (\k -> k . Just . Right) <$> x <.> p) . traverse1 f)) + r