Demonstration of one way to implement subset types, with chosen element type.

TypedSubsets.hs

{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedLists            #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilyDependencies     #-}
{-# LANGUAGE UndecidableInstances       #-}

module TypedSubsets
  (
    Subsettable(..)
  , Subset -- NB constructor not exported
  , build
  , complement
  , difference
  , filter
  , foldMap
  , foldr
  , for_
  , intersection
  , member
  , singleton
  , test
  , toList
  , traverse_
  ) where

import           Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import           Data.Hashable (Hashable)
import           Prelude hiding (filter, foldr, foldMap, showList)
import           Data.String
import           Data.List (intercalate, isPrefixOf, isSuffixOf, sort)
import qualified Data.Foldable as Foldable

-- | Type class representing sets of values whose subsets we want to work with.
class Subsettable s where
  type ElementType s
  allValues :: Subset s

newtype Subset s = Subset { unSubset :: HashSet (ElementType s) }

deriving instance Show (ElementType s)     => Show (Subset s)
deriving instance Eq (ElementType s)       => Eq (Subset s)
deriving instance Ord (ElementType s)      => Ord (Subset s)
deriving instance Hashable (ElementType s) => Hashable (Subset s)
deriving instance Hashable (ElementType s) => Semigroup (Subset s)
deriving instance Hashable (ElementType s) => Monoid (Subset s)

foldMap :: Monoid m => (ElementType s -> m) -> Subset s -> m
foldMap f = Foldable.foldMap f . unSubset

foldr :: (ElementType s -> b -> b) -> b -> Subset s -> b
foldr f b = Foldable.foldr f b . unSubset

traverse_ :: Applicative f => (ElementType s -> f ()) -> Subset s -> f ()
traverse_ f = Foldable.traverse_ f . unSubset

for_ :: Applicative f => Subset s -> (ElementType s -> f ()) -> f ()
for_ = flip traverse_

toList :: Subset s -> [ElementType s]
toList = HS.toList . unSubset

singleton :: forall s. (Subsettable s, Hashable (ElementType s)) => ElementType s -> Maybe (Subset s)
singleton e
  | HS.member e (unSubset (allValues @s)) = Just (Subset (HS.singleton e))
  | otherwise                             = Nothing

build :: (Foldable t, Subsettable s, Hashable (ElementType s)) => t (ElementType s) -> Maybe (Subset s)
build = fmap (Foldable.foldr union empty) . traverse singleton . Foldable.toList

empty :: Subset s
empty = Subset HS.empty

union :: Eq (ElementType s) => Subset s -> Subset s -> Subset s
union = liftOp HS.union

difference :: Hashable (ElementType s) => Subset s -> Subset s -> Subset s
difference = liftOp HS.difference

intersection :: Ord (ElementType s) => Subset s -> Subset s -> Subset s
intersection = liftOp HS.intersection

filter :: (ElementType s -> Bool) -> Subset s -> Subset s
filter pred = Subset . HS.filter pred . unSubset

complement :: (Subsettable s, Hashable (ElementType s)) => Subset s -> Subset s
complement = difference allValues

member :: Hashable (ElementType s) => ElementType s -> Subset s -> Bool
member e = HS.member e . unSubset

liftOp :: (HashSet (ElementType s) -> HashSet (ElementType s) -> HashSet (ElementType s))
       -> Subset s                 -> Subset s                -> Subset s
liftOp op s1 s2 = Subset $ unSubset s1 `op` unSubset s2


--------------------------------------------------------------------------------
-- Example
--------------------------------------------------------------------------------

-- Some types for the example
newtype Animal = Animal { animalName :: String }
  deriving stock (Eq, Ord)
  deriving newtype (IsString, Hashable)
  deriving Show via Unwrap

newtype Plant = Plant { plantName :: String }
  deriving stock (Eq, Ord)
  deriving newtype (IsString, Hashable)
  deriving Show via Unwrap

-- Labels for sets whose subsets we want to work with

data Dogs
data Cats
data Plants
data IntsUnder100

-- Declare the element type and the set of all permissable values for each.

instance Subsettable Cats where
  type ElementType Cats = Animal
  allValues = Subset catBreeds

instance Subsettable Dogs where
  type ElementType Dogs = Animal
  allValues = Subset dogBreeds

instance Subsettable Plants where
  type ElementType Plants = Plant
  allValues = Subset plantNames

instance Subsettable IntsUnder100 where
  type ElementType IntsUnder100 = Int
  allValues = Subset [1..99]

test :: IO ()
test = do
  let
    dogsStartingWithG  = filter (("G" `isPrefixOf`)         . animalName) $ allValues @Dogs
    retrievers         = filter (("Retriever" `isSuffixOf`) . animalName) $ allValues @Dogs
    catsStartingWithS  = filter (("S" `isPrefixOf`)         . animalName) $ allValues @Cats
    trees              = filter (("Tree" `isSuffixOf`) .      plantName)  $ allValues @Plants
    herbs              = complement trees
    treesStartingWithB = filter (("B" `isPrefixOf`) . plantName) trees
    herbsStartingWithW = filter (("W" `isPrefixOf`) . plantName) herbs

  putStrLn $ "Dog breeds starting with G: " ++ showSubset dogsStartingWithG ++ "."
  putStrLn $ "Retriever breeds: " ++ showSubset retrievers ++ "."
  putStrLn $ "Retrievers starting with G: " ++
    showSubset (dogsStartingWithG `intersection` retrievers) ++ "."

  putStrLn $ "Trees starting with B: " ++ showSubset treesStartingWithB ++ "."
  putStrLn $ "Herbs starting with W: " ++ showSubset herbsStartingWithW ++ "."
  putStrLn $ "Trees starting with B and herbs starting with W: " ++
    showSubset (treesStartingWithB `union` herbsStartingWithW) ++ "."


  -- The compiler won't let us mix subsets inappropriately:
  -- • Couldn't match type ‘Plants’ with ‘Cats’
  --   Expected: Subset Cats
  --     Actual: Subset Plants
  -- let typeError1 = catsStartingWithS `union` treesStartingWithB

  -- • Couldn't match type ‘Plant’ with ‘Animal’
  -- Expected: HashSet Animal
  --   Actual: HashSet (ElementType Plants)
  -- let typeError2 = unSubset catsStartingWithS `HS.union` unSubset treesStartingWithB

  -- It's a type error to try to operate on subsets of different top sets, even
  --   if the element types match. Here, both contain Animals, but the top sets
  --   are different. The compiler tells us:
  --
  --   • Couldn't match type ‘Cats’ with ‘Dogs’
  --   Expected: Subset Dogs
  --     Actual: Subset Cats
  -- let typeError3 = dogsStartingWithG `intersection` catsStartingWithS


  -- Creating a subset from explicit values requires a runtime check that may fail:
  let
    animalLists :: [HashSet Animal]
    animalLists = [["Maine Coon", "Bengal"], ["Maine Coon", "Bengal", "Rottweiler"]]

  Foldable.for_ animalLists $ \animals -> do
    putStrLn $ "Are these animals all cats: " ++ showFoldable animals ++ "?"
    let
      ms :: Maybe (Subset Cats)
      ms = build animals
    case ms of
      Just s  -> putStrLn $ "  Yes: built " ++ show s
      Nothing -> putStrLn "  No: failed to build subset"


  let
    divisibleBy3 = filter (\n -> n `mod` 3 == 0) $ allValues @IntsUnder100
    divisibleBy5 = filter (\n -> n `mod` 5 == 0) $ allValues @IntsUnder100
    divisibleBy15 = divisibleBy3 `intersection` divisibleBy5

  Foldable.for_ (sort . toList $ allValues @IntsUnder100) $ \n -> do
    putStr $
      if member n divisibleBy15 then "FizzBuzz "
      else if member n divisibleBy3 then "Fizz "
      else if member n divisibleBy5 then "Buzz "
      else show n ++ " "
  putStrLn ""

--------------------------------------------------------------------------------
-- Data for example
--------------------------------------------------------------------------------

catBreeds :: HashSet Animal
catBreeds =
  [ "Persian"
  , "Siamese"
  , "Maine Coon"
  , "British Shorthair"
  , "Ragdoll"
  , "Bengal"
  , "Sphynx"
  , "Russian Blue"
  , "Norwegian Forest Cat"
  , "Abyssinian"
  , "Scottish Fold"
  , "American Shorthair"
  ]

dogBreeds :: HashSet Animal
dogBreeds =
  [ "German Shepherd"
  , "Labrador Retriever"
  , "Golden Retriever"
  , "French Bulldog"
  , "Poodle"
  , "Rottweiler"
  , "Yorkshire Terrier"
  , "Boxer"
  , "Dachshund"
  , "Great Dane"
  , "Siberian Husky"
  , "Doberman Pinscher"
  ]

plantNames :: HashSet Plant
plantNames =
  [ "Meadowsweet"
  , "Pine Tree"
  , "Yellow Rattle"
  , "Willow Tree"
  , "Wild Garlic"
  , "Foxglove"
  , "Cedar Tree"
  , "Red Campion"
  , "Elm Tree"
  , "Dog Rose"
  , "Spruce Tree"
  , "Wood Anemone"
  , "Maple Tree"
  , "Common Poppy"
  , "Birch Tree"
  , "Bluebell"
  , "Oak Tree"
  , "Beech Tree"
  , "Cowslip"
  , "Ash Tree"
  ]

newtype Unwrap = Unwrap String

instance Show Unwrap where
  show (Unwrap s) = s

showSubset :: Show (ElementType s) => Subset s -> String
showSubset = showList . toList

showFoldable :: (Foldable t, Show a) => t a -> String
showFoldable = showList . Foldable.toList

showList :: Show a => [a] -> String
showList = intercalate ", " . map show