alignment 0.1.0.6 → 0.2.0.0

raw patch · 6 files changed

+1934/−714 lines, 6 filesdep +alignmentdep +containersdep +criteriondep ~basedep ~lensdep ~semigroupoidsPVP ok

version bump matches the API change (PVP)

Dependencies added: alignment, containers, criterion, deepseq, process, vector

Dependency ranges changed: base, lens, semigroupoids

API changes (from Hackage documentation)

Files

• LICENCE +1/−1
• alignment.cabal +106/−32
• bench/Main.hs +160/−0
• changelog.md +31/−0
• src/Data/Alignment.hs +1619/−681
• test/Main.hs +17/−0

@@ -1,4 +1,4 @@-Copyright (c) 2022-2025 Tony Morris+Copyright (c) 2022-2026 Tony Morris  All rights reserved. 

@@ -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-  .-  <<https://logo.systemf.com.au/systemf-450x450.png>>-license:                BSD3-license-file:           LICENCE-author:                 Tony Morris <oᴉ˙ldɟb@llǝʞsɐɥ>-maintainer:             Tony Morris <oᴉ˙ldɟb@llǝʞsɐɥ>-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 :| [])))+                      .+                      <<https://logo.systemf.com.au/systemf-450x450.png>>+license:              BSD-3-Clause+license-file:         LICENCE+author:               Tony Morris <oᴉ˙ldɟb@llǝʞsɐɥ>+maintainer:           Tony Morris <oᴉ˙ldɟb@llǝʞsɐɥ>+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

@@ -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)

@@ -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

@@ -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_ #-}

@@ -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"+      ]