From 489d95b9603c1f34575a67b2d1f069e80769d59a Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Sat, 10 Aug 2013 13:57:58 +0100
Subject: Use Hspec instead of nanospec
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This is motivated by the fact that Haddock tests are not ran by the
GHC's ‘validate’ script so we're pretty liberal on dependencies in that
area. Full Hspec gives us some nice features such as Quickcheck integration.
---
 test/nanospec/Test/Hspec.hs | 126 --------------------------------------------
 1 file changed, 126 deletions(-)
 delete mode 100644 test/nanospec/Test/Hspec.hs

(limited to 'test/nanospec/Test')

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))
-  ]
-- 
cgit v1.2.3