add --force-files, like --force but doesn't allow missing dependencies

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 8290345..9c6ba71 100644 (file)
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -106,6 +106,7 @@ data Flag
   | FlagConfig FilePath
   | FlagGlobalConfig FilePath
   | FlagForce
+  | FlagForceFiles
   | FlagAutoGHCiLibs
   | FlagDefinedName String String
   | FlagSimpleOutput
@@ -123,6 +124,8 @@ flags = [
        "location of the global package config",
   Option [] ["force"] (NoArg FlagForce)
        "ignore missing dependencies, directories, and libraries",
+  Option [] ["force-files"] (NoArg FlagForceFiles)
+       "ignore missing directories and libraries only",
   Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
        "automatically build libs for GHCi (with register)",
   Option ['?'] ["help"] (NoArg FlagHelp)
@@ -191,11 +194,16 @@ substProg prog (c:xs) = c : substProg prog xs
 -- -----------------------------------------------------------------------------
 -- Do the business
 
+data Force = ForceAll | ForceFiles | NoForce
+
 runit :: [Flag] -> [String] -> IO ()
 runit cli nonopts = do
   prog <- getProgramName
   let
-       force = FlagForce `elem` cli
+        force 
+          | FlagForce `elem` cli        = ForceAll 
+          | FlagForceFiles `elem` cli   = ForceFiles
+          | otherwise                   = NoForce
        auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
         defines = [ (nm,val) | FlagDefinedName nm val <- cli ]
   --
@@ -377,7 +385,7 @@ registerPackage :: FilePath
                -> [Flag]
                -> Bool         -- auto_ghci_libs
                -> Bool         -- update
-               -> Bool         -- force
+               -> Force
                -> IO ()
 registerPackage input defines flags auto_ghci_libs update force = do
   db_stack <- getPkgDatabases True flags
@@ -397,7 +405,7 @@ registerPackage input defines flags auto_ghci_libs update force = do
 
   expanded <- expandEnvVars s defines force
 
-  pkg0 <- parsePackageInfo expanded defines force
+  pkg0 <- parsePackageInfo expanded defines
   putStrLn "done."
 
   let pkg = resolveDeps db_stack pkg0
@@ -410,9 +418,8 @@ registerPackage input defines flags auto_ghci_libs update force = do
 parsePackageInfo
        :: String
        -> [(String,String)]
-       -> Bool
        -> IO InstalledPackageInfo
-parsePackageInfo str defines force =
+parsePackageInfo str defines =
   case parseInstalledPackageInfo str of
     ParseOk _warns ok -> return ok
     ParseFailed err -> die (showError err)
@@ -610,11 +617,11 @@ validatePackageConfig :: InstalledPackageInfo
                      -> PackageDBStack
                      -> Bool   -- auto-ghc-libs
                      -> Bool   -- update
-                     -> Bool   -- force
+                     -> Force
                      -> IO ()
 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
   checkPackageId pkg
-  checkDuplicates db_stack pkg update force
+  checkDuplicates db_stack pkg update
   mapM_        (checkDep db_stack force) (depends pkg)
   mapM_        (checkDir force) (importDirs pkg)
   mapM_        (checkDir force) (libraryDirs pkg)
@@ -662,9 +669,8 @@ resolveDeps db_stack p = updateDeps p
                []      -> dep_pkgid    -- No installed package; use 
                                        -- the version-less one
 
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool
-        -> IO ()
-checkDuplicates db_stack pkg update force = do
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
+checkDuplicates db_stack pkg update = do
   let
        pkgid = package pkg
        (_top_db_name, pkgs) : _  = db_stack
@@ -676,37 +682,40 @@ checkDuplicates db_stack pkg update force = do
 
 
 
-checkDir :: Bool -> String -> IO ()
+checkDir :: Force -> String -> IO ()
 checkDir force d
  | "$topdir" `isPrefixOf` d = return ()
        -- can't check this, because we don't know what $topdir is
  | otherwise = do
    there <- doesDirectoryExist d
    when (not there)
-       (dieOrForce force (d ++ " doesn't exist or isn't a directory"))
+       (dieOrForceFile force (d ++ " doesn't exist or isn't a directory"))
 
-checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
+checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
 checkDep db_stack force pkgid
-  | not real_version || pkgid `elem` pkgids = return ()
-  | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
+  | pkgid `elem` pkgids || (not real_version && name_exists) = return ()
+  | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
                                        ++ " doesn't exist")
   where
        -- for backwards compat, we treat 0.0 as a special version,
        -- and don't check that it actually exists.
        real_version = realVersion pkgid
        
+        name_exists = any (\p -> pkgName (package p) == name) all_pkgs
+        name = pkgName pkgid
+
        all_pkgs = concat (map snd db_stack)
        pkgids = map package all_pkgs
 
 realVersion :: PackageIdentifier -> Bool
 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
 
-checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
+checkHSLib :: [String] -> Bool -> Force -> String -> IO ()
 checkHSLib dirs auto_ghci_libs force 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
-       [] -> dieOrForce force ("cannot find " ++ batch_lib_file ++
+       [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++
                                 " on library path") 
        (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
 
@@ -859,7 +868,7 @@ oldRunit clis = do
         where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
       input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
 
-      force = OF_Force `elem` clis
+      force = if OF_Force `elem` clis then ForceAll else NoForce
       
       defines = [ (nm,val) | OF_DefinedName nm val <- clis ]
 
@@ -889,7 +898,7 @@ my_head s (x:xs) = x
 -- ---------------------------------------------------------------------------
 -- expanding environment variables in the package configuration
 
-expandEnvVars :: String -> [(String, String)] -> Bool -> IO String
+expandEnvVars :: String -> [(String, String)] -> Force -> IO String
 expandEnvVars str defines force = go str ""
  where
    go "" acc = return $! reverse acc
@@ -906,7 +915,7 @@ expandEnvVars str defines force = go str ""
        Just x | not (null x) -> return x
        _      -> 
        catch (System.getEnv nm)
-          (\ _ -> do dieOrForce force ("Unable to expand variable " ++ 
+          (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ 
                                        show nm)
                      return "")
 
@@ -928,10 +937,20 @@ die s = do
   hPutStrLn stderr (prog ++ ": " ++ s)
   exitWith (ExitFailure 1)
 
-dieOrForce :: Bool -> String -> IO ()
-dieOrForce force s 
-  | force     = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
-  | otherwise = die (s ++ " (use --force to override)")
+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)")
+
+dieForcible :: String -> IO ()
+dieForcible s = die (s ++ " (use --force to override)")
 
 -----------------------------------------
 --     Cut and pasted from ghc/compiler/SysTools