Merge pull request #893 from harpocrates/get-name-to-instances

Accumulate explicitly which modules to load for 'attachInstances'

1 files changed, 35 insertions, 24 deletions

diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index a66745ea..c330c5fe 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, OverloadedStrings #-}
+{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface
@@ -51,6 +51,7 @@ import System.Directory
 import System.FilePath
 import Text.Printf
 
+import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
 import Digraph
 import DynFlags hiding (verbosity)
 import Exception
@@ -59,7 +60,9 @@ import HscTypes
 import FastString (unpackFS)
 import MonadUtils (liftIO)
 import TcRnTypes (tcg_rdr_env)
-import RdrName (plusGlobalRdrEnv)
+import Name (nameIsFromExternalPackage, nameOccName)
+import OccName (isTcOcc)
+import RdrName (unQualOK, gre_name, globalRdrEnvElts)
 import ErrUtils (withTiming)
 
 #if defined(mingw32_HOST_OS)
@@ -87,7 +90,7 @@ processModules verbosity modules flags extIfaces = do
   out verbosity verbose "Creating interfaces..."
   let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
                                    , iface <- ifInstalledIfaces ext ]
-  interfaces <- createIfaces0 verbosity modules flags instIfaceMap
+  (interfaces, ms) <- createIfaces0 verbosity modules flags instIfaceMap
 
   let exportedNames =
         Set.unions $ map (Set.fromList . ifaceExports) $
@@ -96,7 +99,7 @@ processModules verbosity modules flags extIfaces = do
   out verbosity verbose "Attaching instances..."
   interfaces' <- {-# SCC attachInstances #-}
                  withTiming getDynFlags "attachInstances" (const ()) $ do
-                   attachInstances (exportedNames, mods) interfaces instIfaceMap
+                   attachInstances (exportedNames, mods) interfaces instIfaceMap ms
 
   out verbosity verbose "Building cross-linking environment..."
   -- Combine the link envs of the external packages into one
@@ -120,7 +123,7 @@ processModules verbosity modules flags extIfaces = do
 --------------------------------------------------------------------------------
 
 
-createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
+createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
 createIfaces0 verbosity modules flags instIfaceMap =
   -- Output dir needs to be set before calling depanal since depanal uses it to
   -- compute output file names that are stored in the DynFlags of the
@@ -150,43 +153,51 @@ createIfaces0 verbosity modules flags instIfaceMap =
       depanal [] False
 
 
-createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
+createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc ([Interface], ModuleSet)
 createIfaces verbosity flags instIfaceMap mods = do
   let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
   out verbosity normal "Haddock coverage:"
-  (ifaces, _) <- foldM f ([], Map.empty) sortedMods
-  return (reverse ifaces)
+  (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods
+  return (reverse ifaces, ms)
   where
-    f (ifaces, ifaceMap) modSummary = do
+    f (ifaces, ifaceMap, !ms) modSummary = do
       x <- {-# SCC processModule #-}
            withTiming getDynFlags "processModule" (const ()) $ do
              processModule verbosity modSummary flags ifaceMap instIfaceMap
       return $ case x of
-        Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)
-        Nothing    -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.
+        Just (iface, ms') -> ( iface:ifaces
+                             , Map.insert (ifaceMod iface) iface ifaceMap
+                             , unionModuleSet ms ms' )
+        Nothing           -> ( ifaces
+                             , ifaceMap
+                             , ms ) -- Boot modules don't generate ifaces.
 
 
-processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
+processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet))
 processModule verbosity modsum flags modMap instIfaceMap = do
   out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
   tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum
 
-  -- We need to modify the interactive context's environment so that when
-  -- Haddock later looks for instances, it also looks in the modules it
-  -- encountered while typechecking.
-  --
-  -- See https://github.com/haskell/haddock/issues/469.
-  hsc_env@HscEnv{ hsc_IC = old_IC } <- getSession
-  let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
-  setSession hsc_env{ hsc_IC = old_IC {
-    ic_rn_gbl_env = ic_rn_gbl_env old_IC `plusGlobalRdrEnv` new_rdr_env
-  } }
-
   if not $ isBootSummary modsum then do
     out verbosity verbose "Creating interface..."
     (interface, msgs) <- {-# SCC createIterface #-}
                         withTiming getDynFlags "createInterface" (const ()) $ do
                           runWriterGhc $ createInterface tm flags modMap instIfaceMap
+
+    -- We need to keep track of which modules were somehow in scope so that when
+    -- Haddock later looks for instances, it also looks in these modules too.
+    --
+    -- See https://github.com/haskell/haddock/issues/469.
+    hsc_env <- getSession
+    let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
+        this_pkg = thisPackage (hsc_dflags hsc_env)
+        !mods = mkModuleSet [ nameModule name
+                            | gre <- globalRdrEnvElts new_rdr_env
+                            , let name = gre_name gre
+                            , nameIsFromExternalPackage this_pkg name
+                            , isTcOcc (nameOccName name)   -- Types and classes only
+                            , unQualOK gre ]               -- In scope unqualified
+
     liftIO $ mapM_ putStrLn (nub msgs)
     dflags <- getDynFlags
     let (haddockable, haddocked) = ifaceHaddockCoverage interface
@@ -220,7 +231,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do
         unless header $ out verbosity normal "    Module header"
         mapM_ (out verbosity normal . ("    " ++)) undocumentedExports
     interface' <- liftIO $ evaluate interface
-    return (Just interface')
+    return (Just (interface', mods))
   else
     return Nothing