diff options
Diffstat (limited to 'haddock-api')
| -rw-r--r-- | haddock-api/src/Haddock/Interface.hs | 59 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 11 |
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 ] |