From 11385cf01f0d852782444ebfeb4e5092c174c6f8 Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Thu, 12 Jan 2012 21:28:14 +0100
Subject: Make sure that generated xhtml is valid (close #186)

Thanks to Phyx.
---
 src/Haddock/Backends/Xhtml/Layout.hs |  9 +++++++++
 src/Haddock/Backends/Xhtml/Utils.hs  | 11 +----------
 2 files changed, 10 insertions(+), 10 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index bdd5ac78..da17552c 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -18,6 +18,7 @@ module Haddock.Backends.Xhtml.Layout (
   divIndex, divAlphabet, divModuleList,
 
   sectionName,
+  nonEmptySectionName,
 
   shortDeclList,
   shortSubDecls,
@@ -66,6 +67,14 @@ sectionName :: Html -> Html
 sectionName = paragraph ! [theclass "caption"]
 
 
+-- | Make an element that always has at least something (a non-breaking space)
+-- 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
+
+
 divPackageHeader, divContent, divModuleHeader, divFooter,
   divTableOfContents, divDescription, divSynposis, divInterface,
   divIndex, divAlphabet, divModuleList
diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs
index 7ba6d5f4..c020c64d 100644
--- a/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/src/Haddock/Backends/Xhtml/Utils.hs
@@ -17,7 +17,7 @@ module Haddock.Backends.Xhtml.Utils (
   spliceURL,
   groupId,
 
-  (<+>), char, nonEmpty,
+  (<+>), char,
   keyword, punctuate,
 
   braces, brackets, pabrackets, parens, parenList, ubxParenList,
@@ -119,15 +119,6 @@ char :: Char -> Html
 char c = toHtml [c]
 
 
--- | Make an element that always has at least something (a non-breaking space)
--- If it would have otherwise been empty, then give it the class ".empty"
-nonEmpty :: (Html -> Html) -> Html -> Html
-nonEmpty el content_ =
-  if isNoHtml content_
-    then el ! [theclass "empty"] << spaceHtml
-    else el << content_
-
-
 quote :: Html -> Html
 quote h = char '`' +++ h +++ '`'
 
-- 
cgit v1.2.3


From d327e3dfea1dda473c065b0e6a7da2161c9e6668 Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Thu, 12 Jan 2012 11:54:37 +0100
Subject: Add DocWarning to Doc

The Xhtml backend has special markup for that, Hoogle and LaTeX reuse
what we have for DocEmphasis.
---
 html/Classic.theme/xhaddock.css         |  6 +++---
 html/Ocean.std-theme/ocean.css          |  4 ++++
 src/Haddock/Backends/Hoogle.hs          |  1 +
 src/Haddock/Backends/LaTeX.hs           |  1 +
 src/Haddock/Backends/Xhtml/DocMarkup.hs |  1 +
 src/Haddock/Interface/LexParseRn.hs     |  1 +
 src/Haddock/Interface/Rename.hs         |  3 +++
 src/Haddock/InterfaceFile.hs            | 14 ++++++++++----
 src/Haddock/Types.hs                    |  2 ++
 src/Haddock/Utils.hs                    |  2 ++
 10 files changed, 28 insertions(+), 7 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/html/Classic.theme/xhaddock.css b/html/Classic.theme/xhaddock.css
index d6b58d22..40ea0d06 100644
--- a/html/Classic.theme/xhaddock.css
+++ b/html/Classic.theme/xhaddock.css
@@ -488,6 +488,6 @@ td.rdoc p {
 	background: inherit;
 }
 
-
-
-
+.warning {
+  color: red;
+}
diff --git a/html/Ocean.std-theme/ocean.css b/html/Ocean.std-theme/ocean.css
index e0ba8b0c..42238709 100644
--- a/html/Ocean.std-theme/ocean.css
+++ b/html/Ocean.std-theme/ocean.css
@@ -429,6 +429,10 @@ div#style-menu-holder {
   padding-left: 2em;
 }
 
+.warning {
+  color: red;
+}
+
 .arguments {
   margin-top: -0.4em;
 }
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 6e3e306a..cbb5921d 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -235,6 +235,7 @@ markupTag = Markup {
   markupIdentifier           = box (TagInline "a") . str . out,
   markupIdentifierUnchecked  = box (TagInline "a") . str . out . snd,
   markupModule               = box (TagInline "a") . str,
+  markupWarning              = box (TagInline "i"),
   markupEmphasis             = box (TagInline "i"),
   markupMonospaced           = box (TagInline "tt"),
   markupPic                  = const $ str " ",
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index e0a530be..ffe507ab 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -1006,6 +1006,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 "",
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index f506d2b8..ee0a549f 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -39,6 +39,7 @@ parHtmlMarkup qual ppId = Markup {
   markupIdentifierUnchecked  = thecode . ppUncheckedLink qual,
   markupModule               = \m -> let (mdl,ref) = break (=='#') m
                                      in ppModuleRef (mkModuleName mdl) ref,
+  markupWarning              = thediv ! [theclass "warning"],
   markupEmphasis             = emphasize,
   markupMonospaced           = thecode,
   markupUnorderedList        = unordList,
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index f70c5953..ebd2b8fc 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -108,6 +108,7 @@ rename gre = rn
           a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
               -- If an id can refer to multiple things, we give precedence to type
               -- constructors.
+      DocWarning doc -> DocWarning (rn doc)
       DocEmphasis doc -> DocEmphasis (rn doc)
       DocMonospaced doc -> DocMonospaced (rn doc)
       DocUnorderedList docs -> DocUnorderedList (map rn docs)
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 691dafbc..582c2ccd 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -169,6 +169,9 @@ renameDoc d = case d of
     return (DocIdentifier x')
   DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x)
   DocModule str -> return (DocModule str)
+  DocWarning doc -> do
+    doc' <- renameDoc doc
+    return (DocWarning doc')
   DocEmphasis doc -> do
     doc' <- renameDoc doc
     return (DocEmphasis doc')
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index fcf7fe65..e998ffec 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -65,13 +65,13 @@ binaryInterfaceMagic = 0xD0Cface
 -- we version our interface files accordingly.
 binaryInterfaceVersion :: Word16
 #if __GLASGOW_HASKELL__ == 702
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 20
 #elif __GLASGOW_HASKELL__ == 703
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 20
 #elif __GLASGOW_HASKELL__ == 704
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 20
 #elif __GLASGOW_HASKELL__ == 705
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 20
 #else
 #error Unknown GHC version
 #endif
@@ -469,6 +469,9 @@ instance (Binary id) => Binary (Doc id) where
     put_ bh (DocIdentifierUnchecked x) = do
             putByte bh 16
             put_ bh x
+    put_ bh (DocWarning ag) = do
+            putByte bh 17
+            put_ bh ag
     get bh = do
             h <- getByte bh
             case h of
@@ -523,6 +526,9 @@ instance (Binary id) => Binary (Doc id) where
               16 -> do
                     x <- get bh
                     return (DocIdentifierUnchecked x)
+              17 -> do
+                    ag <- get bh
+                    return (DocWarning ag)
               _ -> fail "invalid binary data found"
 
 
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index a3a7db15..fe4039a7 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -283,6 +283,7 @@ data Doc id
   | DocIdentifier id
   | DocIdentifierUnchecked (ModuleName, OccName)
   | DocModule String
+  | DocWarning (Doc id)
   | DocEmphasis (Doc id)
   | DocMonospaced (Doc id)
   | DocUnorderedList [Doc id]
@@ -324,6 +325,7 @@ data DocMarkup id a = Markup
   , markupIdentifier           :: id -> a
   , markupIdentifierUnchecked  :: (ModuleName, OccName) -> a
   , markupModule               :: String -> a
+  , markupWarning              :: a -> a
   , markupEmphasis             :: a -> a
   , markupMonospaced           :: a -> a
   , markupUnorderedList        :: [a] -> a
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index de97ef85..9865fdf1 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -410,6 +410,7 @@ markup m (DocParagraph d)            = markupParagraph m (markup m d)
 markup m (DocIdentifier x)           = markupIdentifier m x
 markup m (DocIdentifierUnchecked x)  = markupIdentifierUnchecked m x
 markup m (DocModule mod0)            = markupModule m mod0
+markup m (DocWarning d)              = markupWarning m (markup m d)
 markup m (DocEmphasis d)             = markupEmphasis m (markup m d)
 markup m (DocMonospaced d)           = markupMonospaced m (markup m d)
 markup m (DocUnorderedList ds)       = markupUnorderedList m (map (markup m) ds)
@@ -436,6 +437,7 @@ idMarkup = Markup {
   markupIdentifier           = DocIdentifier,
   markupIdentifierUnchecked  = DocIdentifierUnchecked,
   markupModule               = DocModule,
+  markupWarning              = DocWarning,
   markupEmphasis             = DocEmphasis,
   markupMonospaced           = DocMonospaced,
   markupUnorderedList        = DocUnorderedList,
-- 
cgit v1.2.3


From a581f8b2392c31696455ff470f7d46a09c57df2a Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Sun, 15 Jan 2012 16:03:16 +0100
Subject: Remove obsolete TODO

---
 src/Haddock/Backends/Xhtml/Decl.hs | 1 -
 1 file changed, 1 deletion(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 686e9a3e..930a81bf 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -37,7 +37,6 @@ import Name
 import BasicTypes            ( ipNameName )
 
 
--- TODO: use DeclInfo DocName or something
 ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
           DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
           Bool -> Qualification -> Html
-- 
cgit v1.2.3


From 80e2f0460ea89fe5eeb4c389d76ea55a464b2e63 Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Sat, 4 Feb 2012 03:07:51 +0100
Subject: Style police.

---
 src/Haddock/Backends/Xhtml/Layout.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index da17552c..3ddbd28b 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -67,8 +67,8 @@ sectionName :: Html -> Html
 sectionName = paragraph ! [theclass "caption"]
 
 
--- | Make an element that always has at least something (a non-breaking space)
--- If it would have otherwise been empty, then give it the class ".empty"
+-- | Make an element that always has at least something (a non-breaking space).
+-- 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
-- 
cgit v1.2.3


From b31252e0699a65a8e7d0168f012b58fde50c4b3d Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Sat, 4 Feb 2012 03:48:55 +0100
Subject: Remove code for older ghc versions.

---
 src/Haddock/Backends/Xhtml/Decl.hs | 4 ----
 1 file changed, 4 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 930a81bf..9d7865f2 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -717,11 +717,7 @@ ppr_mono_ty _         (HsListTy ty)       u q = brackets (ppr_mono_lty pREC_TOP
 ppr_mono_ty _         (HsPArrTy ty)       u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
 ppr_mono_ty _         (HsIParamTy n ty)   u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)
 ppr_mono_ty _         (HsSpliceTy {})     _ _ = error "ppr_mono_ty HsSpliceTy"
-#if __GLASGOW_HASKELL__ == 612
-ppr_mono_ty _         (HsSpliceTyOut {})  _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
-#else
 ppr_mono_ty _         (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
-#endif
 ppr_mono_ty _         (HsRecTy {})        _ _ = error "ppr_mono_ty HsRecTy"
 ppr_mono_ty _         (HsCoreTy {})       _ _ = error "ppr_mono_ty HsCoreTy"
 ppr_mono_ty _         (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
-- 
cgit v1.2.3


From 12d931b4c3fcd6d8e26cc48b9072b4291efa5cdb Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Sat, 4 Feb 2012 21:37:16 +0100
Subject: Mostly hlint-inspired cleanup.

---
 src/Haddock/Backends/Hoogle.hs             |  4 +-
 src/Haddock/Backends/Xhtml.hs              |  6 +--
 src/Haddock/Backends/Xhtml/Decl.hs         | 65 ++++++++++++++----------------
 src/Haddock/Backends/Xhtml/Utils.hs        |  4 +-
 src/Haddock/Interface/Create.hs            | 24 +++++------
 src/Haddock/Interface/ParseModuleHeader.hs |  6 +--
 src/Haddock/Interface/Rename.hs            | 20 +++++----
 src/Haddock/InterfaceFile.hs               | 34 ++++++++--------
 src/Haddock/Types.hs                       |  2 +-
 src/Haddock/Utils.hs                       |  9 ++---
 10 files changed, 86 insertions(+), 88 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index cbb5921d..e7a78fc2 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -101,7 +101,7 @@ out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr
 
 
 operator :: String -> String
-operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = "(" ++ x:xs ++ ")"
+operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"
 operator x = x
 
 
@@ -124,7 +124,7 @@ ppExport _ = []
 ppSig :: Sig Name -> [String]
 ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ]
     where
-        prettyNames = concat . intersperse ", " $ map out names
+        prettyNames = intercalate ", " $ map out names
         typ = case unL sig of
                    HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c
                    x -> x
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index c8998f3e..84468610 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -431,7 +431,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
                           indexLinks nm entries
           many_entities ->
               td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </>
-                  aboves (map doAnnotatedEntity (zip [1..] many_entities))
+                  aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities)
 
     doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
     doAnnotatedEntity (j,(nm,entries))
@@ -539,7 +539,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
     maybe_doc_hdr
       = case exports of
           [] -> noHtml
-          ExportGroup _ _ _ : _ -> noHtml
+          ExportGroup {} : _ -> noHtml
           _ -> h1 << "Documentation"
 
     bdy =
@@ -621,7 +621,7 @@ ppModuleContents qual exports
 -- we need to assign a unique id to each section heading so we can hyperlink
 -- them from the contents:
 numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]
-numberSectionHeadings exports = go 1 exports
+numberSectionHeadings = go 1
   where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]
         go _ [] = []
         go n (ExportGroup lev _ doc : es)
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 9d7865f2..5cdc819c 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -79,7 +79,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
     argDoc n = Map.lookup n argDocs
 
     do_largs n leader (L _ t) = do_args n leader t
-    do_args :: Int -> Html -> (HsType DocName) -> [SubDecl]
+    do_args :: Int -> Html -> HsType DocName -> [SubDecl]
     do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
       = (leader <+>
           hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
@@ -99,7 +99,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
       = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
         : do_largs (n+1) (arrow unicode) r
     do_args n leader t
-      = (leader <+> ppType unicode qual t, argDoc n, []) : []
+      = [(leader <+> ppType unicode qual t, argDoc n, [])]
 
 
 ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
@@ -296,12 +296,12 @@ ppLContextNoArrow = ppContextNoArrow . unLoc
 
 ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html
 ppContextNoArrow []  _       _     = noHtml
-ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual
+ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual
 
 
 ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html
 ppContextNoLocs []  _       _     = noHtml
-ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual 
+ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual
     <+> darrow unicode
 
 
@@ -309,10 +309,10 @@ ppContext :: HsContext DocName -> Bool -> Qualification -> Html
 ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
 
 
-pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html
-pp_hs_context []  _       _     = noHtml
-pp_hs_context [p] unicode qual = ppType unicode qual p
-pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt)
+ppHsContext :: [HsType DocName] -> Bool -> Qualification-> Html
+ppHsContext []  _       _     = noHtml
+ppHsContext [p] unicode qual = ppType unicode qual p
+ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
 
 
 -------------------------------------------------------------------------------
@@ -326,8 +326,8 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
 ppClassHdr summ lctxt n tvs fds unicode qual =
   keyword "class"
   <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
-  <+> ppAppDocNameNames summ n (tyvarNames $ tvs)
-        <+> ppFds fds unicode qual
+  <+> ppAppDocNameNames summ n (tyvarNames tvs)
+  <+> ppFds fds unicode qual
 
 
 ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html
@@ -396,7 +396,7 @@ ppClassDecl summary links instances loc mbDoc subdocs
                            -- there are different subdocs for different names in a single
                            -- type signature?
 
-    instancesBit = ppInstances instances nm unicode qual 
+    instancesBit = ppInstances instances nm unicode qual
 
 ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
@@ -413,11 +413,8 @@ ppInstances instances baseName unicode qual
         <+> ppAppNameTypes n ts unicode qual
 
 
-lookupAnySubdoc :: (Eq name1) =>
-                   name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
-lookupAnySubdoc n subdocs = case lookup n subdocs of
-  Nothing -> noDocForDecl
-  Just docs -> docs
+lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
+lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
 
 
 -------------------------------------------------------------------------------
@@ -430,7 +427,7 @@ ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool
                 -> Qualification -> Html
 ppShortDataDecl summary _links _loc dataDecl unicode qual
 
-  | [] <- cons = dataHeader 
+  | [] <- cons = dataHeader
 
   | [lcon] <- cons, ResTyH98 <- resTy,
     (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode qual
@@ -513,7 +510,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of
     -- (except each field gets its own line in docs, to match
     -- non-GADT records)
     RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>
-                            ppForAll forall ltvs lcontext unicode qual <+> char '{',
+                            ppForAll forall_ ltvs lcontext unicode qual <+> char '{',
                             doRecordFields fields,
                             char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
     InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
@@ -521,29 +518,29 @@ ppShortConstrParts summary con unicode qual = case con_res con of
   where
     doRecordFields fields = shortSubDecls (map (ppShortField summary unicode qual) fields)
     doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
-                             ppForAll forall ltvs lcontext unicode qual,
+                             ppForAll forall_ ltvs lcontext unicode qual,
                              ppLType unicode qual (foldr mkFunTy resTy args) ]
 
-    header_  = ppConstrHdr forall tyVars context
+    header_  = ppConstrHdr forall_ tyVars context
     occ      = nameOccName . getName . unLoc . con_name $ con
     ltvs     = con_qvars con
     tyVars   = tyvarNames ltvs
     lcontext = con_cxt con
     context  = unLoc (con_cxt con)
-    forall   = con_explicit con
+    forall_  = con_explicit con
     mkFunTy a b = noLoc (HsFunTy a b)
 
 
 -- ppConstrHdr is for (non-GADT) existentials constructors' syntax
 ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool
             -> Qualification -> Html
-ppConstrHdr forall tvs ctxt unicode qual
+ppConstrHdr forall_ tvs ctxt unicode qual
  = (if null tvs then noHtml else ppForall)
    +++
    (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual
         <+> darrow unicode +++ toHtml " ")
   where
-    ppForall = case forall of
+    ppForall = case forall_ of
       Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
       Implicit -> noHtml
 
@@ -581,15 +578,15 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
     doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
     doGADTCon args resTy =
       ppBinder False occ <+> dcolon unicode
-        <+> hsep [ppForAll forall ltvs (con_cxt con) unicode qual,
+        <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual,
                   ppLType unicode qual (foldr mkFunTy resTy args) ]
 
-    header_ = ppConstrHdr forall tyVars context
+    header_ = ppConstrHdr forall_ tyVars context
     occ     = nameOccName . getName . unLoc . con_name $ con
     ltvs    = con_qvars con
     tyVars  = tyvarNames (con_qvars con)
     context = unLoc (con_cxt con)
-    forall  = con_explicit 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.
@@ -651,13 +648,13 @@ tupleParens _              = parenList
 
 pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int
 
-pREC_TOP = (0 :: Int)   -- type in ParseIface.y in GHC
-pREC_FUN = (1 :: Int)   -- btype in ParseIface.y in GHC
-                        -- Used for LH arg of (->)
-pREC_OP  = (2 :: Int)   -- Used for arg of any infix operator
-                        -- (we don't keep their fixities around)
-pREC_CON = (3 :: Int)   -- Used for arg of type applicn:
-                        -- always parenthesise unless atomic
+pREC_TOP = 0 :: Int   -- type in ParseIface.y in GHC
+pREC_FUN = 1 :: Int   -- btype in ParseIface.y in GHC
+                      -- Used for LH arg of (->)
+pREC_OP  = 2 :: Int   -- Used for arg of any infix operator
+                      -- (we don't keep their fixities around)
+pREC_CON = 3 :: Int   -- Used for arg of type applicn:
+                      -- always parenthesise unless atomic
 
 maybeParen :: Int           -- Precedence of context
            -> Int           -- Precedence of top-level operator
@@ -699,7 +696,7 @@ ppForAll expl tvs cxt unicode qual
 
 
 ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html
-ppr_mono_lty ctxt_prec ty unicode qual = ppr_mono_ty ctxt_prec (unLoc ty) unicode qual
+ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
 
 
 ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html
diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs
index c020c64d..be1fcb9b 100644
--- a/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/src/Haddock/Backends/Xhtml/Utils.hs
@@ -44,7 +44,7 @@ import Name     ( getOccString, nameOccName, isValOcc )
 
 spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
              Maybe SrcSpan -> String -> String
-spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url
+spliceURL maybe_file maybe_mod maybe_name maybe_loc = run
  where
   file = fromMaybe "" maybe_file
   mdl = case maybe_mod of
@@ -72,7 +72,7 @@ spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url
   run ('%':'N':rest) = name ++ run rest
   run ('%':'K':rest) = kind ++ run rest
   run ('%':'L':rest) = line ++ run rest
-  run ('%':'%':rest) = "%"  ++ run rest
+  run ('%':'%':rest) = '%'   : run rest
 
   run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl  ++ run rest
   run ('%':'{':'F':'I':'L':'E':'}':rest)         = file ++ run rest
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 737547fd..ed51734d 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -350,7 +350,7 @@ warnAboutFilteredDecls mdl decls = do
     tell [
       "Warning: " ++ modStr ++ ": Instances of type and data "
       ++ "families are not yet supported. Instances of the following families "
-      ++ "will be filtered out:\n  " ++ concat (intersperse ", "
+      ++ "will be filtered out:\n  " ++ (intercalate ", "
       $ map (occNameString . nameOccName) typeInstances) ]
 
   let instances = nub [ pretty i | L _ (InstD (InstDecl i _ _ ats)) <- decls
@@ -359,7 +359,7 @@ warnAboutFilteredDecls mdl decls = do
   unless (null instances) $
     tell [
       "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. "
-      ++ "These instances are affected:\n" ++ concat (intersperse ", " instances) ]
+      ++ "These instances are affected:\n" ++ intercalate ", " instances ]
 
 
 --------------------------------------------------------------------------------
@@ -371,7 +371,7 @@ warnAboutFilteredDecls mdl decls = do
 
 -- | Filter out declarations that we don't handle in Haddock
 filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls decls = filter (isHandled . unL . fst) decls
+filterDecls = filter (isHandled . unL . fst)
   where
     isHandled (ForD (ForeignImport {})) = True
     isHandled (TyClD {}) = True
@@ -408,10 +408,10 @@ collectDocs = go Nothing []
   where
     go Nothing _ [] = []
     go (Just prev) docs [] = finished prev docs []
-    go prev docs ((L _ (DocD (DocCommentNext str))):ds)
+    go prev docs (L _ (DocD (DocCommentNext str)) : ds)
       | Nothing <- prev = go Nothing (str:docs) ds
       | Just decl <- prev = finished decl docs (go Nothing [str] ds)
-    go prev docs ((L _ (DocD (DocCommentPrev str))):ds) = go prev (str:docs) ds
+    go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds
     go Nothing docs (d:ds) = go (Just d) docs ds
     go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
 
@@ -489,7 +489,7 @@ mkExportItems
 
               -- We should not show a subordinate by itself if any of its
               -- parents is also exported. See note [1].
-              | not $ t `elem` declNames,
+              | t `notElem` declNames,
                 Just p <- find isExported (parents t $ unL decl) ->
                 do liftErrMsg $ tell [
                      "Warning: " ++ moduleString thisMod ++ ": " ++
@@ -517,7 +517,7 @@ mkExportItems
           mayDecl <- hiDecl t
           case mayDecl of
             Nothing -> return [ ExportNoDecl t [] ]
-            Just decl -> do
+            Just decl ->
               -- We try to get the subs and docs
               -- from the installed .haddock file for that package.
               case M.lookup (nameModule t) instIfaceMap of
@@ -526,7 +526,7 @@ mkExportItems
                       ["Warning: Couldn't find .haddock for export " ++ pretty t]
                    let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
                    return [ mkExportDecl t decl (noDocForDecl, subs_) ]
-                Just iface -> do
+                Just iface ->
                    return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
 
         _ -> return []
@@ -736,9 +736,9 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
   data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
 
 
--- Pruning
+-- | Keep exprt items with docs.
 pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
-pruneExportItems items = filter hasDoc items
+pruneExportItems = filter hasDoc
   where
     hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d
     hasDoc _ = True
@@ -758,12 +758,12 @@ mkVisibleNames exports opts
 
 -- | Find a stand-alone documentation comment by its name.
 findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
-findNamedDoc name decls = search decls
+findNamedDoc name = search
   where
     search [] = do
       tell ["Cannot find documentation for: $" ++ name]
       return Nothing
-    search ((DocD (DocCommentNamed name' doc)):rest)
+    search (DocD (DocCommentNamed name' doc) : rest)
       | name == name' = return (Just doc)
       | otherwise = search rest
     search (_other_decl : rest) = search rest
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
index 35533d0d..411b6661 100644
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -137,14 +137,14 @@ parseKey key toParse0 =
                (spaces1,cs1) = extractLeadingSpaces cs
             in
                (c:spaces1,cs1)
-         | True = ([],s)
+         | otherwise = ([],s)
 
       extractNextLine :: String -> (String,String)
       extractNextLine [] = ([],[])
       extractNextLine (c:cs)
          | c == '\n' =
             ([],cs)
-         | True =
+         | otherwise =
             let
                (line,rest) = extractNextLine cs
             in
@@ -156,5 +156,5 @@ parseKey key toParse0 =
       extractPrefix _ [] = Nothing
       extractPrefix (c1:cs1) (c2:cs2)
          | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
-         | True = Nothing
+         | otherwise = Nothing
 
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 582c2ccd..cffe68b8 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -12,19 +12,20 @@
 module Haddock.Interface.Rename (renameInterface) where
 
 
-import Haddock.Types
 import Haddock.GhcUtils
+import Haddock.Types
 
-import GHC hiding (NoLink)
-import Name
 import Bag (emptyBag)
 import BasicTypes ( IPName(..), ipNameName )
+import GHC hiding (NoLink)
+import Name
 
+import Control.Applicative
+import Control.Monad hiding (mapM)
 import Data.List
 import qualified Data.Map as Map hiding ( Map )
-import Prelude hiding (mapM)
 import Data.Traversable (mapM)
-import Control.Monad hiding (mapM)
+import Prelude hiding (mapM)
 
 
 renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface
@@ -93,6 +94,9 @@ instance Monad (GenRnM n) where
   (>>=) = thenRn
   return = returnRn
 
+instance Functor (GenRnM n) where
+  fmap f x = do a <- x; return (f a)
+
 returnRn :: a -> GenRnM n a
 returnRn a   = RnM (const (a,[]))
 thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
@@ -211,7 +215,7 @@ renameLKind = renameLType
 
 renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
 renameMaybeLKind Nothing = return Nothing
-renameMaybeLKind (Just ki) = renameLKind ki >>= return . Just
+renameMaybeLKind (Just ki) = Just <$> renameLKind ki
 
 renameType :: HsType Name -> RnM (HsType DocName)
 renameType t = case t of
@@ -241,11 +245,11 @@ renameType t = case t of
 
   HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
 
-  HsOpTy a (w, (L loc op)) b -> do
+  HsOpTy a (w, L loc op) b -> do
     op' <- rename op
     a'  <- renameLType a
     b'  <- renameLType b
-    return (HsOpTy a' (w, (L loc op')) b')
+    return (HsOpTy a' (w, L loc op') b')
 
   HsParTy ty -> return . HsParTy =<< renameLType ty
 
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index e998ffec..970093df 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -22,24 +22,25 @@ module Haddock.InterfaceFile (
 import Haddock.Types
 import Haddock.Utils hiding (out)
 
-import Data.List
-import Data.Word
+import Control.Monad
 import Data.Array
 import Data.IORef
+import Data.List
 import qualified Data.Map as Map
 import Data.Map (Map)
+import Data.Word
 
-import GHC hiding (NoLink)
-import Binary
 import BinIface (getSymtabName, getDictFastString)
-import Name
-import UniqSupply
-import UniqFM
-import IfaceEnv
-import HscTypes
-import GhcMonad (withSession)
+import Binary
 import FastMutInt
 import FastString
+import GHC hiding (NoLink)
+import GhcMonad (withSession)
+import HscTypes
+import IfaceEnv
+import Name
+import UniqFM
+import UniqSupply
 import Unique
 
 
@@ -110,8 +111,8 @@ writeInterfaceFile filename iface = do
                       bin_dict_map  = dict_map_ref }
 
   -- put the main thing
-  bh <- return $ setUserData bh0 $ newWriteState (putName bin_symtab)
-                                                 (putFastString bin_dict)
+  let bh = setUserData bh0 $ newWriteState (putName bin_symtab)
+                                           (putFastString bin_dict)
   put_ bh iface
 
   -- write the symtab pointer at the front of the file
@@ -295,12 +296,9 @@ putSymbolTable bh next_off symtab = do
 getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
 getSymbolTable bh namecache = do
   sz <- get bh
-  od_names <- sequence (replicate sz (get bh))
-  let
-        arr = listArray (0,sz-1) names
-        (namecache', names) =
-                mapAccumR (fromOnDiskName arr) namecache od_names
-  --
+  od_names <- replicateM sz (get bh)
+  let arr = listArray (0,sz-1) names
+      (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names
   return (namecache', arr)
 
 
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 927fcffb..22d2f6ae 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -430,7 +430,7 @@ throwE str = throw (HaddockException str)
 -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
 -- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
 -- transformed monad to be MonadIO.
-newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: (Ghc (a, [ErrMsg])) }
+newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }
 --instance MonadIO ErrMsgGhc where
 --  liftIO = WriterGhc . fmap (\a->(a,[])) liftIO
 --er, implementing GhcMonad involves annoying ExceptionMonad and
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 9865fdf1..3a2f1d28 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -70,7 +70,7 @@ import Data.IORef ( IORef, newIORef, readIORef )
 import Data.List ( isSuffixOf )
 import Data.Maybe ( mapMaybe )
 import System.Environment ( getProgName )
-import System.Exit ( exitWith, ExitCode(..) )
+import System.Exit
 import System.IO ( hPutStr, stderr )
 import System.IO.Unsafe ( unsafePerformIO )
 import qualified System.FilePath.Posix as HtmlPath
@@ -156,11 +156,11 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
         field_avail (ConDeclField n _ _) = unLoc n `elem` names
         field_types flds = [ t | ConDeclField _ t _ <- flds ]
 
-    keep _ | otherwise = Nothing
+    keep _ = Nothing
 
 
 restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
-restrictDecls names decls = mapMaybe (filterLSigNames (`elem` names)) decls
+restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
 
 
 restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name]
@@ -286,7 +286,7 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName
 
 
 bye :: String -> IO a
-bye s = putStr s >> exitWith ExitSuccess
+bye s = putStr s >> exitSuccess
 
 
 die :: String -> IO a
@@ -319,7 +319,6 @@ escapeStr = escapeURIString isUnreserved
 -- to avoid depending on the network lib, since doing so gives a
 -- circular build dependency between haddock and network
 -- (at least if you want to build network with haddock docs)
--- NB: These functions do NOT escape Unicode strings for URLs as per the RFCs
 escapeURIChar :: (Char -> Bool) -> Char -> String
 escapeURIChar p c
     | p c       = [c]
-- 
cgit v1.2.3


From bc89bcc2b076c13ad559543ebba43603c8ab990c Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Sun, 1 Apr 2012 02:40:34 +0200
Subject: Fix crash when using --qual. Naughty GHC API!

---
 src/Haddock/Backends/Xhtml/Names.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 7c2375cf..274078a6 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -52,7 +52,10 @@ ppDocName qual docName =
   case docName of
     Documented name mdl ->
       linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl
-    Undocumented name -> ppQualifyName qual name (nameModule name)
+    Undocumented name
+      | isExternalName name || isWiredInName name ->
+          ppQualifyName qual name (nameModule name)
+      | otherwise -> ppName name
 
 
 -- | Render a name depending on the selected qualification mode
-- 
cgit v1.2.3


From a2bcbcffde1e78a6031132bdf4a1a605978352a8 Mon Sep 17 00:00:00 2001
From: Henning Thielemann <git@henning-thielemann.de>
Date: Sun, 1 Apr 2012 13:03:07 +0200
Subject: add QualOption type for distinction between qualification argument
 given by the user and the actual qualification for a concrete module

---
 src/Haddock/Backends/Xhtml.hs       | 14 +++++---------
 src/Haddock/Backends/Xhtml/Names.hs |  8 ++------
 src/Haddock/Options.hs              | 10 +++++-----
 src/Haddock/Types.hs                | 32 +++++++++++++++++++++++++++-----
 src/Main.hs                         |  3 ++-
 5 files changed, 41 insertions(+), 26 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 84468610..686bd36b 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -66,7 +66,7 @@ ppHtml :: String
        -> Maybe String                 -- ^ The contents URL (--use-contents)
        -> Maybe String                 -- ^ The index URL (--use-index)
        -> Bool                         -- ^ Whether to use unicode in output (--use-unicode)
-       -> Qualification                -- ^ How to qualify names
+       -> QualOption                   -- ^ How to qualify names
        -> Bool                         -- ^ Output pretty html (newlines and indenting)
        -> IO ()
 
@@ -83,7 +83,7 @@ ppHtml doctitle maybe_package ifaces odir prologue
         themes maybe_index_url maybe_source_url maybe_wiki_url
         (map toInstalledIface visible_ifaces)
         False -- we don't want to display the packages in a single-package contents
-        prologue debug qual
+        prologue debug (makeContentsQual qual)
 
   when (isNothing maybe_index_url) $
     ppHtmlIndex odir doctitle maybe_package
@@ -461,7 +461,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
 ppHtmlModule
         :: FilePath -> String -> Themes
         -> SourceURLs -> WikiURLs
-        -> Maybe String -> Maybe String -> Bool -> Qualification
+        -> Maybe String -> Maybe String -> Bool -> QualOption
         -> Bool -> Interface -> IO ()
 ppHtmlModule odir doctitle themes
   maybe_source_url maybe_wiki_url
@@ -469,10 +469,7 @@ ppHtmlModule odir doctitle themes
   let
       mdl = ifaceMod iface
       mdl_str = moduleString mdl
-      real_qual = case qual of
-          LocalQual Nothing    -> LocalQual (Just mdl)
-          RelativeQual Nothing -> RelativeQual (Just mdl)
-          _                     -> qual
+      real_qual = makeModuleQual qual mdl
       html =
         headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
         bodyHtml doctitle (Just iface)
@@ -484,8 +481,7 @@ ppHtmlModule odir doctitle themes
 
   createDirectoryIfMissing True odir
   writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
-  ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode qual debug
-
+  ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug
 
 ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
   -> Interface -> Bool -> Qualification -> Bool -> IO ()
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 274078a6..9963fffc 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -64,14 +64,10 @@ ppQualifyName qual name mdl =
   case qual of
     NoQual   -> ppName name
     FullQual -> ppFullQualName mdl name
-    -- this is just in case, it should never happen
-    LocalQual Nothing -> ppQualifyName FullQual name mdl
-    LocalQual (Just localmdl)
+    LocalQual localmdl
       | moduleString mdl == moduleString localmdl -> ppName name
       | otherwise -> ppFullQualName mdl name
-    -- again, this never happens
-    RelativeQual Nothing -> ppQualifyName FullQual name mdl
-    RelativeQual (Just localmdl) ->
+    RelativeQual localmdl ->
       case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
         -- local, A.x -> x
         Just []      -> ppQualifyName NoQual name mdl
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 4e42fd32..3292ba16 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -229,13 +229,13 @@ optLaTeXStyle :: [Flag] -> Maybe String
 optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
 
 
-qualification :: [Flag] -> Qualification
+qualification :: [Flag] -> QualOption
 qualification flags =
   case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
-      "full":_     -> FullQual
-      "local":_    -> LocalQual Nothing
-      "relative":_ -> RelativeQual Nothing
-      _            -> NoQual
+      "full":_     -> OptFullQual
+      "local":_    -> OptLocalQual
+      "relative":_ -> OptRelativeQual
+      _            -> OptNoQual
 
 
 verbosity :: [Flag] -> Verbosity
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 22d2f6ae..de0cc3d9 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -374,12 +374,34 @@ data DocOption
 
 
 -- | Option controlling how to qualify names
+data QualOption
+  = OptNoQual        -- ^ Never qualify any names.
+  | OptFullQual      -- ^ Qualify all names fully.
+  | OptLocalQual     -- ^ Qualify all imported names fully.
+  | OptRelativeQual  -- ^ Like local, but strip module prefix
+                     --   from modules in the same hierarchy.
+
 data Qualification
-  = NoQual                       -- ^ Never qualify any names.
-  | FullQual                     -- ^ Qualify all names fully.
-  | LocalQual (Maybe Module)     -- ^ Qualify all imported names fully.
-  | RelativeQual (Maybe Module)  -- ^ Like local, but strip module prefix.
-                                 --   from modules in the same hierarchy.
+  = NoQual
+  | FullQual
+  | LocalQual Module
+  | RelativeQual Module
+       -- ^ @Maybe Module@ contains the current module.
+       --   This way we can distinguish imported and local identifiers.
+
+makeContentsQual :: QualOption -> Qualification
+makeContentsQual qual =
+  case qual of
+    OptNoQual -> NoQual
+    _         -> FullQual
+
+makeModuleQual :: QualOption -> Module -> Qualification
+makeModuleQual qual mdl =
+  case qual of
+    OptLocalQual    -> LocalQual mdl
+    OptRelativeQual -> RelativeQual mdl
+    OptFullQual     -> FullQual
+    OptNoQual       -> NoQual
 
 
 -----------------------------------------------------------------------------
diff --git a/src/Main.hs b/src/Main.hs
index 0a3c9ffc..e423cf03 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -228,7 +228,8 @@ render flags ifaces installedIfaces srcMap = do
   when (Flag_GenContents `elem` flags) $ do
     ppHtmlContents odir title pkgStr
                    themes opt_index_url sourceUrls' opt_wiki_urls
-                   allVisibleIfaces True prologue pretty opt_qualification
+                   allVisibleIfaces True prologue pretty
+                   (makeContentsQual opt_qualification)
     copyHtmlBits odir libDir themes
 
   when (Flag_Html `elem` flags) $ do
-- 
cgit v1.2.3


From 979ada5bc63cba38bf570f943a3666298879bdc9 Mon Sep 17 00:00:00 2001
From: Henning Thielemann <git@henning-thielemann.de>
Date: Sun, 1 Apr 2012 22:03:25 +0200
Subject: 'abbreviate' qualification style - basic support Currently we ignore
 the package a module is imported from. This means that a module import would
 shadow another one with the same module name from a different package.

---
 src/Haddock/Backends/Xhtml.hs       |  3 ++-
 src/Haddock/Backends/Xhtml/Names.hs | 22 +++++++++++++++------
 src/Haddock/Interface/Create.hs     | 14 +++++++++++++
 src/Haddock/Options.hs              | 17 ++++++++--------
 src/Haddock/Types.hs                | 39 ++++++++++++++++++++++++-------------
 5 files changed, 67 insertions(+), 28 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 686bd36b..fc94e7d6 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -468,8 +468,9 @@ ppHtmlModule odir doctitle themes
   maybe_contents_url maybe_index_url unicode qual debug iface = do
   let
       mdl = ifaceMod iface
+      abbrevs = ifaceModuleAbbrevs iface
       mdl_str = moduleString mdl
-      real_qual = makeModuleQual qual mdl
+      real_qual = makeModuleQual qual abbrevs mdl
       html =
         headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
         bodyHtml doctitle (Just iface)
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 9963fffc..88ba14dc 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -24,6 +24,7 @@ import Haddock.Types
 import Haddock.Utils
 
 import Text.XHtml hiding ( name, title, p, quote )
+import qualified Data.Map as M
 import qualified Data.List as List
 
 import GHC
@@ -64,24 +65,33 @@ ppQualifyName qual name mdl =
   case qual of
     NoQual   -> ppName name
     FullQual -> ppFullQualName mdl name
-    LocalQual localmdl
-      | moduleString mdl == moduleString localmdl -> ppName name
-      | otherwise -> ppFullQualName mdl name
+    LocalQual localmdl ->
+      if moduleString mdl == moduleString localmdl
+        then ppName name
+        else ppFullQualName mdl name
     RelativeQual localmdl ->
       case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
         -- local, A.x -> x
-        Just []      -> ppQualifyName NoQual name mdl
+        Just []      -> ppName name
         -- sub-module, A.B.x -> B.x
         Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
         -- some module with same prefix, ABC.x -> ABC.x
-        Just _       -> ppQualifyName FullQual name mdl
+        Just _       -> ppFullQualName mdl name
         -- some other module, D.x -> D.x
-        Nothing      -> ppQualifyName FullQual name mdl
+        Nothing      -> ppFullQualName mdl name
+    AbbreviateQual abbrevs localmdl ->
+      case (moduleString mdl == moduleString localmdl,
+            M.lookup (moduleName mdl) abbrevs) of
+        (False, Just abbrev) -> ppQualName abbrev name
+        _ -> ppName name
 
 
 ppFullQualName :: Module -> Name -> Html
 ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name
 
+ppQualName :: ModuleName -> Name -> Html
+ppQualName mdlName name =
+  toHtml $ moduleNameString mdlName ++ '.' : getOccString name
 
 ppName :: Name -> Html
 ppName name = toHtml (getOccString name)
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 94575209..9f183432 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -30,6 +30,7 @@ import Control.Applicative
 import Control.Monad
 import qualified Data.Traversable as T
 
+import qualified SrcLoc
 import GHC hiding (flags)
 import HscTypes
 import Name
@@ -106,6 +107,18 @@ createInterface tm flags modMap instIfaceMap = do
         | OptPrune `elem` opts = prunedExportItems0
         | otherwise = exportItems
 
+  let abbrevs =
+        case tm_renamed_source tm of
+          Nothing -> M.empty
+          Just (_,impDecls,_,_) ->
+            M.fromList $
+            mapMaybe (\(SrcLoc.L _ impDecl) -> do
+              abbrev <- ideclAs impDecl
+              return
+                (case ideclName impDecl of SrcLoc.L _ name -> name,
+                 abbrev))
+              impDecls
+
   return Interface {
     ifaceMod             = mdl,
     ifaceOrigFilename    = msHsFilePath ms,
@@ -123,6 +136,7 @@ createInterface tm flags modMap instIfaceMap = do
     ifaceVisibleExports  = visibleNames,
     ifaceDeclMap         = declMap,
     ifaceSubMap          = subMap,
+    ifaceModuleAbbrevs   = abbrevs,
     ifaceInstances       = instances,
     ifaceHaddockCoverage = coverage
   }
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 537bffac..792c0be3 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -126,7 +126,7 @@ options backwardsCompat =
     Option ['t']  ["title"]    (ReqArg Flag_Heading "TITLE")
       "page heading",
     Option ['q']  ["qual"] (ReqArg Flag_Qualification "QUAL")
-      "qualification of names, one of \n'none' (default), 'full', 'local'\nor 'relative'",
+      "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'abbreviate'",
     Option ['?']  ["help"]  (NoArg Flag_Help)
       "display this help and exit",
     Option ['V']  ["version"]  (NoArg Flag_Version)
@@ -232,13 +232,14 @@ optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
 qualification :: [Flag] -> Either String QualOption
 qualification flags =
   case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
-      []           -> Right OptNoQual
-      ["none"]     -> Right OptNoQual
-      ["full"]     -> Right OptFullQual
-      ["local"]    -> Right OptLocalQual
-      ["relative"] -> Right OptRelativeQual
-      [arg]        -> Left $ "unknown qualification type " ++ show arg
-      _:_          -> Left "qualification option given multiple times"
+      []             -> Right OptNoQual
+      ["none"]       -> Right OptNoQual
+      ["full"]       -> Right OptFullQual
+      ["local"]      -> Right OptLocalQual
+      ["relative"]   -> Right OptRelativeQual
+      ["abbreviate"] -> Right OptAbbreviateQual
+      [arg]          -> Left $ "unknown qualification type " ++ show arg
+      _:_            -> Left "qualification option given multiple times"
 
 
 verbosity :: [Flag] -> Verbosity
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index de0cc3d9..2195faf5 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -103,12 +103,15 @@ data Interface = Interface
     -- module.
   , ifaceVisibleExports  :: ![Name]
 
+    -- | Abbreviations of module imports as in @import A.B.C as C@.
+  , ifaceModuleAbbrevs   :: AbbreviationMap
+
     -- | Instances exported by the module.
   , ifaceInstances       :: ![Instance]
 
     -- | The number of haddockable and haddocked items in the module, as a
     -- tuple. Haddockable items are the exports and the module itself.
-  , ifaceHaddockCoverage  :: (Int,Int)
+  , ifaceHaddockCoverage :: (Int,Int)
   }
 
 
@@ -375,18 +378,27 @@ data DocOption
 
 -- | Option controlling how to qualify names
 data QualOption
-  = OptNoQual        -- ^ Never qualify any names.
-  | OptFullQual      -- ^ Qualify all names fully.
-  | OptLocalQual     -- ^ Qualify all imported names fully.
-  | OptRelativeQual  -- ^ Like local, but strip module prefix
-                     --   from modules in the same hierarchy.
+  = OptNoQual         -- ^ Never qualify any names.
+  | OptFullQual       -- ^ Qualify all names fully.
+  | OptLocalQual      -- ^ Qualify all imported names fully.
+  | OptRelativeQual   -- ^ Like local, but strip module prefix
+                      --   from modules in the same hierarchy.
+  | OptAbbreviateQual -- ^ Uses abbreviations of module names
+                      --   as suggested by module import renamings.
+                      --   However, we are unfortunately not able
+                      --   to maintain the original qualifications.
+                      --   Image a re-export of a whole module,
+                      --   how could the re-exported identifiers be qualified?
+
+type AbbreviationMap = Map ModuleName ModuleName
 
 data Qualification
   = NoQual
   | FullQual
   | LocalQual Module
   | RelativeQual Module
-       -- ^ @Maybe Module@ contains the current module.
+  | AbbreviateQual AbbreviationMap Module
+       -- ^ @Module@ contains the current module.
        --   This way we can distinguish imported and local identifiers.
 
 makeContentsQual :: QualOption -> Qualification
@@ -395,13 +407,14 @@ makeContentsQual qual =
     OptNoQual -> NoQual
     _         -> FullQual
 
-makeModuleQual :: QualOption -> Module -> Qualification
-makeModuleQual qual mdl =
+makeModuleQual :: QualOption -> AbbreviationMap -> Module -> Qualification
+makeModuleQual qual abbrevs mdl =
   case qual of
-    OptLocalQual    -> LocalQual mdl
-    OptRelativeQual -> RelativeQual mdl
-    OptFullQual     -> FullQual
-    OptNoQual       -> NoQual
+    OptLocalQual      -> LocalQual mdl
+    OptRelativeQual   -> RelativeQual mdl
+    OptAbbreviateQual -> AbbreviateQual abbrevs mdl
+    OptFullQual       -> FullQual
+    OptNoQual         -> NoQual
 
 
 -----------------------------------------------------------------------------
-- 
cgit v1.2.3


From c3d370ad042eeeb9f8afc3bf3e99cbbcb9407d60 Mon Sep 17 00:00:00 2001
From: Henning Thielemann <git@henning-thielemann.de>
Date: Mon, 2 Apr 2012 00:19:36 +0200
Subject: abbreviated qualification: use Packages.lookupModuleInAllPackages for
 finding the package that a module belongs to

---
 src/Haddock/Backends/Xhtml/Names.hs |  2 +-
 src/Haddock/Interface/Create.hs     | 41 ++++++++++++++++++++++++++++---------
 src/Haddock/Types.hs                |  2 +-
 3 files changed, 33 insertions(+), 12 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 88ba14dc..863e5f90 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -81,7 +81,7 @@ ppQualifyName qual name mdl =
         Nothing      -> ppFullQualName mdl name
     AbbreviateQual abbrevs localmdl ->
       case (moduleString mdl == moduleString localmdl,
-            M.lookup (moduleName mdl) abbrevs) of
+            M.lookup mdl abbrevs) of
         (False, Just abbrev) -> ppQualName abbrev name
         _ -> ppName name
 
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 9f183432..b9ca6d8c 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -30,6 +30,8 @@ import Control.Applicative
 import Control.Monad
 import qualified Data.Traversable as T
 
+import qualified Packages
+import qualified Module
 import qualified SrcLoc
 import GHC hiding (flags)
 import HscTypes
@@ -108,16 +110,7 @@ createInterface tm flags modMap instIfaceMap = do
         | otherwise = exportItems
 
   let abbrevs =
-        case tm_renamed_source tm of
-          Nothing -> M.empty
-          Just (_,impDecls,_,_) ->
-            M.fromList $
-            mapMaybe (\(SrcLoc.L _ impDecl) -> do
-              abbrev <- ideclAs impDecl
-              return
-                (case ideclName impDecl of SrcLoc.L _ name -> name,
-                 abbrev))
-              impDecls
+        mkAbbrevMap dflags $ tm_renamed_source tm
 
   return Interface {
     ifaceMod             = mdl,
@@ -141,6 +134,34 @@ createInterface tm flags modMap instIfaceMap = do
     ifaceHaddockCoverage = coverage
   }
 
+mkAbbrevMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
+mkAbbrevMap dflags mRenamedSource =
+  case mRenamedSource of
+    Nothing -> M.empty
+    Just (_,impDecls,_,_) ->
+      M.fromList $
+      mapMaybe (\(SrcLoc.L _ impDecl) -> do
+        abbrev <- ideclAs impDecl
+        return $
+          (lookupModuleDyn dflags
+             (fmap Module.fsToPackageId $
+              ideclPkgQual impDecl)
+             (case ideclName impDecl of SrcLoc.L _ name -> name),
+           abbrev))
+        impDecls
+
+-- similar to GHC.lookupModule
+lookupModuleDyn ::
+  DynFlags -> Maybe PackageId -> ModuleName -> Module
+lookupModuleDyn _ (Just pkgId) mdlName =
+  Module.mkModule pkgId mdlName
+lookupModuleDyn dflags Nothing mdlName =
+  flip Module.mkModule mdlName $
+  case filter snd $
+       Packages.lookupModuleInAllPackages dflags mdlName of
+    (pkgId,_):_ -> Packages.packageConfigId pkgId
+    [] -> Module.mainPackageId
+
 
 -------------------------------------------------------------------------------
 -- Warnings
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 2195faf5..7a6d7bb9 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -390,7 +390,7 @@ data QualOption
                       --   Image a re-export of a whole module,
                       --   how could the re-exported identifiers be qualified?
 
-type AbbreviationMap = Map ModuleName ModuleName
+type AbbreviationMap = Map Module ModuleName
 
 data Qualification
   = NoQual
-- 
cgit v1.2.3


From 3eb6d272850950e4d0c41ed1169258e8c332dbed Mon Sep 17 00:00:00 2001
From: Henning Thielemann <git@henning-thielemann.de>
Date: Mon, 2 Apr 2012 00:29:05 +0200
Subject: qualification style 'abbreviated' -> 'aliased'

---
 src/Haddock/Backends/Xhtml.hs       |  4 ++--
 src/Haddock/Backends/Xhtml/Names.hs |  6 +++---
 src/Haddock/Interface/Create.hs     | 14 +++++++-------
 src/Haddock/Options.hs              |  4 ++--
 src/Haddock/Types.hs                | 16 ++++++++--------
 5 files changed, 22 insertions(+), 22 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index fc94e7d6..94ca6d10 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -468,9 +468,9 @@ ppHtmlModule odir doctitle themes
   maybe_contents_url maybe_index_url unicode qual debug iface = do
   let
       mdl = ifaceMod iface
-      abbrevs = ifaceModuleAbbrevs iface
+      aliases = ifaceModuleAliases iface
       mdl_str = moduleString mdl
-      real_qual = makeModuleQual qual abbrevs mdl
+      real_qual = makeModuleQual qual aliases mdl
       html =
         headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
         bodyHtml doctitle (Just iface)
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 863e5f90..48d0f7f1 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -79,10 +79,10 @@ ppQualifyName qual name mdl =
         Just _       -> ppFullQualName mdl name
         -- some other module, D.x -> D.x
         Nothing      -> ppFullQualName mdl name
-    AbbreviateQual abbrevs localmdl ->
+    AliasedQual aliases localmdl ->
       case (moduleString mdl == moduleString localmdl,
-            M.lookup mdl abbrevs) of
-        (False, Just abbrev) -> ppQualName abbrev name
+            M.lookup mdl aliases) of
+        (False, Just alias) -> ppQualName alias name
         _ -> ppName name
 
 
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index b9ca6d8c..a0bfde42 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -109,8 +109,8 @@ createInterface tm flags modMap instIfaceMap = do
         | OptPrune `elem` opts = prunedExportItems0
         | otherwise = exportItems
 
-  let abbrevs =
-        mkAbbrevMap dflags $ tm_renamed_source tm
+  let aliases =
+        mkAliasMap dflags $ tm_renamed_source tm
 
   return Interface {
     ifaceMod             = mdl,
@@ -129,25 +129,25 @@ createInterface tm flags modMap instIfaceMap = do
     ifaceVisibleExports  = visibleNames,
     ifaceDeclMap         = declMap,
     ifaceSubMap          = subMap,
-    ifaceModuleAbbrevs   = abbrevs,
+    ifaceModuleAliases   = aliases,
     ifaceInstances       = instances,
     ifaceHaddockCoverage = coverage
   }
 
-mkAbbrevMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
-mkAbbrevMap dflags mRenamedSource =
+mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
+mkAliasMap dflags mRenamedSource =
   case mRenamedSource of
     Nothing -> M.empty
     Just (_,impDecls,_,_) ->
       M.fromList $
       mapMaybe (\(SrcLoc.L _ impDecl) -> do
-        abbrev <- ideclAs impDecl
+        alias <- ideclAs impDecl
         return $
           (lookupModuleDyn dflags
              (fmap Module.fsToPackageId $
               ideclPkgQual impDecl)
              (case ideclName impDecl of SrcLoc.L _ name -> name),
-           abbrev))
+           alias))
         impDecls
 
 -- similar to GHC.lookupModule
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 792c0be3..46f9def7 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -126,7 +126,7 @@ options backwardsCompat =
     Option ['t']  ["title"]    (ReqArg Flag_Heading "TITLE")
       "page heading",
     Option ['q']  ["qual"] (ReqArg Flag_Qualification "QUAL")
-      "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'abbreviate'",
+      "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'",
     Option ['?']  ["help"]  (NoArg Flag_Help)
       "display this help and exit",
     Option ['V']  ["version"]  (NoArg Flag_Version)
@@ -237,7 +237,7 @@ qualification flags =
       ["full"]       -> Right OptFullQual
       ["local"]      -> Right OptLocalQual
       ["relative"]   -> Right OptRelativeQual
-      ["abbreviate"] -> Right OptAbbreviateQual
+      ["aliased"]    -> Right OptAliasedQual
       [arg]          -> Left $ "unknown qualification type " ++ show arg
       _:_            -> Left "qualification option given multiple times"
 
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 7a6d7bb9..97d56a52 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -103,8 +103,8 @@ data Interface = Interface
     -- module.
   , ifaceVisibleExports  :: ![Name]
 
-    -- | Abbreviations of module imports as in @import A.B.C as C@.
-  , ifaceModuleAbbrevs   :: AbbreviationMap
+    -- | Aliases of module imports as in @import A.B.C as C@.
+  , ifaceModuleAliases   :: AliasMap
 
     -- | Instances exported by the module.
   , ifaceInstances       :: ![Instance]
@@ -383,21 +383,21 @@ data QualOption
   | OptLocalQual      -- ^ Qualify all imported names fully.
   | OptRelativeQual   -- ^ Like local, but strip module prefix
                       --   from modules in the same hierarchy.
-  | OptAbbreviateQual -- ^ Uses abbreviations of module names
+  | OptAliasedQual    -- ^ Uses aliases of module names
                       --   as suggested by module import renamings.
                       --   However, we are unfortunately not able
                       --   to maintain the original qualifications.
                       --   Image a re-export of a whole module,
                       --   how could the re-exported identifiers be qualified?
 
-type AbbreviationMap = Map Module ModuleName
+type AliasMap = Map Module ModuleName
 
 data Qualification
   = NoQual
   | FullQual
   | LocalQual Module
   | RelativeQual Module
-  | AbbreviateQual AbbreviationMap Module
+  | AliasedQual AliasMap Module
        -- ^ @Module@ contains the current module.
        --   This way we can distinguish imported and local identifiers.
 
@@ -407,12 +407,12 @@ makeContentsQual qual =
     OptNoQual -> NoQual
     _         -> FullQual
 
-makeModuleQual :: QualOption -> AbbreviationMap -> Module -> Qualification
-makeModuleQual qual abbrevs mdl =
+makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification
+makeModuleQual qual aliases mdl =
   case qual of
     OptLocalQual      -> LocalQual mdl
     OptRelativeQual   -> RelativeQual mdl
-    OptAbbreviateQual -> AbbreviateQual abbrevs mdl
+    OptAliasedQual    -> AliasedQual aliases mdl
     OptFullQual       -> FullQual
     OptNoQual         -> NoQual
 
-- 
cgit v1.2.3


From 986ff3c5b2e4e519171816c3ad6caa81d4808919 Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Wed, 16 May 2012 17:43:49 +0200
Subject: Use >>= instead of fmap and join

---
 src/Haddock/Backends/LaTeX.hs      | 5 ++---
 src/Haddock/Backends/Xhtml/Decl.hs | 6 ++----
 2 files changed, 4 insertions(+), 7 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index ffe507ab..efe05b9e 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -642,8 +642,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 >>= fst
     mkFunTy a b = noLoc (HsFunTy a b)
 
 
@@ -653,7 +652,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 >>= fst
 
 -- {-
 -- ppHsFullConstr :: HsConDecl -> LaTeX
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 5cdc819c..3cfba1de 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -26,7 +26,6 @@ import Haddock.Backends.Xhtml.Utils
 import Haddock.GhcUtils
 import Haddock.Types
 
-import           Control.Monad         ( join )
 import           Data.List             ( intersperse )
 import qualified Data.Map as Map
 import           Data.Maybe
@@ -589,8 +588,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
     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 >>= fst
     mkFunTy a b = noLoc (HsFunTy a b)
 
 
@@ -602,7 +600,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
     [])
   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 >>= fst
 
 
 ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html
-- 
cgit v1.2.3


From e090bbc5bdc8eb34d5340e467c7157341dfdd945 Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Wed, 16 May 2012 17:14:21 +0200
Subject: newtype-wrap Doc nodes for things that may have warnings attached

---
 src/Haddock/Backends/Hoogle.hs          | 18 ++++++-----
 src/Haddock/Backends/LaTeX.hs           | 56 +++++++++++++++++----------------
 src/Haddock/Backends/Xhtml.hs           | 12 +++----
 src/Haddock/Backends/Xhtml/Decl.hs      | 32 +++++++++----------
 src/Haddock/Backends/Xhtml/DocMarkup.hs | 10 +++---
 src/Haddock/Interface/Create.hs         | 12 ++++---
 src/Haddock/Interface/Rename.hs         | 14 ++++-----
 src/Haddock/Types.hs                    | 20 ++++++------
 8 files changed, 89 insertions(+), 85 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index e7a78fc2..98eeaab8 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -48,7 +48,7 @@ ppHoogle package version synopsis prologue ifaces odir = do
     hClose h
 
 ppModule :: Interface -> [String]
-ppModule iface = "" : doc (ifaceDoc iface) ++
+ppModule iface = "" : ppDocumentation (ifaceDoc iface) ++
                  ["module " ++ moduleString (ifaceMod iface)] ++
                  concatMap ppExport (ifaceExportItems iface) ++
                  concatMap ppInstance (ifaceInstances iface)
@@ -109,7 +109,7 @@ operator x = x
 -- How to print each export
 
 ppExport :: ExportItem Name -> [String]
-ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl)
+ppExport (ExportDecl decl dc subdocs _) = ppDocumentation (fst dc) ++ f (unL decl)
     where
         f (TyClD d@TyData{}) = ppData d subdocs
         f (TyClD d@ClassDecl{}) = ppClass d
@@ -167,19 +167,19 @@ ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} :
                 f w = if w == nam then operator nam else w
 
 -- | for constructors, and named-fields...
-lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name)
+lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> [String]
 lookupCon subdocs (L _ name) = case lookup name subdocs of
-  Just (d, _) -> d
-  _ -> Nothing
+  Just (d, _) -> ppDocumentation d
+  _ -> []
 
 ppCtor :: TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
-ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con))
+ppCtor dat subdocs con = lookupCon subdocs (con_name con)
                          ++ f (con_details con)
     where
         f (PrefixCon args) = [typeSig name $ args ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
         f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
-                          [doc (lookupCon subdocs (cd_fld_name r)) ++
+                          [lookupCon subdocs (cd_fld_name r) ++
                            [out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
                           | r <- recs]
 
@@ -197,6 +197,10 @@ ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con))
 ---------------------------------------------------------------------
 -- DOCUMENTATION
 
+ppDocumentation :: Outputable o => Documentation o -> [String]
+ppDocumentation (Documentation d) = doc d
+
+
 doc :: Outputable o => Maybe (Doc o) -> [String]
 doc = docWith ""
 
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index efe05b9e..6cce753c 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -158,9 +158,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
   --
@@ -210,7 +208,7 @@ processExports (e : es) =
 
 isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
 isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t))))
-                        (Nothing, argDocs) _ _)
+                        (Documentation Nothing, argDocs) _ _)
   | Map.null argDocs = Just (map unLoc lnames, t)
 isSimpleSig _ = Nothing
 
