diff --git a/partial-semigroup/src/Data/PartialSemigroup.hs b/partial-semigroup/src/Data/PartialSemigroup.hs index 4ccf92f..745e16a 100644 --- a/partial-semigroup/src/Data/PartialSemigroup.hs +++ b/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 diff --git a/partial-semigroup/test/Test/PartialSemigroup/Hedgehog.hs b/partial-semigroup/test/Test/PartialSemigroup/Hedgehog.hs index f1c6137..7d99da4 100644 --- a/partial-semigroup/test/Test/PartialSemigroup/Hedgehog.hs +++ b/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) diff --git a/partial-semigroup/test/properties.hs b/partial-semigroup/test/properties.hs index d3c2913..2d36ea6 100644 --- a/partial-semigroup/test/properties.hs +++ b/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 --------------------------------------------------------------------------------