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.

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