{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE TupleSections     #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Interface
-- Copyright   :  (c) Simon Marlow      2003-2006,
--                    David Waern       2006-2010,
--                    Mateusz Kowalczyk 2013
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- This module typechecks Haskell modules using the GHC API and processes
-- the result to create 'Interface's. The typechecking and the 'Interface'
-- creation is interleaved, so that when a module is processed, the
-- 'Interface's of all previously processed modules are available. The
-- creation of an 'Interface' from a typechecked module is delegated to
-- "Haddock.Interface.Create".
--
-- When all modules have been typechecked and processed, information about
-- instances are attached to each 'Interface'. This task is delegated to
-- "Haddock.Interface.AttachInstances". Note that this is done as a separate
-- step because GHC can't know about all instances until all modules have been
-- typechecked.
--
-- As a last step a link environment is built which maps names to the \"best\"
-- places to link to in the documentation, and all 'Interface's are \"renamed\"
-- using this environment.
-----------------------------------------------------------------------------
module Haddock.Interface (
  processModules
) where


import Control.Monad
import Data.List (isPrefixOf)
import qualified Data.List as List
import Data.Traversable (for)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Debug.Trace (traceMarkerIO)
import System.Exit (exitFailure ) -- TODO use Haddock's die
import Text.Printf
import GHC hiding (verbosity, SuccessFlag(..))
import GHC.Builtin.Names (mkMainModule_)
import qualified GHC.Data.EnumSet as EnumSet
import GHC.Data.FastString (unpackFS)
import GHC.Data.Graph.Directed
import GHC.Data.Maybe
import GHC.Driver.Env
import GHC.Driver.Monad
import GHC.Driver.Make
import GHC.Driver.Main
import GHC.Core.InstEnv
import qualified GHC.Driver.DynFlags as DynFlags
import qualified GHC.Utils.Outputable as Outputable
import GHC.Driver.Session hiding (verbosity)
import GHC.Driver.Phases
import GHC.Driver.Pipeline (compileFile)
import GHC.HsToCore.Docs (getMainDeclBinder)
import GHC.Iface.Load (loadSysInterface)
import GHC.IfaceToCore (tcIfaceInst, tcIfaceFamInst)
import GHC.Tc.Utils.Monad (initIfaceLoad, initIfaceLcl)
import GHC.Tc.Utils.Env (lookupGlobal_maybe)
import GHC.Types.Error (mkUnknownDiagnostic)
import GHC.Types.Name.Occurrence (emptyOccEnv)
import GHC.Unit.Finder (findImportedModule, FindResult(Found))
import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.Graph (ModuleGraphNode (..))
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModIface (mi_semantic_module, mi_boot)
import GHC.Unit.Module.ModSummary (isBootSummary)
import GHC.Utils.Outputable (Outputable, (<+>), pprModuleName, text)
import GHC.Utils.Error (withTiming)
import GHC.Utils.Monad (mapMaybeM)

import Haddock.GhcUtils (moduleString, pretty)
import Haddock.Interface.AttachInstances (attachInstances)
import Haddock.Interface.Create (createInterface1, createInterface1')
import Haddock.Interface.Rename (renameInterface)
import Haddock.InterfaceFile (InterfaceFile, ifInstalledIfaces, ifLinkEnv)
import Haddock.Options hiding (verbosity)
import Haddock.Types
import Haddock.Utils (Verbosity (..), normal, out, verbose)
import qualified Haddock.Compat as Compat

-- | Create 'Interface's and a link environment by typechecking the list of
-- modules using the GHC API and processing the resulting syntax trees.
processModules
  :: Verbosity                  -- ^ Verbosity of logging to 'stdout'
  -> [String]                   -- ^ A list of file or module names sorted by
                                -- module topology
  -> [Flag]                     -- ^ Command-line flags
  -> [InterfaceFile]            -- ^ Interface files of package dependencies
  -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming
                                -- environment
processModules :: Verbosity
-> [[Char]]
-> [Flag]
-> [InterfaceFile]
-> Ghc ([Interface], LinkEnv)
processModules Verbosity
verbosity [[Char]]
modules [Flag]
flags [InterfaceFile]
extIfaces = do
  IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO ()
Compat.setEncoding
  dflags <- Ghc DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags

  -- Map from a module to a corresponding installed interface
  let instIfaceMap :: InstIfaceMap
      instIfaceMap = [(Module, InstalledInterface)] -> InstIfaceMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (InstalledInterface -> Module
instMod InstalledInterface
iface, InstalledInterface
iface)
        | InterfaceFile
ext <- [InterfaceFile]
extIfaces
        , InstalledInterface
iface <- InterfaceFile -> [InstalledInterface]
ifInstalledIfaces InterfaceFile
ext
        ]
      oneShotHiFile = [Flag] -> Maybe [Char]
optOneShot [Flag]
flags

  interfaces <- maybe
    (createIfaces verbosity modules flags instIfaceMap)
    (createOneShotIface verbosity flags instIfaceMap)
    oneShotHiFile

  let exportedNames =
        [Set Name] -> Set Name
forall (f :: Type -> Type) a.
(Foldable f, Ord a) =>
f (Set a) -> Set a
Set.unions ([Set Name] -> Set Name) -> [Set Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ (Interface -> Set Name) -> [Interface] -> [Set Name]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name)
-> (Interface -> [Name]) -> Interface -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> [Name]
ifaceExports) ([Interface] -> [Set Name]) -> [Interface] -> [Set Name]
forall a b. (a -> b) -> a -> b
$
        (Interface -> Bool) -> [Interface] -> [Interface]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Interface
