From 0871b4f108c04b370b0293032cd9311c0f301148 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 8 Oct 2026 11:19:40 -0400 Subject: [PATCH 01/15] Update bootstrap with optparse-applicative --- bootstrap/linux-9.10.3.json | 87 +++++++++++++++++++++++++++++++++++++ bootstrap/linux-9.12.4.json | 87 +++++++++++++++++++++++++++++++++++++ bootstrap/linux-9.6.7.json | 87 +++++++++++++++++++++++++++++++++++++ bootstrap/linux-9.8.4.json | 87 +++++++++++++++++++++++++++++++++++++ 4 files changed, 348 insertions(+) diff --git a/bootstrap/linux-9.10.3.json b/bootstrap/linux-9.10.3.json index 140b38d0f40..c1c2252a97d 100644 --- a/bootstrap/linux-9.10.3.json +++ b/bootstrap/linux-9.10.3.json @@ -210,6 +210,38 @@ "src_sha256": "d2a33bc281327d8f20afee18287c2e3f923f0cd86bac40dcba120ca3d2014f9b", "version": "4000.5.0" }, + { + "cabal_sha256": "613dc8d5f6e51babe57398a742ab8d5c2964fa98b773f3bf6e6a72b7e87f1c6e", + "component": "lib:colour", + "flags": [], + "package": "colour", + "revision": 0, + "source": "hackage", + "src_sha256": "1f3b1055675abe4e3362800cc9bf7ab9b92dfdf21a1f6c82b252611270be9680", + "version": "2.3.7" + }, + { + "cabal_sha256": "1d6061eceaf35a9ed269b81177dd4c8c60403a499526f7f68fdffa4ec7842e7f", + "component": "lib:ansi-terminal-types", + "flags": [], + "package": "ansi-terminal-types", + "revision": 0, + "source": "hackage", + "src_sha256": "9fc9ce2157f1889bd99a4d22c9f1c64589590be0f797c3efe71c8fa17a11a689", + "version": "1.1.3" + }, + { + "cabal_sha256": "408d9232e5304efead718f96138d6d7eb2da608c6121c5c0dc6a71a833b14320", + "component": "lib:ansi-terminal", + "flags": [ + "-example" + ], + "package": "ansi-terminal", + "revision": 0, + "source": "hackage", + "src_sha256": "9cf083cef2e2ba88a425f132c8a82bfa931eb4b0c38232b2017f8fcea2e23073", + "version": "1.1.5" + }, { "cabal_sha256": "140fc5adad166f7b527567cbd26ff481e8da4a66bdfc84be3ddf28dbeb66f275", "component": "lib:hashable", @@ -459,6 +491,61 @@ "src_sha256": "1066e286615e39ef43f7e7437a4644775246e264c33b4d259b4858cff0985f0b", "version": "0.5.1.0" }, + { + "cabal_sha256": "e3a802ea939d465b2e37b9fa09d8e5bb88b5775d6d62dd2ec6ca32b63416656d", + "component": "lib:prettyprinter", + "flags": [ + "-buildreadme", + "+text" + ], + "package": "prettyprinter", + "revision": 0, + "source": "hackage", + "src_sha256": "f04eb6fd865512ad8672da1e8bfcea1c384509fc2f662c41b7ac39d7898706ee", + "version": "1.7.2" + }, + { + "cabal_sha256": "5184ba6002a650de3307547347eaba19bdc9b82eb68e943f406818caa215ce4f", + "component": "lib:prettyprinter-ansi-terminal", + "flags": [ + "+text" + ], + "package": "prettyprinter-ansi-terminal", + "revision": 0, + "source": "hackage", + "src_sha256": "912cd340d5c2583111e2eaeb9aa03b87551ca2e3dd78bbfd346756b9f1e6c9fe", + "version": "1.1.4" + }, + { + "cabal_sha256": "044fb9955f63ee138fcebedfdcbe54afe741f2d5892a2d0bdf3a8052bd342643", + "component": "lib:transformers-compat", + "flags": [ + "-five", + "+five-three", + "-four", + "+generic-deriving", + "+mtl", + "-three", + "-two" + ], + "package": "transformers-compat", + "revision": 0, + "source": "hackage", + "src_sha256": "b62c7304c9f3cbc9463d0739aa85cb9489f217ea092b9d625d417514fbcc9d6a", + "version": "0.7.2" + }, + { + "cabal_sha256": "f30973861ac7e7ebff05ff8c7c3d1e4d283a1f3850e1cc14106b0693ec1b6d82", + "component": "lib:optparse-applicative", + "flags": [ + "+process" + ], + "package": "optparse-applicative", + "revision": 1, + "source": "hackage", + "src_sha256": "63811ab4fd26e829b8868364325a88be3acc79819f5bb5005b2dd3b961ecc491", + "version": "0.18.1.0" + }, { "cabal_sha256": "d6c0c6d1136f5046207a331114ff4130e70640452096de7719bf03e3fceb7c7b", "component": "lib:regex-base", diff --git a/bootstrap/linux-9.12.4.json b/bootstrap/linux-9.12.4.json index 2b2203ec259..8fd343f5f94 100644 --- a/bootstrap/linux-9.12.4.json +++ b/bootstrap/linux-9.12.4.json @@ -214,6 +214,38 @@ "src_sha256": "d2a33bc281327d8f20afee18287c2e3f923f0cd86bac40dcba120ca3d2014f9b", "version": "4000.5.0" }, + { + "cabal_sha256": "613dc8d5f6e51babe57398a742ab8d5c2964fa98b773f3bf6e6a72b7e87f1c6e", + "component": "lib:colour", + "flags": [], + "package": "colour", + "revision": 0, + "source": "hackage", + "src_sha256": "1f3b1055675abe4e3362800cc9bf7ab9b92dfdf21a1f6c82b252611270be9680", + "version": "2.3.7" + }, + { + "cabal_sha256": "1d6061eceaf35a9ed269b81177dd4c8c60403a499526f7f68fdffa4ec7842e7f", + "component": "lib:ansi-terminal-types", + "flags": [], + "package": "ansi-terminal-types", + "revision": 0, + "source": "hackage", + "src_sha256": "9fc9ce2157f1889bd99a4d22c9f1c64589590be0f797c3efe71c8fa17a11a689", + "version": "1.1.3" + }, + { + "cabal_sha256": "408d9232e5304efead718f96138d6d7eb2da608c6121c5c0dc6a71a833b14320", + "component": "lib:ansi-terminal", + "flags": [ + "-example" + ], + "package": "ansi-terminal", + "revision": 0, + "source": "hackage", + "src_sha256": "9cf083cef2e2ba88a425f132c8a82bfa931eb4b0c38232b2017f8fcea2e23073", + "version": "1.1.5" + }, { "cabal_sha256": "140fc5adad166f7b527567cbd26ff481e8da4a66bdfc84be3ddf28dbeb66f275", "component": "lib:hashable", @@ -450,6 +482,61 @@ "src_sha256": "1066e286615e39ef43f7e7437a4644775246e264c33b4d259b4858cff0985f0b", "version": "0.5.1.0" }, + { + "cabal_sha256": "e3a802ea939d465b2e37b9fa09d8e5bb88b5775d6d62dd2ec6ca32b63416656d", + "component": "lib:prettyprinter", + "flags": [ + "-buildreadme", + "+text" + ], + "package": "prettyprinter", + "revision": 0, + "source": "hackage", + "src_sha256": "f04eb6fd865512ad8672da1e8bfcea1c384509fc2f662c41b7ac39d7898706ee", + "version": "1.7.2" + }, + { + "cabal_sha256": "5184ba6002a650de3307547347eaba19bdc9b82eb68e943f406818caa215ce4f", + "component": "lib:prettyprinter-ansi-terminal", + "flags": [ + "+text" + ], + "package": "prettyprinter-ansi-terminal", + "revision": 0, + "source": "hackage", + "src_sha256": "912cd340d5c2583111e2eaeb9aa03b87551ca2e3dd78bbfd346756b9f1e6c9fe", + "version": "1.1.4" + }, + { + "cabal_sha256": "044fb9955f63ee138fcebedfdcbe54afe741f2d5892a2d0bdf3a8052bd342643", + "component": "lib:transformers-compat", + "flags": [ + "-five", + "+five-three", + "-four", + "+generic-deriving", + "+mtl", + "-three", + "-two" + ], + "package": "transformers-compat", + "revision": 0, + "source": "hackage", + "src_sha256": "b62c7304c9f3cbc9463d0739aa85cb9489f217ea092b9d625d417514fbcc9d6a", + "version": "0.7.2" + }, + { + "cabal_sha256": "f30973861ac7e7ebff05ff8c7c3d1e4d283a1f3850e1cc14106b0693ec1b6d82", + "component": "lib:optparse-applicative", + "flags": [ + "+process" + ], + "package": "optparse-applicative", + "revision": 1, + "source": "hackage", + "src_sha256": "63811ab4fd26e829b8868364325a88be3acc79819f5bb5005b2dd3b961ecc491", + "version": "0.18.1.0" + }, { "cabal_sha256": "d6c0c6d1136f5046207a331114ff4130e70640452096de7719bf03e3fceb7c7b", "component": "lib:regex-base", diff --git a/bootstrap/linux-9.6.7.json b/bootstrap/linux-9.6.7.json index 842d5572401..bd9320e9429 100644 --- a/bootstrap/linux-9.6.7.json +++ b/bootstrap/linux-9.6.7.json @@ -202,6 +202,38 @@ "src_sha256": "d2a33bc281327d8f20afee18287c2e3f923f0cd86bac40dcba120ca3d2014f9b", "version": "4000.5.0" }, + { + "cabal_sha256": "613dc8d5f6e51babe57398a742ab8d5c2964fa98b773f3bf6e6a72b7e87f1c6e", + "component": "lib:colour", + "flags": [], + "package": "colour", + "revision": 0, + "source": "hackage", + "src_sha256": "1f3b1055675abe4e3362800cc9bf7ab9b92dfdf21a1f6c82b252611270be9680", + "version": "2.3.7" + }, + { + "cabal_sha256": "1d6061eceaf35a9ed269b81177dd4c8c60403a499526f7f68fdffa4ec7842e7f", + "component": "lib:ansi-terminal-types", + "flags": [], + "package": "ansi-terminal-types", + "revision": 0, + "source": "hackage", + "src_sha256": "9fc9ce2157f1889bd99a4d22c9f1c64589590be0f797c3efe71c8fa17a11a689", + "version": "1.1.3" + }, + { + "cabal_sha256": "408d9232e5304efead718f96138d6d7eb2da608c6121c5c0dc6a71a833b14320", + "component": "lib:ansi-terminal", + "flags": [ + "-example" + ], + "package": "ansi-terminal", + "revision": 0, + "source": "hackage", + "src_sha256": "9cf083cef2e2ba88a425f132c8a82bfa931eb4b0c38232b2017f8fcea2e23073", + "version": "1.1.5" + }, { "cabal_sha256": "c0663f5f428108680f4aae0f67b7b357c1bb5954281c7fbe941c50c58cd79f18", "component": "lib:os-string", @@ -461,6 +493,61 @@ "src_sha256": "1066e286615e39ef43f7e7437a4644775246e264c33b4d259b4858cff0985f0b", "version": "0.5.1.0" }, + { + "cabal_sha256": "e3a802ea939d465b2e37b9fa09d8e5bb88b5775d6d62dd2ec6ca32b63416656d", + "component": "lib:prettyprinter", + "flags": [ + "-buildreadme", + "+text" + ], + "package": "prettyprinter", + "revision": 0, + "source": "hackage", + "src_sha256": "f04eb6fd865512ad8672da1e8bfcea1c384509fc2f662c41b7ac39d7898706ee", + "version": "1.7.2" + }, + { + "cabal_sha256": "5184ba6002a650de3307547347eaba19bdc9b82eb68e943f406818caa215ce4f", + "component": "lib:prettyprinter-ansi-terminal", + "flags": [ + "+text" + ], + "package": "prettyprinter-ansi-terminal", + "revision": 0, + "source": "hackage", + "src_sha256": "912cd340d5c2583111e2eaeb9aa03b87551ca2e3dd78bbfd346756b9f1e6c9fe", + "version": "1.1.4" + }, + { + "cabal_sha256": "044fb9955f63ee138fcebedfdcbe54afe741f2d5892a2d0bdf3a8052bd342643", + "component": "lib:transformers-compat", + "flags": [ + "-five", + "+five-three", + "-four", + "+generic-deriving", + "+mtl", + "-three", + "-two" + ], + "package": "transformers-compat", + "revision": 0, + "source": "hackage", + "src_sha256": "b62c7304c9f3cbc9463d0739aa85cb9489f217ea092b9d625d417514fbcc9d6a", + "version": "0.7.2" + }, + { + "cabal_sha256": "f30973861ac7e7ebff05ff8c7c3d1e4d283a1f3850e1cc14106b0693ec1b6d82", + "component": "lib:optparse-applicative", + "flags": [ + "+process" + ], + "package": "optparse-applicative", + "revision": 1, + "source": "hackage", + "src_sha256": "63811ab4fd26e829b8868364325a88be3acc79819f5bb5005b2dd3b961ecc491", + "version": "0.18.1.0" + }, { "cabal_sha256": "d6c0c6d1136f5046207a331114ff4130e70640452096de7719bf03e3fceb7c7b", "component": "lib:regex-base", diff --git a/bootstrap/linux-9.8.4.json b/bootstrap/linux-9.8.4.json index 56be7837098..569e9ac11b7 100644 --- a/bootstrap/linux-9.8.4.json +++ b/bootstrap/linux-9.8.4.json @@ -202,6 +202,38 @@ "src_sha256": "d2a33bc281327d8f20afee18287c2e3f923f0cd86bac40dcba120ca3d2014f9b", "version": "4000.5.0" }, + { + "cabal_sha256": "613dc8d5f6e51babe57398a742ab8d5c2964fa98b773f3bf6e6a72b7e87f1c6e", + "component": "lib:colour", + "flags": [], + "package": "colour", + "revision": 0, + "source": "hackage", + "src_sha256": "1f3b1055675abe4e3362800cc9bf7ab9b92dfdf21a1f6c82b252611270be9680", + "version": "2.3.7" + }, + { + "cabal_sha256": "1d6061eceaf35a9ed269b81177dd4c8c60403a499526f7f68fdffa4ec7842e7f", + "component": "lib:ansi-terminal-types", + "flags": [], + "package": "ansi-terminal-types", + "revision": 0, + "source": "hackage", + "src_sha256": "9fc9ce2157f1889bd99a4d22c9f1c64589590be0f797c3efe71c8fa17a11a689", + "version": "1.1.3" + }, + { + "cabal_sha256": "408d9232e5304efead718f96138d6d7eb2da608c6121c5c0dc6a71a833b14320", + "component": "lib:ansi-terminal", + "flags": [ + "-example" + ], + "package": "ansi-terminal", + "revision": 0, + "source": "hackage", + "src_sha256": "9cf083cef2e2ba88a425f132c8a82bfa931eb4b0c38232b2017f8fcea2e23073", + "version": "1.1.5" + }, { "cabal_sha256": "c0663f5f428108680f4aae0f67b7b357c1bb5954281c7fbe941c50c58cd79f18", "component": "lib:os-string", @@ -461,6 +493,61 @@ "src_sha256": "1066e286615e39ef43f7e7437a4644775246e264c33b4d259b4858cff0985f0b", "version": "0.5.1.0" }, + { + "cabal_sha256": "e3a802ea939d465b2e37b9fa09d8e5bb88b5775d6d62dd2ec6ca32b63416656d", + "component": "lib:prettyprinter", + "flags": [ + "-buildreadme", + "+text" + ], + "package": "prettyprinter", + "revision": 0, + "source": "hackage", + "src_sha256": "f04eb6fd865512ad8672da1e8bfcea1c384509fc2f662c41b7ac39d7898706ee", + "version": "1.7.2" + }, + { + "cabal_sha256": "5184ba6002a650de3307547347eaba19bdc9b82eb68e943f406818caa215ce4f", + "component": "lib:prettyprinter-ansi-terminal", + "flags": [ + "+text" + ], + "package": "prettyprinter-ansi-terminal", + "revision": 0, + "source": "hackage", + "src_sha256": "912cd340d5c2583111e2eaeb9aa03b87551ca2e3dd78bbfd346756b9f1e6c9fe", + "version": "1.1.4" + }, + { + "cabal_sha256": "044fb9955f63ee138fcebedfdcbe54afe741f2d5892a2d0bdf3a8052bd342643", + "component": "lib:transformers-compat", + "flags": [ + "-five", + "+five-three", + "-four", + "+generic-deriving", + "+mtl", + "-three", + "-two" + ], + "package": "transformers-compat", + "revision": 0, + "source": "hackage", + "src_sha256": "b62c7304c9f3cbc9463d0739aa85cb9489f217ea092b9d625d417514fbcc9d6a", + "version": "0.7.2" + }, + { + "cabal_sha256": "f30973861ac7e7ebff05ff8c7c3d1e4d283a1f3850e1cc14106b0693ec1b6d82", + "component": "lib:optparse-applicative", + "flags": [ + "+process" + ], + "package": "optparse-applicative", + "revision": 1, + "source": "hackage", + "src_sha256": "63811ab4fd26e829b8868364325a88be3acc79819f5bb5005b2dd3b961ecc491", + "version": "0.18.1.0" + }, { "cabal_sha256": "d6c0c6d1136f5046207a331114ff4130e70640452096de7719bf03e3fceb7c7b", "component": "lib:regex-base", From bf3fd85848bdfa973ed2f76e1cc625b307950f67 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Fri, 9 Oct 2026 08:45:42 -0400 Subject: [PATCH 02/15] Use optparse-applicative for build and install --- cabal-install/cabal-install.cabal | 2 + .../src/Distribution/Client/Cmd/UI.hs | 295 ++++++++++++++++++ cabal-install/src/Distribution/Client/Main.hs | 21 +- 3 files changed, 317 insertions(+), 1 deletion(-) create mode 100644 cabal-install/src/Distribution/Client/Cmd/UI.hs diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 83628ab03d1..5c9b2396c40 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..1555676d42b --- /dev/null +++ b/cabal-install/src/Distribution/Client/Cmd/UI.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Parsing the command line of a command with optparse-applicative, by +-- translating the command's 'OptionField's into optparse-applicative parsers. +-- +-- Only parsing is affected: help, the list of options and the command registry +-- keep using "Distribution.Simple.Command". +module Distribution.Client.Cmd.UI + ( -- * Parsing a command with optparse-applicative + NamedCommandParser (..) + , commandParserByName + , parseCommandWithOptparseMany + , parseCommand + , commandNames + + -- * Converting CommandUI options to optparse-applicative parsers + , CmdItem (..) + , ParsedCommand (..) + , parsedCommandParser + , cmdItemParser + , cmdOptionParsers + , optionFieldFlagParsers + , optionFieldParser + , optDescrParser + , supplyOptArgDefaults + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Data.List (stripPrefix) +import Data.Monoid (Endo (..)) + +import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) +import Distribution.ReadE (runReadE) +import Distribution.Simple.Command + ( CommandParse (..) + , CommandUI (..) + , OptDescr (..) + , OptionField (..) + , ShowOrParseArgs (..) + , commandParseArgs + ) + +import Options.Applicative + ( ParserInfo + , ParserResult (..) + , asum + , defaultPrefs + , execParserPure + , flag' + , fullDesc + , help + , helper + , info + , long + , metavar + , progDesc + , renderFailure + , strArgument + , (<**>) + ) +import qualified Options.Applicative as O + +-- | A parser for a command under any of its names. +data NamedCommandParser action = NamedCommandParser + { namedCommandNames :: [String] + -- ^ The command name and its aliases. + , namedCommandParser :: String -> [String] -> CommandParse action + -- ^ Parse the arguments of the command, given the name it was invoked by. + } + +-- | Wrap a command's optparse parser together with the names it should match. +commandParserByName + :: CommandUI (NixStyleFlags flags) + -> (NixStyleFlags flags -> [String] -> action) + -> NamedCommandParser action +commandParserByName command action = + NamedCommandParser + { namedCommandNames = commandNames command + , namedCommandParser = parseCommand command action + } + +-- | Parse the global flags with "Distribution.Simple.Command", then the +-- command with the first parser whose names include the command name. +-- Returns 'Nothing' when no parser matches, so the caller can fall back to +-- the command registry. +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 + +-- | Assuming a v2- prefix for the 'commandName' of the given command, the +-- bare name, the new- prefixed name and the v2- prefixed name, in that order. +commandNames :: CommandUI flags -> [String] +commandNames command = [stripVersionPrefix name, affixVersionPrefix "new-" name, name] + where + name = commandName command + +-- | 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 "" + +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 + +-- | The command as it presents itself under the given name: its usage, +-- description and notes refer to that name instead of the canonical one. +renameCommand :: String -> CommandUI flags -> CommandUI flags +renameCommand name command = + command + { commandName = name + , commandUsage = rename . commandUsage command + , commandDescription = (rename .) <$> commandDescription command + , commandNotes = (rename .) <$> commandNotes command + } + where + rename = replaceText (commandName command) name + +-- | Parse a command's arguments with optparse-applicative. Help and the list +-- of options come from "Distribution.Simple.Command", so they are the same +-- as for commands that are not parsed this way. +parseCommand + :: CommandUI (NixStyleFlags a) + -> (NixStyleFlags a -> [String] -> action) + -> String + -- ^ The name the command was invoked by. + -> [String] + -> CommandParse action +parseCommand cmdui action invokedName cmdArgs = + case execParserPure defaultPrefs pInfo (supplyOptArgDefaults optionFields cmdArgs) of + Success parsed + | parsedListOptions parsed -> legacy ["--list-options"] + | otherwise -> + 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 legacy ["--help"] + else CommandErrors [msg] + CompletionInvoked _ -> + CommandErrors ["Shell completion is not supported by this parser path."] + where + pInfo = parserInfo invokedName flagParsers cmdui + optionFields = commandOptions cmdui ParseArgs + flagParsers = cmdOptionParsers optionFields + + -- Help and the options list, rendered by "Distribution.Simple.Command" + -- for the command under the name it was invoked by. + legacy args = + case commandParseArgs (renameCommand invokedName cmdui) False args of + CommandHelp helpText -> CommandHelp helpText + CommandList options -> CommandList options + _ -> CommandErrors ["Unexpected result from the command parser."] + +-- | Insert an empty argument after each bare occurrence of an +-- optional-argument option, so that @--allow-newer@ and @-j@ keep their +-- GetOpt meaning: the option's default, with the next word left as a +-- positional argument. Attached forms such as @--allow-newer=base@ and +-- @-j4@ are left alone, as is everything after @--@. +supplyOptArgDefaults :: [OptionField flags] -> [String] -> [String] +supplyOptArgDefaults fields = go + where + go [] = [] + go ("--" : rest) = "--" : rest + go (arg : rest) + | arg `elem` bareForms = arg : "" : go rest + | otherwise = arg : go rest + + bareForms = + [ form + | OptionField _ descrs <- fields + , OptArg _ (shortFlags, longFlags) _ _ _ _ <- descrs + , form <- map (\c -> ['-', c]) shortFlags ++ map ("--" ++) longFlags + ] + +parserInfo :: String -> [O.Parser (CmdItem a)] -> CommandUI flags -> ParserInfo (ParsedCommand a) +parserInfo invokedName flagParsers cmdui = + info + (parsedCommandParser flagParsers <**> helper) + (fullDesc <> progDesc (commandSynopsis cmdui) <> O.header ("cabal " ++ invokedName)) + +-- | One item of a command line: a flag, a target, or the request to list +-- the options. +data CmdItem a + = CmdItemFlag (Endo (NixStyleFlags a)) + | CmdItemTarget String + | CmdItemListOptions + +data ParsedCommand a = ParsedCommand + { parsedFlagEdits :: Endo (NixStyleFlags a) + , parsedTargets :: [String] + , parsedListOptions :: Bool + } + +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 + { -- Apply edits in command-line order, first to last, so that a + -- later option overrides an earlier one and list options + -- accumulate in the order given. @Endo f <> Endo g@ applies + -- @g@ first, so the list is reversed before being combined. + -- This matches @accum@ in 'commandParseArgs'. + parsedFlagEdits = mconcat (reverse 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 defaultFn _show -> + -- optparse-applicative has no optional-argument options: an option + -- either always takes an argument or never does, and a bare @-j@ would + -- swallow the next word as its value. 'supplyOptArgDefaults' gives each + -- bare occurrence an empty argument instead, which the reader maps to the + -- option's default. An explicit @--jobs=@ therefore also means the default. + [ Endo + <$> O.option + (O.eitherReader readOrDefault) + (optionMods optFlags <> O.metavar placeHolder <> O.help desc) + ] + where + readOrDefault "" = Right defaultFn + readOrDefault s = runReadE reader s + 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) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 2dd8fed4a4a..aba6662edd6 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -182,6 +182,10 @@ import Distribution.PackageDescription , buildable ) +import Distribution.Client.Cmd.UI + ( commandParserByName + , parseCommandWithOptparseMany + ) import Distribution.Client.Errors import Distribution.Compat.ResponseFile import Distribution.PackageDescription.PrettyPrint @@ -345,7 +349,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 @@ -377,6 +381,21 @@ mainWorker args = do warnIfAssertionsAreEnabled action globalFlags where + -- Parse the command line with optparse-applicative for the commands that + -- support it, falling back to the command registry for the others. + 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.buildCommand CmdBuild.buildAction + , commandParserByName CmdInstall.installCommand CmdInstall.installAction + ] + + globalCmd = globalCommand commands + delegateToExternal :: [Command Action] -> String From a90f1171027820466cf36ee0b0677ab7e020eaef Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Fri, 9 Oct 2026 08:55:17 -0400 Subject: [PATCH 03/15] Disambiguate abbreviated, generalise flags --- .../src/Distribution/Client/Cmd/UI.hs | 32 ++++++++++--------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Cmd/UI.hs b/cabal-install/src/Distribution/Client/Cmd/UI.hs index 1555676d42b..f5811e4412c 100644 --- a/cabal-install/src/Distribution/Client/Cmd/UI.hs +++ b/cabal-install/src/Distribution/Client/Cmd/UI.hs @@ -31,7 +31,6 @@ import Prelude () import Data.List (stripPrefix) import Data.Monoid (Endo (..)) -import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) import Distribution.ReadE (runReadE) import Distribution.Simple.Command ( CommandParse (..) @@ -46,7 +45,7 @@ import Options.Applicative ( ParserInfo , ParserResult (..) , asum - , defaultPrefs + , disambiguate , execParserPure , flag' , fullDesc @@ -55,6 +54,7 @@ import Options.Applicative , info , long , metavar + , prefs , progDesc , renderFailure , strArgument @@ -72,8 +72,8 @@ data NamedCommandParser action = NamedCommandParser -- | Wrap a command's optparse parser together with the names it should match. commandParserByName - :: CommandUI (NixStyleFlags flags) - -> (NixStyleFlags flags -> [String] -> action) + :: CommandUI flags + -> (flags -> [String] -> action) -> NamedCommandParser action commandParserByName command action = NamedCommandParser @@ -139,14 +139,16 @@ renameCommand name command = -- of options come from "Distribution.Simple.Command", so they are the same -- as for commands that are not parsed this way. parseCommand - :: CommandUI (NixStyleFlags a) - -> (NixStyleFlags a -> [String] -> action) + :: CommandUI flags + -> (flags -> [String] -> action) -> String -- ^ The name the command was invoked by. -> [String] -> CommandParse action parseCommand cmdui action invokedName cmdArgs = - case execParserPure defaultPrefs pInfo (supplyOptArgDefaults optionFields cmdArgs) of + -- 'disambiguate' accepts an unambiguous prefix of a long option, as + -- "Distribution.GetOpt" does. + case execParserPure (prefs disambiguate) pInfo (supplyOptArgDefaults optionFields cmdArgs) of Success parsed | parsedListOptions parsed -> legacy ["--list-options"] | otherwise -> @@ -193,7 +195,7 @@ supplyOptArgDefaults fields = go , form <- map (\c -> ['-', c]) shortFlags ++ map ("--" ++) longFlags ] -parserInfo :: String -> [O.Parser (CmdItem a)] -> CommandUI flags -> ParserInfo (ParsedCommand a) +parserInfo :: String -> [O.Parser (CmdItem flags)] -> CommandUI flags -> ParserInfo (ParsedCommand flags) parserInfo invokedName flagParsers cmdui = info (parsedCommandParser flagParsers <**> helper) @@ -201,18 +203,18 @@ parserInfo invokedName flagParsers cmdui = -- | One item of a command line: a flag, a target, or the request to list -- the options. -data CmdItem a - = CmdItemFlag (Endo (NixStyleFlags a)) +data CmdItem flags + = CmdItemFlag (Endo flags) | CmdItemTarget String | CmdItemListOptions -data ParsedCommand a = ParsedCommand - { parsedFlagEdits :: Endo (NixStyleFlags a) +data ParsedCommand flags = ParsedCommand + { parsedFlagEdits :: Endo flags , parsedTargets :: [String] , parsedListOptions :: Bool } -parsedCommandParser :: [O.Parser (CmdItem a)] -> O.Parser (ParsedCommand a) +parsedCommandParser :: [O.Parser (CmdItem flags)] -> O.Parser (ParsedCommand flags) parsedCommandParser flagParsers = toParsed <$> many (cmdItemParser flagParsers) where toParsed items = @@ -233,7 +235,7 @@ parsedCommandParser flagParsers = toParsed <$> many (cmdItemParser flagParsers) isListOptions CmdItemListOptions = True isListOptions _ = False -cmdItemParser :: [O.Parser (CmdItem a)] -> O.Parser (CmdItem a) +cmdItemParser :: [O.Parser (CmdItem flags)] -> O.Parser (CmdItem flags) cmdItemParser flags = asum ( flags @@ -243,7 +245,7 @@ cmdItemParser flags = ] ) -cmdOptionParsers :: [OptionField (NixStyleFlags a)] -> [O.Parser (CmdItem a)] +cmdOptionParsers :: [OptionField flags] -> [O.Parser (CmdItem flags)] cmdOptionParsers fields = (fmap . fmap) CmdItemFlag (optionFieldFlagParsers fields) optionFieldFlagParsers :: [OptionField flags] -> [O.Parser (Endo flags)] From dc50579b8fe33f5d97616de20a9957fd42e100f8 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Fri, 9 Oct 2026 09:07:39 -0400 Subject: [PATCH 04/15] Add remaining v2 commands --- cabal-install/src/Distribution/Client/Main.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index aba6662edd6..c8f71ff4434 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -390,8 +390,23 @@ mainWorker args = do Nothing -> commandsRunWithFallback globalCmd commands delegateToExternal argv parsersByName = - [ commandParserByName CmdBuild.buildCommand CmdBuild.buildAction + [ commandParserByName CmdConfigure.configureCommand CmdConfigure.configureAction + , commandParserByName CmdUpdate.updateCommand CmdUpdate.updateAction + , commandParserByName CmdBuild.buildCommand CmdBuild.buildAction + , commandParserByName CmdRepl.replCommand CmdRepl.replAction + , commandParserByName CmdFreeze.freezeCommand CmdFreeze.freezeAction + , commandParserByName CmdHaddock.haddockCommand CmdHaddock.haddockAction + , commandParserByName CmdHaddockProject.haddockProjectCommand CmdHaddockProject.haddockProjectAction , commandParserByName CmdInstall.installCommand CmdInstall.installAction + , commandParserByName CmdRun.runCommand CmdRun.runAction + , commandParserByName CmdTest.testCommand CmdTest.testAction + , commandParserByName CmdBench.benchCommand CmdBench.benchAction + , commandParserByName CmdExec.execCommand CmdExec.execAction + , commandParserByName CmdClean.cleanCommand CmdClean.cleanAction + , commandParserByName CmdSdist.sdistCommand CmdSdist.sdistAction + , commandParserByName CmdTarget.targetCommand CmdTarget.targetAction + , commandParserByName CmdGenBounds.genBoundsCommand CmdGenBounds.genBoundsAction + , commandParserByName CmdOutdated.outdatedCommand CmdOutdated.outdatedAction ] globalCmd = globalCommand commands From 9f580e4783e21ad4dc9400902c0d8971924530a0 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Fri, 9 Oct 2026 09:11:08 -0400 Subject: [PATCH 05/15] Do our own disambiguation --- .../src/Distribution/Client/Cmd/UI.hs | 94 +++++++++++++++---- 1 file changed, 74 insertions(+), 20 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Cmd/UI.hs b/cabal-install/src/Distribution/Client/Cmd/UI.hs index f5811e4412c..db45ee2e543 100644 --- a/cabal-install/src/Distribution/Client/Cmd/UI.hs +++ b/cabal-install/src/Distribution/Client/Cmd/UI.hs @@ -45,7 +45,7 @@ import Options.Applicative ( ParserInfo , ParserResult (..) , asum - , disambiguate + , defaultPrefs , execParserPure , flag' , fullDesc @@ -54,7 +54,6 @@ import Options.Applicative , info , long , metavar - , prefs , progDesc , renderFailure , strArgument @@ -122,8 +121,10 @@ replaceText needle replacement = go | Just remainder <- stripPrefix needle input = replacement ++ go remainder | otherwise = char : go rest --- | The command as it presents itself under the given name: its usage, --- description and notes refer to that name instead of the canonical one. +-- | The command as it presents itself under the given name. As +-- "Distribution.Client.CmdLegacy" does, every @v2-@ prefix in its usage, +-- description and notes is rewritten to the prefix of that name, so that +-- references to other commands follow the invoked spelling too. renameCommand :: String -> CommandUI flags -> CommandUI flags renameCommand name command = command @@ -133,7 +134,8 @@ renameCommand name command = , commandNotes = (rename .) <$> commandNotes command } where - rename = replaceText (commandName command) name + rename = replaceText "v2-" prefix + prefix = take (length name - length (stripVersionPrefix (commandName command))) name -- | Parse a command's arguments with optparse-applicative. Help and the list -- of options come from "Distribution.Simple.Command", so they are the same @@ -146,26 +148,28 @@ parseCommand -> [String] -> CommandParse action parseCommand cmdui action invokedName cmdArgs = - -- 'disambiguate' accepts an unambiguous prefix of a long option, as - -- "Distribution.GetOpt" does. - case execParserPure (prefs disambiguate) pInfo (supplyOptArgDefaults optionFields cmdArgs) of - Success parsed - | parsedListOptions parsed -> legacy ["--list-options"] - | otherwise -> - 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 legacy ["--help"] - else CommandErrors [msg] - CompletionInvoked _ -> - CommandErrors ["Shell completion is not supported by this parser path."] + case expandAbbreviations (optionLongNames optionFields) cmdArgs of + Left ambiguous -> CommandErrors [ambiguous] + Right expanded -> parseExpanded expanded where pInfo = parserInfo invokedName flagParsers cmdui optionFields = commandOptions cmdui ParseArgs flagParsers = cmdOptionParsers optionFields + parseExpanded args = case execParserPure defaultPrefs pInfo (supplyOptArgDefaults optionFields args) of + Success parsed + | parsedListOptions parsed -> legacy ["--list-options"] + | otherwise -> + 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 legacy ["--help"] + else CommandErrors [msg] + CompletionInvoked _ -> + CommandErrors ["Shell completion is not supported by this parser path."] + -- Help and the options list, rendered by "Distribution.Simple.Command" -- for the command under the name it was invoked by. legacy args = @@ -174,6 +178,56 @@ parseCommand cmdui action invokedName cmdArgs = CommandList options -> CommandList options _ -> CommandErrors ["Unexpected result from the command parser."] +-- | The long names of all the options, plus the common @--help@ and +-- @--list-options@. +optionLongNames :: [OptionField flags] -> [String] +optionLongNames fields = + ["help", "list-options"] + ++ [ name + | OptionField _ descrs <- fields + , descr <- descrs + , (_, longs) <- optFlagsOf descr + , name <- longs + ] + where + optFlagsOf = \case + ReqArg _ optFlags _ _ _ -> [optFlags] + OptArg _ optFlags _ _ _ _ -> [optFlags] + ChoiceOpt choices -> [optFlags | (_, optFlags, _, _) <- choices] + BoolOpt _ trueFlags falseFlags _ _ -> [trueFlags, falseFlags] + +-- | Expand each abbreviated long option to its full name, as +-- "Distribution.GetOpt" does: an exact name wins, otherwise a unique prefix +-- is accepted, and an ambiguous prefix is an error naming the candidates. +-- optparse-applicative's own disambiguation has no preference for an exact +-- name, so @--lib@ would be ambiguous with @--libdir@. Everything after +-- @--@ is left alone, as are unknown names, which optparse-applicative +-- reports. +expandAbbreviations :: [String] -> [String] -> Either String [String] +expandAbbreviations longNames = go + where + go [] = Right [] + go ("--" : rest) = Right ("--" : rest) + go (arg : rest) + | Just body <- stripPrefix "--" arg + , not (null body) = + let (name, value) = break (== '=') body + in do + name' <- expand name + (("--" ++ name' ++ value) :) <$> go rest + | otherwise = (arg :) <$> go rest + + expand name + | name `elem` longNames = Right name + | otherwise = case filter (name `isPrefixOf`) longNames of + [full] -> Right full + [] -> Right name + candidates -> + Left $ + unlines $ + ("option `--" ++ name ++ "' is ambiguous; could be one of:") + : map (" --" ++) candidates + -- | Insert an empty argument after each bare occurrence of an -- optional-argument option, so that @--allow-newer@ and @-j@ keep their -- GetOpt meaning: the option's default, with the next word left as a From faecc6b5ce56d05119d550c6dfe306ae0372ee8e Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Fri, 9 Oct 2026 09:13:35 -0400 Subject: [PATCH 06/15] Reference disambiguation issue --- cabal-install/src/Distribution/Client/Cmd/UI.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Cmd/UI.hs b/cabal-install/src/Distribution/Client/Cmd/UI.hs index db45ee2e543..6a6cfc26b9d 100644 --- a/cabal-install/src/Distribution/Client/Cmd/UI.hs +++ b/cabal-install/src/Distribution/Client/Cmd/UI.hs @@ -199,10 +199,12 @@ optionLongNames fields = -- | Expand each abbreviated long option to its full name, as -- "Distribution.GetOpt" does: an exact name wins, otherwise a unique prefix -- is accepted, and an ambiguous prefix is an error naming the candidates. --- optparse-applicative's own disambiguation has no preference for an exact --- name, so @--lib@ would be ambiguous with @--libdir@. Everything after --- @--@ is left alone, as are unknown names, which optparse-applicative --- reports. +-- optparse-applicative's own 'disambiguate' preference gives no precedence +-- to an exact name, so @--lib@ would be ambiguous with @--libdir@; upstream +-- considers that correct and will not change it, see +-- . +-- Everything after @--@ is left alone, as are unknown names, which +-- optparse-applicative reports. expandAbbreviations :: [String] -> [String] -> Either String [String] expandAbbreviations longNames = go where From ae4d5faadb8d3aa329ff88f9981a6fd7d1d9376d Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Fri, 9 Oct 2026 09:35:26 -0400 Subject: [PATCH 07/15] Add tests comparing with GetOpt parser - Smallest set of sample values --- cabal-install/cabal-install.cabal | 1 + cabal-install/tests/UnitTests.hs | 4 + .../UnitTests/Distribution/Client/CmdUI.hs | 218 ++++++++++++++++++ 3 files changed, 223 insertions(+) create mode 100644 cabal-install/tests/UnitTests/Distribution/Client/CmdUI.hs diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 5c9b2396c40..4cf4a6206f5 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -332,6 +332,7 @@ test-suite unit-tests other-modules: UnitTests.Distribution.Client.ArbitraryInstances UnitTests.Distribution.Client.BuildReport + UnitTests.Distribution.Client.CmdUI UnitTests.Distribution.Client.Configure UnitTests.Distribution.Client.FetchUtils UnitTests.Distribution.Client.Get diff --git a/cabal-install/tests/UnitTests.hs b/cabal-install/tests/UnitTests.hs index c38f65d40c1..533037ba4ff 100644 --- a/cabal-install/tests/UnitTests.hs +++ b/cabal-install/tests/UnitTests.hs @@ -3,6 +3,7 @@ module Main (main) where import Test.Tasty import qualified UnitTests.Distribution.Client.BuildReport +import qualified UnitTests.Distribution.Client.CmdUI import qualified UnitTests.Distribution.Client.Configure import qualified UnitTests.Distribution.Client.FetchUtils import qualified UnitTests.Distribution.Client.GZipUtils @@ -48,6 +49,9 @@ main = do , testGroup "UnitTests.Distribution.Client.Glob" UnitTests.Distribution.Client.Glob.tests + , testGroup + "UnitTests.Distribution.Client.CmdUI" + UnitTests.Distribution.Client.CmdUI.tests , testGroup "UnitTests.Distribution.Client.HttpUtils" UnitTests.Distribution.Client.HttpUtils.tests diff --git a/cabal-install/tests/UnitTests/Distribution/Client/CmdUI.hs b/cabal-install/tests/UnitTests/Distribution/Client/CmdUI.hs new file mode 100644 index 00000000000..bca978e5ce2 --- /dev/null +++ b/cabal-install/tests/UnitTests/Distribution/Client/CmdUI.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Differential tests for "Distribution.Client.Cmd.UI": the +-- optparse-applicative parser must agree with "Distribution.Simple.Command", +-- the parser it replaces, on every command line generated from a command's +-- own option definitions. +module UnitTests.Distribution.Client.CmdUI (tests) where + +import Distribution.Client.Cmd.UI (parseCommand) +import Distribution.ReadE (runReadE) +import Distribution.Simple.Command + ( CommandParse (..) + , CommandUI (..) + , OptDescr (..) + , OptionField (..) + , ShowOrParseArgs (..) + , commandParseArgs + , commandShowOptions + ) + +import qualified Distribution.Client.CmdBench as CmdBench +import qualified Distribution.Client.CmdBuild as CmdBuild +import qualified Distribution.Client.CmdClean as CmdClean +import qualified Distribution.Client.CmdConfigure as CmdConfigure +import qualified Distribution.Client.CmdExec as CmdExec +import qualified Distribution.Client.CmdFreeze as CmdFreeze +import qualified Distribution.Client.CmdGenBounds as CmdGenBounds +import qualified Distribution.Client.CmdHaddock as CmdHaddock +import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject +import qualified Distribution.Client.CmdInstall as CmdInstall +import qualified Distribution.Client.CmdOutdated as CmdOutdated +import qualified Distribution.Client.CmdRepl as CmdRepl +import qualified Distribution.Client.CmdRun as CmdRun +import qualified Distribution.Client.CmdSdist as CmdSdist +import qualified Distribution.Client.CmdTarget as CmdTarget +import qualified Distribution.Client.CmdTest as CmdTest +import qualified Distribution.Client.CmdUpdate as CmdUpdate + +import Data.Either (isRight) +import Data.List (inits, isPrefixOf, nub) +import Data.Maybe (listToMaybe) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tests :: [TestTree] +tests = + [ testGroup "optparse-applicative agrees with Distribution.Simple.Command" (map agreementTest commands) + , testGroup "every option has a sample value" (map coverageTest commands) + ] + +-- | A command whose flags type is hidden, so the commands can be listed. +data SomeCommand = forall flags. SomeCommand (CommandUI flags) + +commands :: [SomeCommand] +commands = + [ SomeCommand CmdConfigure.configureCommand + , SomeCommand CmdUpdate.updateCommand + , SomeCommand CmdBuild.buildCommand + , SomeCommand CmdRepl.replCommand + , SomeCommand CmdFreeze.freezeCommand + , SomeCommand CmdHaddock.haddockCommand + , SomeCommand CmdHaddockProject.haddockProjectCommand + , SomeCommand CmdInstall.installCommand + , SomeCommand CmdRun.runCommand + , SomeCommand CmdTest.testCommand + , SomeCommand CmdBench.benchCommand + , SomeCommand CmdExec.execCommand + , SomeCommand CmdClean.cleanCommand + , SomeCommand CmdSdist.sdistCommand + , SomeCommand CmdTarget.targetCommand + , SomeCommand CmdGenBounds.genBoundsCommand + , SomeCommand CmdOutdated.outdatedCommand + ] + +-- | What a parse produced, in a form that can be compared: the options +-- rendered back to their command-line spelling by 'commandShowOptions', +-- and the targets. +data Outcome = Ready [String] [String] | Rejected + deriving (Eq, Show) + +legacyOutcome :: CommandUI flags -> [String] -> Outcome +legacyOutcome command args = + case commandParseArgs command False args of + CommandReadyToGo (setFlags, targets) -> + Ready (commandShowOptions command (setFlags (commandDefaultFlags command))) targets + _ -> Rejected + +optparseOutcome :: CommandUI flags -> [String] -> Outcome +optparseOutcome command args = + case parseCommand command (,) (commandName command) args of + CommandReadyToGo (flags, targets) -> Ready (commandShowOptions command flags) targets + _ -> Rejected + +agreementTest :: SomeCommand -> TestTree +agreementTest (SomeCommand command) = + testProperty (commandName command) $ + forAllShrink (genArgs command) shrinkArgs $ \args -> + legacyOutcome command args === optparseOutcome command args + +-- | Every option with an argument needs at least one sample value its +-- reader accepts, or the agreement test would never exercise it. +coverageTest :: SomeCommand -> TestTree +coverageTest (SomeCommand command) = + testCase (commandName command) $ + assertEqual "options without an accepted sample value" [] uncovered + where + uncovered = + [ name + | OptionField name descrs <- commandOptions command ParseArgs + , descr <- descrs + , Just reader <- [readerOf descr] + , null (acceptedValues reader) + ] + readerOf (ReqArg _ _ _ reader _) = Just (fmap (const ()) . runReadE reader) + readerOf (OptArg _ _ _ reader _ _) = Just (fmap (const ()) . runReadE reader) + readerOf _ = Nothing + +-- | Candidate argument values; each option uses the ones its reader accepts. +-- This is the smallest set that gives every option with an argument, across +-- all the commands, at least one accepted value. Each entry names the options +-- that accept no other value in the set. +sampleValues :: [String] +sampleValues = + [ "1" -- --verbose, --jobs, --max-backjumps, --cabal-lib-version + , "always" -- --test-show-details, --overwrite-policy, --write-ghc-environment-files + , "foo ==1.0" -- --constraint + , "HEAD" -- --index-state + , "Sig=foo-1.0:Impl" -- --instantiate-with + , "copy" -- --install-method + , "latest" -- --prefer-version + , "legacy" -- --project-file-parser + , "modular" -- --solver + , "none" -- --remote-build-reporting, --reject-unconstrained-dependencies + ] + +acceptedValues :: (String -> Either e a) -> [String] +acceptedValues reader = filter (isRight . reader) sampleValues + +-- | The command-line spellings of each option, from its definition: every +-- long and short name, with a sample value where one is taken, plus the +-- shortest unambiguous abbreviation of each long name. +optionSpellings :: CommandUI flags -> [[String]] +optionSpellings command = concatMap spellings descrs ++ abbreviations + where + descrs = [descr | OptionField _ ds <- commandOptions command ParseArgs, descr <- ds] + + spellings (ReqArg _ (shorts, longs) _ reader _) = + [ form + | value <- take 1 (acceptedValues (runReadE reader)) + , form <- + [["--" ++ long ++ "=" ++ value] | long <- longs] + ++ [["--" ++ long, value] | long <- longs] + ++ [["-" ++ [short], value] | short <- shorts] + ++ [["-" ++ [short] ++ value] | short <- shorts] + ] + spellings (OptArg _ (shorts, longs) _ reader _ _) = + [["--" ++ long] | long <- longs] + ++ [["-" ++ [short]] | short <- shorts] + ++ [ form + | value <- take 1 (acceptedValues (runReadE reader)) + , form <- + [["--" ++ long ++ "=" ++ value] | long <- longs] + ++ [["-" ++ [short] ++ value] | short <- shorts] + ] + spellings (ChoiceOpt choices) = + [ form + | (_, (shorts, longs), _, _) <- choices + , form <- [["--" ++ long] | long <- longs] ++ [["-" ++ [short]] | short <- shorts] + ] + spellings (BoolOpt _ trueFlags falseFlags _ _) = + [ form + | (shorts, longs) <- [trueFlags, falseFlags] + , form <- [["--" ++ long] | long <- longs] ++ [["-" ++ [short]] | short <- shorts] + ] + + -- The names the legacy parser disambiguates against include the common + -- --help and --list-options, which the generated lines never use. + allLongNames = nub $ ["help", "list-options"] ++ concatMap longNamesOf descrs + longNamesOf (ReqArg _ (_, longs) _ _ _) = longs + longNamesOf (OptArg _ (_, longs) _ _ _ _) = longs + longNamesOf (ChoiceOpt choices) = concat [longs | (_, (_, longs), _, _) <- choices] + longNamesOf (BoolOpt _ (_, trueLongs) (_, falseLongs) _ _) = trueLongs ++ falseLongs + + abbreviations = + [ ["--" ++ prefix ++ suffix] + | descr <- descrs + , long <- longNamesOf descr + , Just prefix <- [shortestUniquePrefix long] + , suffix <- case descr of + ReqArg _ _ _ reader _ -> ['=' : value | value <- take 1 (acceptedValues (runReadE reader))] + _ -> [""] + ] + shortestUniquePrefix long = + listToMaybe + [ prefix + | prefix <- drop 1 (inits long) + , prefix /= long + , [long] == filter (prefix `isPrefixOf`) allLongNames + ] + +sampleTargets :: [String] +sampleTargets = ["pkg", "lib:foo", "exe:bar", "./dir", "all"] + +genArgs :: CommandUI flags -> Gen [String] +genArgs command = do + items <- listOf item + trailing <- frequency [(3, pure []), (1, ("--" :) <$> listOf (elements ("--bogus" : "-x" : sampleTargets)))] + pure (concat items ++ trailing) + where + spellings = optionSpellings command + item = + frequency $ + [(6, elements spellings) | not (null spellings)] + ++ [(3, (: []) <$> elements sampleTargets), (1, pure ["--bogus"])] + +shrinkArgs :: [String] -> [[String]] +shrinkArgs = shrinkList (const []) From d4bdbceb4eeb4b9ec7baf8cf37e05d83254987e9 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Fri, 9 Oct 2026 15:20:03 -0400 Subject: [PATCH 08/15] Follow hlint suggestions: use void and ordNub --- .../tests/UnitTests/Distribution/Client/CmdUI.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/CmdUI.hs b/cabal-install/tests/UnitTests/Distribution/Client/CmdUI.hs index bca978e5ce2..3e797016ef6 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/CmdUI.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/CmdUI.hs @@ -17,6 +17,7 @@ import Distribution.Simple.Command , commandParseArgs , commandShowOptions ) +import Distribution.Utils.Generic (ordNub) import qualified Distribution.Client.CmdBench as CmdBench import qualified Distribution.Client.CmdBuild as CmdBuild @@ -36,8 +37,9 @@ import qualified Distribution.Client.CmdTarget as CmdTarget import qualified Distribution.Client.CmdTest as CmdTest import qualified Distribution.Client.CmdUpdate as CmdUpdate +import Control.Monad (void) import Data.Either (isRight) -import Data.List (inits, isPrefixOf, nub) +import Data.List (inits, isPrefixOf) import Data.Maybe (listToMaybe) import Test.Tasty import Test.Tasty.HUnit @@ -112,8 +114,8 @@ coverageTest (SomeCommand command) = , Just reader <- [readerOf descr] , null (acceptedValues reader) ] - readerOf (ReqArg _ _ _ reader _) = Just (fmap (const ()) . runReadE reader) - readerOf (OptArg _ _ _ reader _ _) = Just (fmap (const ()) . runReadE reader) + readerOf (ReqArg _ _ _ reader _) = Just (void . runReadE reader) + readerOf (OptArg _ _ _ reader _ _) = Just (void . runReadE reader) readerOf _ = Nothing -- | Candidate argument values; each option uses the ones its reader accepts. @@ -176,7 +178,7 @@ optionSpellings command = concatMap spellings descrs ++ abbreviations -- The names the legacy parser disambiguates against include the common -- --help and --list-options, which the generated lines never use. - allLongNames = nub $ ["help", "list-options"] ++ concatMap longNamesOf descrs + allLongNames = ordNub (["help", "list-options"] ++ concatMap longNamesOf descrs) longNamesOf (ReqArg _ (_, longs) _ _ _) = longs longNamesOf (OptArg _ (_, longs) _ _ _ _) = longs longNamesOf (ChoiceOpt choices) = concat [longs | (_, (_, longs), _, _) <- choices] From cfa9bd888dca7f79d18ec93ecccc8c2479a84dd9 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Fri, 9 Oct 2026 08:45:52 -0400 Subject: [PATCH 09/15] Add changelog entry --- changelog.d/pr-12438.md | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 changelog.d/pr-12438.md diff --git a/changelog.d/pr-12438.md b/changelog.d/pr-12438.md new file mode 100644 index 00000000000..fd9b51f662d --- /dev/null +++ b/changelog.d/pr-12438.md @@ -0,0 +1,20 @@ +--- +synopsis: Parse the v2 command lines with optparse-applicative +packages: [cabal-install] +significance: significant +prs: 12438 +issues: 5607 +--- + +The project commands (the v2- ones and their bare defaults) now parse their +options and targets with `optparse-applicative`. + +The only visible difference is in error messages for a mistyped option, which +now come from `optparse-applicative` and include a lengthy usage line listing +all possible options. + +The parsing behaviour goes beyond `optparse-applicative` default behaviour: + +- abbreviation of a long option is accepted, +- an exact name takes precedence over a longer option it is a prefix of, +- optional-argument options such as `-j` and `--allow-newer` work as before. From 3bd32e09a74f1cf013172c7bef3204aa94b8d165 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 15 Oct 2026 10:21:23 -0400 Subject: [PATCH 10/15] Use @optparse-applicative@ in haddocks --- .../src/Distribution/Client/Cmd/UI.hs | 24 ++++++++++--------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Cmd/UI.hs b/cabal-install/src/Distribution/Client/Cmd/UI.hs index 6a6cfc26b9d..407687a3db2 100644 --- a/cabal-install/src/Distribution/Client/Cmd/UI.hs +++ b/cabal-install/src/Distribution/Client/Cmd/UI.hs @@ -1,19 +1,20 @@ {-# LANGUAGE LambdaCase #-} --- | Parsing the command line of a command with optparse-applicative, by --- translating the command's 'OptionField's into optparse-applicative parsers. +-- | Parsing the command line of a command with +-- , by +-- translating the command's 'OptionField's into @optparse-applicative@ parsers. -- -- Only parsing is affected: help, the list of options and the command registry -- keep using "Distribution.Simple.Command". module Distribution.Client.Cmd.UI - ( -- * Parsing a command with optparse-applicative + ( -- * Parsing a command with @optparse-applicative@ NamedCommandParser (..) , commandParserByName , parseCommandWithOptparseMany , parseCommand , commandNames - -- * Converting CommandUI options to optparse-applicative parsers + -- * Converting CommandUI options to @optparse-applicative@ parsers , CmdItem (..) , ParsedCommand (..) , parsedCommandParser @@ -87,13 +88,14 @@ commandParserByName command action = parseCommandWithOptparseMany :: CommandUI globalFlags -> [NamedCommandParser action] + -- ^ The commands parsed with @optparse-applicative@. -> [String] -> Maybe (CommandParse (globalFlags, CommandParse action)) -parseCommandWithOptparseMany globalCommand commands argv = +parseCommandWithOptparseMany globalCommand parsers argv = case commandParseArgs globalCommand True argv of CommandReadyToGo (mkGlobalFlags, cmdArgs0) -> do cmdName : cmdArgs <- pure cmdArgs0 - parser <- find ((cmdName `elem`) . namedCommandNames) commands + parser <- find ((cmdName `elem`) . namedCommandNames) parsers let globalFlags = mkGlobalFlags (commandDefaultFlags globalCommand) pure $ CommandReadyToGo (globalFlags, namedCommandParser parser cmdName cmdArgs) _ -> Nothing @@ -137,9 +139,9 @@ renameCommand name command = rename = replaceText "v2-" prefix prefix = take (length name - length (stripVersionPrefix (commandName command))) name --- | Parse a command's arguments with optparse-applicative. Help and the list --- of options come from "Distribution.Simple.Command", so they are the same --- as for commands that are not parsed this way. +-- | Parse a command's arguments with @optparse-applicative@. Help and the list +-- of options come from "Distribution.Simple.Command", so they are the same as +-- for commands that are not parsed this way. parseCommand :: CommandUI flags -> (flags -> [String] -> action) @@ -199,12 +201,12 @@ optionLongNames fields = -- | Expand each abbreviated long option to its full name, as -- "Distribution.GetOpt" does: an exact name wins, otherwise a unique prefix -- is accepted, and an ambiguous prefix is an error naming the candidates. --- optparse-applicative's own 'disambiguate' preference gives no precedence +-- @optparse-applicative@'s own 'disambiguate' preference gives no precedence -- to an exact name, so @--lib@ would be ambiguous with @--libdir@; upstream -- considers that correct and will not change it, see -- . -- Everything after @--@ is left alone, as are unknown names, which --- optparse-applicative reports. +-- @optparse-applicative@ reports. expandAbbreviations :: [String] -> [String] -> Either String [String] expandAbbreviations longNames = go where From 8e3030653d7fca823b07409e9a210bf25468ff72 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 15 Oct 2026 10:21:41 -0400 Subject: [PATCH 11/15] Add a CommandRegistry newtype --- cabal-install/src/Distribution/Client/Main.hs | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index c8f71ff4434..111a35b34f8 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -343,6 +343,11 @@ warnIfAssertionsAreEnabled = -- | Core worker, similar to 'defaultMainHelper' in Cabal/Distribution.Simple -- +-- | Every command, under each of its names, that "Distribution.Simple.Command" +-- dispatches on. The commands also parsed with optparse-applicative are +-- registered here too, for their help and for @--list-options@. +newtype CommandRegistry = CommandRegistry {registeredCommands :: [Command Action]} + -- With an exception-handler @topHandler@, mainWorker calls commandsRun -- to parse arguments, then pattern-matches the CommandParse data -- into IO actions for execution. @@ -385,11 +390,14 @@ mainWorker args = do -- support it, falling back to the command registry for the others. commandsParse :: [String] -> IO (CommandParse (GlobalFlags, CommandParse Action)) commandsParse argv = - case parseCommandWithOptparseMany globalCmd parsersByName argv of + case parseCommandWithOptparseMany globalCmd commandParsers argv of Just parsed -> pure parsed - Nothing -> commandsRunWithFallback globalCmd commands delegateToExternal argv + Nothing -> commandsRunWithFallback globalCmd (registeredCommands commandRegistry) delegateToExternal argv - parsersByName = + -- The commands parsed with optparse-applicative, tried before the command + -- registry that "Distribution.Simple.Command" dispatches on. A command + -- missing from here still parses the old way. + commandParsers = [ commandParserByName CmdConfigure.configureCommand CmdConfigure.configureAction , commandParserByName CmdUpdate.updateCommand CmdUpdate.updateAction , commandParserByName CmdBuild.buildCommand CmdBuild.buildAction @@ -409,7 +417,7 @@ mainWorker args = do , commandParserByName CmdOutdated.outdatedCommand CmdOutdated.outdatedAction ] - globalCmd = globalCommand commands + globalCmd = globalCommand (registeredCommands commandRegistry) delegateToExternal :: [Command Action] @@ -489,7 +497,7 @@ mainWorker args = do | cabalGitInfo == cabalInstallGitInfo = "(in-tree)" | otherwise = cabalGitInfo - commands = map commandFromSpec commandSpecs + commandRegistry = CommandRegistry (map commandFromSpec commandSpecs) commandSpecs = [ regularCmd listCommand listAction , regularCmd infoCommand infoAction From 0ea07cc86c0e1c6647bcbeac0da6a540872d9e8c Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 15 Oct 2026 10:31:14 -0400 Subject: [PATCH 12/15] Shorten names in module UI --- .../src/Distribution/Client/Cmd/UI.hs | 72 +++++++++---------- cabal-install/src/Distribution/Client/Main.hs | 4 +- 2 files changed, 38 insertions(+), 38 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Cmd/UI.hs b/cabal-install/src/Distribution/Client/Cmd/UI.hs index 407687a3db2..240dc11db3b 100644 --- a/cabal-install/src/Distribution/Client/Cmd/UI.hs +++ b/cabal-install/src/Distribution/Client/Cmd/UI.hs @@ -10,20 +10,20 @@ module Distribution.Client.Cmd.UI ( -- * Parsing a command with @optparse-applicative@ NamedCommandParser (..) , commandParserByName - , parseCommandWithOptparseMany + , parseCommands , parseCommand , commandNames -- * Converting CommandUI options to @optparse-applicative@ parsers , CmdItem (..) , ParsedCommand (..) - , parsedCommandParser - , cmdItemParser - , cmdOptionParsers - , optionFieldFlagParsers - , optionFieldParser - , optDescrParser - , supplyOptArgDefaults + , commandParser + , itemParser + , optionParsers + , flagEditParsers + , fieldParsers + , descrParsers + , supplyDefaults ) where import Distribution.Client.Compat.Prelude @@ -85,13 +85,13 @@ commandParserByName command action = -- command with the first parser whose names include the command name. -- Returns 'Nothing' when no parser matches, so the caller can fall back to -- the command registry. -parseCommandWithOptparseMany +parseCommands :: CommandUI globalFlags -> [NamedCommandParser action] -- ^ The commands parsed with @optparse-applicative@. -> [String] -> Maybe (CommandParse (globalFlags, CommandParse action)) -parseCommandWithOptparseMany globalCommand parsers argv = +parseCommands globalCommand parsers argv = case commandParseArgs globalCommand True argv of CommandReadyToGo (mkGlobalFlags, cmdArgs0) -> do cmdName : cmdArgs <- pure cmdArgs0 @@ -150,15 +150,15 @@ parseCommand -> [String] -> CommandParse action parseCommand cmdui action invokedName cmdArgs = - case expandAbbreviations (optionLongNames optionFields) cmdArgs of + case expandAbbreviations (longNames optionFields) cmdArgs of Left ambiguous -> CommandErrors [ambiguous] Right expanded -> parseExpanded expanded where - pInfo = parserInfo invokedName flagParsers cmdui + pInfo = parserInfo invokedName itemParsers cmdui optionFields = commandOptions cmdui ParseArgs - flagParsers = cmdOptionParsers optionFields + itemParsers = optionParsers optionFields - parseExpanded args = case execParserPure defaultPrefs pInfo (supplyOptArgDefaults optionFields args) of + parseExpanded args = case execParserPure defaultPrefs pInfo (supplyDefaults optionFields args) of Success parsed | parsedListOptions parsed -> legacy ["--list-options"] | otherwise -> @@ -182,8 +182,8 @@ parseCommand cmdui action invokedName cmdArgs = -- | The long names of all the options, plus the common @--help@ and -- @--list-options@. -optionLongNames :: [OptionField flags] -> [String] -optionLongNames fields = +longNames :: [OptionField flags] -> [String] +longNames fields = ["help", "list-options"] ++ [ name | OptionField _ descrs <- fields @@ -208,7 +208,7 @@ optionLongNames fields = -- Everything after @--@ is left alone, as are unknown names, which -- @optparse-applicative@ reports. expandAbbreviations :: [String] -> [String] -> Either String [String] -expandAbbreviations longNames = go +expandAbbreviations names = go where go [] = Right [] go ("--" : rest) = Right ("--" : rest) @@ -222,8 +222,8 @@ expandAbbreviations longNames = go | otherwise = (arg :) <$> go rest expand name - | name `elem` longNames = Right name - | otherwise = case filter (name `isPrefixOf`) longNames of + | name `elem` names = Right name + | otherwise = case filter (name `isPrefixOf`) names of [full] -> Right full [] -> Right name candidates -> @@ -237,8 +237,8 @@ expandAbbreviations longNames = go -- GetOpt meaning: the option's default, with the next word left as a -- positional argument. Attached forms such as @--allow-newer=base@ and -- @-j4@ are left alone, as is everything after @--@. -supplyOptArgDefaults :: [OptionField flags] -> [String] -> [String] -supplyOptArgDefaults fields = go +supplyDefaults :: [OptionField flags] -> [String] -> [String] +supplyDefaults fields = go where go [] = [] go ("--" : rest) = "--" : rest @@ -254,9 +254,9 @@ supplyOptArgDefaults fields = go ] parserInfo :: String -> [O.Parser (CmdItem flags)] -> CommandUI flags -> ParserInfo (ParsedCommand flags) -parserInfo invokedName flagParsers cmdui = +parserInfo invokedName itemParsers cmdui = info - (parsedCommandParser flagParsers <**> helper) + (commandParser itemParsers <**> helper) (fullDesc <> progDesc (commandSynopsis cmdui) <> O.header ("cabal " ++ invokedName)) -- | One item of a command line: a flag, a target, or the request to list @@ -272,8 +272,8 @@ data ParsedCommand flags = ParsedCommand , parsedListOptions :: Bool } -parsedCommandParser :: [O.Parser (CmdItem flags)] -> O.Parser (ParsedCommand flags) -parsedCommandParser flagParsers = toParsed <$> many (cmdItemParser flagParsers) +commandParser :: [O.Parser (CmdItem flags)] -> O.Parser (ParsedCommand flags) +commandParser itemParsers = toParsed <$> many (itemParser itemParsers) where toParsed items = let edits = [e | CmdItemFlag e <- items] @@ -293,8 +293,8 @@ parsedCommandParser flagParsers = toParsed <$> many (cmdItemParser flagParsers) isListOptions CmdItemListOptions = True isListOptions _ = False -cmdItemParser :: [O.Parser (CmdItem flags)] -> O.Parser (CmdItem flags) -cmdItemParser flags = +itemParser :: [O.Parser (CmdItem flags)] -> O.Parser (CmdItem flags) +itemParser flags = asum ( flags ++ [ CmdItemListOptions @@ -303,17 +303,17 @@ cmdItemParser flags = ] ) -cmdOptionParsers :: [OptionField flags] -> [O.Parser (CmdItem flags)] -cmdOptionParsers fields = (fmap . fmap) CmdItemFlag (optionFieldFlagParsers fields) +optionParsers :: [OptionField flags] -> [O.Parser (CmdItem flags)] +optionParsers fields = (fmap . fmap) CmdItemFlag (flagEditParsers fields) -optionFieldFlagParsers :: [OptionField flags] -> [O.Parser (Endo flags)] -optionFieldFlagParsers = concatMap optionFieldParser +flagEditParsers :: [OptionField flags] -> [O.Parser (Endo flags)] +flagEditParsers = concatMap fieldParsers -optionFieldParser :: OptionField flags -> [O.Parser (Endo flags)] -optionFieldParser (OptionField _ descrs) = concatMap optDescrParser descrs +fieldParsers :: OptionField flags -> [O.Parser (Endo flags)] +fieldParsers (OptionField _ descrs) = concatMap descrParsers descrs -optDescrParser :: OptDescr flags -> [O.Parser (Endo flags)] -optDescrParser = \case +descrParsers :: OptDescr flags -> [O.Parser (Endo flags)] +descrParsers = \case ReqArg desc optFlags placeHolder reader _show -> [ Endo <$> O.option @@ -323,7 +323,7 @@ optDescrParser = \case OptArg desc optFlags placeHolder reader defaultFn _show -> -- optparse-applicative has no optional-argument options: an option -- either always takes an argument or never does, and a bare @-j@ would - -- swallow the next word as its value. 'supplyOptArgDefaults' gives each + -- swallow the next word as its value. 'supplyDefaults' gives each -- bare occurrence an empty argument instead, which the reader maps to the -- option's default. An explicit @--jobs=@ therefore also means the default. [ Endo diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 111a35b34f8..e4c594c7f43 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -184,7 +184,7 @@ import Distribution.PackageDescription import Distribution.Client.Cmd.UI ( commandParserByName - , parseCommandWithOptparseMany + , parseCommands ) import Distribution.Client.Errors import Distribution.Compat.ResponseFile @@ -390,7 +390,7 @@ mainWorker args = do -- support it, falling back to the command registry for the others. commandsParse :: [String] -> IO (CommandParse (GlobalFlags, CommandParse Action)) commandsParse argv = - case parseCommandWithOptparseMany globalCmd commandParsers argv of + case parseCommands globalCmd commandParsers argv of Just parsed -> pure parsed Nothing -> commandsRunWithFallback globalCmd (registeredCommands commandRegistry) delegateToExternal argv From b0264969481cb006e5b4cde1127b9d66435a255d Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 15 Oct 2026 11:19:06 -0400 Subject: [PATCH 13/15] Add a haddock-module Makefile recipe --- Makefile | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/Makefile b/Makefile index 9268d18e562..6cae083f35b 100644 --- a/Makefile +++ b/Makefile @@ -333,6 +333,49 @@ bootstrap-jsons-nix-helper: users-guide: ## Build the users guide. $(MAKE) -C doc users-guide +# Haddock for one module of a library in this repository, typechecked against +# the built in-place library instead of re-haddocking the whole package. The +# library must already be built, with `cabal build $(PKG):lib:$(PKG)`. The +# language and extensions below must cover every library stanza in the +# repository; they all use GHC2021. +# +# The module may import its package's other-modules, which the registered +# library hides, so the recipe registers a copy of the package in a temporary +# package db with every module exposed. +# +# make haddock-module MODULE=Distribution.Client.Cmd.UI +# make haddock-module PKG=Cabal-syntax MODULE=Distribution.Types.Version +# +HADDOCK_MODULE_OUT ?= dist-newstyle/haddock-module +HADDOCK_MODULE_GHC = $(shell ghc --numeric-version) +HADDOCK_MODULE_EXTS := -XGHC2021 -XTypeOperators -XNoImportQualifiedPost +PKG ?= cabal-install + +.PHONY: haddock-module +haddock-module: ## Haddock one module: MODULE=Distribution.Client.Cmd.UI [PKG=cabal-install] + @test -n "$(MODULE)" || { echo "usage: make haddock-module MODULE=Distribution.Client.Cmd.UI [PKG=cabal-install]"; exit 1; } + @pkgdb=dist-newstyle/packagedb/ghc-$(HADDOCK_MODULE_GHC) && \ + conf=$$(ls $$pkgdb/$(PKG)-[0-9]*-inplace.conf) && \ + deps=$$(awk '/^depends:/{f=1; sub(/^depends:/,"")} f && /^[a-z-]+:/ && !/^depends:/{f=0} f{print}' $$conf \ + | tr ' ' '\n' | grep . | sed 's/^/--optghc=-package-id=/') && \ + dbs=$$(for db in $$(cabal path -v0 --store-dir)/ghc-$(HADDOCK_MODULE_GHC)-*/package.db; do echo "--optghc=-package-db=$$db"; done) && \ + macros=$$(ls dist-newstyle/build/*/ghc-$(HADDOCK_MODULE_GHC)/$(PKG)-[0-9]*/build/autogen/cabal_macros.h) && \ + src=$$(ls $(PKG)/src*/$(subst .,/,$(MODULE)).hs) && \ + tmpdb=$$(mktemp -d) && trap 'rm -rf "$$tmpdb"' EXIT && \ + cp $$pkgdb/*.conf $$tmpdb && \ + awk 'NR==FNR { if (/^hidden-modules:/) { h=1; sub(/^hidden-modules:/, "") } else if (h && /^[A-Za-z-]+:/) h=0; if (h) for (i=1; i<=NF; i++) hid = hid " " $$i ",\n"; next } \ + /^hidden-modules:/ { skip=1; next } skip && /^[A-Za-z-]+:/ { skip=0 } skip { next } \ + /^exposed-modules:/ { print; printf "%s", hid; next } { print }' $$conf $$conf > $$tmpdb/$$(basename $$conf) && \ + ghc-pkg recache --package-db=$$tmpdb && \ + haddock --html -o $(HADDOCK_MODULE_OUT) \ + $(addprefix --optghc=,$(HADDOCK_MODULE_EXTS)) \ + --optghc=-optP-include --optghc=-optP$$macros \ + --optghc=-hide-all-packages $$dbs \ + --optghc=-package-db=$$tmpdb \ + $$deps --optghc=-package-id=$$(basename $$conf .conf) \ + $$src + @echo "$(HADDOCK_MODULE_OUT)/$(subst .,-,$(MODULE)).html" + ifeq ($(shell uname), Darwin) PROCS := $(shell sysctl -n hw.logicalcpu) else From a81e6f9c272c05c5c7cd852bbfbb5354bf51bf60 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 15 Oct 2026 11:28:50 -0400 Subject: [PATCH 14/15] Add a translation table to the haddocks --- .../src/Distribution/Client/Cmd/UI.hs | 39 ++++++++++++++++++- 1 file changed, 38 insertions(+), 1 deletion(-) diff --git a/cabal-install/src/Distribution/Client/Cmd/UI.hs b/cabal-install/src/Distribution/Client/Cmd/UI.hs index 240dc11db3b..aebd32d0097 100644 --- a/cabal-install/src/Distribution/Client/Cmd/UI.hs +++ b/cabal-install/src/Distribution/Client/Cmd/UI.hs @@ -6,6 +6,43 @@ -- -- Only parsing is affected: help, the list of options and the command registry -- keep using "Distribution.Simple.Command". +-- +-- The same things go by different names in "Distribution.Simple.Command", in +-- @optparse-applicative@ and here: +-- +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | "Distribution.Simple.Command" | @optparse-applicative@ | this module | +-- +===================================+======================================================+=========================================================================+ +-- | 'CommandUI' | 'ParserInfo' | 'parserInfo', 'NamedCommandParser' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | @Command@ in the command registry | subcommand | 'NamedCommandParser', matched by 'commandNames' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | @commandsRun@ | @execParser@ | 'parseCommands' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | 'commandParseArgs' | 'execParserPure' | 'parseCommand' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | 'OptionField' | a group of parsers | 'fieldParsers' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | 'OptDescr' | 'O.Parser' | 'descrParsers' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | 'ReqArg' | 'O.option' | 'descrParsers' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | 'OptArg' | 'O.option', given @""@ by 'supplyDefaults' when bare | 'descrParsers' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | 'ChoiceOpt' | one @flag'@ per choice | 'descrParsers' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | 'BoolOpt' | two @flag'@, one per spelling | 'descrParsers' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | a setter, @flags -> flags@ | the parser's result | 'Endo', 'CmdItemFlag' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | a non-option argument | 'strArgument' | 'CmdItemTarget', 'parsedTargets' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | @--list-options@ | @flag'@ | 'CmdItemListOptions', rendered by "Distribution.Simple.Command" | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | @--help@ | 'helper' | 'Failure' with 'ExitSuccess', rendered by "Distribution.Simple.Command" | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ +-- | an abbreviated long option | the @disambiguate@ preference | 'expandAbbreviations' | +-- +-----------------------------------+------------------------------------------------------+-------------------------------------------------------------------------+ module Distribution.Client.Cmd.UI ( -- * Parsing a command with @optparse-applicative@ NamedCommandParser (..) @@ -201,7 +238,7 @@ longNames fields = -- | Expand each abbreviated long option to its full name, as -- "Distribution.GetOpt" does: an exact name wins, otherwise a unique prefix -- is accepted, and an ambiguous prefix is an error naming the candidates. --- @optparse-applicative@'s own 'disambiguate' preference gives no precedence +-- @optparse-applicative@'s own @disambiguate@ preference gives no precedence -- to an exact name, so @--lib@ would be ambiguous with @--libdir@; upstream -- considers that correct and will not change it, see -- . From 4221b94fb8ec4574f4d8ddcefe8f1c64f6f0e5cb Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 15 Oct 2026 11:33:44 -0400 Subject: [PATCH 15/15] Add haddocks for remaining exports --- cabal-install/src/Distribution/Client/Cmd/UI.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/cabal-install/src/Distribution/Client/Cmd/UI.hs b/cabal-install/src/Distribution/Client/Cmd/UI.hs index aebd32d0097..6da024254c8 100644 --- a/cabal-install/src/Distribution/Client/Cmd/UI.hs +++ b/cabal-install/src/Distribution/Client/Cmd/UI.hs @@ -303,12 +303,18 @@ data CmdItem flags | CmdItemTarget String | CmdItemListOptions +-- | A command line's items, sorted by kind. data ParsedCommand flags = ParsedCommand { parsedFlagEdits :: Endo flags + -- ^ The edits from every option, combined in command-line order. , parsedTargets :: [String] + -- ^ The targets, in command-line order. , parsedListOptions :: Bool + -- ^ Whether @--list-options@ was given. } +-- | Parse a whole command line as any number of items, in any order, and +-- sort them by kind. commandParser :: [O.Parser (CmdItem flags)] -> O.Parser (ParsedCommand flags) commandParser itemParsers = toParsed <$> many (itemParser itemParsers) where @@ -330,6 +336,8 @@ commandParser itemParsers = toParsed <$> many (itemParser itemParsers) isListOptions CmdItemListOptions = True isListOptions _ = False +-- | Parse one item: one of the given option parsers, @--list-options@, or +-- failing those a target. itemParser :: [O.Parser (CmdItem flags)] -> O.Parser (CmdItem flags) itemParser flags = asum @@ -340,15 +348,20 @@ itemParser flags = ] ) +-- | The parsers of a command's options, as items. optionParsers :: [OptionField flags] -> [O.Parser (CmdItem flags)] optionParsers fields = (fmap . fmap) CmdItemFlag (flagEditParsers fields) +-- | The parsers of a command's options, each producing an edit of the flags. flagEditParsers :: [OptionField flags] -> [O.Parser (Endo flags)] flagEditParsers = concatMap fieldParsers +-- | The parsers of one 'OptionField', one or more per 'OptDescr' it holds. fieldParsers :: OptionField flags -> [O.Parser (Endo flags)] fieldParsers (OptionField _ descrs) = concatMap descrParsers descrs +-- | The parsers of one 'OptDescr': one for a 'ReqArg' or 'OptArg', one per +-- choice of a 'ChoiceOpt', and one per spelling of a 'BoolOpt'. descrParsers :: OptDescr flags -> [O.Parser (Endo flags)] descrParsers = \case ReqArg desc optFlags placeHolder reader _show ->