From 7d98fc1389adcae4b821020ec126c65ce779c730 Mon Sep 17 00:00:00 2001
From: Chris Martin <ch.martin@gmail.com>
Date: Mon, 11 Feb 2019 17:33:21 -0700
Subject: [PATCH] Add newtype Salign
---
Data/Align.hs | 12 +++++++++++-
test/Tests.hs | 7 +++++++
2 files changed, 18 insertions(+), 1 deletion(-)
diff --git a/Data/Align.hs b/Data/Align.hs
index e48df0f..25c74de 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,16 @@ 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
+ mappend = (<>)
+ 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)