{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE Rank2Types          #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- 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 Control.DeepSeq (force)
import Control.Monad hiding (forM_)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bifunctor (second)
import Data.Foldable (forM_)
import Data.Traversable (for)
import qualified Data.List as List
import Control.Exception
import Data.Maybe
import Data.IORef
import Data.Map.Strict (Map)
import Data.Version (makeVersion)
import GHC.Parser.Lexer (ParserOpts)
import qualified GHC.Driver.Config.Parser as Parser
import qualified Data.Map.Strict as Map
import System.IO
import System.Exit
import System.FilePath
#ifdef IN_GHC_TREE
import System.Environment (getExecutablePath)
#else
import qualified GHC.Paths as GhcPaths
import Paths_haddock_api (getDataDir)
#endif
import System.Directory (doesDirectoryExist, getTemporaryDirectory)
import Text.ParserCombinators.ReadP (readP_to_S)
import GHC hiding (verbosity)
import GHC.Settings.Config
import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Env
import GHC.Driver.Session hiding (projectVersion, verbosity)
import qualified GHC.Driver.Session as DynFlags (DynFlags(..))
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Types.Name.Cache
import GHC.Unit
import GHC.Utils.Panic (handleGhcException)
import GHC.Data.FastString

import Haddock.Backends.Xhtml
import Haddock.Backends.Xhtml.Meta
import Haddock.Backends.Xhtml.Themes (getThemes)
import Haddock.Backends.LaTeX
import Haddock.Backends.Hoogle
import Haddock.Backends.Hyperlinker
import Haddock.Interface
import Haddock.Interface.Json
import Haddock.Parser
import Haddock.Types
import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Options
import Haddock.Utils
import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir, getSupportedLanguagesAndExtensions)
import Haddock.Compat (getProcessID)

--------------------------------------------------------------------------------
-- * Exception handling
--------------------------------------------------------------------------------


handleTopExceptions :: IO a -> IO a
handleTopExceptions :: forall a. IO a -> IO a
handleTopExceptions =
  IO a -> IO a
