diff --git a/semialign/CHANGELOG.md b/semialign/CHANGELOG.md index a4c3c58..29ad178 100644 --- a/semialign/CHANGELOG.md +++ b/semialign/CHANGELOG.md @@ -6,6 +6,8 @@ `instance Unzip ((->) e) where unzip = unzipDefault` was added in this patch. - `Unzip f` doesn't imply whole hierarchy, so you may need to change `Unzip f` to `Zip f` in the constraints of some of your functions. +- Relax laws of Unalign allowing list-like instances. + - Add `Unalign []` and `Unalign Vector` instances. # 1.3.1 diff --git a/semialign/src/Data/Semialign/Internal.hs b/semialign/src/Data/Semialign/Internal.hs index f38977f..9b077b0 100644 --- a/semialign/src/Data/Semialign/Internal.hs +++ b/semialign/src/Data/Semialign/Internal.hs @@ -156,10 +156,18 @@ class Semialign f => Align f where -- == Laws -- -- @ --- uncurry align (unalign xs) ≡ xs -- unalign (align xs ys) ≡ (xs, ys) -- @ -- +-- Previously 'Unalign' included a right inverse law +-- +-- @ +-- uncurry align (unalign xs) ≡ xs +-- @ +-- +-- But this law was removed in 1.4 to allow list-like instances, +-- where unalign necessarily loses some information. +-- -- == Compatibility note -- -- In version 1 'unalign' was changed to return @(f a, f b)@ pair, @@ -408,6 +416,16 @@ instance Repeat [] where instance Unzip [] where unzip = Prelude.unzip +-- | +-- +-- @since 1.4 +instance Unalign [] where + unalign = Prelude.foldr f ([], []) where + f :: These a b -> ([a], [b]) -> ([a], [b]) + f (This x) ~(xs, ys) = (x : xs, ys) + f (That y) ~(xs, ys) = ( xs, y : ys) + f (These x y) ~(xs, ys) = (x : xs, y : ys) + instance SemialignWithIndex Int [] instance ZipWithIndex Int [] instance RepeatWithIndex Int [] @@ -429,6 +447,10 @@ instance Unzip ZipList where unzip (ZipList xs) = (ZipList ys, ZipList zs) where (ys, zs) = unzip xs +instance Unalign ZipList where + unalign (ZipList xs) = (ZipList ys, ZipList zs) where + (ys, zs) = unalign xs + instance SemialignWithIndex Int ZipList instance ZipWithIndex Int ZipList instance RepeatWithIndex Int ZipList @@ -701,6 +723,29 @@ instance Monad m => Semialign (Stream m) where _ -> Skip (sa, sb, Nothing, False) #endif +-- | +-- +-- @since 1.4 +instance Monad m => Unalign (Stream m) where + unalign (Stream stepa s) = (Stream stepb s, Stream stepc s) + where + stepb i = do + r <- stepa i + return $ case r of + Done -> Done + Skip j -> Skip j + Yield (This x) j -> Yield x j + Yield (These x _) j -> Yield x j + Yield (That _) j -> Skip j + + stepc i = do + r <- stepa i + return $ case r of + Done -> Done + Skip j -> Skip j + Yield (This _) j -> Skip j + Yield (These _ y) j -> Yield y j + Yield (That y) j -> Yield y j instance Monad m => Zip (Stream m) where zipWith = Stream.zipWith @@ -721,6 +766,15 @@ instance Monad m => Semialign (Bundle m v) where instance Monad m => Zip (Bundle m v) where zipWith = Bundle.zipWith +-- | +-- +-- @since 1.4 +instance Monad m => Unalign (Bundle m v) where + unalign Bundle { sElems = xys, sSize = n } = + (Bundle.fromStream xs (Bundle.toMax n), Bundle.fromStream ys (Bundle.toMax n)) + where + ~(xs, ys) = unalign xys + instance Semialign V.Vector where alignWith = alignVectorWith @@ -733,6 +787,14 @@ instance Align V.Vector where instance Unzip V.Vector where unzip = V.unzip +-- | +-- +-- @since 1.4 +instance Unalign V.Vector where + -- TODO: it would be more efficient to do unalign imperatively. + unalign xys = (unstream xs, unstream ys) where + ~(xs, ys) = unalign (stream xys) + 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) diff --git a/these-tests/test/Tests/Semialign.hs b/these-tests/test/Tests/Semialign.hs index 009b112..ab274b3 100644 --- a/these-tests/test/Tests/Semialign.hs +++ b/these-tests/test/Tests/Semialign.hs @@ -58,7 +58,7 @@ import Tests.Orphans () alignProps :: TestTree alignProps = testGroup "Align" - [ semialignLaws (CAll :: CSemialign []) + [ semialignLaws (CUnAll :: CSemialign []) , semialignLaws (CUnalign :: CSemialign (HashMap String)) , semialignLaws (CUnalign :: CSemialign (Map Char)) , semialignLaws (CUnalign :: CSemialign IntMap) @@ -66,9 +66,9 @@ alignProps = testGroup "Align" , semialignLaws (CAll :: CSemialign (Product [] Maybe)) , semialignLaws (CUnAll :: CSemialign (Product Maybe Maybe)) , semialignLaws (CAll :: CSemialign (Compose [] Maybe)) - , semialignLaws (CAlign :: CSemialign Seq) - , semialignLaws (CAlign :: CSemialign V.Vector) - , semialignLaws (CAlign :: CSemialign ZipList) + , semialignLaws (CAlign :: CSemialign Seq) -- TODO: Add Unalign instance + , semialignLaws (CUnalign :: CSemialign V.Vector) + , semialignLaws (CUnAll :: CSemialign ZipList) , semialignLaws (CZip :: CSemialign T.Tree) , semialignLaws (CZip :: CSemialign NonEmpty) , semialignLaws (CZip :: CSemialign Identity) @@ -336,8 +336,8 @@ unalignLaws' ) => proxy f -> TestTree unalignLaws' _ = testGroup "Unalign" - [ testProperty "right inverse" invProp - , testProperty "left inverse" leftProp + [ testProperty "left inverse" leftProp + -- , testProperty "right inverse" invProp , testProperty "unalignWith via unalign" unalignWithProp , testProperty "unalign via unalignWith" unalignProp ]