{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wall #-}

module Test.QuickCheck.Classes.Monoid
  ( monoidLaws
  , commutativeMonoidLaws
  , semigroupMonoidLaws
  ) where

import Data.Semigroup
import Data.Monoid
import Data.Proxy (Proxy)
import Test.QuickCheck hiding ((.&.))
import Test.QuickCheck.Property (Property)

import Test.QuickCheck.Classes.Internal (Laws(..), SmallList(..), myForAllShrink)

-- | Tests the following properties:
--
-- [/Associative/]
--   @mappend a (mappend b c) ≡ mappend (mappend a b) c@
-- [/Left Identity/]
--   @mappend mempty a ≡ a@
-- [/Right Identity/]
--   @mappend a mempty ≡ a@
-- [/Concatenation/]
--   @mconcat as ≡ foldr mappend mempty as@
monoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
monoidLaws :: Proxy a -> Laws
monoidLaws p :: Proxy a
p = String -> [(String, Property)] -> Laws
Laws "Monoid"
  [ ("Associative", Proxy a -> Property
forall a.
(Monoid a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
monoidAssociative Proxy a
p)
  , ("Left Identity", Proxy a -> Property
forall a.
(Monoid a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
monoidLeftIdentity Proxy a
p)
  , ("Right Identity", Proxy a -> Property
forall a.
(Monoid a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
monoidRightIdentity Proxy a
p)
  , ("Concatenation", Proxy a -> Property
forall a.
(Monoid a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
monoidConcatenation Proxy a
p)
  ]

-- | Tests the following properties:
--
-- [/Commutative/]
--   @mappend a b ≡ mappend b a@
--
-- Note that this does not test associativity or identity. Make sure to use
-- 'monoidLaws' in addition to this set of laws.
commutativeMonoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
commutativeMonoidLaws :: Proxy a -> Laws
commutativeMonoidLaws p :: Proxy a
p = String -> [(String, Property)] -> Laws
Laws "Commutative Monoid"
  [ ("Commutative", Proxy a -> Property
forall a.
(Monoid a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
monoidCommutative Proxy a
p)
  ]

semigroupMonoidLaws :: forall a. (Semigroup a, Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
semigroupMonoidLaws :: Proxy a -> Laws
semigroupMonoidLaws p :: Proxy a
p = String -> [(String, Property)] -> Laws
Laws "Semigroup/Monoid"
  [ ("mappend == <>", Proxy a -> Property
forall a.
(Semigroup a, Monoid a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
semigroupMonoid Proxy a
p)
  ]

semigroupMonoid :: forall a. (Semigroup a, Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
semigroupMonoid :: Proxy a -> Property
semigroupMonoid _ = Bool
-> ((a, a) -> Bool)
-> ((a, a) -> [String])
-> String
-> ((a, a) -> a)
-> String
-> ((a, a) -> a)
-> Property
forall a b.
(Arbitrary a, Show b, Eq b) =>
Bool
-> (a -> Bool)
-> (a -> [String])
-> String
-> (a -> b)
-> String
-> (a -> b)
-> Property
myForAllShrink Bool
True (Bool -> (a, a) -> Bool
forall a b. a -> b -> a
const Bool
True)
  (\(a
a :: a,b :: a
b) -> ["a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a, "b = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
b])
  "mappend a b"
  (\(a :: a
a,b :: a
b) -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a a
b)
  "a <> b"
  (\(a :: a
a,b :: a
b) -> a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
Data.Semigroup.<> a
b)

monoidConcatenation :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
monoidConcatenation :: Proxy a -> Property
monoidConcatenation _ = Bool
-> (SmallList a -> Bool)
-> (SmallList a -> [String])
-> String
-> (SmallList a -> a)
-> String
-> (SmallList a -> a)
-> Property
forall a b.
(Arbitrary a, Show b, Eq b) =>
Bool
-> (a -> Bool)
-> (a -> [String])
-> String
-> (a -> b)
-> String
-> (a -> b)
-> Property
myForAllShrink Bool
True (Bool -> SmallList a -> Bool
forall a b. a -> b -> a
const Bool
True)
  (\(SmallList ([a]
as :: [a])) -> ["as = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => a -> String
show [a]
as])
  "mconcat as"
  (\(SmallList as :: [a]
as) -> [a] -> a
forall a. Monoid a => [a] -> a
mconcat [a]
as)
  "foldr mappend mempty as"
  (\(SmallList as :: [a]
as) -> (a -> a -> a) -> a -> [a] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
forall a. Monoid a => a
mempty [a]
as)

monoidAssociative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
monoidAssociative :: Proxy a -> Property
monoidAssociative _ = Bool
-> ((a, a, a) -> Bool)
-> ((a, a, a) -> [String])
-> String
-> ((a, a, a) -> a)
-> String
-> ((a, a, a) -> a)
-> Property
forall a b.
(Arbitrary a, Show b, Eq b) =>
Bool
-> (a -> Bool)
-> (a -> [String])
-> String
-> (a -> b)
-> String
-> (a -> b)
-> Property
myForAllShrink Bool
True (Bool -> (a, a, a) -> Bool
forall a b. a -> b -> a
const Bool
True)
  (\(a
a :: a,b :: a
b,c :: a
c) -> ["a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a, "b = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
b, "c = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
c])
  "mappend a (mappend b c)"
  (\(a :: a
a,b :: a
b,c :: a
c) -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a (a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
b a
c))
  "mappend (mappend a b) c"
  (\(a :: a
a,b :: a
b,c :: a
c) -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend (a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a a
b) a
c)

monoidLeftIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
monoidLeftIdentity :: Proxy a -> Property
monoidLeftIdentity _ = Bool
-> (a -> Bool)
-> (a -> [String])
-> String
-> (a -> a)
-> String
-> (a -> a)
-> Property
forall a b.
(Arbitrary a, Show b, Eq b) =>
Bool
-> (a -> Bool)
-> (a -> [String])
-> String
-> (a -> b)
-> String
-> (a -> b)
-> Property
myForAllShrink Bool
False (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)
  (\(a
a :: a) -> ["a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a])
  "mappend mempty a"
  (\a :: a
a -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
forall a. Monoid a => a
mempty a
a)
  "a"
  (\a :: a
a -> a
a)

monoidRightIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
monoidRightIdentity :: Proxy a -> Property
monoidRightIdentity _ = Bool
-> (a -> Bool)
-> (a -> [String])
-> String
-> (a -> a)
-> String
-> (a -> a)
-> Property
forall a b.
(Arbitrary a, Show b, Eq b) =>
Bool
-> (a -> Bool)
-> (a -> [String])
-> String
-> (a -> b)
-> String
-> (a -> b)
-> Property
myForAllShrink Bool
False (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)
  (\(a
a :: a) -> ["a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a])
  "mappend a mempty"
  (\a :: a
a -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a a
forall a. Monoid a => a
mempty)
  "a"
  (\a :: a
a -> a
a)

monoidCommutative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
monoidCommutative :: Proxy a -> Property
monoidCommutative _ = Bool
-> ((a, a) -> Bool)
-> ((a, a) -> [String])
-> String
-> ((a, a) -> a)
-> String
-> ((a, a) -> a)
-> Property
forall a b.
(Arbitrary a, Show b, Eq b) =>
Bool
-> (a -> Bool)
-> (a -> [String])
-> String
-> (a -> b)
-> String
-> (a -> b)
-> Property
myForAllShrink Bool
True (Bool -> (a, a) -> Bool
forall a b. a -> b -> a
const Bool
True)
  (\(a
a :: a,b :: a
b) -> ["a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a, "b = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
b])
  "mappend a b"
  (\(a :: a
a,b :: a
b) -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a a
b)
  "mappend b a"
  (\(a :: a
a,b :: a
b) -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
b a
a)