diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,4 +1,4 @@ -Copyright (c) 2022-2025 Tony Morris +Copyright (c) 2022-2026 Tony Morris All rights reserved. diff --git a/alignment.cabal b/alignment.cabal --- a/alignment.cabal +++ b/alignment.cabal @@ -1,38 +1,112 @@ --- documentation, see http://haskell.org/cabal/users-guide/ - -name: alignment -version: 0.1.0.6 -synopsis: Zip-alignment +cabal-version: 2.4 +name: alignment +version: 0.2.0.0 +synopsis: Principled functor alignment with leftovers description: - Zipping with alignment - . - <> -license: BSD3 -license-file: LICENCE -author: Tony Morris -maintainer: 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/code/alignment -bug-reports: https://gitlab.com/system-f/code/alignment/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 + A principled approach to zipping functors that preserves both matched + pairs and leftovers. + . + The @alignment@ library provides type classes and operations for aligning + two functors into a structure (@This@) that captures: + . + * Matched pairs where both functors have elements at the same position + . + * Leftovers when one functor is longer than the other + . + This is more principled than traditional @zip@ which silently discards + extra elements. The library uses functional dependencies (@f -> g@) to + relate the \"paired\" functor to the \"leftover\" functor, ensuring type safety. + . + Key features: + . + * @Semialign@, @Align@, and @Unalign@ type classes with comprehensive laws + . + * @Unalign@ provides inverse operation to recover original functors + . + * Full lens\/optics integration + . + * Instances for common functors: @[]@, @Maybe@, @NonEmpty@, @Vector@, + @Map@, @Seq@, and more + . + * Testable law-checking functions for property-based testing + . + * Complete documentation with 211 doctests + . + Example: + . + > import Data.Alignment + > + > -- Align two lists of different lengths + > align [1,2,3] [10,20] :: This [] NonEmpty Int Int + > -- Result: This [(1,10),(2,20)] (Just (Left (3 :| []))) + . + <> +license: BSD-3-Clause +license-file: LICENCE +author: Tony Morris +maintainer: Tony Morris +copyright: Copyright (C) 2022-2026 Tony Morris +category: Data +build-type: Simple +extra-doc-files: changelog.md +homepage: https://gitlab.com/system-f/code/alignment +bug-reports: https://gitlab.com/system-f/code/alignment/issues +tested-with: GHC == 9.6.7 -source-repository head - type: git - location: git@gitlab.com:system-f/code/alignment.git +source-repository head + type: git + location: git@gitlab.com:system-f/code/alignment.git library - exposed-modules: Data.Alignment + exposed-modules: Data.Alignment - build-depends: base >= 4.8 && < 6 - , bifunctors >= 5 && < 6 - , lens >= 4.15 && < 6 - , semigroupoids >= 5.1 && < 7 - , assoc >= 1 && < 2 + build-depends: base >= 4.18 && < 6 + , bifunctors >= 5 && < 6 + , deepseq >= 1.4 && < 1.6 + , lens >= 4 && < 6 + , semigroupoids >= 6 && < 7 + , assoc >= 1 && < 2 + , containers >= 0.6 && < 0.8 + , vector >= 0.12 && < 0.14 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall + hs-source-dirs: src + + default-language: Haskell2010 + + ghc-options: -Wall + + if flag(dev) + ghc-options: -Werror + +flag dev + description: Enable -Werror for development + manual: True + default: False + +test-suite doctest + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.8 && < 6 + , process >= 1 && < 2 + build-tool-depends: doctest:doctest >= 0.22 + default-language: Haskell2010 + ghc-options: -Wall + -Wno-inline-rule-shadowing + +benchmark alignment-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: base >= 4.8 && < 6 + , alignment + , criterion >= 1.5 && < 1.7 + , deepseq >= 1.4 && < 1.6 + , vector >= 0.12 && < 0.14 + , containers >= 0.6 && < 0.8 + default-language: Haskell2010 + ghc-options: -Wall + -O2 + -threaded + -rtsopts + -with-rtsopts=-N diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{- HLINT ignore "Avoid NonEmpty.unzip" -} + +module Main where + +import Criterion.Main +import Data.Alignment +import qualified Data.Vector as V +import Data.List.NonEmpty (NonEmpty(..)) +import Control.DeepSeq (NFData, force) +import Data.Bifunctor (bimap) + +-- Force evaluation to prevent benchmark cheating +forceThis :: (NFData (f (a, b)), NFData (g a), NFData (g b)) => This f g a b -> This f g a b +forceThis (This pairs leftover) = This (force pairs) (force leftover) + +-- Benchmark groups +main :: IO () +main = defaultMain + [ alignBenchmarks + , unalignBenchmarks + , roundtripBenchmarks + , transformationBenchmarks + , fusionBenchmarks + ] + +-- | Benchmark align vs zip for different sizes and structures +alignBenchmarks :: Benchmark +alignBenchmarks = bgroup "align vs zip" + [ bgroup "lists" + [ bgroup "equal length" + [ bench "zip 100" $ nf (uncurry zip) (listPair 100) + , bench "align 100" $ nf (uncurry alignList) (listPair 100) + , bench "zip 1000" $ nf (uncurry zip) (listPair 1000) + , bench "align 1000" $ nf (uncurry alignList) (listPair 1000) + , bench "zip 10000" $ nf (uncurry zip) (listPair 10000) + , bench "align 10000" $ nf (uncurry alignList) (listPair 10000) + ] + , bgroup "unequal length" + [ bench "zip 100/50" $ nf (\(xs, ys) -> zip xs (take 50 ys)) (listPair 100) + , bench "align 100/50" $ nf (\(xs, ys) -> alignList xs (take 50 ys)) (listPair 100) + , bench "zip 1000/500" $ nf (\(xs, ys) -> zip xs (take 500 ys)) (listPair 1000) + , bench "align 1000/500" $ nf (\(xs, ys) -> alignList xs (take 500 ys)) (listPair 1000) + ] + ] + , bgroup "vectors" + [ bgroup "equal length" + [ bench "zip 100" $ nf (uncurry V.zip) (vectorPair 100) + , bench "align 100" $ nf (uncurry alignVec) (vectorPair 100) + , bench "zip 1000" $ nf (uncurry V.zip) (vectorPair 1000) + , bench "align 1000" $ nf (uncurry alignVec) (vectorPair 1000) + , bench "zip 10000" $ nf (uncurry V.zip) (vectorPair 10000) + , bench "align 10000" $ nf (uncurry alignVec) (vectorPair 10000) + ] + ] + , bgroup "NonEmpty" + [ bench "align 100" $ nf (uncurry alignNE) (nePair 100) + , bench "align 1000" $ nf (uncurry alignNE) (nePair 1000) + ] + ] + where + alignList :: [Int] -> [Int] -> This [] NonEmpty Int Int + alignList = align + alignVec :: V.Vector Int -> V.Vector Int -> This V.Vector NonEmpty Int Int + alignVec = align + alignNE :: NonEmpty Int -> NonEmpty Int -> This NonEmpty NonEmpty Int Int + alignNE = align + +-- | Benchmark unalign vs unzip +unalignBenchmarks :: Benchmark +unalignBenchmarks = bgroup "unalign vs unzip" + [ bgroup "lists" + [ bench "unzip 100" $ nf unzip (pairList 100) + , bench "unalign 100" $ nf unalignList (alignedList 100) + , bench "unzip 1000" $ nf unzip (pairList 1000) + , bench "unalign 1000" $ nf unalignList (alignedList 1000) + , bench "unzip 10000" $ nf unzip (pairList 10000) + , bench "unalign 10000" $ nf unalignList (alignedList 10000) + ] + , bgroup "vectors" + [ bench "unzip 100" $ nf V.unzip (V.fromList $ pairList 100) + , bench "unalign 100" $ nf unalignVec (alignedVector 100) + , bench "unzip 1000" $ nf V.unzip (V.fromList $ pairList 1000) + , bench "unalign 1000" $ nf unalignVec (alignedVector 1000) + , bench "unzip 10000" $ nf V.unzip (V.fromList $ pairList 10000) + , bench "unalign 10000" $ nf unalignVec (alignedVector 10000) + ] + ] + where + unalignList :: This [] NonEmpty Int Int -> ([Int], [Int]) + unalignList = unalign + unalignVec :: This V.Vector NonEmpty Int Int -> (V.Vector Int, V.Vector Int) + unalignVec = unalign + +-- | Benchmark roundtrip: align then unalign +roundtripBenchmarks :: Benchmark +roundtripBenchmarks = bgroup "roundtrip" + [ bgroup "lists" + [ bench "zip/unzip 100" $ nf (\(xs, ys) -> unzip (zip xs ys)) (listPair 100) + , bench "align/unalign 100" $ nf (\(xs, ys) -> unalign (align xs ys :: This [] NonEmpty Int Int)) (listPair 100) + , bench "zip/unzip 1000" $ nf (\(xs, ys) -> unzip (zip xs ys)) (listPair 1000) + , bench "align/unalign 1000" $ nf (\(xs, ys) -> unalign (align xs ys :: This [] NonEmpty Int Int)) (listPair 1000) + ] + , bgroup "vectors" + [ bench "zip/unzip 100" $ nf (\(xs, ys) -> V.unzip (V.zip xs ys)) (vectorPair 100) + , bench "align/unalign 100" $ nf (\(xs, ys) -> unalign (align xs ys :: This V.Vector NonEmpty Int Int)) (vectorPair 100) + , bench "zip/unzip 1000" $ nf (\(xs, ys) -> V.unzip (V.zip xs ys)) (vectorPair 1000) + , bench "align/unalign 1000" $ nf (\(xs, ys) -> unalign (align xs ys :: This V.Vector NonEmpty Int Int)) (vectorPair 1000) + ] + ] + +-- | Benchmark transformation operations (map during align/unalign) +transformationBenchmarks :: Benchmark +transformationBenchmarks = bgroup "with transformation" + [ bgroup "lists" + [ bench "map/zip/map 1000" $ nf (\(xs, ys) -> let zs = zip xs ys in (map ((+1) . fst) zs, map ((*2) . snd) zs)) (listPair 1000) + , bench "alignWith 1000" $ nf (\(xs, ys) -> alignWith id (+1) (*2) xs ys :: This [] NonEmpty Int Int) (listPair 1000) + , bench "unzip/map/map 1000" $ nf (bimap (map (+1)) (map (*2)) . unzip) (pairList 1000) + , bench "unalignWith 1000" $ nf (unalignWith (+1) (*2)) (alignedList 1000) + ] + ] + +-- | Benchmark fusion effectiveness +fusionBenchmarks :: Benchmark +fusionBenchmarks = bgroup "fusion" + [ bgroup "composition" + -- These benchmarks intentionally compare unoptimized vs optimized forms + {- HLINT ignore "Functor law" -} + {- HLINT ignore "Redundant bimap" -} + [ bench "fmap . fmap 1000" $ nf (fmap (*2) . fmap (+1)) (alignedList 1000) + , bench "fmap composed 1000" $ nf (fmap ((*2) . (+1))) (alignedList 1000) + , bench "bimap . bimap 1000" $ nf (bimap (*2) (*3) . bimap (+1) (+2)) (alignedList 1000) + , bench "bimap composed 1000" $ nf (bimap ((*2) . (+1)) ((*3) . (+2))) (alignedList 1000) + ] + , bgroup "roundtrip elimination" + [ bench "align/unalign 1000" $ nf (\(xs, ys) -> unalign (align xs ys :: This [] NonEmpty Int Int)) (listPair 1000) + , bench "direct 1000" $ nf id (listPair 1000) + , bench "alignWith/unalignWith 1000" $ nf (\(xs, ys) -> unalignWith (+1) (*2) (align xs ys :: This [] NonEmpty Int Int)) (listPair 1000) + , bench "map/map 1000" $ nf (bimap (map (+1)) (map (*2))) (listPair 1000) + ] + ] + +-- Test data generators +listPair :: Int -> ([Int], [Int]) +listPair n = ([1..n], [1..n]) + +vectorPair :: Int -> (V.Vector Int, V.Vector Int) +vectorPair n = (V.enumFromN 1 n, V.enumFromN 1 n) + +nePair :: Int -> (NonEmpty Int, NonEmpty Int) +nePair n = (1 :| [2..n], 1 :| [2..n]) + +pairList :: Int -> [(Int, Int)] +pairList n = [(i, i) | i <- [1..n]] + +alignedList :: Int -> This [] NonEmpty Int Int +alignedList n = align [1..n] [1..n] + +alignedVector :: Int -> This V.Vector NonEmpty Int Int +alignedVector n = align (V.enumFromN 1 n) (V.enumFromN 1 n) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,34 @@ +0.2.0.0 (2026-05-19) + +* Add `Unalign` type class for recovering original functors from alignment +* Add `aligned` isomorphism to Unalign, witnessing that alignment is lossless +* Add `unaligned` isomorphism, the inverse of `aligned` +* Add `unalignWith` method to Unalign, the dual of `alignWith` for transformation during unalignment +* Add `Unalign` instances for Identity, [], Maybe, NonEmpty, ZipList, Seq, Vector +* Add `NFData` instance for This (enables criterion benchmarking) +* Note: Map and IntMap deliberately excluded from Unalign to maintain law compliance +* Add comprehensive law documentation for Semialign, Align, and Unalign type classes +* Add testable law-checking functions: `semialignNaturality`, `semialignSymmetry`, + `semialignCoherence`, `semialignWithLaw`, `alignRightIdentity`, `alignLeftIdentity`, + `alignEmpty`, `unalignRoundtrip`, `unalignNaturality` +* Add 12 RULES pragmas for fusion optimization: + - Semialign fusion: `semialign/naturality`, `alignWith/bimap`, `align/swap/symmetry`, `fmap/as/bimap` + - Unalign fusion: `unalign/align/roundtrip`, `unalign/bimap/naturality`, `unalignWith/align` + - Functor/Bifunctor composition: `fmap/fmap/This`, `bimap/bimap/This` + - Swap optimization: `swap/swap/This`, `swap/bimap/This`, `bimap/swap/This` +* Add 56 INLINE/INLINABLE pragmas for comprehensive optimization: + - All type class method defaults marked INLINE + - All Semialign instances marked INLINE or INLINABLE + - All Align nil methods marked INLINE + - All Unalign instances marked INLINE or INLINABLE + - All lens/traversal/fold functions marked INLINE or INLINABLE + - Strategic use of INLINE for small wrappers, INLINABLE for recursive/larger functions +* Add FUSION.md documenting fusion rules and performance characteristics +* Add comprehensive criterion benchmark suite comparing to zip/unzip +* Reorganize all Semialign instances to be consecutive for better code navigation +* Expand README with examples, comparisons, and usage guide +* Improve cabal file description + 0.1.0.6 * Fix URLs in cabal file diff --git a/src/Data/Alignment.hs b/src/Data/Alignment.hs --- a/src/Data/Alignment.hs +++ b/src/Data/Alignment.hs @@ -1,681 +1,1619 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Use fmap" #-} - -module Data.Alignment( --- * Types - This(..) --- * Type-classes -, Semialign(..) -, Align(..) --- * Optics -, these -, those -, allThese -, allThese1 -, allThese2 -, allThose -, allThoseA -, allThoseAOr -, allThoseB -, allThoseBOr -, allTheseThoseA -, allTheseThoseA1 -, allTheseThoseB -, allTheseThoseB1 -) where - -import Control.Applicative - ( Applicative(liftA2, pure, (<*>)), (<$>), ZipList(ZipList) ) -import Control.Category ( Category((.), id) ) -import Control.Lens - ( Identity(Identity), - _Just, - _Left, - _Right, - over, - Field1(_1), - Field2(_2), - Lens, - Lens', - 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(..), either ) -import Data.Eq ( Eq((==)) ) -import Data.Foldable ( Foldable(foldMap) ) -import Data.Functor ( Functor(fmap), (<$) ) -import Data.Functor.Apply ( Apply((<.>), liftF2) ) -import Data.Functor.Classes - ( compare1, - eq1, - showsPrec1, - showsUnaryWith, - Eq1(..), - Ord1(..), - Show1(..) ) -import qualified Data.List.NonEmpty as NonEmpty(cons, toList) -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) ) - --- $setup --- >>> import Prelude - -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 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 id - --- | --- --- >>> 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 = - alignWith id id id - alignWith :: - ((a, b) -> (c, d)) - -> (a -> c) - -> (b -> d) - -> f a - -> f b - -> This f c d - alignWith f g h t1 t2 = - case align t1 t2 of - This t r -> - This (fmap f t) (fmap (bimap (fmap g) (fmap h)) r) - {-# MINIMAL align | alignWith #-} - alignWith' :: - (a -> c) - -> (b -> d) - -> f a - -> f b - -> This f c d - alignWith' f g = - alignWith (bimap f g) f g - --- | --- --- >>> 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 (`This` 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 (This t) (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 allThoseAOr reverse (This [("abc", 'x'), ("def", 'y')] Nothing) --- This [("abc",'x'),("def",'y')] Nothing --- >>> 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 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 -allThoseAOr :: - Traversal' - (This f a b) - [a] -allThoseAOr f (This t Nothing) = - This t <$> (Nothing <$ f []) -allThoseAOr _ th@(This _ (Just (Right _))) = - pure th -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) - --- | --- --- >>> 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 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"])))) --- Nothing --- >>> Control.Lens.preview allThoseBOr (This [("abc", 'x'), ("def", 'y')] (Just (Right ('a':|"bcde")))) --- Just "abcde" -allThoseBOr :: - Traversal' - (This f a b) - [b] -allThoseBOr f (This t Nothing) = - This t <$> (Nothing <$ f []) -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) -allThoseBOr _ th@(This _ (Just (Left _))) = - pure th - --- | --- --- >>> 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) - (This f a' b) - a - 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 - -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) --- 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) - (This f a b') - 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 - -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 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} +-- Suppress inline-rule-shadowing warnings for fusion RULES. +-- The warnings are benign: our RULES use phase [2] to avoid conflicts, +-- and they work correctly in optimized code where fusion matters. +{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} + +module Data.Alignment + ( -- * Data type + This (..), + This', + + -- * Type classes + GetThis (..), + HasThis (..), + ReviewThis (..), + AsThis (..), + Semialign (..), + Align (..), + Unalign (..), + + -- * Lenses + these, + those, + thoseLeft, + thoseRight, + + -- * Traversals + traverseA, + traverseB, + traverseA1, + traverseB1, + + -- * Folds + foldA, + foldB, + foldA1, + foldB1, + + -- * Isomorphisms + unaligned, + + -- * Law-checking functions + semialignNaturality, + semialignSymmetry, + semialignCoherence, + semialignWithLaw, + alignRightIdentity, + alignLeftIdentity, + alignEmpty, + unalignRoundtrip, + unalignNaturality, + ) +where + +import Control.Applicative + ( Applicative (pure, (<*>)), + ZipList (ZipList, getZipList), + (<$>), + (<*), + ) +import Control.Category (Category (id, (.))) +import Control.DeepSeq (NFData (rnf)) +import Control.Lens + ( Fold, + Fold1, + Getter, + Identity (Identity), + Iso', + Lens, + Lens', + Prism', + Review, + Traversal, + Traversal', + Traversal1, + iso, + lens, + over, + prism', + review, + unto, + view, + _Left, + _Right, + ) +import Data.Bifoldable (Bifoldable (bifoldMap)) +import Data.Bifunctor (Bifunctor (bimap), second) +import Data.Bifunctor.Swap (Swap (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.Bool (Bool (False, True), otherwise, (&&)) +import Data.Either (Either (..), either) +import Data.Eq (Eq ((==))) +import Data.Foldable (Foldable (foldMap), traverse_) +import Data.Function (const, flip, ($)) +import Data.Tuple (uncurry) +import Data.Functor (Functor (fmap), ($>), (<$)) +import Data.Functor.Apply (Apply ((<.>)), (.>)) +import Data.Functor.Classes + ( Eq1 (..), + Eq2 (..), + Ord1 (..), + Ord2 (..), + Show1 (..), + Show2 (..), + liftShowList2, + ) +import Data.Functor.Const (Const (Const)) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.List ((++)) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty (cons) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..)) +import Data.Monoid (Monoid (mempty), (<>)) +import Data.Ord (Ord (compare, min), (>)) +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.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Traversable (Traversable (traverse)) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import GHC.Generics (Generic, Generic1) +import GHC.Show (Show (showsPrec)) +import Text.Show (showList, showParen, showString) + +-- $setup +-- >>> import Prelude +-- >>> import Data.List.NonEmpty (NonEmpty(..)) +-- >>> import qualified Data.Sequence as Seq +-- >>> import qualified Data.Vector as Vector +-- >>> import qualified Data.Map as Map +-- >>> import qualified Data.IntMap as IntMap +-- >>> import Data.Functor.Const (Const(..)) + +-- | Alignment result type combining matched pairs with leftovers +-- +-- >>> This [(1,2)] Nothing :: This [] NonEmpty Int Int +-- This [(1,2)] Nothing +-- +-- >>> This [(1,2)] (Just (Left (3 :| []))) :: This [] NonEmpty Int Int +-- This [(1,2)] (Just (Left (3 :| []))) +data This f g a b + = This + (f (a, b)) + (Maybe (Either (g a) (g b))) + deriving (Generic, Generic1) + +-- | Type alias for This when both functor parameters are the same +-- +-- This simplifies the type signature when aligning structures where +-- leftovers on either side use the same container type. +-- +-- >>> align (1 :| [2]) (3 :| [4,5]) :: This' NonEmpty Int Int +-- This ((1,3) :| [(2,4)]) (Just (Right (5 :| []))) +-- >>> align (Identity 1) (Identity 2) :: This' Identity Int Int +-- This (Identity (1,2)) Nothing +type This' f a b = This f f a b + +-- | GetThis type class - provides a Getter to view a value as This +-- +-- >>> import Control.Lens (view) +-- >>> view getThis (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- This [(1,2)] Nothing +class GetThis s f g a b | s -> f g a b where + getThis :: + Getter s (This f g a b) + +instance GetThis (This f g a b) f g a b where + getThis = + id + {-# INLINE getThis #-} + +-- | HasThis type class - provides a Lens for This +-- +-- >>> import Control.Lens (set) +-- >>> set this' (This [(3,4)] Nothing) (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- This [(3,4)] Nothing +class (GetThis s f g a b) => HasThis s f g a b | s -> f g a b where + {-# MINIMAL setThis #-} + setThis :: + This f g a b -> s -> s + this' :: + Lens' s (This f g a b) + this' = + lens (view getThis) (flip setThis) + {-# INLINE this' #-} + +instance HasThis (This f g a b) f g a b where + setThis = + const + {-# INLINE setThis #-} + +-- | ReviewThis type class - provides a Review to construct a value from This +-- +-- >>> review reviewThis (This [(1,2)] Nothing) :: This [] NonEmpty Int Int +-- This [(1,2)] Nothing +class ReviewThis s f g a b | s -> f g a b where + reviewThis :: + Review s (This f g a b) + +instance ReviewThis (This f g a b) f g a b where + reviewThis = + unto id + {-# INLINE reviewThis #-} + +-- | AsThis type class - provides a Prism for This +-- +-- >>> matchThis (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- Just (This [(1,2)] Nothing) +-- >>> import Control.Lens (preview) +-- >>> preview _This (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- Just (This [(1,2)] Nothing) +class (ReviewThis s f g a b) => AsThis s f g a b | s -> f g a b where + {-# MINIMAL matchThis #-} + matchThis :: + s -> Maybe (This f g a b) + _This :: + Prism' s (This f g a b) + _This = + prism' (review reviewThis) matchThis + {-# INLINE _This #-} + +instance AsThis (This f g a b) f g a b where + matchThis = + Just + {-# INLINE matchThis #-} + +-- | Eq instance for This when all type parameters are concrete types with Eq +-- +-- >>> (This [(1,2)] Nothing :: This [] NonEmpty Int Int) == This [(1,2)] Nothing +-- True +-- >>> (This [(1,2)] Nothing :: This [] NonEmpty Int Int) == This [(1,3)] Nothing +-- False +-- >>> (This [(1,2)] (Just (Left (3 :| []))) :: This [] NonEmpty Int Int) == This [(1,2)] (Just (Left (3 :| []))) +-- True +instance (Eq1 f, Eq1 g, Eq a, Eq b) => Eq (This f g a b) where + This t1 r1 == This t2 r2 = + liftEq (==) t1 t2 && liftEq (liftEq2 (liftEq (==)) (liftEq (==))) r1 r2 + +-- | Eq1 instance - makes the last type parameter (b) polymorphic +-- +-- >>> liftEq (==) (This [(1,2)] Nothing) (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- True +-- >>> liftEq (==) (This [(1,2)] Nothing) (This [(1,3)] Nothing :: This [] NonEmpty Int Int) +-- False +instance (Eq1 f, Eq1 g, Eq a) => Eq1 (This f g a) where + liftEq eqB (This t1 r1) (This t2 r2) = + liftEq (liftEq2 (==) eqB) t1 t2 && liftEq (liftEq2 (liftEq (==)) (liftEq eqB)) r1 r2 + +-- | Eq2 instance - makes both type parameters (a, b) polymorphic +-- +-- >>> liftEq2 (==) (==) (This [(1,2)] Nothing) (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- True +-- >>> liftEq2 (==) (==) (This [(1,2)] Nothing) (This [(2,2)] Nothing :: This [] NonEmpty Int Int) +-- False +instance (Eq1 f, Eq1 g) => Eq2 (This f g) where + liftEq2 eqA eqB (This t1 r1) (This t2 r2) = + liftEq (liftEq2 eqA eqB) t1 t2 && liftEq (liftEq2 (liftEq eqA) (liftEq eqB)) r1 r2 + +-- | Ord instance for This when all type parameters are concrete types with Ord +-- +-- >>> compare (This [(1,2)] Nothing) (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- EQ +-- >>> compare (This [(1,2)] Nothing) (This [(1,3)] Nothing :: This [] NonEmpty Int Int) +-- LT +-- >>> compare (This [(2,2)] Nothing) (This [(1,3)] Nothing :: This [] NonEmpty Int Int) +-- GT +instance (Ord1 f, Ord1 g, Ord a, Ord b) => Ord (This f g a b) where + compare (This t1 r1) (This t2 r2) = + liftCompare compare t1 t2 <> liftCompare (liftCompare2 (liftCompare compare) (liftCompare compare)) r1 r2 + +-- | Ord1 instance - makes the last type parameter (b) polymorphic +-- +-- >>> liftCompare compare (This [(1,2)] Nothing) (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- EQ +-- >>> liftCompare compare (This [(1,2)] Nothing) (This [(1,3)] Nothing :: This [] NonEmpty Int Int) +-- LT +instance (Ord1 f, Ord1 g, Ord a) => Ord1 (This f g a) where + liftCompare cmpB (This t1 r1) (This t2 r2) = + liftCompare (liftCompare2 compare cmpB) t1 t2 <> liftCompare (liftCompare2 (liftCompare compare) (liftCompare cmpB)) r1 r2 + +-- | Ord2 instance - makes both type parameters (a, b) polymorphic +-- +-- >>> liftCompare2 compare compare (This [(1,2)] Nothing) (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- EQ +-- >>> liftCompare2 compare compare (This [(1,2)] Nothing) (This [(2,2)] Nothing :: This [] NonEmpty Int Int) +-- LT +instance (Ord1 f, Ord1 g) => Ord2 (This f g) where + liftCompare2 cmpA cmpB (This t1 r1) (This t2 r2) = + liftCompare (liftCompare2 cmpA cmpB) t1 t2 <> liftCompare (liftCompare2 (liftCompare cmpA) (liftCompare cmpB)) r1 r2 + +-- | Show instance for This when all type parameters are concrete types with Show +-- +-- >>> This [(1,2)] Nothing :: This [] NonEmpty Int Int +-- This [(1,2)] Nothing +-- >>> This [(1,2)] (Just (Left (3 :| []))) :: This [] NonEmpty Int Int +-- This [(1,2)] (Just (Left (3 :| []))) +instance (Show1 f, Show1 g, Show a, Show b) => Show (This f g a b) where + showsPrec d (This t r) = + showParen (d > 10) $ + showString "This " + . showsPrec 11 t + . showString " " + . showsPrec 11 r + +-- | Show1 instance - makes the last type parameter (b) polymorphic +instance (Show1 f, Show1 g, Show a) => Show1 (This f g a) where + liftShowsPrec spB slB d (This t r) = + showParen (d > 10) $ + showString "This " + . liftShowsPrec (liftShowsPrec2 showsPrec showList spB slB) (liftShowList2 showsPrec showList spB slB) 11 t + . showString " " + . liftShowsPrec (liftShowsPrec2 (liftShowsPrec showsPrec showList) (liftShowList showsPrec showList) (liftShowsPrec spB slB) (liftShowList spB slB)) (liftShowList2 (liftShowsPrec showsPrec showList) (liftShowList showsPrec showList) (liftShowsPrec spB slB) (liftShowList spB slB)) 11 r + +-- | Show2 instance - makes both type parameters (a, b) polymorphic +instance (Show1 f, Show1 g) => Show2 (This f g) where + liftShowsPrec2 spA slA spB slB d (This t r) = + showParen (d > 10) $ + showString "This " + . liftShowsPrec (liftShowsPrec2 spA slA spB slB) (liftShowList2 spA slA spB slB) 11 t + . showString " " + . liftShowsPrec (liftShowsPrec2 (liftShowsPrec spA slA) (liftShowList spA slA) (liftShowsPrec spB slB) (liftShowList spB slB)) (liftShowList2 (liftShowsPrec spA slA) (liftShowList spA slA) (liftShowsPrec spB slB) (liftShowList spB slB)) 11 r + +-- | Functor instance - maps over the second type parameter (b) +-- Maps the function over b in the tuple (a,b) and over b in the Either branch +-- +-- >>> fmap (*10) (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- This [(1,20)] Nothing +-- >>> fmap (*10) (This [(1,2)] (Just (Right (3 :| []))) :: This [] NonEmpty Int Int) +-- This [(1,20)] (Just (Right (30 :| []))) +-- >>> fmap (*10) (This [(1,2)] (Just (Left (3 :| []))) :: This [] NonEmpty Int Int) +-- This [(1,20)] (Just (Left (3 :| []))) +instance (Functor f, Functor g) => Functor (This f g a) where + fmap h (This t r) = + This (fmap (second h) t) (fmap (fmap (fmap h)) r) + +-- | Bifunctor instance - operates on both type parameters (a, b) +-- The first function maps a, the second function maps b +-- +-- >>> bimap (*10) (*100) (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- This [(10,200)] Nothing +-- >>> bimap (*10) (*100) (This [(1,2)] (Just (Left (3 :| []))) :: This [] NonEmpty Int Int) +-- This [(10,200)] (Just (Left (30 :| []))) +-- >>> bimap (*10) (*100) (This [(1,2)] (Just (Right (3 :| []))) :: This [] NonEmpty Int Int) +-- This [(10,200)] (Just (Right (300 :| []))) +instance (Functor f, Functor g) => Bifunctor (This f g) where + bimap fa fb (This t r) = + This (fmap (bimap fa fb) t) (fmap (bimap (fmap fa) (fmap fb)) r) + +-- | Swap instance - swaps the two type parameters +-- +-- >>> swap (This [(1,'a')] Nothing :: This [] NonEmpty Int Char) +-- This [('a',1)] Nothing +-- >>> swap (This [(1,'a')] (Just (Left (3 :| []))) :: This [] NonEmpty Int Char) +-- This [('a',1)] (Just (Right (3 :| []))) +-- >>> swap (This [(1,'a')] (Just (Right ('b' :| ""))) :: This [] NonEmpty Int Char) +-- This [('a',1)] (Just (Left ('b' :| ""))) +instance (Functor f) => Swap (This f g) where + swap (This t r) = + This (fmap (\(a, b) -> (b, a)) t) (fmap swapEither r) + where + swapEither (Left ga) = Right ga + swapEither (Right gb) = Left gb + +-- | NFData instance for strict evaluation in benchmarks +-- +-- Forces evaluation of both the paired component and the leftover component. +instance (NFData (f (a, b)), NFData (g a), NFData (g b)) => NFData (This f g a b) where + rnf (This pairs leftover) = rnf (pairs, leftover) + {-# INLINE rnf #-} + +-- * Functor/Bifunctor/Swap fusion rules +-- +-- These rules optimize composition of mapping and swapping operations on This. +-- Phase [2] ensures they fire after instance resolution. + +{-# RULES + +-- Functor composition on This - reduces to single traversal +"fmap/fmap/This" [2] forall f g (x :: This [] NonEmpty a b). + fmap f (fmap g x) = fmap (f . g) x + +-- Bifunctor composition on This - reduces to single traversal +"bimap/bimap/This" [2] forall f1 f2 g1 g2 (x :: This [] NonEmpty a b). + bimap f1 g1 (bimap f2 g2 x) = bimap (f1 . f2) (g1 . g2) x + +-- Swap involution - swap is its own inverse, complete elimination +"swap/swap/This" [2] forall (x :: This [] NonEmpty a b). + swap (swap x) = x + +-- Swap and bimap commute by swapping function arguments +"swap/bimap/This" [2] forall f g (x :: This [] NonEmpty a b). + swap (bimap f g x) = bimap g f (swap x) + +-- bimap and swap commute (reverse direction) +"bimap/swap/This" [2] forall f g (x :: This [] NonEmpty a b). + bimap f g (swap x) = swap (bimap g f x) + + #-} + +-- | Semigroup instance - combines two This values by combining their components +-- +-- >>> This [(1,2)] Nothing <> This [(3,4)] Nothing :: This [] NonEmpty Int Int +-- This [(1,2),(3,4)] Nothing +-- >>> This [(1,2)] (Just (Left (3 :| []))) <> This [(4,5)] (Just (Left (6 :| []))) +-- This [(1,2),(4,5)] (Just (Left (3 :| [6]))) +-- >>> This [(1,2)] (Just (Right (3 :| []))) <> This [(4,5)] (Just (Right (6 :| []))) +-- This [(1,2),(4,5)] (Just (Right (3 :| [6]))) +-- >>> This [(1,2)] (Just (Left (3 :| []))) <> This [(4,5)] (Just (Right (6 :| []))) +-- This [(1,2),(4,5)] (Just (Right (6 :| []))) +instance (Semigroup (f (a, b)), Semigroup (g a), Semigroup (g b)) => Semigroup (This f g a b) where + This t1 r1 <> This t2 r2 = + This (t1 <> t2) (combine r1 r2) + where + combine Nothing Nothing = Nothing + combine (Just x) Nothing = Just x + combine Nothing (Just y) = Just y + combine (Just (Left ga1)) (Just (Left ga2)) = Just (Left (ga1 <> ga2)) + combine (Just (Right gb1)) (Just (Right gb2)) = Just (Right (gb1 <> gb2)) + combine (Just (Left _)) (Just (Right gb)) = Just (Right gb) + combine (Just (Right gb)) (Just (Left _)) = Just (Right gb) + +-- | Monoid instance - identity is empty f and Nothing +-- +-- >>> mempty :: This [] NonEmpty Int Int +-- This [] Nothing +-- >>> mempty <> This [(1,2)] Nothing :: This [] NonEmpty Int Int +-- This [(1,2)] Nothing +instance (Monoid (f (a, b)), Semigroup (g a), Semigroup (g b)) => Monoid (This f g a b) where + mempty = This mempty Nothing + +-- | Bifoldable instance - folds over both type parameters +-- +-- >>> import Data.Monoid (Sum(..)) +-- >>> bifoldMap Sum Sum (This [(1,2),(3,4)] Nothing :: This [] NonEmpty Int Int) +-- Sum {getSum = 10} +-- >>> bifoldMap Sum Sum (This [(1,2)] (Just (Left (3 :| []))) :: This [] NonEmpty Int Int) +-- Sum {getSum = 6} +-- >>> bifoldMap Sum Sum (This [(1,2)] (Just (Right (3 :| []))) :: This [] NonEmpty Int Int) +-- Sum {getSum = 6} +instance (Foldable f, Foldable g) => Bifoldable (This f g) where + bifoldMap ha hb (This t r) = + foldMap (\(a, b) -> ha a <> hb b) t <> foldMap (either (foldMap ha) (foldMap hb)) r + {-# INLINE bifoldMap #-} + +-- | Foldable instance - folds over b values in tuples and in the Either branch +-- +-- >>> import Data.Monoid (Sum(..)) +-- >>> foldMap Sum (This [(1,2),(3,4)] Nothing :: This [] NonEmpty Int Int) +-- Sum {getSum = 6} +-- >>> foldMap Sum (This [(1,2)] (Just (Left (3 :| []))) :: This [] NonEmpty Int Int) +-- Sum {getSum = 2} +-- >>> foldMap Sum (This [(1,2)] (Just (Right (3 :| []))) :: This [] NonEmpty Int Int) +-- Sum {getSum = 5} +instance (Foldable f, Foldable g) => Foldable (This f g a) where + foldMap h (This t r) = + foldMap (\(_, b) -> h b) t <> foldMap (either (pure mempty) (foldMap h)) r + {-# INLINE foldMap #-} + +-- | Bifoldable1 instance - folds over both type parameters with at least one value +-- +-- >>> import Data.Semigroup (Sum(..)) +-- >>> bifoldMap1 Sum Sum (This ((1,2) :| [(3,4)]) Nothing :: This NonEmpty NonEmpty Int Int) +-- Sum {getSum = 10} +-- >>> bifoldMap1 Sum Sum (This ((1,2) :| []) (Just (Left (3 :| []))) :: This NonEmpty NonEmpty Int Int) +-- Sum {getSum = 6} +-- >>> bifoldMap1 Sum Sum (This ((1,2) :| []) (Just (Right (3 :| []))) :: This NonEmpty NonEmpty Int Int) +-- Sum {getSum = 6} +instance (Foldable1 f, Foldable1 g) => Bifoldable1 (This f g) where + bifoldMap1 ha hb (This t r) = + case r of + Nothing -> foldMap1 (\(a, b) -> ha a <> hb b) t + Just (Left ga) -> foldMap1 (\(a, b) -> ha a <> hb b) t <> foldMap1 ha ga + Just (Right gb) -> foldMap1 (\(a, b) -> ha a <> hb b) t <> foldMap1 hb gb + {-# INLINE bifoldMap1 #-} + +-- | Foldable1 instance - folds over at least one b value +-- +-- >>> import Data.Semigroup (Sum(..)) +-- >>> foldMap1 Sum (This ((1,2) :| [(3,4)]) Nothing :: This NonEmpty NonEmpty Int Int) +-- Sum {getSum = 6} +-- >>> foldMap1 Sum (This ((1,2) :| []) (Just (Left (3 :| []))) :: This NonEmpty NonEmpty Int Int) +-- Sum {getSum = 2} +-- >>> foldMap1 Sum (This ((1,2) :| []) (Just (Right (3 :| []))) :: This NonEmpty NonEmpty Int Int) +-- Sum {getSum = 5} +instance (Foldable1 f, Foldable1 g) => Foldable1 (This f g a) where + foldMap1 h (This t r) = + case r of + Nothing -> foldMap1 (\(_, b) -> h b) t + Just (Left _) -> foldMap1 (\(_, b) -> h b) t + Just (Right gb) -> foldMap1 (\(_, b) -> h b) t <> foldMap1 h gb + {-# INLINE foldMap1 #-} + +-- | Traversable instance - traverses over b values +-- Implemented using traverseB +instance (Traversable f, Traversable g) => Traversable (This f g a) where + traverse = traverseB + +-- | Traversable1 instance - traverses over at least one b value +-- Implemented using traverseB1 +instance (Traversable1 f, Traversable1 g) => Traversable1 (This f g a) where + traverse1 = traverseB1 + +-- | Bitraversable instance - traverses over both type parameters +-- Implemented using traverseA and traverseB +-- +-- >>> bitraverse Just Just (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- Just (This [(1,2)] Nothing) +-- >>> bitraverse (\x -> if x > 0 then Just x else Nothing) Just (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- Just (This [(1,2)] Nothing) +-- >>> bitraverse (\x -> if x > 0 then Just x else Nothing) Just (This [(-1,2)] Nothing :: This [] NonEmpty Int Int) +-- Nothing +instance (Traversable f, Traversable g) => Bitraversable (This f g) where + bitraverse ha hb (This t r) = + This + <$> traverse (\(a, b) -> (,) <$> ha a <*> hb b) t + <*> traverse traverseEither r + where + traverseEither (Left ga) = Left <$> traverse ha ga + traverseEither (Right gb) = Right <$> traverse hb gb + {-# INLINE bitraverse #-} + +-- | Bitraversable1 instance - traverses over both type parameters with at least one value +-- Implemented using traverseA and traverseB with Apply +-- +-- >>> bitraverse1 (Just) (Just) (This ((1,2) :| []) Nothing :: This NonEmpty NonEmpty Int Int) +-- Just (This ((1,2) :| []) Nothing) +instance (Traversable1 f, Traversable1 g) => Bitraversable1 (This f g) where + bitraverse1 ha hb (This t r) = + let tResult = traverse1 (\(a, b) -> (,) <$> ha a <.> hb b) t + in case r of + Nothing -> (`This` Nothing) <$> tResult + Just (Left ga) -> (\t' ga' -> This t' (Just (Left ga'))) <$> tResult <.> traverse1 ha ga + Just (Right gb) -> (\t' gb' -> This t' (Just (Right gb'))) <$> tResult <.> traverse1 hb gb + {-# INLINE bitraverse1 #-} + +-- | Semialign type class - aligns two functors into a This value +-- +-- >>> align [1,2,3] [4,5] :: This [] NonEmpty Int Int +-- This [(1,4),(2,5)] (Just (Left (3 :| []))) +-- >>> align [1,2] [3,4,5] :: This [] NonEmpty Int Int +-- This [(1,3),(2,4)] (Just (Right (5 :| []))) +-- >>> align [1,2] [3,4] :: This [] NonEmpty Int Int +-- This [(1,3),(2,4)] Nothing +-- +-- = Laws +-- +-- [Naturality (Bifunctoriality)] +-- +-- Mapping over the aligned result is the same as mapping over the inputs first: +-- +-- @bimap f g (align xs ys) ≡ align (fmap f xs) (fmap g ys)@ +-- +-- [Symmetry] +-- +-- Aligning x with y should be the same as aligning y with x and swapping: +-- +-- @align x y ≡ swap (align y x)@ +-- +-- [Coherence with alignWith] +-- +-- The relationship between 'align' and 'alignWith' must be consistent: +-- +-- @align x y ≡ alignWith id id id x y@ +-- +-- @alignWith f g h x y ≡ +-- let This t r = align x y +-- in This (fmap f t) (fmap (bimap (fmap g) (fmap h)) r)@ +-- +-- [Preservation of structure] +-- +-- No elements should be duplicated or lost. The total number of elements +-- in matched pairs plus elements in leftovers equals the total input elements. +-- +-- See 'semialignNaturality', 'semialignSymmetry', 'semialignCoherence' for +-- testable property functions. +class (Functor f, Functor g) => Semialign f g | f -> g where + align :: + f a -> + f b -> + This f g a b + align = + alignWith id id id + + -- | Align with a transformation function + -- + -- >>> alignWith (\(a,b) -> (a*10, b*100)) (*10) (*100) [1,2,3] [4,5] :: This [] NonEmpty Int Int + -- This [(10,400),(20,500)] (Just (Left (30 :| []))) + alignWith :: + ((a, b) -> (c, d)) -> + (a -> c) -> + (b -> d) -> + f a -> + f b -> + This f g c d + alignWith f g h t1 t2 = + case align t1 t2 of + This t r -> + This (fmap f t) (fmap (bimap (fmap g) (fmap h)) r) + + {-# MINIMAL align | alignWith #-} + + -- | Simplified alignWith using bimap + -- + -- >>> alignWith' (*10) (*100) [1,2,3] [4,5] :: This [] NonEmpty Int Int + -- This [(10,400),(20,500)] (Just (Left (30 :| []))) + alignWith' :: + (a -> c) -> + (b -> d) -> + f a -> + f b -> + This f g c d + alignWith' f g = + alignWith (bimap f g) f g + {-# INLINE alignWith' #-} + +-- * Fusion rules +-- +-- These RULES enable GHC to fuse operations for better performance, +-- eliminating intermediate This allocations where possible. +-- +-- Phase [2] ensures these fire after class method specialization, +-- allowing them to see concrete instances while avoiding conflicts +-- with earlier optimization phases. + +{-# RULES + +-- Naturality fusion: fuse bimap into align +-- Implements the semialignNaturality law as a rewrite rule +"semialign/naturality" [2] forall f g xs ys. + bimap f g (align xs ys) = alignWith (bimap f g) f g xs ys + +-- Composition fusion for alignWith followed by bimap +"alignWith/bimap" [2] forall w x y k l xs ys. + bimap k l (alignWith w x y xs ys) = + alignWith (bimap k l . w) (k . x) (l . y) xs ys + +-- Symmetry via swap: align x y = swap (align y x) +-- Can enable other optimizations when combined with swap rules +"align/swap/symmetry" [2] forall x y. + swap (align y x) = align x y + +-- fmap can be expressed as bimap with identity on first param +-- Allows bimap rules to catch fmap patterns +"fmap/as/bimap" [2] forall f (x :: This [] NonEmpty a b). + fmap f x = bimap id f x + + #-} + +-- | Semialign instance for Identity - always produces a perfect match +-- +-- >>> align (Identity 1) (Identity 2) +-- This (Identity (1,2)) Nothing +instance Semialign Identity Identity where + align (Identity a) (Identity b) = + This (Identity (a, b)) Nothing + {-# INLINE align #-} + +-- | Semialign instance for lists - aligns elements pairwise +-- +-- >>> align [1,2,3] [4,5] :: This [] NonEmpty Int Int +-- This [(1,4),(2,5)] (Just (Left (3 :| []))) +-- >>> align [1,2] [3,4,5] :: This [] NonEmpty Int Int +-- This [(1,3),(2,4)] (Just (Right (5 :| []))) +-- >>> align [1,2] [3,4] :: This [] NonEmpty Int Int +-- This [(1,3),(2,4)] Nothing +-- >>> align ([] :: [Int]) [1,2] :: This [] NonEmpty Int Int +-- This [] (Just (Right (1 :| [2]))) +instance Semialign [] NonEmpty 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 + {-# INLINABLE align #-} + +-- | Semialign instance for Maybe - aligns optional values +-- +-- >>> align (Just 1) (Just 2) :: This Maybe Identity Int Int +-- This (Just (1,2)) Nothing +-- >>> align (Just 1) Nothing :: This Maybe Identity Int Int +-- This Nothing (Just (Left (Identity 1))) +-- >>> align Nothing (Just 2) :: This Maybe Identity Int Int +-- This Nothing (Just (Right (Identity 2))) +-- >>> align Nothing Nothing :: This Maybe Identity Int Int +-- This Nothing Nothing +instance Semialign Maybe Identity where + align (Just a) (Just b) = + This (Just (a, b)) Nothing + align (Just a) Nothing = + This Nothing (Just (Left (Identity a))) + align Nothing (Just b) = + This Nothing (Just (Right (Identity b))) + align Nothing Nothing = + This Nothing Nothing + {-# INLINABLE align #-} + +-- | Semialign instance for NonEmpty - aligns non-empty lists +-- +-- >>> align (1 :| [2,3]) (4 :| [5]) +-- This ((1,4) :| [(2,5)]) (Just (Left (3 :| []))) +-- >>> align (1 :| [2]) (3 :| [4,5]) +-- This ((1,3) :| [(2,4)]) (Just (Right (5 :| []))) +-- >>> align (1 :| [2]) (3 :| [4]) +-- This ((1,3) :| [(2,4)]) Nothing +-- >>> align (1 :| []) (2 :| []) +-- This ((1,2) :| []) Nothing +instance Semialign NonEmpty 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 + {-# INLINABLE align #-} + +-- | Semialign instance for ZipList - delegates to list alignment +-- +-- >>> import Control.Lens (view) +-- >>> view these (align (ZipList [1,2,3]) (ZipList [4,5])) +-- ZipList {getZipList = [(1,4),(2,5)]} +instance Semialign ZipList NonEmpty where + align (ZipList a) (ZipList b) = + over these ZipList (align a b) + {-# INLINABLE align #-} + +-- | Semialign instance for Seq - aligns sequences element-wise +-- +-- >>> align (Seq.fromList [1,2,3]) (Seq.fromList [4,5]) :: This Seq NonEmpty Int Int +-- This (fromList [(1,4),(2,5)]) (Just (Left (3 :| []))) +-- >>> align (Seq.fromList [1,2]) (Seq.fromList [3,4,5]) :: This Seq NonEmpty Int Int +-- This (fromList [(1,3),(2,4)]) (Just (Right (5 :| []))) +-- >>> align (Seq.fromList [1,2]) (Seq.fromList [3,4]) :: This Seq NonEmpty Int Int +-- This (fromList [(1,3),(2,4)]) Nothing +instance Semialign Seq NonEmpty where + align sa sb = case (Seq.viewl sa, Seq.viewl sb) of + (Seq.EmptyL, Seq.EmptyL) -> This Seq.empty Nothing + (a Seq.:< as, Seq.EmptyL) -> This Seq.empty (Just (Left (a :| toList as))) + (Seq.EmptyL, b Seq.:< bs) -> This Seq.empty (Just (Right (b :| toList bs))) + (a Seq.:< as, b Seq.:< bs) -> + let This t r = align as bs + in This ((a, b) Seq.<| t) r + where + toList s = case Seq.viewl s of + Seq.EmptyL -> [] + x Seq.:< xs -> x : toList xs + {-# INLINABLE align #-} + +-- | Semialign instance for Vector - aligns vectors element-wise +-- +-- >>> align (Vector.fromList [1,2,3]) (Vector.fromList [4,5]) :: This Vector NonEmpty Int Int +-- This [(1,4),(2,5)] (Just (Left (3 :| []))) +-- >>> align (Vector.fromList [1,2]) (Vector.fromList [3,4,5]) :: This Vector NonEmpty Int Int +-- This [(1,3),(2,4)] (Just (Right (5 :| []))) +instance Semialign Vector NonEmpty where + align va vb = + let minLen = min (Vector.length va) (Vector.length vb) + paired = Vector.zip (Vector.take minLen va) (Vector.take minLen vb) + leftover + | Vector.length va > minLen = + case Vector.toList (Vector.drop minLen va) of + [] -> Nothing + (x : xs) -> Just (Left (x :| xs)) + | Vector.length vb > minLen = + case Vector.toList (Vector.drop minLen vb) of + [] -> Nothing + (y : ys) -> Just (Right (y :| ys)) + | otherwise = Nothing + in This paired leftover + {-# INLINABLE align #-} + +-- | Semialign instance for Map - aligns by keys +-- +-- >>> let m1 = Map.fromList [(1,'a'),(2,'b'),(3,'c')] +-- >>> let m2 = Map.fromList [(2,'x'),(3,'y'),(4,'z')] +-- >>> align m1 m2 :: This (Map Int) (Map Int) Char Char +-- This (fromList [(2,('b','x')),(3,('c','y'))]) (Just (Left (fromList [(1,'a')]))) +instance (Ord k) => Semialign (Map k) (Map k) where + align m1 m2 = + let both = Map.intersectionWith (,) m1 m2 + onlyLeft = Map.difference m1 m2 + onlyRight = Map.difference m2 m1 + leftover = case (Map.null onlyLeft, Map.null onlyRight) of + (True, True) -> Nothing + (False, True) -> Just (Left onlyLeft) + (True, False) -> Just (Right onlyRight) + (False, False) -> Just (Left onlyLeft) -- Left takes precedence + in This both leftover + {-# INLINABLE align #-} + +-- | Semialign instance for IntMap - aligns by Int keys +-- +-- >>> let m1 = IntMap.fromList [(1,'a'),(2,'b'),(3,'c')] +-- >>> let m2 = IntMap.fromList [(2,'x'),(3,'y'),(4,'z')] +-- >>> align m1 m2 :: This IntMap IntMap Char Char +-- This (fromList [(2,('b','x')),(3,('c','y'))]) (Just (Left (fromList [(1,'a')]))) +instance Semialign IntMap IntMap where + align m1 m2 = + let both = IntMap.intersectionWith (,) m1 m2 + onlyLeft = IntMap.difference m1 m2 + onlyRight = IntMap.difference m2 m1 + leftover = case (IntMap.null onlyLeft, IntMap.null onlyRight) of + (True, True) -> Nothing + (False, True) -> Just (Left onlyLeft) + (True, False) -> Just (Right onlyRight) + (False, False) -> Just (Left onlyLeft) + in This both leftover + {-# INLINABLE align #-} + +-- | Semialign instance for functions - pointwise alignment +-- +-- >>> let f = align (+1) (*2) :: This ((->) Int) Identity Int Int +-- >>> view these f 5 +-- (6,10) +instance Semialign ((->) r) Identity where + align f g = This (\r -> (f r, g r)) Nothing + {-# INLINE align #-} + +-- | Semialign instance for pairs with Monoid first component +-- +-- >>> align (mempty :: String, 1) ("", 2) :: This ((,) String) Identity Int Int +-- This ("",(1,2)) Nothing +-- >>> align ("left", 1) ("right", 2) :: This ((,) String) Identity Int Int +-- This ("leftright",(1,2)) Nothing +instance (Monoid e) => Semialign ((,) e) Identity where + align (e1, a) (e2, b) = This (e1 <> e2, (a, b)) Nothing + {-# INLINE align #-} + +-- | Semialign instance for Const - trivial alignment +-- +-- >>> align (Const "left") (Const "right") :: This (Const String) Identity Int Int +-- This (Const "left") Nothing +instance Semialign (Const m) Identity where + align (Const a) (Const _) = This (Const a) Nothing + {-# INLINE align #-} + +-- | Align type class - Semialign with an empty structure +-- +-- This is to Semialign as Applicative is to Apply. +-- The relationship: Semialign : Apply :: Align : Applicative +-- +-- The 'nil' method provides an empty structure, which acts as an identity +-- for alignment operations. +-- +-- = Laws +-- +-- In addition to the Semialign laws, Align instances must satisfy: +-- +-- [Right identity] +-- +-- Aligning with nil on the right produces only left leftovers: +-- +-- @align x nil ≡ This nil (toLeftover x)@ +-- +-- [Left identity] +-- +-- Aligning with nil on the left produces only right leftovers: +-- +-- @align nil y ≡ This nil (toRightover y)@ +-- +-- [Empty alignment] +-- +-- Aligning nil with nil produces an empty result: +-- +-- @align nil nil ≡ This nil Nothing@ +-- +-- Where 'toLeftover' and 'toRightover' convert non-empty structures to the +-- leftover type 'g'. For empty inputs, these return 'Nothing'. +-- +-- Not all Semialign instances can be Align instances. For example, NonEmpty +-- cannot be Align because there is no empty NonEmpty. +-- +-- >>> align (nil :: [Int]) [1,2] :: This [] NonEmpty Int Int +-- This [] (Just (Right (1 :| [2]))) +-- >>> align [1,2] (nil :: [Int]) :: This [] NonEmpty Int Int +-- This [] (Just (Left (1 :| [2]))) +-- >>> align (nil :: Maybe Int) (Just 5) :: This Maybe Identity Int Int +-- This Nothing (Just (Right (Identity 5))) +-- +-- See 'alignRightIdentity', 'alignLeftIdentity', 'alignEmpty' for +-- testable property functions. +class (Semialign f g) => Align f g where + -- | The empty structure - identity for alignment + nil :: f a + +-- | Align instance for lists +-- +-- >>> nil :: [Int] +-- [] +-- >>> align nil [1,2,3] :: This [] NonEmpty Int Int +-- This [] (Just (Right (1 :| [2,3]))) +instance Align [] NonEmpty where + nil = [] + {-# INLINE nil #-} + +-- | Align instance for Maybe +-- +-- >>> nil :: Maybe Int +-- Nothing +-- >>> align nil (Just 42) :: This Maybe Identity Int Int +-- This Nothing (Just (Right (Identity 42))) +instance Align Maybe Identity where + nil = Nothing + {-# INLINE nil #-} + +-- | Align instance for ZipList +-- +-- >>> nil :: ZipList Int +-- ZipList {getZipList = []} +-- >>> import Control.Lens (view) +-- >>> view these (align nil (ZipList [1,2])) +-- ZipList {getZipList = []} +instance Align ZipList NonEmpty where + nil = ZipList [] + {-# INLINE nil #-} + +-- | Align instance for Seq +-- +-- >>> nil :: Seq Int +-- fromList [] +-- >>> align nil (Seq.fromList [1,2]) :: This Seq NonEmpty Int Int +-- This (fromList []) (Just (Right (1 :| [2]))) +instance Align Seq NonEmpty where + nil = Seq.empty + {-# INLINE nil #-} + +-- | Align instance for Vector +-- +-- >>> nil :: Vector Int +-- [] +-- >>> align nil (Vector.fromList [1,2]) :: This Vector NonEmpty Int Int +-- This [] (Just (Right (1 :| [2]))) +instance Align Vector NonEmpty where + nil = Vector.empty + {-# INLINE nil #-} + +-- | Align instance for Map +-- +-- >>> nil :: Map Int Char +-- fromList [] +-- >>> let m = Map.fromList [(1,'a'),(2,'b')] +-- >>> align nil m :: This (Map Int) (Map Int) Char Char +-- This (fromList []) (Just (Right (fromList [(1,'a'),(2,'b')]))) +instance (Ord k) => Align (Map k) (Map k) where + nil = Map.empty + {-# INLINE nil #-} + +-- | Align instance for IntMap +-- +-- >>> nil :: IntMap Char +-- fromList [] +-- >>> let m = IntMap.fromList [(1,'a'),(2,'b')] +-- >>> align nil m :: This IntMap IntMap Char Char +-- This (fromList []) (Just (Right (fromList [(1,'a'),(2,'b')]))) +instance Align IntMap IntMap where + nil = IntMap.empty + {-# INLINE nil #-} + +-- | Align instance for Const with Monoid +-- +-- >>> nil :: Const String Int +-- Const "" +instance (Monoid m) => Align (Const m) Identity where + nil = Const mempty + {-# INLINE nil #-} + +-- Note: Product and Compose instances would require more complex type machinery +-- and are omitted for simplicity. They could be added with careful handling of +-- the leftover types. + +-- | Unalign type class - recover original functors from alignment +-- +-- Not all Semialign instances can be Unalign. This class is for functors +-- where the alignment can be reversed without loss of information. +-- +-- The Unalign class provides the inverse of 'align', allowing you to recover +-- the original two functors from a 'This' value. This is only possible for +-- container-like functors that support both unzipping and merging operations. +-- +-- = Laws +-- +-- [Roundtrip] +-- +-- The fundamental law is that unalign inverts align: +-- +-- @unalign (align xs ys) ≡ (xs, ys)@ +-- +-- [Naturality] +-- +-- Unalign commutes with fmap on both sides: +-- +-- @bimap (fmap f) (fmap g) (unalign t) ≡ unalign (bimap f g t)@ +-- +-- [Isomorphism] +-- +-- The 'aligned' Iso satisfies the isomorphism laws: +-- +-- @from aligned . to aligned ≡ id@ +-- @to aligned . from aligned ≡ id@ +-- +-- Where @to aligned = uncurry align@ and @from aligned = unalign@. +-- +-- = Important Notes +-- +-- Not all Semialign instances can be Unalign instances: +-- +-- * Sequence types ([], Maybe, NonEmpty, Vector, Seq, etc.) ✓ Can unalign +-- * Function types ((->) r) ✗ Cannot meaningfully merge functions with constants +-- * Pair types ((,) e) ✗ Would require duplicating the first component +-- * Map and IntMap ✗ Violate roundtrip law when both sides have leftovers +-- +-- For Map and IntMap, when both sides have leftovers, 'align' keeps only left +-- leftovers (left takes precedence), so 'unalign' cannot recover the original +-- right-side keys. We choose not to provide these instances to keep the type +-- class lawful. +-- +-- See 'unalignRoundtrip' and 'unalignNaturality' for testable property functions. +-- +-- >>> unalign (align [1,2,3] [10,20] :: This [] NonEmpty Int Int) +-- ([1,2,3],[10,20]) +-- >>> unalign (align (Just 1) Nothing :: This Maybe Identity Int Int) +-- (Just 1,Nothing) +class (Semialign f g) => Unalign f g where + {-# MINIMAL unalign #-} + + -- | Recover the original functors from an aligned result + unalign :: This f g a b -> (f a, f b) + + -- | Unalign with transformation - transforms both sides during unalignment + -- + -- This is the dual of 'alignWith': while @alignWith@ transforms during alignment, + -- @unalignWith@ transforms during unalignment. + -- + -- >>> unalignWith (*10) (*100) (This [(1,2),(3,4)] Nothing :: This [] NonEmpty Int Int) + -- ([10,30],[200,400]) + -- >>> unalignWith (*10) (*100) (This [(1,2)] (Just (Left (3 :| []))) :: This [] NonEmpty Int Int) + -- ([10,30],[200]) + -- >>> unalignWith (*10) (*100) (This [(1,2)] (Just (Right (5 :| []))) :: This [] NonEmpty Int Int) + -- ([10],[200,500]) + unalignWith :: + (a -> c) -> + (b -> d) -> + This f g a b -> + (f c, f d) + unalignWith f g = unalign . bimap f g + {-# INLINE unalignWith #-} + + -- | Isomorphism between a pair of functors and their alignment + -- + -- This witnesses that @(f a, f b)@ and @This f g a b@ are isomorphic, + -- meaning alignment is completely lossless for Unalign instances. + -- + -- >>> import Control.Lens (from, view) + -- >>> view aligned ([1,2,3], [10,20]) :: This [] NonEmpty Int Int + -- This [(1,10),(2,20)] (Just (Left (3 :| []))) + -- >>> view (from aligned) (This [(1,10),(2,20)] (Just (Left (3 :| [])))) :: ([Int], [Int]) + -- ([1,2,3],[10,20]) + aligned :: Iso' (f a, f b) (This f g a b) + aligned = iso (uncurry align) unalign + {-# INLINE aligned #-} + +-- | Isomorphism between an aligned result and a pair of functors +-- +-- This is the inverse of 'aligned', providing a direct view from +-- @This f g a b@ to @(f a, f b)@. +-- +-- >>> import Control.Lens (view, from) +-- >>> view unaligned (This [(1,10),(2,20)] (Just (Left (3 :| [])))) :: ([Int], [Int]) +-- ([1,2,3],[10,20]) +-- >>> view (from unaligned) ([1,2,3], [10,20]) :: This [] NonEmpty Int Int +-- This [(1,10),(2,20)] (Just (Left (3 :| []))) +unaligned :: (Unalign f g) => Iso' (This f g a b) (f a, f b) +unaligned = iso unalign (uncurry align) +{-# INLINE unaligned #-} + +-- * Unalign fusion rules +-- +-- Additional fusion rules specific to Unalign instances. +-- +-- Phase [2] ensures these fire after class method specialization. + +{-# RULES + +-- Roundtrip elimination: unalign immediately after align +-- Implements the unalignRoundtrip law as a rewrite rule +"unalign/align/roundtrip" [2] forall xs ys. + unalign (align xs ys) = (xs, ys) + +-- Naturality for unalign: push bimap through unalign +-- Implements the unalignNaturality law as a rewrite rule +"unalign/bimap/naturality" [2] forall f g this. + bimap (fmap f) (fmap g) (unalign this) = unalign (bimap f g this) + +-- unalignWith/align roundtrip with transformation +-- Combines roundtrip elimination with transformation fusion +"unalignWith/align" [2] forall f g xs ys. + unalignWith f g (align xs ys) = (fmap f xs, fmap g ys) + + #-} + +-- | Unalign instance for Identity - simply unwrap +-- +-- >>> unalign (align (Identity 1) (Identity 2) :: This Identity Identity Int Int) +-- (Identity 1,Identity 2) +instance Unalign Identity Identity where + unalign (This (Identity (a, b)) _) = (Identity a, Identity b) + {-# INLINE unalign #-} + +-- | Unalign instance for lists - unzip and append leftovers +-- +-- >>> unalign (align [1,2,3] [10,20] :: This [] NonEmpty Int Int) +-- ([1,2,3],[10,20]) +-- >>> unalign (align [1,2] [10,20,30] :: This [] NonEmpty Int Int) +-- ([1,2],[10,20,30]) +-- >>> unalign (align [1,2] [10,20] :: This [] NonEmpty Int Int) +-- ([1,2],[10,20]) +instance Unalign [] NonEmpty where + unalign (This pairs mleftover) = + let (as, bs) = List.unzip pairs + in case mleftover of + Nothing -> (as, bs) + Just (Left ga) -> (as ++ toList ga, bs) + Just (Right gb) -> (as, bs ++ toList gb) + where + toList (x :| xs) = x : xs + {-# INLINABLE unalign #-} + +-- | Unalign instance for Maybe - reconstruct from pairs or leftovers +-- +-- >>> unalign (align (Just 1) (Just 2) :: This Maybe Identity Int Int) +-- (Just 1,Just 2) +-- >>> unalign (align (Just 1) Nothing :: This Maybe Identity Int Int) +-- (Just 1,Nothing) +-- >>> unalign (align Nothing (Just 2) :: This Maybe Identity Int Int) +-- (Nothing,Just 2) +-- >>> unalign (align Nothing Nothing :: This Maybe Identity Int Int) +-- (Nothing,Nothing) +instance Unalign Maybe Identity where + unalign (This pairs mleftover) = + case (pairs, mleftover) of + (Nothing, Nothing) -> (Nothing, Nothing) + (Just (a, b), Nothing) -> (Just a, Just b) + (Nothing, Just (Left (Identity a))) -> (Just a, Nothing) + (Nothing, Just (Right (Identity b))) -> (Nothing, Just b) + -- The cases with both pairs and leftovers are impossible for Maybe + _ -> (Nothing, Nothing) + {-# INLINE unalign #-} + +-- | Unalign instance for NonEmpty - unzip and append leftovers +-- +-- >>> unalign (align (1 :| [2,3]) (10 :| [20]) :: This NonEmpty NonEmpty Int Int) +-- (1 :| [2,3],10 :| [20]) +-- >>> unalign (align (1 :| [2]) (10 :| [20,30]) :: This NonEmpty NonEmpty Int Int) +-- (1 :| [2],10 :| [20,30]) +-- >>> unalign (align (1 :| [2]) (10 :| [20]) :: This NonEmpty NonEmpty Int Int) +-- (1 :| [2],10 :| [20]) +instance Unalign NonEmpty NonEmpty where + unalign (This pairs mleftover) = + let (leftAs, leftBs) = unzipNonEmpty pairs + in case mleftover of + Nothing -> (leftAs, leftBs) + Just (Left ga) -> (leftAs <> ga, leftBs) + Just (Right gb) -> (leftAs, leftBs <> gb) + where + unzipNonEmpty ((x, y) :| rest) = + let (xs, ys) = List.unzip rest + in (x :| xs, y :| ys) + {-# INLINABLE unalign #-} + +-- | Unalign instance for ZipList - delegates to list unalign +-- +-- >>> unalign (align (ZipList [1,2,3]) (ZipList [10,20]) :: This ZipList NonEmpty Int Int) +-- (ZipList {getZipList = [1,2,3]},ZipList {getZipList = [10,20]}) +instance Unalign ZipList NonEmpty where + unalign t = + let (as, bs) = unalign (over these getZipList t) + in (ZipList as, ZipList bs) + {-# INLINE unalign #-} + +-- | Unalign instance for Seq - unzip and append leftovers +-- +-- >>> unalign (align (Seq.fromList [1,2,3]) (Seq.fromList [10,20]) :: This Seq NonEmpty Int Int) +-- (fromList [1,2,3],fromList [10,20]) +-- >>> unalign (align (Seq.fromList [1,2]) (Seq.fromList [10,20,30]) :: This Seq NonEmpty Int Int) +-- (fromList [1,2],fromList [10,20,30]) +instance Unalign Seq NonEmpty where + unalign (This pairs mleftover) = + let (as, bs) = unzipSeq pairs + in case mleftover of + Nothing -> (as, bs) + Just (Left ga) -> (as Seq.>< fromNonEmpty ga, bs) + Just (Right gb) -> (as, bs Seq.>< fromNonEmpty gb) + where + unzipSeq s = case Seq.viewl s of + Seq.EmptyL -> (Seq.empty, Seq.empty) + (a, b) Seq.:< rest -> + let (as, bs) = unzipSeq rest + in (a Seq.<| as, b Seq.<| bs) + fromNonEmpty (x :| xs) = x Seq.<| Seq.fromList xs + {-# INLINE unalign #-} + +-- | Unalign instance for Vector - unzip and append leftovers +-- +-- >>> unalign (align (Vector.fromList [1,2,3]) (Vector.fromList [10,20]) :: This Vector NonEmpty Int Int) +-- ([1,2,3],[10,20]) +-- >>> unalign (align (Vector.fromList [1,2]) (Vector.fromList [10,20,30]) :: This Vector NonEmpty Int Int) +-- ([1,2],[10,20,30]) +instance Unalign Vector NonEmpty where + unalign (This pairs mleftover) = + let (as, bs) = Vector.unzip pairs + in case mleftover of + Nothing -> (as, bs) + Just (Left ga) -> (as Vector.++ fromNonEmpty ga, bs) + Just (Right gb) -> (as, bs Vector.++ fromNonEmpty gb) + where + fromNonEmpty (x :| xs) = Vector.cons x (Vector.fromList xs) + {-# INLINABLE unalign #-} + +-- Note: Map and IntMap do NOT have Unalign instances because their Semialign +-- instances violate the roundtrip law. When both sides have leftovers, align +-- keeps only left leftovers (left takes precedence), so unalign cannot recover +-- the original right-side keys. We prefer to have a lawful type class rather +-- than instances with caveats. + +-- * Law-checking functions +-- +-- These functions can be used in property-based tests to verify that +-- instances satisfy the required laws. + +-- | Test the naturality law for Semialign +-- +-- Property: @bimap f g (align xs ys) ≡ align (fmap f xs) (fmap g ys)@ +-- +-- >>> semialignNaturality (*10) (*100) [1,2,3] [4,5] :: Bool +-- True +-- >>> semialignNaturality (*10) (*100) [1,2] [3,4,5] :: Bool +-- True +semialignNaturality :: + (Semialign f g, Eq1 f, Eq1 g, Eq c, Eq d) => + (a -> c) -> + (b -> d) -> + f a -> + f b -> + Bool +semialignNaturality f g xs ys = + liftEq2 (==) (==) (bimap f g (align xs ys)) (align (fmap f xs) (fmap g ys)) + +-- | Test the symmetry law for Semialign +-- +-- Property: @align x y ≡ swap (align y x)@ +-- +-- >>> semialignSymmetry [1,2,3] [4,5] :: Bool +-- True +-- >>> semialignSymmetry [1,2] [3,4,5] :: Bool +-- True +-- >>> semialignSymmetry (Just 1) (Just 2) :: Bool +-- True +semialignSymmetry :: + (Semialign f g, Eq1 f, Eq1 g, Eq a, Eq b) => + f a -> + f b -> + Bool +semialignSymmetry x y = + liftEq2 (==) (==) (align x y) (swap (align y x)) + +-- | Test the coherence law between align and alignWith +-- +-- Property: @align x y ≡ alignWith id id id x y@ +-- +-- >>> semialignCoherence [1,2,3] [4,5] :: Bool +-- True +-- >>> semialignCoherence (Just 1) (Just 2) :: Bool +-- True +semialignCoherence :: + (Semialign f g, Eq1 f, Eq1 g, Eq a, Eq b) => + f a -> + f b -> + Bool +semialignCoherence x y = + liftEq2 (==) (==) (align x y) (alignWith id id id x y) + +-- | Test the alignWith transformation law +-- +-- Property: @alignWith f g h x y ≡ let This t r = align x y in This (fmap f t) (fmap (bimap (fmap g) (fmap h)) r)@ +-- +-- >>> semialignWithLaw (\(a,b) -> (a*10, b*100)) (*10) (*100) [1,2,3] [4,5] :: Bool +-- True +semialignWithLaw :: + (Semialign f g, Eq1 f, Eq1 g, Eq c, Eq d) => + ((a, b) -> (c, d)) -> + (a -> c) -> + (b -> d) -> + f a -> + f b -> + Bool +semialignWithLaw f g h x y = + let result1 = alignWith f g h x y + This t r = align x y + result2 = This (fmap f t) (fmap (bimap (fmap g) (fmap h)) r) + in liftEq2 (==) (==) result1 result2 + +-- | Test the right identity law for Align +-- +-- Property: When aligning with nil on the right, paired part is empty +-- +-- >>> alignRightIdentity [1,2,3] ([] :: [Char]) +-- True +-- >>> alignRightIdentity (Just 42) (Nothing :: Maybe Char) +-- True +-- >>> alignRightIdentity ([] :: [Int]) ([] :: [Char]) +-- True +alignRightIdentity :: + (Align f g, Eq1 f, Eq a, Eq b) => + f a -> + f b -> + Bool +alignRightIdentity x emptyY = + case align x emptyY of + This t Nothing -> liftEq (==) t nil + This t (Just (Left _)) -> liftEq (==) t nil + _ -> False + +-- | Test the left identity law for Align +-- +-- Property: When aligning with nil on the left, paired part is empty +-- +-- >>> alignLeftIdentity ([] :: [Char]) [1,2,3] +-- True +-- >>> alignLeftIdentity (Nothing :: Maybe Char) (Just 42) +-- True +-- >>> alignLeftIdentity ([] :: [Char]) ([] :: [Int]) +-- True +alignLeftIdentity :: + (Align f g, Eq1 f, Eq a, Eq b) => + f a -> + f b -> + Bool +alignLeftIdentity emptyX y = + case align emptyX y of + This t Nothing -> liftEq (==) t nil + This t (Just (Right _)) -> liftEq (==) t nil + _ -> False + +-- | Test the empty alignment law for Align +-- +-- Property: @align nil nil ≡ This nil Nothing@ +-- +-- This function requires proxy arguments to determine the functor and element types. +-- You can pass undefined or use type applications with @TypeApplications@. +-- +-- >>> alignEmpty (undefined :: [Int]) (undefined :: [Int]) +-- True +-- >>> alignEmpty (undefined :: Maybe Int) (undefined :: Maybe Int) +-- True +alignEmpty :: + forall f g a. + (Align f g, Eq1 f, Eq1 g, Eq a) => + f a -> + f a -> + Bool +alignEmpty _ _ = + liftEq2 (==) (==) + (align (nil :: f a) (nil :: f a)) + (This (nil :: f (a, a)) Nothing) + +-- | Test the roundtrip law for Unalign +-- +-- Property: @unalign (align xs ys) ≡ (xs, ys)@ +-- +-- >>> unalignRoundtrip [1,2,3] [10,20] +-- True +-- >>> unalignRoundtrip [1,2] [10,20,30] +-- True +-- >>> unalignRoundtrip (Just 1) (Just 2) +-- True +-- >>> unalignRoundtrip (Nothing :: Maybe Int) (Just 2) +-- True +unalignRoundtrip :: + (Unalign f g, Eq1 f, Eq a, Eq b) => + f a -> + f b -> + Bool +unalignRoundtrip xs ys = + let (xs', ys') = unalign (align xs ys) + in liftEq (==) xs xs' && liftEq (==) ys ys' + +-- | Test the naturality law for Unalign +-- +-- Property: @bimap (fmap f) (fmap g) (unalign t) ≡ unalign (bimap f g t)@ +-- +-- >>> let t = This [(1,2),(3,4)] (Just (Left (5 :| []))) :: This [] NonEmpty Int Int +-- >>> unalignNaturality (*10) (*100) t +-- True +unalignNaturality :: + (Unalign f g, Eq1 f, Eq c, Eq d) => + (a -> c) -> + (b -> d) -> + This f g a b -> + Bool +unalignNaturality f g t = + let (as, bs) = unalign t + (as', bs') = unalign (bimap f g t) + in liftEq (==) (fmap f as) as' && liftEq (==) (fmap g bs) bs' + +-- | Lens focusing on the matched pairs component +-- +-- >>> import Control.Lens (view, set) +-- >>> view these (This [(1,2),(3,4)] Nothing :: This [] NonEmpty Int Int) +-- [(1,2),(3,4)] +-- >>> set these [(5,6)] (This [(1,2)] Nothing :: This [] NonEmpty Int Int) +-- This [(5,6)] Nothing +these :: Lens (This f g a b) (This f' g a b) (f (a, b)) (f' (a, b)) +these f (This e o) = fmap (`This` o) (f e) +{-# INLINE these #-} + +-- | Lens focusing on the leftover component +-- +-- >>> import Control.Lens (view, set) +-- >>> view those (This [(1,2)] (Just (Left (3 :| []))) :: This [] NonEmpty Int Int) +-- Just (Left (3 :| [])) +-- >>> set those (Nothing :: Maybe (Either (NonEmpty Int) (NonEmpty Int))) (This [(1,2)] (Just (Left (3 :| []))) :: This [] NonEmpty Int Int) +-- This [(1,2)] Nothing +those :: Lens (This f g a b) (This f g' a b) (Maybe (Either (g a) (g b))) (Maybe (Either (g' a) (g' b))) +those f (This e o) = fmap (This e) (f o) +{-# INLINE those #-} + +-- | Traversal focusing on left leftovers +-- +-- >>> import Control.Lens (view, toListOf) +-- >>> toListOf thoseLeft (This [(1,2)] (Just (Left (3 :| [4]))) :: This [] NonEmpty Int Int) +-- [3 :| [4]] +-- >>> toListOf thoseLeft (This [(1,2)] (Just (Right (3 :| [4]))) :: This [] NonEmpty Int Int) +-- [] +thoseLeft :: Traversal' (This f g a b) (g a) +thoseLeft = those . traverse . _Left +{-# INLINE thoseLeft #-} + +-- | Traversal focusing on right leftovers +-- +-- >>> import Control.Lens (toListOf) +-- >>> toListOf thoseRight (This [(1,2)] (Just (Right (3 :| [4]))) :: This [] NonEmpty Int Int) +-- [3 :| [4]] +-- >>> toListOf thoseRight (This [(1,2)] (Just (Left (3 :| [4]))) :: This [] NonEmpty Int Int) +-- [] +thoseRight :: Traversal' (This f g a b) (g b) +thoseRight = those . traverse . _Right +{-# INLINE thoseRight #-} + +-- | Traversal focusing on all 'a' values in This +-- Touches 'a' in the tuples (a,b) and in Left (g a) +-- +-- >>> import Control.Lens (over, toListOf) +-- >>> over traverseA (*10) (This [(1,2),(3,4)] Nothing :: This [] NonEmpty Int Int) +-- This [(10,2),(30,4)] Nothing +-- >>> over traverseA (*10) (This [(1,2)] (Just (Left (3 :| [4]))) :: This [] NonEmpty Int Int) +-- This [(10,2)] (Just (Left (30 :| [40]))) +-- >>> toListOf traverseA (This [(1,2),(3,4)] (Just (Left (5 :| []))) :: This [] NonEmpty Int Int) +-- [1,3,5] +traverseA :: + (Traversable f, Traversable g) => + Traversal (This f g a b) (This f g a' b) a a' +traverseA h (This t r) = + This + <$> traverse (\(a, b) -> (,b) <$> h a) t + <*> traverse (either (fmap Left . traverse h) (pure . Right)) r +{-# INLINABLE traverseA #-} + +-- | Traversal focusing on all 'b' values in This +-- Touches 'b' in the tuples (a,b) and in Right (g b) +-- +-- >>> import Control.Lens (over, toListOf) +-- >>> over traverseB (*10) (This [(1,2),(3,4)] Nothing :: This [] NonEmpty Int Int) +-- This [(1,20),(3,40)] Nothing +-- >>> over traverseB (*10) (This [(1,2)] (Just (Right (3 :| [4]))) :: This [] NonEmpty Int Int) +-- This [(1,20)] (Just (Right (30 :| [40]))) +-- >>> toListOf traverseB (This [(1,2),(3,4)] (Just (Right (5 :| []))) :: This [] NonEmpty Int Int) +-- [2,4,5] +traverseB :: + (Traversable f, Traversable g) => + Traversal (This f g a b) (This f g a b') b b' +traverseB h (This t r) = + This + <$> traverse (\(a, b) -> (a,) <$> h b) t + <*> traverse (either (pure . Left) (fmap Right . traverse h)) r +{-# INLINABLE traverseB #-} + +-- | Traversal1 focusing on all 'a' values in This (at least one) +-- Uses Apply instead of Applicative +-- +-- >>> import Control.Lens (over) +-- >>> over traverseA1 (*10) (This ((1,2) :| [(3,4)]) Nothing :: This NonEmpty NonEmpty Int Int) +-- This ((10,2) :| [(30,4)]) Nothing +-- >>> over traverseA1 (*10) (This ((1,2) :| []) (Just (Left (3 :| [4]))) :: This NonEmpty NonEmpty Int Int) +-- This ((10,2) :| []) (Just (Left (30 :| [40]))) +traverseA1 :: + (Traversable1 f, Traversable1 g) => + Traversal1 (This f g a b) (This f g a' b) a a' +traverseA1 h (This t r) = + let tResult = traverse1 (\(a, b) -> (,b) <$> h a) t + in case r of + Nothing -> (`This` Nothing) <$> tResult + Just (Left ga) -> (\t' ga' -> This t' (Just (Left ga'))) <$> tResult <.> traverse1 h ga + Just (Right gb) -> (\t' -> This t' (Just (Right gb))) <$> tResult +{-# INLINABLE traverseA1 #-} + +-- | Traversal1 focusing on all 'b' values in This (at least one) +-- Uses Apply instead of Applicative +-- +-- >>> import Control.Lens (over) +-- >>> over traverseB1 (*10) (This ((1,2) :| [(3,4)]) Nothing :: This NonEmpty NonEmpty Int Int) +-- This ((1,20) :| [(3,40)]) Nothing +-- >>> over traverseB1 (*10) (This ((1,2) :| []) (Just (Right (3 :| [4]))) :: This NonEmpty NonEmpty Int Int) +-- This ((1,20) :| []) (Just (Right (30 :| [40]))) +traverseB1 :: + (Traversable1 f, Traversable1 g) => + Traversal1 (This f g a b) (This f g a b') b b' +traverseB1 h (This t r) = + let tResult = traverse1 (\(a, b) -> (a,) <$> h b) t + in case r of + Nothing -> (`This` Nothing) <$> tResult + Just (Left ga) -> (\t' -> This t' (Just (Left ga))) <$> tResult + Just (Right gb) -> (\t' gb' -> This t' (Just (Right gb'))) <$> tResult <.> traverse1 h gb +{-# INLINABLE traverseB1 #-} + +-- | Fold optic over all 'a' values in This +-- +-- >>> import Control.Lens (toListOf) +-- >>> toListOf foldA (This [(1,2),(3,4)] Nothing :: This [] NonEmpty Int Int) +-- [1,3] +-- >>> toListOf foldA (This [(1,2)] (Just (Left (3 :| [4]))) :: This [] NonEmpty Int Int) +-- [1,3,4] +-- >>> toListOf foldA (This [(1,2)] (Just (Right (3 :| [4]))) :: This [] NonEmpty Int Int) +-- [1] +foldA :: (Foldable f, Foldable g) => Fold (This f g a b) a +foldA h x@(This t r) = + x <$ (traverse_ (\(a, _) -> h a) t <* traverse_ (either (traverse_ h) (pure (pure ()))) r) +{-# INLINE foldA #-} + +-- | Fold optic over all 'b' values in This +-- +-- >>> import Control.Lens (toListOf) +-- >>> toListOf foldB (This [(1,2),(3,4)] Nothing :: This [] NonEmpty Int Int) +-- [2,4] +-- >>> toListOf foldB (This [(1,2)] (Just (Right (3 :| [4]))) :: This [] NonEmpty Int Int) +-- [2,3,4] +-- >>> toListOf foldB (This [(1,2)] (Just (Left (3 :| [4]))) :: This [] NonEmpty Int Int) +-- [2] +foldB :: (Foldable f, Foldable g) => Fold (This f g a b) b +foldB h x@(This t r) = + x <$ (traverse_ (\(_, b) -> h b) t <* traverse_ (either (pure (pure ())) (traverse_ h)) r) +{-# INLINE foldB #-} + +-- | Fold1 optic over all 'a' values in This (at least one) +-- +-- >>> import Control.Lens (toListOf) +-- >>> toListOf foldA1 (This ((1,2) :| [(3,4)]) Nothing :: This NonEmpty NonEmpty Int Int) +-- [1,3] +-- >>> toListOf foldA1 (This ((1,2) :| []) (Just (Left (3 :| [4]))) :: This NonEmpty NonEmpty Int Int) +-- [1,3,4] +foldA1 :: (Foldable1 f, Foldable1 g) => Fold1 (This f g a b) a +foldA1 h x@(This t r) = + let ese = traverse1_ (\(a, _) -> h a) t + in x <$ case r of + Nothing -> ese + Just (Left ga) -> ese .> traverse1_ h ga + Just (Right _) -> ese +{-# INLINE foldA1 #-} + +-- | Fold1 optic over all 'b' values in This (at least one) +-- +-- >>> import Control.Lens (toListOf) +-- >>> toListOf foldB1 (This ((1,2) :| [(3,4)]) Nothing :: This NonEmpty NonEmpty Int Int) +-- [2,4] +-- >>> toListOf foldB1 (This ((1,2) :| []) (Just (Right (3 :| [4]))) :: This NonEmpty NonEmpty Int Int) +-- [2,3,4] +foldB1 :: (Foldable1 f, Foldable1 g) => Fold1 (This f g a b) b +foldB1 h x@(This t r) = + let ese = traverse1_ (\(_, b) -> h b) t + in x <$ case r of + Nothing -> ese + Just (Left _) -> ese + Just (Right gb) -> ese .> traverse1_ h gb +{-# INLINE foldB1 #-} + +-- | Traverse with at least one element, discarding results +-- Uses Apply to combine effects +-- +-- >>> traverse1_ Just (1 :| [2,3]) +-- Just () +traverse1_ :: (Foldable1 t, Apply f) => (a -> f b) -> t a -> f () +traverse1_ f xs = case toNonEmpty xs of + (x :| []) -> f x $> () + (x :| (y : ys)) -> f x .> traverse1_ f (y :| ys) + where + toNonEmpty = foldMap1 (:| []) +{-# INLINABLE traverse1_ #-} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,17 @@ +module Main where + +import System.Exit (exitWith) +import System.Process (rawSystem) + +main :: IO () +main = + exitWith + =<< rawSystem + "cabal" + [ "repl", + "--with-compiler=doctest", + "--repl-options=-w", + "--repl-options=-Wdefault", + "--repl-options=-Wno-inline-rule-shadowing", + "lib:alignment" + ]