Forward port changes from stable.

1 files changed, 28 insertions, 27 deletions

diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index f03801bb..c187f104 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -157,9 +157,7 @@ ppLaTeXModule _title odir iface = do
        ]
 
       description
-          = case ifaceRnDoc iface of
-              Nothing -> empty
-              Just doc -> docToLaTeX doc
+          = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface
 
       body = processExports exports
   --
@@ -209,7 +207,7 @@ processExports (e : es) =
 
 isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
 isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t))))
-                        (Nothing, argDocs) _ _)
+                        (Documentation Nothing Nothing, argDocs) _ _)
   | Map.null argDocs = Just (map unLoc lnames, t)
 isSimpleSig _ = Nothing
 
@@ -275,26 +273,25 @@ ppDecl :: LHsDecl DocName
        -> [(DocName, DocForDecl DocName)]
        -> LaTeX
 
-ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of
-  TyClD d@(TyFamily {})          -> ppTyFam False loc mbDoc d unicode
+ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
+  TyClD d@(TyFamily {})          -> ppTyFam False loc doc d unicode
   TyClD d@(TyDecl{ tcdTyDefn = defn })   
-      | isHsDataDefn defn        -> ppDataDecl instances subdocs loc mbDoc d unicode
-      | otherwise                -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode
---    | Just _  <- tcdTyPats d     -> ppDataInst loc mbDoc d
+      | isHsDataDefn defn        -> ppDataDecl instances subdocs loc doc d unicode
+      | otherwise                -> ppTySyn loc (doc, fnArgsDoc) d unicode
 -- Family instances happen via FamInst now
 --  TyClD d@(TySynonym {})         
---    | Just _  <- tcdTyPats d    -> ppTyInst False loc mbDoc d unicode
+--    | Just _  <- tcdTyPats d    -> ppTyInst False loc doc d unicode
 -- Family instances happen via FamInst now
-  TyClD d@(ClassDecl {})         -> ppClassDecl instances loc mbDoc subdocs d unicode
-  SigD (TypeSig lnames (L _ t))  -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode
-  ForD d                         -> ppFor loc (mbDoc, fnArgsDoc) d unicode
+  TyClD d@(ClassDecl {})         -> ppClassDecl instances loc doc subdocs d unicode
+  SigD (TypeSig lnames (L _ t))  -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
+  ForD d                         -> ppFor loc (doc, fnArgsDoc) d unicode
   InstD _                        -> empty
   _                              -> error "declaration not supported by ppDecl"
   where
     unicode = False
 
 
-ppTyFam :: Bool -> SrcSpan -> Maybe (Doc DocName) ->
+ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->
               TyClDecl DocName -> Bool -> LaTeX
 ppTyFam _ _ _ _ _ =
   error "type family declarations are currently not supported by --latex"
@@ -346,13 +343,13 @@ ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
 ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
                unicode
   | Map.null argDocs =
-      declWithDoc pref1 (fmap docToLaTeX doc)
+      declWithDoc pref1 (documentationToLaTeX doc)
   | otherwise        =
       declWithDoc pref2 $ Just $
         text "\\haddockbeginargs" $$
         do_args 0 sep0 typ $$
         text "\\end{tabulary}\\par" $$
-        maybe empty docToLaTeX doc
+        fromMaybe empty (documentationToLaTeX doc)
   where
      do_largs n leader (L _ t) = do_args n leader t
 
@@ -460,9 +457,9 @@ ppFds fds unicode =
 
 
 ppClassDecl :: [DocInstance DocName] -> SrcSpan
-            -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
+            -> Documentation DocName -> [(DocName, DocForDecl DocName)]
             -> TyClDecl DocName -> Bool -> LaTeX
-ppClassDecl instances loc mbDoc subdocs
+ppClassDecl instances loc doc subdocs
   (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds 
              , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode
   = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
@@ -474,7 +471,7 @@ ppClassDecl instances loc mbDoc subdocs
 
     hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds
 
-    body = catMaybes [fmap docToLaTeX mbDoc, body_]
+    body = catMaybes [documentationToLaTeX doc, body_]
 
     body_
       | null lsigs, null ats, null at_defs = Nothing
@@ -515,8 +512,8 @@ isUndocdInstance _ = Nothing
 -- an 'argBox'. The comment is printed to the right of the box in normal comment
 -- style.
 ppDocInstance :: Bool -> DocInstance DocName -> LaTeX
-ppDocInstance unicode (instHead, mbDoc) =
-  declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX mbDoc)
+ppDocInstance unicode (instHead, doc) =
+  declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc)
 
 
 ppInstDecl :: Bool -> InstHead DocName -> LaTeX
@@ -542,9 +539,9 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
 
 ppDataDecl :: [DocInstance DocName] ->
               [(DocName, DocForDecl DocName)] ->
-              SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool ->
+              SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool ->
               LaTeX
-ppDataDecl instances subdocs _loc mbDoc dataDecl unicode
+ppDataDecl instances subdocs _loc doc dataDecl unicode
 
    =  declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
                   (if null body then Nothing else Just (vcat body))
@@ -554,7 +551,7 @@ ppDataDecl instances subdocs _loc mbDoc dataDecl unicode
     cons      = td_cons (tcdTyDefn dataDecl)
     resTy     = (con_res . unLoc . head) cons
 
-    body = catMaybes [constrBit, fmap docToLaTeX mbDoc]
+    body = catMaybes [constrBit, documentationToLaTeX doc]
 
     (whereBit, leaders)
       | null cons = (empty,[])
@@ -634,8 +631,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
     forall  = con_explicit con
     -- don't use "con_doc con", in case it's reconstructed from a .hi file,
     -- or also because we want Haddock to do the doc-parsing, not GHC.
-    -- 'join' is in Maybe.
-    mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
+    mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
     mkFunTy a b = noLoc (HsFunTy a b)
 
 
@@ -645,7 +641,7 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
     <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
   where
     -- don't use cd_fld_doc for same reason we don't use con_doc above
-    mbDoc = join $ fmap fst $ lookup name subdocs
+    mbDoc = lookup name subdocs >>= combineDocumentation . fst
 
 -- {-
 -- ppHsFullConstr :: HsConDecl -> LaTeX
@@ -997,6 +993,7 @@ parLatexMarkup ppId = Markup {
   markupIdentifier           = markupId ppId,
   markupIdentifierUnchecked  = markupId (ppVerbOccName . snd),
   markupModule               = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
+  markupWarning              = \p v -> emph (p v),
   markupEmphasis             = \p v -> emph (p v),
   markupMonospaced           = \p _ -> tt (p Mono),
   markupUnorderedList        = \p v -> itemizedList (map ($v) p) $$ text "",
@@ -1033,6 +1030,10 @@ docToLaTeX :: Doc DocName -> LaTeX
 docToLaTeX doc = markup latexMarkup doc Plain
 
 
+documentationToLaTeX :: Documentation DocName -> Maybe LaTeX
+documentationToLaTeX = fmap docToLaTeX . combineDocumentation
+
+
 rdrDocToLaTeX :: Doc RdrName -> LaTeX
 rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain