-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface
-- Copyright : (c) Simon Marlow 2003-2006,
-- David Waern 2006-2009
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
--
-- Here we build the actual module interfaces. By interface we mean the
-- information that is used to render a Haddock page for a module. Parts of
-- this information are also stored in the .haddock files.
-----------------------------------------------------------------------------
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
-- | Turn a topologically sorted list of module names/filenames into interfaces. Also
-- return the home link environment created in the process.
#if __GLASGOW_HASKELL__ >= 609
createInterfaces :: Verbosity -> [String] -> [Flag] -> [InterfaceFile]
-> Ghc ([Interface], LinkEnv)
createInterfaces verbosity modules flags extIfaces = do
-- part 1, create interfaces
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
, iface <- ifInstalledIfaces ext ]
out verbosity verbose "Creating interfaces..."
interfaces <- createInterfaces' verbosity modules flags instIfaceMap
#else
createInterfaces :: Verbosity -> Session -> [String] -> [Flag]
-> [InterfaceFile] -> IO ([Interface], LinkEnv)
createInterfaces verbosity session modules flags extIfaces = do
-- part 1, create interfaces
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
, iface <- ifInstalledIfaces ext ]
out verbosity verbose "Creating interfaces..."
interfaces <- createInterfaces' verbosity session modules flags instIfaceMap
#endif
-- part 2, build link environment
out verbosity verbose "Building link environment..."
-- combine the link envs of the external packages into one
let extLinks = Map.unions (map ifLinkEnv extIfaces)
homeLinks = buildHomeLinks interfaces -- build the environment for the home
-- package
links = homeLinks `Map.union` extLinks
allNames = Map.keys links
-- part 3, attach instances
out verbosity verbose "Attaching instances..."
let interfaces' = attachInstances interfaces allNames
-- part 4, rename interfaces
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)
#if __GLASGOW_HASKELL__ >= 609
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
#if (__GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ >= 2) || __GLASGOW_HASKELL__ >= 611
-- If template haskell is used by the package, we can not use
-- HscNothing as target since we might need to run code generated from
-- one or more of the modules during typechecking.
#if __GLASGOW_HASKELL__ < 611
let needsTemplateHaskell = any (dopt Opt_TemplateHaskell . ms_hspp_opts)
#endif
modgraph' <- if needsTemplateHaskell modgraph
then do
dflags <- getSessionDynFlags
_ <- setSessionDynFlags dflags { hscTarget = HscAsm }
-- we need to set HscAsm on all the ModSummaries as well
let addHscAsm m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = HscAsm } }
return (map addHscAsm modgraph)
else return modgraph
#else
let modgraph' = modgraph
#endif
let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing
(ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
x <- processModule verbosity modsum flags modMap instIfaceMap
#else
createInterfaces' :: Verbosity -> Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface]
createInterfaces' verbosity session modules flags instIfaceMap = do
targets <- mapM (\f -> guessTarget f Nothing) modules
setTargets session targets
mbGraph <- depanal session [] False
modgraph <- case mbGraph of
Just graph -> return graph
Nothing -> throwE "Failed to create dependency graph"
let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
(ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
x <- processModule verbosity session modsum flags modMap instIfaceMap
#endif
case x of
Just interface ->
return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)
Nothing -> return (ifaces, modMap)
) ([], Map.empty) orderedMods
return (reverse ifaces)
{- liftIO $ do
putStrLn . ppModInfo $ ifaceInfo interface
putStrLn . show $ fmap pretty (ifaceDoc interface)
print (ifaceOptions interface)
mapM (putStrLn . pretty . fst) (Map.elems . ifaceDeclMap $ interface)
mapM (putStrLn . show . fmap pretty . snd) (Map.elems . ifaceDeclMap $ interface)
mapM (putStrLn . ppExportItem) (ifaceExportItems interface)
mapM (putStrLn . pretty) (ifaceLocals interface)
mapM (putStrLn . pretty) (ifaceExports interface)
mapM (putStrLn . pretty) (ifaceVisibleExports interface)
mapM (putStrLn . pretty) (ifaceInstances interface)
mapM (\(a,b) -> putStrLn $ pretty a ++ pretty b) (Map.toList $ ifaceSubMap interface)
mapM (putStrLn . pretty) (ifaceInstances interface)-}
{-
ppInsts = concatMap ppInst
ppInst (a,b,c) = concatMap pretty a ++ pretty b ++ concatMap pretty c
ppExportItem (ExportDecl decl (Just doc) insts) = pretty decl ++ pretty doc ++ ppInsts insts
ppExportItem (ExportDecl decl Nothing insts) = pretty decl ++ ppInsts insts
ppExportItem (ExportNoDecl name name2 names) = pretty name ++ pretty name2 ++ pretty names
ppExportItem (ExportGroup level id doc) = show level ++ show id ++ pretty doc
ppExportItem (ExportDoc doc) = pretty doc
ppExportItem (ExportModule mod) = pretty mod
ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++ show d
-}
#if __GLASGOW_HASKELL__ >= 609
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
#else
processModule :: Verbosity -> Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface)
processModule verbosity session modsum flags modMap instIfaceMap = do
out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
let filename = msHsFilePath modsum
mbMod <- checkAndLoadModule session modsum False
if not $ isBootSummary modsum
then do
ghcMod <- case mbMod of
Just (CheckedModule a (Just b) (Just c) (Just d) _)
-> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum)
_ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum))
(interface, msg) <- runWriterGhc $ createInterface ghcMod flags modMap instIfaceMap
mapM_ putStrLn msg
return (Just interface)
else
return Nothing
#endif
type CheckedMod = (Module, FilePath, FullyCheckedMod)
type FullyCheckedMod = (ParsedSource,
RenamedSource,
TypecheckedSource,
ModuleInfo)
-- | Dig out what we want from the typechecker output
mkGhcModule :: CheckedMod -> DynFlags -> GhcModule
mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule {
ghcModule = mdl,
ghcFilename = file,
ghcMbDocOpts = mbOpts,
ghcHaddockModInfo = info,
ghcMbDoc = mbDoc,
ghcGroup = group_,
ghcMbExports = mbExports,
ghcExportedNames = modInfoExports modInfo,
ghcDefinedNames = map getName $ modInfoTyThings modInfo,
ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo,
ghcInstances = modInfoInstances modInfo
}
where
#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2
HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed
#else
mbOpts = haddockOptions dynflags
#endif
(group_, _, mbExports, mbDoc, info) = renamed
(_, renamed, _, modInfo) = checkedMod
-- | 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 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