alignment-0.2.0.1: src/Data/Alignment.hs
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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 (..),
-- * Zip and unzip (dropping leftovers)
zip,
unzip,
-- * 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.Biapplicative (Biapplicative (..))
import Data.Bifoldable (Bifoldable (bifoldMap))
import Data.Bifunctor (Bifunctor (bimap), second)
import Data.Bifunctor.Apply (Biapply (..))
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.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.Tuple (uncurry)
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)
import Witherable (Filterable (..), Witherable (..))
-- $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(..))
-- >>> import Hedgehog
-- >>> import qualified Hedgehog.Gen as Gen
-- >>> import qualified Hedgehog.Range as Range
-- >>> let genList = Gen.list (Range.linear 0 20) (Gen.int (Range.linear (-100) 100))
-- >>> let genNonEmpty g = (:|) <$> g <*> genList
-- >>> let genInt = Gen.int (Range.linear (-100) 100)
-- | 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)
-- | Biapply instance - applies bifunctions to bivalues
--
-- The Biapply instance combines two This values by:
-- - Applying paired functions to paired values using Apply on the container f
-- - Applying functions in left leftovers to values in left leftovers using Apply on g
-- - Applying functions in right leftovers to values in right leftovers using Apply on g
--
-- This enables biapplicative-style computations without requiring bipure.
--
-- >>> This [((\x -> x * 10), (\y -> y * 100))] Nothing <<.>> This [(1, 2)] Nothing :: This [] NonEmpty Int Int
-- This [(10,200)] Nothing
-- >>> This [] (Just (Left ((+1) :| []))) <<.>> This [] (Just (Left (5 :| []))) :: This [] NonEmpty Int Int
-- This [] (Just (Left (6 :| [])))
-- >>> This [] (Just (Right ((+10) :| []))) <<.>> This [] (Just (Right (5 :| []))) :: This [] NonEmpty Int Int
-- This [] (Just (Right (15 :| [])))
instance (Apply f, Apply g) => Biapply (This f g) where
This tf tr <<.>> This tx xr =
This (liftF2 applyPair tf tx) (applyLeftovers tr xr)
where
applyPair (fa, fb) (a, b) = (fa a, fb b)
liftF2 h fa fb = h <$> fa <.> fb
applyLeftovers Nothing Nothing = Nothing
applyLeftovers (Just _) Nothing = Nothing -- Can't apply without values
applyLeftovers Nothing (Just _) = Nothing -- Can't apply without functions
applyLeftovers (Just (Left gfa)) (Just (Left ga)) = Just (Left (gfa <.> ga))
applyLeftovers (Just (Right gfb)) (Just (Right gb)) = Just (Right (gfb <.> gb))
applyLeftovers (Just (Left _)) (Just (Right _)) = Nothing -- Type mismatch
applyLeftovers (Just (Right _)) (Just (Left _)) = Nothing -- Type mismatch
{-# INLINE (<<.>>) #-}
-- | Biapplicative instance - pure bifunctor with application
--
-- The Biapplicative instance provides 'bipure' which lifts two values into a This
-- with a single matched pair and no leftovers. This requires the container f to be
-- Applicative so we can create the paired structure.
--
-- This is useful for building This values from pure values and then combining them
-- with applicative operations.
--
-- >>> bipure 1 2 :: This [] NonEmpty Int Int
-- This [(1,2)] Nothing
-- >>> bipure 'a' 'b' :: This Maybe Identity Char Char
-- This (Just ('a','b')) Nothing
-- >>> bipure (+10) (*20) <<*>> bipure 1 2 :: This [] NonEmpty Int Int
-- This [(11,40)] Nothing
instance (Applicative f, Applicative g) => Biapplicative (This f g) where
bipure a b = This (pure (a, b)) Nothing
{-# INLINE bipure #-}
-- Implementation matches Biapply but uses Applicative operations
This tf tr <<*>> This tx xr =
This (applyPair <$> tf <*> tx) (applyLeftovers tr xr)
where
applyPair (fa, fb) (a, b) = (fa a, fb b)
applyLeftovers Nothing Nothing = Nothing
applyLeftovers (Just _) Nothing = Nothing -- Can't apply without values
applyLeftovers Nothing (Just _) = Nothing -- Can't apply without functions
applyLeftovers (Just (Left gfa)) (Just (Left ga)) = Just (Left (gfa <*> ga))
applyLeftovers (Just (Right gfb)) (Just (Right gb)) = Just (Right (gfb <*> gb))
applyLeftovers (Just (Left _)) (Just (Right _)) = Nothing -- Type mismatch
applyLeftovers (Just (Right _)) (Just (Left _)) = Nothing -- Type mismatch
{-# INLINE (<<*>>) #-}
-- | Filterable instance - filter elements based on a predicate
--
-- The Filterable instance allows filtering values in the b position while
-- preserving the structure. This is useful for removing unwanted alignment
-- results or transforming values that might fail.
--
-- >>> mapMaybe (\x -> if even x then Just (x * 10) else Nothing) (This [(1,2),(3,4)] Nothing :: This [] Maybe Int Int)
-- This [(1,20),(3,40)] Nothing
-- >>> mapMaybe (\x -> if x > 10 then Just x else Nothing) (This [(1,2)] (Just (Right (Just 15))) :: This [] Maybe Int Int)
-- This [(1,2)] (Just (Right (Just 15)))
-- >>> catMaybes (This [(1, Just 2), (3, Nothing)] Nothing :: This [] Maybe Int (Maybe Int))
-- This [(1,2)] Nothing
instance (Filterable f, Filterable g) => Filterable (This f g a) where
mapMaybe f (This t r) =
This (mapMaybe filterPair t) (fmap (fmap (mapMaybe f)) r)
where
filterPair (a, b) = case f b of
Nothing -> Nothing
Just c -> Just (a, c)
{-# INLINE mapMaybe #-}
-- | Witherable instance - filter with effects
--
-- The Witherable instance extends Filterable to support effectful filtering.
-- This is useful when the filtering predicate needs to perform IO, access
-- state, or use other effects.
--
-- >>> wither (\x -> if even x then Just (Just (x * 10)) else Just Nothing) (This [(1,2),(3,4)] Nothing :: This [] Maybe Int Int)
-- Just (This [(1,20),(3,40)] Nothing)
-- >>> wither (\x -> if x > 10 then pure (Just x) else pure Nothing) (This [(1,2)] (Just (Right (Just 15))) :: This [] Maybe Int Int)
-- Just (This [(1,2)] (Just (Right (Just 15))))
instance (Witherable f, Witherable g) => Witherable (This f g a) where
wither f (This t r) =
This <$> wither witherPair t <*> traverse (traverse (wither f)) r
where
witherPair (a, b) =
fmap (fmap (a,)) (f b)
{-# INLINE wither #-}
-- | 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
{-# INLINEABLE 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
{-# INLINEABLE 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
{-# INLINEABLE 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)
{-# INLINEABLE 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
{-# INLINEABLE 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
{-# INLINEABLE 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
{-# INLINEABLE 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
{-# INLINEABLE 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 #-}
-- | 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@.
--
-- 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 #-}
-- | Zip two functors together, dropping any leftover elements
--
-- This is like 'align' but extracts only the matched pairs, discarding
-- leftovers. It behaves like Prelude's 'Prelude.zip' but works for any
-- Semialign instance.
--
-- >>> Data.Alignment.zip [1,2,3] [10,20] :: [(Int, Int)]
-- [(1,10),(2,20)]
-- >>> Data.Alignment.zip [1,2] [10,20,30] :: [(Int, Int)]
-- [(1,10),(2,20)]
-- >>> Data.Alignment.zip [1,2] [10,20] :: [(Int, Int)]
-- [(1,10),(2,20)]
-- >>> Data.Alignment.zip (Just 1) (Just 2) :: Maybe (Int, Int)
-- Just (1,2)
-- >>> Data.Alignment.zip (Just 1) Nothing :: Maybe (Int, Int)
-- Nothing
-- >>> Data.Alignment.zip (1 :| [2,3]) (10 :| [20]) :: NonEmpty (Int, Int)
-- (1,10) :| [(2,20)]
zip ::
(Semialign f g) =>
f a ->
f b ->
f (a, b)
zip xs ys = view these (align xs ys)
{-# INLINE zip #-}
-- | Unzip a functor of pairs into a pair of functors, dropping leftovers
--
-- This is the inverse of 'zip'. For Unalign instances, it extracts the
-- two components from a paired structure.
--
-- >>> Data.Alignment.unzip [(1,10),(2,20)] :: ([Int], [Int])
-- ([1,2],[10,20])
-- >>> Data.Alignment.unzip (Just (1,2)) :: (Maybe Int, Maybe Int)
-- (Just 1,Just 2)
-- >>> Data.Alignment.unzip Nothing :: (Maybe Int, Maybe Int)
-- (Nothing,Nothing)
-- >>> Data.Alignment.unzip ((1,10) :| [(2,20)]) :: (NonEmpty Int, NonEmpty Int)
-- (1 :| [2],10 :| [20])
--
-- Note: This produces the same paired results as 'unalign', but any
-- leftovers present in the original alignment are lost.
unzip ::
(Unalign f g, Functor f) =>
f (a, b) ->
(f a, f b)
unzip pairs = unalign (This pairs Nothing)
{-# INLINE unzip #-}
-- * 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
{-# INLINEABLE 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)
{-# INLINEABLE 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)
{-# INLINEABLE unalign #-}
-- * 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)@
--
-- This law states that mapping over the aligned result is the same as
-- mapping over the inputs before alignment. This is a key law for functoriality.
--
-- >>> semialignNaturality (*10) (*100) [1,2,3] [4,5] :: Bool
-- True
-- >>> semialignNaturality (*10) (*100) [1,2] [3,4,5] :: Bool
-- True
-- >>> semialignNaturality (+ 1) (* 2) (Just 5) (Just 10) :: Bool
-- True
-- >>> semialignNaturality (+ 1) (* 2) (1 :| [2]) (3 :| [4,5]) :: Bool
-- True
--
-- Hedgehog property test:
--
-- >>> check $ withTests 20 $ property $ do xs <- forAll genList; ys <- forAll genList; semialignNaturality (+1) (*2) xs ys === True
-- ✓ <interactive> passed 20 tests.
-- 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)@
--
-- This law ensures that alignment is symmetric - the order of arguments
-- only affects whether leftovers appear on the left or right side.
--
-- >>> semialignSymmetry [1,2,3] [4,5] :: Bool
-- True
-- >>> semialignSymmetry [1,2] [3,4,5] :: Bool
-- True
-- >>> semialignSymmetry (Just 1) (Just 2) :: Bool
-- True
-- >>> semialignSymmetry (1 :| [2,3]) (10 :| [20]) :: Bool
-- True
--
-- Hedgehog property test:
--
-- >>> check $ withTests 20 $ property $ do xs <- forAll genList; ys <- forAll genList; semialignSymmetry xs ys === True
-- ✓ <interactive> passed 20 tests.
-- 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@
--
-- This law ensures that align and alignWith are coherent - align is
-- just alignWith with identity transformations.
--
-- >>> semialignCoherence [1,2,3] [4,5] :: Bool
-- True
-- >>> semialignCoherence (Just 1) (Just 2) :: Bool
-- True
-- >>> semialignCoherence (1 :| [2]) (3 :| [4,5]) :: 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)@
--
-- This law specifies the correct behavior of alignWith in terms of align
-- followed by mapping transformations.
--
-- >>> semialignWithLaw (\(a,b) -> (a*10, b*100)) (*10) (*100) [1,2,3] [4,5] :: Bool
-- True
-- >>> semialignWithLaw (\(a,b) -> (a+1, b*2)) (+1) (*2) (Just 5) (Just 10) :: 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
--
-- This law ensures that nil acts as a right identity for alignment,
-- producing only left leftovers with no matched pairs.
--
-- >>> 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
--
-- This law ensures that nil acts as a left identity for alignment,
-- producing only right leftovers with no matched pairs.
--
-- >>> 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)@
--
-- This is the fundamental law of Unalign: unalign is the inverse of align.
-- It ensures that alignment is completely lossless for Unalign instances.
--
-- >>> 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 (1 :| [2,3]) (10 :| [20])
-- True
--
-- Hedgehog property test:
--
-- >>> check $ withTests 20 $ property $ do xs <- forAll genList; ys <- forAll genList; unalignRoundtrip xs ys === True
-- ✓ <interactive> passed 20 tests.
-- 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)@
--
-- This law ensures that unalign commutes with mapping transformations,
-- preserving the functorial structure.
--
-- >>> let t = This [(1,2),(3,4)] (Just (Left (5 :| []))) :: This [] NonEmpty Int Int
-- >>> unalignNaturality (*10) (*100) t
-- True
-- >>> let t2 = This [(1,2)] Nothing :: This [] NonEmpty Int Int
-- >>> unalignNaturality (+1) (*2) t2
-- 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
{-# INLINEABLE 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
{-# INLINEABLE 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
{-# INLINEABLE 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
{-# INLINEABLE 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 (:| [])
{-# INLINEABLE traverse1_ #-}