semialign-1.1.0.1/0000755000000000000000000000000007346545000012011 5ustar0000000000000000semialign-1.1.0.1/CHANGELOG.md0000644000000000000000000000171607346545000013627 0ustar0000000000000000# 1.1.0.1 - Drop `base-compat` dependency # 1.1 - Split `Semialign` into `Semialign` and `Zip`. - Rename old `Zip` into `Repeat` - i.e. current main hierarchy is - Remove `malign`, use `salign` or `alignWith mappend` where `Monoid` is necessary. - Add `Option` instances ```haskell instance Functor f => Semialign f where alignWith :: (These a b -> c) -> f a -> f b -> f c instance Semialign f => Align f where nil :: f a instance Semialign f => Zip f where zipWith :: (a -> b -> c) -> f a -> f b -> f c instance Zip f => Repeat f where repeat :: a -> f a ``` This biased choice, that `Semialign` is a super-class of `Zip` is motivated by the fact that - There's no `Semialign`-like class anywhere else, yet - `Zip` and `Repeat` are `Apply` (from `semigroupoids`) and `Applicative` with slightly more laws. I If you need only `Repeat` class, and your type isn't `Aling`able, maybe using `Applicative` is enough? # 1 Split out of `these` package. semialign-1.1.0.1/LICENSE0000644000000000000000000000300407346545000013013 0ustar0000000000000000Copyright (c) 2012, C. McCann, 2015-2019 Oleg Grenrus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of C. McCann nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. semialign-1.1.0.1/semialign.cabal0000644000000000000000000000461407346545000014752 0ustar0000000000000000cabal-version: >=1.10 name: semialign version: 1.1.0.1 synopsis: Align and Zip type-classes from the common Semialign ancestor. homepage: https://github.com/isomorphism/these license: BSD3 license-file: LICENSE author: C. McCann, Oleg Grenrus maintainer: Oleg Grenrus category: Data, These build-type: Simple extra-source-files: CHANGELOG.md description: The major use of @These@ of this is provided by the @align@ member of @Semialign@ class, representing a generalized notion of "zipping with padding" that combines structures without truncating to the size of the smaller input. . It turns out that @zip@ operation fits well the @Semialign@ class, forming lattice-like structure. tested-with: GHC ==7.4.2 || ==7.6.3 || ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1 , GHCJS ==8.4 source-repository head type: git location: https://github.com/isomorphism/these.git flag semigroupoids description: Build with semigroupoids dependency manual: True default: True library default-language: Haskell2010 ghc-options: -Wall if impl(ghc >=8.0) ghc-options: -Wno-trustworthy-safe hs-source-dirs: src exposed-modules: Data.Align Data.Crosswalk Data.Semialign Data.Zip other-modules: Data.Semialign.Internal -- ghc boot libs build-depends: base >=4.5.1.0 && <4.15 , containers >=0.4.2.1 && <0.7 , transformers >=0.3.0.0 && <0.6 -- These build-depends: these >=1 && <1.2 -- other dependencies build-depends: hashable >=1.2.7.0 && <1.4 , tagged >=0.8.6 && <0.9 , unordered-containers >=0.2.8.0 && <0.3 , vector >=0.12.0.2 && <0.13 -- base shims if !impl(ghc >=8.2) build-depends: bifunctors >=5.5.4 && <5.6 if !impl(ghc >=8.0) build-depends: semigroups >=0.18.5 && <0.20 , transformers >=0.3.0.0 && <0.6 , transformers-compat >=0.6.5 && <0.7 -- Ensure Data.Functor.Classes is always available if impl(ghc >=7.10) build-depends: transformers >=0.4.2.0 if impl(ghc <7.5) build-depends: ghc-prim if flag(semigroupoids) build-depends: semigroupoids >=5.3.2 && <5.4 semialign-1.1.0.1/src/Data/0000755000000000000000000000000007346545000013451 5ustar0000000000000000semialign-1.1.0.1/src/Data/Align.hs0000644000000000000000000000073007346545000015037 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} -- | 'These'-based aligning and unaligning of functors with non-uniform -- shapes. -- -- For a traversals traversal of (bi)foldable (bi)functors through said -- functors see "Data.Crosswalk". module Data.Align ( Semialign (..), Align (..), Unalign (..), -- * Specialized aligns salign, padZip, padZipWith, lpadZip, lpadZipWith, rpadZip, rpadZipWith, alignVectorWith, ) where import Data.Semialign.Internal semialign-1.1.0.1/src/Data/Crosswalk.hs0000644000000000000000000000712607346545000015763 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} module Data.Crosswalk ( -- * Crosswalk Crosswalk (..), -- * Bicrosswalk Bicrosswalk (..), ) where import Control.Applicative (pure, (<$>)) import Data.Bifoldable (Bifoldable (..)) import Data.Bifunctor (Bifunctor (..)) import Data.Foldable (Foldable (..)) import Data.Functor.Compose (Compose (..)) import Data.Functor.Identity (Identity (..)) import Data.Vector.Generic (Vector) import Prelude (Either (..), Functor (fmap), Maybe (..), id, (.)) import qualified Data.Sequence as Seq import qualified Data.Vector as V import qualified Data.Vector.Generic as VG import Data.Align import Data.These -- -------------------------------------------------------------------------- -- | Foldable functors supporting traversal through an alignable -- functor. -- -- Minimal definition: @crosswalk@ or @sequenceL@. -- -- Laws: -- -- @ -- crosswalk (const nil) = const nil -- crosswalk f = sequenceL . fmap f -- @ class (Functor t, Foldable t) => Crosswalk t where crosswalk :: (Align f) => (a -> f b) -> t a -> f (t b) crosswalk f = sequenceL . fmap f sequenceL :: (Align f) => t (f a) -> f (t a) sequenceL = crosswalk id #if __GLASGOW_HASKELL__ >= 707 {-# MINIMAL crosswalk | sequenceL #-} #endif instance Crosswalk Identity where crosswalk f (Identity a) = fmap Identity (f a) instance Crosswalk Maybe where crosswalk _ Nothing = nil crosswalk f (Just a) = Just <$> f a instance Crosswalk [] where crosswalk _ [] = nil crosswalk f (x:xs) = alignWith cons (f x) (crosswalk f xs) where cons = these pure id (:) instance Crosswalk Seq.Seq where crosswalk f = foldr (alignWith cons . f) nil where cons = these Seq.singleton id (Seq.<|) instance Crosswalk (These a) where crosswalk _ (This _) = nil crosswalk f (That x) = That <$> f x crosswalk f (These a x) = These a <$> f x crosswalkVector :: (Vector v a, Vector v b, Align f) => (a -> f b) -> v a -> f (v b) crosswalkVector f = fmap VG.fromList . VG.foldr (alignWith cons . f) nil where cons = these pure id (:) instance Crosswalk V.Vector where crosswalk = crosswalkVector instance Crosswalk ((,) a) where crosswalk fun (a, x) = fmap ((,) a) (fun x) -- can't (shouldn't) do longer tuples until there are Functor and Foldable -- instances for them instance (Crosswalk f, Crosswalk g) => Crosswalk (Compose f g) where crosswalk f = fmap Compose -- can't coerce: maybe the Align-able thing has role nominal . crosswalk (crosswalk f) . getCompose -- -------------------------------------------------------------------------- -- | Bifoldable bifunctors supporting traversal through an alignable -- functor. -- -- Minimal definition: @bicrosswalk@ or @bisequenceL@. -- -- Laws: -- -- @ -- bicrosswalk (const empty) (const empty) = const empty -- bicrosswalk f g = bisequenceL . bimap f g -- @ class (Bifunctor t, Bifoldable t) => Bicrosswalk t where bicrosswalk :: (Align f) => (a -> f c) -> (b -> f d) -> t a b -> f (t c d) bicrosswalk f g = bisequenceL . bimap f g bisequenceL :: (Align f) => t (f a) (f b) -> f (t a b) bisequenceL = bicrosswalk id id #if __GLASGOW_HASKELL__ >= 707 {-# MINIMAL bicrosswalk | bisequenceL #-} #endif instance Bicrosswalk Either where bicrosswalk f _ (Left x) = Left <$> f x bicrosswalk _ g (Right x) = Right <$> g x instance Bicrosswalk These where bicrosswalk f _ (This x) = This <$> f x bicrosswalk _ g (That x) = That <$> g x bicrosswalk f g (These x y) = align (f x) (g y) semialign-1.1.0.1/src/Data/Semialign.hs0000644000000000000000000000066307346545000015722 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} -- | Zipping and aligning of functors with non-uniform shapes. -- -- module Data.Semialign ( -- * Classes Semialign (..), Align (..), Unalign (..), Zip (..), Repeat (..), Unzip (..), unzipDefault, -- * Specialized aligns salign, padZip, padZipWith, lpadZip, lpadZipWith, rpadZip, rpadZipWith, alignVectorWith, ) where import Data.Semialign.Internal semialign-1.1.0.1/src/Data/Semialign/0000755000000000000000000000000007346545000015361 5ustar0000000000000000semialign-1.1.0.1/src/Data/Semialign/Internal.hs0000644000000000000000000005423107346545000017476 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} module Data.Semialign.Internal where import Prelude (Bool (..), Eq (..), Functor (fmap), Maybe (..), Monad (..), Ord (..), Ordering (..), String, error, flip, fst, id, maybe, snd, uncurry, ($), (++), (.)) import qualified Prelude as Prelude import Control.Applicative (ZipList (..), pure, (<$>)) import Data.Monoid (Monoid (..)) import Data.Bifunctor (Bifunctor (..)) import Data.Functor.Compose (Compose (..)) import Data.Functor.Identity (Identity (..)) import Data.Functor.Product (Product (..)) import Data.Hashable (Hashable (..)) import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (catMaybes) import Data.Proxy (Proxy (..)) import Data.Semigroup (Option (..), Semigroup (..)) import Data.Sequence (Seq) import Data.Tagged (Tagged (..)) import Data.Vector.Fusion.Stream.Monadic (Step (..), Stream (..)) import Data.Vector.Generic (Vector, empty, stream, unstream) import qualified Data.HashMap.Strict as HM import qualified Data.List.NonEmpty as NE import qualified Data.Sequence as Seq import qualified Data.Tree as T import qualified Data.Vector as V import qualified Data.Vector.Fusion.Stream.Monadic as Stream #if MIN_VERSION_vector(0,11,0) import Data.Vector.Fusion.Bundle.Monadic (Bundle (..)) import qualified Data.Vector.Fusion.Bundle.Monadic as Bundle import qualified Data.Vector.Fusion.Bundle.Size as Bundle #else import qualified Data.Vector.Fusion.Stream.Size as Stream #endif #if MIN_VERSION_containers(0,5,0) import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import Data.IntMap.Lazy (IntMap) import qualified Data.IntMap.Lazy as IntMap #if MIN_VERSION_containers(0,5,9) import qualified Data.IntMap.Merge.Lazy as IntMap import qualified Data.Map.Merge.Lazy as Map #endif -- containers <0.5 #else import Data.Map (Map) import qualified Data.Map as Map import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap #endif import Data.These import Data.These.Combinators oops :: String -> a oops = error . ("Data.Align: internal error: " ++) -- -------------------------------------------------------------------------- -- | Functors supporting an 'align' operation that takes the union of -- non-uniform shapes. -- -- Minimal definition: either 'align' or 'alignWith'. -- -- == Laws -- -- The laws of 'align' and 'zip' resemble lattice laws. -- There is a plenty of laws, but they are simply satisfied. -- -- And an addition property if @f@ is 'Foldable', -- which tries to enforce 'align'-feel: -- neither values are duplicated nor lost. -- -- -- /Note:/ @'join' f x = f x x@ -- -- /Idempotency/ -- -- @ -- join align ≡ fmap (join These) -- @ -- -- /Commutativity/ -- -- @ -- align x y ≡ swap \<$> align y x -- @ -- -- /Associativity/ -- -- @ -- align x (align y z) ≡ assoc \<$> align (align x y) z -- @ -- -- /With/ -- -- @ -- alignWith f a b ≡ f \<$> align a b -- @ -- -- /Functoriality/ -- -- @ -- align (f \<$> x) (g \<$> y) ≡ bimap f g \<$> align x y -- @ -- -- /Alignedness/, if @f@ is 'Foldable' -- -- @ -- toList x ≡ toListOf (folded . here) (align x y) -- ≡ mapMaybe justHere (toList (align x y)) -- @ -- -- -- And an addition property if @f@ is 'Foldable', -- which tries to enforce 'align'-feel: -- neither values are duplicated nor lost. -- -- @ -- toList x = toListOf (folded . here) (align x y) -- = mapMaybe justHere (toList (align x y)) -- @ -- class Functor f => Semialign f where -- | Analogous to @'zip'@, combines two structures by taking the union of -- their shapes and using @'These'@ to hold the elements. align :: f a -> f b -> f (These a b) align = alignWith id -- | Analogous to @'zipWith'@, combines two structures by taking the union of -- their shapes and combining the elements with the given function. alignWith :: (These a b -> c) -> f a -> f b -> f c alignWith f a b = f <$> align a b #if __GLASGOW_HASKELL__ >= 707 {-# MINIMAL (align | alignWith) #-} #endif -- | A unit of 'align'. -- -- == Laws -- -- @ -- (\`align` nil) ≡ fmap This -- (nil \`align`) ≡ fmap That -- @ -- class Semialign f => Align f where -- | An empty structure. @'align'@ing with @'nil'@ will produce a structure with -- the same shape and elements as the other input, modulo @'This'@ or @'That'@. nil :: f a -- | -- -- Alignable functors supporting an \"inverse\" to 'align': splitting -- a union shape into its component parts. -- -- == Laws -- -- @ -- uncurry align (unalign xs) ≡ xs -- unalign (align xs ys) ≡ (xs, ys) -- @ -- -- == Compatibility note -- -- In version 1 'unalign' was changed to return @(f a, f b)@ pair, -- instead of @(f (Just a), f (Just b))@. Old behaviour can be achieved with -- if ever needed. -- -- >>> unzipWith (unalign . Just) [This 'a', That 'b', These 'c' 'd'] -- ([Just 'a',Nothing,Just 'c'],[Nothing,Just 'b',Just 'd']) -- class Semialign f => Unalign f where unalign :: f (These a b) -> (f a, f b) unalign = unalignWith id unalignWith :: (c -> These a b) -> f c -> (f a, f b) unalignWith f fx = unalign (fmap f fx) #if __GLASGOW_HASKELL__ >= 707 {-# MINIMAL unalignWith | unalign #-} #endif -- | Functors supporting a 'zip' operation that takes the intersection of -- non-uniform shapes. -- -- Minimal definition: either 'zip' or 'zipWith'. -- -- /Idempotency/ -- -- @ -- join zip ≡ fmap (join (,)) -- @ -- -- /Commutativity/ -- -- @ -- zip x y ≡ swap \<$> zip y x -- @ -- -- /Associativity/ -- -- @ -- zip x (zip y z) ≡ assoc \<$> zip (zip x y) z -- @ -- -- /Absorption/ -- -- @ -- fst \<$> zip xs (align xs ys) ≡ xs -- toThis \<$> align xs (zip xs ys) ≡ This \<$> xs -- where -- toThis (This a) = This a -- toThis (These a _) = This a -- toThis (That b) = That b -- @ -- -- /With/ -- -- @ -- zipWith f a b ≡ f \<$> zip a b -- @ -- -- /Functoriality/ -- -- @ -- zip (f \<$> x) (g \<$> y) ≡ bimap f g \<$> zip x y -- @ -- -- /Zippyness/ -- -- @ -- fmap fst (zip x x) ≡ x -- fmap snd (zip x x) ≡ x -- zip (fmap fst x) (fmap snd x) ≡ x -- @ -- -- /Distributivity/ -- -- @ -- align (zip xs ys) zs ≡ undistrThesePair \<$> zip (align xs zs) (align ys zs) -- distrPairThese \<$> zip (align xs ys) zs ≡ align (zip xs zs) (zip ys zs) -- zip (align xs ys) zs ≡ undistrPairThese \<$> align (zip xs zs) (zip ys zs) -- @ -- -- /Note/, the following doesn't hold: -- -- @ -- distrThesePair \<$> align (zip xs ys) zs ≢ zip (align xs zs) (align ys zs) -- @ -- -- when @xs = []@ and @ys = zs = [0]@, then -- the left hand side is "only" @[('That' 0, 'That' 0)]@, -- but the right hand side is @[('That' 0, 'These' 0 0)]@. -- class Semialign f => Zip f where -- | Combines two structures by taking the intersection of their shapes -- and using pair to hold the elements. zip :: f a -> f b -> f (a, b) zip = zipWith (,) -- -- | Combines two structures by taking the intersection of their shapes -- and combining the elements with the given function. zipWith :: (a -> b -> c) -> f a -> f b -> f c zipWith f a b = uncurry f <$> zip a b #if __GLASGOW_HASKELL__ >= 707 {-# MINIMAL (zip | zipWith) #-} #endif -- | Zippable functors supporting left and right units -- -- /Unit/ -- -- @ -- fst \<$> zip xs (repeat y) ≡ xs -- snd \<$> zip (repeat x) ys ≡ ys -- @ -- class Zip f => Repeat f where -- | A /repeat/ structure. repeat :: a -> f a -- | Right inverse of 'zip'. -- -- This class is definable for every 'Functor'. See 'unzipDefault'. -- -- == Laws -- -- @ -- uncurry zip (unzip xs) ≡ xs -- unzip (zip xs xs) ≡ (xs, xs) -- @ -- -- Note: -- -- @ -- unzip (zip xs ys) ≢ (xs, _) or (_, ys) -- @ -- -- For sequence-like types this holds, but for Map-like it doesn't. -- class Zip f => Unzip f where unzipWith :: (c -> (a, b)) -> f c -> (f a, f b) unzipWith f = unzip . fmap f unzip :: f (a, b) -> (f a, f b) unzip = unzipWith id #if __GLASGOW_HASKELL__ >= 707 {-# MINIMAL unzipWith | unzip #-} #endif unzipDefault :: Functor f => f (a, b) -> (f a, f b) unzipDefault x = (fst <$> x, snd <$> x) ------------------------------------------------------------------------------- -- base ------------------------------------------------------------------------------- instance Semialign ((->) e) where align f g x = These (f x) (g x) alignWith h f g x = h (These (f x) (g x)) instance Zip ((->) e) where zip f g x = (f x, g x) instance Repeat ((->) e) where repeat = pure instance Semialign Maybe where align Nothing Nothing = Nothing align (Just a) Nothing = Just (This a) align Nothing (Just b) = Just (That b) align (Just a) (Just b) = Just (These a b) instance Zip Maybe where zip Nothing _ = Nothing zip (Just _) Nothing = Nothing zip (Just a) (Just b) = Just (a, b) instance Repeat Maybe where repeat = Just instance Unalign Maybe where unalign Nothing = (Nothing, Nothing) unalign (Just (This a)) = (Just a, Nothing) unalign (Just (That b)) = (Nothing, Just b) unalign (Just (These a b)) = (Just a, Just b) instance Unzip Maybe where unzip = unzipDefault instance Align Maybe where nil = Nothing instance Semialign [] where align xs [] = This <$> xs align [] ys = That <$> ys align (x:xs) (y:ys) = These x y : align xs ys instance Align [] where nil = [] instance Zip [] where zip = Prelude.zip zipWith = Prelude.zipWith instance Repeat [] where repeat = Prelude.repeat instance Unzip [] where unzip = Prelude.unzip -- | @'zipWith' = 'liftA2'@ . instance Semialign ZipList where alignWith f (ZipList xs) (ZipList ys) = ZipList (alignWith f xs ys) instance Align ZipList where nil = ZipList [] instance Zip ZipList where zipWith f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys) instance Repeat ZipList where repeat = pure instance Unzip ZipList where unzip (ZipList xs) = (ZipList ys, ZipList zs) where (ys, zs) = unzip xs ------------------------------------------------------------------------------- -- semigroups ------------------------------------------------------------------------------- instance Semialign NonEmpty where align (x :| xs) (y :| ys) = These x y :| align xs ys instance Zip NonEmpty where zip = NE.zip zipWith = NE.zipWith instance Repeat NonEmpty where repeat = NE.repeat instance Unzip NonEmpty where unzip = NE.unzip deriving instance Semialign Option deriving instance Align Option deriving instance Unalign Option deriving instance Zip Option deriving instance Repeat Option deriving instance Unzip Option ------------------------------------------------------------------------------- -- containers: ListLike ------------------------------------------------------------------------------- instance Semialign Seq where align xs ys = case compare xn yn of EQ -> Seq.zipWith fc xs ys LT -> case Seq.splitAt xn ys of (ysl, ysr) -> Seq.zipWith These xs ysl `mappend` fmap That ysr GT -> case Seq.splitAt yn xs of (xsl, xsr) -> Seq.zipWith These xsl ys `mappend` fmap This xsr where xn = Seq.length xs yn = Seq.length ys fc = These alignWith f xs ys = case compare xn yn of EQ -> Seq.zipWith fc xs ys LT -> case Seq.splitAt xn ys of (ysl, ysr) -> Seq.zipWith fc xs ysl `mappend` fmap (f . That) ysr GT -> case Seq.splitAt yn xs of (xsl, xsr) -> Seq.zipWith fc xsl ys `mappend` fmap (f . This) xsr where xn = Seq.length xs yn = Seq.length ys fc x y = f (These x y) instance Align Seq where nil = Seq.empty instance Unzip Seq where #if MIN_VERSION_containers(0,5,11) unzip = Seq.unzip unzipWith = Seq.unzipWith #else unzip = unzipDefault #endif instance Zip Seq where zip = Seq.zip zipWith = Seq.zipWith instance Semialign T.Tree where align (T.Node x xs) (T.Node y ys) = T.Node (These x y) (alignWith (these (fmap This) (fmap That) align) xs ys) instance Zip T.Tree where zipWith f (T.Node x xs) (T.Node y ys) = T.Node (f x y) (zipWith (zipWith f) xs ys) instance Repeat T.Tree where repeat x = n where n = T.Node x (repeat n) instance Unzip T.Tree where unzipWith f = go where go (T.Node x xs) = (T.Node y ys, T.Node z zs) where ~(y, z) = f x ~(ys, zs) = unzipWith go xs ------------------------------------------------------------------------------- -- containers: MapLike ------------------------------------------------------------------------------- instance Ord k => Semialign (Map k) where #if MIN_VERSION_containers(0,5,9) alignWith f = Map.merge (Map.mapMissing (\_ x -> f (This x))) (Map.mapMissing (\_ y -> f (That y))) (Map.zipWithMatched (\_ x y -> f (These x y))) #elif MIN_VERSION_containers(0,5,0) alignWith f = Map.mergeWithKey (\_ x y -> Just $ f $ These x y) (fmap (f . This)) (fmap (f . That)) #else align m n = Map.unionWith merge (Map.map This m) (Map.map That n) where merge (This a) (That b) = These a b merge _ _ = oops "Align Map: merge" #endif instance (Ord k) => Align (Map k) where nil = Map.empty instance Ord k => Unalign (Map k) where unalign xs = (Map.mapMaybe justHere xs, Map.mapMaybe justThere xs) instance Ord k => Unzip (Map k) where unzip = unzipDefault instance Ord k => Zip (Map k) where zipWith = Map.intersectionWith instance Semialign IntMap where #if MIN_VERSION_containers(0,5,9) alignWith f = IntMap.merge (IntMap.mapMissing (\_ x -> f (This x))) (IntMap.mapMissing (\_ y -> f (That y))) (IntMap.zipWithMatched (\_ x y -> f (These x y))) #elif MIN_VERSION_containers(0,5,0) alignWith f = IntMap.mergeWithKey (\_ x y -> Just $ f $ These x y) (fmap (f . This)) (fmap (f . That)) #else align m n = IntMap.unionWith merge (IntMap.map This m) (IntMap.map That n) where merge (This a) (That b) = These a b merge _ _ = oops "Align IntMap: merge" #endif instance Align IntMap where nil = IntMap.empty instance Unalign IntMap where unalign xs = (IntMap.mapMaybe justHere xs, IntMap.mapMaybe justThere xs) instance Unzip IntMap where unzip = unzipDefault instance Zip IntMap where zipWith = IntMap.intersectionWith ------------------------------------------------------------------------------- -- transformers ------------------------------------------------------------------------------- instance Semialign Identity where alignWith f (Identity a) (Identity b) = Identity (f (These a b)) instance Zip Identity where zipWith f (Identity a) (Identity b) = Identity (f a b) instance Repeat Identity where repeat = pure instance Unzip Identity where unzip (Identity ~(a, b)) = (Identity a, Identity b) instance (Semialign f, Semialign g) => Semialign (Product f g) where align (Pair a b) (Pair c d) = Pair (align a c) (align b d) alignWith f (Pair a b) (Pair c d) = Pair (alignWith f a c) (alignWith f b d) instance (Unalign f, Unalign g) => Unalign (Product f g) where unalign (Pair a b) = (Pair al bl, Pair ar br) where ~(al, ar) = unalign a ~(bl, br) = unalign b instance (Align f, Align g) => Align (Product f g) where nil = Pair nil nil instance (Zip f, Zip g) => Zip (Product f g) where zip (Pair a b) (Pair c d) = Pair (zip a c) (zip b d) zipWith f (Pair a b) (Pair c d) = Pair (zipWith f a c) (zipWith f b d) instance (Repeat f, Repeat g) => Repeat (Product f g) where repeat x = Pair (repeat x) (repeat x) instance (Unzip f, Unzip g) => Unzip (Product f g) where unzip (Pair a b) = (Pair al bl, Pair ar br) where ~(al, ar) = unzip a ~(bl, br) = unzip b instance (Semialign f, Semialign g) => Semialign (Compose f g) where alignWith f (Compose x) (Compose y) = Compose (alignWith g x y) where g (This ga) = fmap (f . This) ga g (That gb) = fmap (f . That) gb g (These ga gb) = alignWith f ga gb instance (Align f, Semialign g) => Align (Compose f g) where nil = Compose nil instance (Zip f, Zip g) => Zip (Compose f g) where zipWith f (Compose x) (Compose y) = Compose (zipWith (zipWith f) x y) instance (Repeat f, Repeat g) => Repeat (Compose f g) where repeat x = Compose (repeat (repeat x)) instance (Unzip f, Unzip g) => Unzip (Compose f g) where unzipWith f (Compose x) = (Compose y, Compose z) where ~(y, z) = unzipWith (unzipWith f) x -- This is unlawful instance. -- -- instance (Unalign f, Unalign g) => Unalign (Compose f g) where -- unalignWith f (Compose x) = (Compose y, Compose z) where -- ~(y, z) = unalignWith (uncurry These . unalignWith f) x ------------------------------------------------------------------------------- -- vector ------------------------------------------------------------------------------- -- Based on the Data.Vector.Fusion.Stream.Monadic zipWith implementation instance Monad m => Align (Stream m) where nil = Stream.empty instance Monad m => Semialign (Stream m) where #if MIN_VERSION_vector(0,11,0) alignWith f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing, False) #else alignWith f (Stream stepa ta na) (Stream stepb tb nb) = Stream step (ta, tb, Nothing, False) (Stream.larger na nb) #endif where step (sa, sb, Nothing, False) = do r <- stepa sa return $ case r of Yield x sa' -> Skip (sa', sb, Just x, False) Skip sa' -> Skip (sa', sb, Nothing, False) Done -> Skip (sa, sb, Nothing, True) step (sa, sb, av, adone) = do r <- stepb sb return $ case r of Yield y sb' -> Yield (f $ maybe (That y) (`These` y) av) (sa, sb', Nothing, adone) Skip sb' -> Skip (sa, sb', av, adone) Done -> case (av, adone) of (Just x, False) -> Yield (f $ This x) (sa, sb, Nothing, adone) (_, True) -> Done _ -> Skip (sa, sb, Nothing, False) instance Monad m => Zip (Stream m) where zipWith = Stream.zipWith #if MIN_VERSION_vector(0,11,0) instance Monad m => Align (Bundle m v) where nil = Bundle.empty instance Monad m => Semialign (Bundle m v) where alignWith f Bundle{sElems = sa, sSize = na} Bundle{sElems = sb, sSize = nb} = Bundle.fromStream (alignWith f sa sb) (Bundle.larger na nb) #endif instance Monad m => Zip (Bundle m v) where zipWith = Bundle.zipWith instance Semialign V.Vector where alignWith = alignVectorWith instance Zip V.Vector where zipWith = V.zipWith instance Align V.Vector where nil = Data.Vector.Generic.empty instance Unzip V.Vector where unzip = V.unzip alignVectorWith :: (Vector v a, Vector v b, Vector v c) => (These a b -> c) -> v a -> v b -> v c alignVectorWith f x y = unstream $ alignWith f (stream x) (stream y) ------------------------------------------------------------------------------- -- unordered-containers ------------------------------------------------------------------------------- instance (Eq k, Hashable k) => Align (HashMap k) where nil = HM.empty instance (Eq k, Hashable k) => Semialign (HashMap k) where align m n = HM.unionWith merge (HM.map This m) (HM.map That n) where merge (This a) (That b) = These a b merge _ _ = oops "Align HashMap: merge" instance (Eq k, Hashable k) => Zip (HashMap k) where zipWith = HM.intersectionWith instance (Eq k, Hashable k) => Unzip (HashMap k) where unzip = unzipDefault instance (Eq k, Hashable k) => Unalign (HashMap k) where unalign xs = (HM.mapMaybe justHere xs, HM.mapMaybe justThere xs) ------------------------------------------------------------------------------- -- tagged ------------------------------------------------------------------------------- instance Semialign (Tagged b) where alignWith f (Tagged x) (Tagged y) = Tagged (f (These x y)) instance Zip (Tagged b) where zipWith f (Tagged x) (Tagged y) = Tagged (f x y) instance Repeat (Tagged b) where repeat = Tagged instance Unzip (Tagged b) where unzip (Tagged ~(a, b)) = (Tagged a, Tagged b) instance Semialign Proxy where alignWith _ _ _ = Proxy align _ _ = Proxy instance Align Proxy where nil = Proxy instance Unalign Proxy where unalign _ = (Proxy, Proxy) instance Zip Proxy where zipWith _ _ _ = Proxy zip _ _ = Proxy instance Repeat Proxy where repeat _ = Proxy instance Unzip Proxy where unzip _ = (Proxy, Proxy) ------------------------------------------------------------------------------- -- combinators ------------------------------------------------------------------------------- -- | Align two structures and combine with '<>'. salign :: (Semialign f, Semigroup a) => f a -> f a -> f a salign = alignWith (mergeThese (<>)) -- | Align two structures as in 'zip', but filling in blanks with 'Nothing'. padZip :: (Semialign f) => f a -> f b -> f (Maybe a, Maybe b) padZip = alignWith (fromThese Nothing Nothing . bimap Just Just) -- | Align two structures as in 'zipWith', but filling in blanks with 'Nothing'. padZipWith :: (Semialign f) => (Maybe a -> Maybe b -> c) -> f a -> f b -> f c padZipWith f xs ys = uncurry f <$> padZip xs ys -- | Left-padded 'zipWith'. lpadZipWith :: (Maybe a -> b -> c) -> [a] -> [b] -> [c] lpadZipWith f xs ys = catMaybes $ padZipWith (\x y -> f x <$> y) xs ys -- | Left-padded 'zip'. lpadZip :: [a] -> [b] -> [(Maybe a, b)] lpadZip = lpadZipWith (,) -- | Right-padded 'zipWith'. rpadZipWith :: (a -> Maybe b -> c) -> [a] -> [b] -> [c] rpadZipWith f xs ys = lpadZipWith (flip f) ys xs -- | Right-padded 'zip'. rpadZip :: [a] -> [b] -> [(a, Maybe b)] rpadZip = rpadZipWith (,) semialign-1.1.0.1/src/Data/Zip.hs0000644000000000000000000000304407346545000014550 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE Trustworthy #-} -- | Zipping and unzipping of functors with non-uniform shapes. -- module Data.Zip ( Semialign (..), Zip (..), Repeat (..), Unzip (..), unzipDefault, Zippy (..), ) where import Control.Applicative (Applicative (..)) import Data.Monoid (Monoid (..)) import Data.Semigroup (Semigroup (..)) import Prelude (Eq, Functor (..), Ord, Read, Show, ($), (.)) import Data.Semialign.Internal #ifdef MIN_VERSION_semigroupoids import Data.Functor.Apply (Apply (..)) #endif ------------------------------------------------------------------------------- -- Zippy ------------------------------------------------------------------------------- newtype Zippy f a = Zippy { getZippy :: f a } deriving (Eq, Ord, Show, Read, Functor) instance (Zip f, Semigroup a) => Semigroup (Zippy f a) where Zippy x <> Zippy y = Zippy $ zipWith (<>) x y instance (Repeat f, Monoid a) => Monoid (Zippy f a) where mempty = Zippy $ repeat mempty mappend (Zippy x) (Zippy y) = Zippy $ zipWith mappend x y #ifdef MIN_VERSION_semigroupoids instance Zip f => Apply (Zippy f) where Zippy f <.> Zippy x = Zippy $ zipWith ($) f x #endif instance Repeat f => Applicative (Zippy f) where pure = Zippy . repeat #ifdef MIN_VERSION_semigroupoids (<*>) = (<.>) #else Zippy f <*> Zippy x = Zippy $ zipWith ($) f x #endif #if MIN_VERSION_base(4,10,0) liftA2 f (Zippy x) (Zippy y) = Zippy $ zipWith f x y #endif