diff --git a/Data/Align.hs b/Data/Align.hs index e48df0f..12b909f 100644 --- a/Data/Align.hs +++ b/Data/Align.hs @@ -8,7 +8,7 @@ module Data.Align ( Align(..) -- * Specialized aligns - , malign, salign, padZip, padZipWith + , malign, salign, Salign (..), padZip, padZipWith , lpadZip, lpadZipWith , rpadZip, rpadZipWith , alignVectorWith @@ -285,6 +285,15 @@ malign = alignWith (mergeThese mappend) salign :: (Align f, Semigroup a) => f a -> f a -> f a salign = alignWith (mergeThese (<>)) +-- | Monoid under 'salign' and 'nil'. +newtype Salign f a = Salign (f a) + +instance (Align f, Semigroup a) => Semigroup (Salign f a) where + Salign x <> Salign y = Salign (salign x y) + +instance (Align f, Semigroup a) => Monoid (Salign f a) where + mempty = Salign nil + -- | Align two structures as in 'zip', but filling in blanks with 'Nothing'. padZip :: (Align f) => f a -> f b -> f (Maybe a, Maybe b) padZip = alignWith (fromThese Nothing Nothing . bimap Just Just) diff --git a/test/Tests.hs b/test/Tests.hs index 4f584ec..0903f94 100644 --- a/test/Tests.hs +++ b/test/Tests.hs @@ -2,9 +2,11 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} module Main (main) where @@ -63,6 +65,7 @@ tests = testGroup "Tests" [ semigroupLaws "These" (These "x" "y") , semigroupLaws "SearchResult" (ScannedAndFound "x" "y") , monoidLaws "List" "x" -- to disallow + , monoidLaws "Salign" (Salign ["x"]) ] ] @@ -444,3 +447,7 @@ instance Monoid a => Monoid (SearchResult a b) where mappend = (<>) mempty = Scanned mempty -} + +deriving instance Eq (f a) => Eq (Salign f a) +deriving instance Show (f a) => Show (Salign f a) +deriving instance Arbitrary (f a) => Arbitrary (Salign f a)