diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Haddock/Options.hs | 3 | ||||
| -rw-r--r-- | src/Main.hs | 39 |
2 files changed, 23 insertions, 19 deletions
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 8cb70d00..7323a806 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -71,6 +71,7 @@ data Flag | Flag_OptGhc String | Flag_GhcLibDir String | Flag_GhcVersion + | Flag_PrintGhcPath | Flag_PrintGhcLibDir | Flag_NoWarnings | Flag_UseUnicode @@ -147,6 +148,8 @@ options backwardsCompat = "option to be forwarded to GHC", Option [] ["ghc-version"] (NoArg Flag_GhcVersion) "output GHC version in numeric format", + Option [] ["print-ghc-path"] (NoArg Flag_PrintGhcPath) + "output path to GHC binary", Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir) "output GHC lib dir", Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings", diff --git a/src/Main.hs b/src/Main.hs index ba48a709..cc5d1302 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -50,7 +50,7 @@ import Data.Int #ifdef IN_GHC_TREE import System.FilePath #else -import GHC.Paths +import qualified GHC.Paths as GhcPaths import Paths_haddock #endif @@ -155,7 +155,7 @@ main = handleTopExceptions $ do readPackagesAndProcessModules :: [Flag] -> [String] -> IO ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do - libDir <- getGhcLibDir flags + libDir <- fmap snd (getGhcDirs flags) -- Catches all GHC source errors, then prints and re-throws them. let handleSrcErrors action' = flip handleSourceError action' $ \err -> do @@ -329,23 +329,24 @@ getHaddockLibDir flags = case [str | Flag_Lib str <- flags] of [] -> #ifdef IN_GHC_TREE - getInTreeLibDir + fmap snd getInTreeDirs #else getDataDir -- provided by Cabal #endif fs -> return (last fs) -getGhcLibDir :: [Flag] -> IO String -getGhcLibDir flags = - case [ dir | Flag_GhcLibDir dir <- flags ] of - [] -> +getGhcDirs :: [Flag] -> IO (String, String) +getGhcDirs flags = do + (ghcPath, libDir) <- #ifdef IN_GHC_TREE - getInTreeLibDir + getInTreeDirs #else - return libdir -- from GHC.Paths + return (GhcPaths.ghc, GhcPaths.libdir) #endif - xs -> return $ last xs + case [ dir | Flag_GhcLibDir dir <- flags ] of + [] -> return (ghcPath, libDir) + xs -> return (ghcPath, last xs) shortcutFlags :: [Flag] -> IO () @@ -356,8 +357,12 @@ shortcutFlags flags = do when (Flag_Version `elem` flags) byeVersion when (Flag_GhcVersion `elem` flags) byeGhcVersion + when (Flag_PrintGhcPath `elem` flags) $ do + dir <- fmap fst (getGhcDirs flags) + bye $ dir ++ "\n" + when (Flag_PrintGhcLibDir `elem` flags) $ do - dir <- getGhcLibDir flags + dir <- fmap snd (getGhcDirs flags) bye $ dir ++ "\n" when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $ @@ -404,16 +409,12 @@ getPrologue flags = #ifdef IN_GHC_TREE -getInTreeLibDir :: IO String -getInTreeLibDir = do +getInTreeDirs :: IO (String, String) +getInTreeDirs = do m <- getExecDir case m of - Nothing -> error "No GhcLibDir found" -#ifdef NEW_GHC_LAYOUT - Just d -> return (d </> ".." </> "lib") -#else - Just d -> return (d </> "..") -#endif + Nothing -> error "No GhcDir found" + Just d -> let p = d </> ".." in return (p </> "bin" </> "ghc", p </> "lib") getExecDir :: IO (Maybe String) |