From 0438f0ac7605fb6b9850acd34cc169f84a3f6088 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 13 Feb 2019 11:36:11 -0500 Subject: Clean up logic for guessing `-B` and `--lib` (#1026) Haddock built with the `in-ghc-tree` flag tries harder to find the GHC lib folder and its own resources. This should make it possible to use `in-ghc-tree`-built Haddock without having to specify the `-B` and `--lib` options (just how you can use in-tree GHC without always specifying the `-B` option). The logic to do this relies on `getExecutablePath`, so we only get this auto-detection on platforms where this function works. --- haddock-api/src/Haddock.hs | 147 ++++++++++----------- .../Haddock/Backends/Hyperlinker/ParserSpec.hs | 2 +- haddock-test/src/Test/Haddock.hs | 1 + haddock-test/src/Test/Haddock/Config.hs | 24 +++- 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 -- cgit v1.2.3