-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Interface
-- Copyright   :  (c) Simon Marlow 2003-2006,
--                    David Waern  2006-2010
-- 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 Data.List
import qualified Data.Map as Map
import Distribution.Verbosity
import System.Directory
import System.FilePath
import Text.Printf

import Digraph
import Exception
import GHC hiding (verbosity, flags)
import HscTypes


-- | 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 modules flags extIfaces = do

  out :: MonadIO m => Verbosity -> Verbosity -> String -> m ()out verbosity :: Verbosityverbosity verbose :: Verbosityverbose "Creating interfaces..."
  let instIfaceMap =  fromList :: Ord k => [(k, a)] -> Map k aMap.fromList [ (instMod :: InstalledInterface -> ModuleinstMod iface :: InstalledInterfaceiface, iface :: InstalledInterfaceiface) | ext <- extIfaces :: [InterfaceFile]extIfaces
                                   , iface <- ifInstalledIfaces :: InterfaceFile -> [InstalledInterface]ifInstalledIfaces ext :: InterfaceFileext ]
  interfaces <- createIfaces0 ::
  Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]createIfaces0 verbosity :: Verbosityverbosity modules :: [String]modules flags :: [Flag]flags instIfaceMap :: Map Module InstalledInterfaceinstIfaceMap

  out :: MonadIO m => Verbosity -> Verbosity -> String -> m ()out verbosity :: Verbosityverbosity verbose :: Verbosityverbose "Attaching instances..."
  interfaces' <- attachInstances :: [Interface] -> InstIfaceMap -> Ghc [Interface]attachInstances interfaces :: [Interface]interfaces instIfaceMap :: Map Module InstalledInterfaceinstIfaceMap

  out :: MonadIO m => Verbosity -> Verbosity -> String -> m ()out verbosity :: Verbosityverbosity verbose :: Verbosityverbose "Building cross-linking environment..."
  -- Combine the link envs of the external packages into one
  let extLinks  = unions :: Ord k => [Map k a] -> Map k aMap.unions (map :: (a -> b) -> [a] -> [b]map ifLinkEnv :: InterfaceFile -> LinkEnvifLinkEnv extIfaces :: [InterfaceFile]extIfaces)
      homeLinks = buildHomeLinks :: [Interface] -> LinkEnvbuildHomeLinks interfaces :: [Interface]interfaces -- Build the environment for the home
                                            -- package
      links     = homeLinks :: LinkEnvhomeLinks union :: Ord k => Map k a -> Map k a -> Map k a`Map.union` extLinks :: Map Name ModuleextLinks

  out :: MonadIO m => Verbosity -> Verbosity -> String -> m ()out verbosity :: Verbosityverbosity verbose :: Verbosityverbose "Renaming interfaces..."
  let warnings = Flag_NoWarnings :: FlagFlag_NoWarnings notElem :: Eq a => a -> [a] -> Bool`notElem` flags :: [Flag]flags
  let (interfaces'', msgs) =
         runWriter :: ErrMsgM a -> (a, [ErrMsg])runWriter ($) :: (a -> b) -> a -> b$ mapM :: Monad m => (a -> m b) -> [a] -> m [b]mapM (renameInterface ::
  LinkEnv -> Bool -> Interface -> ErrMsgM InterfacerenameInterface links :: Map Name Modulelinks warnings :: Boolwarnings) interfaces' :: [Interface]interfaces'
  liftIO :: MonadIO m => forall a. IO a -> m aliftIO ($) :: (a -> b) -> a -> b$ mapM_ :: Monad m => (a -> m b) -> [a] -> m ()mapM_ putStrLn :: String -> IO ()putStrLn msgs :: [ErrMsg]msgs

  return :: Monad m => forall a. a -> m areturn (interfaces'' :: [Interface]interfaces'', homeLinks :: LinkEnvhomeLinks)


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


createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
createIfaces0 verbosity modules flags instIfaceMap =
  -- Output dir needs to be set before calling depanal since depanal uses it to
  -- compute output file names that are stored in the DynFlags of the
  -- resulting ModSummaries.
  (if useTempDir :: BooluseTempDir then withTempOutputDir :: Ghc a -> Ghc awithTempOutputDir else id :: a -> aid) ($) :: (a -> b) -> a -> b$ do
    modGraph <- depAnalysis :: Ghc ModuleGraphdepAnalysis
    if needsTemplateHaskell :: ModuleGraph -> BoolneedsTemplateHaskell modGraph :: ModuleGraphmodGraph then do
      modGraph' <- enableCompilation :: ModuleGraph -> Ghc ModuleGraphenableCompilation modGraph :: ModuleGraphmodGraph
      createIfaces ::
  Verbosity
  -> [Flag]
  -> InstIfaceMap
  -> ModuleGraph
  -> Ghc [Interface]createIfaces verbosity :: Verbosityverbosity flags :: [Flag]flags instIfaceMap :: Map Module InstalledInterfaceinstIfaceMap modGraph' :: [ModSummary]modGraph'
    else
      createIfaces ::
  Verbosity
  -> [Flag]
  -> InstIfaceMap
  -> ModuleGraph
  -> Ghc [Interface]createIfaces verbosity :: Verbosityverbosity flags :: [Flag]flags instIfaceMap :: Map Module InstalledInterfaceinstIfaceMap modGraph :: ModuleGraphmodGraph

  where
    useTempDir :: Bool
    useTempDir = Flag_NoTmpCompDir :: FlagFlag_NoTmpCompDir notElem :: Eq a => a -> [a] -> Bool`notElem` flags :: [Flag]flags


    withTempOutputDir :: Ghc a -> Ghc a
    withTempOutputDir action = do
      tmp <- liftIO :: MonadIO m => forall a. IO a -> m aliftIO getTemporaryDirectory :: IO FilePathgetTemporaryDirectory
      x   <- liftIO :: MonadIO m => forall a. IO a -> m aliftIO getProcessID :: IO IntgetProcessID
      let dir = tmp :: FilePathtmp (</>) :: FilePath -> FilePath -> FilePath</> ".haddock-" (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow x :: Intx
      modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()modifySessionDynFlags (setOutputDir :: String -> DynFlags -> DynFlagssetOutputDir dir :: FilePathdir)
      withTempDir ::
  (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m awithTempDir dir :: FilePathdir action :: Ghc aaction


    depAnalysis :: Ghc ModuleGraph
    depAnalysis = do
      targets <- mapM :: Monad m => (a -> m b) -> [a] -> m [b]mapM (\f -> guessTarget :: GhcMonad m => String -> Maybe Phase -> m TargetguessTarget f :: Stringf Nothing :: Maybe aNothing) modules :: [String]modules
      setTargets :: GhcMonad m => [Target] -> m ()setTargets targets :: [Target]targets
      depanal :: GhcMonad m => [ModuleName] -> Bool -> m ModuleGraphdepanal [] :: [a][] False :: BoolFalse


    enableCompilation :: ModuleGraph -> Ghc ModuleGraph
    enableCompilation modGraph = do
      let enableComp d = d :: DynFlagsd { hscTarget = defaultObjectTarget :: HscTargetdefaultObjectTarget }
      modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()modifySessionDynFlags enableComp :: DynFlags -> DynFlagsenableComp
      -- We need to update the DynFlags of the ModSummaries as well.
      let upd m = m :: ModSummarym { ms_hspp_opts = enableComp :: DynFlags -> DynFlagsenableComp (ms_hspp_opts :: ModSummary -> DynFlagsms_hspp_opts m :: ModSummarym) }
      let modGraph' = map :: (a -> b) -> [a] -> [b]map upd :: ModSummary -> ModSummaryupd modGraph :: ModuleGraphmodGraph
      return :: Monad m => forall a. a -> m areturn modGraph' :: [ModSummary]modGraph'


createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
createIfaces verbosity flags instIfaceMap mods = do
  let sortedMods = flattenSCCs :: [SCC a] -> [a]flattenSCCs ($) :: (a -> b) -> a -> b$ topSortModuleGraph ::
  Bool -> [ModSummary] -> Maybe ModuleName -> [SCC ModSummary]topSortModuleGraph False :: BoolFalse mods :: ModuleGraphmods Nothing :: Maybe aNothing
  (ifaces, _) <- foldM :: Monad m => (a -> b -> m a) -> a -> [b] -> m afoldM f :: Stringf ([] :: [a][], empty :: Map k aMap.empty) sortedMods :: [ModSummary]sortedMods
  return :: Monad m => forall a. a -> m areturn (reverse :: [a] -> [a]reverse ifaces :: [Interface]ifaces)
  where
    f (ifaces, ifaceMap) modSummary = do
      x <- processModule ::
  Verbosity
  -> ModSummary
  -> [Flag]
  -> IfaceMap
  -> InstIfaceMap
  -> Ghc (Maybe Interface)processModule verbosity :: Verbosityverbosity modSummary :: ModSummarymodSummary flags :: [Flag]flags ifaceMap :: IfaceMapifaceMap instIfaceMap :: Map Module InstalledInterfaceinstIfaceMap
      return :: Monad m => forall a. a -> m areturn ($) :: (a -> b) -> a -> b$ case x :: Intx of
        Just iface -> (iface :: InstalledInterfaceiface(:) :: a -> [a] -> [a]:ifaces :: [Interface]ifaces, insert :: Ord k => k -> a -> Map k a -> Map k aMap.insert (ifaceMod :: Interface -> ModuleifaceMod iface :: InstalledInterfaceiface) iface :: InstalledInterfaceiface ifaceMap :: IfaceMapifaceMap)
        Nothing    -> (ifaces :: [Interface]ifaces, ifaceMap :: IfaceMapifaceMap) -- Boot modules don't generate ifaces.


processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
processModule verbosity modsum flags modMap instIfaceMap = do
  out :: MonadIO m => Verbosity -> Verbosity -> String -> m ()out verbosity :: Verbosityverbosity verbose :: Verbosityverbose ($) :: (a -> b) -> a -> b$ "Checking module " (++) :: [a] -> [a] -> [a]++ moduleString :: Module -> StringmoduleString (ms_mod :: ModSummary -> Modulems_mod modsum :: ModSummarymodsum) (++) :: [a] -> [a] -> [a]++ "..."
  tm <- loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m modloadModule (=<<) :: Monad m => (a -> m b) -> m a -> m b=<< typecheckModule ::
  GhcMonad m => ParsedModule -> m TypecheckedModuletypecheckModule (=<<) :: Monad m => (a -> m b) -> m a -> m b=<< parseModule :: GhcMonad m => ModSummary -> m ParsedModuleparseModule modsum :: ModSummarymodsum
  if not :: Bool -> Boolnot ($) :: (a -> b) -> a -> b$ isBootSummary :: ModSummary -> BoolisBootSummary modsum :: ModSummarymodsum then do
    out :: MonadIO m => Verbosity -> Verbosity -> String -> m ()out verbosity :: Verbosityverbosity verbose :: Verbosityverbose "Creating interface..."
    (interface, msg) <- runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg])runWriterGhc ($) :: (a -> b) -> a -> b$ createInterface ::
  TypecheckedModule
  -> [Flag]
  -> IfaceMap
  -> InstIfaceMap
  -> ErrMsgGhc InterfacecreateInterface tm :: TypecheckedModuletm flags :: [Flag]flags modMap :: IfaceMapmodMap instIfaceMap :: Map Module InstalledInterfaceinstIfaceMap
    liftIO :: MonadIO m => forall a. IO a -> m aliftIO ($) :: (a -> b) -> a -> b$ mapM_ :: Monad m => (a -> m b) -> [a] -> m ()mapM_ putStrLn :: String -> IO ()putStrLn msg :: [ErrMsg]msg
    let (haddockable, haddocked) = ifaceHaddockCoverage :: Interface -> (Int, Int)ifaceHaddockCoverage interface :: Interfaceinterface
        percentage = round :: RealFrac a => forall b. Integral b => a -> bround (fromIntegral :: (Integral a, Num b) => a -> bfromIntegral haddocked :: Inthaddocked (*) :: Num a => a -> a -> a* 100 (/) :: Fractional a => a -> a -> a/ fromIntegral :: (Integral a, Num b) => a -> bfromIntegral haddockable :: Inthaddockable :: Double) :: Int
        coveragemsg = printf :: PrintfType r => String -> rprintf "haddock coverage for %s: %7s %3d%%"
                        (ifaceOrigFilename :: Interface -> FilePathifaceOrigFilename interface :: Interfaceinterface)
                        (printf :: PrintfType r => String -> rprintf "%d/%d" haddocked :: Inthaddocked haddockable :: Inthaddockable ::  String)
                        percentage :: Intpercentage
    out :: MonadIO m => Verbosity -> Verbosity -> String -> m ()out verbosity :: Verbosityverbosity normal :: Verbositynormal coveragemsg :: [Char]coveragemsg
    interface' <- liftIO :: MonadIO m => forall a. IO a -> m aliftIO ($) :: (a -> b) -> a -> b$ evaluate :: a -> IO aevaluate interface :: Interfaceinterface
    return :: Monad m => forall a. a -> m areturn (Just :: a -> Maybe aJust interface' :: Interfaceinterface')
  else
    return :: Monad m => forall a. a -> m areturn Nothing :: Maybe aNothing


