diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013-2015 Simon Hengel +Copyright (c) 2013-2018 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/example/Spec.hs b/example/Spec.hs new file mode 100644 --- /dev/null +++ b/example/Spec.hs @@ -0,0 +1,16 @@ +module Main (main, spec) where + +import Test.Hspec +import Test.Hspec.SmallCheck + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "reverse" $ do + it "reverses a list" $ do + reverse [1 :: Int, 2, 3] `shouldBe` [3, 2, 1] + + it "gives the original list, if applied twice" $ property $ + \xs -> (reverse . reverse) xs `shouldBe` (xs :: [Int]) diff --git a/hspec-smallcheck.cabal b/hspec-smallcheck.cabal --- a/hspec-smallcheck.cabal +++ b/hspec-smallcheck.cabal @@ -1,11 +1,17 @@ +-- This file has been generated from package.yaml by hpack version 0.21.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 9cd99f0806cf8dfefb5b2761767e11bcc64bbb719b6d31200201b36702038392 + name: hspec-smallcheck -version: 0.4.2 +version: 0.5.0 license: MIT license-file: LICENSE -copyright: (c) 2013-2015 Simon Hengel +copyright: (c) 2013-2018 Simon Hengel maintainer: Simon Hengel build-type: Simple -cabal-version: >= 1.8 +cabal-version: >= 1.10 category: Testing bug-reports: https://github.com/hspec/hspec-smallcheck/issues homepage: http://hspec.github.io/ @@ -17,31 +23,61 @@ location: https://github.com/hspec/hspec-smallcheck library - ghc-options: - -Wall + ghc-options: -Wall hs-source-dirs: src exposed-modules: Test.Hspec.SmallCheck + other-modules: + Test.Hspec.SmallCheck.Compat + Test.Hspec.SmallCheck.Types + Paths_hspec_smallcheck build-depends: - base == 4.* - , hspec-core >= 2.4 - , smallcheck >= 1.0 + HUnit + , base >=4.5.0.0 && <5 + , call-stack + , hspec-core ==2.4.* + , smallcheck >=1.1 + default-language: Haskell2010 -test-suite spec - type: - exitcode-stdio-1.0 - ghc-options: - -Wall +test-suite example + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_hspec_smallcheck hs-source-dirs: - test - main-is: - Spec.hs + example + ghc-options: -Wall build-depends: - base == 4.* + HUnit + , base >=4.5.0.0 && <5 + , call-stack , hspec - , hspec-core - , smallcheck - + , hspec-core ==2.4.* , hspec-smallcheck + , smallcheck >=1.1 + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: -Wall + hs-source-dirs: + src + test + main-is: Spec.hs + other-modules: + Test.Hspec.SmallCheck + Test.Hspec.SmallCheck.Compat + Test.Hspec.SmallCheck.Types + Test.Hspec.SmallCheck.TypesSpec + Test.Hspec.SmallCheckSpec + Paths_hspec_smallcheck + build-depends: + HUnit , QuickCheck + , base >=4.5.0.0 && <5 + , call-stack + , hspec + , hspec-core ==2.4.* + , smallcheck >=1.1 + default-language: Haskell2010 diff --git a/src/Test/Hspec/SmallCheck.hs b/src/Test/Hspec/SmallCheck.hs --- a/src/Test/Hspec/SmallCheck.hs +++ b/src/Test/Hspec/SmallCheck.hs @@ -1,18 +1,48 @@ -{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Hspec.SmallCheck (property) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Prelude () +import Test.Hspec.SmallCheck.Compat + import Data.IORef import Test.Hspec.Core.Spec import Test.SmallCheck import Test.SmallCheck.Drivers +import qualified Test.HUnit.Lang as HUnit +import Control.Exception (try) +import Data.Maybe +import Data.CallStack +import qualified Test.Hspec.SmallCheck.Types as T + property :: Testable IO a => a -> Property IO property = test +srcLocToLocation :: SrcLoc -> Location +srcLocToLocation loc = Location { + locationFile = srcLocFile loc +, locationLine = srcLocStartLine loc +, locationColumn = srcLocStartCol loc +, locationAccuracy = ExactLocation +} + +instance Testable IO (IO ()) where + test action = monadic $ do + r <- try action + return $ case r of + Right () -> test True + Left e -> case e of + HUnit.HUnitFailure loc reason -> test . failure $ case reason of + HUnit.Reason s -> T.Reason s + HUnit.ExpectedButGot prefix expected actual -> T.ExpectedActual (fromMaybe "" prefix) expected actual + where + failure :: T.Reason -> Either String String + failure = Left . show . T.Failure (srcLocToLocation <$> loc) + instance Example (Property IO) where type Arg (Property IO) = () evaluateExample p c _ reportProgress = do @@ -21,4 +51,11 @@ modifyIORef counter succ n <- readIORef counter reportProgress (n, 0) - maybe Success (Failure Nothing . Reason . ppFailure) <$> smallCheckWithHook (paramsSmallCheckDepth c) hook p + r <- smallCheckWithHook (paramsSmallCheckDepth c) hook p + return $ case r of + Just e -> case T.parseResult (ppFailure e) of + (m, Just (T.Failure loc reason)) -> Failure loc $ case reason of + T.Reason err -> Reason (fromMaybe "" $ T.concatPrefix m err) + T.ExpectedActual prefix expected actual -> ExpectedButGot (T.concatPrefix m prefix) expected actual + (m, Nothing) -> Failure Nothing (Reason m) + Nothing -> Success diff --git a/src/Test/Hspec/SmallCheck/Compat.hs b/src/Test/Hspec/SmallCheck/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/SmallCheck/Compat.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.SmallCheck.Compat ( + module Prelude +, module Control.Applicative +, readMaybe +) where + +import Text.Read +import Control.Applicative + +#if !MIN_VERSION_base(4,6,0) +import qualified Text.ParserCombinators.ReadP as P + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +-- A 'Left' value indicates a parse error. +readEither :: Read a => String -> Either String a +readEither s = + case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of + [x] -> Right x + [] -> Left "Prelude.read: no parse" + _ -> Left "Prelude.read: ambiguous parse" + where + read' = + do x <- readPrec + lift P.skipSpaces + return x + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +readMaybe :: Read a => String -> Maybe a +readMaybe s = case readEither s of + Left _ -> Nothing + Right a -> Just a +#endif diff --git a/src/Test/Hspec/SmallCheck/Types.hs b/src/Test/Hspec/SmallCheck/Types.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/SmallCheck/Types.hs @@ -0,0 +1,26 @@ +module Test.Hspec.SmallCheck.Types where + +import Prelude () +import Test.Hspec.SmallCheck.Compat + +import Data.List +import Test.Hspec.Core.Spec (Location(..)) + + +data Result = Failure (Maybe Location) Reason + deriving (Eq, Show, Read) + +data Reason = + Reason String + | ExpectedActual String String String + deriving (Eq, Show, Read) + +parseResult :: String -> (String, Maybe Result) +parseResult xs = case [(x, Just y) | (x, Just y) <- zip (inits xs) (map readMaybe $ tails xs)] of + r : _ -> r + [] -> (xs, Nothing) + +concatPrefix :: String -> String -> Maybe String +concatPrefix a b = case filter (not . null) $ [a, b] of + [] -> Nothing + xs -> Just (intercalate "\n" xs) diff --git a/test/Test/Hspec/SmallCheck/TypesSpec.hs b/test/Test/Hspec/SmallCheck/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/SmallCheck/TypesSpec.hs @@ -0,0 +1,41 @@ +module Test.Hspec.SmallCheck.TypesSpec (spec) where + +import Test.Hspec + +import Test.Hspec.SmallCheck.Types + +spec :: Spec +spec = do + describe "parseResult" $ do + let r = Failure Nothing (ExpectedActual "" "23" "42") + it "parses result" $ do + parseResult (show r) `shouldBe` ("", Just r) + + context "with prefix" $ do + it "includes prefix" $ do + let + prefix = "some prefix" + input = prefix ++ show r + parseResult input `shouldBe` (prefix, Just r) + + context "on parse error" $ do + it "returns input verbatim" $ do + let input = init (show r) + parseResult input `shouldBe` (input, Nothing) + + describe "concatPrefix" $ do + context "when given two empty strings" $ do + it "returns Nothing" $ do + concatPrefix "" "" `shouldBe` Nothing + + context "with first string empty" $ do + it "returns second" $ do + concatPrefix "foo" "" `shouldBe` Just "foo" + + context "with second string empty" $ do + it "returns first" $ do + concatPrefix "" "foo" `shouldBe` Just "foo" + + context "with two strings" $ do + it "concatenates with newline" $ do + concatPrefix "foo" "bar" `shouldBe` Just "foo\nbar" diff --git a/test/Test/Hspec/SmallCheckSpec.hs b/test/Test/Hspec/SmallCheckSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/SmallCheckSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +module Test.Hspec.SmallCheckSpec (main, spec) where + +import Test.Hspec + +import qualified Test.Hspec.Core.Spec as H +import qualified Test.Hspec.Runner as H +import Test.SmallCheck +import Test.QuickCheck (stdArgs) +import Test.HUnit (Assertion, assertFailure, assertEqual) + +import Test.Hspec.SmallCheck + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "evaluateExample" $ do + context "with Property IO" $ do + it "returns Success if property holds" $ do + eval True `shouldReturn` H.Success + + it "returns Failure if property does not hold" $ do + eval False `shouldReturn` H.Failure Nothing (H.Reason "condition is false") + + it "shows what falsified it" $ do + eval (/= (2 :: Int)) `shouldReturn` H.Failure Nothing (H.Reason "there exists 2 such that\n condition is false") + + it "propagates exceptions" $ do + eval (error "foobar" :: Property IO) `shouldThrow` errorCall "foobar" + + context "with HUnit Assertion" $ do + it "includes failure reason" $ do + H.Failure _loc reason <- eval ((\ _ -> assertFailure "some failure") :: Int -> Assertion) + reason `shouldBe` H.Reason "there exists 0 such that\nsome failure" + + context "with assertEqual" $ do + it "includes actual and expected" $ do + H.Failure _loc reason <- eval (assertEqual "foo" (42 :: Int)) + reason `shouldBe` H.ExpectedButGot (Just "there exists 0 such that\nfoo") "42" "0" + where + eval :: Testable IO a => a -> IO H.Result + eval = evaluateExample . property + + evaluateExample :: (Example a, Arg a ~ ()) => a -> IO H.Result + evaluateExample e = H.evaluateExample e defaultParams ($ ()) (const $ return ()) + + defaultParams :: H.Params + defaultParams = H.Params stdArgs (H.configSmallCheckDepth H.defaultConfig)