Merge branch 'ghc-8.6' into ghc-head

9 files changed, 69 insertions, 47 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index d6a6a12d..73a200f0 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -118,10 +118,14 @@ commaSeparate dflags = showSDocUnqual dflags . interpp'SP
 
 ppExport :: DynFlags -> ExportItem GhcRn -> [String]
 ppExport dflags ExportDecl { expItemDecl    = L _ decl
-                           , expItemMbDoc   = (dc, _)
+                           , expItemPats    = bundledPats
+                           , expItemMbDoc   = mbDoc
                            , expItemSubDocs = subdocs
                            , expItemFixities = fixities
-                           } = ppDocumentation dflags dc ++ f decl ++ ppFixities
+                           } = concat [ ppDocumentation dflags dc ++ f d
+                                      | (d, (dc, _)) <- (decl, mbDoc) : bundledPats
+                                      ] ++
+                               ppFixities
     where
         f (TyClD _ d@DataDecl{})  = ppData dflags d subdocs
         f (TyClD _ d@SynDecl{})   = ppSynonym dflags d
@@ -136,12 +140,13 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
 ppExport _ _ = []
 
 ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
-ppSigWithDoc dflags (TypeSig _ names sig) subdocs
-    = concatMap mkDocSig names
-    where
-        mkDocSig n = mkSubdoc dflags n subdocs [pp_sig dflags [n] (hsSigWcType sig)]
-
-ppSigWithDoc _ _ _ = []
+ppSigWithDoc dflags sig subdocs = case sig of
+    TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names
+    PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names
+    _ -> []
+  where
+    mkDocSig leader typ n = mkSubdoc dflags n subdocs
+                                     [leader ++ pp_sig dflags [n] typ]
 
 ppSig :: DynFlags -> Sig GhcRn -> [String]
 ppSig dflags x  = ppSigWithDoc dflags x []
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d5b2f325..69b43eca 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -243,8 +243,8 @@ ppDocGroup lev doc = sec lev <> braces doc
 
 -- | Given a declaration, extract out the names being declared
 declNames :: LHsDecl DocNameI
