aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock.hs147
-rw-r--r--haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs2
2 files changed, 72 insertions, 77 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 03:39:49 +0000