-
Notifications
You must be signed in to change notification settings - Fork 686
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge branch 'master' into dedupe-more-include-and-linker-flags
- Loading branch information
Showing
72 changed files
with
577 additions
and
160 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,107 @@ | ||
| {-# LANGUAGE RecordWildCards #-} | ||
| module Distribution.Client.CmdClean (cleanCommand, cleanAction) where | ||
|
|
||
| import Prelude () | ||
| import Distribution.Client.Compat.Prelude | ||
|
|
||
| import Distribution.Client.DistDirLayout | ||
| ( DistDirLayout(..), defaultDistDirLayout ) | ||
| import Distribution.Client.ProjectConfig | ||
| ( findProjectRoot ) | ||
| import Distribution.Client.Setup | ||
| ( GlobalFlags ) | ||
| import Distribution.ReadE ( succeedReadE ) | ||
| import Distribution.Simple.Setup | ||
| ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe | ||
| , optionDistPref, optionVerbosity, falseArg | ||
| ) | ||
| import Distribution.Simple.Command | ||
| ( CommandUI(..), option, reqArg ) | ||
| import Distribution.Simple.Utils | ||
| ( info, die', wrapText ) | ||
| import Distribution.Verbosity | ||
| ( Verbosity, normal ) | ||
|
|
||
| import Control.Exception | ||
| ( throwIO ) | ||
| import System.Directory | ||
| ( removeDirectoryRecursive, doesDirectoryExist ) | ||
|
|
||
| data CleanFlags = CleanFlags | ||
| { cleanSaveConfig :: Flag Bool | ||
| , cleanVerbosity :: Flag Verbosity | ||
| , cleanDistDir :: Flag FilePath | ||
| , cleanProjectFile :: Flag FilePath | ||
| } deriving (Eq) | ||
|
|
||
| defaultCleanFlags :: CleanFlags | ||
| defaultCleanFlags = CleanFlags | ||
| { cleanSaveConfig = toFlag False | ||
| , cleanVerbosity = toFlag normal | ||
| , cleanDistDir = NoFlag | ||
| , cleanProjectFile = mempty | ||
| } | ||
|
|
||
| cleanCommand :: CommandUI CleanFlags | ||
| cleanCommand = CommandUI | ||
| { commandName = "new-clean" | ||
| , commandSynopsis = "Clean the package store and remove temporary files." | ||
| , commandUsage = \pname -> | ||
| "Usage: " ++ pname ++ " new-clean [FLAGS]\n" | ||
| , commandDescription = Just $ \_ -> wrapText $ | ||
| "Removes all temporary files created during the building process " | ||
| ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the " | ||
| ++ "local caches (by default).\n\n" | ||
| , commandNotes = Nothing | ||
| , commandDefaultFlags = defaultCleanFlags | ||
| , commandOptions = \showOrParseArgs -> | ||
| [ optionVerbosity | ||
| cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) | ||
| , optionDistPref | ||
| cleanDistDir (\dd flags -> flags { cleanDistDir = dd }) | ||
| showOrParseArgs | ||
| , option [] ["project-file"] | ||
| "Set the name of the cabal.project file to search for in parent directories" | ||
| cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf}) | ||
| (reqArg "FILE" (succeedReadE Flag) flagToList) | ||
| , option ['s'] ["save-config"] | ||
| "Save configuration, only remove build artifacts" | ||
| cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc }) | ||
| falseArg | ||
| ] | ||
| } | ||
|
|
||
| cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO () | ||
| cleanAction CleanFlags{..} extraArgs _ = do | ||
| let verbosity = fromFlagOrDefault normal cleanVerbosity | ||
| saveConfig = fromFlagOrDefault False cleanSaveConfig | ||
| mdistDirectory = flagToMaybe cleanDistDir | ||
| mprojectFile = flagToMaybe cleanProjectFile | ||
|
|
||
| unless (null extraArgs) $ | ||
| die' verbosity $ "'clean' doesn't take any extra arguments: " ++ unwords extraArgs | ||
|
|
||
| projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile | ||
|
|
||
| let distLayout = defaultDistDirLayout projectRoot mdistDirectory | ||
|
|
||
| if saveConfig | ||
| then do | ||
| let buildRoot = distBuildRootDirectory distLayout | ||
| unpackedSrcRoot = distUnpackedSrcRootDirectory distLayout | ||
|
|
||
| buildRootExists <- doesDirectoryExist buildRoot | ||
| unpackedSrcRootExists <- doesDirectoryExist unpackedSrcRoot | ||
|
|
||
| when buildRootExists $ do | ||
| info verbosity ("Deleting build root (" ++ buildRoot ++ ")") | ||
| removeDirectoryRecursive buildRoot | ||
|
|
||
| when unpackedSrcRootExists $ do | ||
| info verbosity ("Deleting unpacked source root (" ++ unpackedSrcRoot ++ ")") | ||
| removeDirectoryRecursive unpackedSrcRoot | ||
| else do | ||
| let distRoot = distDirectory distLayout | ||
|
|
||
| info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") | ||
| removeDirectoryRecursive distRoot |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,109 @@ | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE FlexibleInstances #-} | ||
| {-# LANGUAGE RecordWildCards #-} | ||
| {-# LANGUAGE ViewPatterns #-} | ||
| module Distribution.Client.CmdLegacy (legacyCmd) where | ||
|
|
||
| import Prelude () | ||
| import Distribution.Client.Compat.Prelude | ||
|
|
||
| import qualified Distribution.Client.Setup as Client | ||
| import qualified Distribution.Simple.Setup as Setup | ||
| import Distribution.Simple.Command | ||
| import Distribution.Simple.Utils | ||
| ( warn ) | ||
| import Distribution.Verbosity | ||
| ( Verbosity, normal ) | ||
|
|
||
| import qualified Data.Text as T | ||
|
|
||
| -- Duplicated code (it's identical to Main.regularCmd), but makes things cleaner | ||
| -- and lets me keep how this happens a dirty little secret. | ||
| makeCmd :: CommandUI flags -> (flags -> [String] -> action) -> CommandSpec action | ||
| makeCmd ui action = CommandSpec ui ((flip commandAddAction) action) NormalCommand | ||
|
|
||
| deprecationNote :: String -> String | ||
| deprecationNote cmd = | ||
| "The " ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ | ||
|
|
||
| "Please switch to using either the new project style or the legacy v1-" ++ cmd ++ "\n" ++ | ||
| "alias as new-style projects will become the default in the next version of\n" ++ | ||
| "cabal-install. Please file a bug if you cannot replicate a working v1- use\n" ++ | ||
| "case with the new-style commands.\n" | ||
|
|
||
| legacyNote :: String -> String | ||
| legacyNote cmd = | ||
| "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ | ||
|
|
||
| "It is a legacy feature and will be removed in a future release of cabal-install.\n" ++ | ||
| "Please file a bug if you cannot replicate a working v1- use case with the new-style\n" ++ | ||
| "commands.\n" | ||
|
|
||
| -- | ||
|
|
||
| class HasVerbosity a where | ||
| verbosity :: a -> Verbosity | ||
|
|
||
| instance HasVerbosity (Setup.Flag Verbosity) where | ||
| verbosity = Setup.fromFlagOrDefault normal | ||
|
|
||
| instance (HasVerbosity a) => HasVerbosity (a, b) where | ||
| verbosity (a, _) = verbosity a | ||
|
|
||
| instance (HasVerbosity b) => HasVerbosity (a, b, c) where | ||
| verbosity (_ , b, _) = verbosity b | ||
|
|
||
| instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where | ||
| verbosity (a, _, _, _) = verbosity a | ||
|
|
||
| instance HasVerbosity Setup.BuildFlags where | ||
| verbosity = verbosity . Setup.buildVerbosity | ||
|
|
||
| instance HasVerbosity Setup.ConfigFlags where | ||
| verbosity = verbosity . Setup.configVerbosity | ||
|
|
||
| instance HasVerbosity Setup.ReplFlags where | ||
| verbosity = verbosity . Setup.replVerbosity | ||
|
|
||
| instance HasVerbosity Client.FreezeFlags where | ||
| verbosity = verbosity . Client.freezeVerbosity | ||
|
|
||
| instance HasVerbosity Setup.HaddockFlags where | ||
| verbosity = verbosity . Setup.haddockVerbosity | ||
|
|
||
| instance HasVerbosity Client.ExecFlags where | ||
| verbosity = verbosity . Client.execVerbosity | ||
|
|
||
| instance HasVerbosity Client.UpdateFlags where | ||
| verbosity = verbosity . Client.updateVerbosity | ||
|
|
||
| instance HasVerbosity Setup.CleanFlags where | ||
| verbosity = verbosity . Setup.cleanVerbosity | ||
|
|
||
| -- | ||
|
|
||
| legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] | ||
| legacyCmd origUi@CommandUI{..} action = [makeCmd legUi action, makeCmd depUi depAction] | ||
| where | ||
| legacyMsg = T.unpack . T.replace "v1-" "" . T.pack | ||
|
|
||
| depNote = deprecationNote commandName | ||
| legNote = legacyNote commandName | ||
|
|
||
| depAction flags extra globals = warn (verbosity flags) (depNote ++ "\n") >> action flags extra globals | ||
|
|
||
| legUi = origUi | ||
| { commandName = "v1-" ++ commandName | ||
| , commandNotes = Just $ \pname -> case commandNotes of | ||
| Just notes -> notes pname ++ "\n" ++ legNote | ||
| Nothing -> legNote | ||
| } | ||
|
|
||
| depUi = origUi | ||
| { commandName = legacyMsg commandName | ||
| , commandUsage = legacyMsg . commandUsage | ||
| , commandDescription = (legacyMsg .) <$> commandDescription | ||
| , commandNotes = Just $ \pname -> case commandNotes of | ||
| Just notes -> legacyMsg (notes pname) ++ "\n" ++ depNote | ||
| Nothing -> depNote | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.