aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Hengel <sol@typeful.net>2012-09-24 10:07:44 +0200
committerSimon Hengel <sol@typeful.net>2012-10-01 11:30:51 +0200
commit25badd84cf6e09f4e556c7511a78144d38578d9f (patch)
treeed4d4d778e249b8991c62e37e837263a3484fd54
parentc0d71b685dfdcbafa8ca0b3924aef6629142e6dc (diff)
Add test-suite section for parsetests to cabal file
+ get rid of HUnit dependency
-rw-r--r--haddock.cabal28
-rw-r--r--tests/nanospec/README6
-rw-r--r--tests/nanospec/Test/Hspec.hs126
-rw-r--r--tests/unit-tests/.ghci1
-rw-r--r--tests/unit-tests/parsetests.hs125
-rwxr-xr-xtests/unit-tests/runparsetests.sh15
6 files changed, 214 insertions, 87 deletions
diff --git a/haddock.cabal b/haddock.cabal
index f70d6813..3486b2f7 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -212,6 +212,34 @@ test-suite html-tests
hs-source-dirs: tests/html-tests
build-depends: base, directory, process, filepath, Cabal
+test-suite spec
+ type: exitcode-stdio-1.0
+ default-language: Haskell2010
+ main-is: parsetests.hs
+ hs-source-dirs:
+ tests/unit-tests
+ , tests/nanospec
+ , src
+
+ build-depends:
+ base
+ , ghc
+ , containers
+ , array
+
+ -- NOTE: As of this writing, Cabal does not properly handle alex/happy for
+ -- test suites. We work around this by adding dist/build to hs-source-dirs,
+ -- so that the the generated lexer/parser from the library is used. I
+ -- addition we depend on 'haddock', so that the library is compiled before
+ -- the test suite.
+ --
+ -- The corresponding cabal ticket is here:
+ -- https://github.com/haskell/cabal/issues/943
+ hs-source-dirs:
+ dist/build
+ build-depends:
+ haddock
+
source-repository head
type: git
location: http://darcs.haskell.org/haddock.git
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))
+ ]
diff --git a/tests/unit-tests/.ghci b/tests/unit-tests/.ghci
deleted file mode 100644
index dcc5b13d..00000000
--- a/tests/unit-tests/.ghci
+++ /dev/null
@@ -1 +0,0 @@
-:set -i../../src -i../../dist/build/autogen -i../../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../../dist/build/autogen/cabal_macros.h
diff --git a/tests/unit-tests/parsetests.hs b/tests/unit-tests/parsetests.hs
index 58348a59..4a6c8d90 100644
--- a/tests/unit-tests/parsetests.hs
+++ b/tests/unit-tests/parsetests.hs
@@ -1,16 +1,17 @@
{-# LANGUAGE StandaloneDeriving, FlexibleInstances, UndecidableInstances, IncoherentInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Main (main) where
-
-import Test.HUnit
-import RdrName (RdrName)
-import DynFlags (defaultDynFlags)
-import Haddock.Lex (tokenise)
-import Haddock.Parse (parseParas)
-import Haddock.Types
-import Outputable
-import Data.Monoid
-
+module Main (main, spec) where
+
+import Test.Hspec
+import RdrName (RdrName)
+import DynFlags (DynFlags, defaultDynFlags)
+import Haddock.Lex (tokenise)
+import Haddock.Parse (parseParas)
+import Haddock.Types
+import Outputable
+import Data.Monoid
+
+dynFlags :: DynFlags
dynFlags = defaultDynFlags (error "dynFlags for Haddock tests: undefined")
instance Outputable a => Show a where
@@ -19,67 +20,49 @@ instance Outputable a => Show a where
deriving instance Show a => Show (Doc a)
deriving instance Eq a =>Eq (Doc a)
-data ParseTest = ParseTest {
- input :: String
- , result :: (Maybe (Doc RdrName))
- }
-
-tests :: [ParseTest]
-tests = [
- ParseTest {
- input = "foobar"
- , result = Just $ DocParagraph $ DocString "foobar\n"
- }
-
- , ParseTest {
- input = "foobar\n\n>>> fib 10\n55"
- , result = Just $ DocAppend (DocParagraph $ DocString "foobar\n") (DocExamples $ [Example "fib 10" ["55"]])
- }
-
- , ParseTest {
- input = "foobar\n>>> fib 10\n55"
- , result = Nothing -- parse error
- }
-
- , ParseTest {
- input = "foobar\n\n> some code"
- , result = Just (DocAppend (DocParagraph (DocString "foobar\n")) (DocCodeBlock (DocString " some code\n")))
- }
-
- , ParseTest {
- input = "foobar\n> some code"
- , result = Nothing -- parse error
- }
-
- -- test <BLANKLINE> support
- , ParseTest {
- input = ">>> putFooBar\nfoo\n<BLANKLINE>\nbar"
- , result = Just $ DocExamples $ [Example "putFooBar" ["foo","","bar"]]
- }
-
- -- tests for links
- , ParseTest {
- input = "<http://example.com/>"
- , result = Just . DocParagraph $ hyperlink "http://example.com/" Nothing `mappend` DocString "\n"
- }
-
- , ParseTest {
- input = "<http://example.com/ some link>"
- , result = Just . DocParagraph $ hyperlink "http://example.com/" (Just "some link") `mappend` DocString "\n"
- }
- ]
-
-hyperlink :: String -> Maybe String -> Doc RdrName
-hyperlink url = DocHyperlink . Hyperlink url
+parse :: String -> Maybe (Doc RdrName)
+parse s = parseParas $ tokenise dynFlags s (0,0)
main :: IO ()
-main = do
- _ <- runTestTT $ TestList $ map toTestCase tests
- return ();
- where
+main = hspec spec
+
+spec :: Spec
+spec = do
+ describe "parseParas" $ do
+
+ it "parses a paragraph" $ do
+ parse "foobar" `shouldBe` (Just . DocParagraph . DocString) "foobar\n"
+
+ context "when parsing an example" $ do
+
+ it "requires an example to be separated from a previous paragrap by an empty line" $ do
+ parse "foobar\n\n>>> fib 10\n55" `shouldBe`
+ (Just $ DocAppend (DocParagraph $ DocString "foobar\n") (DocExamples $ [Example "fib 10" ["55"]]))
- toTestCase :: ParseTest -> Test
- toTestCase (ParseTest s r) = TestCase $ assertEqual s r (parse s)
+ -- parse error
+ parse "foobar\n>>> fib 10\n55" `shouldBe` Nothing
- parse :: String -> Maybe (Doc RdrName)
- parse s = parseParas $ tokenise dynFlags s (0,0)
+ it "parses a result line that only contains <BLANKLINE> as an emptly line" $ do
+ parse ">>> putFooBar\nfoo\n<BLANKLINE>\nbar" `shouldBe`
+ (Just $ DocExamples $ [Example "putFooBar" ["foo","","bar"]])
+
+ context "when parsing a code block" $ do
+ it "requires a code blocks to be separated from a previous paragrap by an empty line" $ do
+ parse "foobar\n\n> some code" `shouldBe`
+ Just (DocAppend (DocParagraph (DocString "foobar\n")) (DocCodeBlock (DocString " some code\n")))
+
+ -- parse error
+ parse "foobar\n> some code" `shouldBe` Nothing
+
+
+ context "when parsing a URL" $ do
+ it "parses a URL" $ do
+ parse "<http://example.com/>" `shouldBe`
+ (Just . DocParagraph $ hyperlink "http://example.com/" Nothing `mappend` DocString "\n")
+
+ it "accepts an optional label" $ do
+ parse "<http://example.com/ some link>" `shouldBe`
+ (Just . DocParagraph $ hyperlink "http://example.com/" (Just "some link") `mappend` DocString "\n")
+ where
+ hyperlink :: String -> Maybe String -> Doc RdrName
+ hyperlink url = DocHyperlink . Hyperlink url
diff --git a/tests/unit-tests/runparsetests.sh b/tests/unit-tests/runparsetests.sh
deleted file mode 100755
index ead0ccf5..00000000
--- a/tests/unit-tests/runparsetests.sh
+++ /dev/null
@@ -1,15 +0,0 @@
-#!/bin/sh
-cd `dirname $0`
-
-runhaskell \
- -i../../src \
- -i../../dist/build/autogen \
- -i../../dist/build/haddock/haddock-tmp/ \
- -packageghc \
- -optP-include \
- -optP../../dist/build/autogen/cabal_macros.h \
- -XCPP \
- -XDeriveDataTypeable \
- -XScopedTypeVariables \
- -XMagicHash \
- parsetests.hs