diff --git a/Cabal/src/Distribution/Simple/Command.hs b/Cabal/src/Distribution/Simple/Command.hs index 937662b1d33..676b6f15b12 100644 --- a/Cabal/src/Distribution/Simple/Command.hs +++ b/Cabal/src/Distribution/Simple/Command.hs @@ -350,10 +350,10 @@ commandGetOpts -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)] commandGetOpts showOrParse command = - concatMap viewAsGetOpt (commandOptions command showOrParse) + concatMap (viewAsGetOpt showOrParse) (commandOptions command showOrParse) -viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)] -viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa +viewAsGetOpt :: ShowOrParseArgs -> OptionField a -> [GetOpt.OptDescr (a -> a)] +viewAsGetOpt showOrParse (OptionField _n aa) = concatMap optDescrToGetOpt aa where optDescrToGetOpt (ReqArg d (cs, ss) arg_desc set _) = [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d] @@ -368,10 +368,27 @@ viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa [GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d] optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = [GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d] - optDescrToGetOpt (BoolOpt d (sfT, lfT) (sfF, lfF) set _) = - [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) - , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) - ] + optDescrToGetOpt (BoolOpt d trueFlags@(sfT, lfT) falseFlags@(sfF, lfF) set _) = + case showOrParse of + ShowArgs + | Just groupedLongFlag <- mkGroupedBoolLongFlag trueFlags falseFlags -> + [ GetOpt.Option [] [groupedLongFlag] (GetOpt.NoArg (set True)) ("Toggle " ++ d) + ] + _ -> + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) + , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) + ] + + mkGroupedBoolLongFlag :: OptFlags -> OptFlags -> Maybe String + mkGroupedBoolLongFlag ([], [longA]) ([], [longB]) = + checkPair longA longB <|> checkPair longB longA + where + checkPair longEnable longDisable = do + suffixEnable <- List.stripPrefix "enable-" longEnable + suffixDisable <- List.stripPrefix "disable-" longDisable + guard (suffixEnable == suffixDisable) + pure ("[enable|disable]-" ++ suffixEnable) + mkGroupedBoolLongFlag _ _ = Nothing getCurrentChoice :: OptDescr a -> a -> [String] getCurrentChoice (ChoiceOpt alts) a = diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 53c3b35caa0..d724e605fd4 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -73,6 +73,7 @@ module Distribution.Simple.Configure import Control.Monad import Distribution.Compat.Prelude +import GHC.Stack (HasCallStack) import Prelude () import Distribution.Backpack.Configure @@ -81,7 +82,6 @@ import Distribution.Backpack.DescribeUnitId import Distribution.Backpack.Id import Distribution.Backpack.PreExistingComponent import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Stack import Distribution.Compiler import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as IPI @@ -253,7 +253,8 @@ instance Exception ConfigStateFileError -- missing, if the file cannot be read, or if the file was created by an older -- version of Cabal. getConfigStateFile - :: Maybe (SymbolicPath CWD (Dir Pkg)) + :: HasCallStack + => Maybe (SymbolicPath CWD (Dir Pkg)) -> SymbolicPath Pkg File -- ^ The file path of the @setup-config@ file. -> IO LocalBuildInfo @@ -279,8 +280,6 @@ getConfigStateFile mbWorkDir setupConfigFile = do throwIO $ ConfigStateFileBadVersion cabalId compId eResult | otherwise = act deferErrorIfBadVersion getStoredValue - where - _ = callStack -- TODO: attach call stack to exception -- | Read the 'localBuildInfoFile', returning either an error or the local build -- info. diff --git a/Cabal/src/Distribution/Simple/Setup/Test.hs b/Cabal/src/Distribution/Simple/Setup/Test.hs index 5a1563f2b70..00b8121e98f 100644 --- a/Cabal/src/Distribution/Simple/Setup/Test.hs +++ b/Cabal/src/Distribution/Simple/Setup/Test.hs @@ -194,16 +194,19 @@ testOptions' showOrParseArgs = , option [] ["show-details"] - ( "'always': always show results of individual test cases. " - ++ "'never': never show results of individual test cases. " - ++ "'failures': show results of failing test cases. " - ++ "'streaming': show results of test cases in real time." - ++ "'direct': send results of test cases in real time; no log file." + ( unlines + [ "Allowed values:" + , "- always: always show results of individual test cases," + , "- never: never show results of individual test cases," + , "- failures: show results of failing test cases," + , "- streaming: show results of test cases in real time," + , "- direct: send results of test cases in real time; no log file." + ] ) testShowDetails (\v flags -> flags{testShowDetails = v}) ( reqArg - "FILTER" + "always|never|failures|streaming|direct" ( parsecToReadE ( \_ -> "--show-details flag expects one of " diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 3de8bccf6fc..67c8bb76246 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -106,6 +106,7 @@ library Distribution.Client.CmdClean Distribution.Client.CmdConfigure Distribution.Client.CmdErrorMessages + Distribution.Client.Cmd.UI Distribution.Client.CmdExec Distribution.Client.CmdFreeze Distribution.Client.CmdHaddock @@ -256,6 +257,7 @@ library , HTTP >= 4000.1.5 && < 4000.6 , mtl >= 2.0 && < 2.4 , network-uri >= 2.6.2.0 && < 2.7 + , optparse-applicative >= 0.18 && < 0.19 , pretty >= 1.1 && < 1.2 , process >= 1.6.29.0 && < 1.7 , random >= 1.2 && < 1.4 diff --git a/cabal-install/src/Distribution/Client/Cmd/UI.hs b/cabal-install/src/Distribution/Client/Cmd/UI.hs new file mode 100644 index 00000000000..d157f24461b --- /dev/null +++ b/cabal-install/src/Distribution/Client/Cmd/UI.hs @@ -0,0 +1,705 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Client.Cmd.UI + ( -- * Converting CommandUI options to optparse-applicative parsers + optionFieldFlagParsers + , optionFieldParser + , optDescrParser + , optionMods + , flagMods + + -- * Converting CommandUI options to GetOpt descriptions + , optionFieldToGetOpt + , optDescrToGetOpt + + -- * Command data types + , Examples + , ReplaceCommandAlias + , CmdItem (..) + , ParsedCommand (..) + , parsedCommandParser + , cmdItemParser + , cmdOptionParsers + , cmdSpec + , cmdListOptions + , commandNames + , NamedCommandParser (..) + , commandParserByName + , parseCommandWithOptparse + , parseCommandWithOptparseMany + , parseCommand + , replaceCommandAlias + , helpDescriptionOrSynopsis + , parserInfo + + -- * Help text layout helpers + , renderOptionRows + , getOptToColumns + , wrapDescription + , capitalizeDescription + , helpText + + -- * Option grouping helpers + , groupPredicates + , groupSequentially + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Data.Char (isLower) +import Data.List (mapAccumL, stripPrefix) +import Data.Monoid (Endo (..)) +import qualified Data.Text as T +import qualified System.Console.GetOpt as GetOpt + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..) + , keepBenchOptions + , keepCompilerOptions + , keepConfigureOptions + , keepCoverageOptions + , keepDeprecatedOptions + , keepExeOptions + , keepHaddockOptions + , keepIncludeOptions + , keepInstallOptions + , keepIrrelevantOptions + , keepLibOptions + , keepLoggingOptions + , keepOutputOptions + , keepPhaseOptions + , keepProfilingOptions + , keepProgOptions + , keepSolvingOptions + , keepTestOptions + , keepUnsupportedOptions + ) +import Distribution.ReadE (runReadE) +import Distribution.Simple.Command + ( CommandParse (..) + , CommandSpec (..) + , CommandType (NormalCommand) + , CommandUI (..) + , OptDescr (..) + , OptionField (..) + , ShowOrParseArgs (..) + , commandAddAction + , commandParseArgs + ) +import Distribution.Simple.Utils (ordNub) + +import Options.Applicative + ( ParserInfo + , ParserResult (..) + , asum + , defaultPrefs + , execParserPure + , flag' + , footer + , fullDesc + , header + , help + , helper + , info + , long + , metavar + , progDesc + , renderFailure + , strArgument + , (<**>) + ) +import qualified Options.Applicative as O + +helpDescriptionOrSynopsis :: CommandUI flags -> String +helpDescriptionOrSynopsis x = + case commandDescription x of + Nothing -> commandSynopsis x + Just mkDescription -> mkDescription "cabal" + +data CmdItem a + = CmdItemFlag (Endo (NixStyleFlags a)) + | CmdItemTarget String + | CmdItemListOptions + +data ParsedCommand a = ParsedCommand + { parsedFlagEdits :: Endo (NixStyleFlags a) + , parsedTargets :: [String] + , parsedListOptions :: Bool + } + +-- | Examples text for a command, given the program name and command name. +type Examples = + String + -- ^ program name + -> String + -- ^ command name + -> String + -- ^ examples text + +-- | Replacements for v2- prefixed commands, such as; +-- +-- * v2-build -> new-build or +-- * v2-build -> build. +type ReplaceCommandAlias = + String + -- ^ the new prefix + -> String + -- ^ the command + -> String + -- ^ the command name with the prefix replaced + +-- | Given a v2- prefixed command name, returns a function for replacing that +-- prefix with a new prefix. +replaceCommandAlias :: String -> ReplaceCommandAlias +replaceCommandAlias = replaceText + +-- SEE: generic-sop-lens.hs +replaceText :: String -> String -> String -> String +replaceText needle replacement = go + where + go [] = [] + go input@(char : rest) + | Just remainder <- stripPrefix needle input = replacement ++ go remainder + | otherwise = char : go rest + +-- | Puts a prefix before a bare command name. +affixVersionPrefix :: String -> String -> String +affixVersionPrefix = replaceText "v2-" + +-- | Removes the v2- prefix from a command name, leaving the bare command name. +stripVersionPrefix :: String -> String +stripVersionPrefix = affixVersionPrefix "" + +-- | Assuming a v2- prefix for a command name, for the 'commandName' of the +-- given command, makes a list that includes the bare name, the new- prefixed +-- name, and the v2- prefixed name. +commandNames :: CommandUI flags -> [String] +commandNames command = + [ stripVersionPrefix name + , affixVersionPrefix "new-" name + , name + ] + where + name = commandName command + +cmdSpec + :: CommandUI flags + -> (flags -> [String] -> action) + -> [CommandSpec action] +cmdSpec command action = + [CommandSpec ui (`commandAddAction` action) NormalCommand] + where + ui = + command + { commandName = stripVersionPrefix (commandName command) + , commandUsage = stripVersionPrefix . commandUsage command + , commandDescription = (stripVersionPrefix .) <$> commandDescription command + , commandNotes = (stripVersionPrefix .) <$> commandNotes command + } + +cmdListOptions :: CommandUI flags -> [String] +cmdListOptions command = + case commandParseArgs command False ["--list-options"] of + CommandList opts -> opts + _ -> [] + +parseCommand + :: Examples + -> CommandUI (NixStyleFlags a) + -> (NixStyleFlags a -> [String] -> action) + -> String + -> [String] + -> CommandParse action +parseCommand examples cmdui action invokedName cmdArgs = + case execParserPure defaultPrefs pInfo cmdArgs of + Success parsed -> + if parsedListOptions parsed + then CommandList (cmdListOptions cmdui) + else + let flags = appEndo (parsedFlagEdits parsed) (commandDefaultFlags cmdui) + in CommandReadyToGo (action flags (parsedTargets parsed)) + Failure failure -> + let (msg, exitCode) = renderFailure failure ("cabal " ++ invokedName) + in if exitCode == ExitSuccess + then CommandHelp (helpText (replaceCommandAlias (commandName cmdui)) cmdui invokedName) + else CommandErrors [msg] + CompletionInvoked _ -> + CommandErrors ["Shell completion is not supported by this parser path."] + where + pInfo = parserInfo invokedName examples flagParsers cmdui + flagParsers = cmdOptionParsers (commandOptions cmdui ParseArgs) + +parseCommandWithOptparse + :: CommandUI globalFlags + -> (String -> Maybe (String -> [String] -> CommandParse action)) + -> [String] + -> Maybe (CommandParse (globalFlags, CommandParse action)) +parseCommandWithOptparse globalCommand parserForCommand argv = + case commandParseArgs globalCommand True argv of + CommandReadyToGo (mkGlobalFlags, cmdArgs0) -> do + cmdName : cmdArgs <- pure cmdArgs0 + cmdParser <- parserForCommand cmdName + let globalFlags = mkGlobalFlags (commandDefaultFlags globalCommand) + pure $ CommandReadyToGo (globalFlags, cmdParser cmdName cmdArgs) + _ -> Nothing + +-- | A parser for one or more command names. +data NamedCommandParser action = NamedCommandParser + { namedCommandNames :: [String] + -- ^ The command name and its aliases. + , namedCommandParser :: String -> [String] -> CommandParse action + } + +-- | Wrap a command's optparse parser together with the names it should match. +commandParserByName + :: Examples + -> CommandUI (NixStyleFlags flags) + -> (NixStyleFlags flags -> [String] -> action) + -> NamedCommandParser action +commandParserByName examples command action = + NamedCommandParser + { namedCommandNames = commandNames command + , namedCommandParser = \name args -> parseCommand examples command action name args + } + +-- | Parse a command using a list of name/parser associations, picking the first +-- match in the list. +parseCommandWithOptparseMany + :: CommandUI globalFlags + -> [NamedCommandParser action] + -> [String] + -> Maybe (CommandParse (globalFlags, CommandParse action)) +parseCommandWithOptparseMany globalCommand commands argv = + case commandParseArgs globalCommand True argv of + CommandReadyToGo (mkGlobalFlags, cmdArgs0) -> do + cmdName : cmdArgs <- pure cmdArgs0 + parser <- find ((cmdName `elem`) . namedCommandNames) commands + let globalFlags = mkGlobalFlags (commandDefaultFlags globalCommand) + pure $ CommandReadyToGo (globalFlags, namedCommandParser parser cmdName cmdArgs) + _ -> Nothing + +parserInfo :: String -> Examples -> [O.Parser (CmdItem a)] -> CommandUI flags -> ParserInfo (ParsedCommand a) +parserInfo invokedName examples flagParsers cmdui = + info + (parsedCommandParser flagParsers <**> helper) + ( fullDesc + <> progDesc (helpDescriptionOrSynopsis cmdui) + <> header ("cabal " ++ invokedName) + <> footer (examples "cabal" invokedName) + ) + +parsedCommandParser :: [O.Parser (CmdItem a)] -> O.Parser (ParsedCommand a) +parsedCommandParser flagParsers = toParsed <$> many (cmdItemParser flagParsers) + where + toParsed items = + let edits = [e | CmdItemFlag e <- items] + targets = [t | CmdItemTarget t <- items] + listOptionsSeen = any isListOptions items + in ParsedCommand + { parsedFlagEdits = mconcat edits + , parsedTargets = targets + , parsedListOptions = listOptionsSeen + } + + isListOptions CmdItemListOptions = True + isListOptions _ = False + +cmdItemParser :: [O.Parser (CmdItem a)] -> O.Parser (CmdItem a) +cmdItemParser flags = + asum + ( flags + ++ [ CmdItemListOptions + <$ flag' + () + (long "list-options" <> help "Print a list of command line flags") + , CmdItemTarget <$> strArgument (metavar "TARGET") + ] + ) + +cmdOptionParsers :: [OptionField (NixStyleFlags a)] -> [O.Parser (CmdItem a)] +cmdOptionParsers fields = (fmap . fmap) CmdItemFlag (optionFieldFlagParsers fields) + +optionFieldFlagParsers :: [OptionField flags] -> [O.Parser (Endo flags)] +optionFieldFlagParsers = concatMap optionFieldParser + +optionFieldParser :: OptionField flags -> [O.Parser (Endo flags)] +optionFieldParser (OptionField _ descrs) = concatMap optDescrParser descrs + +optDescrParser :: OptDescr flags -> [O.Parser (Endo flags)] +optDescrParser = \case + ReqArg desc optFlags placeHolder reader _show -> + [ Endo + <$> O.option + (O.eitherReader (runReadE reader)) + (optionMods optFlags <> O.metavar placeHolder <> O.help desc) + ] + OptArg desc optFlags placeHolder reader (_defaultText, defaultFn) _show -> + [ Endo + <$> ( O.option + (O.eitherReader (runReadE reader)) + (optionMods optFlags <> O.metavar placeHolder <> O.help desc) + <|> O.flag' defaultFn (flagMods optFlags <> O.internal) + ) + ] + ChoiceOpt choices -> + [ Endo setFn + <$ O.flag' () (flagMods optFlags <> O.help desc) + | (desc, optFlags, setFn, _get) <- choices + ] + BoolOpt desc trueFlags falseFlags setFn _get -> + [ Endo (setFn True) + <$ O.flag' () (flagMods trueFlags <> O.help desc) + , Endo (setFn False) + <$ O.flag' () (flagMods falseFlags <> O.help desc) + ] + +optionMods :: (String, [String]) -> O.Mod O.OptionFields a +optionMods (shortFlags, longFlags) = + mconcat (map O.short shortFlags) <> mconcat (map O.long longFlags) + +flagMods :: (String, [String]) -> O.Mod O.FlagFields a +flagMods (shortFlags, longFlags) = + mconcat (map O.short shortFlags) <> mconcat (map O.long longFlags) + +optionFieldToGetOpt :: OptionField flags -> [GetOpt.OptDescr ()] +optionFieldToGetOpt (OptionField _ descrs) = concatMap optDescrToGetOpt descrs + +optDescrToGetOpt :: OptDescr flags -> [GetOpt.OptDescr ()] +optDescrToGetOpt = \case + ReqArg desc (shortFlags, longFlags) placeHolder _reader _showFlag -> + [GetOpt.Option shortFlags longFlags (GetOpt.ReqArg (const ()) placeHolder) desc] + OptArg desc (shortFlags, longFlags) placeHolder _reader (_defaultValue, _defaultSetter) _showFlag -> + [GetOpt.Option shortFlags longFlags (GetOpt.OptArg (const ()) placeHolder) desc] + ChoiceOpt choices -> + [ GetOpt.Option shortFlags longFlags (GetOpt.NoArg ()) desc + | (desc, (shortFlags, longFlags), _setFn, _getFn) <- choices + ] + BoolOpt desc trueFlags@(shortTrue, longTrue) falseFlags@(shortFalse, longFalse) _setFn _getFn + | null shortFalse && null longFalse -> + [GetOpt.Option shortTrue longTrue (GetOpt.NoArg ()) desc] + | null shortTrue && null longTrue -> + [GetOpt.Option shortFalse longFalse (GetOpt.NoArg ()) desc] + | Just groupedLongFlag <- mkGroupedBoolLongFlag trueFlags falseFlags -> + [GetOpt.Option [] [groupedLongFlag] (GetOpt.NoArg ()) ("Toggle " <> desc)] + | otherwise -> + [ GetOpt.Option shortTrue longTrue (GetOpt.NoArg ()) ("Enable " <> desc) + , GetOpt.Option shortFalse longFalse (GetOpt.NoArg ()) ("Disable " <> desc) + ] + +mkGroupedBoolLongFlag :: (String, [String]) -> (String, [String]) -> Maybe String +mkGroupedBoolLongFlag ([], [longA]) ([], [longB]) = + checkPair longA longB <|> checkPair longB longA + where + checkPair longEnable longDisable = do + suffixEnable <- stripPrefix "enable-" longEnable + suffixDisable <- stripPrefix "disable-" longDisable + guard (suffixEnable == suffixDisable) + pure ("[enable|disable]-" <> suffixEnable) +mkGroupedBoolLongFlag _ _ = Nothing + +renderOptionRows :: (String -> String) -> Int -> Int -> Int -> [GetOpt.OptDescr ()] -> (String, [String]) +renderOptionRows colorizeWarning maxFlagColumnWidth descColumn helpOutputWidth options = + let rendered = [renderOption (index == 0) opt | (index, opt) <- zip [0 :: Int ..] options] + in (concatMap fst rendered, concatMap snd rendered) + where + descriptionMarker = "• " + markerPadding = replicate (length descriptionMarker) ' ' + descriptionIndent = replicate (2 + descColumn) ' ' + descriptionWidth = max 20 (helpOutputWidth - (2 + descColumn) - length descriptionMarker) + + renderOption isFirstInGroup opt = + let (flagColumn, description) = getOptToColumns opt + (capitalizedDescription, wasAutoCapitalized) = capitalizeDescription description + wrappedDescription = wrapDescription descriptionWidth capitalizedDescription + displayDescription = + if wasAutoCapitalized + then colorizeFirstAlpha wrappedDescription + else wrappedDescription + isStacked = length flagColumn > maxFlagColumnWidth + spacer = if isStacked && not isFirstInGroup then "\n" else "" + warning = ["Auto-capitalized help text for " <> flagColumn | wasAutoCapitalized] + renderedRow = + spacer + <> if isStacked + then renderStacked flagColumn displayDescription + else renderInline flagColumn displayDescription + in (renderedRow, warning) + + colorizeFirstAlpha :: [String] -> [String] + colorizeFirstAlpha = go + where + go [] = [] + go (line : rest) = + case colorizeFirstAlphaInLine line of + Nothing -> line : go rest + Just colored -> colored : rest + + colorizeFirstAlphaInLine :: String -> Maybe String + colorizeFirstAlphaInLine = scan [] + where + scan _ [] = Nothing + scan acc (ch : cs) + | isAlpha ch = Just (reverse acc <> colorizeWarning [ch] <> cs) + | otherwise = scan (ch : acc) cs + + renderInline flagColumn descriptionLines = + let padding = max 1 (descColumn - length flagColumn) + in case descriptionLines of + [] -> " " <> flagColumn <> "\n" + firstLineText : continuation -> + let firstLine = " " <> flagColumn <> replicate padding ' ' <> descriptionMarker <> firstLineText <> "\n" + continuationLines = [descriptionIndent <> markerPadding <> line <> "\n" | line <- continuation] + in firstLine <> concat continuationLines + + renderStacked flagColumn descriptionLines = + case descriptionLines of + [] -> " " <> flagColumn <> "\n" + firstLineText : continuation -> + " " + <> flagColumn + <> "\n" + <> descriptionIndent + <> descriptionMarker + <> firstLineText + <> "\n" + <> concat [descriptionIndent <> markerPadding <> line <> "\n" | line <- continuation] + +wrapDescription :: Int -> String -> [String] +wrapDescription width description = + case concatMap wrapParagraph (lines description) of + [] -> [""] + wrapped -> wrapped + where + wrapParagraph paragraph + | null ws = [""] + | otherwise = reverse (foldl' step [""] ws) + where + ws = words paragraph + + step (current : previous) word + | null current = word : previous + | length current + 1 + length word <= width = (current <> " " <> word) : previous + | otherwise = word : current : previous + step [] _ = [] + +capitalizeDescription :: String -> (String, Bool) +capitalizeDescription = go [] + where + go acc [] = (reverse acc, False) + go acc (ch : rest) + | isAlpha ch = + if isLower ch + then (reverse acc <> (toUpper ch : rest), True) + else (reverse acc <> (ch : rest), False) + | otherwise = go (ch : acc) rest + +getOptToColumns :: GetOpt.OptDescr () -> (String, String) +getOptToColumns (GetOpt.Option shortFlags longFlags argDescr description) = + (intercalate ", " (renderShortFlags ++ renderLongFlags), description) + where + renderShortFlags = map renderShortFlag shortFlags + + renderShortFlag shortFlag = + case argDescr of + GetOpt.NoArg _ -> "-" <> [shortFlag] + GetOpt.ReqArg _ metaVar -> "-" <> [shortFlag] <> " " <> metaVar + GetOpt.OptArg _ metaVar -> "-" <> [shortFlag] <> "[" <> metaVar <> "]" + + renderLongFlags = map renderLongFlag longFlags + + renderLongFlag longFlag = + case argDescr of + GetOpt.NoArg _ -> "--" <> longFlag + GetOpt.ReqArg _ metaVar -> "--" <> longFlag <> "=" <> metaVar + GetOpt.OptArg _ metaVar -> "--" <> longFlag <> "[=" <> metaVar <> "]" + +groupSequentially :: [a] -> [(groupName, a -> Bool)] -> ([(groupName, [a])], [a]) +groupSequentially options groupingSpecs = + let step remaining (groupName, keepPred) = + let (groupMembers, leftovers) = partition keepPred remaining + in (leftovers, (groupName, groupMembers)) + (leftoverOptions, groupedBuckets) = mapAccumL step options groupingSpecs + in (groupedBuckets, leftoverOptions) + +data OptionGroupKey + = DeprecatedOptions + | UnsupportedOptions + | InstallLayoutOptions + | IrrelevantOptions + | HaddockOptions + | TestOptions + | BenchmarkOptions + | ProfilingOptions + | DependencySolvingOptions + | ExecutableBuildOptions + | LibraryBuildOptions + | CoverageOptions + | OutputAndArtifactOptions + | ConfigurePhaseOptions + | BuildPhaseControlOptions + | CompilerAndParallelismOptions + | LoggingAndReportingOptions + | IncludeAndLinkerPathOptions + | ProgramOverrideOptions + deriving (Eq) + +instance Show OptionGroupKey where + show DeprecatedOptions = "Deprecated options" + show UnsupportedOptions = "Unsupported options" + show InstallLayoutOptions = "Install layout options" + show IrrelevantOptions = "Irrelevant options" + show HaddockOptions = "Haddock options" + show TestOptions = "Test options" + show BenchmarkOptions = "Benchmark options" + show ProfilingOptions = "Profiling options" + show DependencySolvingOptions = "Dependency solving options" + show ExecutableBuildOptions = "Executable build options" + show LibraryBuildOptions = "Library build options" + show CoverageOptions = "Coverage options" + show OutputAndArtifactOptions = "Output and artifact options" + show ConfigurePhaseOptions = "Configure-phase options" + show BuildPhaseControlOptions = "Build phase control options" + show CompilerAndParallelismOptions = "Compiler and parallelism options" + show LoggingAndReportingOptions = "Logging and reporting options" + show IncludeAndLinkerPathOptions = "Include and linker path options" + show ProgramOverrideOptions = "Program override options" + +groupPredicates :: [(OptionGroupKey, OptionField a -> Bool)] +groupPredicates = + [ (DeprecatedOptions, keepDeprecatedOptions) + , (UnsupportedOptions, keepUnsupportedOptions) + , (InstallLayoutOptions, keepInstallOptions) + , (IrrelevantOptions, keepIrrelevantOptions) + , (HaddockOptions, keepHaddockOptions) + , (TestOptions, keepTestOptions) + , (BenchmarkOptions, keepBenchOptions) + , (ProfilingOptions, keepProfilingOptions) + , (DependencySolvingOptions, keepSolvingOptions) + , (ExecutableBuildOptions, keepExeOptions) + , (LibraryBuildOptions, keepLibOptions) + , (CoverageOptions, keepCoverageOptions) + , (OutputAndArtifactOptions, keepOutputOptions) + , (ConfigurePhaseOptions, keepConfigureOptions) + , (BuildPhaseControlOptions, keepPhaseOptions) + , (CompilerAndParallelismOptions, keepCompilerOptions) + , (LoggingAndReportingOptions, keepLoggingOptions) + , (IncludeAndLinkerPathOptions, keepIncludeOptions) + , (ProgramOverrideOptions, keepProgOptions) + ] + +helpText :: ReplaceCommandAlias -> CommandUI (NixStyleFlags a) -> String -> String -> String +helpText replaceBuildAlias buildCommand invokedName pname = + commandSynopsis buildCommand + <> "\n\n" + <> colorizeUsageHeader (replaceBuildAlias invokedName (commandUsage buildCommand pname)) + <> maybe "" (('\n' :) . ($ pname)) (commandDescription buildCommand) + <> "\n" + <> colorizeHeader "Flags for build:" + <> "\n" + <> ungroupedRows + <> groupedRows + <> warningSection + <> maybe "" (('\n' :) . colorizeExamplesHeader . replaceBuildAlias invokedName . ($ pname)) (commandNotes buildCommand) + where + commonHelpOptions :: [GetOpt.OptDescr ()] + commonHelpOptions = + [GetOpt.Option ['h'] ["help"] (GetOpt.NoArg ()) "Show this help text"] + + maxFlagColumnWidth :: Int + maxFlagColumnWidth = 30 + + helpOutputWidth :: Int + helpOutputWidth = 100 + + allOptions :: [GetOpt.OptDescr ()] + allOptions = + commonHelpOptions + ++ concatMap optionFieldToGetOpt optsUngrouped + ++ concatMap (concatMap optionFieldToGetOpt . snd) optsGrouped + + descColumn :: Int + descColumn = + min + maxFlagColumnWidth + ( maximum + ( 0 + : map + (length . fst . getOptToColumns) + allOptions + ) + ) + + 2 + + (ungroupedRows, ungroupedWarnings) = + renderOptionRows + colorizeWarningHeader + maxFlagColumnWidth + descColumn + helpOutputWidth + (commonHelpOptions ++ concatMap optionFieldToGetOpt optsUngrouped) + + renderGroupToWidth = renderGroup maxFlagColumnWidth descColumn helpOutputWidth + renderedGroups = map renderGroupToWidth optsGrouped + + groupedRows = concatMap fst renderedGroups + + groupedWarnings = concatMap snd renderedGroups + + warningSection = + case ungroupedWarnings ++ groupedWarnings of + [] -> "" + warnings -> + "\n" + <> colorizeWarningHeader "Warnings:" + <> "\n" + <> concat [" - " <> warning <> "\n" | warning <- warnings] + + (optsGrouped, optsUngrouped) = + groupSequentially (commandOptions buildCommand ShowArgs) groupPredicates + +renderGroup :: Int -> Int -> Int -> (OptionGroupKey, [OptionField a]) -> (String, [String]) +renderGroup maxFlagColumnWidth descColumn helpOutputWidth (title, options) + | null options = ("", []) + | title == InstallLayoutOptions = renderInstallLayoutGroupCompact helpOutputWidth options + | otherwise = + let (rows, warnings) = + renderOptionRows + colorizeWarningHeader + maxFlagColumnWidth + descColumn + helpOutputWidth + (concatMap optionFieldToGetOpt options) + in ( "\n" + <> colorizeHeader (show title <> ":") + <> "\n" + <> rows + , warnings + ) + +renderInstallLayoutGroupCompact :: Int -> [OptionField a] -> (String, [String]) +renderInstallLayoutGroupCompact helpOutputWidth options = + ( "\n" + <> colorizeHeader (show InstallLayoutOptions <> ":") + <> "\n" + <> concat [" " <> line <> "\n" | line <- wrappedFlagLines] + , [] + ) + where + flagColumns = map (fst . getOptToColumns) (concatMap optionFieldToGetOpt options) + compactFlags = ordNub flagColumns + flagsLine = intercalate ", " compactFlags + wrappedFlagLines = wrapDescription (max 40 (helpOutputWidth - 2)) flagsLine + +colorizeHeader :: String -> String +colorizeHeader text = "\ESC[32m" <> text <> "\ESC[0m" + +colorizeWarningHeader :: String -> String +colorizeWarningHeader text = "\ESC[31m" <> text <> "\ESC[0m" + +colorizeUsageHeader :: String -> String +colorizeUsageHeader = T.unpack . T.replace (T.pack "Usage:") (T.pack $ colorizeHeader "Usage:") . T.pack + +colorizeExamplesHeader :: String -> String +colorizeExamplesHeader = T.unpack . T.replace (T.pack "Examples:") (T.pack $ colorizeHeader "Examples:") . T.pack diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs index 7314187b815..552161f86d9 100644 --- a/cabal-install/src/Distribution/Client/CmdBuild.hs +++ b/cabal-install/src/Distribution/Client/CmdBuild.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | cabal-install CLI command: build module Distribution.Client.CmdBuild - ( -- * The @build@ CLI and action + ( -- * The @build@ CLI command UI and action buildCommand , buildAction + , examples , BuildFlags (..) , defaultBuildFlags @@ -38,23 +41,44 @@ import Distribution.Client.ScriptUtils , updateContextAndWriteProjectFile , withContextAndSelectors ) -import Distribution.Client.Setup - ( GlobalFlags - , yesNoOpt - ) +import Distribution.Client.Setup (GlobalFlags, yesNoOpt) import Distribution.Simple.Command ( CommandUI (..) , option , usageAlternatives ) import Distribution.Simple.Flag (Flag, fromFlag, toFlag) -import Distribution.Simple.Utils - ( dieWithException - , wrapText - ) -import Distribution.Verbosity - ( normal - ) +import Distribution.Simple.Utils (dieWithException, wrapText) +import Distribution.Verbosity (normal) + +description :: String +description = + "Build one or more targets from within the project. The available " + ++ "targets are the packages in the project as well as individual " + ++ "components within those packages, including libraries, executables, " + ++ "test-suites or benchmarks. Targets can be specified by name or " + ++ "location. If no target is specified then the default is to build " + ++ "the package in the current directory.\n\n" + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files." + +examples :: String -> String -> String +examples pname invokedName = + unlines + [ "Examples:" + , " - " <> pname <> " " <> invokedName + , " Build the package in the current directory or all packages in the project" + , " - " <> pname <> " " <> invokedName <> " pkgname" + , " Build the package named pkgname in the project" + , " - " <> pname <> " " <> invokedName <> " ./pkgfoo" + , " Build the package in the ./pkgfoo directory" + , " - " <> pname <> " " <> invokedName <> " cname" + , " Build the component named cname in the project" + , " - " <> pname <> " " <> invokedName <> " cname --enable-profiling" + , " Build the component in profiling mode (including dependencies as needed)" + ] buildCommand :: CommandUI (NixStyleFlags BuildFlags) buildCommand = @@ -62,42 +86,8 @@ buildCommand = { commandName = "v2-build" , commandSynopsis = "Compile targets within the project." , commandUsage = usageAlternatives "v2-build" ["[TARGETS] [FLAGS]"] - , commandDescription = Just $ \_ -> - wrapText $ - "Build one or more targets from within the project. The available " - ++ "targets are the packages in the project as well as individual " - ++ "components within those packages, including libraries, executables, " - ++ "test-suites or benchmarks. Targets can be specified by name or " - ++ "location. If no target is specified then the default is to build " - ++ "the package in the current directory.\n\n" - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " - ++ pname - ++ " v2-build\n" - ++ " Build the package in the current directory " - ++ "or all packages in the project\n" - ++ " " - ++ pname - ++ " v2-build pkgname\n" - ++ " Build the package named pkgname in the project\n" - ++ " " - ++ pname - ++ " v2-build ./pkgfoo\n" - ++ " Build the package in the ./pkgfoo directory\n" - ++ " " - ++ pname - ++ " v2-build cname\n" - ++ " Build the component named cname in the project\n" - ++ " " - ++ pname - ++ " v2-build cname --enable-profiling\n" - ++ " Build the component in profiling mode " - ++ "(including dependencies as needed)\n" + , commandDescription = Just $ \_ -> wrapText description + , commandNotes = Just $ \pname -> examples pname "v2-build" , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags , commandOptions = removeIgnoreProjectOption diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index 2b0caff2262..a828cef6f23 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -133,7 +133,7 @@ haddockProjectAction flags _extraArgs globalFlags = do verbosity RejectNoTargets Nothing - (commandDefaultFlags CmdBuild.buildCommand) + buildDefaultFlags ["all"] globalFlags HaddockCommand @@ -199,7 +199,7 @@ haddockProjectAction flags _extraArgs globalFlags = do when localStyle $ CmdBuild.buildAction - (commandDefaultFlags CmdBuild.buildCommand) + buildDefaultFlags ["all"] globalFlags @@ -362,6 +362,7 @@ haddockProjectAction flags _extraArgs globalFlags = do where -- build all packages with appropriate haddock flags commonFlags = haddockProjectCommonFlags flags + buildDefaultFlags = NixStyleOptions.defaultNixStyleFlags CmdBuild.defaultBuildFlags verbosity = mkVerbosity defaultVerbosityHandles $ @@ -413,7 +414,7 @@ haddockProjectAction flags _extraArgs globalFlags = do (commandDefaultFlags CmdHaddock.haddockCommand) { NixStyleOptions.haddockFlags = haddockFlags , NixStyleOptions.configFlags = - (NixStyleOptions.configFlags (commandDefaultFlags CmdBuild.buildCommand)) + (NixStyleOptions.configFlags buildDefaultFlags) { configCommonFlags = commonFlags } } diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 1215af9fc7b..c78c7fe85cf 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -4,9 +4,10 @@ -- | cabal-install CLI command: install module Distribution.Client.CmdInstall - ( -- * The @install@ CLI and action + ( -- * The @install@ CLI command UI and action installCommand , installAction + , examples -- * Internals exposed for testing , selectPackageTargets @@ -119,6 +120,7 @@ import Distribution.Simple.BuildPaths ) import Distribution.Simple.Command ( CommandUI (..) + , OptionField (..) , optionName , usageAlternatives ) @@ -187,7 +189,7 @@ import Distribution.System , Platform , buildOS ) -import Distribution.Types.InstalledPackageInfo +import qualified Distribution.Types.InstalledPackageInfo as IPI ( InstalledPackageInfo (..) ) import Distribution.Types.PackageId @@ -285,42 +287,39 @@ data InstallExe = InstallExe -- store. } +description :: String +description = + "Installs one or more packages. This is done by installing them " + ++ "in the store and symlinking or copying the executables in the directory " + ++ "specified by the --installdir flag (`~/.local/bin/` by default). " + ++ "If you want the installed executables to be available globally, " + ++ "make sure that the PATH environment variable contains that directory. " + ++ "\n\n" + ++ "If TARGET is a library and --lib (provisional) is used, " + ++ "it will be added to the global environment. " + ++ "When doing this, cabal will try to build a plan that includes all " + ++ "the previously installed libraries. This is currently not implemented." + +examples :: String -> String -> String +examples pname invokedName = + unlines + [ "Examples:" + , " - " <> pname <> " " <> invokedName + , " Install the package in the current directory" + , " - " <> pname <> " " <> invokedName <> " pkgname" + , " Install the package named pkgname (fetching it from hackage if necessary)" + , " - " <> pname <> " " <> invokedName <> " ./pkgfoo" + , " Install the package in the ./pkgfoo directory" + ] + installCommand :: CommandUI (NixStyleFlags ClientInstallFlags) installCommand = CommandUI { commandName = "v2-install" , commandSynopsis = "Install packages." - , commandUsage = - usageAlternatives - "v2-install" - ["[TARGETS] [FLAGS]"] - , commandDescription = Just $ \_ -> - wrapText $ - "Installs one or more packages. This is done by installing them " - ++ "in the store and symlinking or copying the executables in the directory " - ++ "specified by the --installdir flag (`~/.local/bin/` by default). " - ++ "If you want the installed executables to be available globally, " - ++ "make sure that the PATH environment variable contains that directory. " - ++ "\n\n" - ++ "If TARGET is a library and --lib (provisional) is used, " - ++ "it will be added to the global environment. " - ++ "When doing this, cabal will try to build a plan that includes all " - ++ "the previously installed libraries. This is currently not implemented." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " - ++ pname - ++ " v2-install\n" - ++ " Install the package in the current directory\n" - ++ " " - ++ pname - ++ " v2-install pkgname\n" - ++ " Install the package named pkgname" - ++ " (fetching it from hackage if necessary)\n" - ++ " " - ++ pname - ++ " v2-install ./pkgfoo\n" - ++ " Install the package in the ./pkgfoo directory\n" + , commandUsage = usageAlternatives "v2-install" ["[TARGETS] [FLAGS]"] + , commandDescription = Just $ \_ -> wrapText description + , commandNotes = Just $ \pname -> examples pname "v2-install" , commandOptions = \x -> filter notInstallDirOpt $ nixStyleOptions clientInstallOptions x , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags } @@ -956,7 +955,7 @@ prepareExeInstall installLibraries :: Verbosity -> ProjectBuildContext - -> PI.PackageIndex InstalledPackageInfo + -> PI.PackageIndex IPI.InstalledPackageInfo -> Compiler -> PackageDBStackCWD -> FilePath @@ -989,7 +988,7 @@ installLibraries . sortBy (comparing (Down . fst)) . PI.lookupPackageName installedIndex globalLatest = concatMap getLatest globalPackages - globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest + globalEntries = GhcEnvFilePackageId . IPI.installedUnitId <$> globalLatest baseEntries = GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs pkgEntries = @@ -1078,7 +1077,7 @@ environmentFileToSpecifiers environmentFileToSpecifiers ipi = foldMap $ \case (GhcEnvFilePackageId unitId) | Just - InstalledPackageInfo + IPI.InstalledPackageInfo { sourcePackageId = PackageIdentifier{..} , installedUnitId } <- diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index dc41e483a5e..17bbc3da55c 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -182,6 +182,11 @@ import Distribution.PackageDescription , buildable ) +import Distribution.Client.Cmd.UI + ( cmdSpec + , commandParserByName + , parseCommandWithOptparseMany + ) import Distribution.Client.Errors import Distribution.Compat.ResponseFile import Distribution.PackageDescription.PrettyPrint @@ -232,6 +237,7 @@ import Distribution.Simple.Utils , createDirectoryIfMissingVerbose , die' , dieNoVerbosity + , dieNoWrap , dieWithException , findPackageDesc , info @@ -344,7 +350,7 @@ warnIfAssertionsAreEnabled = mainWorker :: [String] -> IO () mainWorker args = do topHandler (isUserException (Proxy @(VerboseException CabalInstallException))) $ do - command <- commandsRunWithFallback (globalCommand commands) commands delegateToExternal args + command <- commandsParse args case command of CommandHelp help -> printGlobalHelp help CommandList opts -> printOptionsList opts @@ -376,6 +382,19 @@ mainWorker args = do warnIfAssertionsAreEnabled action globalFlags where + -- Tries to parse the command line arguments with optparse-applicative + -- first, and if that fails, falls back to the standard command registry. + commandsParse :: [String] -> IO (CommandParse (GlobalFlags, CommandParse Action)) + commandsParse argv = + case parseCommandWithOptparseMany globalCmd parsersByName argv of + Just parsed -> pure parsed + Nothing -> commandsRunWithFallback globalCmd commands delegateToExternal argv + + parsersByName = + [ commandParserByName CmdBuild.examples CmdBuild.buildCommand CmdBuild.buildAction + , commandParserByName CmdInstall.examples CmdInstall.installCommand CmdInstall.installAction + ] + delegateToExternal :: [Command Action] -> String @@ -454,6 +473,8 @@ mainWorker args = do | cabalGitInfo == cabalInstallGitInfo = "(in-tree)" | otherwise = cabalGitInfo + globalCmd = globalCommand commands + commands = map commandFromSpec commandSpecs commandSpecs = [ regularCmd listCommand listAction @@ -476,14 +497,14 @@ mainWorker args = do ++ concat [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction - , newCmd CmdBuild.buildCommand CmdBuild.buildAction + , cmdSpec CmdBuild.buildCommand CmdBuild.buildAction , newCmd CmdRepl.replCommand CmdRepl.replAction , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction , newCmd CmdHaddockProject.haddockProjectCommand CmdHaddockProject.haddockProjectAction - , newCmd CmdInstall.installCommand CmdInstall.installAction + , cmdSpec CmdInstall.installCommand CmdInstall.installAction , newCmd CmdRun.runCommand CmdRun.runAction , newCmd CmdTest.testCommand CmdTest.testAction , newCmd CmdBench.benchCommand CmdBench.benchAction @@ -1572,9 +1593,14 @@ actAsSetupAction actAsSetupFlags args _globalFlags = Simple.autoconfSetupHooks defaultVerbosityHandles args - Make -> error "actAsSetupAction Main" - Hooks -> error "actAsSetupAction Hooks" - Custom -> error "actAsSetupAction Custom" + Make -> unsupportedBuildType + Hooks -> unsupportedBuildType + Custom -> unsupportedBuildType + where + verbosity = mkVerbosity defaultVerbosityHandles normal + unsupportedBuildType = do + warn verbosity "act-as-setup accepts --build-type=Simple|Configure, case-sensitively." + dieNoWrap verbosity "act-as-setup doesn't accept --build-type=Make|Hooks|Custom." manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action manpageAction commands flags extraArgs _ = do diff --git a/cabal-install/src/Distribution/Client/NixStyleOptions.hs b/cabal-install/src/Distribution/Client/NixStyleOptions.hs index 6201df0d316..c6eda25bda8 100644 --- a/cabal-install/src/Distribution/Client/NixStyleOptions.hs +++ b/cabal-install/src/Distribution/Client/NixStyleOptions.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ViewPatterns #-} + -- | Command line options for nix-style / v2 commands. -- -- The commands take a lot of the same options, which affect how install plan @@ -8,6 +10,27 @@ module Distribution.Client.NixStyleOptions , defaultNixStyleFlags , updNixStyleCommonSetupFlags , cfgVerbosity + + -- * Option filtering/grouping predicates + , keepDeprecatedOptions + , keepUnsupportedOptions + , keepInstallOptions + , keepIrrelevantOptions + , keepHaddockOptions + , keepTestOptions + , keepBenchOptions + , keepProfilingOptions + , keepSolvingOptions + , keepExeOptions + , keepLibOptions + , keepCoverageOptions + , keepOutputOptions + , keepConfigureOptions + , keepPhaseOptions + , keepCompilerOptions + , keepLoggingOptions + , keepIncludeOptions + , keepProgOptions ) where import Distribution.Client.Compat.Prelude @@ -40,6 +63,7 @@ import Distribution.Client.Setup , liftOptions , testOptions ) +import Distribution.Simple.Utils (isInfixOf) import Distribution.Verbosity (VerbosityFlags, defaultVerbosityHandles, mkVerbosity) data NixStyleFlags a = NixStyleFlags @@ -162,3 +186,137 @@ cfgVerbosity :: VerbosityFlags -> NixStyleFlags a -> Verbosity cfgVerbosity v flags = mkVerbosity defaultVerbosityHandles $ fromFlagOrDefault v (setupVerbosity . configCommonFlags $ configFlags flags) + +keepDeprecatedOptions :: OptionField a -> Bool +keepDeprecatedOptions (optionName -> o) = "prefer-oldest" == o + +keepUnsupportedOptions :: OptionField a -> Bool +keepUnsupportedOptions (optionName -> o) = "root-cmd" == o || "allow-boot-library-installs" == o + +keepInstallOptions :: OptionField a -> Bool +keepInstallOptions (optionName -> o) = + "dir" `isSuffixOf` o + || "reinstall" `isInfixOf` o + || "run-tests" == o + || "root-cmd" == o + || "allow-boot-library-installs" == o + || "program-prefix" == o + || "program-suffix" == o + || "ipid" == o + || "cid" == o + || "user" == o + || "global" == o + || "prefix" == o + +keepIrrelevantOptions :: OptionField a -> Bool +keepIrrelevantOptions (optionName -> o) = "per-component" `isSuffixOf` o + +keepHaddockOptions :: OptionField a -> Bool +keepHaddockOptions (optionName -> o) = + "haddock" `isPrefixOf` o + || "documentation" `isSuffixOf` o + || "doc-index-file" == o + +keepTestOptions :: OptionField a -> Bool +keepTestOptions (optionName -> o) = "test" `isPrefixOf` o + +keepBenchOptions :: OptionField a -> Bool +keepBenchOptions (optionName -> o) = "bench" `isPrefixOf` o + +keepProfilingOptions :: OptionField a -> Bool +keepProfilingOptions (optionName -> o) = "profiling" `isInfixOf` o + +keepSolvingOptions :: OptionField a -> Bool +keepSolvingOptions (optionName -> o) = + "max-backjumps" == o + || "conflicts" `isInfixOf` o + || "goals" `isInfixOf` o + || "index-state" == o + || "upgrade-dependencies" == o + || "reject-unconstrained-dependencies" == o + || "prefer-oldest" == o + || "allow-older" == o + || "allow-newer" == o + || "preference" == o + || "shadow-installed-packages" == o + || "ignore-build-tools" == o + || "solver" == o + || "only-dependencies" == o + || "dependencies-only" == o + || "minimize-conflict-set" == o + || "allow-depending-on-private-libs" == o + +keepExeOptions :: OptionField a -> Bool +keepExeOptions (optionName -> o) = + "executable" `isInfixOf` o + || "split" `isInfixOf` o + || "stripping" `isInfixOf` o + +keepLibOptions :: OptionField a -> Bool +keepLibOptions (optionName -> o) = + "vanilla" `isSuffixOf` o + || "shared" `isSuffixOf` o + || "static" `isSuffixOf` o + || "bytecode" `isSuffixOf` o + || "ghci" `isSuffixOf` o + +keepCoverageOptions :: OptionField a -> Bool +keepCoverageOptions (optionName -> o) = + "coverage" `isSuffixOf` o + || "coverage" `isPrefixOf` o + +keepOutputOptions :: OptionField a -> Bool +keepOutputOptions (optionName -> o) = + "build-info" `isSuffixOf` o + || "debug-info" `isSuffixOf` o + || "deterministic" `isSuffixOf` o + || "relocatable" `isSuffixOf` o + || "write-ghc-environment-files" == o + +keepConfigureOptions :: OptionField a -> Bool +keepConfigureOptions (optionName -> o) = + "append" `isSuffixOf` o + || "backup" `isSuffixOf` o + || "configure-option" == o + +keepPhaseOptions :: OptionField a -> Bool +keepPhaseOptions (optionName -> o) = + "only-configure" == o + || "only-download" == o + || "dry-run" == o + +keepCompilerOptions :: OptionField a -> Bool +keepCompilerOptions (optionName -> o) = + "ghc" == o + || "ghcjs" == o + || "uhc" == o + || "with-compiler" == o + || "cabal-lib-version" == o + || "optimization" `isSuffixOf` o + || "semaphore" == o + || "jobs" == o + || "keep-going" == o + || "offline" == o + +keepLoggingOptions :: OptionField a -> Bool +keepLoggingOptions (optionName -> o) = + "verbose" == o + || "keep-temp-files" == o + || "build-summary" == o + || "build-log" == o + || "build-timings" == o + || "remote-build-reporting" == o + || "report-planning-failure" == o + +keepIncludeOptions :: OptionField a -> Bool +keepIncludeOptions (optionName -> o) = + "extra-include-dirs" == o + || "extra-lib-dirs" == o + || "extra-framework-dirs" == o + || "extra-prog-path" == o + || "disable-response-files" == o + +keepProgOptions :: OptionField a -> Bool +keepProgOptions (optionName -> o) = + "with-PROG" == o + || "PROG-option" `isPrefixOf` o diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 7fe9e61fff1..f53d00baba9 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -2739,11 +2739,17 @@ installOptions showOrParseArgs = , option [] ["remote-build-reporting"] - "Generate build reports to send to a remote server (none, anonymous or detailed)." + ( unlines + [ "Generate build reports to send to a remote server:" + , "- none: do not report," + , "- anonymous: report without identifying information," + , "- detailed: report with full details." + ] + ) installBuildReports (\v flags -> flags{installBuildReports = v}) ( reqArg - "LEVEL" + "none|anonymous|detailed" ( parsecToReadE ( const $ "report level must be 'none', " @@ -3445,7 +3451,7 @@ actAsSetupCommand = actAsSetupBuildType (\v flags -> flags{actAsSetupBuildType = v}) ( reqArg - "BUILD-TYPE" + placeholder ( parsecToReadE ("Cannot parse build type: " ++) (fmap toFlag parsec) @@ -3454,6 +3460,9 @@ actAsSetupCommand = ) ] } + where + placeholder = intercalate "|" $ map show setupBuildTypes + setupBuildTypes = [Simple, Configure] -- ------------------------------------------------------------ diff --git a/cabal.project b/cabal.project index f2a31a35ec3..6d1d8b2c04a 100644 --- a/cabal.project +++ b/cabal.project @@ -15,3 +15,6 @@ package Cabal package semaphore-compat flags: -build-testing + +package cabal-testsuite + ghc-options: -Wno-unused-packages