{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock
-- Copyright   :  (c) Simon Marlow 2003-2006,
--                    David Waern  2006-2010,
--                    Mateusz Kowalczyk 2014
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Haddock - A Haskell Documentation Tool
--
-- Program entry point and top-level code.
-----------------------------------------------------------------------------
module Haddock (
  haddock,
  haddockWithGhc,
  getGhcDirs,
  readPackagesAndProcessModules,
  withGhc
) where

import Haddock.Backends.Xhtml
import Haddock.Backends.Xhtml.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 Control.Monad hiding (forM_)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bifunctor (second)
import Data.Foldable (forM_, foldl')
import Data.Traversable (for)
import Data.List (isPrefixOf)
import Control.Exception
import Data.Maybe
import Data.IORef
import Data.Map (Map)
import Data.Version (makeVersion)
import qualified Data.Map as Map
import System.IO
import System.Exit

#ifdef IN_GHC_TREE
import System.FilePath
import System.Environment (getExecutablePath)
#else
import qualified GHC.Paths as GhcPaths
import Paths_haddock_api (getDataDir)
#endif
import System.Directory (doesDirectoryExist, getTemporaryDirectory)
import System.FilePath ((</>))

import Text.ParserCombinators.ReadP (readP_to_S)
import GHC hiding (verbosity)
import Config
import DynFlags hiding (projectVersion, verbosity)
import ErrUtils
import Packages
import Panic (handleGhcException)
import Module
import FastString
import Outputable (defaultUserStyle)

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


handleTopExceptions :: IO a -> IO a
handleTopExceptions :: 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 :: 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
           String -> IO ()
putStrLn String
"stack overflow: use -g +RTS -K<size> to increase it"
           IO a
forall a. IO a
exitFailure
         AsyncException
_ -> do
           String -> IO ()
putStrLn (String
"haddock: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AsyncException -> String
forall a. Show a => a -> String
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
        String -> IO ()
putStrLn (String
"haddock: internal error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
ex)
        IO a
forall a. IO a
exitFailure)
  ]


handleHaddockExceptions :: IO a -> IO a
handleHaddockExceptions :: 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
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"haddock: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HaddockException -> String
forall a. Show a => a -> String
show HaddockException
e
      IO b
forall a. IO a
exitFailure


handleGhcExceptions :: IO a -> IO a
handleGhcExceptions :: IO a -> IO a
handleGhcExceptions =
  -- error messages propagated as exceptions
  (GhcException -> IO a) -> IO a -> IO a
forall (m :: * -> *) 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 :: [String] -> IO ()
haddock [String]
args = (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO ()
haddockWithGhc forall a. [Flag] -> Ghc a -> IO a
withGhc [String]
args

haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO ()
haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO ()
haddockWithGhc forall a. [Flag] -> Ghc a -> IO a
ghc [String]
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.
  ([Flag]
flags, [String]
files) <- [String] -> IO ([Flag], [String])
parseHaddockOpts [String]
args
  [Flag] -> IO ()
shortcutFlags [Flag]
flags
  QualOption
qual <- Either String QualOption -> IO QualOption
forall b. Either String b -> IO b
rightOrThrowE ([Flag] -> Either String QualOption
qualification [Flag]
flags)
  SinceQual
sinceQual <- Either String SinceQual -> IO SinceQual
forall b. Either String b -> IO b
rightOrThrowE ([Flag] -> Either String SinceQual
sinceQualification [Flag]
flags)

  -- inject dynamic-too into flags before we proceed
  [Flag]
flags' <- [Flag] -> Ghc [Flag] -> IO [Flag]
forall a. [Flag] -> Ghc a -> IO a
ghc [Flag]
flags (Ghc [Flag] -> IO [Flag]) -> Ghc [Flag] -> IO [Flag]
forall a b. (a -> b) -> a -> b
$ do
        DynFlags
df <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"GHC Dynamic" (DynFlags -> [(String, String)]
compilerInfo DynFlags
df) of
          Just String
"YES" -> [Flag] -> Ghc [Flag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Flag] -> Ghc [Flag]) -> [Flag] -> Ghc [Flag]
forall a b. (a -> b) -> a -> b
$ String -> Flag
Flag_OptGhc String
"-dynamic-too" Flag -> [Flag] -> [Flag]
forall a. a -> [a] -> [a]
: [Flag]
flags
          Maybe String
_ -> [Flag] -> Ghc [Flag]
forall (m :: * -> *) a. Monad m => a -> m a
return [Flag]
flags

  -- bypass the interface version check
  let noChecks :: Bool
noChecks = Flag
Flag_BypassInterfaceVersonCheck Flag -> [Flag] -> Bool
forall (t :: * -> *) 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 :: Ghc a -> Ghc a
withDir | Flag
Flag_NoTmpCompDir Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags = Ghc a -> Ghc a
forall a. a -> a
id
              | Bool
otherwise = Ghc a -> Ghc a
forall a. Ghc a -> Ghc a
withTempOutputDir

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Flag
Flag_NoWarnings Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Flag] -> IO ()
hypSrcWarnings [Flag]
flags
    [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([String] -> [String]
warnings [String]
args) ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
warning -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
warning
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
noChecks (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
noCheckWarning

  [Flag] -> Ghc () -> IO ()
forall a. [Flag] -> Ghc a -> IO a
ghc [Flag]
flags' (Ghc () -> IO ()) -> Ghc () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ghc () -> Ghc ()
forall a. Ghc a -> Ghc a
withDir (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
    DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    Maybe String -> (String -> Ghc ()) -> Ghc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Flag] -> Maybe String
optShowInterfaceFile [Flag]
flags) ((String -> Ghc ()) -> Ghc ()) -> (String -> Ghc ()) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ \String
path -> IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
      [(DocPaths, InterfaceFile)]
mIfaceFile <- NameCacheAccessor IO
-> [(DocPaths, String)] -> Bool -> IO [(DocPaths, InterfaceFile)]
forall (m :: * -> *).
MonadIO m =>
NameCacheAccessor m
-> [(DocPaths, String)] -> Bool -> m [(DocPaths, InterfaceFile)]
readInterfaceFiles NameCacheAccessor IO
freshNameCache [((String
"", Maybe String
forall a. Maybe a
Nothing), String
path)] Bool
noChecks
      [(DocPaths, InterfaceFile)]
-> ((DocPaths, InterfaceFile) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(DocPaths, InterfaceFile)]
mIfaceFile (((DocPaths, InterfaceFile) -> IO ()) -> IO ())
-> ((DocPaths, InterfaceFile) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(DocPaths
_, InterfaceFile
ifaceFile) -> do
        DynFlags -> PprStyle -> MsgDoc -> IO ()
logOutput DynFlags
dflags (DynFlags -> PprStyle
defaultUserStyle DynFlags
dflags) (JsonDoc -> MsgDoc
renderJson (InterfaceFile -> JsonDoc
jsonInterfaceFile InterfaceFile
ifaceFile))

    if Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files) then do
      ([(DocPaths, InterfaceFile)]
packages, [Interface]
ifaces, LinkEnv
homeLinks) <- [Flag]
-> [String]
-> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
readPackagesAndProcessModules [Flag]
flags [String]
files

      -- Dump an "interface file" (.haddock file), if requested.
      Maybe String -> (String -> Ghc ()) -> Ghc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Flag] -> Maybe String
