aboutsummaryrefslogtreecommitdiff
path: root/tests/nanospec
diff options
context:
space:
mode:
authorDavid Waern <david.waern@gmail.com>2012-09-28 23:42:28 +0200
committerDavid Waern <david.waern@gmail.com>2012-09-28 23:42:28 +0200
commiteb44b441af0cf6d1fcc68f10ea4a8758f03f2ad9 (patch)
treee1c04862a2205de88f48f545ffde03424a9e8dfc /tests/nanospec
parent6ccf78e15a525282fef61bc4f58a279aa9c21771 (diff)
parent34953914bf4d577a9609e7e291eca43c45b29aba (diff)
Merge branch 'ghc-7.6' of http://darcs.haskell.org/haddock into ghc-7.6
Diffstat (limited to 'tests/nanospec')
-rw-r--r--tests/nanospec/README6
-rw-r--r--tests/nanospec/Test/Hspec.hs126
2 files changed, 132 insertions, 0 deletions
diff --git a/tests/nanospec/README b/tests/nanospec/README
new file mode 100644
index 00000000..ffce7c74
--- /dev/null
+++ b/tests/nanospec/README
@@ -0,0 +1,6 @@
+A lightweight implementation of a subset of Hspec's API with minimal
+dependencies.
+
+http://hackage.haskell.org/package/nanospec
+
+This is a copy of version 0.1.0.
diff --git a/tests/nanospec/Test/Hspec.hs b/tests/nanospec/Test/Hspec.hs
new file mode 100644
index 00000000..904ce2e0
--- /dev/null
+++ b/tests/nanospec/Test/Hspec.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE DeriveDataTypeable, CPP #-}
+-- | A lightweight implementation of a subset of Hspec's API.
+module Test.Hspec (
+-- * Types
+ SpecM
+, Spec
+
+-- * Defining a spec
+, describe
+, context
+, it
+
+-- ** Setting expectations
+, Expectation
+, expect
+, shouldBe
+, shouldReturn
+
+-- * Running a spec
+, hspec
+) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Monoid
+import Data.List (intercalate)
+import Data.Typeable
+import qualified Control.Exception as E
+import System.Exit
+
+-- a writer monad
+data SpecM a = SpecM a [SpecTree]
+
+add :: SpecTree -> SpecM ()
+add s = SpecM () [s]
+
+instance Monad SpecM where
+ return a = SpecM a []
+ SpecM a xs >>= f = case f a of
+ SpecM b ys -> SpecM b (xs ++ ys)
+
+data SpecTree = SpecGroup String Spec
+ | SpecExample String (IO Result)
+
+data Result = Success | Failure String
+ deriving (Eq, Show)
+
+type Spec = SpecM ()
+
+describe :: String -> Spec -> Spec
+describe label = add . SpecGroup label
+
+context :: String -> Spec -> Spec
+context = describe
+
+it :: String -> Expectation -> Spec
+it label = add . SpecExample label . evaluateExpectation
+
+-- | Summary of a test run.
+data Summary = Summary Int Int
+
+instance Monoid Summary where
+ mempty = Summary 0 0
+ (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)
+
+runSpec :: Spec -> IO Summary
+runSpec = runForrest []
+ where
+ runForrest :: [String] -> Spec -> IO Summary
+ runForrest labels (SpecM () xs) = mconcat <$> mapM (runTree labels) xs
+
+ runTree :: [String] -> SpecTree -> IO Summary
+ runTree labels spec = case spec of
+ SpecExample label x -> do
+ putStr $ "/" ++ (intercalate "/" . reverse) (label:labels) ++ "/ "
+ r <- x
+ case r of
+ Success -> do
+ putStrLn "OK"
+ return (Summary 1 0)
+ Failure err -> do
+ putStrLn "FAILED"
+ putStrLn err
+ return (Summary 1 1)
+ SpecGroup label xs -> do
+ runForrest (label:labels) xs
+
+hspec :: Spec -> IO ()
+hspec spec = do
+ Summary total failures <- runSpec spec
+ putStrLn (show total ++ " example(s), " ++ show failures ++ " failure(s)")
+ when (failures /= 0) exitFailure
+
+type Expectation = IO ()
+
+infix 1 `shouldBe`, `shouldReturn`
+
+shouldBe :: (Show a, Eq a) => a -> a -> Expectation
+actual `shouldBe` expected =
+ expect ("expected: " ++ show expected ++ "\n but got: " ++ show actual) (actual == expected)
+
+shouldReturn :: (Show a, Eq a) => IO a -> a -> Expectation
+action `shouldReturn` expected = action >>= (`shouldBe` expected)
+
+expect :: String -> Bool -> Expectation
+expect label f
+ | f = return ()
+ | otherwise = E.throwIO (ExpectationFailure label)
+
+data ExpectationFailure = ExpectationFailure String
+ deriving (Show, Eq, Typeable)
+
+instance E.Exception ExpectationFailure
+
+evaluateExpectation :: Expectation -> IO Result
+evaluateExpectation action = (action >> return Success)
+ `E.catches` [
+ -- Re-throw AsyncException, otherwise execution will not terminate on SIGINT
+ -- (ctrl-c). All AsyncExceptions are re-thrown (not just UserInterrupt)
+ -- because all of them indicate severe conditions and should not occur during
+ -- normal operation.
+ E.Handler $ \e -> E.throw (e :: E.AsyncException)
+
+ , E.Handler $ \(ExpectationFailure err) -> return (Failure err)
+ , E.Handler $ \e -> (return . Failure) ("*** Exception: " ++ show (e :: E.SomeException))
+ ]