@@ -276,24 +274,24 @@ 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@(TyData {})
-    | Nothing <- tcdTyPats d     -> ppDataDecl instances subdocs loc mbDoc d unicode
-    | Just _  <- tcdTyPats d     -> ppDataInst loc mbDoc d
+    | Nothing <- tcdTyPats d     -> ppDataDecl instances subdocs loc doc d unicode
+    | Just _  <- tcdTyPats d     -> ppDataInst loc doc d
   TyClD d@(TySynonym {})
-    | Nothing <- tcdTyPats d     -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode
-    | Just _  <- tcdTyPats d     -> ppTyInst False loc mbDoc d unicode
-  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
+    | Nothing <- tcdTyPats d     -> ppTySyn loc (doc, fnArgsDoc) d unicode
+    | Just _  <- tcdTyPats d     -> ppTyInst False loc doc 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"
@@ -304,7 +302,7 @@ ppDataInst =
   error "data instance declarations are currently not supported by --latex"
 
 
-ppTyInst :: Bool -> SrcSpan -> Maybe (Doc DocName) ->
+ppTyInst :: Bool -> SrcSpan -> Documentation DocName ->
             TyClDecl DocName -> Bool -> LaTeX
 ppTyInst _ _ _ _ _ =
   error "type instance declarations are currently not supported by --latex"
