From 6cc832dfb1de6088a4abcaae62b25a7e944d55c3 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Tue, 14 Mar 2017 03:53:49 -0700
Subject: Better Backpack support with signature merging.

When we merge signatures, we gain exports that don't
necessarily have a source-level declaration corresponding
to them.  This meant Haddock dropped them.

There are two big limitations:

* If there's no export list, we won't report inherited
  signatures.

* If the type has a subordinate, the current hiDecl
  implementation doesn't reconstitute them.

These are probably worth fixing eventually, but this gets
us to minimum viable functionality.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
---
 haddock-api/src/Haddock/Interface/Create.hs | 46 +++++++++++++++++++++--------
 1 file changed, 34 insertions(+), 12 deletions(-)

(limited to 'haddock-api/src/Haddock')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 97005437..cd46831e 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -71,6 +71,7 @@ createInterface tm flags modMap instIfaceMap = do
       !safety        = modInfoSafe mi
       mdl            = ms_mod ms
       sem_mdl        = tcg_semantic_mod (fst (tm_internals_ tm))
+      is_sig         = ms_hsc_src ms == HsigFile
       dflags         = ms_hspp_opts ms
       !instances     = modInfoInstances mi
       !fam_instances = md_fam_insts md
@@ -117,7 +118,7 @@ createInterface tm flags modMap instIfaceMap = do
 
   -- The MAIN functionality: compute the export items which will
   -- each be the actual documentation of this module.
-  exportItems <- mkExportItems modMap mdl sem_mdl allWarnings gre exportedNames decls
+  exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls
                    maps fixMap splices exports instIfaceMap dflags
 
   let !visibleNames = mkVisibleNames maps exportItems opts
@@ -143,7 +144,7 @@ createInterface tm flags modMap instIfaceMap = do
 
   return $! Interface {
     ifaceMod             = mdl
-  , ifaceIsSig           = Module.isHoleModule sem_mdl
+  , ifaceIsSig           = is_sig
   , ifaceOrigFilename    = msHsFilePath ms
   , ifaceInfo            = info
   , ifaceDoc             = Documentation mbDoc modWarn
@@ -525,7 +526,8 @@ collectDocs = go Nothing []
 -- We create the export items even if the module is hidden, since they
 -- might be useful when creating the export items for other modules.
 mkExportItems
-  :: IfaceMap
+  :: Bool               -- is it a signature
+  -> IfaceMap
   -> Module             -- this module
   -> Module             -- semantic module
   -> WarningMap
@@ -540,7 +542,7 @@ mkExportItems
   -> DynFlags
   -> ErrMsgGhc [ExportItem Name]
 mkExportItems
-  modMap thisMod semMod warnings gre exportedNames decls
+  is_sig modMap thisMod semMod warnings gre exportedNames decls
   maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
   case optExports of
     Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
@@ -569,8 +571,9 @@ mkExportItems
         Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
 
     declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
-    declWith t =
-      case findDecl t of
+    declWith t = do
+      r <- findDecl t
+      case r of
         ([L l (ValD _)], (doc, _)) -> do
           -- Top-level binding without type signature
           export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
@@ -649,13 +652,32 @@ mkExportItems
     isExported = (`elem` exportedNames)
 
 
-    findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
+    findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
     findDecl n
-      | m == semMod, Just ds <- M.lookup n declMap =
-          (ds, lookupDocs n warnings docMap argMap subMap)
-      | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
-          (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
-      | otherwise = ([], (noDocForDecl, []))
+      | m == semMod =
+          case M.lookup n declMap of
+            Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap)
+            Nothing
+              | is_sig -> do
+                -- OK, so it wasn't in the local declaration map.  It could
+                -- have been inherited from a signature.  Reconstitute it
+                -- from the type.
+                mb_r <- hiDecl dflags n
+                case mb_r of
+                    Nothing -> return ([], (noDocForDecl, []))
+                    -- TODO: If we try harder, we might be able to find
+                    -- a Haddock!  Look in the Haddocks for each thing in
+                    -- requirementContext (pkgState)
+                    Just decl -> return ([decl], (noDocForDecl, []))
+              | otherwise ->
+                return ([], (noDocForDecl, []))
+      | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
+      , Just ds <- M.lookup n (ifaceDeclMap iface) =
+          return (ds, lookupDocs n warnings
+                            (ifaceDocMap iface)
+                            (ifaceArgMap iface)
+                            (ifaceSubMap iface))
+      | otherwise = return ([], (noDocForDecl, []))
       where
         m = nameModule n
 
-- 
cgit v1.2.3