aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock.hs147
-rw-r--r--haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs2
-rw-r--r--haddock-test/src/Test/Haddock.hs1
-rw-r--r--haddock-test/src/Test/Haddock/Config.hs24
4 files changed, 91 insertions, 83 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 358e5c3a..9f33eb77 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -54,20 +54,14 @@ import qualified Data.Map as Map
import System.IO
import System.Exit
-#if defined(mingw32_HOST_OS)
-import Foreign
-import Foreign.C
-import Data.Int
-#endif
-
#ifdef IN_GHC_TREE
import System.FilePath
+import System.Environment (getExecutablePath)
#else
import qualified GHC.Paths as GhcPaths
import Paths_haddock_api (getDataDir)
-import System.Directory (doesDirectoryExist)
#endif
-import System.Directory (getTemporaryDirectory)
+import System.Directory (doesDirectoryExist, getTemporaryDirectory)
import System.FilePath ((</>))
import Text.ParserCombinators.ReadP (readP_to_S)
@@ -236,7 +230,7 @@ noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " ++
withGhc :: [Flag] -> Ghc a -> IO a
withGhc flags action = do
- libDir <- fmap snd (getGhcDirs flags)
+ libDir <- fmap (fromMaybe (error "No GhcDir found") . snd) (getGhcDirs flags)
-- Catches all GHC source errors, then prints and re-throws them.
let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
@@ -530,51 +524,87 @@ unsetPatternMatchWarnings dflags =
-------------------------------------------------------------------------------
-getHaddockLibDir :: [Flag] -> IO String
+getHaddockLibDir :: [Flag] -> IO FilePath
getHaddockLibDir flags =
case [str | Flag_Lib str <- flags] of
[] -> do
#ifdef IN_GHC_TREE
- getInTreeDir
+
+ -- 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
- -- if data directory does not exist we are probably
- -- invoking from either ./haddock-api or ./
- let res_dirs = [ getDataDir -- provided by Cabal
- , pure "resources"
- , pure "haddock-api/resources"
- ]
- check get_path = do
- p <- get_path
- exists <- doesDirectoryExist p
- pure $ if exists then Just p else Nothing
+ -- When Haddock was installed by @cabal@, the resources (which are listed
+ -- under @data-files@ in the Cabal file) will have been copied to a
+ -- special directory.
+ data_dir <- getDataDir -- Provided by Cabal
+ let res_dirs = [ data_dir ] ++
- dirs <- mapM check res_dirs
- case [p | Just p <- dirs] of
- (p : _) -> return p
- _ -> die "Haddock's resource directory does not exist!\n"
#endif
- fs -> return (last fs)
+ -- 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 @./@
+ [ "resources"
+ , "haddock-api/resources"
+ ]
+
+ res_dir <- check res_dirs
+ case res_dir of
+ Just p -> return p
+ _ -> die "Haddock's resource directory does not exist!\n"
-getGhcDirs :: [Flag] -> IO (String, String)
+ fs -> return (last fs)
+ where
+ -- Pick the first path that corresponds to a directory that exists
+ check :: [FilePath] -> IO (Maybe FilePath)
+ check [] = pure Nothing
+ check (path : other_paths) = do
+ exists <- doesDirectoryExist path
+ if exists then pure (Just path) else check other_paths
+
+-- | Find the @lib@ directory for GHC and the path to @ghc@
+getGhcDirs :: [Flag] -> IO (Maybe FilePath, Maybe FilePath)
getGhcDirs flags = do
- case [ dir | Flag_GhcLibDir dir <- flags ] of
- [] -> do
+
#ifdef IN_GHC_TREE
- libDir <- getInTreeDir
- return (ghcPath, libDir)
+ base_dir <- getBaseDir
+ let ghc_path = Nothing
#else
- return (ghcPath, GhcPaths.libdir)
+ let base_dir = Just GhcPaths.libdir
+ ghc_path = Just GhcPaths.ghc
#endif
- xs -> return (ghcPath, last xs)
- where
+
+ -- If the user explicitly specifies a lib dir, use that
+ let ghc_dir = case [ dir | Flag_GhcLibDir dir <- flags ] of
+ [] -> base_dir
+ xs -> Just (last xs)
+
+ pure (ghc_path, ghc_dir)
+
+
#ifdef IN_GHC_TREE
- ghcPath = "not available"
-#else
- ghcPath = GhcPaths.ghc
-#endif
+-- | 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 flags = do
@@ -588,12 +618,12 @@ shortcutFlags flags = do
when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n"))
when (Flag_PrintGhcPath `elem` flags) $ do
- dir <- fmap fst (getGhcDirs flags)
- bye $ dir ++ "\n"
+ path <- fmap fst (getGhcDirs flags)
+ bye $ fromMaybe "not available" path ++ "\n"
when (Flag_PrintGhcLibDir `elem` flags) $ do
dir <- fmap snd (getGhcDirs flags)
- bye $ dir ++ "\n"
+ bye $ fromMaybe "not available" dir ++ "\n"
when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $
throwE "Unicode can only be enabled for HTML output."
@@ -670,38 +700,3 @@ rightOrThrowE :: Either String b -> IO b
rightOrThrowE (Left msg) = throwE msg
rightOrThrowE (Right x) = pure x
-
-#ifdef IN_GHC_TREE
-
-getInTreeDir :: IO String
-getInTreeDir = getExecDir >>= \case
- Nothing -> error "No GhcDir found"
- Just d -> return (d </> ".." </> "lib")
-
-
-getExecDir :: IO (Maybe String)
-#if defined(mingw32_HOST_OS)
-getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
- where
- try_size size = allocaArray (fromIntegral size) $ \buf -> do
- ret <- c_GetModuleFileName nullPtr buf size
- case ret of
- 0 -> return Nothing
- _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf
- | otherwise -> try_size (size * 2)
-
-# if defined(i386_HOST_ARCH)
-# define WINDOWS_CCONV stdcall
-# elif defined(x86_64_HOST_ARCH)
-# define WINDOWS_CCONV ccall
-# else
-# error Unknown mingw32 arch
-# endif
-
-foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
- c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
-#else
-getExecDir = return Nothing
-#endif
-
-#endif
diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
index 1273a45a..6e065dfb 100644
--- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
+++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
@@ -19,7 +19,7 @@ import Haddock.Backends.Hyperlinker.Types
withDynFlags :: (DynFlags -> IO ()) -> IO ()
withDynFlags cont = do
libDir <- fmap snd (getGhcDirs [])
- runGhc (Just libDir) $ do
+ runGhc libDir $ do
dflags <- getSessionDynFlags
liftIO $ cont dflags
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 25c64cfe..1019e815 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -42,6 +42,7 @@ checkFiles :: Config c -> Bool -> IO ()
checkFiles cfg@(Config { .. }) somethingCrashed = do
putStrLn "Testing output files..."
+ createDirectoryIfMissing True (cfgOutDir cfg)
files <- ignore <$> getDirectoryTree (cfgOutDir cfg)
failed <- liftM catMaybes . forM files $ \file -> do
putStr $ "Checking \"" ++ file ++ "\"... "
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 51394eff..94ca7759 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -170,6 +170,7 @@ loadConfig :: CheckConfig c -> DirConfig -> [Flag] -> [String] -> IO (Config c)
loadConfig ccfg dcfg flags files = do
cfgEnv <- (:) ("haddock_datadir", dcfgResDir dcfg) <$> getEnvironment
+ -- Find Haddock executable
systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment
haddockOnPath <- findExecutable "haddock"
@@ -181,14 +182,25 @@ loadConfig ccfg dcfg flags files = do
cfgHaddockPath <- case haddock_path of
Just path -> pure path
Nothing -> do
- hPutStrLn stderr "Haddock executable not found"
+ hPutStrLn stderr "Haddock executable not found; consider using the `--haddock-path` flag."
exitFailure
- ghcPath <- case flagsGhcPath flags of
- Just fp -> return fp
- Nothing -> init <$> rawSystemStdout normal
- cfgHaddockPath
- ["--print-ghc-path"]
+ -- Perhaps Haddock knows where you can find GHC?
+ queriedGhcPath <- do
+ p <- init <$> rawSystemStdout normal cfgHaddockPath ["--print-ghc-path"]
+ exists <- doesFileExist p
+ pure $ if exists then Just p else Nothing
+
+
+ let ghc_path = msum [ flagsGhcPath flags
+ , queriedGhcPath
+ ]
+
+ ghcPath <- case ghc_path of
+ Just path -> pure path
+ Nothing -> do
+ hPutStrLn stderr "GHC executable not found; consider using the `--ghc-path` flag."
+ exitFailure
printVersions cfgEnv cfgHaddockPath
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-14 17:18:00 +0000