DiffMonoid.hs

#!/usr/bin/env stack
-- stack --resolver lts-6.4 --install-ghc runghc --package unordered-containers --package QuickCheck --package hashable

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module DiffMonoid where

import Data.Hashable (Hashable)
import Data.Monoid ((<>))
import Test.QuickCheck
import qualified Data.HashSet as HS

data DiffMonoid a
  = DiffMonoid
  { dmGenerated :: HS.HashSet a
  , dmGarbage :: HS.HashSet a
  } deriving (Show, Eq)

instance (Arbitrary a, Eq a, Hashable a) => Arbitrary (DiffMonoid a) where
  arbitrary = DiffMonoid <$> arbitrarySet <*> arbitrarySet
    where
      arbitrarySet = HS.fromList <$> arbitrary

instance (Eq a, Hashable a) => Monoid (DiffMonoid a) where
  mempty = DiffMonoid mempty mempty
  mappend a b =
    DiffMonoid
      { dmGenerated = (dmGenerated a `HS.difference` dmGarbage b) `HS.union` dmGenerated b
      , dmGarbage = (dmGarbage a `HS.difference` dmGenerated b) `HS.union` dmGarbage b
      }

newtype DiffMonoidDistinct a
  = DiffMonoidDistinct
  { unDiffMonoidDistinct :: DiffMonoid a
  } deriving (Show, Eq, Monoid)

isDistinct :: (Hashable a, Eq a) => DiffMonoid a -> Bool
isDistinct dm = HS.null (HS.intersection (dmGenerated dm) (dmGarbage dm))

instance (Arbitrary a, Eq a, Hashable a) => Arbitrary (DiffMonoidDistinct a) where
  arbitrary = DiffMonoidDistinct <$> (arbitrary `suchThat` isDistinct)

prop_neutralRight :: (Monoid m, Eq m) => m -> Bool
prop_neutralRight x = x <> mempty == x

prop_neutralLeft :: (Monoid m, Eq m) => m -> Bool
prop_neutralLeft x = mempty <> x == x

prop_assoc :: (Monoid m, Eq m) => m -> m -> m -> Bool
prop_assoc x y z = (x <> y) <> z == x <> (y <> z)

prop_distinctIsSubset :: (Hashable a, Eq a) => DiffMonoidDistinct a -> DiffMonoidDistinct a -> Bool
prop_distinctIsSubset x y = isDistinct (unDiffMonoidDistinct (x <> y))

main :: IO ()
main = do
  quickCheck (prop_neutralRight :: DiffMonoid Char -> Bool)
  quickCheck (prop_neutralLeft :: DiffMonoid Char -> Bool)
  quickCheck (prop_assoc :: DiffMonoid Char -> DiffMonoid Char -> DiffMonoid Char -> Bool)
  quickCheck (prop_distinctIsSubset :: DiffMonoidDistinct Char -> DiffMonoidDistinct Char -> Bool)