From 0f8e38017cbb981ea07e52d5a4a7f4736c30718b Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Wed, 22 Sep 2010 17:58:06 +0000
Subject: print haddock coverage info on stdout when generating docs A module's
 haddockable items are its exports and the module itself. The output is
 lightly formatted so you can align the :'s and sort for readability.

---
 src/Haddock/Interface.hs        |  8 ++++++++
 src/Haddock/Interface/Create.hs | 12 ++++++++++--
 src/Haddock/Types.hs            |  7 +++++--
 3 files changed, 23 insertions(+), 4 deletions(-)

diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 0c171cbc..81919aed 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -46,6 +46,7 @@ import qualified Data.Map as Map
 import Distribution.Verbosity
 import System.Directory
 import System.FilePath
+import Text.Printf
 
 import Digraph
 import Exception
@@ -161,6 +162,13 @@ processModule verbosity modsum flags modMap instIfaceMap = do
       out verbosity verbose "Creating interface..."
       (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap
       liftIO $ mapM_ putStrLn msg
+      let (haddockable, haddocked) = ifaceHaddockCoverage interface
+          percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int
+          coveragemsg = printf "haddock coverage for %s: %7s %3d%%"
+                        (ifaceOrigFilename interface)
+                        (printf "%d/%d" haddocked haddockable ::  String)
+                        percentage
+      out verbosity normal coveragemsg
       interface' <- liftIO $ evaluate interface
       return (Just interface')
     else
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index b6215a34..db2ec05c 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -79,11 +79,18 @@ 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)
+
   -- prune the export list to just those declarations that have
   -- documentation, if the 'prune' option is on.
   let
     prunedExportItems
-      | OptPrune `elem` opts = pruneExportItems exportItems
+      | OptPrune `elem` opts = prunedExportItems0
       | otherwise = exportItems
 
   return Interface {
@@ -101,7 +108,8 @@ createInterface tm flags modMap instIfaceMap = do
     ifaceDeclMap         = declMap,
     ifaceSubMap          = mkSubMap declMap exportedNames,
     ifaceInstances       = instances,
-    ifaceInstanceDocMap  = instanceDocMap
+    ifaceInstanceDocMap  = instanceDocMap,
+    ifaceHaddockCoverage = coverage
   }
 
 
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 33892e49..b0ac6cac 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -99,9 +99,12 @@ data Interface = Interface {
   ifaceInstances       :: ![Instance],
 
   -- | Documentation of instances defined in the module.
-  ifaceInstanceDocMap  :: Map Name (Doc Name)
-}
+  ifaceInstanceDocMap  :: Map Name (Doc Name),
 
+  -- | 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)
+}
 
 -- | A smaller version of 'Interface' that can be created from Haddock's
 -- interface files ('InterfaceFile').
-- 
cgit v1.2.3