From b8dcf173c272ebf85bbf2b427f84522e1474d092 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 11 Apr 2012 07:54:33 +0200 Subject: Add support for hyperlink labels to parser --- tests/unit-tests/parsetests.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'tests/unit-tests') diff --git a/tests/unit-tests/parsetests.hs b/tests/unit-tests/parsetests.hs index 7180a79e..0192ebfc 100644 --- a/tests/unit-tests/parsetests.hs +++ b/tests/unit-tests/parsetests.hs @@ -9,6 +9,7 @@ import Haddock.Lex (tokenise) import Haddock.Parse (parseParas) import Haddock.Types import Outputable +import Data.Monoid instance Outputable a => Show a where show = showSDoc . ppr @@ -53,8 +54,21 @@ tests = [ input = ">>> putFooBar\nfoo\n\nbar" , result = Just $ DocExamples $ [Example "putFooBar" ["foo","","bar"]] } + + -- tests for links + , ParseTest { + input = "" + , result = Just . DocParagraph $ hyperlink "http://example.com/" Nothing `mappend` DocString "\n" + } + + , ParseTest { + input = "" + , result = Just . DocParagraph $ hyperlink "http://example.com/" (Just "some link") `mappend` DocString "\n" + } ] +hyperlink :: String -> Maybe String -> Doc RdrName +hyperlink url = DocHyperlink . Hyperlink url main :: IO () main = do -- cgit v1.2.3 From 1483f369caaacc25e07f9715b15e49c35205b417 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 13:37:02 +0200 Subject: Use LANGUAGE pragmas instead of default-extensions in cabal file --- haddock.cabal | 4 ---- src/.ghci | 2 +- src/Haddock/Interface/AttachInstances.hs | 2 +- src/Haddock/InterfaceFile.hs | 2 +- src/Haddock/Utils.hs | 1 + src/Main.hs | 2 +- tests/unit-tests/.ghci | 2 +- 7 files changed, 6 insertions(+), 9 deletions(-) (limited to 'tests/unit-tests') diff --git a/haddock.cabal b/haddock.cabal index 9d6f1a9b..609df296 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -104,8 +104,6 @@ executable haddock main-is: Main.hs hs-source-dirs: src - default-extensions: CPP, DeriveDataTypeable, - ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs other-modules: @@ -165,8 +163,6 @@ library build-depends: QuickCheck >= 2.1 && < 3 hs-source-dirs: src - default-extensions: CPP, DeriveDataTypeable, - ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs exposed-modules: diff --git a/src/.ghci b/src/.ghci index f00e6d55..3e83f04c 100644 --- a/src/.ghci +++ b/src/.ghci @@ -1 +1 @@ -:set -i../dist/build/autogen -i../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../dist/build/autogen/cabal_macros.h -XCPP -XDeriveDataTypeable -XScopedTypeVariables -XMagicHash +:set -i../dist/build/autogen -i../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../dist/build/autogen/cabal_macros.h diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index c012f2e0..d9f4350f 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP, MagicHash #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index ebe15325..7abb0583 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index ad61e88a..ef1b0469 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils diff --git a/src/Main.hs b/src/Main.hs index 8c15661d..52406821 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Main diff --git a/tests/unit-tests/.ghci b/tests/unit-tests/.ghci index 10563664..dcc5b13d 100644 --- a/tests/unit-tests/.ghci +++ b/tests/unit-tests/.ghci @@ -1 +1 @@ -:set -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 +:set -i../../src -i../../dist/build/autogen -i../../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../../dist/build/autogen/cabal_macros.h -- cgit v1.2.3 From c0d71b685dfdcbafa8ca0b3924aef6629142e6dc Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 22 Sep 2012 14:15:53 +0200 Subject: Adapt parsetests for GHC 7.6.1 --- tests/unit-tests/parsetests.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'tests/unit-tests') diff --git a/tests/unit-tests/parsetests.hs b/tests/unit-tests/parsetests.hs index 0192ebfc..58348a59 100644 --- a/tests/unit-tests/parsetests.hs +++ b/tests/unit-tests/parsetests.hs @@ -11,8 +11,10 @@ import Haddock.Types import Outputable import Data.Monoid +dynFlags = defaultDynFlags (error "dynFlags for Haddock tests: undefined") + instance Outputable a => Show a where - show = showSDoc . ppr + show = showSDoc dynFlags . ppr deriving instance Show a => Show (Doc a) deriving instance Eq a =>Eq (Doc a) @@ -80,4 +82,4 @@ main = do toTestCase (ParseTest s r) = TestCase $ assertEqual s r (parse s) parse :: String -> Maybe (Doc RdrName) - parse s = parseParas $ tokenise (defaultDynFlags undefined) s (0,0) + parse s = parseParas $ tokenise dynFlags s (0,0) -- cgit v1.2.3 From 25badd84cf6e09f4e556c7511a78144d38578d9f Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Mon, 24 Sep 2012 10:07:44 +0200 Subject: Add test-suite section for parsetests to cabal file + get rid of HUnit dependency --- haddock.cabal | 28 +++++++++ tests/nanospec/README | 6 ++ tests/nanospec/Test/Hspec.hs | 126 ++++++++++++++++++++++++++++++++++++++ tests/unit-tests/.ghci | 1 - tests/unit-tests/parsetests.hs | 125 ++++++++++++++++--------------------- tests/unit-tests/runparsetests.sh | 15 ----- 6 files changed, 214 insertions(+), 87 deletions(-) create mode 100644 tests/nanospec/README create mode 100644 tests/nanospec/Test/Hspec.hs delete mode 100644 tests/unit-tests/.ghci delete mode 100755 tests/unit-tests/runparsetests.sh (limited to 'tests/unit-tests') 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 support - , ParseTest { - input = ">>> putFooBar\nfoo\n\nbar" - , result = Just $ DocExamples $ [Example "putFooBar" ["foo","","bar"]] - } - - -- tests for links - , ParseTest { - input = "" - , result = Just . DocParagraph $ hyperlink "http://example.com/" Nothing `mappend` DocString "\n" - } - - , ParseTest { - input = "" - , 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 as an emptly line" $ do + parse ">>> putFooBar\nfoo\n\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 "" `shouldBe` + (Just . DocParagraph $ hyperlink "http://example.com/" Nothing `mappend` DocString "\n") + + it "accepts an optional label" $ do + parse "" `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 -- cgit v1.2.3 From 48a078a6f3158470abbb2746a71d4659c768949e Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 9 Oct 2012 12:04:20 +0200 Subject: Add unit tests for properties --- tests/unit-tests/parsetests.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'tests/unit-tests') diff --git a/tests/unit-tests/parsetests.hs b/tests/unit-tests/parsetests.hs index 4a6c8d90..1f923aa0 100644 --- a/tests/unit-tests/parsetests.hs +++ b/tests/unit-tests/parsetests.hs @@ -63,6 +63,17 @@ spec = do it "accepts an optional label" $ do parse "" `shouldBe` (Just . DocParagraph $ hyperlink "http://example.com/" (Just "some link") `mappend` DocString "\n") + + context "when parsing properties" $ do + it "can parse a single property" $ do + parse "prop> 23 == 23" `shouldBe` (Just $ DocProperty "23 == 23") + + it "can parse a multiple subsequent properties" $ do + let input = unlines [ + "prop> 23 == 23" + , "prop> 42 == 42" + ] + parse input `shouldBe` (Just $ DocProperty "23 == 23" `DocAppend` DocProperty "42 == 42") where hyperlink :: String -> Maybe String -> Doc RdrName hyperlink url = DocHyperlink . Hyperlink url -- cgit v1.2.3 From 6fafde62449fa8a5cb8405d6270caa5e1ddac613 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 01:51:32 +0200 Subject: Organize unite tests hierarchically --- haddock.cabal | 2 +- tests/unit-tests/Haddock/ParseSpec.hs | 79 +++++++++++++++++++++++++++++++++++ tests/unit-tests/Spec.hs | 9 ++++ tests/unit-tests/parsetests.hs | 79 ----------------------------------- 4 files changed, 89 insertions(+), 80 deletions(-) create mode 100644 tests/unit-tests/Haddock/ParseSpec.hs create mode 100644 tests/unit-tests/Spec.hs delete mode 100644 tests/unit-tests/parsetests.hs (limited to 'tests/unit-tests') diff --git a/haddock.cabal b/haddock.cabal index c0d77a10..b77fc5ac 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -179,7 +179,7 @@ test-suite html-tests test-suite spec type: exitcode-stdio-1.0 default-language: Haskell2010 - main-is: parsetests.hs + main-is: Spec.hs hs-source-dirs: tests/unit-tests , tests/nanospec diff --git a/tests/unit-tests/Haddock/ParseSpec.hs b/tests/unit-tests/Haddock/ParseSpec.hs new file mode 100644 index 00000000..0c959982 --- /dev/null +++ b/tests/unit-tests/Haddock/ParseSpec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE StandaloneDeriving, FlexibleInstances, UndecidableInstances, IncoherentInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Haddock.ParseSpec (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 + show = showSDoc dynFlags . ppr + +deriving instance Show a => Show (Doc a) +deriving instance Eq a =>Eq (Doc a) + +parse :: String -> Maybe (Doc RdrName) +parse s = parseParas $ tokenise dynFlags s (0,0) + +main :: IO () +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"]])) + + -- parse error + parse "foobar\n>>> fib 10\n55" `shouldBe` Nothing + + it "parses a result line that only contains as an emptly line" $ do + parse ">>> putFooBar\nfoo\n\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 "" `shouldBe` + (Just . DocParagraph $ hyperlink "http://example.com/" Nothing `mappend` DocString "\n") + + it "accepts an optional label" $ do + parse "" `shouldBe` + (Just . DocParagraph $ hyperlink "http://example.com/" (Just "some link") `mappend` DocString "\n") + + context "when parsing properties" $ do + it "can parse a single property" $ do + parse "prop> 23 == 23" `shouldBe` (Just $ DocProperty "23 == 23") + + it "can parse a multiple subsequent properties" $ do + let input = unlines [ + "prop> 23 == 23" + , "prop> 42 == 42" + ] + parse input `shouldBe` (Just $ DocProperty "23 == 23" `DocAppend` DocProperty "42 == 42") + where + hyperlink :: String -> Maybe String -> Doc RdrName + hyperlink url = DocHyperlink . Hyperlink url diff --git a/tests/unit-tests/Spec.hs b/tests/unit-tests/Spec.hs new file mode 100644 index 00000000..68521c03 --- /dev/null +++ b/tests/unit-tests/Spec.hs @@ -0,0 +1,9 @@ +module Main where + +import Test.Hspec + +import qualified Haddock.ParseSpec + +main :: IO () +main = hspec $ do + describe "Haddock.Parse" Haddock.ParseSpec.spec diff --git a/tests/unit-tests/parsetests.hs b/tests/unit-tests/parsetests.hs deleted file mode 100644 index 1f923aa0..00000000 --- a/tests/unit-tests/parsetests.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE StandaloneDeriving, FlexibleInstances, UndecidableInstances, IncoherentInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -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 - show = showSDoc dynFlags . ppr - -deriving instance Show a => Show (Doc a) -deriving instance Eq a =>Eq (Doc a) - -parse :: String -> Maybe (Doc RdrName) -parse s = parseParas $ tokenise dynFlags s (0,0) - -main :: IO () -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"]])) - - -- parse error - parse "foobar\n>>> fib 10\n55" `shouldBe` Nothing - - it "parses a result line that only contains as an emptly line" $ do - parse ">>> putFooBar\nfoo\n\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 "" `shouldBe` - (Just . DocParagraph $ hyperlink "http://example.com/" Nothing `mappend` DocString "\n") - - it "accepts an optional label" $ do - parse "" `shouldBe` - (Just . DocParagraph $ hyperlink "http://example.com/" (Just "some link") `mappend` DocString "\n") - - context "when parsing properties" $ do - it "can parse a single property" $ do - parse "prop> 23 == 23" `shouldBe` (Just $ DocProperty "23 == 23") - - it "can parse a multiple subsequent properties" $ do - let input = unlines [ - "prop> 23 == 23" - , "prop> 42 == 42" - ] - parse input `shouldBe` (Just $ DocProperty "23 == 23" `DocAppend` DocProperty "42 == 42") - where - hyperlink :: String -> Maybe String -> Doc RdrName - hyperlink url = DocHyperlink . Hyperlink url -- cgit v1.2.3 From b892eed5336993c3196fb411f6e91dbe90e152c7 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 23:20:26 +0200 Subject: unit-tests: Improve readability Add IsString instance for (Doc RdrName) + use <> instead of DocAppend. --- tests/unit-tests/Haddock/ParseSpec.hs | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) (limited to 'tests/unit-tests') diff --git a/tests/unit-tests/Haddock/ParseSpec.hs b/tests/unit-tests/Haddock/ParseSpec.hs index 0c959982..f7b32fb8 100644 --- a/tests/unit-tests/Haddock/ParseSpec.hs +++ b/tests/unit-tests/Haddock/ParseSpec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE StandaloneDeriving, FlexibleInstances, UndecidableInstances, IncoherentInstances #-} +{-# LANGUAGE OverloadedStrings, StandaloneDeriving, FlexibleInstances, UndecidableInstances, IncoherentInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Haddock.ParseSpec (main, spec) where @@ -8,8 +8,9 @@ import DynFlags (DynFlags, defaultDynFlags) import Haddock.Lex (tokenise) import Haddock.Parse (parseParas) import Haddock.Types -import Outputable +import Outputable (Outputable, showSDoc, ppr) import Data.Monoid +import Data.String dynFlags :: DynFlags dynFlags = defaultDynFlags (error "dynFlags for Haddock tests: undefined") @@ -20,6 +21,9 @@ instance Outputable a => Show a where deriving instance Show a => Show (Doc a) deriving instance Eq a =>Eq (Doc a) +instance IsString (Doc RdrName) where + fromString = DocString + parse :: String -> Maybe (Doc RdrName) parse s = parseParas $ tokenise dynFlags s (0,0) @@ -29,27 +33,25 @@ main = hspec spec spec :: Spec spec = do describe "parseParas" $ do - it "parses a paragraph" $ do - parse "foobar" `shouldBe` (Just . DocParagraph . DocString) "foobar\n" + parse "foobar" `shouldBe` Just (DocParagraph "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"]])) + Just (DocParagraph "foobar\n" <> DocExamples [Example "fib 10" ["55"]]) -- parse error parse "foobar\n>>> fib 10\n55" `shouldBe` Nothing it "parses a result line that only contains as an emptly line" $ do parse ">>> putFooBar\nfoo\n\nbar" `shouldBe` - (Just $ DocExamples $ [Example "putFooBar" ["foo","","bar"]]) + 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"))) + Just (DocParagraph "foobar\n" <> DocCodeBlock " some code\n") -- parse error parse "foobar\n> some code" `shouldBe` Nothing @@ -58,22 +60,22 @@ spec = do context "when parsing a URL" $ do it "parses a URL" $ do parse "" `shouldBe` - (Just . DocParagraph $ hyperlink "http://example.com/" Nothing `mappend` DocString "\n") + Just (DocParagraph $ hyperlink "http://example.com/" Nothing <> "\n") it "accepts an optional label" $ do parse "" `shouldBe` - (Just . DocParagraph $ hyperlink "http://example.com/" (Just "some link") `mappend` DocString "\n") + Just (DocParagraph $ hyperlink "http://example.com/" (Just "some link") <> "\n") context "when parsing properties" $ do it "can parse a single property" $ do - parse "prop> 23 == 23" `shouldBe` (Just $ DocProperty "23 == 23") + parse "prop> 23 == 23" `shouldBe` Just (DocProperty "23 == 23") it "can parse a multiple subsequent properties" $ do - let input = unlines [ - "prop> 23 == 23" - , "prop> 42 == 42" - ] - parse input `shouldBe` (Just $ DocProperty "23 == 23" `DocAppend` DocProperty "42 == 42") + parse $ unlines [ + "prop> 23 == 23" + , "prop> 42 == 42" + ] + `shouldBe` Just (DocProperty "23 == 23" <> DocProperty "42 == 42") where hyperlink :: String -> Maybe String -> Doc RdrName hyperlink url = DocHyperlink . Hyperlink url -- cgit v1.2.3 From a9de80ea72421837848cbdca01745e2a5b9920a7 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 23:37:21 +0200 Subject: unit-tests: Minor refactoring Rename parse to parseParas. --- tests/unit-tests/Haddock/ParseSpec.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) (limited to 'tests/unit-tests') diff --git a/tests/unit-tests/Haddock/ParseSpec.hs b/tests/unit-tests/Haddock/ParseSpec.hs index f7b32fb8..adaca3f7 100644 --- a/tests/unit-tests/Haddock/ParseSpec.hs +++ b/tests/unit-tests/Haddock/ParseSpec.hs @@ -6,7 +6,7 @@ import Test.Hspec import RdrName (RdrName) import DynFlags (DynFlags, defaultDynFlags) import Haddock.Lex (tokenise) -import Haddock.Parse (parseParas) +import qualified Haddock.Parse as Parse import Haddock.Types import Outputable (Outputable, showSDoc, ppr) import Data.Monoid @@ -24,8 +24,8 @@ deriving instance Eq a =>Eq (Doc a) instance IsString (Doc RdrName) where fromString = DocString -parse :: String -> Maybe (Doc RdrName) -parse s = parseParas $ tokenise dynFlags s (0,0) +parseParas :: String -> Maybe (Doc RdrName) +parseParas s = Parse.parseParas $ tokenise dynFlags s (0,0) main :: IO () main = hspec spec @@ -34,44 +34,44 @@ spec :: Spec spec = do describe "parseParas" $ do it "parses a paragraph" $ do - parse "foobar" `shouldBe` Just (DocParagraph "foobar\n") + parseParas "foobar" `shouldBe` Just (DocParagraph "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` + parseParas "foobar\n\n>>> fib 10\n55" `shouldBe` Just (DocParagraph "foobar\n" <> DocExamples [Example "fib 10" ["55"]]) -- parse error - parse "foobar\n>>> fib 10\n55" `shouldBe` Nothing + parseParas "foobar\n>>> fib 10\n55" `shouldBe` Nothing it "parses a result line that only contains as an emptly line" $ do - parse ">>> putFooBar\nfoo\n\nbar" `shouldBe` + parseParas ">>> putFooBar\nfoo\n\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` + parseParas "foobar\n\n> some code" `shouldBe` Just (DocParagraph "foobar\n" <> DocCodeBlock " some code\n") -- parse error - parse "foobar\n> some code" `shouldBe` Nothing + parseParas "foobar\n> some code" `shouldBe` Nothing context "when parsing a URL" $ do it "parses a URL" $ do - parse "" `shouldBe` + parseParas "" `shouldBe` Just (DocParagraph $ hyperlink "http://example.com/" Nothing <> "\n") it "accepts an optional label" $ do - parse "" `shouldBe` + parseParas "" `shouldBe` Just (DocParagraph $ hyperlink "http://example.com/" (Just "some link") <> "\n") context "when parsing properties" $ do it "can parse a single property" $ do - parse "prop> 23 == 23" `shouldBe` Just (DocProperty "23 == 23") + parseParas "prop> 23 == 23" `shouldBe` Just (DocProperty "23 == 23") it "can parse a multiple subsequent properties" $ do - parse $ unlines [ + parseParas $ unlines [ "prop> 23 == 23" , "prop> 42 == 42" ] -- cgit v1.2.3 From 6b294a1b19bbda6124b0dc7e7929c58225c35733 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Mon, 15 Oct 2012 00:36:42 +0200 Subject: Fix typo --- tests/unit-tests/Haddock/ParseSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tests/unit-tests') diff --git a/tests/unit-tests/Haddock/ParseSpec.hs b/tests/unit-tests/Haddock/ParseSpec.hs index adaca3f7..d692cb0c 100644 --- a/tests/unit-tests/Haddock/ParseSpec.hs +++ b/tests/unit-tests/Haddock/ParseSpec.hs @@ -70,7 +70,7 @@ spec = do it "can parse a single property" $ do parseParas "prop> 23 == 23" `shouldBe` Just (DocProperty "23 == 23") - it "can parse a multiple subsequent properties" $ do + it "can parse multiple subsequent properties" $ do parseParas $ unlines [ "prop> 23 == 23" , "prop> 42 == 42" -- cgit v1.2.3 From d63c49537da8c2a3ee20e6153e2471087054730d Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Mon, 15 Oct 2012 14:25:39 +0200 Subject: Move unit tests to /test directory --- haddock.cabal | 4 +- test/Haddock/ParseSpec.hs | 81 ++++++++++++++++++++++ test/Spec.hs | 9 +++ test/nanospec/README | 6 ++ test/nanospec/Test/Hspec.hs | 126 ++++++++++++++++++++++++++++++++++ tests/nanospec/README | 6 -- tests/nanospec/Test/Hspec.hs | 126 ---------------------------------- tests/unit-tests/Haddock/ParseSpec.hs | 81 ---------------------- tests/unit-tests/Spec.hs | 9 --- 9 files changed, 224 insertions(+), 224 deletions(-) create mode 100644 test/Haddock/ParseSpec.hs create mode 100644 test/Spec.hs create mode 100644 test/nanospec/README create mode 100644 test/nanospec/Test/Hspec.hs delete mode 100644 tests/nanospec/README delete mode 100644 tests/nanospec/Test/Hspec.hs delete mode 100644 tests/unit-tests/Haddock/ParseSpec.hs delete mode 100644 tests/unit-tests/Spec.hs (limited to 'tests/unit-tests') diff --git a/haddock.cabal b/haddock.cabal index 36c016e9..8f655d83 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -181,8 +181,8 @@ test-suite spec default-language: Haskell2010 main-is: Spec.hs hs-source-dirs: - tests/unit-tests - , tests/nanospec + test + , test/nanospec , src build-depends: diff --git a/test/Haddock/ParseSpec.hs b/test/Haddock/ParseSpec.hs new file mode 100644 index 00000000..d692cb0c --- /dev/null +++ b/test/Haddock/ParseSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings, StandaloneDeriving, FlexibleInstances, UndecidableInstances, IncoherentInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Haddock.ParseSpec (main, spec) where + +import Test.Hspec +import RdrName (RdrName) +import DynFlags (DynFlags, defaultDynFlags) +import Haddock.Lex (tokenise) +import qualified Haddock.Parse as Parse +import Haddock.Types +import Outputable (Outputable, showSDoc, ppr) +import Data.Monoid +import Data.String + +dynFlags :: DynFlags +dynFlags = defaultDynFlags (error "dynFlags for Haddock tests: undefined") + +instance Outputable a => Show a where + show = showSDoc dynFlags . ppr + +deriving instance Show a => Show (Doc a) +deriving instance Eq a =>Eq (Doc a) + +instance IsString (Doc RdrName) where + fromString = DocString + +parseParas :: String -> Maybe (Doc RdrName) +parseParas s = Parse.parseParas $ tokenise dynFlags s (0,0) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "parseParas" $ do + it "parses a paragraph" $ do + parseParas "foobar" `shouldBe` Just (DocParagraph "foobar\n") + + context "when parsing an example" $ do + it "requires an example to be separated from a previous paragrap by an empty line" $ do + parseParas "foobar\n\n>>> fib 10\n55" `shouldBe` + Just (DocParagraph "foobar\n" <> DocExamples [Example "fib 10" ["55"]]) + + -- parse error + parseParas "foobar\n>>> fib 10\n55" `shouldBe` Nothing + + it "parses a result line that only contains as an emptly line" $ do + parseParas ">>> putFooBar\nfoo\n\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 + parseParas "foobar\n\n> some code" `shouldBe` + Just (DocParagraph "foobar\n" <> DocCodeBlock " some code\n") + + -- parse error + parseParas "foobar\n> some code" `shouldBe` Nothing + + + context "when parsing a URL" $ do + it "parses a URL" $ do + parseParas "" `shouldBe` + Just (DocParagraph $ hyperlink "http://example.com/" Nothing <> "\n") + + it "accepts an optional label" $ do + parseParas "" `shouldBe` + Just (DocParagraph $ hyperlink "http://example.com/" (Just "some link") <> "\n") + + context "when parsing properties" $ do + it "can parse a single property" $ do + parseParas "prop> 23 == 23" `shouldBe` Just (DocProperty "23 == 23") + + it "can parse multiple subsequent properties" $ do + parseParas $ unlines [ + "prop> 23 == 23" + , "prop> 42 == 42" + ] + `shouldBe` Just (DocProperty "23 == 23" <> DocProperty "42 == 42") + where + hyperlink :: String -> Maybe String -> Doc RdrName + hyperlink url = DocHyperlink . Hyperlink url diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 00000000..68521c03 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,9 @@ +module Main where + +import Test.Hspec + +import qualified Haddock.ParseSpec + +main :: IO () +main = hspec $ do + describe "Haddock.Parse" Haddock.ParseSpec.spec diff --git a/test/nanospec/README b/test/nanospec/README new file mode 100644 index 00000000..ffce7c74 --- /dev/null +++ b/test/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/test/nanospec/Test/Hspec.hs b/test/nanospec/Test/Hspec.hs new file mode 100644 index 00000000..904ce2e0 --- /dev/null +++ b/test/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/nanospec/README b/tests/nanospec/README deleted file mode 100644 index ffce7c74..00000000 --- a/tests/nanospec/README +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index 904ce2e0..00000000 --- a/tests/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)) - ] diff --git a/tests/unit-tests/Haddock/ParseSpec.hs b/tests/unit-tests/Haddock/ParseSpec.hs deleted file mode 100644 index d692cb0c..00000000 --- a/tests/unit-tests/Haddock/ParseSpec.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE OverloadedStrings, StandaloneDeriving, FlexibleInstances, UndecidableInstances, IncoherentInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Haddock.ParseSpec (main, spec) where - -import Test.Hspec -import RdrName (RdrName) -import DynFlags (DynFlags, defaultDynFlags) -import Haddock.Lex (tokenise) -import qualified Haddock.Parse as Parse -import Haddock.Types -import Outputable (Outputable, showSDoc, ppr) -import Data.Monoid -import Data.String - -dynFlags :: DynFlags -dynFlags = defaultDynFlags (error "dynFlags for Haddock tests: undefined") - -instance Outputable a => Show a where - show = showSDoc dynFlags . ppr - -deriving instance Show a => Show (Doc a) -deriving instance Eq a =>Eq (Doc a) - -instance IsString (Doc RdrName) where - fromString = DocString - -parseParas :: String -> Maybe (Doc RdrName) -parseParas s = Parse.parseParas $ tokenise dynFlags s (0,0) - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "parseParas" $ do - it "parses a paragraph" $ do - parseParas "foobar" `shouldBe` Just (DocParagraph "foobar\n") - - context "when parsing an example" $ do - it "requires an example to be separated from a previous paragrap by an empty line" $ do - parseParas "foobar\n\n>>> fib 10\n55" `shouldBe` - Just (DocParagraph "foobar\n" <> DocExamples [Example "fib 10" ["55"]]) - - -- parse error - parseParas "foobar\n>>> fib 10\n55" `shouldBe` Nothing - - it "parses a result line that only contains as an emptly line" $ do - parseParas ">>> putFooBar\nfoo\n\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 - parseParas "foobar\n\n> some code" `shouldBe` - Just (DocParagraph "foobar\n" <> DocCodeBlock " some code\n") - - -- parse error - parseParas "foobar\n> some code" `shouldBe` Nothing - - - context "when parsing a URL" $ do - it "parses a URL" $ do - parseParas "" `shouldBe` - Just (DocParagraph $ hyperlink "http://example.com/" Nothing <> "\n") - - it "accepts an optional label" $ do - parseParas "" `shouldBe` - Just (DocParagraph $ hyperlink "http://example.com/" (Just "some link") <> "\n") - - context "when parsing properties" $ do - it "can parse a single property" $ do - parseParas "prop> 23 == 23" `shouldBe` Just (DocProperty "23 == 23") - - it "can parse multiple subsequent properties" $ do - parseParas $ unlines [ - "prop> 23 == 23" - , "prop> 42 == 42" - ] - `shouldBe` Just (DocProperty "23 == 23" <> DocProperty "42 == 42") - where - hyperlink :: String -> Maybe String -> Doc RdrName - hyperlink url = DocHyperlink . Hyperlink url diff --git a/tests/unit-tests/Spec.hs b/tests/unit-tests/Spec.hs deleted file mode 100644 index 68521c03..00000000 --- a/tests/unit-tests/Spec.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import Test.Hspec - -import qualified Haddock.ParseSpec - -main :: IO () -main = hspec $ do - describe "Haddock.Parse" Haddock.ParseSpec.spec -- cgit v1.2.3