Add PartialMonoid typeclass

partial-semigroup/src/Data/PartialSemigroup.hs

@@ -6,6 +6,10 @@ module Data.PartialSemigroup
   ( -- * Partial semigroup
     PartialSemigroup (..),
 
+    -- * Partial monoid
+    PartialMonoid (..),
+    pmappend,
+
     -- * Either
     -- $either
     AppendLeft (..),
@@ -39,13 +43,13 @@ module Data.PartialSemigroup
 where
 
 import Control.Applicative (ZipList (..), (<$>), (<*>))
-import Control.Monad ((>>=))
+import Control.Monad (foldM, (>>=))
 import Data.Either (Either (..))
-import Data.Function ((.))
+import Data.Function (($), (.))
 import Data.Functor.Identity (Identity (..))
 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
-import Data.Maybe (Maybe (..))
-import Data.Monoid (Product (..), Sum (..))
+import Data.Maybe (fromJust, Maybe (..))
+import Data.Monoid (Monoid (..), Product (..), Sum (..))
 import Data.Semigroup (Semigroup (..))
 import Prelude (Eq, Num (..), Ord, Read, Show)
 
@@ -101,27 +105,92 @@ class PartialSemigroup a where
 
 --------------------------------------------------------------------------------
 
+-- | A 'PartialMonoid' is like a 'Monoid', but with an operator returning
+-- @'Maybe' a@ rather than @a@.  Every 'PartialMonoid' is a 'PartialSemigroup'.
+--
+-- == The identity axioms for partial monoids
+--
+-- For all @x@:
+--
+--  * @'pmempty' '<>?' x = x '<>?' 'pempty'@.
+--
+--  * @'pmempty' '<>?' x = 'Nothing'@ or @'pmempty' '<>?' x = 'Just' x@.
+--
+-- @since 0.7.0.0
+class PartialSemigroup a => PartialMonoid a where
+  -- | Identity of '<>?'.
+  pmempty :: a
+  pmempty = fromJust . pmconcat $ []
+  {-# INLINE pmempty #-}
+
+  -- | Fold a list using the monoid.
+  --
+  -- For most types, the default definition of 'pmconcat' will be used, but the
+  -- function is included in the class definition so that an optimized version
+  -- can be provided for specific types.
+  pmconcat :: [a] -> Maybe a
+  pmconcat = foldM pmappend pmempty
+  {-# INLINE pmconcat #-}
+
+  {-# MINIMAL pmempty | pmconcat #-}
+
+-- | An associative operation.
+--
+-- This is an alias for '<>?', for compatibility with 'mappend'.
+--
+-- @since 0.7.0.0
+pmappend :: PartialMonoid a => a -> a -> Maybe a
+pmappend = (<>?)
+{-# INLINE pmappend #-}
+
+--------------------------------------------------------------------------------
+
 instance PartialSemigroup () where
   () <>? () = Just ()
 
+-- | @since 0.7.0.0
+instance PartialMonoid () where
+  pmempty = ()
+  pmconcat _ = Just ()
+
 --------------------------------------------------------------------------------
 
 instance PartialSemigroup [a] where
   x <>? y = Just (x <> y)
 
+-- | @since 0.7.0.0
+instance PartialMonoid [a] where
+  pmempty = mempty
+  pmconcat = Just . mconcat
+
 --------------------------------------------------------------------------------
 
 instance Num a => PartialSemigroup (Sum a) where
   x <>? y = Just (x <> y)
 
+-- | @since 0.7.0.0
+instance Num a => PartialMonoid (Sum a) where
+  pmempty = mempty
+  pmconcat = Just . mconcat
+
 instance Num a => PartialSemigroup (Product a) where
   x <>? y = Just (x <> y)
 
+-- | @since 0.7.0.0
+instance Num a => PartialMonoid (Product a) where
+  pmempty = mempty
+  pmconcat = Just . mconcat
+
 --------------------------------------------------------------------------------
 
 instance PartialSemigroup a => PartialSemigroup (Identity a) where
   Identity x <>? Identity y = Identity <$> (x <>? y)
 
+-- | @since 0.7.0.0
+instance PartialMonoid a => PartialMonoid (Identity a) where
+  pmempty = Identity pmempty
+  pmconcat = pmconcat
+
 --------------------------------------------------------------------------------
 
 instance
@@ -168,6 +237,10 @@ instance (PartialSemigroup a, PartialSemigroup b) => PartialSemigroup (a, b) whe
       <$> (a <>? a')
       <*> (b <>? b')
 
+-- | @since 0.7.0.0
+instance (PartialMonoid a, PartialMonoid b) => PartialMonoid (a, b) where
+  pmempty = (pmempty, pmempty)
+
 instance
   (PartialSemigroup a, PartialSemigroup b, PartialSemigroup c) =>
   PartialSemigroup (a, b, c)
@@ -178,6 +251,13 @@ instance
       <*> (b <>? b')
       <*> (c <>? c')
 
+-- | @since 0.7.0.0
+instance
+  (PartialMonoid a, PartialMonoid b, PartialMonoid c) =>
+  PartialMonoid (a, b, c)
+  where
+  pmempty = (pmempty, pmempty, pmempty)
+
 --------------------------------------------------------------------------------
 
 -- | Apply a semigroup operation to any pairs of consecutive list elements where
@@ -334,6 +414,10 @@ instance PartialSemigroup a => Semigroup (Partial a) where
   Partial (Just x) <> Partial (Just y) = Partial (x <>? y)
   _ <> _ = Partial Nothing
 
+-- | @since 0.7.0.0
+instance PartialMonoid a => Monoid (Partial a) where
+  mempty = Partial . Just $ pmempty
+
 --------------------------------------------------------------------------------
 
 -- $total
@@ -366,6 +450,10 @@ newtype Total a = Total {unTotal :: a}
 instance Semigroup a => PartialSemigroup (Total a) where
   Total x <>? Total y = Just (Total (x <> y))
 
+-- | @since 0.7.0.0
+instance Monoid a => PartialMonoid (Total a) where
+  pmempty = Total mempty
+
 --------------------------------------------------------------------------------
 
 -- | A wrapper for 'Either' where the 'PartialSemigroup' operator is defined
@@ -397,6 +485,10 @@ instance PartialSemigroup a => PartialSemigroup (AppendLeft a b) where
     AppendLeft . Left <$> (x <>? y)
   _ <>? _ = Nothing
 
+-- | @since 0.7.0.0
+instance PartialMonoid a => PartialMonoid (AppendLeft a b) where
+  pmempty = AppendLeft . Left $ pmempty
+
 --------------------------------------------------------------------------------
 
 -- | A wrapper for 'Either' where the 'PartialSemigroup' operator is defined
@@ -428,6 +520,10 @@ instance PartialSemigroup b => PartialSemigroup (AppendRight a b) where
     AppendRight . Right <$> (x <>? y)
   _ <>? _ = Nothing
 
+-- | @since 0.7.0.0
+instance PartialMonoid b => PartialMonoid (AppendRight a b) where
+  pmempty = AppendRight . Right $ pmempty
+
 --------------------------------------------------------------------------------
 
 -- $refusing
@@ -451,3 +547,7 @@ instance PartialSemigroup (AtMostOne a) where
   AtMostOne Nothing <>? x = Just x
   x <>? AtMostOne Nothing = Just x
   _ <>? _ = Nothing
+
+-- | @since 0.7.0.0
+instance PartialMonoid (AtMostOne a) where
+  pmempty = AtMostOne Nothing

partial-semigroup/test/Test/PartialSemigroup/Hedgehog.hs

@@ -2,10 +2,11 @@
 -- testing library.
 module Test.PartialSemigroup.Hedgehog
   ( assoc,
+    identity,
   )
 where
 
-import Data.PartialSemigroup (PartialSemigroup (..))
+import Data.PartialSemigroup (PartialMonoid (..), PartialSemigroup (..))
 import Hedgehog (Gen, Property, forAll, property, (===))
 
 -- | The partial semigroup associativity axiom:
@@ -24,3 +25,20 @@ assoc gen = property $ do
       yz <- y <>? z
 
       return (x <>? yz === xy <>? z)
+
+-- | The partial monoid identity axiom:
+--
+-- For all @x@, @y@: @'pmempty' '<>?' x = x '<>?' 'pmempty'@ and if @'pmempty
+-- '<>?' x = 'Just' y@, @x = y@.
+identity :: (PartialMonoid a, Eq a, Show a) => Gen a -> Property
+identity gen = property $ do
+  x <- forAll gen
+
+  -- Both are either Nothing or Just y.
+  pmempty <>? x === x <>? pmempty
+
+  -- If they are Just y, then y == x.
+  sequence_ $
+    do
+      oneX <- pmempty <>? x
+      return (oneX === x)

partial-semigroup/test/properties.hs

@@ -16,7 +16,7 @@ import Hedgehog.Gen qualified as Gen
 import Hedgehog.Range qualified as Range
 import System.Exit qualified as Exit
 import System.IO qualified as IO
-import Test.PartialSemigroup.Hedgehog (assoc)
+import Test.PartialSemigroup.Hedgehog (assoc, identity)
 
 main :: IO ()
 main = do
@@ -34,18 +34,34 @@ prop_unit_assoc :: Property
 prop_unit_assoc =
   assoc (Gen.constant ())
 
+prop_unit_identity :: Property
+prop_unit_identity =
+  identity (Gen.constant ())
+
 prop_identity_assoc :: Property
 prop_identity_assoc =
   assoc (Identity <$> genStr)
 
+prop_identity_identity :: Property
+prop_identity_identity =
+  identity (Identity <$> genStr)
+
 prop_list_assoc :: Property
 prop_list_assoc =
   assoc genStr
 
+prop_list_identity :: Property
+prop_list_identity =
+  identity genStr
+
 prop_list_total_assoc :: Property
 prop_list_total_assoc =
   assoc (Total <$> genStr)
 
+prop_list_total_identity :: Property
+prop_list_total_identity =
+  identity (Total <$> genStr)
+
 prop_zipList_assoc :: Property
 prop_zipList_assoc =
   assoc (ZipList <$> Gen.list (Range.linear 0 3) genEither)
@@ -58,26 +74,47 @@ prop_tuple2_assoc :: Property
 prop_tuple2_assoc =
   assoc ((,) <$> genStr <*> genEither)
 
+prop_tuple2_identity :: Property
+prop_tuple2_identity =
+  identity ((,) <$> genStr <*> Gen.constant ())
+
 prop_tuple3_assoc :: Property
 prop_tuple3_assoc =
   assoc ((,,) <$> genStr <*> genEither <*> genSum)
 
+prop_tuple3_identity :: Property
+prop_tuple3_identity =
+  identity ((,,) <$> genStr <*> Gen.constant () <*> genSum)
+
 prop_appendLeft_assoc :: Property
 prop_appendLeft_assoc =
   assoc (AppendLeft <$> genEither)
 
+prop_appendLeft_identity :: Property
+prop_appendLeft_identity =
+  identity (AppendLeft <$> genEither)
+
 prop_appendRight_assoc :: Property
 prop_appendRight_assoc =
   assoc (AppendRight <$> genEither)
 
+prop_appendRight_identity :: Property
+prop_appendRight_identity =
+  identity (AppendRight <$> genEither)
+
 prop_one_assoc :: Property
 prop_one_assoc =
   assoc (One <$> genMaybe)
 
+
 prop_atMostOne_assoc :: Property
 prop_atMostOne_assoc =
   assoc (AtMostOne <$> genMaybe)
 
+prop_atMostOne_identity :: Property
+prop_atMostOne_identity =
+  identity (AtMostOne <$> genMaybe)
+
 --------------------------------------------------------------------------------
 --  Generators
 --------------------------------------------------------------------------------