QuickCheck and Monoid experimentation

quickCheckAndMonoid.hs

import Test.QuickCheck
import Data.List
import Data.Monoid

prop_revapp :: [Int] -> [Int] -> Bool
prop_revapp xs ys = reverse (ys++xs) == reverse xs ++ reverse ys

quotVsRem :: Integral a => a -> a -> Bool
quotVsRem x y = quot x y * y + rem x y == x

divVsMod :: Integral a => a -> a -> Bool
divVsMod x y = div x y * y + mod x y == x

genTupleNonZero :: (Arbitrary a, Num a, Eq a) => Gen (a, a)
genTupleNonZero = do
  x <- arbitrary `suchThat` (/= 0)
  y <- arbitrary `suchThat` (/= 0)
  return (x, y)

prop_quotRem :: Property
prop_quotRem =
  forAll (genTupleNonZero :: Gen (Int, Int))
  (uncurry quotVsRem)

prop_divMod :: Property
prop_divMod =
  forAll (genTupleNonZero :: Gen (Int, Int))
  (uncurry divVsMod)

genList :: (Arbitrary a, Eq a) => Gen [a]
genList = do
  a <- arbitrary
  b <- arbitrary `suchThat` (/= a)
  c <- arbitrary `suchThat` (`notElem` [a, b])
  return [a, b, c]

listOrdered :: (Ord a) => [a] -> Bool
listOrdered xs = snd $ foldr go (Nothing, True) xs
  where go _ status@(_, False) = status
        go y (Nothing, t) = (Just y, t)
        go y (Just x, t) = (Just y, x >= y)

prop_listOrdered :: Property
prop_listOrdered =
    forAll (genList :: Gen String)
    (listOrdered . sort)
    
data Optional a = Nada | Only a deriving (Eq, Show)

instance Monoid a => Monoid (Optional a) where
  mempty = Nada
  mappend (Only a) (Only b) = Only (mappend a b)
  mappend Nada b = b
  mappend a Nada = a

genOptional :: (Eq a, Arbitrary a) => Gen (Optional a)
genOptional = do
  a <- arbitrary
  elements [Nada, Only a]

instance Arbitrary a => Arbitrary (Optional a) where
  arbitrary = do
    x <- arbitrary
    frequency [ (1, return (Only x))
              , (1, return Nada)]

prop_Optional_identity :: Property
prop_Optional_identity =
    forAll (genOptional :: Gen (Optional String))
      (\x -> mappend x (mempty x) == mappend (mempty x) x)

prop_Optional_associativity :: Optional String -> Optional String -> Optional String -> Bool
prop_Optional_associativity x y z =
    mappend x (mappend y z) == mappend (mappend x y) z

--sample' (genOptional  :: Gen (Optional Int))

monoidAssoc :: (Eq m, Monoid m) => m -> m -> m -> Bool
monoidAssoc a b c = (a <> (b <> c)) == ((a <> b) <> c)

monoidLeftIdentity :: (Eq m, Monoid m) => m -> Bool
monoidLeftIdentity a = (mempty <> a) == a

monoidRightIdentity :: (Eq m, Monoid m) => m -> Bool
monoidRightIdentity a = (a <> mempty) == a

newtype First' a = First' {
    getFirst' :: Optional a
  } deriving (Eq, Show)

instance Monoid (First' a) where
  mempty = First' Nada
  mappend (First' (Only x)) _ = First' (Only x)
  mappend (First' Nada) (First' (Only x)) = First' (Only x)
  mappend _ _ = First' Nada


instance Arbitrary a => Arbitrary (First' a) where
  arbitrary = do
    x <- arbitrary
    frequency [ (1, return (First' (Only x)))
              , (1, return (First' Nada))]

firstMappend :: First' a -> First' a -> First' a
firstMappend = mappend

type FirstMappend =
     First' String
  -> First' String
  -> First' String
  -> Bool

main :: IO ()
main = do
  quickCheck (monoidAssoc :: FirstMappend)
  quickCheck (monoidLeftIdentity :: First' String -> Bool)
  quickCheck (monoidRightIdentity :: First' String -> Bool)