optDumpInterfaceFile [Flag]
flags) ((String -> Ghc ()) -> Ghc ()) -> (String -> Ghc ()) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ \String
path -> IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
        String -> InterfaceFile -> IO ()
writeInterfaceFile String
path InterfaceFile :: LinkEnv -> [InstalledInterface] -> InterfaceFile
InterfaceFile {
            ifInstalledIfaces :: [InstalledInterface]
ifInstalledIfaces = (Interface -> InstalledInterface)
-> [Interface] -> [InstalledInterface]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> InstalledInterface
toInstalledIface [Interface]
ifaces
          , ifLinkEnv :: LinkEnv
ifLinkEnv         = LinkEnv
homeLinks
          }

      -- Render the interfaces.
      IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Flag]
-> SinceQual
-> QualOption
-> [(DocPaths, InterfaceFile)]
-> [Interface]
-> IO ()
renderStep DynFlags
dflags [Flag]
flags SinceQual
sinceQual QualOption
qual [(DocPaths, InterfaceFile)]
packages [Interface]
ifaces

    else do
      Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Flag -> Bool) -> [Flag] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag
Flag_Html, Flag
Flag_Hoogle, Flag
Flag_LaTeX]) [Flag]
flags) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$
        String -> Ghc ()
forall a. String -> a
throwE String
"No input file(s)."

      -- Get packages supplied with --read-interface.
      [(DocPaths, InterfaceFile)]
packages <- IO [(DocPaths, InterfaceFile)] -> Ghc [(DocPaths, InterfaceFile)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(DocPaths, InterfaceFile)] -> Ghc [(DocPaths, InterfaceFile)])
-> IO [(DocPaths, InterfaceFile)]
-> Ghc [(DocPaths, InterfaceFile)]
forall a b. (a -> b) -> a -> b
$ NameCacheAccessor IO
-> [(DocPaths, String)] -> Bool -> IO [(DocPaths, InterfaceFile)]
forall (m :: * -> *).
MonadIO m =>
NameCacheAccessor m
-> [(DocPaths, String)] -> Bool -> m [(DocPaths, InterfaceFile)]
readInterfaceFiles NameCacheAccessor IO
freshNameCache ([Flag] -> [(DocPaths, String)]
readIfaceArgs [Flag]
flags) Bool
noChecks

      -- Render even though there are no input files (usually contents/index).
      IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Flag]
-> SinceQual
-> QualOption
-> [(DocPaths, InterfaceFile)]
-> [Interface]
-> IO ()
renderStep DynFlags
dflags [Flag]
flags SinceQual
sinceQual QualOption
qual [(DocPaths, InterfaceFile)]
packages []

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

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

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

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

  -- Catches all GHC source errors, then prints and re-throws them.
  let handleSrcErrors :: m a -> m a
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 :: * -> *) a.
ExceptionMonad 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 :: * -> *). GhcMonad m => SourceError -> m ()
printException SourceError
err
        IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
forall a. IO a
exitFailure
      needHieFiles :: Bool
needHieFiles = Flag
Flag_HyperlinkedSource Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags

  String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a
