module Haddock.Interface (
createInterfaces
) where
import Haddock.Interface.Create
import Haddock.Interface.AttachInstances
import Haddock.Interface.Rename
import Haddock.Types
import Haddock.Options
import Haddock.GhcUtils
import Haddock.Utils
import Haddock.InterfaceFile
import qualified Data.Map as Map
import Data.List
import Data.Maybe
import Control.Monad
import Control.Exception ( evaluate )
import Distribution.Verbosity
import GHC hiding (verbosity, flags)
import Digraph
import HscTypes
createInterfaces
:: Verbosity
-> [String]
-> [Flag]
-> [InterfaceFile]
-> Ghc ([Interface], LinkEnv)
createInterfaces verbosity modules flags extIfaces = do
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
, iface <- ifInstalledIfaces ext ]
out verbosity verbose "Creating interfaces..."
interfaces <- createInterfaces' verbosity modules flags instIfaceMap
out verbosity verbose "Building link environment..."
let extLinks = Map.unions (map ifLinkEnv extIfaces)
homeLinks = buildHomeLinks interfaces
links = homeLinks `Map.union` extLinks
out verbosity verbose "Attaching instances..."
interfaces' <- attachInstances interfaces instIfaceMap
out verbosity verbose "Renaming interfaces..."
let warnings = Flag_NoWarnings `notElem` flags
let (interfaces'', msgs) =
runWriter $ mapM (renameInterface links warnings) interfaces'
liftIO $ mapM_ putStrLn msgs
return (interfaces'', homeLinks)
createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
createInterfaces' verbosity modules flags instIfaceMap = do
targets <- mapM (\f -> guessTarget f Nothing) modules
setTargets targets
modgraph <- depanal [] False
modgraph' <- if needsTemplateHaskell modgraph
then do
dflags <- getSessionDynFlags
_ <- setSessionDynFlags dflags { hscTarget = defaultObjectTarget }
let addHscAsm m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = defaultObjectTarget } }
return (map addHscAsm modgraph)
else return modgraph
let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing
(ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
x <- processModule verbosity modsum flags modMap instIfaceMap
case x of
Just interface ->
return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)
Nothing -> return (ifaces, modMap)
) ([], Map.empty) orderedMods
return (reverse ifaces)
processModule :: Verbosity -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface)
processModule verbosity modsum flags modMap instIfaceMap = do
out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum
if not $ isBootSummary modsum
then do
let filename = msHsFilePath modsum
let dynflags = ms_hspp_opts modsum
let Just renamed_src = renamedSource tc_mod
let ghcMod = mkGhcModule (ms_mod modsum,
filename,
(parsedSource tc_mod,
renamed_src,
typecheckedSource tc_mod,
moduleInfo tc_mod))
dynflags
out verbosity verbose "Creating interface..."
(interface, msg) <- runWriterGhc $ createInterface ghcMod flags modMap instIfaceMap
liftIO $ mapM_ putStrLn msg
interface' <- liftIO $ evaluate interface
return (Just interface')
else
return Nothing
type CheckedMod = (Module, FilePath, FullyCheckedMod)
type FullyCheckedMod = (ParsedSource,
RenamedSource,
TypecheckedSource,
ModuleInfo)
mkGhcModule :: CheckedMod -> DynFlags -> GhcModule
mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule {
ghcModule = mdl,
ghcFilename = file,
ghcMbDocOpts = mbOpts,
ghcMbDocHdr = mbDocHdr,
ghcGroup = group_,
ghcMbExports = mbExports,
ghcExportedNames = modInfoExports modInfo,
ghcDefinedNames = map getName $ modInfoTyThings modInfo,
ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo,
ghcInstances = modInfoInstances modInfo
}
where
mbOpts = haddockOptions dynflags
(group_, _, mbExports, mbDocHdr) = renamed
(_, renamed, _, modInfo) = checkedMod
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
mdl = ifaceMod iface
keep_old env n = Map.insertWith (\_ old -> old) n mdl env
keep_new env n = Map.insert n mdl env