diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/nanospec/README | 6 | ||||
| -rw-r--r-- | tests/nanospec/Test/Hspec.hs | 126 | ||||
| -rw-r--r-- | tests/unit-tests/.ghci | 1 | ||||
| -rw-r--r-- | tests/unit-tests/parsetests.hs | 125 | ||||
| -rwxr-xr-x | tests/unit-tests/runparsetests.sh | 15 |
5 files changed, 186 insertions, 87 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)) + ] 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 |