aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/A.hs2
-rw-r--r--examples/B.hs2
-rw-r--r--examples/Bug1.hs6
-rw-r--r--examples/Bug10.hs3
-rw-r--r--examples/Bug2.hs4
-rw-r--r--examples/Bug3.hs6
-rw-r--r--examples/Bug4.hs4
-rw-r--r--examples/Bug6.hs23
-rw-r--r--examples/Bug7.hs12
-rw-r--r--examples/Bug8.hs8
-rw-r--r--examples/Bug9.hs6
-rw-r--r--examples/Hash.hs45
-rw-r--r--examples/Hidden.hs4
-rw-r--r--examples/Makefile11
-rw-r--r--examples/NoLayout.hs4
-rw-r--r--examples/Test.hs410
-rw-r--r--examples/Visible.hs3
-rw-r--r--examples/hide-bug/A.hs2
-rw-r--r--examples/hide-bug/B.hs5
-rw-r--r--examples/hide-bug/C.hs6
-rw-r--r--examples/hide-bug/D.hs7
-rw-r--r--haddock.cabal40
-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
27 files changed, 215 insertions, 671 deletions
diff --git a/examples/A.hs b/examples/A.hs
deleted file mode 100644
index 4a344a24..00000000
--- a/examples/A.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-module A where
-data A = A
diff --git a/examples/B.hs b/examples/B.hs
deleted file mode 100644
index 3a31507e..00000000
--- a/examples/B.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-module B ( module A ) where
-import A
diff --git a/examples/Bug1.hs b/examples/Bug1.hs
deleted file mode 100644
index af1ed4d3..00000000
--- a/examples/Bug1.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Bug1 where
-
--- | We should have different anchors for constructors and types\/classes. This
--- hyperlink should point to the type constructor by default: 'T'.
-data T = T
-
diff --git a/examples/Bug10.hs b/examples/Bug10.hs
deleted file mode 100644
index 04c5ff50..00000000
--- a/examples/Bug10.hs
+++ /dev/null
@@ -1,3 +0,0 @@
--- | Module: M
-f :: a -> a
-
diff --git a/examples/Bug2.hs b/examples/Bug2.hs
deleted file mode 100644
index 9121922e..00000000
--- a/examples/Bug2.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Bug2 ( x ) where
-import B
-x :: A
-x = A
diff --git a/examples/Bug3.hs b/examples/Bug3.hs
deleted file mode 100644
index cfda7e4c..00000000
--- a/examples/Bug3.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Bug3 where
-
--- | /multi-line
--- emphasis/
-foo :: Int
-
diff --git a/examples/Bug4.hs b/examples/Bug4.hs
deleted file mode 100644
index bb3c4fe2..00000000
--- a/examples/Bug4.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Bug4 where
--- | don't use apostrophe's in the wrong place's
-foo :: Int
-
diff --git a/examples/Bug6.hs b/examples/Bug6.hs
deleted file mode 100644
index 498983df..00000000
--- a/examples/Bug6.hs
+++ /dev/null
@@ -1,23 +0,0 @@
--- | Exporting records.
-module Bug6( A(A), B(B), b, C(C,c1,c2), D(D,d1), E(E) ) where
-
--- |
--- This record is exported without its field
-data A = A { a :: Int }
-
--- |
--- .. with its field, but the field is named separately in the export list
--- (should still be visible as a field name)
-data B = B { b :: Int }
-
--- |
--- .. with fields names as subordinate names in the export
-data C = C { c1 :: Int, c2 :: Int }
-
--- |
--- .. with only some of the fields exported (we can't handle this one -
--- how do we render the declaration?)
-data D = D { d1 :: Int, d2 :: Int }
-
--- | a newtype with a field
-newtype E = E { e :: Int }
diff --git a/examples/Bug7.hs b/examples/Bug7.hs
deleted file mode 100644
index 8cf57914..00000000
--- a/examples/Bug7.hs
+++ /dev/null
@@ -1,12 +0,0 @@
--- | This module caused a duplicate instance in the documentation for the Foo
--- type.
-module Bug7 where
-
--- | The Foo datatype
-data Foo = Foo
-
--- | The Bar class
-class Bar x y
-
--- | Just one instance
-instance Bar Foo Foo
diff --git a/examples/Bug8.hs b/examples/Bug8.hs
deleted file mode 100644
index 6481ca3f..00000000
--- a/examples/Bug8.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-infix -->
-infix --->
-
-data Typ = Type (String,[Typ])
- | TFree (String, [String])
-
-x --> y = Type("fun",[s,t])
-(--->) = flip $ foldr (-->)
diff --git a/examples/Bug9.hs b/examples/Bug9.hs
deleted file mode 100644
index 81e341db..00000000
--- a/examples/Bug9.hs
+++ /dev/null
@@ -1,6 +0,0 @@
--- Haddock 0.6 didn't parse this module, because the qualified
--- identifier C.safe was incorrectly lexed as 3 tokens.
-
-module Check where
-import qualified Foo as C
-check = undefined { C.safe = 3 }
diff --git a/examples/Hash.hs b/examples/Hash.hs
deleted file mode 100644
index b399b129..00000000
--- a/examples/Hash.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-{- |
- Implementation of fixed-size hash tables, with a type
- class for constructing hash values for structured types.
--}
-module Hash (
- -- * The @HashTable@ type
- HashTable,
-
- -- ** Operations on @HashTable@s
- new, insert, lookup,
-
- -- * The @Hash@ class
- Hash(..),
- ) where
-
-import Array
-
--- | A hash table with keys of type @key@ and values of type @val@.
--- The type @key@ should be an instance of 'Eq'.
-data HashTable key val = HashTable Int (Array Int [(key,val)])
-
--- | Builds a new hash table with a given size
-new :: (Eq key, Hash key) => Int -> IO (HashTable key val)
-
--- | Inserts a new element into the hash table
-insert :: (Eq key, Hash key) => key -> val -> IO ()
-
--- | Looks up a key in the hash table, returns @'Just' val@ if the key
--- was found, or 'Nothing' otherwise.
-lookup :: Hash key => key -> IO (Maybe val)
-
--- | A class of types which can be hashed.
-class Hash a where
- -- | hashes the value of type @a@ into an 'Int'
- hash :: a -> Int
-
-instance Hash Int where
- hash = id
-
-instance Hash Float where
- hash = trunc
-
-instance (Hash a, Hash b) => Hash (a,b) where
- hash (a,b) = hash a `xor` hash b
-
diff --git a/examples/Hidden.hs b/examples/Hidden.hs
deleted file mode 100644
index d30925b1..00000000
--- a/examples/Hidden.hs
+++ /dev/null
@@ -1,4 +0,0 @@
--- #hide
-module Hidden where
-hidden :: Int -> Int
-hidden a = a
diff --git a/examples/Makefile b/examples/Makefile
deleted file mode 100644
index 034358ec..00000000
--- a/examples/Makefile
+++ /dev/null
@@ -1,11 +0,0 @@
-TOP = ..
-include $(TOP)/mk/boilerplate.mk
-
-all :: index.html
-
-index.html : $(HS_SRCS) $(HADDOCK_INPLACE)
- $(HADDOCK_INPLACE) -h $(HS_SRCS)
-
-CLEAN_FILES += index.html
-
-include $(TOP)/mk/target.mk
diff --git a/examples/NoLayout.hs b/examples/NoLayout.hs
deleted file mode 100644
index 0be97ba1..00000000
--- a/examples/NoLayout.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module NoLayout where {
- -- | the class 'C'
- g :: Int;
- }
diff --git a/examples/Test.hs b/examples/Test.hs
deleted file mode 100644
index 230f32d8..00000000
--- a/examples/Test.hs
+++ /dev/null
@@ -1,410 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Test
--- Copyright : (c) Simon Marlow 2002
--- License : BSD-style
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- This module illustrates & tests most of the features of Haddock.
--- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'.
---
------------------------------------------------------------------------------
-
--- This is plain comment, ignored by Haddock.
-
-module Test (
-
- -- Section headings are introduced with '-- *':
- -- * Type declarations
-
- -- Subsection headings are introduced with '-- **' and so on.
- -- ** Data types
- T(..), T2, T3(..), T4(..), T5(..), T6(..),
- N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..),
-
- -- ** Records
- R(..), R1(..),
-
- -- | test that we can export record selectors on their own:
- p, q, u,
-
- -- * Class declarations
- C(a,b), D(..), E, F(..),
-
- -- | Test that we can export a class method on its own:
- a,
-
- -- * Function types
- f, g,
-
- -- * Auxiliary stuff
-
- -- $aux1
-
- -- $aux2
-
- -- $aux3
-
- -- $aux4
-
- -- $aux5
-
- -- $aux6
-
- -- $aux7
-
- -- $aux8
-
- -- $aux9
-
- -- $aux10
-
- -- $aux11
-
- -- $aux12
-
- -- | This is some inline documentation in the export list
- --
- -- > a code block using bird-tracks
- -- > each line must begin with > (which isn't significant unless it
- -- > is at the beginning of the line).
-
- -- * A hidden module
- module Hidden,
-
- -- * A visible module
- module Visible,
-
- {-| nested-style doc comments -}
-
- -- * Existential \/ Universal types
- Ex(..),
-
- -- * Type signatures with argument docs
- k, l, m, o,
-
- -- * A section
- -- and without an intervening comma:
- -- ** A subsection
-
-{-|
- > a literal line
-
- $ a non /literal/ line $
--}
-
- f'
- ) where
-
-import Hidden
-import Visible
-import Data.Maybe
-
-bla = Nothing
-
--- | This comment applies to the /following/ declaration
--- and it continues until the next non-comment line
-data T a b
- = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor
- | -- | This comment describes the 'B' constructor
- B (T a b, T Int Float) -- ^
-
--- | An abstract data declaration
-data T2 a b = T2 a b
-
--- | A data declaration with no documentation annotations on the constructors
-data T3 a b = A1 a | B1 b
-
--- A data declaration with no documentation annotations at all
-data T4 a b = A2 a | B2 b
-
--- A data declaration documentation on the constructors only
-data T5 a b
- = A3 a -- ^ documents 'A3'
- | B3 b -- ^ documents 'B3'
-
--- | Testing alternative comment styles
-data T6
- -- | This is the doc for 'A4'
- = A4
- | B4
- | -- ^ This is the doc for 'B4'
-
- -- | This is the doc for 'C4'
- C4
-
--- | A newtype
-newtype N1 a = N1 a
-
--- | A newtype with a fieldname
-newtype N2 a b = N2 {n :: a b}
-
--- | A newtype with a fieldname, documentation on the field
-newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field
- }
-
--- | An abstract newtype - we show this one as data rather than newtype because
--- the difference isn\'t visible to the programmer for an abstract type.
-newtype N4 a b = N4 a
-
-newtype N5 a b = N5 {n5 :: a b -- ^ no docs on the datatype or the constructor
- }
-
-newtype N6 a b = N6 {n6 :: a b
- }
- -- ^ docs on the constructor only
-
--- | docs on the newtype and the constructor
-newtype N7 a b = N7 {n7 :: a b
- }
- -- ^ The 'N7' constructor
-
-
-class (D a) => C a where
- -- |this is a description of the 'a' method
- a :: IO a
- b :: [a]
- -- ^ this is a description of the 'b' method
- c :: a -- c is hidden in the export list
-
--- ^ This comment applies to the /previous/ declaration (the 'C' class)
-
-class D a where
- d :: T a b
- e :: (a,a)
--- ^ This is a class declaration with no separate docs for the methods
-
-instance D Int where
- d = undefined
- e = undefined
-
--- instance with a qualified class name
-instance Test.D Float where
- d = undefined
- e = undefined
-
-class E a where
- ee :: a
--- ^ This is a class declaration with no methods (or no methods exported)
-
--- This is a class declaration with no documentation at all
-class F a where
- ff :: a
-
--- | This is the documentation for the 'R' record, which has four fields,
--- 'p', 'q', 'r', and 's'.
-data R =
- -- | This is the 'C1' record constructor, with the following fields:
- C1 { p :: Int -- ^ This comment applies to the 'p' field
- , q :: forall a . a->a -- ^ This comment applies to the 'q' field
- , -- | This comment applies to both 'r' and 's'
- r,s :: Int
- }
- | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (),
- u,v :: Int
- }
- -- ^ This is the 'C2' record constructor, also with some fields:
-
--- | Testing different record commenting styles
-data R1
- -- | This is the 'C3' record constructor
- = C3 {
- -- | The 's1' record selector
- s1 :: Int
- -- | The 's2' record selector
- , s2 :: Int
- , s3 :: Int -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here.
- -- Since GHC doesn't allow that, I have removed it in this file.
- -- ^ The 's3' record selector
- }
-
--- These section headers are only used when there is no export list to
--- give the structure of the documentation:
-
--- * This is a section header (level 1)
--- ** This is a section header (level 2)
--- *** This is a section header (level 3)
-
-{-|
-In a comment string we can refer to identifiers in scope with
-single quotes like this: 'T', and we can refer to modules by
-using double quotes: "Foo". We can add emphasis /like this/.
-
- * This is a bulleted list
-
- - This is the next item (different kind of bullet)
-
- (1) This is an ordered list
-
- 2. This is the next item (different kind of bullet)
-
-@
- This is a block of code, which can include other markup: 'R'
- formatting
- is
- significant
-@
-
-> this is another block of code
-
-We can also include URLs in documentation: <http://www.haskell.org/>.
--}
-
-f :: C a => a -> Int
-
--- | we can export foreign declarations too
-foreign import ccall g :: Int -> IO CInt
-
--- | this doc string has a parse error in it: \'
-h :: Int
-h = 42
-
-
--- $aux1 This is some documentation that is attached to a name ($aux1)
--- rather than a source declaration. The documentation may be
--- referred to in the export list using its name.
---
--- @ code block in named doc @
-
--- $aux2 This is some documentation that is attached to a name ($aux2)
-
--- $aux3
--- @ code block on its own in named doc @
-
--- $aux4
---
--- @ code block on its own in named doc (after newline) @
-
-{- $aux5 a nested, named doc comment
-
- with a paragraph,
-
- @ and a code block @
--}
-
--- some tests for various arrangements of code blocks:
-
-{- $aux6
->test
->test1
-
-@ test2
- test3
-@
--}
-
-{- $aux7
-@
-test1
-test2
-@
--}
-
-{- $aux8
->test3
->test4
--}
-
-{- $aux9
-@
-test1
-test2
-@
-
->test3
->test4
--}
-
-{- $aux10
->test3
->test4
-
-@
-test1
-test2
-@
--}
-
--- This one is currently wrong (Haddock 0.4). The @...@ part is
--- interpreted as part of the bird-tracked code block.
-{- $aux11
-aux11:
-
->test3
->test4
-
-@
-test1
-test2
-@
--}
-
--- $aux12
--- > foo
---
--- > bar
---
-
--- | A data-type using existential\/universal types
-data Ex a
- = forall b . C b => Ex1 b
- | forall b . Ex2 b
- | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file
- | Ex4 (forall a . a -> a)
-
--- | This is a function with documentation for each argument
-k :: T () () -- ^ This argument has type 'T'
- -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int'
- -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@
- -> T5 () () -- ^ This argument has a very long description that should
- -- hopefully cause some wrapping to happen when it is finally
- -- rendered by Haddock in the generated HTML page.
- -> IO () -- ^ This is the result type
-
--- This function has arg docs but no docs for the function itself
-l :: (Int, Int, Float) -- ^ takes a triple
- -> Int -- ^ returns an 'Int'
-
--- | This function has some arg docs
-m :: R
- -> N1 () -- ^ one of the arguments
- -> IO Int -- ^ and the return value
-
--- | This function has some arg docs but not a return value doc
-
--- can't use the original name ('n') with GHC
-newn :: R -- ^ one of the arguments, an 'R'
- -> N1 () -- ^ one of the arguments
- -> IO Int
-newn = undefined
-
-
--- | A foreign import with argument docs
-foreign import ccall unsafe
- o :: Float -- ^ The input float
- -> IO Float -- ^ The output float
-
--- | We should be able to escape this: \#\#\#
-
--- p :: Int
--- can't use the above original definition with GHC
-newp :: Int
-newp = undefined
-
--- | a function with a prime can be referred to as 'f''
--- but f' doesn't get link'd 'f\''
-f' :: Int
-
-
--- Add some definitions here so that this file can be compiled with GHC
-
-data T1
-f = undefined
-f' = undefined
-type CInt = Int
-k = undefined
-l = undefined
-m = undefined
diff --git a/examples/Visible.hs b/examples/Visible.hs
deleted file mode 100644
index cad71931..00000000
--- a/examples/Visible.hs
+++ /dev/null
@@ -1,3 +0,0 @@
-module Visible where
-visible :: Int -> Int
-visible a = a
diff --git a/examples/hide-bug/A.hs b/examples/hide-bug/A.hs
deleted file mode 100644
index a9386a40..00000000
--- a/examples/hide-bug/A.hs
+++ /dev/null
@@ -1,2 +0,0 @@
--- #hide
-module A where { data T = MkT; f :: T; f = MkT }
diff --git a/examples/hide-bug/B.hs b/examples/hide-bug/B.hs
deleted file mode 100644
index eeaa8290..00000000
--- a/examples/hide-bug/B.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module B(Test, vis) where
-
-vis = id
-
-data Test = Test
diff --git a/examples/hide-bug/C.hs b/examples/hide-bug/C.hs
deleted file mode 100644
index d846035b..00000000
--- a/examples/hide-bug/C.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module C(C.bla) where
-
-import D
-
-bla :: Test
-bla = undefined
diff --git a/examples/hide-bug/D.hs b/examples/hide-bug/D.hs
deleted file mode 100644
index e8ce5744..00000000
--- a/examples/hide-bug/D.hs
+++ /dev/null
@@ -1,7 +0,0 @@
--- The link to the type T in the doc for this module should point to
--- B.T, not A.T. Bug fixed in rev 1.59 of Main.hs.
-module D(Test, hej) where
-
-import B
-
-hej = vis
diff --git a/haddock.cabal b/haddock.cabal
index f70d6813..bbd4e755 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -72,10 +72,6 @@ flag in-ghc-tree
default: False
manual: True
-flag test
- default: False
- manual: True
-
executable haddock
default-language: Haskell2010
-- In a GHC tree - in particular, in a source tarball - we don't
@@ -99,10 +95,6 @@ executable haddock
else
build-depends: ghc-paths
- if flag(test)
- cpp-options: -DTEST
- build-depends: QuickCheck >= 2.1 && < 3
-
main-is: Main.hs
hs-source-dirs: src
ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs
@@ -160,10 +152,6 @@ library
else
build-depends: ghc-paths
- if flag(test)
- cpp-options: -DTEST
- build-depends: QuickCheck >= 2.1 && < 3
-
hs-source-dirs: src
ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs
@@ -212,6 +200,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 0192ebfc..4a6c8d90 100644
--- a/tests/unit-tests/parsetests.hs
+++ b/tests/unit-tests/parsetests.hs
@@ -1,83 +1,68 @@
{-# LANGUAGE StandaloneDeriving, FlexibleInstances, UndecidableInstances, IncoherentInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Main (main) where
+module Main (main, spec) 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
+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 . ppr
+ show = showSDoc dynFlags . ppr
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 (defaultDynFlags undefined) 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