@@ -355,13 +353,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
 
@@ -469,9 +467,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 lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode
   = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
     instancesBit
@@ -482,7 +480,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
@@ -523,8 +521,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
@@ -550,9 +548,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))
@@ -562,7 +560,7 @@ ppDataDecl instances subdocs _loc mbDoc dataDecl unicode
     cons      = tcdCons dataDecl
     resTy     = (con_res . unLoc . head) cons
 
-    body = catMaybes [constrBit, fmap docToLaTeX mbDoc]
+    body = catMaybes [constrBit, documentationToLaTeX doc]
 
     (whereBit, leaders)
       | null cons = (empty,[])
@@ -642,7 +640,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.
-    mbDoc = lookup (unLoc $ con_name con) subdocs >>= fst
+    mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst
     mkFunTy a b = noLoc (HsFunTy a b)
 
 
@@ -652,7 +650,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 = lookup name subdocs >>= fst
+    mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst
 
 -- {-
 -- ppHsFullConstr :: HsConDecl -> LaTeX
@@ -1042,6 +1040,10 @@ docToLaTeX :: Doc DocName -> LaTeX
 docToLaTeX doc = markup latexMarkup doc Plain
 
 
+documentationToLaTeX :: Documentation DocName -> Maybe LaTeX
+documentationToLaTeX (Documentation mDoc) = docToLaTeX `fmap` mDoc
+
+
 rdrDocToLaTeX :: Doc RdrName -> LaTeX
 rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain
 
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 94ca6d10..c5925cda 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -508,18 +508,16 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
 
     -- todo: if something has only sub-docs, or fn-args-docs, should
     -- it be measured here and thus prevent omitting the synopsis?
-    has_doc (ExportDecl _ doc _ _) = isJust (fst doc)
+    has_doc (ExportDecl _ (Documentation mDoc, _) _ _) = isJust mDoc
     has_doc (ExportNoDecl _ _) = False
     has_doc (ExportModule _) = False
     has_doc _ = True
 
     no_doc_at_all = not (any has_doc exports)
 
-    description
-          = case ifaceRnDoc iface of
-              Nothing -> noHtml
-              Just doc -> divDescription $
-                            sectionName << "Description" +++ docSection qual doc
+    description | isNoHtml doc = doc
+                | otherwise    = divDescription $ sectionName << "Description" +++ doc
+                where doc = docSection qual (ifaceRnDoc iface)
 
         -- omit the synopsis if there are no documentation annotations at all
     synopsis
@@ -639,7 +637,7 @@ processExport summary _ _ qual (ExportNoDecl y subs)
   = processDeclOneLiner summary $
       ppDocName qual y +++ parenList (map (ppDocName qual) subs)
 processExport summary _ _ qual (ExportDoc doc)
-  = nothingIf summary $ docSection qual doc
+  = nothingIf summary $ docSection_ qual doc
 processExport summary _ _ _ (ExportModule mdl)
   = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
 
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 3cfba1de..66b78cbd 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -71,9 +71,9 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
                -> DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification -> Html
 ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) unicode qual
   | summary = pref1