forall a. String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a
withGhc' String
libDir Bool
needHieFiles ([Flag] -> [String]
ghcFlags [Flag]
flags) (\DynFlags
_ -> Ghc a -> Ghc a
forall (m :: * -> *) a. GhcMonad m => m a -> m a
handleSrcErrors Ghc a
action)


readPackagesAndProcessModules :: [Flag] -> [String]
                              -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
readPackagesAndProcessModules :: [Flag]
-> [String]
-> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
readPackagesAndProcessModules [Flag]
flags [String]
files = do
    -- Get packages supplied with --read-interface.
    let noChecks :: Bool
noChecks = Flag
Flag_BypassInterfaceVersonCheck Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags
    [(DocPaths, InterfaceFile)]
packages <- NameCacheAccessor Ghc
-> [(DocPaths, String)] -> Bool -> Ghc [(DocPaths, InterfaceFile)]
forall (m :: * -> *).
MonadIO m =>
NameCacheAccessor m
-> [(DocPaths, String)] -> Bool -> m [(DocPaths, InterfaceFile)]
readInterfaceFiles NameCacheAccessor Ghc
forall (m :: * -> *). GhcMonad m => NameCacheAccessor m
nameCacheFromGhc ([Flag] -> [(DocPaths, String)]
readIfaceArgs [Flag]
flags) Bool
noChecks

    -- Create the interfaces -- this is the core part of Haddock.
    let ifaceFiles :: [InterfaceFile]
ifaceFiles = ((DocPaths, InterfaceFile) -> InterfaceFile)
-> [(DocPaths, InterfaceFile)] -> [InterfaceFile]
forall a b. (a -> b) -> [a] -> [b]
map (DocPaths, InterfaceFile) -> InterfaceFile
forall a b. (a, b) -> b
snd [(DocPaths, InterfaceFile)]
packages
    ([Interface]
ifaces, LinkEnv
homeLinks) <- Verbosity
-> [String]
-> [Flag]
-> [InterfaceFile]
-> Ghc ([Interface], LinkEnv)
processModules ([Flag] -> Verbosity
verbosity [Flag]
flags) [String]
files [Flag]
flags [InterfaceFile]
ifaceFiles

    ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
-> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(DocPaths, InterfaceFile)]
packages, [Interface]
ifaces, LinkEnv
homeLinks)


renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption
           -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
renderStep :: DynFlags
-> [Flag]
-> SinceQual
-> QualOption
-> [(DocPaths, InterfaceFile)]
-> [Interface]
-> IO ()
renderStep DynFlags
dflags [Flag]
flags SinceQual
sinceQual QualOption
nameQual [(DocPaths, InterfaceFile)]
pkgs [Interface]
interfaces = do
  [(DocPaths, InterfaceFile)] -> IO ()
updateHTMLXRefs [(DocPaths, InterfaceFile)]
pkgs
  let
    ifaceFiles :: [InterfaceFile]
ifaceFiles = ((DocPaths, InterfaceFile) -> InterfaceFile)
-> [(DocPaths, InterfaceFile)] -> [InterfaceFile]
forall a b. (a -> b) -> [a] -> [b]
map (DocPaths, InterfaceFile) -> InterfaceFile
forall a b. (a, b) -> b
snd [(DocPaths, InterfaceFile)]
pkgs
    installedIfaces :: [InstalledInterface]
installedIfaces = (InterfaceFile -> [InstalledInterface])
-> [InterfaceFile] -> [InstalledInterface]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap InterfaceFile -> [InstalledInterface]
ifInstalledIfaces [InterfaceFile]
ifaceFiles
    extSrcMap :: Map Module String
extSrcMap = [(Module, String)] -> Map Module String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Module, String)] -> Map Module String)
-> [(Module, String)] -> Map Module String
forall a b. (a -> b) -> a -> b
$ do
      ((String
_, Just String
path), InterfaceFile
ifile) <- [(DocPaths, InterfaceFile)]
pkgs
      InstalledInterface
iface <- InterfaceFile -> [InstalledInterface]
ifInstalledIfaces InterfaceFile
ifile
      (Module, String) -> [(Module, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledInterface -> Module
instMod InstalledInterface
iface, String
path)
  DynFlags
-> [Flag]
-> SinceQual
-> QualOption
-> [Interface]
-> [InstalledInterface]
-> Map Module String
-> IO ()
render DynFlags
dflags [Flag]
flags SinceQual
sinceQual QualOption
nameQual [Interface]
interfaces [InstalledInterface]
installedIfaces Map Module String
extSrcMap

-- | Render the interfaces with whatever backend is specified in the flags.
render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface]
       -> [InstalledInterface] -> Map Module FilePath -> IO ()
render :: DynFlags
-> [Flag]
-> SinceQual
-> QualOption
-> [Interface]
-> [InstalledInterface]
-> Map Module String
-> IO ()
render DynFlags
dflags [Flag]
flags SinceQual
sinceQual QualOption
qual [Interface]
ifaces [InstalledInterface]
installedIfaces Map Module String
extSrcMap = do

  let
    title :: String
title                = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" ([Flag] -> Maybe String
optTitle [Flag]
flags)
    unicode :: Bool
unicode              = Flag
Flag_UseUnicode Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags
    pretty :: Bool