forall a. IO a -> IO a
handleNormalExceptions (IO a -> IO a) -> (IO a -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
handleHaddockExceptions (IO a -> IO a) -> (IO a -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
handleGhcExceptions


-- | Either returns normally or throws an ExitCode exception;
-- all other exceptions are turned into exit exceptions.
handleNormalExceptions :: IO a -> IO a
handleNormalExceptions :: forall a. IO a -> IO a
handleNormalExceptions IO a
inner =
  (IO a
inner IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` Handle -> IO ()
hFlush Handle
stdout)
  IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
`catches`
  [  (ExitCode -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(ExitCode
code :: ExitCode) -> ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith ExitCode
code)

  ,  (AsyncException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(AsyncException
ex :: AsyncException) ->
       case AsyncException
ex of
         AsyncException
StackOverflow -> do
           [Char] -> IO ()
putStrLn [Char]
"stack overflow: use -g +RTS -K<size> to increase it"
           IO a
forall a. IO a
exitFailure
         AsyncException
_ -> do
           [Char] -> IO ()
putStrLn ([Char]
"haddock: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AsyncException -> [Char]
forall a. Show a => a -> [Char]
show AsyncException
ex)
           IO a
forall a. IO a
exitFailure)

  ,  (SomeException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(SomeException
ex :: SomeException) -> do
        [Char] -> IO ()
putStrLn ([Char]
"haddock: internal error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
ex)
        IO a
forall a. IO a
exitFailure)
  ]


handleHaddockExceptions :: IO a -> IO a
handleHaddockExceptions :: forall a. IO a -> IO a
handleHaddockExceptions IO a
inner =
  IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
catches IO a
inner [(HaddockException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler HaddockException -> IO a
forall {b}. HaddockException -> IO b
handler]
  where
    handler :: HaddockException -> IO b
handler (HaddockException
e::HaddockException) = do
      [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"haddock: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ HaddockException -> [Char]
forall a. Show a => a -> [Char]
show HaddockException
e
      IO b
forall a. IO a
exitFailure


handleGhcExceptions :: IO a -> IO a
handleGhcExceptions :: forall a. IO a -> IO a
handleGhcExceptions =
  -- error messages propagated as exceptions
  (GhcException -> IO a) -> IO a -> IO a
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException ((GhcException -> IO a) -> IO a -> IO a)
-> (GhcException -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ \GhcException
e -> do
    Handle -> IO ()
hFlush Handle
stdout
    GhcException -> IO ()
forall a. Show a => a -> IO ()
print (GhcException
e :: GhcException)
    IO a
forall a. IO a
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 :: [[Char]] -> IO ()
haddock [[Char]]
args = (forall a. [Flag] -> Ghc a -> IO a) -> [[Char]] -> IO ()
haddockWithGhc [Flag] -> Ghc a -> IO a
forall a. [Flag] -> Ghc a -> IO a
withGhc [[Char]]
args

haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO ()
haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [[Char]] -> IO ()
haddockWithGhc forall a. [Flag] -> Ghc a -> IO a
ghc [[Char]]
args = IO () -> IO ()
forall a. IO a -> IO a
handleTopExceptions (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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) <- [[Char]] -> IO ([Flag], [[Char]])
parseHaddockOpts [[Char]]
args
  shortcutFlags flags

  -- If argument tracing is enabled, print the arguments we were given
  when (Flag_TraceArgs `elem` flags) $ do
    putStrLn $ "haddock received arguments:"
    mapM_ (putStrLn . ("  " ++)) args

  qual <- rightOrThrowE (qualification flags)
  sinceQual <- rightOrThrowE (sinceQualification flags)

  let noCompilation = Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust ([Flag] -> Maybe [Char]
optOneShot [Flag]
flags) Bool -> Bool -> Bool
|| Flag
Flag_NoCompilation Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags

  -- Inject dynamic-too into ghc options if the ghc we are using was built with
  -- dynamic linking (except when not doing any compilation)
  flags'' <- ghc flags $ do
        df <- getDynFlags
        case lookup "GHC Dynamic" (compilerInfo df) of
          Just [Char]
"YES" | Bool -> Bool
not Bool
noCompilation -> [Flag] -> Ghc [Flag]
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Flag] -> Ghc [Flag]) -> [Flag] -> Ghc [Flag]
forall a b. (a -> b) -> a -> b
$ [Char] -> Flag
Flag_OptGhc [Char]
"-dynamic-too" Flag -> [Flag] -> [Flag]
forall a. a -> [a] -> [a]
: [Flag]
flags
          Maybe [Char]
_ -> [Flag] -> Ghc [Flag]
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Flag]
flags

  -- Inject `-j` into ghc options, if given to Haddock
  flags' <- pure $ case optParCount flags'' of
    Maybe (Maybe Int)
Nothing       -> [Flag]
flags''
    Just Maybe Int
Nothing  -> [Char] -> Flag
Flag_OptGhc [Char]
"-j" Flag -> [Flag] -> [Flag]
forall a. a -> [a] -> [a]
: [Flag]
flags''
    Just (Just Int
n) -> [Char] -> Flag
Flag_OptGhc ([Char]
"-j" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n) Flag -> [Flag] -> [Flag]
forall a. a -> [a] -> [a]
: [Flag]
flags''

  -- Whether or not to bypass the interface version check
  let noChecks = Flag
Flag_BypassInterfaceVersonCheck Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags

  -- Create a temporary directory and redirect GHC output there (unless user
  -- requested otherwise).
  --
  -- 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 'ModSummary's.
  let withDir | Flag
Flag_NoTmpCompDir Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags Bool -> Bool -> Bool
|| Bool
noCompilation = Ghc a -> Ghc a
forall a. a -> a
id
              | Bool
otherwise = Ghc a -> Ghc a
forall a. Ghc a -> Ghc a
withTempOutputDir

  -- Output warnings about potential misuse of some flags
  unless (Flag_NoWarnings `elem` flags) $ do
    hypSrcWarnings flags
    mapM_ (hPutStrLn stderr) (optGhcWarnings args)
    when noChecks $
      hPutStrLn stderr noCheckWarning

  ghc flags' $ withDir $ do
    dflags' <- getDynFlags
    let unicode = Flag
Flag_UseUnicode Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags
    let dflags
          | Bool
unicode = DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags' GeneralFlag
Opt_PrintUnicodeSyntax
          | Bool
otherwise = DynFlags
dflags'
    logger' <- getLogger
    let logger = Logger -> LogFlags -> Logger
setLogFlags Logger
logger' (DynFlags -> LogFlags
initLogFlags DynFlags
dflags)
    let parserOpts = DynFlags -> ParserOpts
Parser.initParserOpts DynFlags
dflags
    !unit_state <- hsc_units <$> getSession

    -- If any --show-interface was used, show the given interfaces
    forM_ (optShowInterfaceFile flags) $ \[Char]
path -> IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
      name_cache <- IO NameCache
freshNameCache
      mIfaceFile <- readInterfaceFiles name_cache [(DocPaths "" Nothing, Visible, path)] noChecks
      forM_ mIfaceFile $ \(DocPaths
_,Visibility
_,[Char]
_, InterfaceFile
ifaceFile) -> do
        Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ JsonDoc -> SDoc
renderJson (InterfaceFile -> JsonDoc
jsonInterfaceFile InterfaceFile
ifaceFile)

    -- If we were given source files to generate documentation from, do it
    if not (null files) || isJust (optOneShot flags) then do
      (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
      let packageInfo = PackageInfo { piPackageName :: PackageName
piPackageName =
                                        PackageName -> Maybe PackageName -> PackageName
forall a. a -> Maybe a -> a
fromMaybe (FastString -> PackageName
PackageName FastString
forall a. Monoid a => a
mempty) ([Flag] -> Maybe PackageName
optPackageName [Flag]
flags)
                                    , piPackageVersion :: Version
piPackageVersion =
                                        Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe ([Int] -> Version
makeVersion []) ([Flag] -> Maybe Version
optPackageVersion [Flag]
flags)
                                    }
          languagesAndExtensions = [Interface] -> [[Char]]
getSupportedLanguagesAndExtensions [Interface]
ifaces

      -- Dump an "interface file" (.haddock file), if requested.
      forM_ (optDumpInterfaceFile flags) $ \[Char]
path -> IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> InterfaceFile -> IO ()
writeInterfaceFile [Char]
path InterfaceFile {
            ifInstalledIfaces :: [InstalledInterface]
ifInstalledIfaces = (Interface -> InstalledInterface)
-> [Interface] -> [InstalledInterface]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> InstalledInterface
toInstalledIface [Interface]
ifaces
          , ifPackageInfo :: PackageInfo
ifPackageInfo     = PackageInfo
packageInfo
          , ifLinkEnv :: LinkEnv
ifLinkEnv         = LinkEnv
homeLinks
          }

      -- Render the interfaces.
      liftIO $ renderStep dflags languagesAndExtensions parserOpts logger unit_state flags sinceQual qual packages ifaces

    -- If we were not given any input files, error if documentation was
    -- requested
    else do
      when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
        throwE "No input file(s)."

      -- Get packages supplied with --read-interface.
      name_cache <- liftIO $ freshNameCache
      packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks

      -- Render even though there are no input files (usually contents/index).
      liftIO $ renderStep dflags [] parserOpts logger unit_state flags sinceQual qual packages []

-- | Run the GHC action using a temporary output directory
withTempOutputDir :: Ghc a -> Ghc a
withTempOutputDir :: forall a. Ghc a -> Ghc a
withTempOutputDir Ghc a
action = do
  tmp <- IO [Char] -> Ghc [Char]
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO [Char]
getTemporaryDirectory
  x   <- liftIO getProcessID
  let dir = [Char]
tmp [Char] -> [Char] -> [Char]
</> [Char]
".haddock-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x
  modifySessionDynFlags (setOutputDir dir)
  withTempDir dir action

-- | Create warnings about potential misuse of -optghc
optGhcWarnings :: [String] -> [String]
optGhcWarnings :: [[Char]] -> [[Char]]
optGhcWarnings = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
format ([[Char]] -> [[Char]])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf [Char]
"-optghc")
  where
    format :: [Char] -> [Char]
format [Char]
arg = [[Char]] -> [Char]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Char]
"Warning: `", [Char]
arg, [Char]
"' means `-o ", Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
2 [Char]
arg, [Char]
"', did you mean `-", [Char]
arg, [Char]
"'?"]

-- | Create a warning about bypassing the interface version check
noCheckWarning :: String
noCheckWarning :: [Char]
noCheckWarning = [Char]
"Warning: `--bypass-interface-version-check' can cause " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                 [Char]
"Haddock to crash when reading Haddock interface files."

withGhc :: [Flag] -> Ghc a -> IO a
withGhc :: forall a. [Flag] -> Ghc a -> IO a
withGhc [Flag]
flags Ghc a
action = do
  libDir <- ((Maybe [Char], Maybe [Char]) -> [Char])
-> IO (Maybe [Char], Maybe [Char]) -> IO [Char]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"No GhcDir found") (Maybe [Char] -> [Char])
-> ((Maybe [Char], Maybe [Char]) -> Maybe [Char])
-> (Maybe [Char], Maybe [Char])
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe [Char], Maybe [Char]) -> Maybe [Char]
forall a b. (a, b) -> b
snd) ([Flag] -> IO (Maybe [Char], Maybe [Char])
getGhcDirs [Flag]
flags)

  -- Catches all GHC source errors, then prints and re-throws them.
  let handleSrcErrors m a
action' = ((SourceError -> m a) -> m a -> m a)
-> m a -> (SourceError -> m a) -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SourceError -> m a) -> m a -> m a
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError m a
action' ((SourceError -> m a) -> m a) -> (SourceError -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \SourceError
err -> do
        SourceError -> m ()
forall (m :: Type -> Type).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
printException SourceError
err
        IO a -> m a
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO a
forall a. IO a
exitFailure
      needHieFiles = Flag
Flag_HyperlinkedSource Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags

  withGhc' libDir needHieFiles (ghcFlags flags) (\DynFlags
_ -> Ghc a -> Ghc a
forall {m :: Type -> Type} {a}.
(MonadCatch m, HasLogger m, MonadIO m, HasDynFlags m) =>
m a -> m a
handleSrcErrors Ghc a
action)


readPackagesAndProcessModules :: [Flag] -> [String]
                              -> Ghc ([(DocPaths, Visibility, FilePath, InterfaceFile)], [Interface], LinkEnv)
