X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=19052a5e2ce3fefcd63a6e1b35b262d6e3195d33;hb=1c83695b5b9ae3175c18908c1d58aeadb1f225ae;hp=8afde04e75162407b83de5d74102707e0244fefe;hpb=ecf0782b93019747f3801e6b077ecf1482a5fb25;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 8afde04..19052a5 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -16,6 +16,7 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) +import Distribution.ModuleName hiding (main) import Distribution.InstalledPackageInfo hiding (depends) import Distribution.Compat.ReadP import Distribution.ParseUtils @@ -60,7 +61,11 @@ import System.Posix hiding (fdToHandle) import IO ( isPermissionError ) import System.Posix.Internals +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Handle.FD (fdToHandle) +#else import GHC.Handle (fdToHandle) +#endif #if defined(GLOB) import System.Process(runInteractiveCommand) @@ -81,7 +86,9 @@ main = do (cli,_,[]) | FlagVersion `elem` cli -> bye ourCopyright (cli,nonopts,[]) -> - runit cli nonopts + case getVerbosity Normal cli of + Right v -> runit v cli nonopts + Left err -> die err (_,_,errors) -> do prog <- getProgramName die (concat errors ++ usageInfo (usageHeader prog) flags) @@ -103,6 +110,7 @@ data Flag | FlagNamesOnly | FlagIgnoreCase | FlagNoUserDb + | FlagVerbosity (Maybe String) deriving Eq flags :: [OptDescr Flag] @@ -132,9 +140,23 @@ flags = [ Option [] ["names-only"] (NoArg FlagNamesOnly) "only print package names, not versions; can only be used with list --simple-output", Option [] ["ignore-case"] (NoArg FlagIgnoreCase) - "ignore case for substring matching" + "ignore case for substring matching", + Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity") + "verbosity level (0-2, default 1)" ] +data Verbosity = Silent | Normal | Verbose + deriving (Show, Eq, Ord) + +getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity +getVerbosity v [] = Right v +getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs +getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs +getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs +getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs +getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v) +getVerbosity v (_ : fs) = getVerbosity v fs + deprecFlags :: [OptDescr Flag] deprecFlags = [ -- put deprecated flags here @@ -223,12 +245,13 @@ substProg prog (c:xs) = c : substProg prog xs -- ----------------------------------------------------------------------------- -- Do the business -data Force = ForceAll | ForceFiles | NoForce +data Force = NoForce | ForceFiles | ForceAll | CannotForce + deriving (Eq,Ord) data PackageArg = Id PackageIdentifier | Substring String (String->Bool) -runit :: [Flag] -> [String] -> IO () -runit cli nonopts = do +runit :: Verbosity -> [Flag] -> [String] -> IO () +runit verbosity cli nonopts = do installSignalHandlers -- catch ^C and clean up prog <- getProgramName let @@ -274,18 +297,18 @@ runit cli nonopts = do glob filename >>= print #endif ["register", filename] -> - registerPackage filename cli auto_ghci_libs False force + registerPackage filename verbosity cli auto_ghci_libs False force ["update", filename] -> - registerPackage filename cli auto_ghci_libs True force + registerPackage filename verbosity cli auto_ghci_libs True force ["unregister", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - unregisterPackage pkgid cli force + unregisterPackage pkgid verbosity cli force ["expose", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - exposePackage pkgid cli force + exposePackage pkgid verbosity cli force ["hide", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - hidePackage pkgid cli force + hidePackage pkgid verbosity cli force ["list"] -> do listPackages cli Nothing Nothing ["list", pkgid_str] -> @@ -376,19 +399,14 @@ getPkgDatabases modify my_flags = do let err_msg = "missing --global-conf option, location of global package.conf unknown\n" global_conf <- case [ f | FlagGlobalConfig f <- my_flags ] of - [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe" + [] -> do mb_dir <- getLibDir case mb_dir of Nothing -> die err_msg Just dir -> - do let path1 = dir "package.conf" - path2 = dir ".." ".." ".." - "inplace-datadir" - "package.conf" - exists1 <- doesFileExist path1 - exists2 <- doesFileExist path2 - if exists1 then return path1 - else if exists2 then return path2 - else die "Can't find package.conf" + do let path = dir "package.conf" + exists <- doesFileExist path + unless exists $ die "Can't find package.conf" + return path fs -> return (last fs) let global_conf_dir = global_conf ++ ".d" @@ -497,12 +515,13 @@ readParseDatabase mb_user_conf filename -- Registering registerPackage :: FilePath + -> Verbosity -> [Flag] -> Bool -- auto_ghci_libs -> Bool -- update -> Force -> IO () -registerPackage input my_flags auto_ghci_libs update force = do +registerPackage input verbosity my_flags auto_ghci_libs update force = do (db_stack, Just to_modify) <- getPkgDatabases True my_flags let db_to_operate_on = my_head "register" $ @@ -511,16 +530,19 @@ registerPackage input my_flags auto_ghci_libs update force = do s <- case input of "-" -> do - putStr "Reading package info from stdin ... " + when (verbosity >= Normal) $ + putStr "Reading package info from stdin ... " getContents f -> do - putStr ("Reading package info from " ++ show f ++ " ... ") + when (verbosity >= Normal) $ + putStr ("Reading package info from " ++ show f ++ " ... ") readFile f expanded <- expandEnvVars s force pkg <- parsePackageInfo expanded - putStrLn "done." + when (verbosity >= Normal) $ + putStrLn "done." let unversioned_deps = filter (not . realVersion) (depends pkg) unless (null unversioned_deps) $ @@ -533,7 +555,7 @@ registerPackage input my_flags auto_ghci_libs update force = do validatePackageConfig pkg truncated_stack auto_ghci_libs update force let new_details = filter not_this (snd db_to_operate_on) ++ [pkg] not_this p = package p /= package pkg - writeNewConfig to_modify new_details + writeNewConfig verbosity to_modify new_details parsePackageInfo :: String @@ -548,22 +570,23 @@ parsePackageInfo str = -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Unregistering are all similar -exposePackage :: PackageIdentifier -> [Flag] -> Force -> IO () +exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () exposePackage = modifyPackage (\p -> [p{exposed=True}]) -hidePackage :: PackageIdentifier -> [Flag] -> Force -> IO () +hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () hidePackage = modifyPackage (\p -> [p{exposed=False}]) -unregisterPackage :: PackageIdentifier -> [Flag] -> Force -> IO () +unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () unregisterPackage = modifyPackage (\_ -> []) modifyPackage :: (InstalledPackageInfo -> [InstalledPackageInfo]) -> PackageIdentifier + -> Verbosity -> [Flag] -> Force -> IO () -modifyPackage fn pkgid my_flags force = do +modifyPackage fn pkgid verbosity my_flags force = do (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) -- let ((db_name, pkgs) : rest_of_stack) = db_stack @@ -588,7 +611,7 @@ modifyPackage fn pkgid my_flags force = do " would break the following packages: " ++ unwords (map display newly_broken)) - writeNewConfig db_name new_config + writeNewConfig verbosity db_name new_config -- ----------------------------------------------------------------------------- -- Listing packages @@ -635,13 +658,15 @@ listPackages my_flags mPackageName mModuleName = do | otherwise = parens doc where doc = text (display (package p)) - show_simple db_stack = do - let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName - else display - pkgs = map showPkg $ sortBy compPkgIdVer $ - map package (allPackagesInStack db_stack) - when (not (null pkgs)) $ - hPutStrLn stdout $ concat $ intersperse " " pkgs + show_simple = simplePackageList my_flags . allPackagesInStack + +simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () +simplePackageList my_flags pkgs = do + let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName + else display + strs = map showPkg $ sortBy compPkgIdVer $ map package pkgs + when (not (null pkgs)) $ + hPutStrLn stdout $ concat $ intersperse " " strs -- ----------------------------------------------------------------------------- -- Prints the highest (hidden or exposed) version of a package @@ -776,29 +801,50 @@ checkConsistency my_flags = do (db_stack, _) <- getPkgDatabases True my_flags -- check behaves like modify for the purposes of deciding which -- databases to use, because ordering is important. - let pkgs = allPackagesInStack db_stack - broken_pkgs = brokenPackages pkgs - broken_ids = map package broken_pkgs - broken_why = [ (package p, filter (`elem` broken_ids) (depends p)) - | p <- broken_pkgs ] - mapM_ (putStrLn . render . show_func) broken_why - where - show_func | FlagSimpleOutput `elem` my_flags = show_simple - | otherwise = show_normal - show_simple (pid,deps) = - text (display pid) <> colon - <+> fsep (punctuate comma (map (text . display) deps)) - show_normal (pid,deps) = - text "package" <+> text (display pid) <+> text "has missing dependencies:" - $$ nest 4 (fsep (punctuate comma (map (text . display) deps))) + let simple_output = FlagSimpleOutput `elem` my_flags -brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] -brokenPackages pkgs = go [] pkgs + let pkgs = allPackagesInStack db_stack + + checkPackage p = do + (_,es) <- runValidate $ checkPackageConfig p db_stack False True + if null es + then return [] + else do + when (not simple_output) $ do + reportError ("There are problems in package " ++ display (package p) ++ ":") + reportValidateErrors es " " Nothing + return () + return [p] + + broken_pkgs <- concat `fmap` mapM checkPackage pkgs + + let filterOut pkgs1 pkgs2 = filter not_in pkgs2 + where not_in p = package p `notElem` all_ps + all_ps = map package pkgs1 + + let not_broken_pkgs = filterOut broken_pkgs pkgs + (_, trans_broken_pkgs) = closure [] not_broken_pkgs + all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs + + when (not (null all_broken_pkgs)) $ do + if simple_output + then simplePackageList my_flags all_broken_pkgs + else do + reportError ("\nThe following packages are broken, either because they have a problem\n"++ + "listed above, or because they depend on a broken package.") + mapM_ (hPutStrLn stderr . display . package) all_broken_pkgs + + when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1) + + +closure :: [InstalledPackageInfo] -> [InstalledPackageInfo] + -> ([InstalledPackageInfo], [InstalledPackageInfo]) +closure pkgs db_stack = go pkgs db_stack where go avail not_avail = case partition (depsAvailable avail) not_avail of - ([], not_avail') -> not_avail' + ([], not_avail') -> (avail, not_avail') (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo @@ -810,6 +856,9 @@ brokenPackages pkgs = go [] pkgs -- we want mutually recursive groups of package to show up -- as broken. (#1750) +brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] +brokenPackages pkgs = snd (closure [] pkgs) + -- ----------------------------------------------------------------------------- -- Manipulating package.conf files @@ -830,9 +879,10 @@ convertPackageInfoIn hiddenModules = map convert h } where convert = fromJust . simpleParse -writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO () -writeNewConfig filename packages = do - hPutStr stdout "Writing new package config file... " +writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO () +writeNewConfig verbosity filename packages = do + when (verbosity >= Normal) $ + hPutStr stdout "Writing new package config file... " createDirectoryIfMissing True $ takeDirectory filename let shown = concat $ intersperse ",\n " $ map (show . convertPackageInfoOut) packages @@ -842,27 +892,77 @@ writeNewConfig filename packages = do if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e - hPutStrLn stdout "done." + when (verbosity >= Normal) $ + hPutStrLn stdout "done." ----------------------------------------------------------------------------- -- Sanity-check a new package config, and automatically build GHCi libs -- if requested. +type ValidateError = (Force,String) + +newtype Validate a = V { runValidate :: IO (a, [ValidateError]) } + +instance Monad Validate where + return a = V $ return (a, []) + m >>= k = V $ do + (a, es) <- runValidate m + (b, es') <- runValidate (k a) + return (b,es++es') + +verror :: Force -> String -> Validate () +verror f s = V (return ((),[(f,s)])) + +liftIO :: IO a -> Validate a +liftIO k = V (k >>= \a -> return (a,[])) + +-- returns False if we should die +reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool +reportValidateErrors es prefix mb_force = do + oks <- mapM report es + return (and oks) + where + report (f,s) + | Just force <- mb_force + = if (force >= f) + then do reportError (prefix ++ s ++ " (ignoring)") + return True + else if f < CannotForce + then do reportError (prefix ++ s ++ " (use --force to override)") + return False + else do reportError err + return False + | otherwise = do reportError err + return False + where + err = prefix ++ s + validatePackageConfig :: InstalledPackageInfo -> PackageDBStack -> Bool -- auto-ghc-libs - -> Bool -- update + -> Bool -- update, or check -> Force -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do + (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update + ok <- reportValidateErrors es (display (package pkg) ++ ": ") (Just force) + when (not ok) $ exitWith (ExitFailure 1) + +checkPackageConfig :: InstalledPackageInfo + -> PackageDBStack + -> Bool -- auto-ghc-libs + -> Bool -- update, or check + -> Validate () +checkPackageConfig pkg db_stack auto_ghci_libs update = do checkPackageId pkg - checkDuplicates db_stack pkg update force - mapM_ (checkDep db_stack force) (depends pkg) - checkDuplicateDepends force (depends pkg) - mapM_ (checkDir force) (importDirs pkg) - mapM_ (checkDir force) (libraryDirs pkg) - mapM_ (checkDir force) (includeDirs pkg) - mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg) + checkDuplicates db_stack pkg update + mapM_ (checkDep db_stack) (depends pkg) + checkDuplicateDepends (depends pkg) + mapM_ (checkDir "import-dirs") (importDirs pkg) + mapM_ (checkDir "library-dirs") (libraryDirs pkg) + mapM_ (checkDir "include-dirs") (includeDirs pkg) + checkModules pkg + mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) -- ToDo: check these somehow? -- extra_libraries :: [String], -- c_includes :: [String], @@ -871,16 +971,16 @@ validatePackageConfig pkg db_stack auto_ghci_libs update force = do -- end up with a package id that cannot be parsed. This will lead to -- difficulties when the user wants to refer to the package later, so -- we check that the package id can be parsed properly here. -checkPackageId :: InstalledPackageInfo -> IO () +checkPackageId :: InstalledPackageInfo -> Validate () checkPackageId ipi = let str = display (package ipi) in case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of [_] -> return () - [] -> die ("invalid package identifier: " ++ str) - _ -> die ("ambiguous package identifier: " ++ str) + [] -> verror CannotForce ("invalid package identifier: " ++ str) + _ -> verror CannotForce ("ambiguous package identifier: " ++ str) -checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Force -> IO () -checkDuplicates db_stack pkg update force = do +checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate () +checkDuplicates db_stack pkg update = do let pkgid = package pkg (_top_db_name, pkgs) : _ = db_stack @@ -888,33 +988,34 @@ checkDuplicates db_stack pkg update force = do -- Check whether this package id already exists in this DB -- when (not update && (pkgid `elem` map package pkgs)) $ - die ("package " ++ display pkgid ++ " is already installed") + verror CannotForce $ + "package " ++ display pkgid ++ " is already installed" let uncasep = map toLower . display dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs) - when (not update && not (null dups)) $ dieOrForceAll force $ + when (not update && not (null dups)) $ verror ForceAll $ "Package names may be treated case-insensitively in the future.\n"++ "Package " ++ display pkgid ++ " overlaps with: " ++ unwords (map display dups) -checkDir :: Force -> String -> IO () -checkDir force d +checkDir :: String -> String -> Validate () +checkDir thisfield d | "$topdir" `isPrefixOf` d = return () | "$httptopdir" `isPrefixOf` d = return () -- can't check these, because we don't know what $(http)topdir is | otherwise = do - there <- doesDirectoryExist d - when (not there) - (dieOrForceFile force (d ++ " doesn't exist or isn't a directory")) + there <- liftIO $ doesDirectoryExist d + when (not there) $ + verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory") -checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO () -checkDep db_stack force pkgid +checkDep :: PackageDBStack -> PackageIdentifier -> Validate () +checkDep db_stack pkgid | pkgid `elem` pkgids || (not real_version && name_exists) = return () - | otherwise = dieOrForceAll force ("dependency " ++ display pkgid - ++ " doesn't exist") + | otherwise = verror ForceAll ("dependency " ++ display pkgid + ++ " doesn't exist") where -- for backwards compat, we treat 0.0 as a special version, -- and don't check that it actually exists. @@ -926,10 +1027,10 @@ checkDep db_stack force pkgid all_pkgs = allPackagesInStack db_stack pkgids = map package all_pkgs -checkDuplicateDepends :: Force -> [PackageIdentifier] -> IO () -checkDuplicateDepends force deps +checkDuplicateDepends :: [PackageIdentifier] -> Validate () +checkDuplicateDepends deps | null dups = return () - | otherwise = dieOrForceAll force ("package has duplicate dependencies: " ++ + | otherwise = verror ForceAll ("package has duplicate dependencies: " ++ unwords (map display dups)) where dups = [ p | (p:_:_) <- group (sort deps) ] @@ -937,31 +1038,48 @@ checkDuplicateDepends force deps realVersion :: PackageIdentifier -> Bool realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] -checkHSLib :: [String] -> Bool -> Force -> String -> IO () -checkHSLib dirs auto_ghci_libs force lib = do +checkHSLib :: [String] -> Bool -> String -> Validate () +checkHSLib dirs auto_ghci_libs lib = do let batch_lib_file = "lib" ++ lib ++ ".a" - bs <- mapM (doesLibExistIn batch_lib_file) dirs - case [ dir | (exists,dir) <- zip bs dirs, exists ] of - [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++ - " on library path") - (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs - -doesLibExistIn :: String -> String -> IO Bool -doesLibExistIn lib d + m <- liftIO $ doesFileExistOnPath batch_lib_file dirs + case m of + Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++ + " on library path") + Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs + +doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath) +doesFileExistOnPath file path = go path + where go [] = return Nothing + go (p:ps) = do b <- doesFileExistIn file p + if b then return (Just p) else go ps + +doesFileExistIn :: String -> String -> IO Bool +doesFileExistIn lib d | "$topdir" `isPrefixOf` d = return True | "$httptopdir" `isPrefixOf` d = return True - | otherwise = doesFileExist (d ++ '/':lib) + | otherwise = doesFileExist (d lib) + +checkModules :: InstalledPackageInfo -> Validate () +checkModules pkg = do + mapM_ findModule (exposedModules pkg ++ hiddenModules pkg) + where + findModule modl = do + -- there's no .hi file for GHC.Prim + if modl == fromString "GHC.Prim" then return () else do + let file = toFilePath modl <.> "hi" + m <- liftIO $ doesFileExistOnPath file (importDirs pkg) + when (isNothing m) $ + verror ForceFiles ("file " ++ file ++ " is missing") checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file | otherwise = do - bs <- mapM (doesLibExistIn ghci_lib_file) dirs - case [dir | (exists,dir) <- zip bs dirs, exists] of - [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file) - (_:_) -> return () - where - ghci_lib_file = lib ++ ".o" + m <- doesFileExistOnPath ghci_lib_file dirs + when (isNothing m && ghci_lib_file /= "HSrts.o") $ + hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file) + where + ghci_lib_file = lib <.> "o" -- automatically build the GHCi version of a batch lib, -- using ld --whole-archive. @@ -974,7 +1092,7 @@ autoBuildGHCiLib dir batch_file ghci_file = do #if defined(darwin_HOST_OS) r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file] #elif defined(mingw32_HOST_OS) - execDir <- getExecDir "/bin/ghc-pkg.exe" + execDir <- getLibDir r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] #else r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] @@ -1066,13 +1184,11 @@ dieOrForceAll :: Force -> String -> IO () dieOrForceAll ForceAll s = ignoreError s dieOrForceAll _other s = dieForcible s -dieOrForceFile :: Force -> String -> IO () -dieOrForceFile ForceAll s = ignoreError s -dieOrForceFile ForceFiles s = ignoreError s -dieOrForceFile _other s = dieForcible s - ignoreError :: String -> IO () -ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)") +ignoreError s = reportError (s ++ " (ignoring)") + +reportError :: String -> IO () +reportError s = do hFlush stdout; hPutStrLn stderr s dieForcible :: String -> IO () dieForcible s = die (s ++ " (use --force to override)") @@ -1091,26 +1207,33 @@ subst a b ls = map (\ x -> if x == a then b else x) ls unDosifyPath :: FilePath -> FilePath unDosifyPath xs = subst '\\' '/' xs -getExecDir :: String -> IO (Maybe String) +getLibDir :: IO (Maybe String) +getLibDir = fmap (fmap ( "lib")) $ getExecDir "/bin/ghc-pkg.exe" + -- (getExecDir cmd) returns the directory in which the current -- executable, which should be called 'cmd', is running -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd, -- you'll get "/a/b/c" back as the result -getExecDir cmd - = allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else do s <- peekCString buf - return (Just (reverse (drop (length cmd) - (reverse (unDosifyPath s))))) - where - len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32. +getExecDir :: String -> IO (Maybe String) +getExecDir cmd = + getExecPath >>= maybe (return Nothing) removeCmdSuffix + where initN n = reverse . drop n . reverse + removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath + +getExecPath :: IO (Maybe String) +getExecPath = + allocaArray len $ \buf -> do + ret <- getModuleFileName nullPtr buf len + if ret == 0 then return Nothing + else liftM Just $ peekCString buf + where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. + +foreign import stdcall unsafe "GetModuleFileNameA" + getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 #else -getExecDir :: String -> IO (Maybe String) -getExecDir _ = return Nothing +getLibDir :: IO (Maybe String) +getLibDir = return Nothing #endif -----------------------------------------