[WIP] Tasty Integration

cabal.project

@@ -0,0 +1,2 @@
+packages: ./hedgehog-classes
+          ./tasty-hedgehog-classes

CHANGELOG.md → hedgehog-classes/CHANGELOG.md

@@ -61,4 +61,4 @@ The changelog is available [on GitHub][2].
 * Initially created.
 
 [1]: https://pvp.haskell.org
-[2]: https://github.com/chessai/hedgehog-classes/releases
+[2]: https://github.com/hedgehogqa/haskell-hedgehog-classes/releases

hedgehog-classes.cabal → hedgehog-classes/hedgehog-classes.cabal

@@ -36,7 +36,7 @@ build-type:
 extra-doc-files:
     README.md
   , CHANGELOG.md
-tested-with: GHC == 8.6.5
+tested-with: GHC == 8.6.5, GHC == 8.8.1
 
 source-repository head
   type:

tasty-hedgehog-classes/CHANGELOG.md

@@ -0,0 +1,11 @@
+# Changelog
+
+`tasty-hedgehog-classes` uses [PVP Versioning][1].
+The changelog is available [on GitHub][2].
+
+0.1
+===
+* Initial version.
+
+[1]: https://pvp.haskell.org
+[2]: https://github.com/hedgehogqa/haskell-hedgehog-classes/releases

tasty-hedgehog-classes/LICENSE

@@ -0,0 +1,29 @@
+BSD 3-Clause License
+
+Copyright (c) 2019, chessai
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+* Neither the name of the copyright holder nor the names of its
+  contributors may be used to endorse or promote products derived from
+  this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

tasty-hedgehog-classes/src/Test/Tasty/Hedgehog/Classes.hs

@@ -0,0 +1,103 @@
+{-# language
+    TypeApplications
+  #-}
+
+module Test.Tasty.Hedgehog.Classes
+  ( testLaws
+  ) where
+
+import Data.Maybe (fromMaybe)
+import Data.Proxy
+import Test.Tasty
+import Test.Tasty.Hedgehog
+import Test.Tasty.Options
+import qualified Test.Tasty.Providers as T
+
+import Hedgehog
+import Hedgehog.Classes
+
+import Hedgehog.Internal.Property
+import Hedgehog.Internal.Runner (checkReport)
+import Hedgehog.Internal.Report
+import Hedgehog.Internal.Seed as Seed
+
+testLaws :: Laws -> T.TestTree
+testLaws (Laws tcName laws_props) = testGroup tcName (go laws_props)
+  where
+    go [] = []
+    go ((lawName,prop):lps) =
+      T.singleTest lawName (P lawName prop) : go lps
+
+data P = P { _testName :: String, _property :: Property }
+
+instance T.IsTest P where
+  testOptions = pure
+    [ Option (Proxy @HedgehogReplay)
+    , Option (Proxy @HedgehogShowReplay)
+    , Option (Proxy @HedgehogTestLimit)
+    , Option (Proxy @HedgehogDiscardLimit)
+    , Option (Proxy @HedgehogShrinkLimit)
+    , Option (Proxy @HedgehogShrinkRetries)
+    ]
+  run opts (P name (Property pConfig pTest)) yieldProgress = do
+    let HedgehogReplay        replay     = lookupOption opts
+    let HedgehogShowReplay    showReplay = lookupOption opts
+    let HedgehogTestLimit     mTests     = lookupOption opts
+    let HedgehogDiscardLimit  mDiscards  = lookupOption opts
+    let HedgehogShrinkLimit   mShrinks   = lookupOption opts
+    let HedgehogShrinkRetries mRetries   = lookupOption opts
+    let config = PropertyConfig
+          (fromMaybe (propertyTestLimit pConfig) mTests)
+          (fromMaybe (propertyDiscardLimit pConfig) mDiscards)
+          (fromMaybe (propertyShrinkLimit pConfig) mShrinks)
+          (fromMaybe (propertyShrinkRetries pConfig) mRetries)
+
+    randSeed <- Seed.random
+    let size = maybe 0 fst replay
+    let seed = maybe randSeed snd replay
+
+    report <- checkReport config size seed pTest (yieldProgress . reportToProgress config)
+
+    let resultFn = if reportStatus report == OK
+          then T.testPassed
+          else T.testFailed
+
+    out <- reportOutput showReplay name report
+    pure $ resultFn out
+
+reportToProgress :: PropertyConfig -> Report Progress -> T.Progress
+reportToProgress config (Report testsDone _ _ status) =
+  let
+    TestLimit testLimit = propertyTestLimit config
+    ShrinkLimit shrinkLimit = propertyShrinkLimit config
+    ratio x y = 1.0 * fromIntegral x / fromIntegral y
+  in
+    -- TODO add details for tests run / discarded / shrunk
+    case status of
+      Running ->
+        T.Progress "Running" (ratio testsDone testLimit)
+      Shrinking fr ->
+        T.Progress "Shrinking" (ratio (failureShrinks fr) shrinkLimit)
+
+reportOutput :: Bool -> String -> Report Result -> IO String
+reportOutput showReplay name report = do
+  s <- renderResult Nothing (Just (PropertyName name)) report
+  case reportStatus report of
+    Failed fr -> do
+      let size = failureSize fr
+      let seed = failureSeed fr
+      let replayStr = if showReplay
+            then "\nUse '--hedgehog-replay \""
+              ++ show size
+              ++ " "
+              ++ show seed
+              ++ "\"' to reproduce."
+            else ""
+      pure $ s ++ replayStr ++ "\n"
+    GaveUp {} -> do
+      let DiscardCount discards = reportDiscards report
+      pure $ s ++ "   ⚐ <interactive> gave up after "
+        ++ show discards
+        ++ " discards.\n"
+    OK -> do
+      pure $ s ++ "   ✓ <interactive> passed 100 tests.\n"

tasty-hedgehog-classes/tasty-hedgehog-classes.cabal

@@ -0,0 +1,53 @@
+cabal-version: 2.2
+name:
+  tasty-hedgehog-classes
+version:
+  0.1
+synopsis:
+  Hedgehog will eat your typeclass bugs
+description:
+  This library extends `hedgehog-classes` with `tasty`.
+homepage:
+  https://github.com/hedgehogqa/haskell-hedgehog-classes
+bug-reports:
+  https://github.com/hedgehogqa/haskell-hedgehog-classes/issues
+license:
+  BSD-3-Clause
+license-file:
+  LICENSE
+author:
+  chessai
+maintainer:
+  [email protected]
+copyright:
+  2019 chessai
+category:
+  Testing
+build-type:
+  Simple
+extra-doc-files:
+    README.md
+  , CHANGELOG.md
+tested-with: GHC == 8.6.5, GHC == 8.8.1
+
+source-repository head
+  type:
+    git
+  location:
+    https://github.com/hedgehogqa/haskell-hedgehog-classes.git
+
+library
+  hs-source-dirs:
+    src
+  exposed-modules:
+    Test.Tasty.Hedgehog.Classes
+  build-depends:
+    , base >= 4.12 && < 4.14
+    , hedgehog >= 1 && < 1.1
+    , hedgehog-classes >= 0.2 && < 0.3
+    , tasty >= 1.2 && < 1.3
+    , tasty-hedgehog >= 1.0 && < 1.1
+  ghc-options:
+    -Wall
+  default-language:
+    Haskell2010