readPackagesAndProcessModules :: [Flag]
-> [[Char]]
-> Ghc
     ([(DocPaths, Visibility, [Char], InterfaceFile)], [Interface],
      LinkEnv)
readPackagesAndProcessModules [Flag]
flags [[Char]]
files = do
    -- Whether or not we bypass the interface file version check
    let noChecks :: Bool
noChecks = Flag
Flag_BypassInterfaceVersonCheck Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags

    -- Read package dependency interface files supplied with --read-interface
    name_cache <- HscEnv -> NameCache
hsc_NC (HscEnv -> NameCache) -> Ghc HscEnv -> Ghc NameCache
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
    packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks

    -- Create the interfaces for the given modules -- this is the core part of Haddock
    let ifaceFiles = ((DocPaths, Visibility, [Char], InterfaceFile) -> InterfaceFile)
-> [(DocPaths, Visibility, [Char], InterfaceFile)]
-> [InterfaceFile]
forall a b. (a -> b) -> [a] -> [b]
map (\(DocPaths
_, Visibility
_, [Char]
_, InterfaceFile
ifaceFile) -> InterfaceFile
ifaceFile) [(DocPaths, Visibility, [Char], InterfaceFile)]
packages
    (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles

    return (packages, ifaces, homeLinks)


renderStep
  :: DynFlags
  -> [String]
  -- ^ Supported languages and extensions based on architecture and OS
  -> ParserOpts
  -> Logger
  -> UnitState
  -> [Flag]
  -> SinceQual
  -> QualOption
  -> [(DocPaths, Visibility, FilePath, InterfaceFile)]
  -> [Interface]
  -> IO ()
renderStep :: DynFlags
-> [[Char]]
-> ParserOpts
-> Logger
-> UnitState
-> [Flag]
-> SinceQual
-> QualOption
-> [(DocPaths, Visibility, [Char], InterfaceFile)]
-> [Interface]
-> IO ()
renderStep DynFlags
dflags [[Char]]
languagesAndExtensions ParserOpts
parserOpts Logger
logger UnitState
unit_state [Flag]
flags SinceQual
sinceQual QualOption
nameQual [(DocPaths, Visibility, [Char], InterfaceFile)]
pkgs [Interface]
interfaces = do
  [([Char], InterfaceFile)] -> IO ()
updateHTMLXRefs (((DocPaths, Visibility, [Char], InterfaceFile)
 -> ([Char], InterfaceFile))
-> [(DocPaths, Visibility, [Char], InterfaceFile)]
-> [([Char], InterfaceFile)]
forall a b. (a -> b) -> [a] -> [b]
map (\(DocPaths
docPath, Visibility
_ifaceFilePath, [Char]
_showModules, InterfaceFile
ifaceFile) ->
                          ( case [Flag] -> Maybe [Char]
baseUrl [Flag]
flags of
                              Maybe [Char]
Nothing  -> DocPaths -> [Char]
docPathsHtml DocPaths
docPath
                              Just [Char]
url -> [Char]
url [Char] -> [Char] -> [Char]
</> Unit -> [Char]
packageName (InterfaceFile -> Unit
ifUnitId InterfaceFile
ifaceFile)
                          , InterfaceFile
ifaceFile)) [(DocPaths, Visibility, [Char], InterfaceFile)]
pkgs)
  let
    installedIfaces :: [([Char], PackageInterfaces)]
installedIfaces =
      ((DocPaths, Visibility, [Char], InterfaceFile)
 -> ([Char], PackageInterfaces))
-> [(DocPaths, Visibility, [Char], InterfaceFile)]
-> [([Char], PackageInterfaces)]
forall a b. (a -> b) -> [a] -> [b]
map
        (\(DocPaths
_, Visibility
showModules, [Char]
ifaceFilePath, InterfaceFile
ifaceFile)
          -> ([Char]
ifaceFilePath, Visibility -> InterfaceFile -> PackageInterfaces
mkPackageInterfaces Visibility
showModules InterfaceFile
ifaceFile))
        [(DocPaths, Visibility, [Char], InterfaceFile)]
pkgs
    extSrcMap :: Map Module [Char]
extSrcMap = [(Module, [Char])] -> Map Module [Char]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Module, [Char])] -> Map Module [Char])
-> [(Module, [Char])] -> Map Module [Char]
forall a b. (a -> b) -> a -> b
$ do
      (DocPaths {docPathsSources=Just path}, _, _, ifile) <- [(DocPaths, Visibility, [Char], InterfaceFile)]
pkgs
      iface <- ifInstalledIfaces ifile
      return (instMod iface, path)
  DynFlags
-> [[Char]]
-> ParserOpts
-> Logger
-> UnitState
-> [Flag]
-> SinceQual
-> QualOption
-> [Interface]
-> [([Char], PackageInterfaces)]
-> Map Module [Char]
-> IO ()
render DynFlags
dflags [[Char]]
languagesAndExtensions ParserOpts
parserOpts Logger
logger UnitState
unit_state [Flag]
flags SinceQual
sinceQual QualOption
nameQual [Interface]
interfaces [([Char], PackageInterfaces)]
installedIfaces Map Module [Char]
extSrcMap
  where
    -- get package name from unit-id
    packageName :: Unit -> String
    packageName :: Unit -> [Char]
packageName Unit
unit =
      case UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
unit_state Unit
unit of
        Maybe UnitInfo
Nothing  -> Unit -> [Char]
forall a. Show a => a -> [Char]
show Unit
unit
        Just UnitInfo
pkg -> UnitInfo -> [Char]
forall u. GenUnitInfo u -> [Char]
unitPackageNameString UnitInfo
pkg

-- | Render the interfaces with whatever backend is specified in the flags.
render
  :: DynFlags
  -> [String]
  -- ^ Supported languages and extensions based on architecture and OS
  -> ParserOpts
  -> Logger
  -> UnitState
  -> [Flag]
  -> SinceQual
  -> QualOption
  -> [Interface]
  -> [(FilePath, PackageInterfaces)]
  -> Map Module FilePath
  -> IO ()
render :: DynFlags
-> [[Char]]
-> ParserOpts
-> Logger
-> UnitState
-> [Flag]
-> SinceQual
-> QualOption
-> [Interface]
-> [([Char], PackageInterfaces)]
-> Map Module [Char]
-> IO ()
render DynFlags
dflags [[Char]]
languagesAndExtensions ParserOpts
parserOpts Logger
logger UnitState
unit_state [Flag]
flags SinceQual
sinceQual QualOption
qual [Interface]
ifaces [([Char], PackageInterfaces)]
packages Map Module [Char]
extSrcMap = do
  let
    packageInfo :: PackageInfo
packageInfo = PackageInfo { piPackageName :: PackageName
piPackageName    = PackageName -> Maybe PackageName -> PackageName
forall a. a -> Maybe a -> a
fromMaybe (FastString -> PackageName
PackageName FastString
forall a. Monoid a => a
mempty)
                                                 (Maybe PackageName -> PackageName)
-> Maybe PackageName -> PackageName
forall a b. (a -> b) -> a -> b
$ [Flag] -> Maybe PackageName
optPackageName [Flag]
flags
                              , piPackageVersion :: Version
piPackageVersion = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe ([Int] -> Version
makeVersion [])
                                                 (Maybe Version -> Version) -> Maybe Version -> Version
forall a b. (a -> b) -> a -> b
$ [Flag] -> Maybe Version
optPackageVersion [Flag]
flags
                              }

    title :: [Char]
