Diamond: Implement property-based tests

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

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

exercises/diamond/examples/success-standard/src/Diamond.hs

@@ -2,15 +2,11 @@ module Diamond (diamond) where
 
 import Data.Char (ord, chr)
 
-pad :: Int -> String
-pad x = replicate x ' '
-
-oneRow :: Char -> (Int, Int) -> String
-oneRow c (0, y) = pad y ++ [c] ++ pad y
-oneRow c (x, y) = pad y ++ [c] ++ pad x ++ [c] ++ pad y
-
 diamond :: Char -> Maybe [String]
-diamond = Just . (\x -> x ++ tail (reverse x)) . mkTop . subtract 64 . ord
-  where rows x = zip (0 : take (x-1) [1, 3..]) [x-1, x-2..0]
-        mkTop  = zipWith oneRow abc . rows
-        abc    = map chr [65..90]
+diamond c | c `notElem` ['A'..'Z'] = Nothing
+diamond c = Just . mirror . map row $ [0..n] where
+  n = ord c - ord 'A'
+  mirror top = top ++ reverse (init top)
+  row i = mirror $ spaces (n - i) ++ [letter i] ++ spaces i
+  letter i = chr (ord 'A' + i)
+  spaces i = replicate i ' '

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

@@ -1,17 +1,53 @@
 {-# LANGUAGE RecordWildCards #-}
 
+import Data.Char         (isLetter, isPrint, isSpace)
 import Data.Foldable     (for_)
+import Data.List         (isSuffixOf)
+import Data.Maybe        (isJust, isNothing)
 import Test.Hspec        (Spec, describe, it, shouldBe)
 import Test.Hspec.Runner (configFastFail, defaultConfig, hspecWith)
+import Test.QuickCheck   (arbitraryASCIIChar, conjoin, counterexample,
+                          discard, elements, forAll, forAllShrink, Gen,
+                          Property, suchThat, Testable, (===))
+
 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 "should not have a result for a non-alpha character" $
+    forAllShrink genNonAlphaChar shrinkNonAlphaChar $
+      isNothing . diamond
+
+  it "should produce a value for an alpha character" $
+    forAll genAlphaChar $ isJust . diamond
+
+  it "should have an odd number of rows" $
+    forAllDiamond $ odd . length
+
+  it "should have equal top and bottom" $
+    forAllDiamond $ \rows ->
+      let halfRoundDown = length rows `div` 2
+      in take halfRoundDown rows === take halfRoundDown (reverse rows)
+
+  it "should have the same width and height" $
+    forAllDiamond $ \rows ->
+      let sameHeightWidth idx row = counterexample
+            (concat [ "The length of row with index "
+                    , show idx
+                    , " is not equal to the height" ])
+            (length row === length rows)
+      in conjoin $ zipWith sameHeightWidth [0 :: Int ..] rows
+
+  it "rows should start and end with the same letter" $
+    forAllDiamond $
+      let headEqualsLast row = not (null row) && take 1 row `isSuffixOf` row
+      in (&&) <$> not . null <*> all (headEqualsLast . filter (not . isSpace))
 
+  for_ cases test
+  where
     test Case{..} = it description assertion
       where
         assertion = diamond input `shouldBe` Just expected
@@ -107,3 +143,23 @@ cases = [ Case { description = "Degenerate case with a single 'A' row"
                         "                         A                         "]
                }
         ]
+
+genNonAlphaChar :: Gen Char
+genNonAlphaChar = arbitraryASCIIChar `suchThat` (not . isLetter)
+
+genAlphaChar :: Gen Char
+genAlphaChar = elements ['A'..'Z']
+
+genDiamond :: Gen (Maybe [String])
+genDiamond = diamond <$> genAlphaChar
+
+forAllDiamond :: Testable prop => ([String] -> prop) -> Property
+forAllDiamond p = forAll genDiamond $ maybe discard p
+
+shrinkNonAlphaChar :: Char -> String
+shrinkNonAlphaChar c =
+  if isPrint c
+  then takeWhile (/= c) printableChars
+  else printableChars
+  where
+    printableChars = filter isPrint ['\0' .. '\127']