{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
{-# LANGUAGE LambdaCase #-}
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)
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
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 =
(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
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
([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)
[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
let noChecks :: Bool
noChecks = Flag
Flag_BypassInterfaceVersonCheck Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags
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
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
}
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)."
[(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
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 []
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
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
"'?"]
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)
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
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
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 :: 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 ]
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
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 ]
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
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 ()
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
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)
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
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'
[InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
dynflags''
DynFlags -> Ghc a
ghcActs DynFlags
dynflags''
where
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
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
]
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
base_dir <- getBaseDir
let res_dirs = [ d | Just d <- [base_dir] ] ++
#else
String
data_dir <- IO String
getDataDir
let res_dirs :: [String]
res_dirs = [ String
data_dir ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
#endif
[ 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
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
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
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
getBaseDir :: IO (Maybe FilePath)
getBaseDir = do
exec_path_opt <- catch (Just <$> getExecutablePath)
(\(_ :: SomeException) -> pure Nothing)
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"
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
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