-          -> ( LaTeX           -- ^ to print before each name in an export list
-             , [DocName]       -- ^ names being declared
+          -> ( LaTeX           --   to print before each name in an export list
+             , [DocName]       --   names being declared
              )
 declNames (L _ decl) = case decl of
   TyClD _ d  -> (empty, [tcdName d])
@@ -444,9 +444,9 @@ ppLPatSig doc docnames ty unicode
 -- arguments as needed.
 ppTypeOrFunSig :: HsType DocNameI
                -> DocForDecl DocName  -- ^ documentation
-               -> ( LaTeX             -- ^ first-line (no-argument docs only)
-                  , LaTeX             -- ^ first-line (argument docs only)
-                  , LaTeX             -- ^ type prefix (argument docs only)
+               -> ( LaTeX             --   first-line (no-argument docs only)
+                  , LaTeX             --   first-line (argument docs only)
+                  , LaTeX             --   type prefix (argument docs only)
                   )
                -> Bool                -- ^ unicode
                -> LaTeX
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index f5fc4c3e..db29c7cf 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -33,6 +33,7 @@ import Haddock.Version
 import Haddock.Utils
 import Haddock.Utils.Json
 import Text.XHtml hiding ( name, title, p, quote )
+import qualified Text.XHtml as XHtml
 import Haddock.GhcUtils
 
 import Control.Monad         ( when, unless )
@@ -120,17 +121,26 @@ copyHtmlBits odir libdir themes withQuickjump = do
 
 headHtml :: String -> Themes -> Maybe String -> Html
 headHtml docTitle themes mathjax_url =
-  header << [
-    meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
-    thetitle << docTitle,
-    styleSheet themes,
-    thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml,
-    script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml,
-    script ! [src mjUrl, thetype "text/javascript"] << noHtml
+  header <<
+    [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"]
+    , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"]
+    , thetitle << docTitle
+    , styleSheet themes
+    , thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml
+    , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml
+    , script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml
+    , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf
+    , script ! [src mjUrl, thetype "text/javascript"] << noHtml
     ]
   where
-    mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url
-
+    fontUrl = "https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700"
+    mjUrl = fromMaybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" mathjax_url
+    mjConf = unwords [ "MathJax.Hub.Config({"
+                     ,   "tex2jax: {"
+                     ,     "processClass: \"mathjax\","
+                     ,     "ignoreClass: \".*\""
+                     ,   "}"
+                     , "});" ]
 
 srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
 srcButton (Just src_base_url, _, _, _) Nothing =
@@ -177,13 +187,13 @@ bodyHtml doctitle iface
            pageContent =
   body << [
     divPackageHeader << [
+      nonEmptySectionName << doctitle,
       unordList (catMaybes [
         srcButton maybe_source_url iface,
         wikiButton maybe_wiki_url (ifaceMod <$> iface),
         contentsButton maybe_contents_url,
         indexButton maybe_index_url])
-            ! [theclass "links", identifier "page-menu"],
-      nonEmptySectionName << doctitle
+            ! [theclass "links", identifier "page-menu"]
       ],
     divContent << pageContent,
     divFooter << paragraph << (
@@ -321,6 +331,7 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
 
     cBtn = case (ts, leaf) of
       (_:_, Just _) -> thespan ! collapseControl p "" << spaceHtml
+      ([] , Just _) -> thespan ! [theclass "noexpander"] << spaceHtml
       (_,   _   ) -> noHtml
       -- We only need an explicit collapser button when the module name
       -- is also a leaf, and so is a link to a module page. Indeed, the
@@ -629,9 +640,9 @@ ppModuleContents pkg qual exports orphan
   | null sections && not orphan  = noHtml
   | otherwise                    = contentsDiv
  where
-  contentsDiv = divTableOfContents << (
-    sectionName << "Contents" +++
-    unordList (sections ++ orphanSection))
+  contentsDiv = divTableOfContents << (divContentsList << (
+    (sectionName << "Contents") ! [ strAttr "onclick" "window.scrollTo(0,0)" ] +++
+    unordList (sections ++ orphanSection)))
 
   (sections, _leftovers{-should be []-}) = process 0 exports
   orphanSection
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 12e65716..9df6acc0 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -122,12 +122,12 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI
 ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
                splice unicode pkg qual emptyCtxts
   | summary = pref1
-  | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc
+  | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curname pkg qual doc
   | otherwise = topDeclElem links loc splice docnames pref2
                   +++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts)
-                  +++ docSection curName pkg qual doc
+                  +++ docSection curname pkg qual doc
   where
-    curName = getName <$> listToMaybe docnames
+    curname = getName <$> listToMaybe docnames
 
 
 -- This splits up a type signature along `->` and adds docs (when they exist) to
@@ -290,10 +290,11 @@ ppFamDecl :: Bool                     -- ^ is a summary
           -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
 ppFamDecl summary associated links instances fixities loc doc decl splice unicode pkg qual
   | summary   = ppFamHeader True associated decl unicode qual
-  | otherwise = header_ +++ docSection Nothing pkg qual doc +++ instancesBit
+  | otherwise = header_ +++ docSection curname pkg qual doc +++ instancesBit
 
   where
     docname = unLoc $ fdLName decl
+    curname = Just $ getName docname
 
     header_ = topDeclElem links loc splice [docname] $
        ppFamHeader summary associated decl unicode qual <+> ppFixities fixities qual
@@ -528,9 +529,11 @@ ppClassDecl summary links instances fixities loc d subdocs
                         , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
             splice unicode pkg qual
   | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual
-  | otherwise = classheader +++ docSection Nothing pkg qual d
+  | otherwise = classheader +++ docSection curname pkg qual d
                   +++ minimalBit +++ atBit +++ methodBit +++ instancesBit
   where
+    curname = Just $ getName nm
+
     sigs = map unLoc lsigs
 
     classheader
@@ -759,10 +762,11 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
            splice unicode pkg qual
 
   | summary   = ppShortDataDecl summary False dataDecl pats unicode qual
-  | otherwise = header_ +++ docSection Nothing pkg qual doc +++ constrBit +++ patternBit +++ instancesBit
+  | otherwise = header_ +++ docSection curname pkg qual doc +++ constrBit +++ patternBit +++ instancesBit
 
   where
     docname   = tcdName dataDecl
+    curname   = Just $ getName docname
     cons      = dd_cons (tcdDataDefn dataDecl)
     isH98     = case unLoc (head cons) of
                   ConDeclH98 {} -> True
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 42643ed0..09aabc0c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -69,8 +69,8 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
                                   then namedAnchor aname << ""
                                   else noHtml,
   markupPic                  = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
-  markupMathInline           = \mathjax -> toHtml ("\\(" ++ mathjax ++ "\\)"),
-  markupMathDisplay          = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"),
+  markupMathInline           = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\(" ++ mathjax ++ "\\)"),
+  markupMathDisplay          = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\[" ++ mathjax ++ "\\]"),
   markupProperty             = pre . toHtml,
   markupExample              = examplesToHtml,
   markupHeader               = \(Header l t) -> makeHeader l t,
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 1c44ffda..25d8b07a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.Layout (
 
   divPackageHeader, divContent, divModuleHeader, divFooter,
   divTableOfContents, divDescription, divSynopsis, divInterface,
-  divIndex, divAlphabet, divModuleList,
+  divIndex, divAlphabet, divModuleList, divContentsList,
 
   sectionName,
   nonEmptySectionName,
@@ -74,13 +74,13 @@ sectionName = paragraph ! [theclass "caption"]
 -- If it would have otherwise been empty, then give it the class ".empty".
 nonEmptySectionName :: Html -> Html
 nonEmptySectionName c
-  | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml
-  | otherwise  = paragraph ! [theclass "caption"]       $ c
+  | isNoHtml c = thespan ! [theclass "caption empty"] $ spaceHtml
+  | otherwise  = thespan ! [theclass "caption"]       $ c
 
 
 divPackageHeader, divContent, divModuleHeader, divFooter,
   divTableOfContents, divDescription, divSynopsis, divInterface,
-  divIndex, divAlphabet, divModuleList
+  divIndex, divAlphabet, divModuleList, divContentsList
     :: Html -> Html
 
 divPackageHeader    = sectionDiv "package-header"
@@ -88,6 +88,7 @@ divContent          = sectionDiv "content"
 divModuleHeader     = sectionDiv "module-header"
 divFooter           = sectionDiv "footer"
 divTableOfContents  = sectionDiv "table-of-contents"
+divContentsList     = sectionDiv "contents-list"
 divDescription      = sectionDiv "description"
 divSynopsis         = sectionDiv "synopsis"
 divInterface        = sectionDiv "interface"
@@ -195,17 +196,18 @@ subEquations :: Maybe Package -> Qualification -> [SubDecl] -> Html
 subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual
 
 
--- | Generate sub table for instance declarations, with source
+-- | Generate collapsible sub table for instance declarations, with source
 subInstances :: Maybe Package -> Qualification
              -> String -- ^ Class name, used for anchor generation
              -> LinksInfo -> Bool
              -> [(SubDecl, Maybe Module, Located DocName)] -> Html
 subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable
   where
-    wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents))
+    wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents))
     instTable = subTableSrc pkg qual lnks splice
     subSection = thediv ! [theclass "subs instances"]
-    summary = thesummary << "Instances"
+    hdr = h4 ! collapseControl id_ "instances" << "Instances"
+    summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instances details"
     id_ = makeAnchorId $ "i:" ++ nm
 
 
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index c4df2090..a4408434 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -85,7 +85,7 @@ createInterface tm flags modMap instIfaceMap = do
       !instances     = modInfoInstances mi
       !fam_instances = md_fam_insts md
       !exportedNames = modInfoExportsWithSelectors mi
-      (pkgNameFS, _) = modulePackageInfo dflags flags mdl
+      (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl)
       pkgName        = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
 
       (TcGblEnv { tcg_rdr_env = gre
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 4dff77ce..59ad4fdf 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -165,8 +165,7 @@ outOfScope dflags x =
   where
     warnAndMonospace a = do
       tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++
-            "    If you qualify the identifier, haddock can try to link it\n" ++
-            "    it anyway."]
+            "    If you qualify the identifier, haddock can try to link it anyway."]
       pure (monospaced a)
     monospaced a = DocMonospaced (DocString (showPpr dflags a))
 
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 46db572b..e314bbd0 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -374,9 +374,10 @@ modulePackageInfo :: DynFlags
                   -> [Flag] -- ^ Haddock flags are checked as they may contain
                             -- the package name or version provided by the user
                             -- which we prioritise
-                  -> Module
+                  -> Maybe Module
                   -> (Maybe PackageName, Maybe Data.Version.Version)
-modulePackageInfo dflags flags modu =
+modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing)
+modulePackageInfo dflags flags (Just modu) =
   ( optPackageName flags    <|> fmap packageName pkgDb
   , optPackageVersion flags <|> fmap packageVersion pkgDb
   )