{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Main
-- Copyright   :  (c) Simon Marlow 2003-2006,
--                    David Waern  2006-2009
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Haddock - A Haskell Documentation Tool
--
-- Program entry point and top-level code.
-----------------------------------------------------------------------------

module Main (main) where


import Haddock.Backends.Html
import Haddock.Backends.Hoogle
import Haddock.Interface
import Haddock.Interface.Lex
import Haddock.Interface.Parse
import Haddock.Types
import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Options
import Haddock.Utils
import Haddock.GhcUtils
import Paths_haddock

import Control.Monad
import Control.OldException
import qualified Control.Exception as NewException
import Data.Maybe
import Data.IORef
import qualified Data.Map as Map
import System.IO
import System.Exit
import System.Environment
import System.FilePath
import Distribution.Verbosity

#if defined(mingw32_HOST_OS)
import Foreign
import Foreign.C
import Data.Int
#endif

#ifndef IN_GHC_TREE
import GHC.Paths
#endif

import GHC hiding (flags, verbosity)
import Config
import DynFlags hiding (flags, verbosity)
import Panic (handleGhcException)
import MonadUtils ( MonadIO(..) )


--------------------------------------------------------------------------------
-- Exception handling
--------------------------------------------------------------------------------


handleTopExceptions :: IO a -> IO a
handleTopExceptions =
  handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions


handleNormalExceptions :: IO a -> IO a
handleNormalExceptions inner =
  handle (\exception -> do
    hFlush stdout
    case exception of
      AsyncException StackOverflow -> do
        putStrLn "stack overflow: use -g +RTS -K<size> to increase it"
        exitFailure
      ExitException code -> exitWith code
      _other -> do
        putStrLn ("haddock: internal Haddock or GHC error: " ++ show exception)
        exitFailure
  ) inner


handleHaddockExceptions :: IO a -> IO a
handleHaddockExceptions inner =
  NewException.catches inner [NewException.Handler handler]
  where
    handler (e::HaddockException) = do
      putStrLn $ "haddock: " ++ (show e)
      exitFailure


handleGhcExceptions :: IO a -> IO a
handleGhcExceptions inner =
  -- error messages propagated as exceptions
  handleGhcException (\e -> do
    hFlush stdout
    case e of
      PhaseFailed _ code -> exitWith code
      Interrupted -> exitFailure
      _ -> do
        print (e :: GhcException)
        exitFailure
  ) inner


-------------------------------------------------------------------------------
-- Top level
-------------------------------------------------------------------------------


main :: IO ()
main = handleTopExceptions $ do

  -- parse command-line flags and handle some of them initially
  args <- getArgs
  (flags, fileArgs) <- parseHaddockOpts args
  handleEasyFlags flags
  verbosity <- getVerbosity flags

  let renderStep packages interfaces = do
        updateHTMLXRefs packages
        let ifaceFiles = map fst packages
            installedIfaces = concatMap ifInstalledIfaces ifaceFiles
        render flags interfaces installedIfaces

  if not (null fileArgs)
    then do

      libDir <- getGhcLibDir flags

      -- We have one global error handler for all GHC source errors.  Other kinds
      -- of exceptions will be propagated to the top-level error handler.
      let handleSrcErrors action = flip handleSourceError action $ \err -> do
            printExceptionAndWarnings err
            liftIO exitFailure

      -- initialize GHC
      startGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do

        -- get packages supplied with --read-interface
        packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)


        -- create the interfaces -- this is the core part of Haddock
        (interfaces, homeLinks) <- createInterfaces verbosity fileArgs flags
                                                    (map fst packages)

        liftIO $ do
          -- render the interfaces
          renderStep packages interfaces

          -- last but not least, dump the interface file
          dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags

    else do
      -- get packages supplied with --read-interface
      packages <- readInterfaceFiles freshNameCache (ifacePairs flags)

      -- render even though there are no input files (usually contents/index)
      renderStep packages []


-------------------------------------------------------------------------------
-- Rendering
-------------------------------------------------------------------------------


