Diamond: Implement property-based tests

exercises/diamond/package.yaml

@@ -1,5 +1,5 @@
 name: diamond
-version: 1.1.0.4
+version: 1.1.0.5
 
 dependencies:
   - base
@@ -19,3 +19,4 @@ tests:
     dependencies:
       - diamond
       - hspec
+      - QuickCheck

exercises/diamond/test/Tests.hs

@@ -3,15 +3,32 @@
 import Data.Foldable     (for_)
 import Test.Hspec        (Spec, describe, it, shouldBe)
 import Test.Hspec.Runner (configFastFail, defaultConfig, hspecWith)
+import Test.QuickCheck   (Gen, elements, forAll, choose)
+import Data.List         ((\\))
+import Data.Maybe        (isNothing, fromMaybe)
+import Data.Char         (ord)
 import Diamond (diamond)
 
 main :: IO ()
 main = hspecWith defaultConfig {configFastFail = True} specs
 
 specs :: Spec
-specs = describe "diamond" $ for_ cases test
-  where
+specs = describe "diamond" $ do
+  it "non-Alpha characters should produce `Nothing`" $
+    forAll genNonAlphaChar $
+      isNothing . diamond
+
+  it "Length of a diamond should be odd" $
+    forAll genAlphaChar $ odd . length . fromMaybe [""] . diamond
+
+  it "Top and bottom of a diamond should be equal" $
+    forAll genAlphaChar $ topEqualToBottom . fromMaybe [""] . diamond
 
+  it "Check the middle of the diamond is correct" $
+    forAll genAlphaChar $ \c -> checkMiddle c . fromMaybe [""] $ diamond c
+
+  for_ cases test
+  where
     test Case{..} = it description assertion
       where
         assertion = diamond input `shouldBe` Just expected
@@ -107,3 +124,27 @@ cases = [ Case { description = "Degenerate case with a single 'A' row"
                         "                         A                         "]
                }
         ]
+
+genNonAlphaChar :: Gen Char
+genNonAlphaChar = elements nonAlphaChars
+  where nonAlphaChars = ['\0' .. '\127'] \\ (['A' .. 'Z'] ++ ['a' .. 'z'])
+
+genAlphaChar :: Gen Char
+genAlphaChar = choose ('A', 'Z')
+
+topLength :: [String] -> Int
+topLength = (`div` 2) . length
+
+topEqualToBottom :: [String] -> Bool
+topEqualToBottom xs = take len xs == take len (reverse xs)
+  where
+    len = topLength xs
+
+checkMiddle :: Char -> [String] -> Bool
+checkMiddle c xs = getMiddle xs == middle
+  where
+    position = ord c - ord 'A'
+    getMiddle ys = ys !! topLength ys
+    leftSide = c : replicate position ' '
+    rightSide = tail . reverse $ leftSide
+    middle = leftSide ++ rightSide