aboutsummaryrefslogtreecommitdiff
path: root/test/nanospec/Test
diff options
context:
space:
mode:
Diffstat (limited to 'test/nanospec/Test')
-rw-r--r--test/nanospec/Test/Hspec.hs126
1 files changed, 0 insertions, 126 deletions
diff --git a/test/nanospec/Test/Hspec.hs b/test/nanospec/Test/Hspec.hs
deleted file mode 100644
index 904ce2e0..00000000
--- a/test/nanospec/Test/Hspec.hs
+++ /dev/null
@@ -1,126 +0,0 @@
-{-# 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))
- ]