-- | Render the interfaces with whatever backend is specified in the flags
render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO ()
render flags ifaces installedIfaces = do
  let
    title = case [str | Flag_Heading str <- flags] of
              [] -> ""
              (t:_) -> t

    maybe_source_urls = (listToMaybe [str | Flag_SourceBaseURL   str <- flags]
                        ,listToMaybe [str | Flag_SourceModuleURL str <- flags]
                        ,listToMaybe [str | Flag_SourceEntityURL str <- flags])

    maybe_wiki_urls = (listToMaybe [str | Flag_WikiBaseURL   str <- flags]
                      ,listToMaybe [str | Flag_WikiModuleURL str <- flags]
                      ,listToMaybe [str | Flag_WikiEntityURL str <- flags])

  libDir <- case [str | Flag_Lib str <- flags] of
    [] ->
#ifdef IN_GHC_TREE
                      do m <- getExecDir
                         case m of
                             Nothing -> error "No libdir found"
#ifdef NEW_GHC_LAYOUT
                             Just d -> return (d </> ".." </> "lib")
#else
                             Just d -> return (d </> "..")
#endif
#else
                      getDataDir -- provided by Cabal
#endif
    fs -> return (last fs)
  let unicode = Flag_UseUnicode `elem` flags
  let css_file = case [str | Flag_CSS str <- flags] of
                   [] -> Nothing
                   fs -> Just (last fs)

  odir <- case [str | Flag_OutputDir str <- flags] of
            [] -> return "."
            fs -> return (last fs)

  let
    maybe_contents_url =
      case [url | Flag_UseContents url <- flags] of
        [] -> Nothing
        us -> Just (last us)

    maybe_index_url =
      case [url | Flag_UseIndex url <- flags] of
        [] -> Nothing
        us -> Just (last us)

    maybe_html_help_format =
      case [hhformat | Flag_HtmlHelp hhformat <- flags] of
        []      -> Nothing
        formats -> Just (last formats)

  prologue <- getPrologue flags

  let
    visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]

    -- *all* visible interfaces including external package modules
    allIfaces        = map toInstalledIface ifaces ++ installedIfaces
    allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]

    packageMod       = ifaceMod (head ifaces)
    packageStr       = Just (modulePackageString packageMod)
    (pkgName,pkgVer) = modulePackageInfo packageMod


  when (Flag_GenIndex `elem` flags) $ do
    ppHtmlIndex odir title packageStr maybe_html_help_format
                maybe_contents_url maybe_source_urls maybe_wiki_urls
                allVisibleIfaces
    copyHtmlBits odir libDir css_file

  when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do
    ppHtmlHelpFiles title packageStr visibleIfaces odir maybe_html_help_format []

  when (Flag_GenContents `elem` flags) $ do
    ppHtmlContents odir title packageStr maybe_html_help_format
                   maybe_index_url maybe_source_urls maybe_wiki_urls
                   allVisibleIfaces True prologue
    copyHtmlBits odir libDir css_file

  when (Flag_Html `elem` flags) $ do
    ppHtml title packageStr visibleIfaces odir
                prologue maybe_html_help_format
                maybe_source_urls maybe_wiki_urls
                maybe_contents_url maybe_index_url unicode
    copyHtmlBits odir libDir css_file

  when (Flag_Hoogle `elem` flags) $ do
    let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName
    ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir


-------------------------------------------------------------------------------
-- Reading and dumping interface files
-------------------------------------------------------------------------------


readInterfaceFiles :: MonadIO m =>
                      NameCacheAccessor m
                   -> [(FilePath, FilePath)] ->
                      m [(InterfaceFile, FilePath)]
readInterfaceFiles name_cache_accessor pairs = do
  mbPackages <- mapM tryReadIface pairs
  return (catMaybes mbPackages)
  where
    -- try to read an interface, warn if we can't
    tryReadIface (html, iface) = do
      eIface <- readInterfaceFile name_cache_accessor iface
      case eIface of
        Left err -> liftIO $ do
          putStrLn ("Warning: Cannot read " ++ iface ++ ":")
          putStrLn ("   " ++ show err)
          putStrLn "Skipping this interface."
          return Nothing
        Right f -> return $ Just (f, html)


dumpInterfaceFile :: [InstalledInterface] -> LinkEnv -> [Flag] -> IO ()
dumpInterfaceFile ifaces homeLinks flags =
  case [str | Flag_DumpInterface str <- flags] of
    [] -> return ()
    fs -> let filename = last fs in writeInterfaceFile filename ifaceFile
  where
    ifaceFile = InterfaceFile {
        ifInstalledIfaces = ifaces,
        ifLinkEnv         = homeLinks
      }


