{-# LANGUAGE CPP, OverloadedStrings #-}
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 Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Verbosity
import System.Directory
import System.FilePath
import Text.Printf
import Digraph
import DynFlags hiding (verbosity)
import Exception
import GHC hiding (verbosity)
import HscTypes
import FastString (unpackFS)
import MonadUtils (liftIO)
import TcRnTypes (tcg_rdr_env)
import RdrName (plusGlobalRdrEnv)
import ErrUtils (withTiming)
#if defined(mingw32_HOST_OS)
import System.IO
import GHC.IO.Encoding.CodePage (mkLocaleEncoding)
import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
#endif
processModules
:: Verbosity
-> [String]
-> [Flag]
-> [InterfaceFile]
-> Ghc ([Interface], LinkEnv)
processModules verbosity modules flags extIfaces = do
#if defined(mingw32_HOST_OS)
liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure
#endif
out verbosity verbose "Creating interfaces..."
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
, iface <- ifInstalledIfaces ext ]
interfaces <- createIfaces0 verbosity modules flags instIfaceMap
let exportedNames =
Set.unions $ map (Set.fromList . ifaceExports) $
filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces
mods = Set.fromList $ map ifaceMod interfaces
out verbosity verbose "Attaching instances..."
interfaces' <- {-# SCC attachInstances #-}
withTiming getDynFlags "attachInstances" (const ()) $ do
attachInstances (exportedNames, mods) interfaces instIfaceMap
out verbosity verbose "Building cross-linking environment..."
let extLinks = Map.unions (map ifLinkEnv extIfaces)
homeLinks = buildHomeLinks interfaces'
links = homeLinks `Map.union` extLinks
out verbosity verbose "Renaming interfaces..."
let warnings = Flag_NoWarnings `notElem` flags
dflags <- getDynFlags
let (interfaces'', msgs) =
runWriter $ mapM (renameInterface dflags links warnings) interfaces'
liftIO $ mapM_ putStrLn msgs
return (interfaces'', homeLinks)
createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
createIfaces0 verbosity modules flags instIfaceMap =
(if useTempDir then withTempOutputDir else id) $ do
modGraph <- depAnalysis
createIfaces verbosity flags instIfaceMap modGraph
where
useTempDir :: Bool
useTempDir = Flag_NoTmpCompDir `notElem` flags
withTempOutputDir :: Ghc a -> Ghc a
withTempOutputDir action = do
tmp <- liftIO getTemporaryDirectory
x <- liftIO getProcessID
let dir = tmp </> ".haddock-" ++ show x
modifySessionDynFlags (setOutputDir dir)
withTempDir dir action
depAnalysis :: Ghc ModuleGraph
depAnalysis = do
targets <- mapM (\f -> guessTarget f Nothing) modules
setTargets targets
depanal [] False
createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
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)
where
f (ifaces, ifaceMap) 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)
processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
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
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, msg) <- {-# SCC createIterface #-}
withTiming getDynFlags "createInterface" (const ()) $ do
runWriterGhc $ createInterface tm flags modMap instIfaceMap
liftIO $ mapM_ putStrLn msg
dflags <- getDynFlags
let (haddockable, haddocked) = ifaceHaddockCoverage interface
percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int
modString = moduleString (ifaceMod interface)
coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
header = case ifaceDoc interface of
Documentation Nothing _ -> False
_ -> True
undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n
, expItemMbDoc = (Documentation Nothing _, _)
} <- ifaceExportItems interface ]
where
formatName :: SrcSpan -> HsDecl GhcRn -> String
formatName loc n = p (getMainDeclBinder n) ++ case loc of
RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"
_ -> ""
p [] = ""
p (x:_) = let n = pretty dflags x
ms = modString ++ "."
in if ms `isPrefixOf` n
then drop (length ms) n
else 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
interface' <- liftIO $ evaluate interface
return (Just interface')
else
return Nothing
buildHomeLinks :: [Interface] -> LinkEnv
buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
where
upd old_env iface
| OptHide `elem` ifaceOptions iface = old_env
| OptNotHome `elem` ifaceOptions iface =
foldl' keep_old old_env exported_names
| otherwise = foldl' keep_new old_env exported_names
where
exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface)
mdl = ifaceMod iface
keep_old env n = Map.insertWith (\_ old -> old) n mdl env
keep_new env n = Map.insert n mdl env
withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a
withTempDir dir = gbracket_ (liftIO $ createDirectory dir)
(liftIO $ removeDirectoryRecursive dir)