semialign (empty) → 1
raw patch · 8 files changed
+1017/−0 lines, 8 filesdep +basedep +base-compatdep +bifunctors
Dependencies added: base, base-compat, bifunctors, containers, ghc-prim, hashable, semigroupoids, semigroups, tagged, these, transformers, transformers-compat, unordered-containers, vector
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- semialign.cabal +86/−0
- src/Data/Align.hs +18/−0
- src/Data/Crosswalk.hs +121/−0
- src/Data/Semialign.hs +17/−0
- src/Data/Semialign/Internal.hs +692/−0
- src/Data/Zip.hs +50/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 1++Split out of `these` package.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (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.cabal view
@@ -0,0 +1,86 @@+cabal-version: >=1.10+name: semialign+version: 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 <oleg.grenrus@iki.fi>+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.1++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.13+ , containers >=0.4.2.1 && <0.7+ , transformers >=0.3.0.0 && <0.6++ -- These+ build-depends: these >=1 && <1.1++ -- other dependencies+ build-depends:+ base-compat >=0.10.5 && <0.11+ , 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
+ src/Data/Align.hs view
@@ -0,0 +1,18 @@+{-# 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+ malign, salign, padZip, padZipWith,+ lpadZip, lpadZipWith,+ rpadZip, rpadZipWith,+ alignVectorWith,+ ) where++import Data.Semialign.Internal
+ src/Data/Crosswalk.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}+module Data.Crosswalk (+ -- * Crosswalk+ Crosswalk (..),+ -- * Bicrosswalk+ Bicrosswalk (..),+ ) where++import Prelude ()+import Prelude.Compat++import Data.Bifoldable (Bifoldable (..))+import Data.Bifunctor (Bifunctor (..))+import Data.Functor.Compose (Compose (..))+import Data.Functor.Identity (Identity (..))+import Data.Vector.Generic (Vector)++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 = id+ . 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)
+ src/Data/Semialign.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE Trustworthy #-}+-- | Zipping and aligning of functors with non-uniform shapes.+module Data.Semialign (+ Semialign (..),+ Align (..),+ Unalign (..),+ Zip (..),+ Unzip (..),+ unzipDefault,+ -- * Specialized aligns+ malign, salign, padZip, padZipWith,+ lpadZip, lpadZipWith,+ rpadZip, rpadZipWith,+ alignVectorWith,+ ) where++import Data.Semialign.Internal
+ src/Data/Semialign/Internal.hs view
@@ -0,0 +1,692 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE CPP #-}+module Data.Semialign.Internal where++import Prelude ()+import Prelude.Compat hiding (unzip, zip, zipWith)++import qualified Prelude.Compat as Prelude++import Control.Applicative (ZipList (..))+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 (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 HashMap+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 a 'zip' and 'align' operations that takes the+-- intersection and union of non-uniform shapes.+--+-- Minimal definition: either 'align' or 'alignWith' and either 'zip' or 'zipWith'.+--+-- == 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)+-- join zip ≡ fmap (join (,))+-- @+--+-- /Commutativity/+--+-- @+-- align x y ≡ swap \<$> align y x+-- zip x y ≡ swap \<$> zip y x+-- @+--+-- /Associativity/+--+-- @+-- align x (align y z) ≡ assoc \<$> align (align x y) z+-- 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/+--+-- @+-- alignWith f a b ≡ f \<$> align a b+-- zipWith f a b ≡ f \<$> zip a b+-- @+--+-- /Functoriality/+--+-- @+-- align (f \<$> x) (g \<$> y) ≡ bimap f g \<$> align x y+-- 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+-- @+--+-- /Alignedness/, if @f@ is 'Foldable'+--+-- @+-- toList x ≡ toListOf (folded . here) (align x y)+-- ≡ mapMaybe justHere (toList (align x y))+-- @+--+-- /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 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++ -- | Combines to 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 to 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 (align | alignWith), (zip | zipWith) #-}+#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+++-- | A unit of 'zip'.+--+-- @+-- fst \<$> zip xs (full y) ≡ xs+-- snd \<$> zip (full x) ys ≡ ys+-- @+--+class Semialign f => Zip f where+ -- | A /full/ strucutre.+ full :: 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 Semialign 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))++ zip f g x = (f x, g x)++instance Zip ((->) e) where+ full = 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)++ zip Nothing _ = Nothing+ zip (Just _) Nothing = Nothing+ zip (Just a) (Just b) = Just (a, b)++instance Zip Maybe where+ full = 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++ zip = Prelude.zip+ zipWith = Prelude.zipWith++instance Align [] where+ nil = []++instance Zip [] where+ full = repeat++instance Unzip [] where+ unzip = Prelude.unzip+++-- | @'zipWith' = 'liftA2'@ .+instance Semialign ZipList where+ alignWith f (ZipList xs) (ZipList ys) = ZipList (alignWith f xs ys)+ zipWith f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys)++instance Align ZipList where+ nil = ZipList []++instance Zip ZipList where+ full = 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++ zip = NE.zip+ zipWith = NE.zipWith++instance Zip NonEmpty where+ full = NE.repeat++instance Unzip NonEmpty where+ unzip = NE.unzip++-------------------------------------------------------------------------------+-- 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)++ zip = Seq.zip+ zipWith = Seq.zipWith++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 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)++ zipWith f (T.Node x xs) (T.Node y ys) = T.Node (f x y) (zipWith (zipWith f) xs ys)++instance Zip T.Tree where+ full 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++ zipWith = Map.intersectionWith++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 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++ zipWith = IntMap.intersectionWith++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++-------------------------------------------------------------------------------+-- transformers+-------------------------------------------------------------------------------++instance Semialign Identity where+ alignWith f (Identity a) (Identity b) = Identity (f (These a b))++ zipWith f (Identity a) (Identity b) = Identity (f a b)++instance Zip Identity where+ full = 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)++ 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 (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+ full x = Pair (full x) (full 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++ zipWith f (Compose x) (Compose y) = Compose (zipWith (zipWith f) x y)++instance (Align f, Semialign g) => Align (Compose f g) where+ nil = Compose nil++instance (Zip f, Zip g) => Zip (Compose f g) where+ full x = Compose (full (full 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)++ 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)++ zipWith = Bundle.zipWith+#endif++instance Semialign V.Vector where+ alignWith = alignVectorWith+ 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 = HashMap.empty++instance (Eq k, Hashable k) => Semialign (HashMap k) where+ align m n = HashMap.unionWith merge (HashMap.map This m) (HashMap.map That n)+ where merge (This a) (That b) = These a b+ merge _ _ = oops "Align HashMap: merge"++ zipWith = HashMap.intersectionWith++instance (Eq k, Hashable k) => Unzip (HashMap k) where unzip = unzipDefault++instance (Eq k, Hashable k) => Unalign (HashMap k) where+ unalign xs = (HashMap.mapMaybe justHere xs, HashMap.mapMaybe justThere xs)++-------------------------------------------------------------------------------+-- tagged+-------------------------------------------------------------------------------++instance Semialign (Tagged b) where+ alignWith f (Tagged x) (Tagged y) = Tagged (f (These x y))++ zipWith f (Tagged x) (Tagged y) = Tagged (f x y)++instance Zip (Tagged b) where+ full = Tagged++instance Unzip (Tagged b) where+ unzip (Tagged ~(a, b)) = (Tagged a, Tagged b)+++instance Semialign Proxy where+ alignWith _ _ _ = Proxy+ align _ _ = Proxy++ zipWith _ _ _ = Proxy+ zip _ _ = Proxy++instance Align Proxy where+ nil = Proxy++instance Unalign Proxy where+ unalign _ = (Proxy, Proxy)++instance Zip Proxy where+ full _ = Proxy++instance Unzip Proxy where+ unzip _ = (Proxy, Proxy)++-------------------------------------------------------------------------------+-- combinators+-------------------------------------------------------------------------------++-- | Align two structures and combine with 'mappend'.+--+-- See `salign`. `malign` will be deprecated after `Semigroup` becomes a super+-- class of `Monoid`+malign :: (Semialign f, Monoid a) => f a -> f a -> f a+malign = alignWith (mergeThese mappend)++-- | 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 (,)
+ src/Data/Zip.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE Trustworthy #-}+-- | Zipping and unzipping of functors with non-uniform shapes.+--+module Data.Zip (+ Semialign (..),+ Zip (..),+ Unzip (..),+ unzipDefault,+ Zippy (..),+ ) where++import Prelude ()+import Prelude.Compat hiding (zipWith)++import Data.Semigroup (Semigroup (..))++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 (Semialign f, Semigroup a) => Semigroup (Zippy f a) where+ Zippy x <> Zippy y = Zippy $ zipWith (<>) x y++instance (Zip f, Monoid a) => Monoid (Zippy f a) where+ mempty = Zippy $ full mempty+ mappend (Zippy x) (Zippy y) = Zippy $ zipWith mappend x y++#ifdef MIN_VERSION_semigroupoids+instance Semialign f => Apply (Zippy f) where+ Zippy f <.> Zippy x = Zippy $ zipWith ($) f x+#endif++instance Zip f => Applicative (Zippy f) where+ pure = Zippy . full+#ifdef MIN_VERSION_semigroupoids+ (<*>) = (<.>)+#else+ Zippy f <*> Zippy x = Zippy $ zipWith ($) f x+#endif