pretty               = Flag
Flag_PrettyHtml Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags
    opt_wiki_urls :: (Maybe String, Maybe String, Maybe String)
opt_wiki_urls        = [Flag] -> (Maybe String, Maybe String, Maybe String)
wikiUrls          [Flag]
flags
    opt_contents_url :: Maybe String
opt_contents_url     = [Flag] -> Maybe String
optContentsUrl    [Flag]
flags
    opt_index_url :: Maybe String
opt_index_url        = [Flag] -> Maybe String
optIndexUrl       [Flag]
flags
    odir :: String
odir                 = [Flag] -> String
outputDir         [Flag]
flags
    opt_latex_style :: Maybe String
opt_latex_style      = [Flag] -> Maybe String
optLaTeXStyle     [Flag]
flags
    opt_source_css :: Maybe String
opt_source_css       = [Flag] -> Maybe String
optSourceCssFile  [Flag]
flags
    opt_mathjax :: Maybe String
opt_mathjax          = [Flag] -> Maybe String
optMathjax        [Flag]
flags
    dflags' :: DynFlags
dflags'
      | Bool
unicode          = DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags GeneralFlag
Opt_PrintUnicodeSyntax
      | Bool
otherwise        = DynFlags
dflags

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

    -- /All/ visible interfaces including external package modules.
    allIfaces :: [InstalledInterface]
allIfaces        = (Interface -> InstalledInterface)
-> [Interface] -> [InstalledInterface]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> InstalledInterface
toInstalledIface [Interface]
ifaces [InstalledInterface]
-> [InstalledInterface] -> [InstalledInterface]
forall a. [a] -> [a] -> [a]
++ [InstalledInterface]
installedIfaces
    allVisibleIfaces :: [InstalledInterface]