-  | Map.null argDocs = topDeclElem links loc docnames pref1 +++ maybeDocSection qual doc
+  | Map.null argDocs = topDeclElem links loc docnames pref1 +++ docSection qual doc
   | otherwise = topDeclElem links loc docnames pref2 +++
-      subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc
+      subArguments qual (do_args 0 sep typ) +++ docSection qual doc
   where
     argDoc n = Map.lookup n argDocs
 
@@ -166,12 +166,12 @@ ppTyFamHeader summary associated decl unicode qual =
     Nothing -> noHtml
 
 
-ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
+ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
               TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyFam summary associated links loc mbDoc decl unicode qual
+ppTyFam summary associated links loc doc decl unicode qual
 
   | summary   = ppTyFamHeader True associated decl unicode qual
-  | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit
+  | otherwise = header_ +++ docSection qual doc +++ instancesBit
 
   where
     docname = tcdName decl
@@ -206,12 +206,12 @@ ppDataInst = undefined
 --------------------------------------------------------------------------------
 
 
-ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
+ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
             TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyInst summary associated links loc mbDoc decl unicode qual
+ppTyInst summary associated links loc doc decl unicode qual
 
   | summary   = ppTyInstHeader True associated decl unicode qual
-  | otherwise = header_ +++ maybeDocSection qual mbDoc
+  | otherwise = header_ +++ docSection qual doc
 
   where
     docname = tcdName decl