-------------------------------------------------------------------------------
-- Creating a GHC session
-------------------------------------------------------------------------------

-- | Start a GHC session with the -haddock flag set. Also turn off
-- compilation and linking.
startGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
startGhc libDir flags ghcActs = do
  -- TODO: handle warnings?
  (restFlags, _) <- parseStaticFlags (map noLoc flags)
  runGhc (Just libDir) $ do
    dynflags  <- getSessionDynFlags
    let dynflags' = dopt_set dynflags Opt_Haddock
    let dynflags'' = dynflags' {
        hscTarget = HscNothing,
        ghcMode   = CompManager,
        ghcLink   = NoLink
      }
    dynflags''' <- parseGhcFlags dynflags'' restFlags flags
    defaultCleanupHandler dynflags''' $ do
        setSessionDynFlags dynflags'''
        ghcActs dynflags'''
  where
    parseGhcFlags :: Monad m => DynFlags -> [Located String]
                  -> [String] -> m DynFlags
    parseGhcFlags dynflags flags_ origFlags = do
      -- TODO: handle warnings?
      (dynflags', rest, _) <- parseDynamicFlags dynflags flags_
      if not (null rest)
        then throwE ("Couldn't parse GHC options: " ++ (unwords origFlags))
        else return dynflags'


-------------------------------------------------------------------------------
-- Misc
-------------------------------------------------------------------------------


getGhcLibDir :: [Flag] -> IO String
getGhcLibDir flags = do
  case [ dir | Flag_GhcLibDir dir <- flags ] of
    [] ->
#ifdef IN_GHC_TREE
      do m <- getExecDir
         case m of
             Nothing -> error "No GhcLibDir found"
#ifdef NEW_GHC_LAYOUT
             Just d -> return (d </> ".." </> "lib")
#else
             Just d -> return (d </> "..")
#endif
#else
      return libdir -- from GHC.Paths
#endif
    xs -> return $ last xs


getVerbosity :: Monad m => [Flag] -> m Verbosity
getVerbosity flags =
  case [ str | Flag_Verbosity str <- flags ] of
    [] -> return normal
    x:_ -> case parseVerbosity x of
      Left e -> throwE e
      Right v -> return v


handleEasyFlags :: [Flag] -> IO ()
handleEasyFlags flags = do
  usage <- getUsage

  when (Flag_Help           `elem` flags) (bye usage)
  when (Flag_Version        `elem` flags) byeVersion
  when (Flag_GhcVersion     `elem` flags) byeGhcVersion

  when (Flag_PrintGhcLibDir `elem` flags) $ do
    dir <- getGhcLibDir flags
    bye $ dir ++ "\n"

  when (Flag_UseUnicode `elem` flags && not (Flag_Html `elem` flags)) $
  	throwE ("Unicode can only be enabled for HTML output.")

  when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
        && Flag_Html `elem` flags) $
    throwE ("-h cannot be used with --gen-index or --gen-contents")
  where
    byeVersion = bye $
      "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n"
      ++ "Ported to use the GHC API by David Waern 2006-2008\n"

    byeGhcVersion = bye (cProjectVersion ++ "\n")


updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO ()
updateHTMLXRefs packages = do
  writeIORef html_xrefs_ref (Map.fromList mapping)
  where
    mapping = [ (instMod iface, html) | (ifaces, html) <- packages
              , iface <- ifInstalledIfaces ifaces ]


getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName))
getPrologue flags =
  case [filename | Flag_Prologue filename <- flags ] of
    [] -> return Nothing
    [filename] -> do
      str <- readFile filename
      case parseHaddockParagraphs (tokenise str) of
        Nothing -> throwE "parsing haddock prologue failed"
        Just doc -> return (Just doc)
    _otherwise -> throwE "multiple -p/--prologue options"


getExecDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
getExecDir = allocaArray len $ \buf -> do
    ret <- getModuleFileName nullPtr buf len
    if ret == 0
        then return Nothing
        else do s <- peekCString buf
                return (Just (dropFileName s))
  where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.

foreign import stdcall unsafe "GetModuleFileNameA"
  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
getExecDir = return Nothing
#endif