title                = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"" ([Flag] -> Maybe [Char]
optTitle [Flag]
flags)
    unicode :: Bool
unicode              = Flag
Flag_UseUnicode Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags
    pretty :: Bool
pretty               = Flag
Flag_PrettyHtml Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags
    opt_wiki_urls :: (Maybe [Char], Maybe [Char], Maybe [Char])
opt_wiki_urls        = [Flag] -> (Maybe [Char], Maybe [Char], Maybe [Char])
wikiUrls          [Flag]
flags
    opt_base_url :: Maybe [Char]
opt_base_url         = [Flag] -> Maybe [Char]
baseUrl           [Flag]
flags
    opt_contents_url :: Maybe [Char]
opt_contents_url     = [Flag] -> Maybe [Char]
optContentsUrl    [Flag]
flags
    opt_index_url :: Maybe [Char]
opt_index_url        = [Flag] -> Maybe [Char]
optIndexUrl       [Flag]
flags
    odir :: [Char]
odir                 = [Flag] -> [Char]
outputDir         [Flag]
flags
    opt_latex_style :: Maybe [Char]
opt_latex_style      = [Flag] -> Maybe [Char]
optLaTeXStyle     [Flag]
flags
    opt_source_css :: Maybe [Char]
opt_source_css       = [Flag] -> Maybe [Char]
optSourceCssFile  [Flag]
flags
    opt_mathjax :: Maybe [Char]
opt_mathjax          = [Flag] -> Maybe [Char]
optMathjax        [Flag]
flags

    visibleIfaces :: [Interface]
visibleIfaces    = [ Interface
i | Interface
i <- [Interface]
ifaces, DocOption
OptHide DocOption -> [DocOption] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` Interface -> [DocOption]
ifaceOptions Interface
i ]

    -- /All/ interfaces including external package modules, grouped by
    -- interface file (package).
    allPackages      :: [PackageInterfaces]
    allPackages :: [PackageInterfaces]
allPackages      = [PackageInterfaces
                         { piPackageInfo :: PackageInfo
piPackageInfo = PackageInfo
packageInfo
                         , piVisibility :: Visibility
piVisibility  = Visibility
Visible
                         , piInstalledInterfaces :: [InstalledInterface]
piInstalledInterfaces  = (Interface -> InstalledInterface)
-> [Interface] -> [InstalledInterface]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> InstalledInterface
toInstalledIface [Interface]
ifaces
                         }]
                    [PackageInterfaces] -> [PackageInterfaces] -> [PackageInterfaces]
forall a. [a] -> [a] -> [a]
++ (([Char], PackageInterfaces) -> PackageInterfaces)
-> [([Char], PackageInterfaces)] -> [PackageInterfaces]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], PackageInterfaces) -> PackageInterfaces
forall a b. (a, b) -> b
snd [([Char], PackageInterfaces)]
packages

    -- /All/ visible interfaces including external package modules, grouped by
    -- interface file (package).
    allVisiblePackages :: [PackageInterfaces]
    allVisiblePackages :: [PackageInterfaces]
allVisiblePackages = [ PackageInterfaces
pinfo { piInstalledInterfaces =
                                     filter (\InstalledInterface
i -> DocOption
OptHide DocOption -> [DocOption] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` InstalledInterface -> [DocOption]
instOptions InstalledInterface
i)
                                            piInstalledInterfaces
                                 }
                         | pinfo :: PackageInterfaces
pinfo@PackageInterfaces
                             { piVisibility :: PackageInterfaces -> Visibility
piVisibility = Visibility
Visible
                             , [InstalledInterface]
piInstalledInterfaces :: PackageInterfaces -> [InstalledInterface]
piInstalledInterfaces :: [InstalledInterface]
piInstalledInterfaces
                             } <- [PackageInterfaces]
allPackages
                         ]

    -- /All/ installed interfaces.
    allInstalledIfaces :: [InstalledInterface]
    allInstalledIfaces :: [InstalledInterface]
allInstalledIfaces = (([Char], PackageInterfaces) -> [InstalledInterface])
-> [([Char], PackageInterfaces)] -> [InstalledInterface]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (PackageInterfaces -> [InstalledInterface]
piInstalledInterfaces (PackageInterfaces -> [InstalledInterface])
-> (([Char], PackageInterfaces) -> PackageInterfaces)
-> ([Char], PackageInterfaces)
-> [InstalledInterface]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], PackageInterfaces) -> PackageInterfaces
forall a b. (a, b) -> b
snd) [([Char], PackageInterfaces)]
packages

    pkgMod :: Maybe Module
pkgMod           = (Interface -> Module) -> Maybe Interface -> Maybe Module
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Interface -> Module
ifaceMod ([Interface] -> Maybe Interface
forall a. [a] -> Maybe a
listToMaybe [Interface]
ifaces)
    pkgKey :: Maybe Unit
pkgKey           = (Module -> Unit) -> Maybe Module -> Maybe Unit
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Maybe Module
pkgMod
    pkgStr :: Maybe [Char]
pkgStr           = (Unit -> [Char]) -> Maybe Unit -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Unit -> [Char]
forall u. IsUnitId u => u -> [Char]
unitString Maybe Unit
pkgKey
    pkgNameVer :: (Maybe PackageName, Maybe Version)
pkgNameVer       = UnitState
-> [Flag] -> Maybe Module -> (Maybe PackageName, Maybe Version)
modulePackageInfo UnitState
unit_state [Flag]
flags Maybe Module
pkgMod
    pkgName :: Maybe [Char]
pkgName          = (PackageName -> [Char]) -> Maybe PackageName -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (FastString -> [Char]
unpackFS (FastString -> [Char])
-> (PackageName -> FastString) -> PackageName -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(PackageName FastString
n) -> FastString
n)) ((Maybe PackageName, Maybe Version) -> Maybe PackageName
forall a b. (a, b) -> a
fst (Maybe PackageName, Maybe Version)
pkgNameVer)
    sincePkg :: Maybe [Char]
sincePkg         = case SinceQual
sinceQual of
                         SinceQual
External -> Maybe [Char]
pkgName
                         SinceQual
Always -> Maybe [Char]
forall a. Maybe a
Nothing

    (Maybe [Char]
srcBase, Maybe [Char]
srcModule, Maybe [Char]
srcEntity, Maybe [Char]
srcLEntity) = [Flag] -> (Maybe [Char], Maybe [Char], Maybe [Char], Maybe [Char])
sourceUrls [Flag]
flags

    srcModule' :: Maybe [Char]
srcModule'
      | Flag
Flag_HyperlinkedSource Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
hypSrcModuleUrlFormat
      | Bool
otherwise = Maybe [Char]
srcModule

    -- These urls have a template for the module %M
    srcMap :: Map Module SrcPath
