Merge branch 'ghc-7.6' into ghc-7.6-merge-2

Conflicts:
	haddock.cabal
	src/Haddock/Interface/AttachInstances.hs
	src/Haddock/Interface/Create.hs
	src/Haddock/Interface/LexParseRn.hs
	src/Haddock/InterfaceFile.hs
	src/Haddock/Types.hs

Only GHC HEAD can compile this. GHC 7.6.x cannot compile this.

Some test fail.

4 files changed, 222 insertions, 0 deletions

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 <BLANKLINE> as an emptly line" $ do
+        parseParas ">>> 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
+        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 "<http://example.com/>" `shouldBe`
+          Just (DocParagraph $ hyperlink "http://example.com/" Nothing <> "\n")
+
+      it "accepts an optional label" $ do
+        parseParas "<http://example.com/ some link>" `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))
+  ]