diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..1d0bd9e --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2011-2015 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 +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 index 0000000..5bde0de --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/hspec-expectations.cabal b/hspec-expectations.cabal new file mode 100644 index 0000000..7f1f378 --- /dev/null +++ b/hspec-expectations.cabal @@ -0,0 +1,58 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: hspec-expectations +version: 0.8.2 +synopsis: Catchy combinators for HUnit +description: Catchy combinators for HUnit: +bug-reports: https://github.com/hspec/hspec-expectations/issues +license: MIT +license-file: LICENSE +copyright: (c) 2011-2015 Simon Hengel +author: Simon Hengel +maintainer: Simon Hengel +build-type: Simple +category: Testing +cabal-version: >= 1.10 +homepage: https://github.com/hspec/hspec-expectations#readme + +source-repository head + type: git + location: https://github.com/hspec/hspec-expectations + +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base == 4.* + , call-stack + , HUnit + exposed-modules: + Test.Hspec.Expectations + Test.Hspec.Expectations.Contrib + other-modules: + Test.Hspec.Expectations.Matcher + Paths_hspec_expectations + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + src + ghc-options: -Wall + build-depends: + base == 4.* + , call-stack + , nanospec + , HUnit >= 1.5.0.0 + other-modules: + Test.Hspec.Expectations.MatcherSpec + Test.Hspec.ExpectationsSpec + Test.Hspec.Expectations + Test.Hspec.Expectations.Contrib + Test.Hspec.Expectations.Matcher + default-language: Haskell2010 diff --git a/src/Test/Hspec/Expectations.hs b/src/Test/Hspec/Expectations.hs new file mode 100644 index 0000000..81ffdf7 --- /dev/null +++ b/src/Test/Hspec/Expectations.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ImplicitParams #-} +-- | +-- Introductory documentation: +module Test.Hspec.Expectations ( + +-- * Setting expectations + Expectation +, expectationFailure +, shouldBe +, shouldSatisfy +, shouldStartWith +, shouldEndWith +, shouldContain +, shouldMatchList +, shouldReturn + +, shouldNotBe +, shouldNotSatisfy +, shouldNotContain +, shouldNotReturn + +-- * Expecting exceptions +, shouldThrow + +-- ** Selecting exceptions +, Selector + +-- ** Predefined type-based selectors +-- | +-- There are predefined selectors for some standard exceptions. Each selector +-- is just @const True@ with an appropriate type. +, anyException +, anyErrorCall +, anyIOException +, anyArithException + +-- ** Combinators for defining value-based selectors +-- | +-- Some exceptions (most prominently `ErrorCall`) have no `Eq` instance. +-- Selecting a specific value would require pattern matching. +-- +-- For such exceptions, combinators that construct selectors are provided. +-- Each combinator corresponds to a constructor; it takes the same arguments, +-- and has the same name (but starting with a lower-case letter). +, errorCall + +-- * Re-exports +, HasCallStack +) where + +import qualified Test.HUnit +import Test.HUnit ((@?=)) +import Control.Exception +import Data.Typeable +import Data.List + +import Control.Monad (unless) + +import Test.Hspec.Expectations.Matcher + +#if MIN_VERSION_HUnit(1,4,0) +import Data.CallStack (HasCallStack) +#else +#if MIN_VERSION_base(4,8,1) +import qualified GHC.Stack as GHC +type HasCallStack = (?loc :: GHC.CallStack) +#else +import GHC.Exts (Constraint) +type HasCallStack = (() :: Constraint) +#endif +#endif + +type Expectation = Test.HUnit.Assertion + +expectationFailure :: HasCallStack => String -> Expectation +expectationFailure = Test.HUnit.assertFailure + +expectTrue :: HasCallStack => String -> Bool -> Expectation +expectTrue msg b = unless b (expectationFailure msg) + +infix 1 `shouldBe`, `shouldSatisfy`, `shouldStartWith`, `shouldEndWith`, `shouldContain`, `shouldMatchList`, `shouldReturn`, `shouldThrow` +infix 1 `shouldNotBe`, `shouldNotSatisfy`, `shouldNotContain`, `shouldNotReturn` + +-- | +-- @actual \`shouldBe\` expected@ sets the expectation that @actual@ is equal +-- to @expected@. +shouldBe :: (HasCallStack, Show a, Eq a) => a -> a -> Expectation +actual `shouldBe` expected = actual @?= expected + +-- | +-- @v \`shouldSatisfy\` p@ sets the expectation that @p v@ is @True@. +shouldSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation +v `shouldSatisfy` p = expectTrue ("predicate failed on: " ++ show v) (p v) + +compareWith :: (HasCallStack, Show a) => (a -> a -> Bool) -> String -> a -> a -> Expectation +compareWith comparator errorDesc result expected = expectTrue errorMsg (comparator expected result) + where + errorMsg = show result ++ " " ++ errorDesc ++ " " ++ show expected + +-- | +-- @list \`shouldStartWith\` prefix@ sets the expectation that @list@ starts with @prefix@, +shouldStartWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +shouldStartWith = compareWith isPrefixOf "does not start with" + +-- | +-- @list \`shouldEndWith\` suffix@ sets the expectation that @list@ ends with @suffix@, +shouldEndWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +shouldEndWith = compareWith isSuffixOf "does not end with" + +-- | +-- @list \`shouldContain\` sublist@ sets the expectation that @sublist@ is contained, +-- wholly and intact, anywhere in @list@. +shouldContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +shouldContain = compareWith isInfixOf "does not contain" + +-- | +-- @xs \`shouldMatchList\` ys@ sets the expectation that @xs@ has the same +-- elements that @ys@ has, possibly in another order +shouldMatchList :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +xs `shouldMatchList` ys = maybe (return ()) expectationFailure (matchList xs ys) + +-- | +-- @action \`shouldReturn\` expected@ sets the expectation that @action@ +-- returns @expected@. +shouldReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation +action `shouldReturn` expected = action >>= (`shouldBe` expected) + +-- | +-- @actual \`shouldNotBe\` notExpected@ sets the expectation that @actual@ is not +-- equal to @notExpected@ +shouldNotBe :: (HasCallStack, Show a, Eq a) => a -> a -> Expectation +actual `shouldNotBe` notExpected = expectTrue ("not expected: " ++ show actual) (actual /= notExpected) + +-- | +-- @v \`shouldNotSatisfy\` p@ sets the expectation that @p v@ is @False@. +shouldNotSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation +v `shouldNotSatisfy` p = expectTrue ("predicate succeeded on: " ++ show v) ((not . p) v) + +-- | +-- @list \`shouldNotContain\` sublist@ sets the expectation that @sublist@ is not +-- contained anywhere in @list@. +shouldNotContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +list `shouldNotContain` sublist = expectTrue errorMsg ((not . isInfixOf sublist) list) + where + errorMsg = show list ++ " does contain " ++ show sublist + +-- | +-- @action \`shouldNotReturn\` notExpected@ sets the expectation that @action@ +-- does not return @notExpected@. +shouldNotReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation +action `shouldNotReturn` notExpected = action >>= (`shouldNotBe` notExpected) + +-- | +-- A @Selector@ is a predicate; it can simultaneously constrain the type and +-- value of an exception. +type Selector a = (a -> Bool) + +-- | +-- @action \`shouldThrow\` selector@ sets the expectation that @action@ throws +-- an exception. The precise nature of the expected exception is described +-- with a 'Selector'. +shouldThrow :: (HasCallStack, Exception e) => IO a -> Selector e -> Expectation +action `shouldThrow` p = do + r <- try action + case r of + Right _ -> + expectationFailure $ + "did not get expected exception: " ++ exceptionType + Left e -> + (`expectTrue` p e) $ + "predicate failed on expected exception: " ++ exceptionType ++ " (" ++ show e ++ ")" + where + -- a string repsentation of the expected exception's type + exceptionType = (show . typeOf . instanceOf) p + where + instanceOf :: Selector a -> a + instanceOf _ = error "Test.Hspec.Expectations.shouldThrow: broken Typeable instance" + +anyException :: Selector SomeException +anyException = const True + +anyErrorCall :: Selector ErrorCall +anyErrorCall = const True + +errorCall :: String -> Selector ErrorCall +#if MIN_VERSION_base(4,9,0) +errorCall s (ErrorCallWithLocation msg _) = s == msg +#else +errorCall s (ErrorCall msg) = s == msg +#endif + +anyIOException :: Selector IOException +anyIOException = const True + +anyArithException :: Selector ArithException +anyArithException = const True diff --git a/src/Test/Hspec/Expectations/Contrib.hs b/src/Test/Hspec/Expectations/Contrib.hs new file mode 100644 index 0000000..80ffef5 --- /dev/null +++ b/src/Test/Hspec/Expectations/Contrib.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +-- | +-- Experimental combinators, that may become part of the main distribution, if +-- they turn out to be useful for a wider audience. +module Test.Hspec.Expectations.Contrib ( +-- * Predicates +-- | (useful in combination with `shouldSatisfy`) + isLeft +, isRight +) where + + +#if MIN_VERSION_base(4,7,0) +import Data.Either +#else + +isLeft :: Either a b -> Bool +{-# DEPRECATED isLeft "use Data.Either.Compat.isLeft from package base-compat instead" #-} +isLeft (Left _) = True +isLeft (Right _) = False + +isRight :: Either a b -> Bool +{-# DEPRECATED isRight "use Data.Either.Compat.isRight from package base-compat instead" #-} +isRight (Left _) = False +isRight (Right _) = True +#endif diff --git a/src/Test/Hspec/Expectations/Matcher.hs b/src/Test/Hspec/Expectations/Matcher.hs new file mode 100644 index 0000000..e39e030 --- /dev/null +++ b/src/Test/Hspec/Expectations/Matcher.hs @@ -0,0 +1,26 @@ +module Test.Hspec.Expectations.Matcher (matchList) where + +import Prelude hiding (showList) +import Data.List + +matchList :: (Show a, Eq a) => [a] -> [a] -> Maybe String +xs `matchList` ys + | null extra && null missing = Nothing + | otherwise = Just (err "") + where + extra = xs \\ ys + missing = ys \\ xs + + msgAndList msg zs = showString msg . showList zs . showString "\n" + optMsgList msg zs = if null zs then id else msgAndList msg zs + + err :: ShowS + err = + showString "Actual list is not a permutation of expected list!\n" + . msgAndList " expected list contains: " ys + . msgAndList " actual list contains: " xs + . optMsgList " the missing elements are: " missing + . optMsgList " the extra elements are: " extra + +showList :: Show a => [a] -> ShowS +showList xs = showChar '[' . foldr (.) (showChar ']') (intersperse (showString ", ") $ map shows xs) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..b243222 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,14 @@ +module Main where + +import Test.Hspec + +import qualified Test.Hspec.ExpectationsSpec +import qualified Test.Hspec.Expectations.MatcherSpec + +spec :: Spec +spec = do + describe "Test.Hspec.ExpectationsSpec" Test.Hspec.ExpectationsSpec.spec + describe "Test.Hspec.Expectations.MatcherSpec" Test.Hspec.Expectations.MatcherSpec.spec + +main :: IO () +main = hspec spec diff --git a/test/Test/Hspec/Expectations/MatcherSpec.hs b/test/Test/Hspec/Expectations/MatcherSpec.hs new file mode 100644 index 0000000..5b4d49a --- /dev/null +++ b/test/Test/Hspec/Expectations/MatcherSpec.hs @@ -0,0 +1,34 @@ +module Test.Hspec.Expectations.MatcherSpec (main, spec) where + +import Test.Hspec + +import Test.Hspec.Expectations.Matcher + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "matchList" $ do + it "succeeds if arguments are empty lists" $ do + matchList [] ([] :: [Int]) `shouldBe` Nothing + + it "succeeds if arguments are equal up to permutation" $ do + matchList [1, 2, 2, 3] [3, 2, 1, 2 :: Int] `shouldBe` Nothing + + context "when arguments are not equal up to permutation" $ do + it "shows extra elements" $ do + [1, 2, 2, 3] `matchList` [1, 2, 3 :: Int] `shouldBe` (Just . unlines) [ + "Actual list is not a permutation of expected list!" + , " expected list contains: [1, 2, 3]" + , " actual list contains: [1, 2, 2, 3]" + , " the extra elements are: [2]" + ] + + it "shows missing elements" $ do + [1, 2, 3] `matchList` [1, 2, 2, 3 :: Int] `shouldBe` (Just . unlines) [ + "Actual list is not a permutation of expected list!" + , " expected list contains: [1, 2, 2, 3]" + , " actual list contains: [1, 2, 3]" + , " the missing elements are: [2]" + ] diff --git a/test/Test/Hspec/ExpectationsSpec.hs b/test/Test/Hspec/ExpectationsSpec.hs new file mode 100644 index 0000000..b744618 --- /dev/null +++ b/test/Test/Hspec/ExpectationsSpec.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +module Test.Hspec.ExpectationsSpec (spec) where + +import Control.Exception +import Test.HUnit.Lang +import Test.Hspec (Spec, describe, it) + +import Test.Hspec.Expectations hiding (HasCallStack) +import Data.CallStack + +expectationFailed :: HasCallStack => FailureReason -> HUnitFailure -> Bool +expectationFailed msg (HUnitFailure l m) = m == msg && (fmap setColumn l) == (fmap setColumn location) + where + location = case reverse callStack of + [] -> Nothing + (_, loc) : _ -> Just loc + location :: Maybe SrcLoc + + setColumn loc_ = loc_{srcLocStartCol = 0, srcLocEndCol = 0} + +spec :: Spec +spec = do + describe "shouldBe" $ do + it "succeeds if arguments are equal" $ do + "foo" `shouldBe` "foo" + + it "fails if arguments are not equal" $ do + ("foo" `shouldBe` "bar") `shouldThrow` expectationFailed (ExpectedButGot Nothing "\"bar\"" "\"foo\"") + + describe "shouldSatisfy" $ do + it "succeeds if value satisfies predicate" $ do + "" `shouldSatisfy` null + + it "fails if value does not satisfy predicate" $ do + ("foo" `shouldSatisfy` null) `shouldThrow` expectationFailed (Reason "predicate failed on: \"foo\"") + + describe "shouldReturn" $ do + it "succeeds if arguments represent equal values" $ do + return "foo" `shouldReturn` "foo" + + it "fails if arguments do not represent equal values" $ do + (return "foo" `shouldReturn` "bar") `shouldThrow` expectationFailed (ExpectedButGot Nothing "\"bar\"" "\"foo\"") + + describe "shouldStartWith" $ do + it "succeeds if second is prefix of first" $ do + "hello world" `shouldStartWith` "hello" + + it "fails if second is not prefix of first" $ do + ("hello world" `shouldStartWith` "world") `shouldThrow` expectationFailed (Reason "\"hello world\" does not start with \"world\"") + + describe "shouldEndWith" $ do + it "succeeds if second is suffix of first" $ do + "hello world" `shouldEndWith` "world" + + it "fails if second is not suffix of first" $ do + ("hello world" `shouldEndWith` "hello") `shouldThrow` expectationFailed (Reason "\"hello world\" does not end with \"hello\"") + + describe "shouldContain" $ do + it "succeeds if second argument is contained in the first" $ do + "I'm an hello world message" `shouldContain` "an hello" + + it "fails if first argument does not contain the second" $ do + ("foo" `shouldContain` "bar") `shouldThrow` expectationFailed (Reason "\"foo\" does not contain \"bar\"") + + describe "shouldNotBe" $ do + it "succeeds if arguments are not equal" $ do + "foo" `shouldNotBe` "bar" + + it "fails if arguments are equal" $ do + ("foo" `shouldNotBe` "foo") `shouldThrow` expectationFailed (Reason "not expected: \"foo\"") + + describe "shouldNotSatisfy" $ do + it "succeeds if value does not satisfy predicate" $ do + "bar" `shouldNotSatisfy` null + + it "fails if the value does satisfy predicate" $ do + ("" `shouldNotSatisfy` null) `shouldThrow` expectationFailed (Reason "predicate succeeded on: \"\"") + + describe "shouldNotReturn" $ do + it "succeeds if arguments does not represent equal values" $ do + return "foo" `shouldNotReturn` "bar" + + it "fails if arguments do represent equal values" $ do + (return "foo" `shouldNotReturn` "foo") `shouldThrow` expectationFailed (Reason "not expected: \"foo\"") + + describe "shouldNotContain" $ do + it "succeeds if second argument is not contained in the first" $ do + "I'm an hello world message" `shouldNotContain` "test" + + it "fails if first argument does contain the second" $ do + ("foo abc def" `shouldNotContain` "def") `shouldThrow` expectationFailed (Reason "\"foo abc def\" does contain \"def\"") + + describe "shouldThrow" $ do + it "can be used to require a specific exception" $ do + throwIO DivideByZero `shouldThrow` (== DivideByZero) + + it "can be used to require any exception" $ do + error "foobar" `shouldThrow` anyException + + it "can be used to require an exception of a specific type" $ do + error "foobar" `shouldThrow` anyErrorCall + + it "can be used to require a specific exception" $ do + error "foobar" `shouldThrow` errorCall "foobar" + + it "fails, if a required specific exception is not thrown" $ do + (throwIO Overflow `shouldThrow` (== DivideByZero)) `shouldThrow` expectationFailed (Reason "predicate failed on expected exception: ArithException (arithmetic overflow)") + + it "fails, if any exception is required, but no exception is thrown" $ do + (return () `shouldThrow` anyException) `shouldThrow` expectationFailed (Reason "did not get expected exception: SomeException") + + it "fails, if an exception of a specific type is required, but no exception is thrown" $ do + (return () `shouldThrow` anyErrorCall) `shouldThrow` expectationFailed (Reason "did not get expected exception: ErrorCall")