From e596b668926725fc19f1e4f63ffcc569cdd93eda Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Wed, 25 Jan 2012 02:20:36 +0100
Subject: Some cleanup and make sure we filter warnings through exports.

---
 src/Haddock/Interface/Create.hs | 80 ++++++++++++++++++++++++-----------------
 1 file changed, 47 insertions(+), 33 deletions(-)

(limited to 'src/Haddock')

diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index f890b72e..06d97265 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -73,24 +73,19 @@ createInterface tm flags modMap instIfaceMap = do
 
   (info, mbDoc) <- do
     (i, d) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader
-    return (i, addModuleWarnig warnings d)
+    return (i, addModuleWarning warnings d)
 
   let declsWithDocs = topDecls group_
       (decls, _) = unzip declsWithDocs
       localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
 
-  (docMap0, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs
+  (docMap0, argMap, subMap, declMap) <-
+    liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs
 
-  -- Attach warnings to documentation. If there is a warning for an identifier
-  -- with no documentation, create a piece of documentation that just contains
-  -- the warning.
-  let docMap = foldl' (\m (n, d) -> M.insertWith mappend n d m) docMap0 l
-        where l = [ (gre_name elt, warningToDoc w) | WarnSome ws <- [warnings]
-                  , (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ ]
+  let docMap = addWarnings warnings gre exportedNames docMap0
+      maps = (docMap, argMap, subMap, declMap)
 
-  let maps = (docMap, argMap, subMap, declMap)
-
-  let exports0 = fmap (reverse . map unLoc) mayExports
+      exports0 = fmap (reverse . map unLoc) mayExports
       exports
        | OptIgnoreExports `elem` opts = Nothing
        | otherwise = exports0
@@ -103,18 +98,16 @@ createInterface tm flags modMap instIfaceMap = do
   let visibleNames = mkVisibleNames exportItems opts
 
   -- Measure haddock documentation coverage.
-  let
-    prunedExportItems0 = pruneExportItems exportItems
-    haddockable = 1 + length exportItems -- module + exports
-    haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
-    coverage = (haddockable, haddocked)
+  let prunedExportItems0 = pruneExportItems exportItems
+      haddockable = 1 + length exportItems -- module + exports
+      haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
+      coverage = (haddockable, haddocked)
 
   -- Prune the export list to just those declarations that have
   -- documentation, if the 'prune' option is on.
-  let
-    prunedExportItems
-      | OptPrune `elem` opts = prunedExportItems0
-      | otherwise = exportItems
+  let prunedExportItems
+        | OptPrune `elem` opts = prunedExportItems0
+        | otherwise = exportItems
 
   return Interface {
     ifaceMod             = mdl,
@@ -138,20 +131,40 @@ createInterface tm flags modMap instIfaceMap = do
   }
 
 
-warningToDoc :: WarningTxt -> Doc id
-warningToDoc w = case w of
+-------------------------------------------------------------------------------
+-- Warnings
+-------------------------------------------------------------------------------
+
+
+-- | 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 mappend) dm wm
+  where
+    wm = M.fromList
+      [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+      , let n = gre_name elt, n `elem` exps ]
+
+
+addModuleWarning :: Warnings -> Maybe (Doc id) -> Maybe (Doc id)
+addModuleWarning ws =
+  case ws of
+    NoWarnings -> id
+    WarnSome _ -> id
+    WarnAll w  -> let d = warnToDoc w in Just . maybe d (mappend d)
+
+
+warnToDoc :: WarningTxt -> Doc id
+warnToDoc w = case w of
   (DeprecatedTxt msg) -> format "Deprecated: " msg
   (WarningTxt    msg) -> format "Warning: "    msg
   where
     format x xs = DocWarning . DocParagraph . DocString . concat $ x : map unpackFS xs
 
 
-addModuleWarnig :: Warnings -> Maybe (Doc id) -> Maybe (Doc id)
-addModuleWarnig warnings
-  | WarnAll w <- warnings = let d = warningToDoc w in Just . maybe d (mappend d)
-  | otherwise = id
-
-
 -------------------------------------------------------------------------------
 -- Doc options
 --
@@ -555,11 +568,12 @@ hiValExportItem name doc = do
 
 -- | Lookup docs for a declaration from maps.
 lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
-lookupDocs name docMap argMap subMap =
-  let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in
-  let doc = (M.lookup name docMap, lookupArgMap name) in
-  let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in
-  (doc, subs)
+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 subs = M.findWithDefault [] n subMap in
+  let subDocs = [ (s, (M.lookup s docMap, lookupArgDoc s)) | s <- subs ] in
+  (doc, subDocs)
 
 
 -- | Return all export items produced by an exported module. That is, we're
-- 
cgit v1.2.3