-----------------------------------------------------------------------------
-- |
-- 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


-- | Create 'Interface' structures by typechecking the list of modules
-- using the GHC API and processing the resulting syntax trees.
createInterfaces
  :: 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
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

  -- 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

  -- part 3, attach instances
  out verbosity verbose "Attaching instances..."
  interfaces' <- attachInstances interfaces instIfaceMap

  -- 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)


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 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.
  modgraph' <- if needsTemplateHaskell modgraph
       then do
         dflags <- getSessionDynFlags
         _ <- setSessionDynFlags dflags { hscTarget = defaultObjectTarget }
         -- we need to set defaultObjectTarget on all the ModSummaries as well
         let addDefTarget m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = defaultObjectTarget } }
         return (map addDefTarget 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)


-- | 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,
  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


-- | 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