Switch from QuickCheck to Hedgehog.

Haskell/BookingApi.cabal

@@ -22,7 +22,7 @@ library
                        ,         time >= 1.5 && < 1.6
                        ,          mtl >= 2.2 && < 2.3
                        , transformers >= 0.4 && < 0.5
-                       ,   QuickCheck >= 2.1 && < 3.0
+                       ,     hedgehog >= 0.2
 
 test-suite discordia
  type:                exitcode-stdio-1.0
@@ -31,4 +31,4 @@ test-suite discordia
  default-language:    Haskell2010
  build-depends:                 base >= 4.8 && < 4.9
                       ,         time >= 1.5 && < 1.6
-                      ,   QuickCheck >= 2.1 && < 3.0
+                      ,     hedgehog >= 0.2

Haskell/Discordia.hs

@@ -15,28 +15,16 @@
 -- 3. http://wiki.c2.com/?DoTheSimplestThingThatCouldPossiblyWork
 --
 
-import           Control.Monad   (unless)
-import           MaitreDTests
-import           Test.QuickCheck (Property, Result (..), maxSize, maxSuccess,
-                                  property, quickCheckWithResult, stdArgs)
-import           Text.Printf     (printf)
-
-tests :: [(String, Property)]
-tests =
-  [ ("tryAccept behaves correctly when it can accept"
-    , property tryAcceptBehavesCorrectlyWhenItCanAccept)
+{-# LANGUAGE OverloadedStrings #-}
 
-  , ("tryAccept behaves correctly when it can not accept"
-    , property tryAcceptBehavesCorrectlyWhenItCanNotAccept) ]
+import           Hedgehog
+import           MaitreDTests
 
-main :: IO ()
-main = do
-  let args = stdArgs { maxSuccess = 100, maxSize = 100 }
-      qc t = do
-        c <- quickCheckWithResult args t
-        case c of
-          Success{} -> return True
-          _         -> return False
-      perform (s, t) = printf "%-35s: " s >> qc t
-  n <- length . filter not <$> mapM perform tests
-  unless (n == 0) (error (show n ++ " test(s) failed"))
+main :: IO Bool
+main =
+  checkParallel $ Group "Maître d' tests" [
+      ("tryAccept behaves correctly when it can accept"
+      , tryAcceptBehavesCorrectlyWhenItCanAccept)
+    , ("tryAccept behaves correctly when it can not accept"
+      , tryAcceptBehavesCorrectlyWhenItCanNotAccept)
+    ]

Haskell/MaitreDTests.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 module MaitreDTests
     ( tryAcceptBehavesCorrectlyWhenItCanAccept
     , tryAcceptBehavesCorrectlyWhenItCanNotAccept
@@ -11,49 +9,54 @@ import           Data.Time          (LocalTime (..), ZonedTime (..), midnight,
                                      utc)
 import           Data.Time.Calendar (fromGregorian, gregorianMonthLength)
 import           MaitreD
-import           Test.QuickCheck
 
-instance Arbitrary ZonedTime where
-  arbitrary = do
-    y <- choose (1, 9999)
-    m <- choose (1, 12)
-    d <- choose (1, gregorianMonthLength y m)
-    return $ ZonedTime (LocalTime (fromGregorian y m d) midnight) utc
+import           Hedgehog
+import qualified Hedgehog.Gen       as Gen
+import qualified Hedgehog.Range     as Range
+
+genZonedTime :: Monad m => Gen m ZonedTime
+genZonedTime = do
+    y <- Gen.int (Range.constant 1 9999)
+    m <- Gen.int (Range.constant 1 12)
+    d <- Gen.int (Range.constant 1 (gregorianMonthLength (toInteger y) m))
+    return $ ZonedTime (LocalTime (fromGregorian (toInteger y) m d) midnight) utc
 
-genReservation :: Gen Reservation
+genReservation :: Monad m => Gen m Reservation
 genReservation = do
-  bookingDate <- arbitrary
-  Positive qt <- arbitrary
-  trueOrFalse <- arbitrary
+  bookingDate <- genZonedTime
+  positiveQty <- Gen.int (Range.linear 1 100)
+  trueOrFalse <- Gen.bool
   return Reservation
     { date       = bookingDate
-    , quantity   = qt
+    , quantity   = positiveQty
     , isAccepted = trueOrFalse }
 
 sumBy :: Num a => (b -> a) -> [b] -> a
 sumBy x xs = sum $ map x xs
 
-tryAcceptBehavesCorrectlyWhenItCanAccept :: NonNegative Int -> Property
-tryAcceptBehavesCorrectlyWhenItCanAccept (NonNegative excessCapacity) =
-  forAll
-    (liftM2 (,) genReservation $ listOf genReservation)
-    (\(reservation, reservations) ->
-      let capacity =
-            excessCapacity
-            + sumBy quantity reservations
-            + quantity reservation
+tryAcceptBehavesCorrectlyWhenItCanAccept :: Property
+tryAcceptBehavesCorrectlyWhenItCanAccept =
+  property $ do
+    reservation    <- forAll genReservation
+    reservations   <- forAll $ Gen.list (Range.linear 0 100) genReservation
+    excessCapacity <- forAll $ Gen.int  (Range.linear 0 100)
+    let capacity =
+          excessCapacity
+          + sumBy quantity reservations
+          + quantity reservation
 
-          actual = tryAccept capacity reservations reservation
+        actual = tryAccept capacity reservations reservation
 
-      in Just (reservation { isAccepted = True }) == actual)
+    Just (reservation { isAccepted = True }) === actual
 
-tryAcceptBehavesCorrectlyWhenItCanNotAccept :: Positive Int -> Property
-tryAcceptBehavesCorrectlyWhenItCanNotAccept (Positive lackingCapacity) =
-  forAll
-    (liftM2 (,) genReservation $ listOf genReservation)
-    (\(reservation, reservations) ->
-      let capacity = sumBy quantity reservations - lackingCapacity
+tryAcceptBehavesCorrectlyWhenItCanNotAccept :: Property
+tryAcceptBehavesCorrectlyWhenItCanNotAccept =
+  property $ do
+    reservation     <- forAll genReservation
+    reservations    <- forAll $ Gen.list (Range.linear 0 100) genReservation
+    lackingCapacity <- forAll $ Gen.int  (Range.linear 1 100)
+    let capacity = sumBy quantity reservations - lackingCapacity
 
-          actual = tryAccept capacity reservations reservation
+        actual = tryAccept capacity reservations reservation
 
-      in isNothing actual)
+    Nothing === actual

Haskell/stack.yaml

@@ -39,7 +39,9 @@ packages:
 - '.'
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
-extra-deps: []
+extra-deps:
+- hedgehog-0.2
+- wl-pprint-annotated-0.0.1.4
 
 # Override default flag values for local packages and extra-deps
 flags: {}