X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=b1aaaba7b09d0c11b38d3e688d00294f6f4cd8b6;hp=49ac435cc2450ddecd7979bc1ca5ee8b4dbadd69;hb=34cc75e1a62638f2833815746ebce0a9114dc26b;hpb=7bca8c45ee7efbdef91210fa5673570413539a45 diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 49ac435..b1aaaba 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 @@ -32,7 +33,11 @@ import Prelude import System.Console.GetOpt import Text.PrettyPrint +#if __GLASGOW_HASKELL__ >= 609 import qualified Control.Exception as Exception +#else +import qualified Control.Exception.Extensible as Exception +#endif import Data.Maybe import Data.Char ( isSpace, toLower ) @@ -219,7 +224,8 @@ 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) @@ -372,19 +378,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" @@ -471,20 +472,23 @@ getPkgDatabases modify my_flags = do in return (flag_stack, to_modify) - db_stack <- mapM readParseDatabase final_stack + db_stack <- mapM (readParseDatabase mb_user_conf) final_stack return (db_stack, to_modify) -readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB) -readParseDatabase filename = do - str <- readFile filename `catchIO` \_ -> return emptyPackageConfig - let packages = map convertPackageInfoIn $ read str - Exception.evaluate packages - `catchError` \e-> - die ("error while parsing " ++ filename ++ ": " ++ show e) - return (filename,packages) - -emptyPackageConfig :: String -emptyPackageConfig = "[]" +readParseDatabase :: Maybe (PackageDBName,Bool) + -> PackageDBName + -> IO (PackageDBName,PackageDB) +readParseDatabase mb_user_conf filename + -- the user database (only) is allowed to be non-existent + | Just (user_conf,False) <- mb_user_conf, filename == user_conf + = return (filename, []) + | otherwise + = do str <- readFile filename + let packages = map convertPackageInfoIn $ read str + Exception.evaluate packages + `catchError` \e-> + die ("error while parsing " ++ filename ++ ": " ++ show e) + return (filename,packages) -- ----------------------------------------------------------------------------- -- Registering @@ -515,6 +519,11 @@ registerPackage input my_flags auto_ghci_libs update force = do pkg <- parsePackageInfo expanded putStrLn "done." + let unversioned_deps = filter (not . realVersion) (depends pkg) + unless (null unversioned_deps) $ + die ("Unversioned dependencies found: " ++ + unwords (map display unversioned_deps)) + let truncated_stack = dropWhile ((/= to_modify).fst) db_stack -- truncate the stack for validation, because we don't allow -- packages lower in the stack to refer to those higher up. @@ -623,13 +632,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 @@ -764,29 +775,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 @@ -798,6 +830,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 @@ -836,21 +871,70 @@ writeNewConfig filename packages = do -- 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], @@ -859,16 +943,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 @@ -876,33 +960,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. @@ -914,10 +999,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) ] @@ -925,31 +1010,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. @@ -962,7 +1064,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] @@ -1054,13 +1156,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)") @@ -1079,26 +1179,34 @@ 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 unDosifyPath = subst '\\' '/' + 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 ----------------------------------------- @@ -1108,10 +1216,11 @@ installSignalHandlers :: IO () installSignalHandlers = do threadid <- myThreadId let - interrupt = throwTo threadid (Exception.ErrorCall "interrupted") + interrupt = Exception.throwTo threadid + (Exception.ErrorCall "interrupted") -- #if !defined(mingw32_HOST_OS) - installHandler sigQUIT (Catch interrupt) Nothing + installHandler sigQUIT (Catch interrupt) Nothing installHandler sigINT (Catch interrupt) Nothing return () #elif __GLASGOW_HASKELL__ >= 603 @@ -1135,41 +1244,17 @@ isInfixOf :: (Eq a) => [a] -> [a] -> Bool isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) #endif -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#if __GLASGOW_HASKELL__ >= 609 -catchIO = Exception.catch -#else -catchIO io handler = io `Exception.catch` handler' - where handler' (Exception.IOException ioe) = handler ioe - handler' e = Exception.throw e -#endif - #if mingw32_HOST_OS || mingw32_TARGET_OS throwIOIO :: Exception.IOException -> IO a -#if __GLASGOW_HASKELL__ >= 609 throwIOIO = Exception.throwIO -#else -throwIOIO ioe = Exception.throwIO (Exception.IOException ioe) -#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch #endif catchError :: IO a -> (String -> IO a) -> IO a -#if __GLASGOW_HASKELL__ >= 609 catchError io handler = io `Exception.catch` handler' where handler' (Exception.ErrorCall err) = handler err -#else -catchError io handler = io `Exception.catch` handler' - where handler' (Exception.ErrorCall err) = handler err - handler' e = Exception.throw e -#endif - -onException :: IO a -> IO b -> IO a -#if __GLASGOW_HASKELL__ >= 609 -onException = Exception.onException -#else -onException io what = io `Exception.catch` \e -> do what - Exception.throw e -#endif -- copied from Cabal's Distribution.Simple.Utils, except that we want @@ -1194,8 +1279,8 @@ writeFileAtomic targetFile content = do #else renameFile newFile targetFile #endif - `onException` do hClose newHandle - removeFile newFile + `Exception.onException` do hClose newHandle + removeFile newFile where template = targetName <.> "tmp" targetDir | null targetDir_ = "." @@ -1243,7 +1328,13 @@ openNewFile dir template = do -- XXX We want to tell fdToHandle what the filepath is, -- as any exceptions etc will only be able to report the -- fd currently - h <- fdToHandle fd `onException` c_close fd + h <- +#if __GLASGOW_HASKELL__ >= 609 + fdToHandle fd +#else + fdToHandle (fromIntegral fd) +#endif + `Exception.onException` c_close fd return (filepath, h) where filename = prefix ++ show x ++ suffix