{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- 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 Haddock.GhcUtils
import Haddock.InterfaceFile
import Haddock.Interface.Create
import Haddock.Interface.AttachInstances
import Haddock.Interface.Rename
import Haddock.Options hiding (verbosity)
import Haddock.Types
import Haddock.Utils

import Control.Monad
import Control.Monad.IO.Class ( liftIO )
import Control.Exception (evaluate)
import Data.List (foldl', isPrefixOf, nub)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Text.Printf

import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
import Digraph
import DynFlags hiding (verbosity)
import GHC hiding (verbosity)
import HscTypes
import FastString (unpackFS)
import TcRnTypes (tcg_rdr_env)
import Name (nameIsFromExternalPackage, nameOccName)
import OccName (isTcOcc)
import RdrName (unQualOK, gre_name, globalRdrEnvElts)
import ErrUtils (withTimingD)
import DynamicLoading (initializePlugins)

#if defined(mingw32_HOST_OS)
import System.IO
import GHC.IO.Encoding.CodePage (mkLocaleEncoding)
import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
#endif

-- | 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
-> [String]
-> [Flag]
-> [InterfaceFile]
-> Ghc ([Interface], LinkEnv)
processModules Verbosity
verbosity [String]
modules [Flag]
flags [InterfaceFile]
extIfaces = do
#if defined(mingw32_HOST_OS)
  -- Avoid internal error: <stderr>: hPutChar: invalid argument (invalid character)' non UTF-8 Windows
  liftIO $ hSetEncoding stdout $ mkLocaleEncoding TransliterateCodingFailure
  liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure
#endif

  Verbosity -> Verbosity -> String -> Ghc ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> String -> m ()
out Verbosity
verbosity Verbosity
verbose String
"Creating interfaces..."
  let instIfaceMap :: Map Module InstalledInterface
instIfaceMap =  [(Module, InstalledInterface)] -> Map Module InstalledInterface
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 ]
  ([Interface]
interfaces, ModuleSet
ms) <- Verbosity
-> [String]
-> [Flag]
-> Map Module InstalledInterface
-> Ghc ([Interface], ModuleSet)
createIfaces Verbosity
verbosity [String]
modules [Flag]
flags Map Module InstalledInterface
instIfaceMap

  let exportedNames :: Set Name
exportedNames =
        [Set Name] -> Set Name
forall (f :: * -> *) 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Interface -> [DocOption]
ifaceOptions Interface
i) [Interface]
interfaces
      mods :: Set Module
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
  Verbosity -> Verbosity -> String -> Ghc ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> String -> m ()
out Verbosity
verbosity Verbosity
verbose String
"Attaching instances..."
  [Interface]
interfaces' <- {-# SCC attachInstances #-}
                 SDoc -> ([Interface] -> ()) -> Ghc [Interface] -> Ghc [Interface]
forall (m :: * -> *) a.
(MonadIO m, HasDynFlags m) =>
SDoc -> (a -> ()) -> m a -> m a
withTimingD SDoc
"attachInstances" (() -> [Interface] -> ()
forall a b. a -> b -> a
const ()) (Ghc [Interface] -> Ghc [Interface])
-> Ghc [Interface] -> Ghc [Interface]
forall a b. (a -> b) -> a -> b
$ do
                   ExportInfo
-> [Interface]
-> Map Module InstalledInterface
-> ModuleSet
-> Ghc [Interface]
attachInstances (Set Name
exportedNames, Set Module
mods) [Interface]
interfaces Map Module InstalledInterface
instIfaceMap ModuleSet
ms

  Verbosity -> Verbosity -> String -> Ghc ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> String -> m ()
out Verbosity
verbosity Verbosity
verbose String
"Building cross-linking environment..."
  -- Combine the link envs of the external packages into one
  let extLinks :: LinkEnv
extLinks  = [LinkEnv] -> LinkEnv
forall (f :: * -> *) 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 :: LinkEnv
homeLinks = [Interface] -> LinkEnv
buildHomeLinks [Interface]
interfaces' -- Build the environment for the home
                                             -- package
      links :: LinkEnv