@@ -367,12 +367,12 @@ ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShor
 
 
 ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
-            -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
+            -> Documentation DocName -> [(DocName, DocForDecl DocName)]
             -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppClassDecl summary links instances loc mbDoc subdocs
+ppClassDecl summary links instances loc d subdocs
         decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual
   | summary = ppShortClassDecl summary links decl loc subdocs unicode qual
-  | otherwise = classheader +++ maybeDocSection qual mbDoc
+  | otherwise = classheader +++ docSection qual d
                   +++ atBit +++ methodBit  +++ instancesBit
   where
     classheader
@@ -449,12 +449,12 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual
 
 ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
               [(DocName, DocForDecl DocName)] ->
-              SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool ->
+              SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool ->
               Qualification -> Html
-ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual
+ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
 
   | summary   = ppShortDataDecl summary links loc dataDecl unicode qual
-  | otherwise = header_ +++ maybeDocSection qual mbDoc +++ constrBit +++ instancesBit
+  | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
 
   where
     docname   = unLoc . tcdLName $ dataDecl
@@ -588,7 +588,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
     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.
-    mbDoc = lookup (unLoc $ con_name con) subdocs >>= fst
+    mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst
     mkFunTy a b = noLoc (HsFunTy a b)
 
 
@@ -600,7 +600,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
     [])
   where
     -- don't use cd_fld_doc for same reason we don't use con_doc above