--------------------------------------------------------------------------------
-- * 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 ifaces = foldl :: (a -> b -> a) -> a -> [b] -> afoldl upd :: ModSummary -> ModSummaryupd empty :: Map k aMap.empty (reverse :: [a] -> [a]reverse ifaces :: [Interface]ifaces)
  where
    upd old_env iface
      | OptHide :: DocOptionOptHide    elem :: Eq a => a -> [a] -> Bool`elem` ifaceOptions :: Interface -> [DocOption]ifaceOptions iface :: InstalledInterfaceiface = old_env :: Map Name Moduleold_env
      | OptNotHome :: DocOptionOptNotHome elem :: Eq a => a -> [a] -> Bool`elem` ifaceOptions :: Interface -> [DocOption]ifaceOptions iface :: InstalledInterfaceiface =
        foldl' :: (a -> b -> a) -> a -> [b] -> afoldl' keep_old :: Map k Module -> k -> Map k Modulekeep_old old_env :: Map Name Moduleold_env exported_names :: [Name]exported_names
      | otherwise :: Boolotherwise = foldl' :: (a -> b -> a) -> a -> [b] -> afoldl' keep_new :: Map k Module -> k -> Map k Modulekeep_new old_env :: Map Name Moduleold_env exported_names :: [Name]exported_names
      where
        exported_names = ifaceVisibleExports :: Interface -> [Name]ifaceVisibleExports iface :: InstalledInterfaceiface
        mdl            = ifaceMod :: Interface -> ModuleifaceMod iface :: InstalledInterfaceiface
        keep_old env n = insertWith ::
  Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k aMap.insertWith (\_ old -> old :: Moduleold) n :: kn mdl :: Modulemdl env :: Map k Moduleenv
        keep_new env n = insert :: Ord k => k -> a -> Map k a -> Map k aMap.insert n :: kn mdl :: Modulemdl env :: Map k Moduleenv


--------------------------------------------------------------------------------
-- * Utils
--------------------------------------------------------------------------------


withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a
withTempDir dir = gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m cgbracket_ (liftIO :: MonadIO m => forall a. IO a -> m aliftIO ($) :: (a -> b) -> a -> b$ createDirectory :: FilePath -> IO ()createDirectory dir :: FilePathdir)
                            (liftIO :: MonadIO m => forall a. IO a -> m aliftIO ($) :: (a -> b) -> a -> b$ removeDirectoryRecursive :: FilePath -> IO ()removeDirectoryRecursive dir :: FilePathdir)