module Haddock.Interface (
createInterfaces
) where
import Haddock.DocName
import Haddock.Interface.Create
import Haddock.Interface.AttachInstances
import Haddock.Interface.Rename
import Haddock.Types
import Haddock.Options
import Haddock.GHC.Utils
import Haddock.GHC.Typecheck
import Haddock.Exception
import Haddock.Utils
import Haddock.InterfaceFile
import qualified Data.Map as Map
import Data.Map (Map)
import Data.List
import Control.Monad
import Control.Exception ( evaluate )
import GHC
import Name
import HscTypes ( msHsFilePath )
import Digraph
import BasicTypes
import SrcLoc
import HscTypes
#if __GLASGOW_HASKELL__ >= 609
createInterfaces :: [String] -> [Flag] -> [InterfaceFile]
-> Ghc ([Interface], LinkEnv)
createInterfaces modules flags extIfaces = do
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
, iface <- ifInstalledIfaces ext ]
interfaces <- createInterfaces' modules flags instIfaceMap
#else
createInterfaces :: Session -> [String] -> [Flag]
-> [InterfaceFile] -> IO ([Interface], LinkEnv)
createInterfaces session modules flags extIfaces = do
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
, iface <- ifInstalledIfaces ext ]
interfaces <- createInterfaces' session modules flags instIfaceMap
#endif
let extLinks = Map.unions (map ifLinkEnv extIfaces)
homeLinks = buildHomeLinks interfaces
links = homeLinks `Map.union` extLinks
allNames = Map.keys links
let interfaces' = attachInstances interfaces allNames
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' :: [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
createInterfaces' 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 __GLASGOW_HASKELL__ < 611
let needsTemplateHaskell = any (dopt Opt_TemplateHaskell . ms_hspp_opts)
#endif
modgraph' <- if needsTemplateHaskell modgraph
then do
dflags <- getSessionDynFlags
setSessionDynFlags dflags { hscTarget = HscC }
let addHscC m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = HscC } }
return (map addHscC modgraph)
else return modgraph
#else
let modgraph' = modgraph
#endif
let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing
(ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
x <- processModule modsum flags modMap instIfaceMap
#else
createInterfaces' :: Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface]
createInterfaces' 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 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)
#if __GLASGOW_HASKELL__ >= 609
processModule :: ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface)
processModule modsum flags modMap instIfaceMap = do
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
let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
liftIO $ mapM_ putStrLn msg
liftIO $ evaluate interface
return (Just interface)
else
return Nothing
#else
processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface)
processModule session modsum flags modMap instIfaceMap = do
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))
let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
mapM_ putStrLn msg
return (Just interface)
else
return Nothing
#endif
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
mod = ifaceMod iface
keep_old env n = Map.insertWith (\new old -> old) n mod env
keep_new env n = Map.insert n mod env