-    mbDoc = lookup name subdocs >>= fst
+    mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst
 
 
 ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index ee0a549f..cd1595f6 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.DocMarkup (
   rdrDocToHtml,
   origDocToHtml,
 
-  docElement, docSection, maybeDocSection,
+  docElement, docSection, docSection_,
 ) where
 
 
@@ -85,12 +85,12 @@ docElement el content_ =
     else el ! [theclass "doc"] << content_
 
 
-docSection :: Qualification -> Doc DocName -> Html
-docSection qual = (docElement thediv <<) . docToHtml qual
+docSection :: Qualification -> Documentation DocName -> Html
+docSection qual (Documentation doc) = maybe noHtml (docSection_ qual) doc
 
 
-maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html
-maybeDocSection qual = maybe noHtml (docSection qual)
+docSection_ :: Qualification -> Doc DocName -> Html
+docSection_ qual = (docElement thediv <<) . docToHtml qual
 
 
 cleanup :: Doc a -> Doc a
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index ea4636fe..e2cc9959 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -117,8 +117,8 @@ createInterface tm flags modMap instIfaceMap = do
     ifaceMod             = mdl,
     ifaceOrigFilename    = msHsFilePath ms,
     ifaceInfo            = info,
-    ifaceDoc             = mbDoc,
-    ifaceRnDoc           = Nothing,
+    ifaceDoc             = Documentation mbDoc,
+    ifaceRnDoc           = Documentation Nothing,
     ifaceOptions         = opts,
     ifaceDocMap          = docMap,
     ifaceArgMap          = argMap,