srcMap = Map Module SrcPath -> Map Module SrcPath -> Map Module SrcPath
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
      (([Char] -> SrcPath) -> Map Module [Char] -> Map Module SrcPath
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ([Char] -> SrcPath
SrcExternal ([Char] -> SrcPath) -> ([Char] -> [Char]) -> [Char] -> SrcPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
hypSrcPkgUrlToModuleFormat) Map Module [Char]
extSrcMap)
      ([(Module, SrcPath)] -> Map Module SrcPath
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Interface -> Module
ifaceMod Interface
iface, SrcPath
SrcLocal) | Interface
iface <- [Interface]
ifaces ])

    -- These urls have a template for the module %M and the name %N
    pkgSrcMap :: Map Unit [Char]
pkgSrcMap = ([Char] -> [Char]) -> Map Unit [Char] -> Map Unit [Char]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ([Char] -> [Char]
hypSrcModuleUrlToNameFormat ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
hypSrcPkgUrlToModuleFormat)
              (Map Unit [Char] -> Map Unit [Char])
-> Map Unit [Char] -> Map Unit [Char]
forall a b. (a -> b) -> a -> b
$ (Module -> Unit) -> Map Module [Char] -> Map Unit [Char]
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Map Module [Char]
extSrcMap
    pkgSrcMap' :: Map Unit [Char]
pkgSrcMap'
      | Flag
Flag_HyperlinkedSource Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags
      , Just Unit
k <- Maybe Unit
pkgKey
      = Unit -> [Char] -> Map Unit [Char] -> Map Unit [Char]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Unit
k [Char]
hypSrcModuleNameUrlFormat Map Unit [Char]
pkgSrcMap
      | Just [Char]
srcNameUrl <- Maybe [Char]
srcEntity
      , Just Unit
k <- Maybe Unit
pkgKey
      = Unit -> [Char] -> Map Unit [Char] -> Map Unit [Char]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Unit
k [Char]
srcNameUrl Map Unit [Char]
pkgSrcMap
      | Bool
otherwise = Map Unit [Char]
pkgSrcMap

    pkgSrcLMap :: Map Unit [Char]
pkgSrcLMap = ([Char] -> [Char]) -> Map Unit [Char] -> Map Unit [Char]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ([Char] -> [Char]
hypSrcModuleUrlToLineFormat ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
hypSrcPkgUrlToModuleFormat)
               (Map Unit [Char] -> Map Unit [Char])
-> Map Unit [Char] -> Map Unit [Char]
forall a b. (a -> b) -> a -> b
$ (Module -> Unit) -> Map Module [Char] -> Map Unit [Char]
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Map Module [Char]
extSrcMap
    -- These urls have a template for the module %M and the line %L
    pkgSrcLMap' :: Map Unit [Char]
pkgSrcLMap'
      | Flag
Flag_HyperlinkedSource Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags
      , Just Unit
k <- Maybe Unit
pkgKey
      = Unit -> [Char] -> Map Unit [Char] -> Map Unit [Char]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Unit
k [Char]
hypSrcModuleLineUrlFormat Map Unit [Char]
pkgSrcLMap
      | Just [Char]
path <- Maybe [Char]
srcLEntity
      , Just Unit
k <- Maybe Unit
pkgKey
      = Unit -> [Char] -> Map Unit [Char] -> Map Unit [Char]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Unit
k [Char]
path Map Unit [Char]
pkgSrcLMap
      | Bool
otherwise = Map Unit [Char]
pkgSrcLMap

    sourceUrls' :: (Maybe [Char], Maybe [Char], Map Unit [Char], Map Unit [Char])
sourceUrls' = (Maybe [Char]
srcBase, Maybe [Char]
srcModule', Map Unit [Char]
pkgSrcMap', Map Unit [Char]
pkgSrcLMap')

    installedMap :: Map Module InstalledInterface
    installedMap :: Map Module InstalledInterface
installedMap = [(Module, InstalledInterface)] -> Map Module InstalledInterface
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Module -> Module
unwire (InstalledInterface -> Module
instMod InstalledInterface
iface), InstalledInterface
iface) | InstalledInterface
iface <- [InstalledInterface]
allInstalledIfaces ]

    -- The user gives use base-4.9.0.0, but the InstalledInterface
    -- records the *wired in* identity base.  So untranslate it
    -- so that we can service the request.
    unwire :: Module -> Module
    unwire :: Module -> Module
unwire Module
m = Module
m { moduleUnit = unwireUnit unit_state (moduleUnit m) }

  reexportedIfaces <- [[InstalledInterface]] -> [InstalledInterface]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[InstalledInterface]] -> [InstalledInterface])
-> IO [[InstalledInterface]] -> IO [InstalledInterface]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ([[Char]]
-> ([Char] -> IO [InstalledInterface]) -> IO [[InstalledInterface]]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Flag] -> [[Char]]
reexportFlags [Flag]
flags) (([Char] -> IO [InstalledInterface]) -> IO [[InstalledInterface]])
-> ([Char] -> IO [InstalledInterface]) -> IO [[InstalledInterface]]
forall a b. (a -> b) -> a -> b
$ \[Char]
mod_str -> do
    let warn' :: [Char] -> IO ()
warn' = Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"Warning: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
    case ReadP Module -> ReadS Module
forall a. ReadP a -> ReadS a
readP_to_S ReadP Module
parseHoleyModule [Char]
mod_str of
      [(Module
m, [Char]
"")]
        | Just InstalledInterface
iface <- Module -> Map Module InstalledInterface -> Maybe InstalledInterface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
m Map Module InstalledInterface
installedMap
        -> [InstalledInterface] -> IO [InstalledInterface]
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [InstalledInterface
iface]
        | Bool
otherwise
        -> [Char] -> IO ()
warn' ([Char]
"Cannot find reexported module '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mod_str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'") IO () -> IO [InstalledInterface] -> IO [InstalledInterface]
forall a b. IO a -> IO b -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> [InstalledInterface] -> IO [InstalledInterface]
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
      [(Module, [Char])]
_ -> [Char] -> IO ()
warn' ([Char]
"Cannot parse reexported module flag '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mod_str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'") IO () -> IO [InstalledInterface] -> IO [InstalledInterface]
forall a b. IO a -> IO b -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> [InstalledInterface] -> IO [InstalledInterface]
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [])

  libDir   <- getHaddockLibDir flags
  !prologue <- force <$> getPrologue parserOpts flags
  themes   <- getThemes libDir flags >>= either bye return

  let withQuickjump = Flag
Flag_QuickJumpIndex Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags
      withBaseURL = Maybe Flag -> Bool
