{-# 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 Proxy a
p = String -> [(String, Property)] -> Laws
Laws String
"Monoid"
  [ (String
"Associative", Proxy a -> Property
forall a.
(Monoid a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
monoidAssociative Proxy a
p)
  , (String
"Left Identity", Proxy a -> Property
forall a.
(Monoid a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
monoidLeftIdentity Proxy a
p)
  , (String
"Right Identity", Proxy a -> Property
forall a.
(Monoid a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
monoidRightIdentity Proxy a
p)
  , (String
"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 Proxy a
p = String -> [(String, Property)] -> Laws
Laws String
"Commutative Monoid"
  [ (String
"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 Proxy a
p = String -> [(String, Property)] -> Laws
Laws String
"Semigroup/Monoid"
  [ (String
"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 Proxy a
_ = 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,a
b) -> [String
"a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a, String
"b = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
b])
  String
"mappend a b"
  (\(a
a,a
b) -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a a
b)
  String
"a <> b"
  (\(a
a,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 Proxy a
_ = 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])) -> [String
"as = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => a -> String
show [a]
as])
  String
"mconcat as"
  (\(SmallList [a]
as) -> [a] -> a
forall a. Monoid a => [a] -> a
mconcat [a]
as)
  String
"foldr mappend mempty as"
  (\(SmallList [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 Proxy a
_ = 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,a
b,a
c) -> [String
"a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a, String
"b = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
b, String
"c = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
c])
  String
"mappend a (mappend b c)"
  (\(a
a,a
b,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))
  String
"mappend (mappend a b) c"
  (\(a
a,a
b,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 Proxy a
_ = 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) -> [String
"a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a])
  String
"mappend mempty a"
  (\a
a -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
forall a. Monoid a => a
mempty a
a)
  String
"a"
  (\a
a -> a
a)

monoidRightIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
monoidRightIdentity :: Proxy a -> Property
monoidRightIdentity Proxy a
_ = 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) -> [String
"a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a])
  String
"mappend a mempty"
  (\a
a -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a a
forall a. Monoid a => a
mempty)
  String
"a"
  (\a
a -> a
a)

monoidCommutative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
monoidCommutative :: Proxy a -> Property
monoidCommutative Proxy a
_ = 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,a
b) -> [String
"a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a, String
"b = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
b])
  String
"mappend a b"
  (\(a
a,a
b) -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a a
b)
  String
"mappend b a"
  (\(a
a,a
b) -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
b a
a)