links     = LinkEnv
homeLinks LinkEnv -> LinkEnv -> LinkEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` LinkEnv
extLinks

  Verbosity -> Verbosity -> String -> Ghc ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> String -> m ()
out Verbosity
verbosity Verbosity
verbose String
"Renaming interfaces..."
  let warnings :: Bool
warnings = Flag
Flag_NoWarnings Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Flag]
flags
  DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let ([Interface]
interfaces'', [String]
msgs) =
         ErrMsgM [Interface] -> ([Interface], [String])
forall a. ErrMsgM a -> (a, [String])
runWriter (ErrMsgM [Interface] -> ([Interface], [String]))
-> ErrMsgM [Interface] -> ([Interface], [String])
forall a b. (a -> b) -> a -> b
$ (Interface -> ErrMsgM Interface)
-> [Interface] -> ErrMsgM [Interface]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags
-> [String] -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
renameInterface DynFlags
dflags ([Flag] -> [String]
ignoredSymbols [Flag]
flags) LinkEnv
links Bool
warnings) [Interface]
interfaces'
  IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
msgs

  ([Interface], LinkEnv) -> Ghc ([Interface], LinkEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Interface]
interfaces'', LinkEnv
homeLinks)


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


createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
createIfaces :: Verbosity
-> [String]
-> [Flag]
-> Map Module InstalledInterface
-> Ghc ([Interface], ModuleSet)
createIfaces Verbosity
verbosity [String]
modules [Flag]
flags Map Module InstalledInterface
instIfaceMap = do
  -- Ask GHC to tell us what the module graph is
  [Target]
targets <- (String -> Ghc Target) -> [String] -> Ghc [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
filePath -> String -> Maybe Phase -> Ghc Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe Phase -> m Target
guessTarget String
filePath Maybe Phase
forall a. Maybe a
Nothing) [String]
modules
  [Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target]
targets
  ModuleGraph
modGraph <- [ModuleName] -> Bool -> Ghc ModuleGraph
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [] Bool
False

  -- Visit modules in that order
  let sortedMods :: [ModSummary]
sortedMods = [SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
flattenSCCs ([SCC ModSummary] -> [ModSummary])
-> [SCC ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$ Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
topSortModuleGraph Bool
False ModuleGraph
modGraph Maybe ModuleName
forall a. Maybe a
Nothing
  Verbosity -> Verbosity -> String -> Ghc ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> String -> m ()
out Verbosity
verbosity Verbosity
normal String
"Haddock coverage:"
  ([Interface]
ifaces, Map Module Interface
_, !ModuleSet
ms) <- (([Interface], Map Module Interface, ModuleSet)
 -> ModSummary
 -> Ghc ([Interface], Map Module Interface, ModuleSet))
-> ([Interface], Map Module Interface, ModuleSet)
-> [ModSummary]
-> Ghc ([Interface], Map Module Interface, ModuleSet)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([Interface], Map Module Interface, ModuleSet)
-> ModSummary -> Ghc ([Interface], Map Module Interface, ModuleSet)
f ([], Map Module Interface
forall k a. Map k a
Map.empty, ModuleSet
emptyModuleSet) [ModSummary]
sortedMods
  ([Interface], ModuleSet) -> Ghc ([Interface], ModuleSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Interface] -> [Interface]
forall a. [a] -> [a]
reverse [Interface]
ifaces, ModuleSet
ms)
  where
    f :: ([Interface], Map Module Interface, ModuleSet)
-> ModSummary -> Ghc ([Interface], Map Module Interface, ModuleSet)
f ([Interface]
ifaces, Map Module Interface
ifaceMap, !ModuleSet
ms) ModSummary
modSummary = do
      Maybe (Interface, ModuleSet)
x <- {-# SCC processModule #-}
           SDoc
-> (Maybe (Interface, ModuleSet) -> ())
-> Ghc (Maybe (Interface, ModuleSet))
-> Ghc (Maybe (Interface, ModuleSet))
forall (m :: * -> *) a.
(MonadIO m, HasDynFlags m) =>
SDoc -> (a -> ()) -> m a -> m a
withTimingD SDoc
"processModule" (() -> Maybe (Interface, ModuleSet) -> ()
forall a b. a -> b -> a
const ()) (Ghc (Maybe (Interface, ModuleSet))
 -> Ghc (Maybe (Interface, ModuleSet)))
-> Ghc (Maybe (Interface, ModuleSet))
-> Ghc (Maybe (Interface, ModuleSet))
forall a b. (a -> b) -> a -> b
$ do
             Verbosity
-> ModSummary
-> [Flag]
-> Map Module Interface
-> Map Module InstalledInterface
-> Ghc (Maybe (Interface, ModuleSet))
processModule Verbosity
verbosity ModSummary
modSummary [Flag]
flags Map Module Interface
ifaceMap Map Module InstalledInterface
instIfaceMap
      ([Interface], Map Module Interface, ModuleSet)
-> Ghc ([Interface], Map Module Interface, ModuleSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (([Interface], Map Module Interface, ModuleSet)
 -> Ghc ([Interface], Map Module Interface, ModuleSet))
-> ([Interface], Map Module Interface, ModuleSet)
-> Ghc ([Interface], Map Module Interface, ModuleSet)
forall a b. (a -> b) -> a -> b
$ case Maybe (Interface, ModuleSet)
x of
        Just (Interface
iface, ModuleSet
ms') -> ( Interface
ifaceInterface -> [Interface] -> [Interface]
forall a. a -> [a] -> [a]
:[Interface]
ifaces
                             , Module -> Interface -> Map Module Interface -> Map Module Interface
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Interface -> Module
ifaceMod Interface
iface) Interface
iface Map Module Interface
ifaceMap
                             , ModuleSet -> ModuleSet -> ModuleSet
unionModuleSet ModuleSet
ms ModuleSet
ms' )
        Maybe (Interface, ModuleSet)
Nothing           -> ( [Interface]
ifaces
                             , Map Module Interface
ifaceMap
                             , ModuleSet
ms ) -- Boot modules don't generate ifaces.


processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet))
processModule :: Verbosity
-> ModSummary
-> [Flag]
-> Map Module Interface
-> Map Module InstalledInterface
-> Ghc (Maybe (Interface, ModuleSet))
processModule Verbosity
verbosity ModSummary
modsum [Flag]
flags Map Module Interface
modMap Map Module InstalledInterface
instIfaceMap = do
  Verbosity -> Verbosity -> String -> Ghc ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> String -> m ()
out Verbosity
verbosity Verbosity
verbose (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Checking module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
moduleString (ModSummary -> Module
ms_mod ModSummary
modsum) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."

  -- Since GHC 8.6, plugins are initialized on a per module basis
  HscEnv
hsc_env' <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  DynFlags
dynflags' <- IO DynFlags -> Ghc DynFlags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> DynFlags -> IO DynFlags
initializePlugins HscEnv
hsc_env' (ModSummary -> DynFlags
GHC.ms_hspp_opts ModSummary
modsum))
  let modsum' :: ModSummary
modsum' = ModSummary
modsum { ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dynflags' }

  TypecheckedModule
tm <- {-# SCC "parse/typecheck/load" #-} TypecheckedModule -> Ghc TypecheckedModule
forall mod (m :: * -> *).
(TypecheckedMod mod, GhcMonad m) =>
mod -> m mod
loadModule (TypecheckedModule -> Ghc TypecheckedModule)
-> Ghc TypecheckedModule -> Ghc TypecheckedModule
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParsedModule -> Ghc TypecheckedModule
forall (m :: * -> *).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
typecheckModule (ParsedModule -> Ghc TypecheckedModule)
-> Ghc ParsedModule -> Ghc TypecheckedModule
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModSummary -> Ghc ParsedModule
forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
parseModule ModSummary
modsum'

  if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ModSummary -> Bool
isBootSummary ModSummary
modsum then do
    Verbosity -> Verbosity -> String -> Ghc ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> String -> m ()
out Verbosity
verbosity Verbosity
verbose String
"Creating interface..."
    (Interface
interface, [String]
msgs) <- {-# SCC createIterface #-}
                        SDoc
-> ((Interface, [String]) -> ())
-> Ghc (Interface, [String])
-> Ghc (Interface, [String])
forall (m :: * -> *) a.
(MonadIO m, HasDynFlags m) =>
SDoc -> (a -> ()) -> m a -> m a
withTimingD SDoc
"createInterface" (() -> (Interface, [String]) -> ()
forall a b. a -> b -> a
const ()) (Ghc (Interface, [String]) -> Ghc (Interface, [String]))
-> Ghc (Interface, [String]) -> Ghc (Interface, [String])
forall a b. (a -> b) -> a -> b
$ do
                          ErrMsgGhc Interface -> Ghc (Interface, [String])
forall a. ErrMsgGhc a -> Ghc (a, [String])
runWriterGhc (ErrMsgGhc Interface -> Ghc (Interface, [String]))
-> ErrMsgGhc Interface -> Ghc (Interface, [String])
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
TypecheckedModule
-> [Flag]
-> Map Module Interface
-> Map Module InstalledInterface
-> ErrMsgGhc Interface
TypecheckedModule
-> [Flag]
-> Map Module Interface
-> Map Module InstalledInterface
-> ErrMsgGhc Interface
createInterface TypecheckedModule
tm [Flag]
flags Map Module Interface
modMap Map Module InstalledInterface
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.
    HscEnv
hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    let new_rdr_env :: GlobalRdrEnv
new_rdr_env = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env (TcGblEnv -> GlobalRdrEnv)
-> (TypecheckedModule -> TcGblEnv)
-> TypecheckedModule
-> GlobalRdrEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a, b) -> a
fst ((TcGblEnv, ModDetails) -> TcGblEnv)
-> (TypecheckedModule -> (TcGblEnv, ModDetails))
-> TypecheckedModule
-> TcGblEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypecheckedModule -> (TcGblEnv, ModDetails)
GHC.tm_internals_ (TypecheckedModule -> GlobalRdrEnv)
-> TypecheckedModule -> GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ TypecheckedModule
tm
        this_pkg :: UnitId
this_pkg = DynFlags -> UnitId
thisPackage (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
        !mods :: ModuleSet
mods = [Module] -> ModuleSet
mkModuleSet [ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name
                            | GlobalRdrElt
gre <- GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts GlobalRdrEnv
new_rdr_env
                            , let name :: Name
name = GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre
                            , UnitId -> Name -> Bool
nameIsFromExternalPackage UnitId
this_pkg Name
name
                            , OccName -> Bool
isTcOcc (Name -> OccName
nameOccName Name
name)   -- Types and classes only
                            , GlobalRdrElt -> Bool
unQualOK GlobalRdrElt
gre ]               -- In scope unqualified

    IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
msgs)
    DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let (Int
haddockable, Int
haddocked) = Interface -> (Int, Int)
ifaceHaddockCoverage Interface
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 -> String
moduleString (Interface -> Module
ifaceMod Interface
interface)
        coverageMsg :: String
coverageMsg = String -> Int -> Int -> Int -> String -> String
forall r. PrintfType r => String -> r
printf String
" %3d%% (%3d /%3d) in '%s'" Int
percentage Int
haddocked Int
haddockable String
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 -> String
formatName SrcSpan
s HsDecl GhcRn
n | ExportDecl { expItemDecl :: forall name. ExportItem name -> LHsDecl name
expItemDecl = L SrcSpan
s HsDecl GhcRn
n
                                                            , expItemMbDoc :: forall name. ExportItem name -> DocForDecl (IdP name)
expItemMbDoc = (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 -> String
formatName SrcSpan
loc HsDecl GhcRn
n = [Name] -> String
forall a. Outputable a => [a] -> String
p (HsDecl GhcRn -> [IdP GhcRn]
forall (p :: Pass). HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder HsDecl GhcRn
n) String -> String -> String
forall a. [a] -> [a] -> [a]
++ case SrcSpan
loc of
              RealSrcSpan RealSrcSpan
rss -> String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FastString -> String
unpackFS (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
rss) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rss) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
              SrcSpan
_ -> String
""

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

    Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DocOption
OptHide DocOption -> [DocOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Interface -> [DocOption]
ifaceOptions Interface
interface) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
      Verbosity -> Verbosity -> String -> Ghc ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> String -> m ()
out Verbosity
verbosity Verbosity
normal String
coverageMsg
      Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_NoPrintMissingDocs Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Flag]
flags
            Bool -> Bool -> Bool
&& Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
undocumentedExports Bool -> Bool -> Bool
&& Bool
header)) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
        Verbosity -> Verbosity -> String -> Ghc ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> String -> m ()
out Verbosity
verbosity Verbosity
normal String
"  Missing documentation for:"
        Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
header (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> Verbosity -> String -> Ghc ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> String -> m ()
out Verbosity
verbosity Verbosity
normal String
"    Module header"
        (String -> Ghc ()) -> [String] -> Ghc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Verbosity -> Verbosity -> String -> Ghc ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> String -> m ()
out Verbosity
verbosity Verbosity
normal (String -> Ghc ()) -> (String -> String) -> String -> Ghc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++)) [String]
undocumentedExports
    Interface
interface' <- IO Interface -> Ghc Interface
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Interface -> Ghc Interface) -> IO Interface -> Ghc Interface
forall a b. (a -> b) -> a -> b
$ Interface -> IO Interface
forall a. a -> IO a
evaluate Interface
interface
    Maybe (Interface, ModuleSet) -> Ghc (Maybe (Interface, ModuleSet))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Interface, ModuleSet) -> Maybe (Interface, ModuleSet)
forall a. a -> Maybe a
Just (Interface
interface', ModuleSet
mods))
  else
    Maybe (Interface, ModuleSet) -> Ghc (Maybe (Interface, ModuleSet))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Interface, ModuleSet)
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
-- * 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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Interface -> [DocOption]
ifaceOptions Interface
iface = LinkEnv
old_env
      | DocOption
OptNotHome DocOption -> [DocOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Interface -> [DocOption]
ifaceOptions Interface
iface =
        (LinkEnv -> Name -> LinkEnv) -> LinkEnv -> [Name] -> LinkEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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