i -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DocOption
OptHide DocOption -> [DocOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` Interface -> [DocOption]
ifaceOptions Interface
i) [Interface]
interfaces
      mods = [Module] -> Set Module
forall a. Ord a => [a] -> Set a
Set.fromList ([Module] -> Set Module) -> [Module] -> Set Module
forall a b. (a -> b) -> a -> b
$ (Interface -> Module) -> [Interface] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> Module
ifaceMod [Interface]
interfaces

  interfaces' <- {-# SCC attachInstances #-}
                 withTimingM "attachInstances" (const ()) $ do
                   attachInstances (exportedNames, mods) interfaces instIfaceMap (isJust oneShotHiFile)

  -- Combine the link envs of the external packages into one
  let extLinks  = [LinkEnv] -> LinkEnv
forall (f :: Type -> Type) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ((InterfaceFile -> LinkEnv) -> [InterfaceFile] -> [LinkEnv]
forall a b. (a -> b) -> [a] -> [b]
map InterfaceFile -> LinkEnv
ifLinkEnv [InterfaceFile]
extIfaces)
      homeLinks = [Interface] -> LinkEnv
buildHomeLinks [Interface]
interfaces' -- Build the environment for the home
                                             -- package
      links     = LinkEnv
homeLinks LinkEnv -> LinkEnv -> LinkEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` LinkEnv
extLinks

  let warnings = Flag
Flag_NoWarnings Flag -> [Flag] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` [Flag]
flags
      ignoredSymbolSet = [Flag] -> Map (Maybe [Char]) (Set [Char])
ignoredSymbols [Flag]
flags

  interfaces'' <-
    withTimingM "renameAllInterfaces" (const ()) $
      for interfaces' $ \Interface
i -> do
        SDoc -> (Interface -> ()) -> Ghc Interface -> Ghc Interface
forall (m :: Type -> Type) b.
GhcMonad m =>
SDoc -> (b -> ()) -> m b -> m b
withTimingM (SDoc
"renameInterface: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleName -> SDoc
forall doc. IsLine doc => ModuleName -> doc
pprModuleName (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Interface -> Module
ifaceMod Interface
i))) (() -> Interface -> ()
forall a b. a -> b -> a
const ()) (Ghc Interface -> Ghc Interface) -> Ghc Interface -> Ghc Interface
forall a b. (a -> b) -> a -> b
$
          DynFlags
-> Map (Maybe [Char]) (Set [Char])
-> LinkEnv
-> Bool
-> Bool
-> Interface
-> Ghc Interface
renameInterface DynFlags
dflags Map (Maybe [Char]) (Set [Char])
ignoredSymbolSet LinkEnv
links Bool
warnings (Flag
Flag_Hoogle Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags) Interface
i

  return (interfaces'', homeLinks)

--------------------------------------------------------------------------------
-- * Module typechecking and Interface creation
--------------------------------------------------------------------------------

createIfaces
    :: Verbosity
    -- ^ Verbosity requested by the caller
    -> [String]
    -- ^ List of modules provided as arguments to Haddock (still in FilePath
    -- format)
    -> [Flag]
    -- ^ Command line flags which Hadddock was invoked with
    -> InstIfaceMap
    -- ^ Map from module to corresponding installed interface file
    -> Ghc [Interface]
    -- ^ Resulting interfaces
createIfaces :: Verbosity -> [[Char]] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
createIfaces Verbosity
verbosity [[Char]]
modules [Flag]
flags InstIfaceMap
instIfaceMap = do
  let ([([Char], Maybe Phase)]
hs_srcs, [([Char], Maybe Phase)]
non_hs_srcs) = (([Char], Maybe Phase) -> Bool)
-> [([Char], Maybe Phase)]
-> ([([Char], Maybe Phase)], [([Char], Maybe Phase)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ([Char], Maybe Phase) -> Bool
isHaskellishTarget ([([Char], Maybe Phase)]
 -> ([([Char], Maybe Phase)], [([Char], Maybe Phase)]))
-> [([Char], Maybe Phase)]
-> ([([Char], Maybe Phase)], [([Char], Maybe Phase)])
forall a b. (a -> b) -> a -> b
$ ([Char] -> ([Char], Maybe Phase))
-> [[Char]] -> [([Char], Maybe Phase)]
forall a b. (a -> b) -> [a] -> [b]
map (,Maybe Phase
forall a. Maybe a
Nothing) [[Char]]
modules
  hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
  o_files <- mapMaybeM (\([Char], Maybe Phase)
x -> IO (Maybe [Char]) -> Ghc (Maybe [Char])
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Char]) -> Ghc (Maybe [Char]))
-> IO (Maybe [Char]) -> Ghc (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ HscEnv -> StopPhase -> ([Char], Maybe Phase) -> IO (Maybe [Char])
compileFile HscEnv
hsc_env StopPhase
NoStop ([Char], Maybe Phase)
x)
             non_hs_srcs
  dflags <- getSessionDynFlags
  let dflags' = DynFlags
dflags { ldInputs = map (FileOption "") o_files
                                    ++ ldInputs dflags }
      dflags'' = if Flag
Flag_NoCompilation Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags then DynFlags
dflags' { ghcMode = OneShot } else DynFlags
dflags'
  _ <- setSessionDynFlags dflags''
  targets <- mapM (\([Char]
filePath, Maybe Phase
_) -> [Char] -> Maybe UnitId -> Maybe Phase -> Ghc Target
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> Maybe UnitId -> Maybe Phase -> m Target
guessTarget [Char]
filePath Maybe UnitId
forall a. Maybe a
Nothing Maybe Phase
forall a. Maybe a
Nothing) hs_srcs
  setTargets targets
  (_errs, modGraph) <- depanalE mkUnknownDiagnostic (Just batchMsg) [] False

  -- Create (if necessary) and load .hi-files. With --no-compilation this happens later.
  when (Flag_NoCompilation `notElem` flags) $ do
    liftIO $ traceMarkerIO "Load started"
    success <- withTimingM "load'" (const ()) $
                load' noIfaceCache LoadAllTargets mkUnknownDiagnostic (Just batchMsg) modGraph
    when (failed success) $ do
      out verbosity normal "load' failed"
      liftIO exitFailure
    liftIO $ traceMarkerIO "Load ended"

      -- We topologically sort the module graph including boot files,
      -- so it should be acylic (hopefully we failed much earlier if this is not the case)
      -- We then filter out boot modules from the resultant topological sort
      --
      -- We do it this way to make 'buildHomeLinks' a bit more stable
      -- 'buildHomeLinks' depends on the topological order of its input in order
      -- to construct its result. In particular, modules closer to the bottom of
      -- the dependency chain are to be prefered for link destinations.
      --
      -- If there are cycles in the graph, then this order is indeterminate
      -- (the nodes in the cycle can be ordered in any way).
      -- While 'topSortModuleGraph' does guarantee stability for equivalent
      -- module graphs, seemingly small changes in the ModuleGraph can have
      -- big impacts on the `LinkEnv` constructed.
      --
      -- For example, suppose
      --  G1 = A.hs -> B.hs -> C.hs (where '->' denotes an import).
      --
      -- Then suppose C.hs is changed to have a cyclic dependency on A
      --
      --  G2 = A.hs -> B.hs -> C.hs -> A.hs-boot
      --
      -- For G1, `C.hs` is preferred for link destinations. However, for G2,
      -- the topologically sorted order not taking into account boot files (so
      -- C -> A) is completely indeterminate.
      -- Using boot files to resolve cycles, we end up with the original order
      -- [C, B, A] (in decreasing order of preference for links)
      --
      -- This exact case came up in testing for the 'base' package, where there
      -- is a big module cycle involving 'Prelude' on windows, but the cycle doesn't
      -- include 'Prelude' on non-windows platforms. This lead to drastically different
      -- LinkEnv's (and failing haddockHtmlTests) across the platforms
      --
      -- In effect, for haddock users this behaviour (using boot files to eliminate cycles)
      -- means that {-# SOURCE #-} imports no longer count towards re-ordering
      -- the preference of modules for linking.
      --
      -- i.e. if module A imports B, then B is preferred over A,
      -- but if module A {-# SOURCE #-} imports B, then we can't say the same.
      --
  let
      go (AcyclicSCC (ModuleNode [NodeKey]
_ ModSummary
ms))
        | IsBootInterface
NotBoot <- ModSummary -> IsBootInterface
isBootSummary ModSummary
ms = [ModSummary
ms]
        | Bool
otherwise = []
      go (AcyclicSCC ModuleGraphNode
_) = []
      go (CyclicSCC [ModuleGraphNode]
_) = [Char] -> [ModSummary]
forall a. HasCallStack => [Char] -> a
error [Char]
"haddock: module graph cyclic even with boot files"

      -- Visit modules in that order
      sortedMods = (SCC ModuleGraphNode -> [ModSummary])
-> [SCC ModuleGraphNode] -> [ModSummary]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap SCC ModuleGraphNode -> [ModSummary]
go ([SCC ModuleGraphNode] -> [ModSummary])
-> [SCC ModuleGraphNode] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
False ModuleGraph
modGraph Maybe HomeUnitModule
forall a. Maybe a
Nothing
  out verbosity normal "Haddock coverage:"
  let inst_warning_map = [Map Name (Doc Name)] -> Map Name (Doc Name)
forall (f :: Type -> Type) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map Name (Doc Name)] -> Map Name (Doc Name))
-> [Map Name (Doc Name)] -> Map Name (Doc Name)
forall a b. (a -> b) -> a -> b
$ (InstalledInterface -> Map Name (Doc Name))
-> [InstalledInterface] -> [Map Name (Doc Name)]
forall a b. (a -> b) -> [a] -> [b]
map InstalledInterface -> Map Name (Doc Name)
instWarningMap (InstIfaceMap -> [InstalledInterface]
forall k a. Map k a -> [a]
Map.elems InstIfaceMap
instIfaceMap)
  (ifaces, _, _) <- foldM f ([], Map.empty, inst_warning_map) sortedMods
  return (reverse ifaces)
  where
    f :: ([Interface], IfaceMap, Map Name (Doc Name))
-> ModSummary -> Ghc ([Interface], IfaceMap, Map Name (Doc Name))
f ([Interface]
ifaces, IfaceMap
ifaceMap, Map Name (Doc Name)
warningMap) ModSummary
modSummary = do
      x <- {-# SCC processModule #-}
           SDoc
-> (Maybe Interface -> ())
-> Ghc (Maybe Interface)
-> Ghc (Maybe Interface)
forall (m :: Type -> Type) b.
GhcMonad m =>
SDoc -> (b -> ()) -> m b -> m b
withTimingM SDoc
"processModule" (() -> Maybe Interface -> ()
forall a b. a -> b -> a
const ()) (Ghc (Maybe Interface) -> Ghc (Maybe Interface))
-> Ghc (Maybe Interface) -> Ghc (Maybe Interface)
forall a b. (a -> b) -> a -> b
$ do
             Verbosity
-> ModSummary
-> [Flag]
-> IfaceMap
-> InstIfaceMap
-> Map Name (Doc Name)
-> Ghc (Maybe Interface)
processModule Verbosity
verbosity ModSummary
modSummary [Flag]
flags IfaceMap
ifaceMap InstIfaceMap
instIfaceMap Map Name (Doc Name)
warningMap
      return $ case x of
        Just Interface
iface -> ( Interface
ifaceInterface -> [Interface] -> [Interface]
forall a. a -> [a] -> [a]
:[Interface]
ifaces
                      , Module -> Interface -> IfaceMap -> IfaceMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Interface -> Module
ifaceMod Interface
iface) Interface
iface IfaceMap
ifaceMap
                      , Map Name (Doc Name) -> Map Name (Doc Name) -> Map Name (Doc Name)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Interface -> Map Name (Doc Name)
ifaceWarningMap Interface
iface) Map Name (Doc Name)
warningMap)
        Maybe Interface
Nothing    -> ( [Interface]
ifaces
                      , IfaceMap
ifaceMap
                      , Map Name (Doc Name)
warningMap ) -- Boot modules don't generate ifaces.

dropErr :: MaybeErr e a -> Maybe a
dropErr :: forall e a. MaybeErr e a -> Maybe a
dropErr (Succeeded a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
dropErr (Failed e
_) = Maybe a
forall a. Maybe a
Nothing

loadHiFile :: HscEnv -> Outputable.SDoc -> Module -> IO (ModIface, ([ClsInst], [FamInst]))
loadHiFile :: HscEnv -> SDoc -> Module -> IO (ModIface, ([ClsInst], [FamInst]))
loadHiFile HscEnv
hsc_env SDoc
doc Module
theModule = HscEnv
-> IfG (ModIface, ([ClsInst], [FamInst]))
-> IO (ModIface, ([ClsInst], [FamInst]))
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG (ModIface, ([ClsInst], [FamInst]))
 -> IO (ModIface, ([ClsInst], [FamInst])))
-> IfG (ModIface, ([ClsInst], [FamInst]))
-> IO (ModIface, ([ClsInst], [FamInst]))
forall a b. (a -> b) -> a -> b
$ do

  mod_iface <- SDoc -> Module -> IfM () ModIface
forall lcl. SDoc -> Module -> IfM lcl ModIface
loadSysInterface SDoc
doc Module
theModule

  insts <- initIfaceLcl (mi_semantic_module mod_iface) doc (mi_boot mod_iface) $ do

    new_eps_insts     <- mapM tcIfaceInst (mi_insts mod_iface)
    new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts mod_iface)

    pure (new_eps_insts, new_eps_fam_insts)

  pure (mod_iface, insts)

processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> WarningMap -> Ghc (Maybe Interface)
processModule :: Verbosity
-> ModSummary
-> [Flag]
-> IfaceMap
-> InstIfaceMap
-> Map Name (Doc Name)
-> Ghc (Maybe Interface)
processModule Verbosity
verbosity ModSummary
modSummary [Flag]
flags IfaceMap
ifaceMap InstIfaceMap
instIfaceMap Map Name (Doc Name)
warningMap = do
  Verbosity -> Verbosity -> [Char] -> Ghc ()
forall (m :: Type -> Type).
MonadIO m =>
Verbosity -> Verbosity -> [Char] -> m ()
out Verbosity
verbosity Verbosity
verbose ([Char] -> Ghc ()) -> [Char] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Checking module " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Module -> [Char]
moduleString (ModSummary -> Module
ms_mod ModSummary
modSummary) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"..."

  hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
  dflags <- getDynFlags
  let sDocContext = DynFlags -> PprStyle -> SDocContext
DynFlags.initSDocContext DynFlags
dflags PprStyle
Outputable.defaultUserStyle
      doc = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"processModule"
      unit_state = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env

  (mod_iface, insts) <- if Flag_NoCompilation `elem` flags
    then liftIO $ loadHiFile hsc_env doc $ ms_mod modSummary
    else
      let hmi = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
modSummary) of
            Maybe HomeModInfo
Nothing -> [Char] -> HomeModInfo
forall a. HasCallStack => [Char] -> a
error [Char]
"processModule: All modules should be loaded into the HPT by this point"
            Just HomeModInfo
x -> HomeModInfo
x
          cls_insts = InstEnv -> [ClsInst]
instEnvElts (InstEnv -> [ClsInst])
-> (ModDetails -> InstEnv) -> ModDetails -> [ClsInst]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModDetails -> InstEnv
md_insts (ModDetails -> [ClsInst]) -> ModDetails -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> ModDetails
hm_details HomeModInfo
hmi
          fam_insts = ModDetails -> [FamInst]
md_fam_insts (ModDetails -> [FamInst]) -> ModDetails -> [FamInst]
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> ModDetails
hm_details HomeModInfo
hmi

      in pure (hm_iface hmi, (cls_insts, fam_insts))

  !interface <- do
    logger <- getLogger
    {-# SCC createInterface #-}
      withTiming logger "createInterface" (const ()) $
        runIfM (liftIO . fmap dropErr . lookupGlobal_maybe hsc_env) $
          createInterface1 flags unit_state modSummary mod_iface ifaceMap instIfaceMap insts warningMap

  let
    (haddockable, haddocked) =
      ifaceHaddockCoverage interface

    percentage :: Int
    percentage = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Int
haddocked Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100) Int
haddockable

    modString :: String
    modString = Module -> [Char]
moduleString (Interface -> Module
ifaceMod Interface
interface)

    coverageMsg :: String
    coverageMsg =
      [Char] -> Int -> Int -> Int -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
" %3d%% (%3d /%3d) in '%s'" Int
percentage Int
haddocked Int
haddockable [Char]
modString

    header :: Bool
    header = case Interface -> Documentation Name
ifaceDoc Interface
interface of
      Documentation Maybe (MDoc Name)
Nothing Maybe (Doc Name)
_ -> Bool
False
      Documentation Name
_ -> Bool
True

    undocumentedExports :: [String]
    undocumentedExports =
      [ SrcSpan -> HsDecl GhcRn -> [Char]
formatName (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
s) HsDecl GhcRn
n
      | ExportDecl ExportD
          { expDDecl :: forall name. ExportD name -> LHsDecl name
expDDecl = L SrcSpanAnnA
s HsDecl GhcRn
n
          , expDMbDoc :: forall name. ExportD name -> DocForDecl (IdP name)
expDMbDoc = (Documentation Maybe (MDoc (IdP GhcRn))
Nothing Maybe (Doc (IdP GhcRn))
_, FnArgsDoc (IdP GhcRn)
_)
          } <- Interface -> [ExportItem GhcRn]
ifaceExportItems Interface
interface
      ]
        where
          formatName :: SrcSpan -> HsDecl GhcRn -> String
          formatName :: SrcSpan -> HsDecl GhcRn -> [Char]
formatName SrcSpan
loc HsDecl GhcRn
n = [Name] -> [Char]
forall a. Outputable a => [a] -> [Char]
p (OccEnv Name -> HsDecl GhcRn -> [Name]
getMainDeclBinder OccEnv Name
forall a. OccEnv a
emptyOccEnv HsDecl GhcRn
n) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ case SrcSpan
loc of
            RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_ -> [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FastString -> [Char]
unpackFS (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
rss) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
              Int -> [Char]
forall a. Show a => a -> [Char]
show (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rss) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
            SrcSpan
_ -> [Char]
""

          p :: Outputable a => [a] -> String
          p :: forall a. Outputable a => [a] -> [Char]
p [] = [Char]
""
          p (a
x:[a]
_) = let n :: [Char]
n = SDocContext -> a -> [Char]
forall a. Outputable a => SDocContext -> a -> [Char]
pretty SDocContext
sDocContext a
x
                        ms :: [Char]
ms = [Char]
modString [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
                    in if [Char]
ms [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
n
                       then Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Char]
ms) [Char]
n
                       else [Char]
n

  when (OptHide `notElem` ifaceOptions interface) $ do
    out verbosity normal coverageMsg
    when (Flag_NoPrintMissingDocs `notElem` flags
          && not (null undocumentedExports && header)) $ do
      out verbosity normal "  Missing documentation for:"
      unless header $ out verbosity normal "    Module header"
      mapM_ (out verbosity normal . ("    " ++)) undocumentedExports

  return (Just interface)


-- | Create a single interface from a single module in one-shot mode.
createOneShotIface
    :: Verbosity
    -- ^ Verbosity requested by the caller
    -> [Flag]
    -- ^ Command line flags which Hadddock was invoked with
    -> InstIfaceMap
    -- ^ Map from module to corresponding installed interface file
    -> String
    -- ^ Name of the module
    -> Ghc [Interface]
    -- ^ Resulting interfaces
createOneShotIface :: Verbosity -> [Flag] -> InstIfaceMap -> [Char] -> Ghc [Interface]
createOneShotIface Verbosity
verbosity [Flag]
flags InstIfaceMap
instIfaceMap [Char]
moduleNameStr = do

  let moduleNm :: ModuleName
moduleNm = [Char] -> ModuleName
mkModuleName [Char]
moduleNameStr
      doc :: SDoc
doc = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"createOneShotIface"

  Verbosity -> Verbosity -> [Char] -> Ghc ()
forall (m :: Type -> Type).
MonadIO m =>
Verbosity -> Verbosity -> [Char] -> m ()
out Verbosity
verbosity Verbosity
verbose ([Char] -> Ghc ()) -> [Char] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Checking interface " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
moduleNameStr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"..."

  -- Turn on GHC's one-shot mode
  dflags <- (\DynFlags
df -> DynFlags
df{ ghcMode = OneShot }) (DynFlags -> DynFlags) -> Ghc DynFlags -> Ghc DynFlags
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghc DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  modifySession $ hscSetFlags dflags
  hsc_env <- getSession

  (iface, insts) <- liftIO $ loadHiFile hsc_env doc $ mkMainModule_ moduleNm

  -- Update the DynFlags with the extensions from the source file (as stored in the interface file)
  -- This is instead of ms_hspp_opts from ModSummary, which is not available in one-shot mode.
  let dflags' = case ModIface -> Maybe Docs
forall (phase :: ModIfacePhase). ModIface_ phase -> Maybe Docs
mi_docs ModIface
iface of
                  Just Docs
docs -> DynFlags -> DynFlags
setExtensions (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
setLanguage DynFlags
dflags
                    where
                      setLanguage :: DynFlags -> DynFlags
setLanguage DynFlags
df = DynFlags -> Maybe Language -> DynFlags
lang_set DynFlags
df (Docs -> Maybe Language
docs_language Docs
docs)
                      setExtensions :: DynFlags -> DynFlags
setExtensions DynFlags
df = (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' DynFlags -> Extension -> DynFlags
xopt_set DynFlags
df ([Extension] -> DynFlags) -> [Extension] -> DynFlags
forall a b. (a -> b) -> a -> b
$ EnumSet Extension -> [Extension]
forall a. Enum a => EnumSet a -> [a]
EnumSet.toList (Docs -> EnumSet Extension
docs_extensions Docs
docs)
                  Maybe Docs
Nothing -> DynFlags
dflags

  -- We should find the module here, otherwise there would have been an error earlier.
  res <- liftIO $ findImportedModule hsc_env moduleNm NoPkgQual
  let hieFilePath = case FindResult
res of
                      Found ModLocation
ml Module
_ -> ModLocation -> [Char]
ml_hie_file ModLocation
ml
                      FindResult
_ -> [Char] -> [Char]
forall a. [Char] -> a
throwE [Char]
"createOneShotIface: module not found"
  let inst_warning_map = [Map Name (Doc Name)] -> Map Name (Doc Name)
forall (f :: Type -> Type) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map Name (Doc Name)] -> Map Name (Doc Name))
-> [Map Name (Doc Name)] -> Map Name (Doc Name)
forall a b. (a -> b) -> a -> b
$ (InstalledInterface -> Map Name (Doc Name))
-> [InstalledInterface] -> [Map Name (Doc Name)]
forall a b. (a -> b) -> [a] -> [b]
map InstalledInterface -> Map Name (Doc Name)
instWarningMap (InstIfaceMap -> [InstalledInterface]
forall k a. Map k a -> [a]
Map.elems InstIfaceMap
instIfaceMap)
  !interface <- do
    logger <- getLogger
    {-# SCC createInterface #-}
      withTiming logger "createInterface" (const ()) $
        runIfM (liftIO . fmap dropErr . lookupGlobal_maybe hsc_env) $
          createInterface1' flags (hsc_units hsc_env) dflags' hieFilePath iface mempty instIfaceMap insts inst_warning_map

  pure [interface]

--------------------------------------------------------------------------------
-- * Building of cross-linking environment
--------------------------------------------------------------------------------


-- | Build a mapping which for each original name, points to the "best"
-- place to link to in the documentation.  For the definition of
-- "best", we use "the module nearest the bottom of the dependency
-- graph which exports this name", not including hidden modules.  When
-- there are multiple choices, we pick a random one.
--
-- The interfaces are passed in in topologically sorted order, but we start
-- by reversing the list so we can do a foldl.
buildHomeLinks :: [Interface] -> LinkEnv
buildHomeLinks :: [Interface] -> LinkEnv
buildHomeLinks [Interface]
ifaces = (LinkEnv -> Interface -> LinkEnv)
-> LinkEnv -> [Interface] -> LinkEnv
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' LinkEnv -> Interface -> LinkEnv
upd LinkEnv
forall k a. Map k a
Map.empty ([Interface] -> [Interface]
forall a. [a] -> [a]
reverse [Interface]
ifaces)
  where
    upd :: LinkEnv -> Interface -> LinkEnv
upd LinkEnv
old_env Interface
iface
      | DocOption
OptHide DocOption -> [DocOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` Interface -> [DocOption]
ifaceOptions Interface
iface =
          LinkEnv
old_env
      | DocOption
OptNotHome DocOption -> [DocOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` Interface -> [DocOption]
ifaceOptions Interface
iface =
          (LinkEnv -> Name -> LinkEnv) -> LinkEnv -> [Name] -> LinkEnv
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' LinkEnv -> Name -> LinkEnv
forall {k}. Ord k => Map k Module -> k -> Map k Module
keep_old LinkEnv
old_env [Name]
exported_names
      | Bool
otherwise =
          (LinkEnv -> Name -> LinkEnv) -> LinkEnv -> [Name] -> LinkEnv
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' LinkEnv -> Name -> LinkEnv
forall {k}. Ord k => Map k Module -> k -> Map k Module
keep_new LinkEnv
old_env [Name]
exported_names
      where
        exported_names :: [Name]
exported_names = Interface -> [Name]
ifaceVisibleExports Interface
iface [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (ClsInst -> Name) -> [ClsInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> Name
forall a. NamedThing a => a -> Name
getName (Interface -> [ClsInst]
ifaceInstances Interface
iface)
        mdl :: Module
mdl            = Interface -> Module
ifaceMod Interface
iface
        keep_old :: Map k Module -> k -> Map k Module
keep_old Map k Module
env k
n = (Module -> Module -> Module)
-> k -> Module -> Map k Module -> Map k Module
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\Module
_ Module
old -> Module
old) k
n Module
mdl Map k Module
env
        keep_new :: Map k Module -> k -> Map k Module
keep_new Map k Module
env k
n = k -> Module -> Map k Module -> Map k Module
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
n Module
mdl Map k Module
env