----------------------------------------------------------------------------- -- | -- Module : Main -- Copyright : (c) David Himmelstrup 2005 -- License : BSD-like -- -- Maintainer : lemmih@gmail.com -- Stability : provisional -- Portability : portable -- -- Entry point to the default cabal-install front-end. ----------------------------------------------------------------------------- module Main (main) where import Distribution.Client.Setup ( GlobalFlags(..), globalCommand, globalRepos , ConfigFlags(..) , ConfigExFlags(..), defaultConfigExFlags, configureExCommand , BuildFlags(..), buildCommand , InstallFlags(..), defaultInstallFlags , installCommand, upgradeCommand , FetchFlags(..), fetchCommand , checkCommand , updateCommand , ListFlags(..), listCommand , InfoFlags(..), infoCommand , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand , InitFlags(initVerbosity), initCommand , SDistFlags(..), SDistExFlags(..), sdistCommand , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand , IndexFlags(..), indexCommand , SandboxFlags(..), sandboxAddSourceCommand , sandboxConfigureCommand, sandboxBuildCommand, sandboxInstallCommand , dumpPkgEnvCommand , reportCommand , unpackCommand, UnpackFlags(..) ) import Distribution.Simple.Setup ( HaddockFlags(..), haddockCommand , HscolourFlags(..), hscolourCommand , CopyFlags(..), copyCommand , RegisterFlags(..), registerCommand , CleanFlags(..), cleanCommand , TestFlags(..), testCommand , BenchmarkFlags(..), benchmarkCommand , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag ) import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Config ( SavedConfig(..), loadConfig, defaultConfigFile ) import Distribution.Client.Targets ( readUserTargets ) import Distribution.Client.List (list, info) import Distribution.Client.Install (install, upgrade) import Distribution.Client.Configure (configure) import Distribution.Client.Update (update) import Distribution.Client.Fetch (fetch) import Distribution.Client.Check as Check (check) --import Distribution.Client.Clean (clean) import Distribution.Client.Upload as Upload (upload, check, report) import Distribution.Client.SrcDist (sdist) import Distribution.Client.Unpack (unpack) import Distribution.Client.Index (index) import Distribution.Client.Sandbox (sandboxConfigure , sandboxAddSource, sandboxBuild , sandboxInstall , dumpPackageEnvironment) import Distribution.Client.Init (initCabal) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import Distribution.Simple.Compiler ( Compiler, PackageDBStack ) import Distribution.Simple.Program ( ProgramConfiguration ) import Distribution.Simple.Command import Distribution.Simple.Configure ( checkPersistBuildConfigOutdated, configCompilerAux , interpretPackageDbFlags, maybeGetPersistBuildConfig ) import qualified Distribution.Simple.LocalBuildInfo as LBI import Distribution.Simple.Utils ( cabalVersion, die, intercalate, notice, topHandler ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity ( Verbosity, normal, lessVerbose ) import qualified Paths_cabal_install (version) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import System.FilePath (splitExtension, takeExtension) import System.Directory (doesFileExist) import Data.List (intersperse) import Data.Monoid (Monoid(..)) import Control.Monad (when, unless) -- | Entry point -- main :: IO () main = getArgs >>= mainWorker mainWorker :: [String] -> IO () mainWorker args = topHandler $ case commandsRun globalCommand commands args of CommandHelp help -> printGlobalHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs CommandReadyToGo (globalflags, commandParse) -> case commandParse of _ | fromFlag (globalVersion globalflags) -> printVersion | fromFlag (globalNumericVersion globalflags) -> printNumericVersion CommandHelp help -> printCommandHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs CommandReadyToGo action -> action globalflags where printCommandHelp help = do pname <- getProgName putStr (help pname) printGlobalHelp help = do pname <- getProgName configFile <- defaultConfigFile putStr (help pname) putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" ++ " " ++ configFile ++ "\n" printOptionsList = putStr . unlines printErrors errs = die $ concat (intersperse "\n" errs) printNumericVersion = putStrLn $ display Paths_cabal_install.version printVersion = putStrLn $ "cabal-install version " ++ display Paths_cabal_install.version ++ "\nusing version " ++ display cabalVersion ++ " of the Cabal library " commands = [installCommand `commandAddAction` installAction ,updateCommand `commandAddAction` updateAction ,listCommand `commandAddAction` listAction ,infoCommand `commandAddAction` infoAction ,fetchCommand `commandAddAction` fetchAction ,unpackCommand `commandAddAction` unpackAction ,checkCommand `commandAddAction` checkAction ,sdistCommand `commandAddAction` sdistAction ,uploadCommand `commandAddAction` uploadAction ,reportCommand `commandAddAction` reportAction ,initCommand `commandAddAction` initAction ,configureExCommand `commandAddAction` configureAction ,buildCommand `commandAddAction` buildAction ,wrapperAction copyCommand copyVerbosity copyDistPref ,wrapperAction haddockCommand haddockVerbosity haddockDistPref ,wrapperAction cleanCommand cleanVerbosity cleanDistPref ,wrapperAction hscolourCommand hscolourVerbosity hscolourDistPref ,wrapperAction registerCommand regVerbosity regDistPref ,testCommand `commandAddAction` testAction ,benchmarkCommand `commandAddAction` benchmarkAction ,upgradeCommand `commandAddAction` upgradeAction ,hiddenCommand $ win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction ,hiddenCommand $ indexCommand `commandAddAction` indexAction ,hiddenCommand $ sandboxConfigureCommand `commandAddAction` sandboxConfigureAction ,hiddenCommand $ sandboxAddSourceCommand `commandAddAction` sandboxAddSourceAction ,hiddenCommand $ sandboxBuildCommand `commandAddAction` sandboxBuildAction ,hiddenCommand $ sandboxInstallCommand `commandAddAction` sandboxInstallAction ,hiddenCommand $ dumpPkgEnvCommand `commandAddAction` dumpPkgEnvAction ] wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) -> (flags -> Flag String) -> Command (GlobalFlags -> IO ()) wrapperAction command verbosityFlag distPrefFlag = commandAddAction command { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do let verbosity = fromFlagOrDefault normal (verbosityFlag flags) setupScriptOptions = defaultSetupScriptOptions { useDistPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) (distPrefFlag flags) } setupWrapper verbosity setupScriptOptions Nothing command (const flags) extraArgs configureAction :: (ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO () configureAction (configFlags, configExFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) config <- loadConfig verbosity (globalConfigFile globalFlags) (configUserInstall configFlags) let configFlags' = savedConfigureFlags config `mappend` configFlags configExFlags' = savedConfigureExFlags config `mappend` configExFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux configFlags' configure verbosity (configPackageDB' configFlags') (globalRepos globalFlags') comp conf configFlags' configExFlags' extraArgs buildAction :: BuildFlags -> [String] -> GlobalFlags -> IO () buildAction buildFlags extraArgs globalFlags = do let distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) (buildDistPref buildFlags) verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) reconfigure verbosity distPref mempty [] globalFlags (const Nothing) build verbosity distPref buildFlags extraArgs -- | Actually do the work of building the package. This is separate from -- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke -- 'reconfigure' twice. build :: Verbosity -> FilePath -> BuildFlags -> [String] -> IO () build verbosity distPref buildFlags extraArgs = setupWrapper verbosity setupOptions Nothing buildCommand (const buildFlags') extraArgs where setupOptions = defaultSetupScriptOptions { useDistPref = distPref } buildFlags' = buildFlags { buildVerbosity = toFlag verbosity , buildDistPref = toFlag distPref } -- | Re-configure the package in the current directory if needed. Deciding -- when to reconfigure and with which options is convoluted: -- -- If we are reconfiguring, we must always run @configure@ with the -- verbosity option we are given; however, that a previous configuration -- uses a different verbosity setting is not reason enough to reconfigure. -- -- The package should be configured to use the same \"dist\" prefix as -- given to the @build@ command, otherwise the build will probably -- fail. Not only does this determine the \"dist\" prefix setting if we -- need to reconfigure anyway, but an existing configuration should be -- invalidated if its \"dist\" prefix differs. -- -- If the package has never been configured (i.e., there is no -- LocalBuildInfo), we must configure first, using the default options. -- -- If the package has been configured, there will be a 'LocalBuildInfo'. -- If there no package description file, we assume that the -- 'PackageDescription' is up to date, though the configuration may need -- to be updated for other reasons (see above). If there is a package -- description file, and it has been modified since the 'LocalBuildInfo' -- was generated, then we need to reconfigure. -- -- The caller of this function may also have specific requirements -- regarding the flags the last configuration used. For example, -- 'testAction' requires that the package be configured with test suites -- enabled. The caller may pass the required settings to this function -- along with a function to check the validity of the saved 'ConfigFlags'; -- these required settings will be checked first upon determining that -- a previous configuration exists. reconfigure :: Verbosity -- ^ Verbosity setting -> FilePath -- ^ \"dist\" prefix -> ConfigFlags -- ^ Additional config flags to set. These flags -- will be 'mappend'ed to the last used or -- default 'ConfigFlags' as appropriate, so -- this value should be 'mempty' with only the -- required flags set. The required verbosity -- and \"dist\" prefix flags will be set -- automatically because they are always -- required; therefore, it is not necessary to -- set them here. -> [String] -- ^ Extra arguments -> GlobalFlags -- ^ Global flags -> (ConfigFlags -> Maybe String) -- ^ Check that the required flags are set in -- the last used 'ConfigFlags'. If the required -- flags are not set, provide a message to the -- user explaining the reason for -- reconfiguration. Because the correct \"dist\" -- prefix setting is always required, it is checked -- automatically; this function need not check -- for it. -> IO () reconfigure verbosity distPref addConfigFlags extraArgs globalFlags checkFlags = do mLbi <- maybeGetPersistBuildConfig distPref case mLbi of -- Package has never been configured. Nothing -> do notice verbosity $ "Configuring with default flags." ++ configureManually configureAction (defaultFlags, defaultConfigExFlags) extraArgs globalFlags -- Package has been configured, but the configuration may be out of -- date or required flags may not be set. Just lbi -> do let configFlags = LBI.configFlags lbi flags = mconcat [configFlags, addConfigFlags, distVerbFlags] savedDistPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) (configDistPref configFlags) -- Determine what message, if any, to display to the user if -- reconfiguration is required. message <- case checkFlags configFlags of -- Flag required by the caller is not set. Just msg -> return $! Just $! msg ++ configureManually Nothing -- Required "dist" prefix is not set. | savedDistPref /= distPref -> return $! Just distPrefMessage -- All required flags are set, but the configuration -- may be outdated. | otherwise -> case LBI.pkgDescrFile lbi of Nothing -> return Nothing Just pdFile -> do outdated <- checkPersistBuildConfigOutdated distPref pdFile return $! if outdated then Just $! outdatedMessage pdFile else Nothing case message of -- No message for the user indicates that reconfiguration -- is not required. Nothing -> return () Just msg -> do notice verbosity msg configureAction (flags, defaultConfigExFlags) extraArgs globalFlags where defaultFlags = mappend addConfigFlags distVerbFlags distVerbFlags = mempty { configVerbosity = toFlag verbosity , configDistPref = toFlag distPref } configureManually = " If this fails, please run configure manually.\n" distPrefMessage = "Package previously configured with different \"dist\" prefix. " ++ "Re-configuring based on most recently used options." ++ configureManually outdatedMessage pdFile = pdFile ++ " has been changed. " ++ "Re-configuring with most recently used options." ++ configureManually installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () installAction (configFlags, _, installFlags, _) _ _globalFlags | fromFlagOrDefault False (installOnly installFlags) = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) in setupWrapper verbosity defaultSetupScriptOptions Nothing installCommand (const mempty) [] installAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) (configUserInstall configFlags) let configFlags' = savedConfigureFlags config `mappend` configFlags configExFlags' = defaultConfigExFlags `mappend` savedConfigureExFlags config `mappend` configExFlags installFlags' = defaultInstallFlags `mappend` savedInstallFlags config `mappend` installFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux' configFlags' install verbosity (configPackageDB' configFlags') (globalRepos globalFlags') comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags targets testAction :: TestFlags -> [String] -> GlobalFlags -> IO () testAction testFlags extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (testVerbosity testFlags) distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) (testDistPref testFlags) setupOptions = defaultSetupScriptOptions { useDistPref = distPref } addConfigFlags = mempty { configTests = toFlag True } checkFlags flags | fromFlagOrDefault False (configTests flags) = Nothing | otherwise = Just "Re-configuring with test suites enabled." reconfigure verbosity distPref addConfigFlags [] globalFlags checkFlags build verbosity distPref mempty [] setupWrapper verbosity setupOptions Nothing testCommand (const testFlags) extraArgs benchmarkAction :: BenchmarkFlags -> [String] -> GlobalFlags -> IO () benchmarkAction benchmarkFlags extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (benchmarkVerbosity benchmarkFlags) distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) (benchmarkDistPref benchmarkFlags) setupOptions = defaultSetupScriptOptions { useDistPref = distPref } addConfigFlags = mempty { configBenchmarks = toFlag True } checkFlags flags | fromFlagOrDefault False (configTests flags) = Nothing | otherwise = Just "Re-configuring with benchmarks enabled." reconfigure verbosity distPref addConfigFlags [] globalFlags checkFlags build verbosity distPref mempty [] setupWrapper verbosity setupOptions Nothing benchmarkCommand (const benchmarkFlags) extraArgs listAction :: ListFlags -> [String] -> GlobalFlags -> IO () listAction listFlags extraArgs globalFlags = do let verbosity = fromFlag (listVerbosity listFlags) config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux' configFlags list verbosity (configPackageDB' configFlags) (globalRepos globalFlags') comp conf listFlags extraArgs infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO () infoAction infoFlags extraArgs globalFlags = do let verbosity = fromFlag (infoVerbosity infoFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux configFlags info verbosity (configPackageDB' configFlags) (globalRepos globalFlags') comp conf globalFlags' infoFlags targets updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () updateAction verbosityFlag extraArgs globalFlags = do unless (null extraArgs) $ do die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs let verbosity = fromFlag verbosityFlag config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let globalFlags' = savedGlobalFlags config `mappend` globalFlags update verbosity (globalRepos globalFlags') upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () upgradeAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) (configUserInstall configFlags) let configFlags' = savedConfigureFlags config `mappend` configFlags configExFlags' = savedConfigureExFlags config `mappend` configExFlags installFlags' = defaultInstallFlags `mappend` savedInstallFlags config `mappend` installFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux' configFlags' upgrade verbosity (configPackageDB' configFlags') (globalRepos globalFlags') comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags targets fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO () fetchAction fetchFlags extraArgs globalFlags = do let verbosity = fromFlag (fetchVerbosity fetchFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux' configFlags fetch verbosity (configPackageDB' configFlags) (globalRepos globalFlags') comp conf globalFlags' fetchFlags targets uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO () uploadAction uploadFlags extraArgs globalFlags = do let verbosity = fromFlag (uploadVerbosity uploadFlags) config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let uploadFlags' = savedUploadFlags config `mappend` uploadFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags tarfiles = extraArgs checkTarFiles extraArgs if fromFlag (uploadCheck uploadFlags') then Upload.check verbosity tarfiles else upload verbosity (globalRepos globalFlags') (flagToMaybe $ uploadUsername uploadFlags') (flagToMaybe $ uploadPassword uploadFlags') tarfiles where checkTarFiles tarfiles | null tarfiles = die "the 'upload' command expects one or more .tar.gz packages." | not (null otherFiles) = die $ "the 'upload' command expects only .tar.gz packages: " ++ intercalate ", " otherFiles | otherwise = sequence_ [ do exists <- doesFileExist tarfile unless exists $ die $ "file not found: " ++ tarfile | tarfile <- tarfiles ] where otherFiles = filter (not . isTarGzFile) tarfiles isTarGzFile file = case splitExtension file of (file', ".gz") -> takeExtension file' == ".tar" _ -> False checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () checkAction verbosityFlag extraArgs _globalFlags = do unless (null extraArgs) $ do die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs allOk <- Check.check (fromFlag verbosityFlag) unless allOk exitFailure sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO () sdistAction (sdistFlags, sdistExFlags) extraArgs _globalFlags = do unless (null extraArgs) $ do die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs sdist sdistFlags sdistExFlags reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO () reportAction reportFlags extraArgs globalFlags = do unless (null extraArgs) $ do die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs let verbosity = fromFlag (reportVerbosity reportFlags) config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let globalFlags' = savedGlobalFlags config `mappend` globalFlags reportFlags' = savedReportFlags config `mappend` reportFlags Upload.report verbosity (globalRepos globalFlags') (flagToMaybe $ reportUsername reportFlags') (flagToMaybe $ reportPassword reportFlags') unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO () unpackAction unpackFlags extraArgs globalFlags = do let verbosity = fromFlag (unpackVerbosity unpackFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let globalFlags' = savedGlobalFlags config `mappend` globalFlags unpack verbosity (globalRepos (savedGlobalFlags config)) globalFlags' unpackFlags targets initAction :: InitFlags -> [String] -> GlobalFlags -> IO () initAction initFlags _extraArgs globalFlags = do let verbosity = fromFlag (initVerbosity initFlags) config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let configFlags = savedConfigureFlags config (comp, conf) <- configCompilerAux' configFlags initCabal verbosity (configPackageDB' configFlags) comp conf initFlags indexAction :: IndexFlags -> [String] -> GlobalFlags -> IO () indexAction indexFlags extraArgs _globalFlags = do when (null extraArgs) $ do die $ "the 'index' command expects a single argument." when ((>1). length $ extraArgs) $ do die $ "the 'index' command expects a single argument: " ++ unwords extraArgs let verbosity = fromFlag (indexVerbosity indexFlags) index verbosity indexFlags (head extraArgs) sandboxConfigureAction :: (SandboxFlags, ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO () sandboxConfigureAction (sandboxFlags, configFlags, configExFlags) extraArgs globalFlags = do let verbosity = fromFlag (sandboxVerbosity sandboxFlags) sandboxConfigure verbosity sandboxFlags configFlags configExFlags extraArgs globalFlags sandboxAddSourceAction :: SandboxFlags -> [String] -> GlobalFlags -> IO () sandboxAddSourceAction sandboxFlags extraArgs _globalFlags = do let verbosity = fromFlag (sandboxVerbosity sandboxFlags) sandboxAddSource verbosity sandboxFlags extraArgs sandboxBuildAction :: (SandboxFlags, BuildFlags) -> [String] -> GlobalFlags -> IO () sandboxBuildAction (sandboxFlags, buildFlags) extraArgs _globalFlags = do let verbosity = fromFlag (sandboxVerbosity sandboxFlags) sandboxBuild verbosity sandboxFlags buildFlags extraArgs sandboxInstallAction :: (SandboxFlags, ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () sandboxInstallAction (sandboxFlags, configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do let verbosity = fromFlag (sandboxVerbosity sandboxFlags) sandboxInstall verbosity sandboxFlags configFlags configExFlags installFlags haddockFlags extraArgs globalFlags dumpPkgEnvAction :: SandboxFlags -> [String] -> GlobalFlags -> IO () dumpPkgEnvAction sandboxFlags extraArgs _globalFlags = do when ((>0). length $ extraArgs) $ do die $ "the 'dump-pkgenv' command doesn't expect any arguments: " ++ unwords extraArgs let verbosity = fromFlag (sandboxVerbosity sandboxFlags) dumpPackageEnvironment verbosity sandboxFlags -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. -- win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags -> IO () win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path win32SelfUpgradeAction _ _ _ = return () -- -- Utils (transitionary) -- configPackageDB' :: ConfigFlags -> PackageDBStack configPackageDB' cfg = interpretPackageDbFlags userInstall (configPackageDBs cfg) where userInstall = fromFlagOrDefault True (configUserInstall cfg) configCompilerAux' :: ConfigFlags -> IO (Compiler, ProgramConfiguration) configCompilerAux' configFlags = configCompilerAux configFlags --FIXME: make configCompilerAux use a sensible verbosity { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }