From 7d535dea5dd1fc8d3af0cbee38c90febc75318b9 Mon Sep 17 00:00:00 2001
From: ijones <ijones@syntaxpolice.org>
Date: Wed, 16 Feb 2005 06:37:41 +0000
Subject: [PATCH] added --gen-script to register and unregister
---
Distribution/Make.hs | 8 ++++----
Distribution/Setup.hs | 36 ++++++++++++++++++++-------------
Distribution/Simple.hs | 10 ++++-----
Distribution/Simple/Register.hs | 17 ++++++++--------
tests/ModuleTest.hs | 2 +-
5 files changed, 40 insertions(+), 33 deletions(-)
diff --git a/Distribution/Make.hs b/Distribution/Make.hs
index 72c60f3e72..67b1347d10 100644
--- a/Distribution/Make.hs
+++ b/Distribution/Make.hs
@@ -159,11 +159,11 @@ defaultMainNoRead pkg_descr
SDistCmd -> basicCommand "SDist" "make dist" (parseSDistArgs args [])
- RegisterCmd uInst -> basicCommand "Register" "make register"
- (parseRegisterArgs (uInst,0) args [])
+ RegisterCmd uInst genScript -> basicCommand "Register" "make register"
+ (parseRegisterArgs (uInst,genScript, 0) args [])
- UnregisterCmd uInst -> basicCommand "Unregister" "make unregister"
- (parseUnregisterArgs (uInst, 0) args [])
+ UnregisterCmd uInst genScript -> basicCommand "Unregister" "make unregister"
+ (parseUnregisterArgs (uInst, genScript, 0) args [])
ProgramaticaCmd -> basicCommand "Programatica" "make programatica"
(parseProgramaticaArgs args [])
diff --git a/Distribution/Setup.hs b/Distribution/Setup.hs
index f73407e570..ecbfa13826 100644
--- a/Distribution/Setup.hs
+++ b/Distribution/Setup.hs
@@ -91,8 +91,8 @@ data Action = ConfigCmd ConfigFlags -- config
| ProgramaticaCmd -- pfesetup
| InstallCmd Bool -- install (install-prefix) (--user flag)
| SDistCmd -- sdist
- | RegisterCmd Bool -- register (--user flag)
- | UnregisterCmd Bool -- unregister (--user flag)
+ | RegisterCmd Bool Bool -- register (--user flag, --gen-script)
+ | UnregisterCmd Bool Bool -- unregister (--user flag, --gen-script)
| HelpCmd -- help
-- | NoCmd -- error case, help case.
-- | TestCmd 1.0?
@@ -137,8 +137,10 @@ data Flag a = GhcFlag | NhcFlag | HugsFlag
| WithCompiler FilePath | WithHcPkg FilePath | Prefix FilePath
| WithHaddock FilePath | WithHappy FilePath | WithAlex FilePath
| WithHsc2hs FilePath | WithCpphs FilePath
- -- For install and register:
+ -- For install, register, and unregister:
| UserFlag | GlobalFlag
+ -- for register & unregister
+ | GenScriptFlag
-- For copy:
| InstPrefix FilePath
-- For everyone:
@@ -447,13 +449,15 @@ registerCmd = Cmd {
Option "" ["user"] (NoArg UserFlag)
"upon registration, register this package in the user's local package database",
Option "" ["global"] (NoArg GlobalFlag)
- "(default) upon registration, register this package in the system-wide package database"
+ "(default) upon registration, register this package in the system-wide package database",
+ Option "" ["gen-script"] (NoArg GenScriptFlag)
+ "Instead of performing the register command, generate a script to register later"
],
- cmdAction = RegisterCmd False
+ cmdAction = RegisterCmd False False
}
--- | Flags to @register@ and @unregister@: (user package, verbose)
-type RegisterFlags = (Bool,Int)
+-- | Flags to @register@ and @unregister@: (user package, gen-script, verbose)
+type RegisterFlags = (Bool, Bool, Int)
parseRegisterArgs :: RegisterFlags -> [String] -> [OptDescr a] ->
IO (RegisterFlags, [a], [String])
@@ -467,12 +471,13 @@ parseRegisterArgs cfg args customOpts =
(_, _, errs) -> do putStrLn "Errors: "
mapM_ putStrLn errs
exitWith (ExitFailure 1)
- where updateCfg (fl:flags) (uFlag,verbose) = updateCfg flags $
+ where updateCfg (fl:flags) (uFlag, genScriptFlag, verbose) = updateCfg flags $
case fl of
- UserFlag -> (True,verbose)
- GlobalFlag -> (False,verbose)
- Verbose n -> (uFlag,n)
- Lift _ -> (uFlag,verbose)
+ UserFlag -> (True, genScriptFlag, verbose)
+ GlobalFlag -> (False, genScriptFlag, verbose)
+ Verbose n -> (uFlag,genScriptFlag, n)
+ GenScriptFlag -> (uFlag, True, verbose)
+ Lift _ -> (uFlag,genScriptFlag, verbose)
_ -> error $ "Unexpected flag!"
updateCfg [] t = t
@@ -485,9 +490,12 @@ unregisterCmd = Cmd {
Option "" ["user"] (NoArg UserFlag)
"unregister this package in the user's local package database",
Option "" ["global"] (NoArg GlobalFlag)
- "(default) unregister this package in the system-wide package database"
+ "(default) unregister this package in the system-wide package database",
+ Option "" ["gen-script"] (NoArg GenScriptFlag)
+ "Instead of performing the unregister command, generate a script to unregister later"
+
],
- cmdAction = UnregisterCmd False
+ cmdAction = UnregisterCmd False False
}
parseUnregisterArgs :: RegisterFlags -> [String] -> [OptDescr a] ->
diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs
index 05528b046f..a60636eaea 100644
--- a/Distribution/Simple.hs
+++ b/Distribution/Simple.hs
@@ -301,7 +301,7 @@ defaultMainWorker pkg_descr_in action args hooks
(die "Hugs cannot yet install user-only packages.")
install pkg_descr localbuildinfo (Nothing, verbose)
when (hasLibs pkg_descr)
- (register pkg_descr localbuildinfo flags)
+ (register pkg_descr localbuildinfo (uInst, False, verbose))
postHook postInst args flags localbuildinfo
SDistCmd -> do
@@ -313,15 +313,15 @@ defaultMainWorker pkg_descr_in action args hooks
sdist srcPref distPref verbose pps pkg_descr
postHook postSDist args verbose localbuildinfo
- RegisterCmd uInst -> do
- (flags, _, args) <- parseRegisterArgs (uInst,0) args []
+ RegisterCmd uInst genScript -> do
+ (flags, _, args) <- parseRegisterArgs (uInst, genScript, 0) args []
pkg_descr <- hookOrInArgs preReg args flags
localbuildinfo <- getPersistBuildConfig
when (hasLibs pkg_descr) (register pkg_descr localbuildinfo flags)
postHook postReg args flags localbuildinfo
- UnregisterCmd uInst -> do
- (flags,_, args) <- parseUnregisterArgs (uInst,0) args []
+ UnregisterCmd uInst genScript -> do
+ (flags,_, args) <- parseUnregisterArgs (uInst,genScript, 0) args []
pkg_descr <- hookOrInArgs preUnreg args flags
localbuildinfo <- getPersistBuildConfig
unregister pkg_descr localbuildinfo flags
diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs
index f4d5f677a8..f276927f33 100644
--- a/Distribution/Simple/Register.hs
+++ b/Distribution/Simple/Register.hs
@@ -99,13 +99,12 @@ unregScriptLocation = "unregister.sh"
register :: PackageDescription -> LocalBuildInfo
-> RegisterFlags -- ^Install in the user's database?; verbose
-> IO ()
-register pkg_descr lbi (userInst,verbose)
+register pkg_descr lbi (userInst, genScript, verbose)
| isNothing (library pkg_descr) = do
setupMessage "No package to register" pkg_descr
return ()
| otherwise = do
- let writeRegScript = verbose > 10 -- FIX, thread new flag.
- setupMessage (if writeRegScript
+ setupMessage (if genScript
then ("Writing registration script: " ++ regScriptLocation)
else "Registering")
pkg_descr
@@ -121,13 +120,13 @@ register pkg_descr lbi (userInst,verbose)
GHC.maybeCreateLocalPackageConfig
localConf <- GHC.localPackageConfig
pkgConfWriteable <- GHC.canWriteLocalPackageConfig
- when (not pkgConfWriteable && not writeRegScript)
+ when (not pkgConfWriteable && not genScript)
$ userPkgConfErr localConf
return ["--config-file=" ++ localConf]
else return []
instConfExists <- doesFileExist installedPkgConfigFile
- when (not instConfExists && not writeRegScript) $ do
+ when (not instConfExists && not genScript) $ do
when (verbose > 0) $
putStrLn ("create "++installedPkgConfigFile)
writeInstalledConfig pkg_descr lbi
@@ -135,7 +134,7 @@ register pkg_descr lbi (userInst,verbose)
let register_flags
| ghc_63_plus = ["update", installedPkgConfigFile]
| otherwise = "--update-package":
- if writeRegScript
+ if genScript
then []
else ["--input-file="++installedPkgConfigFile]
@@ -144,7 +143,7 @@ register pkg_descr lbi (userInst,verbose)
++ config_flags)
let pkgTool = compilerPkgTool (compiler lbi)
- if writeRegScript
+ if genScript
then rawSystemPipe regScriptLocation verbose
(showInstalledConfig pkg_descr lbi)
pkgTool allFlags
@@ -229,7 +228,7 @@ mkInstalledPackageInfo pkg_descr lbi
-- Unregistration
unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
-unregister pkg_descr lbi (user_unreg, verbose) = do
+unregister pkg_descr lbi (user_unreg, genScript, verbose) = do
setupMessage "Unregistering" pkg_descr
let ghc_63_plus = compilerVersion (compiler lbi) >= Version [6,3] []
let theName = pkgName (package pkg_descr)
@@ -248,7 +247,7 @@ unregister pkg_descr lbi (user_unreg, verbose) = do
let removeCmd = if ghc_63_plus
then ["unregister",theName]
else ["--remove-package="++theName]
- rawSystemEmit unregScriptLocation (verbose>10) verbose (compilerPkgTool (compiler lbi))
+ rawSystemEmit unregScriptLocation genScript verbose (compilerPkgTool (compiler lbi))
(removeCmd++config_flags)
Hugs -> do
try $ removeDirectoryRecursive (hugsPackageDir pkg_descr lbi)
diff --git a/tests/ModuleTest.hs b/tests/ModuleTest.hs
index e1765cf19f..2445a805a3 100644
--- a/tests/ModuleTest.hs
+++ b/tests/ModuleTest.hs
@@ -346,7 +346,7 @@ tests currDir comp compConf = [
GHC -> do checkTargetDir ghcTargetDir [".hi"]
doesFileExist (ghcTargetDir `joinFileName` "libHStest-1.0.a")
>>= assertBool "library doesn't exist"
- dumpScriptFlag = "-v11"
+ dumpScriptFlag = "--gen-script"
main :: IO ()
main = do putStrLn "compile successful"
putStrLn "-= Setup Tests =-"
--
GitLab