Move sources under haddock-api/src

1 files changed, 488 insertions, 0 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
new file mode 100644
index 00000000..0cff5bd3
--- /dev/null
+++ b/haddock-api/src/Haddock.hs
@@ -0,0 +1,488 @@
+{-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-}
+{-# LANGUAGE LambdaCase #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock
+-- Copyright   :  (c) Simon Marlow 2003-2006,
+--                    David Waern  2006-2010,
+--                    Mateusz Kowalczyk 2014
+-- 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 Haddock (
+  haddock,
+  haddockWithGhc,
+  getGhcDirs,
+  readPackagesAndProcessModules,
+  withGhc
+) where
+
+import Haddock.Backends.Xhtml
+import Haddock.Backends.Xhtml.Themes (getThemes)
+import Haddock.Backends.LaTeX
+import Haddock.Backends.Hoogle
+import Haddock.Interface
+import Haddock.Parser
+import Haddock.Types
+import Haddock.Version
+import Haddock.InterfaceFile
+import Haddock.Options
+import Haddock.Utils
+import Haddock.GhcUtils hiding (pretty)
+
+import Control.Monad hiding (forM_)
+import Data.Foldable (forM_)
+import Data.List (isPrefixOf)
+import Control.Exception
+import Data.Maybe
+import Data.IORef
+import qualified Data.Map as Map
+import System.IO
+import System.Exit
+import System.Directory
+
+#if defined(mingw32_HOST_OS)
+import Foreign
+import Foreign.C
+import Data.Int
+#endif
+
+#ifdef IN_GHC_TREE
+import System.FilePath
+#else
+import qualified GHC.Paths as GhcPaths
+import Paths_haddock_api (getDataDir)
+#endif
+
+import GHC hiding (verbosity)
+import Config
+import DynFlags hiding (verbosity)
+import StaticFlags (discardStaticFlags)
+import Panic (handleGhcException)
+import Module
+
+--------------------------------------------------------------------------------
+-- * Exception handling
+--------------------------------------------------------------------------------
+
+
+handleTopExceptions :: IO a -> IO a
+handleTopExceptions =
+  handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions
+
+
+-- | Either returns normally or throws an ExitCode exception;
+-- all other exceptions are turned into exit exceptions.
+handleNormalExceptions :: IO a -> IO a
+handleNormalExceptions inner =
+  (inner `onException` hFlush stdout)
+  `catches`
+  [  Handler (\(code :: ExitCode) -> exitWith code)
+
+  ,  Handler (\(ex :: AsyncException) ->
+       case ex of
+         StackOverflow -> do
+           putStrLn "stack overflow: use -g +RTS -K<size> to increase it"
+           exitFailure
+         _ -> do
+           putStrLn ("haddock: " ++ show ex)
+           exitFailure)
+
+  ,  Handler (\(ex :: SomeException) -> do
+        putStrLn ("haddock: internal error: " ++ show ex)
+        exitFailure)
+  ]
+
+
+handleHaddockExceptions :: IO a -> IO a
+handleHaddockExceptions inner =
+  catches inner [Handler handler]
+  where
+    handler (e::HaddockException) = do
+      putStrLn $ "haddock: " ++ show e
+      exitFailure
+
+
+handleGhcExceptions :: IO a -> IO a
+handleGhcExceptions =
+  -- error messages propagated as exceptions
+  handleGhcException $ \e -> do
+    hFlush stdout
+    case e of
+      PhaseFailed _ code -> exitWith code
+      _ -> do
+        print (e :: GhcException)
+        exitFailure
+
+
+-------------------------------------------------------------------------------
+-- * Top level
+-------------------------------------------------------------------------------
+
+
+-- | Run Haddock with given list of arguments.
+--
+-- Haddock's own main function is defined in terms of this:
+--
+-- > main = getArgs >>= haddock
+haddock :: [String] -> IO ()
+haddock args = haddockWithGhc withGhc args
+
+haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO ()
+haddockWithGhc ghc args = handleTopExceptions $ do
+
+  -- Parse command-line flags and handle some of them initially.
+  -- TODO: unify all of this (and some of what's in the 'render' function),
+  -- into one function that returns a record with a field for each option,
+  -- or which exits with an error or help message.
+  (flags, files) <- parseHaddockOpts args
+  shortcutFlags flags
+  qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
+
+  -- inject dynamic-too into flags before we proceed
+  flags' <- ghc flags $ do
+        df <- getDynFlags
+        case lookup "GHC Dynamic" (compilerInfo df) of
+          Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
+          _ -> return flags
+
+  unless (Flag_NoWarnings `elem` flags) $ do
+    forM_ (warnings args) $ \warning -> do
+      hPutStrLn stderr warning
+
+  ghc flags' $ do
+
+    dflags <- getDynFlags
+
+    if not (null files) then do
+      (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
+
+      -- Dump an "interface file" (.haddock file), if requested.
+      forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do
+        writeInterfaceFile path InterfaceFile {
+            ifInstalledIfaces = map toInstalledIface ifaces
+          , ifLinkEnv         = homeLinks
+          }
+
+      -- Render the interfaces.
+      liftIO $ renderStep dflags flags qual packages ifaces
+
+    else do
+      when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
+        throwE "No input file(s)."
+
+      -- Get packages supplied with --read-interface.
+      packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
+
+      -- Render even though there are no input files (usually contents/index).
+      liftIO $ renderStep dflags flags qual packages []
+
+-- | Create warnings about potential misuse of -optghc
+warnings :: [String] -> [String]
+warnings = map format . filter (isPrefixOf "-optghc")
+  where
+    format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]
+
+
+withGhc :: [Flag] -> Ghc a -> IO a
+withGhc flags action = do
+  libDir <- fmap snd (getGhcDirs flags)
+
+  -- Catches all GHC source errors, then prints and re-throws them.
+  let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
+        printException err
+        liftIO exitFailure
+
+  withGhc' libDir (ghcFlags flags) (\_ -> handleSrcErrors action)
+
+
+readPackagesAndProcessModules :: [Flag] -> [String]
+                              -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
+readPackagesAndProcessModules flags files = do
+    -- Get packages supplied with --read-interface.
+    packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
+
+    -- Create the interfaces -- this is the core part of Haddock.
+    let ifaceFiles = map snd packages
+    (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
+
+    return (packages, ifaces, homeLinks)
+
+
+renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+renderStep dflags flags qual pkgs interfaces = do
+  updateHTMLXRefs pkgs
+  let
+    ifaceFiles = map snd pkgs
+    installedIfaces = concatMap ifInstalledIfaces ifaceFiles
+    srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ]
+  render dflags flags qual interfaces installedIfaces srcMap
+
+
+-- | Render the interfaces with whatever backend is specified in the flags.
+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
+render dflags flags qual ifaces installedIfaces srcMap = do
+
+  let
+    title                = fromMaybe "" (optTitle flags)
+    unicode              = Flag_UseUnicode `elem` flags
+    pretty               = Flag_PrettyHtml `elem` flags
+    opt_wiki_urls        = wikiUrls          flags
+    opt_contents_url     = optContentsUrl    flags
+    opt_index_url        = optIndexUrl       flags
+    odir                 = outputDir         flags
+    opt_latex_style      = optLaTeXStyle     flags
+
+    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 ]
+
+    pkgMod           = ifaceMod (head ifaces)
+    pkgId            = modulePackageId pkgMod
+    pkgStr           = Just (packageIdString pkgId)
+    (pkgName,pkgVer) = modulePackageInfo pkgMod
+
+    (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
+    srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity
+    -- TODO: Get these from the interface files as with srcMap
+    srcLMap' = maybe Map.empty (\path -> Map.singleton pkgId path) srcLEntity
+    sourceUrls' = (srcBase, srcModule, srcMap', srcLMap')
+
+  libDir   <- getHaddockLibDir flags
+  prologue <- getPrologue dflags flags
+  themes   <- getThemes libDir flags >>= either bye return
+
+  when (Flag_GenIndex `elem` flags) $ do
+    ppHtmlIndex odir title pkgStr
+                themes opt_contents_url sourceUrls' opt_wiki_urls
+                allVisibleIfaces pretty
+    copyHtmlBits odir libDir themes
+
+  when (Flag_GenContents `elem` flags) $ do
+    ppHtmlContents odir title pkgStr
+                   themes opt_index_url sourceUrls' opt_wiki_urls
+                   allVisibleIfaces True prologue pretty
+                   (makeContentsQual qual)
+    copyHtmlBits odir libDir themes
+
+  when (Flag_Html `elem` flags) $ do
+    ppHtml title pkgStr visibleIfaces odir
+                prologue
+                themes sourceUrls' opt_wiki_urls
+                opt_contents_url opt_index_url unicode qual
+                pretty
+    copyHtmlBits odir libDir themes
+
+  when (Flag_Hoogle `elem` flags) $ do
+    let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName
+    ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir
+
+  when (Flag_LaTeX `elem` flags) $ do
+    ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style
+                  libDir
+
+
+-------------------------------------------------------------------------------
+-- * Reading and dumping interface files
+-------------------------------------------------------------------------------
+
+
+readInterfaceFiles :: MonadIO m
+                   => NameCacheAccessor m
+                   -> [(DocPaths, FilePath)]
+                   -> m [(DocPaths, InterfaceFile)]
+readInterfaceFiles name_cache_accessor pairs = do
+  catMaybes `liftM` mapM tryReadIface pairs
+  where
+    -- try to read an interface, warn if we can't
+    tryReadIface (paths, file) =
+      readInterfaceFile name_cache_accessor file >>= \case
+        Left err -> liftIO $ do
+          putStrLn ("Warning: Cannot read " ++ file ++ ":")
+          putStrLn ("   " ++ err)
+          putStrLn "Skipping this interface."
+          return Nothing
+        Right f -> return $ Just (paths, f)
+
+
+-------------------------------------------------------------------------------
+-- * Creating a GHC session
+-------------------------------------------------------------------------------
+
+
+-- | Start a GHC session with the -haddock flag set. Also turn off
+-- compilation and linking. Then run the given 'Ghc' action.
+withGhc' :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
+withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
+  dynflags  <- getSessionDynFlags
+  dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) {
+    hscTarget = HscNothing,
+    ghcMode   = CompManager,
+    ghcLink   = NoLink
+    }
+  let dynflags'' = gopt_unset dynflags' Opt_SplitObjs
+  defaultCleanupHandler dynflags'' $ do
+      -- ignore the following return-value, which is a list of packages
+      -- that may need to be re-linked: Haddock doesn't do any
+      -- dynamic or static linking at all!
+      _ <- setSessionDynFlags dynflags''
+      ghcActs dynflags''
+  where
+    parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags
+    parseGhcFlags dynflags = do
+      -- TODO: handle warnings?
+
+      -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot
+      -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if
+      -- we pass any, Haddock will fail. Since StaticFlags are global to the
+      -- GHC invocation, there's also no way to reparse/save them to set them
+      -- again properly.
+      --
+      -- This is a bit of a hack until we get rid of the rest of the remaining
+      -- StaticFlags. See GHC issue #8276.
+      let flags' = discardStaticFlags flags
+      (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')
+      if not (null rest)
+        then throwE ("Couldn't parse GHC options: " ++ unwords flags')
+        else return dynflags'
+
+-------------------------------------------------------------------------------
+-- * Misc
+-------------------------------------------------------------------------------
+
+
+getHaddockLibDir :: [Flag] -> IO String
+getHaddockLibDir flags =
+  case [str | Flag_Lib str <- flags] of
+    [] -> do
+#ifdef IN_GHC_TREE
+      getInTreeDir
+#else
+      d <- getDataDir -- provided by Cabal
+      doesDirectoryExist d >>= \exists -> case exists of
+        True -> return d
+        False -> do
+          -- If directory does not exist then we are probably invoking from
+          -- ./dist/build/haddock/haddock so we use ./resources as a fallback.
+          doesDirectoryExist "resources" >>= \exists_ -> case exists_ of
+            True -> return "resources"
+            False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n")
+#endif
+    fs -> return (last fs)
+
+
+getGhcDirs :: [Flag] -> IO (String, String)
+getGhcDirs flags = do
+  case [ dir | Flag_GhcLibDir dir <- flags ] of
+    [] -> do
+#ifdef IN_GHC_TREE
+      libDir <- getInTreeDir
+      return (ghcPath, libDir)
+#else
+      return (ghcPath, GhcPaths.libdir)
+#endif
+    xs -> return (ghcPath, last xs)
+  where
+#ifdef IN_GHC_TREE
+    ghcPath = "not available"
+#else
+    ghcPath = GhcPaths.ghc
+#endif
+
+
+shortcutFlags :: [Flag] -> IO ()
+shortcutFlags flags = do
+  usage <- getUsage
+
+  when (Flag_Help             `elem` flags) (bye usage)
+  when (Flag_Version          `elem` flags) byeVersion
+  when (Flag_InterfaceVersion `elem` flags) (bye (show binaryInterfaceVersion ++ "\n"))
+  when (Flag_CompatibleInterfaceVersions `elem` flags)
+    (bye (unwords (map show binaryInterfaceVersionCompatibility) ++ "\n"))
+  when (Flag_GhcVersion       `elem` flags) (bye (cProjectVersion ++ "\n"))
+
+  when (Flag_PrintGhcPath `elem` flags) $ do
+    dir <- fmap fst (getGhcDirs flags)
+    bye $ dir ++ "\n"
+
+  when (Flag_PrintGhcLibDir `elem` flags) $ do
+    dir <- fmap snd (getGhcDirs flags)
+    bye $ dir ++ "\n"
+
+  when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` 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"
+
+  when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
+        && Flag_Hoogle `elem` flags) $
+    throwE "--hoogle cannot be used with --gen-index or --gen-contents"
+
+  when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
+        && Flag_LaTeX `elem` flags) $
+    throwE "--latex 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"
+
+
+updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
+updateHTMLXRefs packages = do
+  writeIORef html_xrefs_ref (Map.fromList mapping)
+  writeIORef html_xrefs_ref' (Map.fromList mapping')
+  where
+    mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages
+              , iface <- ifInstalledIfaces ifaces ]
+    mapping' = [ (moduleName m, html) | (m, html) <- mapping ]
+
+
+getPrologue :: DynFlags -> [Flag] -> IO (Maybe (Doc RdrName))
+getPrologue dflags flags =
+  case [filename | Flag_Prologue filename <- flags ] of
+    [] -> return Nothing
+    [filename] -> withFile filename ReadMode $ \h -> do
+      hSetEncoding h utf8
+      str <- hGetContents h
+      return . Just $ parseParas dflags str
+    _ -> throwE "multiple -p/--prologue options"
+
+
+#ifdef IN_GHC_TREE
+
+getInTreeDir :: IO String
+getInTreeDir = getExecDir >>= \case
+  Nothing -> error "No GhcDir found"
+  Just d -> return (d </> ".." </> "lib")
+
+
+getExecDir :: IO (Maybe String)
+#if defined(mingw32_HOST_OS)
+getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+  where
+    try_size size = allocaArray (fromIntegral size) $ \buf -> do
+        ret <- c_GetModuleFileName nullPtr buf size
+        case ret of
+          0 -> return Nothing
+          _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf
+            | otherwise  -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
+#else
+getExecDir = return Nothing
+#endif
+
+#endif