forall a. Maybe a -> Bool
isJust
                  (Maybe Flag -> Bool) -> ([Flag] -> Maybe Flag) -> [Flag] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Flag -> Bool) -> [Flag] -> Maybe Flag
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
List.find (\Flag
flag -> case Flag
flag of
                           Flag_BaseURL [Char]
base_url ->
                             [Char]
base_url [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"." Bool -> Bool -> Bool
&& [Char]
base_url [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"./"
                           Flag
_ -> Bool
False
                         )
                  ([Flag] -> Bool) -> [Flag] -> Bool
forall a b. (a -> b) -> a -> b
$ [Flag]
flags

  when (Flag_GenIndex `elem` flags) $ do
    withTiming logger "ppHtmlIndex" (const ()) $ do
      _ <- {-# SCC ppHtmlIndex #-}
           ppHtmlIndex odir title pkgStr
                  themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
                  (concatMap piInstalledInterfaces allVisiblePackages) pretty
      return ()

    unless withBaseURL $
      copyHtmlBits odir libDir themes withQuickjump

  when (Flag_GenContents `elem` flags) $ do
    withTiming logger "ppHtmlContents" (const ()) $ do
      _ <- {-# SCC ppHtmlContents #-}
           ppHtmlContents unit_state odir title pkgStr
                     themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
                     allVisiblePackages True prologue pretty
                     sincePkg (makeContentsQual qual)
      return ()
    copyHtmlBits odir libDir themes withQuickjump

  when withQuickjump $ void $
            ppJsonIndex odir sourceUrls' opt_wiki_urls
                        unicode Nothing qual
                        ifaces
                        ( List.nub
                        . map fst
                        . filter ((== Visible) . piVisibility . snd)
                        $ packages)

  when (Flag_Html `elem` flags) $ do
    withTiming logger "ppHtml" (const ()) $ do
      _ <- {-# SCC ppHtml #-}
           ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir
                  prologue
                  themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url
                  opt_contents_url opt_index_url unicode sincePkg packageInfo
                  qual pretty withQuickjump
      return ()
    unless (withBaseURL || isJust (optOneShot flags)) $ do
      copyHtmlBits odir libDir themes withQuickjump
      writeHaddockMeta odir withQuickjump

  -- TODO: we throw away Meta for both Hoogle and LaTeX right now,
  -- might want to fix that if/when these two get some work on them
  when (Flag_Hoogle `elem` flags) $ do
    case pkgNameVer of
      (Just (PackageName FastString
pkgNameFS), Maybe Version
mpkgVer) ->
          let
            pkgNameStr :: [Char]
pkgNameStr | FastString -> [Char]
unpackFS FastString
pkgNameFS [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"main" Bool -> Bool -> Bool
&& [Char]
title [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] = [Char]
title
                       | Bool
otherwise = FastString -> [Char]
unpackFS FastString
pkgNameFS

            pkgVer :: Version
pkgVer =
              Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe ([Int] -> Version
makeVersion []) Maybe Version
mpkgVer
          in DynFlags
-> UnitState
-> [Char]
-> Version
-> [Char]
-> Maybe (Doc RdrName)
-> [Interface]
-> [Char]
-> IO ()
ppHoogle DynFlags
dflags UnitState
unit_state [Char]
pkgNameStr Version
pkgVer [Char]
title ((MDoc RdrName -> Doc RdrName)
-> Maybe (MDoc RdrName) -> Maybe (Doc RdrName)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap MDoc RdrName -> Doc RdrName
forall mod id. MetaDoc mod id -> DocH mod id
_doc Maybe (MDoc RdrName)
prologue)
               [Interface]
visibleIfaces [Char]
odir
      (Maybe PackageName, Maybe Version)
_ -> [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> ([[Char]] -> [Char]) -> [[Char]] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> IO ()) -> [[Char]] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [ [Char]
"haddock: Unable to find a package providing module "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> (Module -> [Char]) -> Maybe Module -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"<no-mod>" (ModuleName -> [Char]
moduleNameString (ModuleName -> [Char])
-> (Module -> ModuleName) -> Module -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName) Maybe Module
pkgMod
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", skipping Hoogle."
          , [Char]
""
          , [Char]
"         Perhaps try specifying the desired package explicitly"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" using the --package-name"
          , [Char]
"         and --package-version arguments."
          ]

  when (Flag_LaTeX `elem` flags) $ do
    withTiming logger "ppLatex" (const ()) $ do
      _ <- {-# SCC ppLatex #-}
           ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
                   libDir
      return ()

  when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do
    withTiming logger "ppHyperlinkedSource" (const ()) $ do
      _ <- {-# SCC ppHyperlinkedSource #-}
           ppHyperlinkedSource (verbosity flags) (isJust (optOneShot flags)) languagesAndExtensions  odir libDir opt_source_css pretty srcMap ifaces
      return ()


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


readInterfaceFiles :: NameCache
                   -> [(DocPaths, Visibility, FilePath)]
                   -> Bool
                   -> IO [(DocPaths, Visibility, FilePath, InterfaceFile)]
readInterfaceFiles :: NameCache
-> [(DocPaths, Visibility, [Char])]
-> Bool
-> IO [(DocPaths, Visibility, [Char], InterfaceFile)]
readInterfaceFiles NameCache
name_cache_accessor [(DocPaths, Visibility, [Char])]
pairs Bool
bypass_version_check = do
  [Maybe (DocPaths, Visibility, [Char], InterfaceFile)]
-> [(DocPaths, Visibility, [Char], InterfaceFile)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (DocPaths, Visibility, [Char], InterfaceFile)]
 -> [(DocPaths, Visibility, [Char], InterfaceFile)])
-> IO [Maybe (DocPaths, Visibility, [Char], InterfaceFile)]
-> IO [(DocPaths, Visibility, [Char], InterfaceFile)]
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
`liftM` ((DocPaths, Visibility, [Char])
 -> IO (Maybe (DocPaths, Visibility, [Char], InterfaceFile)))
-> [(DocPaths, Visibility, [Char])]
-> IO [Maybe (DocPaths, Visibility, [Char], InterfaceFile)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM ({-# SCC readInterfaceFile #-} (DocPaths, Visibility, [Char])
-> IO (Maybe (DocPaths, Visibility, [Char], InterfaceFile))
forall {a} {b}.
(a, b, [Char]) -> IO (Maybe (a, b, [Char], InterfaceFile))
tryReadIface) [(DocPaths, Visibility, [Char])]
pairs
  where
    -- try to read an interface, warn if we can't
    tryReadIface :: (a, b, [Char]) -> IO (Maybe (a, b, [Char], InterfaceFile))
tryReadIface (a
paths, b
vis, [Char]
file) =
      NameCache -> [Char] -> Bool -> IO (Either [Char] InterfaceFile)
readInterfaceFile NameCache
name_cache_accessor [Char]
file Bool
bypass_version_check IO (Either [Char] InterfaceFile)
-> (Either [Char] InterfaceFile
    -> IO (Maybe (a, b, [Char], InterfaceFile)))
-> IO (Maybe (a, b, [Char], InterfaceFile))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left [Char]
err -> do
          [Char] -> IO ()
putStrLn ([Char]
"Warning: Cannot read " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
file [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":")
          [Char] -> IO ()
putStrLn ([Char]
"   " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err)
          [Char] -> IO ()
putStrLn [Char]
"Skipping this interface."
          Maybe (a, b, [Char], InterfaceFile)
-> IO (Maybe (a, b, [Char], InterfaceFile))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (a, b, [Char], InterfaceFile)
forall a. Maybe a
Nothing
        Right InterfaceFile
f -> Maybe (a, b, [Char], InterfaceFile)
-> IO (Maybe (a, b, [Char], InterfaceFile))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((a, b, [Char], InterfaceFile)
-> Maybe (a, b, [Char], InterfaceFile)
forall a. a -> Maybe a
Just (a
paths, b
vis, [Char]
file, InterfaceFile
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 -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a
withGhc' :: forall a. [Char] -> Bool -> [[Char]] -> (DynFlags -> Ghc a) -> IO a
withGhc' [Char]
libDir Bool
needHieFiles [[Char]]
flags DynFlags -> Ghc a
ghcActs = Maybe [Char] -> Ghc a -> IO a
forall a. Maybe [Char] -> Ghc a -> IO a
runGhc ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
libDir) (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    logger <- Ghc Logger
forall (m :: Type -> Type). HasLogger m => m Logger
getLogger

    -- Set default GHC verbosity to 1. This is better for hi-haddock since -v0
    -- creates an awkward silence during the load operation
    default_dflags <- getSessionDynFlags >>= \DynFlags
dflags ->
      DynFlags -> Ghc DynFlags
forall a. a -> Ghc a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure DynFlags
dflags { DynFlags.verbosity = 1 }

    dynflags' <- parseGhcFlags logger default_dflags

    -- Disable pattern match warnings because they can be very expensive to
    -- check, set optimization level to 0 for fastest compilation.
    let dynflags'' = DynFlags -> DynFlags
unsetPatternMatchWarnings (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ Int -> DynFlags -> DynFlags
updOptLevel Int
0 DynFlags
dynflags'

    -- 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
    -- ignore sublists of flags that start with "+RTS" and end in "-RTS"
    --
    -- See https://github.com/haskell/haddock/issues/666
    filterRtsFlags :: [String] -> [String]
    filterRtsFlags :: [[Char]] -> [[Char]]
filterRtsFlags [[Char]]
flgs = ([Char] -> (Bool -> [[Char]]) -> Bool -> [[Char]])
-> (Bool -> [[Char]]) -> [[Char]] -> Bool -> [[Char]]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Char] -> (Bool -> [[Char]]) -> Bool -> [[Char]]
forall {a}. (Eq a, IsString a) => a -> (Bool -> [a]) -> Bool -> [a]
go ([[Char]] -> Bool -> [[Char]]
forall a b. a -> b -> a
const []) [[Char]]
flgs Bool
True
      where go :: a -> (Bool -> [a]) -> Bool -> [a]
go a
"-RTS" Bool -> [a]
func Bool
_ = Bool -> [a]
func Bool
True
            go a
"+RTS" Bool -> [a]
func Bool
_ = Bool -> [a]
func Bool
False
            go a
_      Bool -> [a]
func Bool
False = Bool -> [a]
func Bool
False
            go a
arg    Bool -> [a]
func Bool
True = a
arg a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Bool -> [a]
func Bool
True

    parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
    parseGhcFlags :: forall (m :: Type -> Type).
MonadIO m =>
Logger -> DynFlags -> m DynFlags
parseGhcFlags Logger
logger DynFlags
dynflags = do
      -- TODO: handle warnings?

      let extra_opts :: [GeneralFlag]
extra_opts =
            [ -- Include docstrings in .hi files.
              GeneralFlag
Opt_Haddock

              -- Do not recompile because of changes to optimization flags
            , GeneralFlag
Opt_IgnoreOptimChanges
            ]
              -- Write .hie files if we need them for hyperlinked src
              [GeneralFlag] -> [GeneralFlag] -> [GeneralFlag]
forall a. [a] -> [a] -> [a]
++ if Bool
needHieFiles
                    then [GeneralFlag
Opt_WriteHie] -- Generate .hie-files
                    else []
          dynflags' :: DynFlags
dynflags' = ((DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dynflags [GeneralFlag]
extra_opts)
                        { backend = noBackend
                        , ghcMode = CompManager
                        , ghcLink = NoLink
                        }
          flags' :: [[Char]]
flags' = [[Char]] -> [[Char]]
filterRtsFlags [[Char]]
flags

      (dynflags'', rest, _) <- Logger
-> DynFlags
-> [Located [Char]]
-> m (DynFlags, [Located [Char]], Messages DriverMessage)
forall (m :: Type -> Type).
MonadIO m =>
Logger
-> DynFlags
-> [Located [Char]]
-> m (DynFlags, [Located [Char]], Messages DriverMessage)
parseDynamicFlags Logger
logger DynFlags
dynflags' (([Char] -> Located [Char]) -> [[Char]] -> [Located [Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Located [Char]
forall e. e -> Located e
noLoc [[Char]]
flags')
      if not (null rest)
        then throwE ("Couldn't parse GHC options: " ++ unwords flags')
        else return dynflags''

unsetPatternMatchWarnings :: DynFlags -> DynFlags
unsetPatternMatchWarnings :: DynFlags -> DynFlags
unsetPatternMatchWarnings DynFlags
dflags =
  (DynFlags -> WarningFlag -> DynFlags)
-> DynFlags -> [WarningFlag] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' DynFlags -> WarningFlag -> DynFlags
wopt_unset DynFlags
dflags [WarningFlag]
pattern_match_warnings
  where
    pattern_match_warnings :: [WarningFlag]
pattern_match_warnings =
      [ WarningFlag
Opt_WarnIncompletePatterns
      , WarningFlag
Opt_WarnIncompleteUniPatterns
      , WarningFlag
Opt_WarnIncompletePatternsRecUpd
      , WarningFlag
Opt_WarnOverlappingPatterns
      ]

-------------------------------------------------------------------------------
-- * Misc
-------------------------------------------------------------------------------


getHaddockLibDir :: [Flag] -> IO FilePath
getHaddockLibDir :: [Flag] -> IO [Char]
getHaddockLibDir [Flag]
flags =
  case [[Char]
str | Flag_Lib [Char]
str <- [Flag]
flags] of
    [] -> do
#ifdef IN_GHC_TREE

      -- When in the GHC tree, we should be able to locate the "lib" folder
      -- based on the location of the current executable.
      base_dir <- IO (Maybe [Char])
getBaseDir      -- Provided by GHC
      let res_dirs = [ [Char]
d | Just [Char]
d <- [Maybe [Char]
base_dir] ] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++

#else

      -- When Haddock was installed by @cabal@, the resources (which are listed
      -- under @data-files@ in the Cabal file) will have been copied to a
      -- special directory.
      data_dir <- getDataDir      -- Provided by Cabal
      let res_dirs = [ data_dir ] ++

#endif

      -- When Haddock is built locally (eg. regular @cabal new-build@), the data
      -- directory does not exist and we are probably invoking from either
      -- @./haddock-api@ or @./@
                     [ [Char]
"resources"
                     , [Char]
"haddock-api/resources"
                     ]

      res_dir <- check res_dirs
      case res_dir of
        Just [Char]
p -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Char]
p
        Maybe [Char]
_      -> [Char] -> IO [Char]
forall a. [Char] -> IO a
die [Char]
"Haddock's resource directory does not exist!\n"

    [[Char]]
fs -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
last [[Char]]
fs)
  where
    -- Pick the first path that corresponds to a directory that exists
    check :: [FilePath] -> IO (Maybe FilePath)
    check :: [[Char]] -> IO (Maybe [Char])
check [] = Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
    check ([Char]
path : [[Char]]
other_paths) = do
      exists <- [Char] -> IO Bool
doesDirectoryExist [Char]
path
      if exists then pure (Just path) else check other_paths

-- | Find the @lib@ directory for GHC and the path to @ghc@
getGhcDirs :: [Flag] -> IO (Maybe FilePath, Maybe FilePath)
getGhcDirs :: [Flag] -> IO (Maybe [Char], Maybe [Char])
getGhcDirs [Flag]
flags = do

#ifdef IN_GHC_TREE
  base_dir <- IO (Maybe [Char])
getBaseDir
  let ghc_path = Maybe a
forall a. Maybe a
Nothing
#else
  let base_dir = Just GhcPaths.libdir
      ghc_path = Just GhcPaths.ghc
#endif

  -- If the user explicitly specifies a lib dir, use that
  let ghc_dir = case [ [Char]
dir | Flag_GhcLibDir [Char]
dir <- [Flag]
flags ] of
                  [] -> Maybe [Char]
base_dir
                  [[Char]]
xs -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
last [[Char]]
xs)

  pure (ghc_path, ghc_dir)


#ifdef IN_GHC_TREE

-- | See 'getBaseDir' in "SysTools.BaseDir"
getBaseDir :: IO (Maybe FilePath)
getBaseDir :: IO (Maybe [Char])
getBaseDir = do

  -- Getting executable path can fail. Turn that into 'Nothing'
  exec_path_opt <- IO (Maybe [Char])
-> (SomeException -> IO (Maybe [Char])) -> IO (Maybe [Char])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> IO [Char] -> IO (Maybe [Char])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
getExecutablePath)
                         (\(SomeException
_ :: SomeException) -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing)

  -- Check that the path we are about to return actually exists
  case exec_path_opt of
    Maybe [Char]
Nothing -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
    Just [Char]
exec_path -> do
      let base_dir :: [Char]
base_dir = [Char] -> [Char]
takeDirectory ([Char] -> [Char]
takeDirectory [Char]
exec_path) [Char] -> [Char] -> [Char]
</> [Char]
"lib"
      exists <- [Char] -> IO Bool
doesDirectoryExist [Char]
base_dir
      pure (if exists then Just base_dir else Nothing)

#endif

shortcutFlags :: [Flag] -> IO ()
shortcutFlags :: [Flag] -> IO ()
shortcutFlags [Flag]
flags = do
  usage <- IO [Char]
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
    path <- fmap fst (getGhcDirs flags)
    bye $ fromMaybe "not available" path ++ "\n"

  when (Flag_PrintGhcLibDir `elem` flags) $ do
    dir <- fmap snd (getGhcDirs flags)
    bye $ fromMaybe "not available" 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/--html 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 :: IO a
byeVersion = [Char] -> IO a
forall a. [Char] -> IO a
bye ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$
      [Char]
"Haddock version " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
projectVersion [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", (c) Simon Marlow 2006\n"
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Ported to use the GHC API by David Waern 2006-2008\n"


-- | Generate some warnings about potential misuse of @--hyperlinked-source@.
hypSrcWarnings :: [Flag] -> IO ()
hypSrcWarnings :: [Flag] -> IO ()
hypSrcWarnings [Flag]
flags = do
    Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool
hypSrc Bool -> Bool -> Bool
&& (Flag -> Bool) -> [Flag] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any Flag -> Bool
isSourceUrlFlag [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat
            [ [Char]
"Warning: "
            , [Char]
"--source-* options are ignored when "
            , [Char]
"--hyperlinked-source is enabled."
            ]
    Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
hypSrc Bool -> Bool -> Bool
&& (Flag -> Bool) -> [Flag] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any Flag -> Bool
isSourceCssFlag [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat
            [ [Char]
"Warning: "
            , [Char]
"source CSS file is specified but "
            , [Char]
"--hyperlinked-source is disabled."
            ]
  where
    hypSrc :: Bool
    hypSrc :: Bool
hypSrc = Flag
Flag_HyperlinkedSource Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Flag]
flags

    isSourceUrlFlag :: Flag -> Bool
    isSourceUrlFlag :: Flag -> Bool
isSourceUrlFlag (Flag_SourceBaseURL [Char]
_) = Bool
True
    isSourceUrlFlag (Flag_SourceModuleURL [Char]
_) = Bool
True
    isSourceUrlFlag (Flag_SourceEntityURL [Char]
_) = Bool
True
    isSourceUrlFlag (Flag_SourceLEntityURL [Char]
_) = Bool
True
    isSourceUrlFlag Flag
_ = Bool
False

    isSourceCssFlag :: Flag -> Bool
    isSourceCssFlag :: Flag -> Bool
isSourceCssFlag (Flag_SourceCss [Char]
_) = Bool
True
    isSourceCssFlag Flag
_ = Bool
False


updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO ()
updateHTMLXRefs :: [([Char], InterfaceFile)] -> IO ()
updateHTMLXRefs [([Char], InterfaceFile)]
packages = do
  let !modMap :: Map Module [Char]
modMap     = Map Module [Char] -> Map Module [Char]
forall a. NFData a => a -> a
force (Map Module [Char] -> Map Module [Char])
-> Map Module [Char] -> Map Module [Char]
forall a b. (a -> b) -> a -> b
$ [(Module, [Char])] -> Map Module [Char]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Module, [Char])]
mapping
      !modNameMap :: Map ModuleName [Char]
modNameMap = Map ModuleName [Char] -> Map ModuleName [Char]
forall a. NFData a => a -> a
force (Map ModuleName [Char] -> Map ModuleName [Char])
-> Map ModuleName [Char] -> Map ModuleName [Char]
forall a b. (a -> b) -> a -> b
$ [(ModuleName, [Char])] -> Map ModuleName [Char]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ModuleName, [Char])]
mapping'
  IORef (Map Module [Char]) -> Map Module [Char] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Map Module [Char])
html_xrefs_ref  Map Module [Char]
modMap
  IORef (Map ModuleName [Char]) -> Map ModuleName [Char] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Map ModuleName [Char])
html_xrefs_ref' Map ModuleName [Char]
modNameMap
  where
    mapping :: [(Module, [Char])]
mapping = [ (InstalledInterface -> Module
instMod InstalledInterface
iface, [Char]
html) | ([Char]
html, InterfaceFile
ifaces) <- [([Char], InterfaceFile)]
packages
              , InstalledInterface
iface <- InterfaceFile -> [InstalledInterface]
ifInstalledIfaces InterfaceFile
ifaces ]
    mapping' :: [(ModuleName, [Char])]
mapping' = [ (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m, [Char]
html) | (Module
m, [Char]
html) <- [(Module, [Char])]
mapping ]


getPrologue :: ParserOpts -> [Flag] -> IO (Maybe (MDoc RdrName))
getPrologue :: ParserOpts -> [Flag] -> IO (Maybe (MDoc RdrName))
getPrologue ParserOpts
parserOpts [Flag]
flags =
  case [[Char]
filename | Flag_Prologue [Char]
filename <- [Flag]
flags ] of
    [] -> Maybe (MDoc RdrName) -> IO (Maybe (MDoc RdrName))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (MDoc RdrName)
forall a. Maybe a
Nothing
    [[Char]
filename] -> do
      h <- [Char] -> IOMode -> IO Handle
openFile [Char]
filename IOMode
ReadMode
      hSetEncoding h utf8
      str <- hGetContents h -- semi-closes the handle
      return . Just $! second (fmap rdrName) $ parseParas parserOpts Nothing str
    [[Char]]
_ -> [Char] -> IO (Maybe (MDoc RdrName))
forall a. [Char] -> a
throwE [Char]
"multiple -p/--prologue options"


rightOrThrowE :: Either String b -> IO b
rightOrThrowE :: forall b. Either [Char] b -> IO b
rightOrThrowE (Left [Char]
msg) = [Char] -> IO b
forall a. [Char] -> a
throwE [Char]
msg
rightOrThrowE (Right b
x) = b -> IO b
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure b
x