Fancy Monoids

Service.Types.hs

{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}

module Service.Types where

--------------------------------------------------------------------------------
import Control.Lens
import Data.List (nub)
import Data.Text (Text)
--------------------------------------------------------------------------------

-- | 'Control' determines whether this node is the owner of a TCP connection for
-- N data brokers across a range of domains.
data Control
  = Node [Text]
  deriving (Eq, Show)

instance Semigroup Control where
  Node t0 <> Node t1 = Node (nub $ t0 <> t1)

instance Monoid Control where
  mempty = Node []
  mappend a b = a <> b

removeControl :: Text -> Control -> Control
removeControl t (Node ts) = Node (filter (/= t) ts)

data Service
  = Service
  { serviceControl :: Control
  }

makeFields ''Service

defaultService :: Service
defaultService = Service mempty

Service.TypeSpec.hs

{-# LANGUAGE OverloadedStrings #-}

module Service.TypesSpec where

--------------------------------------------------------------------------------
import Test.Hspec
import Test.QuickCheck
--------------------------------------------------------------------------------
import Data.List (nub)
import Data.Text (Text)
--------------------------------------------------------------------------------
import Service.Types
--------------------------------------------------------------------------------

instance Arbitrary Text where
  arbitrary = elements ["aa", "bb", "cc"]

instance Arbitrary Control where
  arbitrary = do
    es <- listOf arbitrary
    return $ Node (nub es)

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

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

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

prop_removeControl :: Text -> Control -> Bool
prop_removeControl t m@(Node x) =
  let (Node y) = removeControl t m
  in
    if not . elem t $ x
    then x == y
    else and [ length y == length x - 1, not . elem t $ y ]

spec :: Spec
spec = do
  describe "Control Monoid" $ do
    it "is associative" $
      quickCheck (prop_monoidAssoc :: Control -> Control -> Control -> Bool)
    it "is right identity" $
      quickCheck (prop_monoidRightId :: Control -> Bool)
    it "is left identity" $
      quickCheck (prop_monoidLeftId :: Control -> Bool)
  describe "Control Function" $
    it "element can be removed" $
      quickCheck (prop_removeControl :: Text -> Control -> Bool)