allergies: Property-based tests.

exercises/allergies/examples/success-standard/package.yaml

@@ -14,3 +14,4 @@ tests:
     dependencies:
       - allergies
       - hspec
+      - QuickCheck

exercises/allergies/package.yaml

@@ -1,5 +1,5 @@
 name: allergies
-version: 1.2.0.5
+version: 1.2.0.6
 
 dependencies:
   - base
@@ -18,3 +18,4 @@ tests:
     dependencies:
       - allergies
       - hspec
+      - QuickCheck

exercises/allergies/src/Allergies.hs

@@ -8,7 +8,7 @@ data Allergen = Eggs
               | Chocolate
               | Pollen
               | Cats
-              deriving (Eq)
+              deriving (Eq, Show)
 
 allergies :: Int -> [Allergen]
 allergies score = error "You need to implement this function."

exercises/allergies/test/Tests.hs

@@ -1,7 +1,10 @@
 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
 
+import Test.QuickCheck   (Gen, forAll, forAllShrink, elements, sublistOf, suchThat)
 import Test.Hspec        (Spec, describe, it, shouldBe)
 import Test.Hspec.Runner (configFastFail, defaultConfig, hspecWith)
+import Data.List         (delete, lookup)
+import Data.Maybe        (mapMaybe)
 
 import Allergies
   ( Allergen ( Cats
@@ -48,6 +51,34 @@ specs = do
               isAllergicTo Shellfish    score `shouldBe` False
               isAllergicTo Strawberries score `shouldBe` True
 
+            -- Property: For an arbitrary `allergen` and its `score`,
+            -- `isAllergicTo allergen score` is True.
+
+            it "accepts single allergens" $ forAll allergenWithScore $
+              uncurry isAllergicTo
+
+            -- Property: For an arbitrary `score` and arbitrary `allergen`
+            -- that does not match it, `isAllergicTo allergen score` is
+            -- False.
+
+            it "rejects mismatching allergens" $ forAll complementWithScore $
+              not . uncurry isAllergicTo
+
+            -- Property: For an arbitrary set of `allergens` and their
+            -- combined `score`, it holds for all `allergen` in `allergens`
+            -- that `isAllergicTo allergen score` is True.
+
+            it "accepts multiple allergens" $ forAll allergensWithScore $
+              \(allergens, score) -> all (`isAllergicTo` score) allergens
+
+            -- Property: For an arbitrary `score` and all `allergens` that
+            -- are not part of that score, `isAllergicTo allergen score` is
+            -- False.
+
+            it "rejects multiple mismatching allergens" $
+              forAllShrink complementsWithScore shrinkComplementsWithScore $
+                \(allergens, score) -> all (not . (`isAllergicTo` score)) allergens
+
           describe "allergies" $ do
 
             let xs `shouldMatch` ys =  all (`elem` ys) xs
@@ -98,3 +129,66 @@ specs = do
                                           , Shellfish
                                           , Strawberries
                                           , Tomatoes     ]
+
+            -- Property: For an arbitrary `allergen` and its `score`,
+            -- `allergies score` is a list of exactly the element
+            -- `allergen`.
+
+            it "accepts single allergens" $ forAll allergenWithScore $
+              \(allergen, score) -> allergies score == [allergen]
+
+            -- Property: For an arbitrary set of `allergens` and their
+            -- combined `score`, `allergies score` is a list of exactly
+            -- `allergens`.
+
+            it "accepts multiple allergens" $
+              forAllShrink allergensWithScore shrinkAllergensWithScore $
+                \(allergens, score) -> allergies score == allergens
+
+allergenScores :: [(Allergen, Int)]
+allergenScores =
+  [ (Eggs,           1)
+  , (Peanuts,        2)
+  , (Shellfish,      4)
+  , (Strawberries,   8)
+  , (Tomatoes,      16)
+  , (Chocolate,     32)
+  , (Pollen,        64)
+  , (Cats,         128)
+  ]
+
+allergenWithScore :: Gen (Allergen, Int)
+allergenWithScore = elements allergenScores
+
+complementWithScore :: Gen (Allergen, Int)
+complementWithScore = do
+  (allergen, score) <- allergenWithScore
+  (complement, _) <- allergenWithScore `suchThat` ((/= allergen) . fst)
+  return (complement, score)
+
+allergensWithScore :: Gen ([Allergen], Int)
+allergensWithScore = fmap sum . unzip <$> sublistOf allergenScores
+
+complementsWithScore :: Gen ([Allergen], Int)
+complementsWithScore = do
+  (allergens, score) <- allergensWithScore
+  let complements = [ allergen | (allergen, _) <- allergenScores
+                               , allergen `notElem` allergens ]
+  return (complements, score)
+
+shrinkAllergensWithScore :: ([Allergen], Int) -> [([Allergen], Int)]
+shrinkAllergensWithScore (allergens, score) =
+  mapMaybe (\allergen -> without allergen <$> scoreFor allergen) allergens
+  where
+    without :: Allergen -> Int -> ([Allergen], Int)
+    without allergen allergenScore =
+      (delete allergen allergens, score - allergenScore)
+
+    scoreFor :: Allergen -> Maybe Int
+    scoreFor = flip lookup allergenScores
+
+shrinkComplementsWithScore :: ([Allergen], Int) -> [([Allergen], Int)]
+shrinkComplementsWithScore (allergens, score) = map without allergens
+  where
+    without :: Allergen -> ([Allergen], Int)
+    without allergen = (delete allergen allergens, score)