alignment-0.2.0.0: src/Data/Alignment.hs

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