allVisibleIfaces = [ InstalledInterface
i | InstalledInterface
i <- [InstalledInterface]
allIfaces, DocOption
OptHide DocOption -> [DocOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` InstalledInterface -> [DocOption]
instOptions InstalledInterface
i ]

    pkgMod :: Maybe Module
pkgMod           = (Interface -> Module) -> Maybe Interface -> Maybe Module
forall (f :: * -> *) 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 UnitId
pkgKey           = (Module -> UnitId) -> Maybe Module -> Maybe UnitId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> UnitId
moduleUnitId Maybe Module
pkgMod
    pkgStr :: Maybe String
pkgStr           = (UnitId -> String) -> Maybe UnitId -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnitId -> String
unitIdString Maybe UnitId
pkgKey
    pkgNameVer :: (Maybe PackageName, Maybe Version)
pkgNameVer       = DynFlags
-> [Flag] -> Maybe Module -> (Maybe PackageName, Maybe Version)
modulePackageInfo DynFlags
dflags [Flag]
flags Maybe Module
pkgMod
    pkgName :: Maybe String
pkgName          = (PackageName -> String) -> Maybe PackageName -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FastString -> String
unpackFS (FastString -> String)
-> (PackageName -> FastString) -> PackageName -> String
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 String
sincePkg         = case SinceQual
sinceQual of
                         SinceQual
External -> Maybe String
pkgName
                         SinceQual
Always -> Maybe String
forall a. Maybe a
Nothing

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

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

    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
      ((String -> SrcPath) -> Map Module String -> Map Module SrcPath
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map String -> SrcPath
SrcExternal Map Module String
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 ])

    pkgSrcMap :: Map UnitId String
pkgSrcMap = (Module -> UnitId) -> Map Module String -> Map UnitId String
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Module -> UnitId
moduleUnitId Map Module String
extSrcMap
    pkgSrcMap' :: Map UnitId String
pkgSrcMap'
      | Flag
Flag_HyperlinkedSource Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags
      , Just UnitId
k <- Maybe UnitId
pkgKey
      = UnitId -> String -> Map UnitId String -> Map UnitId String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert UnitId
k String
hypSrcModuleNameUrlFormat Map UnitId String
pkgSrcMap
      | Just String
srcNameUrl <- Maybe String
srcEntity
      , Just UnitId
k <- Maybe UnitId
pkgKey
      = UnitId -> String -> Map UnitId String -> Map UnitId String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert UnitId
k String
srcNameUrl Map UnitId String
pkgSrcMap
      | Bool
otherwise = Map UnitId String
pkgSrcMap

    -- TODO: Get these from the interface files as with srcMap
    pkgSrcLMap' :: Map UnitId String
pkgSrcLMap'
      | Flag
Flag_HyperlinkedSource Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags
      , Just UnitId
k <- Maybe UnitId
pkgKey
      = UnitId -> String -> Map UnitId String
forall k a. k -> a -> Map k a
Map.singleton UnitId
k String
hypSrcModuleLineUrlFormat
      | Just String
path <- Maybe String
srcLEntity
      , Just UnitId
k <- Maybe UnitId
pkgKey
      = UnitId -> String -> Map UnitId String
forall k a. k -> a -> Map k a
Map.singleton UnitId
k String
path
      | Bool
otherwise = Map UnitId String
forall k a. Map k a
Map.empty

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

    -- 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 { moduleUnitId :: UnitId
moduleUnitId = DynFlags -> UnitId -> UnitId
unwireUnitId DynFlags
dflags (Module -> UnitId
moduleUnitId Module
m) }

  [InstalledInterface]
reexportedIfaces <- [[InstalledInterface]] -> [InstalledInterface]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[InstalledInterface]] -> [InstalledInterface])
-> IO [[InstalledInterface]] -> IO [InstalledInterface]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ([String]
-> (String -> IO [InstalledInterface]) -> IO [[InstalledInterface]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Flag] -> [String]
reexportFlags [Flag]
flags) ((String -> IO [InstalledInterface]) -> IO [[InstalledInterface]])
-> (String -> IO [InstalledInterface]) -> IO [[InstalledInterface]]
forall a b. (a -> b) -> a -> b
$ \String
mod_str -> do
    let warn :: String -> IO ()
warn = Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Warning: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
    case ReadP Module -> ReadS Module
forall a. ReadP a -> ReadS a
readP_to_S ReadP Module
parseModuleId String
mod_str of
      [(Module
m, String
"")]
        | 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 (m :: * -> *) a. Monad m => a -> m a
return [InstalledInterface
iface]
        | Bool
otherwise
        -> String -> IO ()
warn (String
"Cannot find reexported module '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mod_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'") IO () -> IO [InstalledInterface] -> IO [InstalledInterface]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [InstalledInterface] -> IO [InstalledInterface]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      [(Module, String)]
_ -> String -> IO ()
warn (String
"Cannot parse reexported module flag '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mod_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'") IO () -> IO [InstalledInterface] -> IO [InstalledInterface]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [InstalledInterface] -> IO [InstalledInterface]
forall (m :: * -> *) a. Monad m => a -> m a
return [])

  String
libDir   <- [Flag] -> IO String
getHaddockLibDir [Flag]
flags
  Maybe (MDoc RdrName)
prologue <- DynFlags -> [Flag] -> IO (Maybe (MDoc RdrName))
getPrologue DynFlags
dflags' [Flag]
flags
  Themes
themes   <- String -> [Flag] -> IO PossibleThemes
getThemes String
libDir [Flag]
flags IO PossibleThemes -> (PossibleThemes -> IO Themes) -> IO Themes
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO Themes)
-> (Themes -> IO Themes) -> PossibleThemes -> IO Themes
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO Themes
forall a. String -> IO a
bye Themes -> IO Themes
forall (m :: * -> *) a. Monad m => a -> m a
return

  let withQuickjump :: Bool
withQuickjump = Flag
Flag_QuickJumpIndex Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_GenIndex Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    DynFlags -> MsgDoc -> (() -> ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> MsgDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags' MsgDoc
"ppHtmlIndex" (() -> () -> ()
forall a b. a -> b -> a
const ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ()
_ <- {-# SCC ppHtmlIndex #-}
           String
-> String
-> Maybe String
-> Themes
-> Maybe String
-> Maybe String
-> (Maybe String, Maybe String, Map UnitId String,
    Map UnitId String)
-> (Maybe String, Maybe String, Maybe String)
-> [InstalledInterface]
-> Bool
-> IO ()
ppHtmlIndex String
odir String
title Maybe String
pkgStr
                  Themes
themes Maybe String
opt_mathjax Maybe String
opt_contents_url (Maybe String, Maybe String, Map UnitId String, Map UnitId String)
sourceUrls' (Maybe String, Maybe String, Maybe String)
opt_wiki_urls
                  [InstalledInterface]
allVisibleIfaces Bool
pretty
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    String -> String -> Themes -> Bool -> IO ()
copyHtmlBits String
odir String
libDir Themes
themes Bool
withQuickjump

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_GenContents Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    DynFlags -> MsgDoc -> (() -> ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> MsgDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags' MsgDoc
"ppHtmlContents" (() -> () -> ()
forall a b. a -> b -> a
const ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ()
_ <- {-# SCC ppHtmlContents #-}
           DynFlags
-> String
-> String
-> Maybe String
-> Themes
-> Maybe String
-> Maybe String
-> (Maybe String, Maybe String, Map UnitId String,
    Map UnitId String)
-> (Maybe String, Maybe String, Maybe String)
-> [InstalledInterface]
-> Bool
-> Maybe (MDoc RdrName)
-> Bool
-> Maybe String
-> Qualification
-> IO ()
ppHtmlContents DynFlags
dflags' String
odir String
title Maybe String
pkgStr
                     Themes
themes Maybe String
opt_mathjax Maybe String
opt_index_url (Maybe String, Maybe String, Map UnitId String, Map UnitId String)
sourceUrls' (Maybe String, Maybe String, Maybe String)
opt_wiki_urls
                     [InstalledInterface]
allVisibleIfaces Bool
True Maybe (MDoc RdrName)
prologue Bool
pretty
                     Maybe String
sincePkg (QualOption -> Qualification
makeContentsQual QualOption
qual)
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String -> String -> Themes -> Bool -> IO ()
copyHtmlBits String
odir String
libDir Themes
themes Bool
withQuickjump

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_Html Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    DynFlags -> MsgDoc -> (() -> ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> MsgDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags' MsgDoc
"ppHtml" (() -> () -> ()
forall a b. a -> b -> a
const ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ()
_ <- {-# SCC ppHtml #-}
           DynFlags
-> String
-> Maybe String
-> [Interface]
-> [InstalledInterface]
-> String
-> Maybe (MDoc RdrName)
-> Themes
-> Maybe String
-> (Maybe String, Maybe String, Map UnitId String,
    Map UnitId String)
-> (Maybe String, Maybe String, Maybe String)
-> Maybe String
-> Maybe String
-> Bool
-> Maybe String
-> QualOption
-> Bool
-> Bool
-> IO ()
ppHtml DynFlags
dflags' String
title Maybe String
pkgStr [Interface]
visibleIfaces [InstalledInterface]
reexportedIfaces String
odir
                  Maybe (MDoc RdrName)
prologue
                  Themes
themes Maybe String
opt_mathjax (Maybe String, Maybe String, Map UnitId String, Map UnitId String)
sourceUrls' (Maybe String, Maybe String, Maybe String)
opt_wiki_urls
                  Maybe String
opt_contents_url Maybe String
opt_index_url Bool
unicode Maybe String
sincePkg QualOption
qual
                  Bool
pretty Bool
withQuickjump
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String -> String -> Themes -> Bool -> IO ()
copyHtmlBits String
odir String
libDir Themes
themes Bool
withQuickjump
    String -> Bool -> IO ()
writeHaddockMeta String
odir Bool
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_Hoogle Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    case (Maybe PackageName, Maybe Version)
pkgNameVer of
      (Just (PackageName FastString
pkgNameFS), Maybe Version
mpkgVer) ->
          let
            pkgNameStr :: String
pkgNameStr | FastString -> String
unpackFS FastString
pkgNameFS String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"main" Bool -> Bool -> Bool
&& String
title String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= [] = String
title
                       | Bool
otherwise = FastString -> String
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
-> String
-> Version
-> String
-> Maybe (Doc RdrName)
-> [Interface]
-> String
-> IO ()
ppHoogle DynFlags
dflags' String
pkgNameStr Version
pkgVer String
title ((MDoc RdrName -> Doc RdrName)
-> Maybe (MDoc RdrName) -> Maybe (Doc RdrName)
forall (f :: * -> *) 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 String
odir
      (Maybe PackageName, Maybe Version)
_ -> String -> IO ()
putStrLn (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [ String
"haddock: Unable to find a package providing module "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Module -> String) -> Maybe Module -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"<no-mod>" (ModuleName -> String
moduleNameString (ModuleName -> String)
-> (Module -> ModuleName) -> Module -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
moduleName) Maybe Module
pkgMod
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", skipping Hoogle."
          , String
""
          , String
"         Perhaps try specifying the desired package explicitly"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" using the --package-name"
          , String
"         and --package-version arguments."
          ]

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_LaTeX Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    DynFlags -> MsgDoc -> (() -> ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> MsgDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags' MsgDoc
"ppLatex" (() -> () -> ()
forall a b. a -> b -> a
const ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ()
_ <- {-# SCC ppLatex #-}
           String
-> Maybe String
-> [Interface]
-> String
-> Maybe (Doc RdrName)
-> Maybe String
-> String
-> IO ()
ppLaTeX String
title Maybe String
pkgStr [Interface]
visibleIfaces String
odir ((MDoc RdrName -> Doc RdrName)
-> Maybe (MDoc RdrName) -> Maybe (Doc RdrName)
forall (f :: * -> *) 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) Maybe String
opt_latex_style
                   String
libDir
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_HyperlinkedSource Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags Bool -> Bool -> Bool
&& Bool -> Bool
not ([Interface] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Interface]
ifaces)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    DynFlags -> MsgDoc -> (() -> ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> MsgDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags' MsgDoc
"ppHyperlinkedSource" (() -> () -> ()
forall a b. a -> b -> a
const ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ()
_ <- {-# SCC ppHyperlinkedSource #-}
           Verbosity
-> String
-> String
-> Maybe String
-> Bool
-> Map Module SrcPath
-> [Interface]
-> IO ()
ppHyperlinkedSource ([Flag] -> Verbosity
verbosity [Flag]
flags) String
odir String
libDir Maybe String
opt_source_css Bool
pretty Map Module SrcPath
srcMap [Interface]
ifaces
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


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


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

  -- We disable pattern match warnings because than can be very
  -- expensive to check
  let dynflags'' :: DynFlags
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!
  [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
dynflags''
  DynFlags -> Ghc a
ghcActs DynFlags
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 :: [String] -> [String]
filterRtsFlags [String]
flgs = (String -> (Bool -> [String]) -> Bool -> [String])
-> (Bool -> [String]) -> [String] -> Bool -> [String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> (Bool -> [String]) -> Bool -> [String]
forall a. (Eq a, IsString a) => a -> (Bool -> [a]) -> Bool -> [a]
go ([String] -> Bool -> [String]
forall a b. a -> b -> a
const []) [String]
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 => DynFlags -> m DynFlags
    parseGhcFlags :: DynFlags -> m DynFlags
parseGhcFlags DynFlags
dynflags = do
      -- TODO: handle warnings?

      let extra_opts :: [GeneralFlag]
extra_opts | Bool
needHieFiles = [GeneralFlag
Opt_WriteHie, GeneralFlag
Opt_Haddock]
                     | Bool
otherwise = [GeneralFlag
Opt_Haddock]
          dynflags' :: DynFlags
dynflags' = ((DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dynflags [GeneralFlag]
extra_opts)
                        { hscTarget :: HscTarget
hscTarget = HscTarget
HscNothing
                        , ghcMode :: GhcMode
ghcMode   = GhcMode
CompManager
                        , ghcLink :: GhcLink
ghcLink   = GhcLink
NoLink
                        }
          flags' :: [String]
flags' = [String] -> [String]
filterRtsFlags [String]
flags

      (DynFlags
dynflags'', [Located String]
rest, [Warn]
_) <- DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlags DynFlags
dynflags' ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [String]
flags')
      if Bool -> Bool
not ([Located String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located String]
rest)
        then String -> m DynFlags
forall a. String -> a
throwE (String
"Couldn't parse GHC options: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
flags')
        else DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dynflags''

unsetPatternMatchWarnings :: DynFlags -> DynFlags
unsetPatternMatchWarnings :: DynFlags -> DynFlags
unsetPatternMatchWarnings DynFlags
dflags =
  (DynFlags -> WarningFlag -> DynFlags)
-> DynFlags -> [WarningFlag] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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 String
getHaddockLibDir [Flag]
flags =
  case [String
str | Flag_Lib String
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 <- getBaseDir      -- Provided by GHC
      let res_dirs = [ d | Just d <- [base_dir] ] ++

#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.
      String
data_dir <- IO String
getDataDir      -- Provided by Cabal
      let res_dirs :: [String]
res_dirs = [ String
data_dir ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++

#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 @./@
                     [ String
"resources"
                     , String
"haddock-api/resources"
                     ]

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

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

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

#ifdef IN_GHC_TREE
  base_dir <- getBaseDir
  let ghc_path = Nothing
#else
  let base_dir :: Maybe String
base_dir = String -> Maybe String
forall a. a -> Maybe a
Just String
GhcPaths.libdir
      ghc_path :: Maybe String
ghc_path = String -> Maybe String
forall a. a -> Maybe a
Just String
GhcPaths.ghc
#endif

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

  (Maybe String, Maybe String) -> IO (Maybe String, Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String
ghc_path, Maybe String
ghc_dir)


#ifdef IN_GHC_TREE

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

  -- Getting executable path can fail. Turn that into 'Nothing'
  exec_path_opt <- catch (Just <$> getExecutablePath)
                         (\(_ :: SomeException) -> pure Nothing)

  -- Check that the path we are about to return actually exists
  case exec_path_opt of
    Nothing -> pure Nothing
    Just exec_path -> do
      let base_dir = takeDirectory (takeDirectory exec_path) </> "lib"
      exists <- doesDirectoryExist base_dir
      pure (if exists then Just base_dir else Nothing)

#endif

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

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_Help             Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (String -> IO ()
forall a. String -> IO a
bye String
usage)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_Version          Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) IO ()
forall a. IO a
byeVersion
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_InterfaceVersion Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (String -> IO ()
forall a. String -> IO a
bye (Word16 -> String
forall a. Show a => a -> String
show Word16
binaryInterfaceVersion String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"))
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_CompatibleInterfaceVersions Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags)
    (String -> IO ()
forall a. String -> IO a
bye ([String] -> String
unwords ((Word16 -> String) -> [Word16] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word16 -> String
forall a. Show a => a -> String
show [Word16]
binaryInterfaceVersionCompatibility) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"))
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_GhcVersion       Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (String -> IO ()
forall a. String -> IO a
bye (String
cProjectVersion String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"))

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_PrintGhcPath Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe String
path <- ((Maybe String, Maybe String) -> Maybe String)
-> IO (Maybe String, Maybe String) -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe String, Maybe String) -> Maybe String
forall a b. (a, b) -> a
fst ([Flag] -> IO (Maybe String, Maybe String)
getGhcDirs [Flag]
flags)
    String -> IO ()
forall a. String -> IO a
bye (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"not available" Maybe String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_PrintGhcLibDir Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe String
dir <- ((Maybe String, Maybe String) -> Maybe String)
-> IO (Maybe String, Maybe String) -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe String, Maybe String) -> Maybe String
forall a b. (a, b) -> b
snd ([Flag] -> IO (Maybe String, Maybe String)
getGhcDirs [Flag]
flags)
    String -> IO ()
forall a. String -> IO a
bye (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"not available" Maybe String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Flag_UseUnicode Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags Bool -> Bool -> Bool
&& Flag
Flag_Html Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall a. String -> a
throwE String
"Unicode can only be enabled for HTML output."

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Flag
Flag_GenIndex Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags Bool -> Bool -> Bool
|| Flag
Flag_GenContents Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags)
        Bool -> Bool -> Bool
&& Flag
Flag_Html Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall a. String -> a
throwE String
"-h/--html cannot be used with --gen-index or --gen-contents"

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Flag
Flag_GenIndex Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags Bool -> Bool -> Bool
|| Flag
Flag_GenContents Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags)
        Bool -> Bool -> Bool
&& Flag
Flag_Hoogle Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall a. String -> a
throwE String
"--hoogle cannot be used with --gen-index or --gen-contents"

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Flag
Flag_GenIndex Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags Bool -> Bool -> Bool
|| Flag
Flag_GenContents Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags)
        Bool -> Bool -> Bool
&& Flag
Flag_LaTeX Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall a. String -> a
throwE String
"--latex cannot be used with --gen-index or --gen-contents"
  where
    byeVersion :: IO a
byeVersion = String -> IO a
forall a. String -> IO a
bye (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$
      String
"Haddock version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
projectVersion String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", (c) Simon Marlow 2006\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"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 :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hypSrc Bool -> Bool -> Bool
&& (Flag -> Bool) -> [Flag] -> Bool
forall (t :: * -> *) 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 -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Warning: "
            , String
"--source-* options are ignored when "
            , String
"--hyperlinked-source is enabled."
            ]

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
hypSrc Bool -> Bool -> Bool
&& (Flag -> Bool) -> [Flag] -> Bool
forall (t :: * -> *) 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 -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Warning: "
            , String
"source CSS file is specified but "
            , String
"--hyperlinked-source is disabled."
            ]

  where
    hypSrc :: Bool
hypSrc = Flag
Flag_HyperlinkedSource Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags
    isSourceUrlFlag :: Flag -> Bool
isSourceUrlFlag (Flag_SourceBaseURL String
_) = Bool
True
    isSourceUrlFlag (Flag_SourceModuleURL String
_) = Bool
True
    isSourceUrlFlag (Flag_SourceEntityURL String
_) = Bool
True
    isSourceUrlFlag (Flag_SourceLEntityURL String
_) = Bool
True
    isSourceUrlFlag Flag
_ = Bool
False
    isSourceCssFlag :: Flag -> Bool
isSourceCssFlag (Flag_SourceCss String
_) = Bool
True
    isSourceCssFlag Flag
_ = Bool
False


updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
updateHTMLXRefs [(DocPaths, InterfaceFile)]
packages = do
  IORef (Map Module String) -> Map Module String -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Map Module String)
html_xrefs_ref ([(Module, String)] -> Map Module String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Module, String)]
mapping)
  IORef (Map ModuleName String) -> Map ModuleName String -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Map ModuleName String)
html_xrefs_ref' ([(ModuleName, String)] -> Map ModuleName String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ModuleName, String)]
mapping')
  where
    mapping :: [(Module, String)]
mapping = [ (InstalledInterface -> Module
instMod InstalledInterface
iface, String
html) | ((String
html, Maybe String
_), InterfaceFile
ifaces) <- [(DocPaths, InterfaceFile)]
packages
              , InstalledInterface
iface <- InterfaceFile -> [InstalledInterface]
ifInstalledIfaces InterfaceFile
ifaces ]
    mapping' :: [(ModuleName, String)]
mapping' = [ (Module -> ModuleName
moduleName Module
m, String
html) | (Module
m, String
html) <- [(Module, String)]
mapping ]


getPrologue :: DynFlags -> [Flag] -> IO (Maybe (MDoc RdrName))
getPrologue :: DynFlags -> [Flag] -> IO (Maybe (MDoc RdrName))
getPrologue DynFlags
dflags [Flag]
flags =
  case [String
filename | Flag_Prologue String
filename <- [Flag]
flags ] of
    [] -> Maybe (MDoc RdrName) -> IO (Maybe (MDoc RdrName))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MDoc RdrName)
forall a. Maybe a
Nothing
    [String
filename] -> do
      Handle
h <- String -> IOMode -> IO Handle
openFile String
filename IOMode
ReadMode
      Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
      String
str <- Handle -> IO String
hGetContents Handle
h -- semi-closes the handle
      Maybe (MDoc RdrName) -> IO (Maybe (MDoc RdrName))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MDoc RdrName) -> IO (Maybe (MDoc RdrName)))
-> (MDoc RdrName -> Maybe (MDoc RdrName))
-> MDoc RdrName
-> IO (Maybe (MDoc RdrName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MDoc RdrName -> Maybe (MDoc RdrName)
forall a. a -> Maybe a
Just (MDoc RdrName -> IO (Maybe (MDoc RdrName)))
-> MDoc RdrName -> IO (Maybe (MDoc RdrName))
forall a b. (a -> b) -> a -> b
$! (Wrap NsRdrName -> Wrap RdrName)
-> MetaDoc (Wrap (ModuleName, OccName)) (Wrap NsRdrName)
-> MDoc RdrName
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((NsRdrName -> RdrName) -> Wrap NsRdrName -> Wrap RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NsRdrName -> RdrName
rdrName) (MetaDoc (Wrap (ModuleName, OccName)) (Wrap NsRdrName)
 -> MDoc RdrName)
-> MetaDoc (Wrap (ModuleName, OccName)) (Wrap NsRdrName)
-> MDoc RdrName
forall a b. (a -> b) -> a -> b
$ DynFlags
-> Maybe String
-> String
-> MetaDoc (Wrap (ModuleName, OccName)) (Wrap NsRdrName)
forall mod.
DynFlags -> Maybe String -> String -> MetaDoc mod (Wrap NsRdrName)
parseParas DynFlags
dflags Maybe String
forall a. Maybe a
Nothing String
str
    [String]
_ -> String -> IO (Maybe (MDoc RdrName))
forall a. String -> a
throwE String
"multiple -p/--prologue options"


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