    {-# 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)
    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)
                                        }

          -- 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 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
      -> ParserOpts
      -> Logger
      -> UnitState
      -> [Flag]
      -> SinceQual
      -> QualOption
      -> [(DocPaths, Visibility, FilePath, InterfaceFile)]
      -> [Interface]
      -> IO ()
    renderStep :: DynFlags
    -> ParserOpts
    -> Logger
    -> UnitState
    -> [Flag]
    -> SinceQual
    -> QualOption
    -> [(DocPaths, Visibility, [Char], InterfaceFile)]
    -> [Interface]
    -> IO ()
    renderStep DynFlags
    dflags 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]
    </> GenUnit UnitId -> [Char]
    packageName (InterfaceFile -> GenUnit UnitId
    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
    -> ParserOpts
    -> Logger
    -> UnitState
    -> [Flag]
    -> SinceQual
    -> QualOption
    -> [Interface]
    -> [([Char], PackageInterfaces)]
    -> Map Module [Char]
    -> IO ()
    render DynFlags
    dflags 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 :: GenUnit UnitId -> [Char]
    packageName GenUnit UnitId
    unit =
          case UnitState -> GenUnit UnitId -> Maybe UnitInfo
    lookupUnit UnitState
    unit_state GenUnit UnitId
    unit of
            Maybe UnitInfo
    Nothing  -> GenUnit UnitId -> [Char]
    forall a. Show a => a -> [Char]
    show GenUnit UnitId
    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
      -> ParserOpts
      -> Logger
      -> UnitState
      -> [Flag]
      -> SinceQual
      -> QualOption
      -> [Interface]
      -> [(FilePath, PackageInterfaces)]
      -> Map Module FilePath
      -> IO ()
    render :: DynFlags
    -> ParserOpts
    -> Logger
    -> UnitState
    -> [Flag]
    -> SinceQual
    -> QualOption
    -> [Interface]
    -> [([Char], PackageInterfaces)]
    -> Map Module [Char]
    -> IO ()
    render DynFlags
    dflags 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 (GenUnit UnitId)
    pkgKey           = (Module -> GenUnit UnitId)
    -> Maybe Module -> Maybe (GenUnit UnitId)
    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 -> GenUnit UnitId
    forall unit. GenModule unit -> unit
    moduleUnit Maybe Module
    pkgMod
        pkgStr :: Maybe [Char]
    pkgStr           = (GenUnit UnitId -> [Char])
    -> Maybe (GenUnit UnitId) -> 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 GenUnit UnitId -> [Char]
    forall u. IsUnitId u => u -> [Char]
    unitString Maybe (GenUnit UnitId)
    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 (GenUnit UnitId) [Char]
    pkgSrcMap = ([Char] -> [Char])
    -> Map (GenUnit UnitId) [Char] -> Map (GenUnit UnitId) [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 (GenUnit UnitId) [Char] -> Map (GenUnit UnitId) [Char])
    -> Map (GenUnit UnitId) [Char] -> Map (GenUnit UnitId) [Char]
    forall a b. (a -> b) -> a -> b
    $ (Module -> GenUnit UnitId)
    -> Map Module [Char] -> Map (GenUnit UnitId) [Char]
    forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
    Map.mapKeys Module -> GenUnit UnitId
    forall unit. GenModule unit -> unit
    moduleUnit Map Module [Char]
    extSrcMap
        pkgSrcMap' :: Map (GenUnit UnitId) [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 GenUnit UnitId
    k <- Maybe (GenUnit UnitId)
    pkgKey
          = GenUnit UnitId
    -> [Char]
    -> Map (GenUnit UnitId) [Char]
    -> Map (GenUnit UnitId) [Char]
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert GenUnit UnitId
    k [Char]
    hypSrcModuleNameUrlFormat Map (GenUnit UnitId) [Char]
    pkgSrcMap
          | Just [Char]
    srcNameUrl <- Maybe [Char]
    srcEntity
          , Just GenUnit UnitId
    k <- Maybe (GenUnit UnitId)
    pkgKey
          = GenUnit UnitId
    -> [Char]
    -> Map (GenUnit UnitId) [Char]
    -> Map (GenUnit UnitId) [Char]
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert GenUnit UnitId
    k [Char]
    srcNameUrl Map (GenUnit UnitId) [Char]
    pkgSrcMap
          | Bool
    otherwise = Map (GenUnit UnitId) [Char]
    pkgSrcMap

        pkgSrcLMap :: Map (GenUnit UnitId) [Char]
    pkgSrcLMap = ([Char] -> [Char])
    -> Map (GenUnit UnitId) [Char] -> Map (GenUnit UnitId) [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 (GenUnit UnitId) [Char] -> Map (GenUnit UnitId) [Char])
    -> Map (GenUnit UnitId) [Char] -> Map (GenUnit UnitId) [Char]
    forall a b. (a -> b) -> a -> b
    $ (Module -> GenUnit UnitId)
    -> Map Module [Char] -> Map (GenUnit UnitId) [Char]
    forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
    Map.mapKeys Module -> GenUnit UnitId
    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 (GenUnit UnitId) [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 GenUnit UnitId
    k <- Maybe (GenUnit UnitId)
    pkgKey
          = GenUnit UnitId
    -> [Char]
    -> Map (GenUnit UnitId) [Char]
    -> Map (GenUnit UnitId) [Char]
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert GenUnit UnitId
    k [Char]
    hypSrcModuleLineUrlFormat Map (GenUnit UnitId) [Char]
    pkgSrcLMap
          | Just [Char]
    path <- Maybe [Char]
    srcLEntity
          , Just GenUnit UnitId
    k <- Maybe (GenUnit UnitId)
    pkgKey
          = GenUnit UnitId
    -> [Char]
    -> Map (GenUnit UnitId) [Char]
    -> Map (GenUnit UnitId) [Char]
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert GenUnit UnitId
    k [Char]
    path Map (GenUnit UnitId) [Char]
    pkgSrcLMap
          | Bool
    otherwise = Map (GenUnit UnitId) [Char]
    pkgSrcLMap

        sourceUrls' :: (Maybe [Char], Maybe [Char], Map (GenUnit UnitId) [Char],
     Map (GenUnit UnitId) [Char])
    sourceUrls' = (Maybe [Char]
    srcBase, Maybe [Char]
    srcModule', Map (GenUnit UnitId) [Char]
    pkgSrcMap', Map (GenUnit UnitId) [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)) 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