Accumulate explicitly which modules to load for 'attachInstances'

The old approach to fixing #469, while correct, consumes a lot of
memory. We ended up with a HUGE 'GblRdrEnv' in 'ic_rn_gbl_env'. However,
'getNameToInstancesIndex' takes that environment and compresses it down
to a much smaller 'ModuleSet'.

Now, we compute that 'ModuleSet' explicitly as we process modules. That
way we can just tell 'getNameToInstancesIndex' what modules to load
(instead of it trying to compute that information from the interactive
context).

2 files changed, 42 insertions, 28 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
 
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index bf50ded3..2d72d117 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash #-}
+{-# LANGUAGE CPP, MagicHash, BangPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
 -----------------------------------------------------------------------------
 -- |
@@ -34,6 +34,7 @@ import FamInstEnv
 import FastString
 import GHC
 import InstEnv
+import Module ( ModuleSet, moduleSetElts )
 import MonadUtils (liftIO)
 import Name
 import NameEnv
@@ -51,11 +52,13 @@ type Modules = Set.Set Module
 type ExportInfo = (ExportedNames, Modules)
 
 -- Also attaches fixities
-attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
-attachInstances expInfo ifaces instIfaceMap = do
-  (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces)
+attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> ModuleSet -> Ghc [Interface]
+attachInstances expInfo ifaces instIfaceMap mods = do
+  (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mods'
   mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces
   where
+    mods' = Just (moduleSetElts mods)
+
     -- TODO: take an IfaceMap as input
     ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]