@@ -609,10 +609,12 @@ hiValExportItem name doc = do
 lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
 lookupDocs n docMap argMap subMap =
   let lookupArgDoc x = M.findWithDefault M.empty x argMap in
-  let doc = (M.lookup n docMap, lookupArgDoc n) in
+  let doc = (lookupDoc n, lookupArgDoc n) in
   let subs = M.findWithDefault [] n subMap in
-  let subDocs = [ (s, (M.lookup s docMap, lookupArgDoc s)) | s <- subs ] in
+  let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in
   (doc, subDocs)
+  where
+    lookupDoc = Documentation . (`M.lookup` docMap)
 
 
 -- | Return all export items produced by an exported module. That is, we're
@@ -772,7 +774,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
 pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
 pruneExportItems = filter hasDoc
   where
-    hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d
+    hasDoc (ExportDecl{expItemMbDoc = (Documentation d, _)}) = isJust d
     hasDoc _ = True
 
 
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index cffe68b8..fd2a1f10 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -47,7 +47,7 @@ renameInterface renamingEnv warnings iface =
       (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))
 
       (finalModuleDoc, missingNames4)
-        = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface))
+        = runRnFM localEnv (renameDocumentation (ifaceDoc iface))
 
       -- combine the missing names and filter out the built-ins, which would
       -- otherwise allways be missing.
@@ -142,15 +142,13 @@ renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
 renameExportItems = mapM renameExportItem
 
 
-renameDocForDecl :: (Maybe (Doc Name), FnArgsDoc Name) -> RnM (Maybe (Doc DocName), FnArgsDoc DocName)
-renameDocForDecl (mbDoc, fnArgsDoc) = do
-  mbDoc' <- renameMaybeDoc mbDoc
-  fnArgsDoc' <- renameFnArgsDoc fnArgsDoc
-  return (mbDoc', fnArgsDoc')
+renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName)
+renameDocForDecl (doc, fnArgsDoc) =
+  (,) `fmap` renameDocumentation doc `ap` renameFnArgsDoc fnArgsDoc
 
 
-renameMaybeDoc :: Maybe (Doc Name) -> RnM (Maybe (Doc DocName))
-renameMaybeDoc = mapM renameDoc
+renameDocumentation :: Documentation Name -> RnM (Documentation DocName)
+renameDocumentation (Documentation mDoc) = Documentation <$> mapM renameDoc mDoc
 
 
 renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 97d56a52..f8d51b2b 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -67,10 +67,10 @@ data Interface = Interface
   , ifaceInfo            :: !(HaddockModInfo Name)
 
     -- | Documentation header.
-  , ifaceDoc             :: !(Maybe (Doc Name))
+  , ifaceDoc             :: !(Documentation Name)
 
     -- | Documentation header with cross-reference information.
-  , ifaceRnDoc           :: Maybe (Doc DocName)
+  , ifaceRnDoc           :: Documentation DocName
 
     -- | Haddock options for this module (prune, ignore-exports, etc).
   , ifaceOptions         :: ![DocOption]
@@ -214,19 +214,23 @@ data ExportItem name
   | ExportModule Module
 
 
+newtype Documentation name = Documentation (Maybe (Doc name))
+  deriving Functor
+
+
 -- | Arguments and result are indexed by Int, zero-based from the left,
 -- because that's the easiest to use when recursing over types.
 type FnArgsDoc name = Map Int (Doc name)
-type DocForDecl name = (Maybe (Doc name), FnArgsDoc name)
+type DocForDecl name = (Documentation name, FnArgsDoc name)
 
 
 noDocForDecl :: DocForDecl name
-noDocForDecl = (Nothing, Map.empty)
+noDocForDecl = (Documentation Nothing, Map.empty)
 
 
 unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name
-unrenameDocForDecl (mbDoc, fnArgsDoc) =
-    (fmap unrenameDoc mbDoc, fmap unrenameDoc fnArgsDoc)
+unrenameDocForDecl (doc, fnArgsDoc) =
+    (fmap getName doc, (fmap . fmap) getName fnArgsDoc)
 
 
 -----------------------------------------------------------------------------
@@ -304,10 +308,6 @@ instance Monoid (Doc id) where
   mappend = DocAppend
 
 
-unrenameDoc :: Doc DocName -> Doc Name
-unrenameDoc = fmap getName
-
-
 data Example = Example
   { exampleExpression :: String
   , exampleResult     :: [String]
-- 
cgit v1.2.3


From a6bcb1e464ff33161f84c5794f5ae239604fb7e5 Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Thu, 17 May 2012 18:35:21 +0200
Subject: Attach warnings to `Documentation` type

---
 src/Haddock/Backends/Hoogle.hs          |  2 +-
 src/Haddock/Backends/LaTeX.hs           |  8 ++--
 src/Haddock/Backends/Xhtml.hs           |  2 +-
 src/Haddock/Backends/Xhtml/Decl.hs      |  4 +-
 src/Haddock/Backends/Xhtml/DocMarkup.hs |  2 +-
 src/Haddock/Interface/Create.hs         | 75 +++++++++++++++------------------
 src/Haddock/Interface/Rename.hs         |  3 +-
 src/Haddock/Types.hs                    | 13 ++++--
 8 files changed, 56 insertions(+), 53 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 98eeaab8..d27ca80f 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -198,7 +198,7 @@ ppCtor dat subdocs con = lookupCon subdocs (con_name con)
 -- DOCUMENTATION
 
 ppDocumentation :: Outputable o => Documentation o -> [String]
-ppDocumentation (Documentation d) = doc d
+ppDocumentation (Documentation d w) = doc d ++ doc w
 
 
 doc :: Outputable o => Maybe (Doc o) -> [String]
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 6cce753c..31ba3b0b 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -208,7 +208,7 @@ processExports (e : es) =
 
 isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
 isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t))))
-                        (Documentation Nothing, argDocs) _ _)
+                        (Documentation Nothing Nothing, argDocs) _ _)
   | Map.null argDocs = Just (map unLoc lnames, t)
 isSimpleSig _ = Nothing
 
@@ -640,7 +640,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.
-    mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst
+    mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
     mkFunTy a b = noLoc (HsFunTy a b)
 
 
@@ -650,7 +650,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 = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst
+    mbDoc = lookup name subdocs >>= combineDocumentation . fst
 
 -- {-
 -- ppHsFullConstr :: HsConDecl -> LaTeX
@@ -1041,7 +1041,7 @@ docToLaTeX doc = markup latexMarkup doc Plain
 
 
 documentationToLaTeX :: Documentation DocName -> Maybe LaTeX
-documentationToLaTeX (Documentation mDoc) = docToLaTeX `fmap` mDoc
+documentationToLaTeX = fmap docToLaTeX . combineDocumentation
 
 
 rdrDocToLaTeX :: Doc RdrName -> LaTeX
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index c5925cda..5a3cbac0 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -508,7 +508,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
 
     -- todo: if something has only sub-docs, or fn-args-docs, should
     -- it be measured here and thus prevent omitting the synopsis?
-    has_doc (ExportDecl _ (Documentation mDoc, _) _ _) = isJust mDoc
+    has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _) = isJust mDoc || isJust mWarning
     has_doc (ExportNoDecl _ _) = False
     has_doc (ExportModule _) = False
     has_doc _ = True
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 66b78cbd..21a33ea8 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -588,7 +588,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
     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.
