Permalink
Browse files

Switch from QuickCheck to Hedgehog.

  • Loading branch information...
moodmosaic committed Apr 10, 2017
1 parent f21b5d1 commit e088c7e1763f34b52240b4c3d0b2c1e421e0e3b7
Showing with 52 additions and 59 deletions.
  1. +2 −2 Haskell/BookingApi.cabal
  2. +11 −23 Haskell/Discordia.hs
  3. +36 −33 Haskell/MaitreDTests.hs
  4. +3 −1 Haskell/stack.yaml
View
@@ -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
View
@@ -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)
]
View
@@ -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
View
@@ -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: {}

0 comments on commit e088c7e

Please sign in to comment.