-    mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst
+    mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
     mkFunTy a b = noLoc (HsFunTy a b)
 
 
@@ -600,7 +600,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
     [])
   where
     -- don't use cd_fld_doc for same reason we don't use con_doc above
-    mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst
+    mbDoc = lookup name subdocs >>= combineDocumentation . fst
 
 
 ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index cd1595f6..052116ee 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -86,7 +86,7 @@ docElement el content_ =
 
 
 docSection :: Qualification -> Documentation DocName -> Html
-docSection qual (Documentation doc) = maybe noHtml (docSection_ qual) doc
+docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation
 
 
 docSection_ :: Qualification -> Doc DocName -> Html
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index e2cc9959..1513349f 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -72,28 +72,23 @@ createInterface tm flags modMap instIfaceMap = do
         | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
         | otherwise = opts0
 
-  (info, mbDoc) <- do
-    (i, d) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
-    return (i, addModuleWarning warnings d)
+  (info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
 
   let declsWithDocs = topDecls group_
       (decls, _) = unzip declsWithDocs
       localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
 
-  (docMap0, argMap, subMap, declMap) <-
+  maps@(docMap, argMap, subMap, declMap) <-
     liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
 
-  let docMap = addWarnings warnings gre exportedNames docMap0
-      maps = (docMap, argMap, subMap, declMap)
-
-      exports0 = fmap (reverse . map unLoc) mayExports
+  let exports0 = fmap (reverse . map unLoc) mayExports
       exports
        | OptIgnoreExports `elem` opts = Nothing
        | otherwise = exports0
 
   liftErrMsg $ warnAboutFilteredDecls mdl decls
 
-  exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports
+  exportItems <- mkExportItems modMap mdl warnings gre exportedNames decls maps exports
                    instances instIfaceMap dflags
 
   let visibleNames = mkVisibleNames exportItems opts
@@ -117,8 +112,8 @@ createInterface tm flags modMap instIfaceMap = do
     ifaceMod             = mdl,
     ifaceOrigFilename    = msHsFilePath ms,
     ifaceInfo            = info,
-    ifaceDoc             = Documentation mbDoc,
-    ifaceRnDoc           = Documentation Nothing,
+    ifaceDoc             = Documentation mbDoc (moduleWarning warnings),
+    ifaceRnDoc           = Documentation Nothing Nothing,
     ifaceOptions         = opts,
     ifaceDocMap          = docMap,
     ifaceArgMap          = argMap,
@@ -169,25 +164,23 @@ lookupModuleDyn dflags Nothing mdlName =
 -------------------------------------------------------------------------------
 
 
--- | Add warnings to documentation. If there is a warning for an identifier
--- with no documentation, create a piece of documentation that just contains
--- the warning.
-addWarnings :: Warnings -> GlobalRdrEnv -> [Name] -> DocMap Name -> DocMap Name
-addWarnings NoWarnings  _ _ dm = dm
-addWarnings (WarnAll _) _ _ dm = dm
-addWarnings (WarnSome ws) gre exps dm = M.unionWith (flip (<>)) dm wm
+-- FIXME: simplify
+lookupWarning :: Warnings -> GlobalRdrEnv -> Name -> Maybe (Doc id)
+lookupWarning NoWarnings  _ _ = Nothing
+lookupWarning (WarnAll _) _ _ = Nothing
+lookupWarning (WarnSome ws) gre name = M.lookup name wm
   where
     wm = M.fromList
       [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
-      , let n = gre_name elt, n `elem` exps ]
+      , let n = gre_name elt, n == name ]
 
 
-addModuleWarning :: Warnings -> Maybe (Doc id) -> Maybe (Doc id)
-addModuleWarning ws =
+moduleWarning :: Warnings -> Maybe (Doc id)
+moduleWarning ws =
   case ws of
-    NoWarnings -> id
-    WarnSome _ -> id
-    WarnAll w  -> let d = warnToDoc w in Just . maybe d (d <>)
+    NoWarnings -> Nothing
+    WarnSome _ -> Nothing
+    WarnAll w  -> Just (warnToDoc w)
 
 
 warnToDoc :: WarningTxt -> Doc id
@@ -459,6 +452,7 @@ collectDocs = go Nothing []
 mkExportItems
   :: IfaceMap
   -> Module             -- this module
+  -> Warnings
   -> GlobalRdrEnv
   -> [Name]             -- exported names (orig)
   -> [LHsDecl Name]
@@ -469,10 +463,10 @@ mkExportItems
   -> DynFlags
   -> ErrMsgGhc [ExportItem Name]
 mkExportItems
-  modMap thisMod gre exportedNames decls0
+  modMap thisMod warnings gre exportedNames decls0
   (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags =
   case optExports of
-    Nothing -> fullModuleContents dflags gre maps decls
+    Nothing -> fullModuleContents dflags warnings gre maps decls
     Just exports -> liftM concat $ mapM lookupExport exports
   where
     decls = filter (not . isInstD . unLoc) decls0
@@ -483,7 +477,7 @@ mkExportItems
     lookupExport (IEThingAll t)        = declWith t
     lookupExport (IEThingWith t _)     = declWith t
     lookupExport (IEModuleContents m)  =
-      moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps
+      moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps
     lookupExport (IEGroup lev docStr)  = liftErrMsg $
       ifDoc (processDocString dflags gre docStr)
             (\doc -> return [ ExportGroup lev "" doc ])
@@ -559,7 +553,7 @@ mkExportItems
                    let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
                    return [ mkExportDecl t decl (noDocForDecl, subs_) ]
                 Just iface ->
-                   return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+                   return [ mkExportDecl t decl (lookupDocs t warnings gre (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
 
         _ -> return []
 
@@ -579,9 +573,9 @@ mkExportItems
     findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
     findDecl n
       | m == thisMod, Just ds <- M.lookup n declMap =
-          (ds, lookupDocs n docMap argMap subMap)
+          (ds, lookupDocs n warnings gre docMap argMap subMap)
       | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
-          (ds, lookupDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
+          (ds, lookupDocs n warnings gre (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
       | otherwise = ([], (noDocForDecl, []))
       where
         m = nameModule n
@@ -606,15 +600,15 @@ hiValExportItem name doc = do
 
 
 -- | Lookup docs for a declaration from maps.
-lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
-lookupDocs n docMap argMap subMap =
+lookupDocs :: Name -> Warnings -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
+lookupDocs n warnings gre docMap argMap subMap =
   let lookupArgDoc x = M.findWithDefault M.empty x argMap in
   let doc = (lookupDoc n, lookupArgDoc n) in
   let subs = M.findWithDefault [] n subMap in
   let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in
   (doc, subDocs)
   where
-    lookupDoc = Documentation . (`M.lookup` docMap)
+    lookupDoc name = Documentation (M.lookup name docMap) (lookupWarning warnings gre name)
 
 
 -- | Return all export items produced by an exported module. That is, we're
@@ -633,6 +627,7 @@ lookupDocs n docMap argMap subMap =
 moduleExports :: Module           -- ^ Module A
               -> ModuleName       -- ^ The real name of B, the exported module
               -> DynFlags         -- ^ The flags used when typechecking A
+              -> Warnings
               -> GlobalRdrEnv     -- ^ The renaming environment used for A
               -> [Name]           -- ^ All the exports of A
               -> [LHsDecl Name]   -- ^ All the declarations in A
@@ -640,8 +635,8 @@ moduleExports :: Module           -- ^ Module A
               -> InstIfaceMap     -- ^ Interfaces in other packages
               -> Maps
               -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap maps
-  | m == thisMod = fullModuleContents dflags gre maps decls
+moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps
+  | m == thisMod = fullModuleContents dflags warnings gre maps decls
   | otherwise =
     case M.lookup m ifaceMap of
       Just iface
@@ -679,8 +674,8 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map
 -- (For more information, see Trac #69)
 
 
-fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls =
+fullModuleContents :: DynFlags -> Warnings -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
   liftM catMaybes $ mapM mkExportItem (expandSig decls)
   where
     -- A type signature can have multiple names, like:
@@ -705,12 +700,12 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls =
     mkExportItem (L _ (ValD d))
       | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
           -- Top-level binding without type signature.
-          let (doc, _) = lookupDocs name docMap argMap subMap in
+          let (doc, _) = lookupDocs name warnings gre docMap argMap subMap in
           fmap Just (hiValExportItem name doc)
       | otherwise = return Nothing
     mkExportItem decl
       | name:_ <- getMainDeclBinder (unLoc decl) =
-        let (doc, subs) = lookupDocs name docMap argMap subMap in
+        let (doc, subs) = lookupDocs name warnings gre docMap argMap subMap in
         return $ Just (ExportDecl decl doc subs [])
       | otherwise = return Nothing
 
@@ -774,7 +769,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
 pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
 pruneExportItems = filter hasDoc
   where
-    hasDoc (ExportDecl{expItemMbDoc = (Documentation d, _)}) = isJust d
+    hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
     hasDoc _ = True
 
 
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index fd2a1f10..7f322eca 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -148,7 +148,8 @@ renameDocForDecl (doc, fnArgsDoc) =
 
 
 renameDocumentation :: Documentation Name -> RnM (Documentation DocName)
-renameDocumentation (Documentation mDoc) = Documentation <$> mapM renameDoc mDoc
+renameDocumentation (Documentation mDoc mWarning) =
+  Documentation `fmap` mapM renameDoc mDoc `ap` mapM renameDoc mWarning
 
 
 renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index f8d51b2b..048a7ff7 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -24,6 +24,7 @@ import Control.Exception
 import Control.Arrow
 import Data.Typeable
 import Data.Map (Map)
+import Data.Maybe
 import qualified Data.Map as Map
 import Data.Monoid
 import GHC hiding (NoLink)
@@ -213,9 +214,15 @@ data ExportItem name
   -- | A cross-reference to another module.
   | ExportModule Module
 
+data Documentation name = Documentation
+  { documentationDoc :: Maybe (Doc name)
+  , documentationWarning :: Maybe (Doc name)
+  } deriving Functor
 
-newtype Documentation name = Documentation (Maybe (Doc name))
-  deriving Functor
+
+combineDocumentation :: Documentation name -> Maybe (Doc name)
+combineDocumentation (Documentation Nothing Nothing) = Nothing
+combineDocumentation (Documentation mDoc mWarning)   = Just (fromMaybe mempty mWarning `mappend` fromMaybe mempty mDoc)
 
 
 -- | Arguments and result are indexed by Int, zero-based from the left,
@@ -225,7 +232,7 @@ type DocForDecl name = (Documentation name, FnArgsDoc name)
 
 
 noDocForDecl :: DocForDecl name
-noDocForDecl = (Documentation Nothing, Map.empty)
+noDocForDecl = (Documentation Nothing Nothing, Map.empty)
 
 
 unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name
-- 
cgit v1.2.3