Merge pull request #515 from tbidne/commands

Implement command aliases.

Thanks!

Author: HuwCampbell

CHANGELOG.md

@@ -6,6 +6,8 @@
 - Remove `fullDesc` and `briefDesc` builder modifiers – they have not had an
   effect since version 0.8.
 
+- Add `commandWithAliases` for defining multiple aliases for the same command.
+
 ## Version 0.19.0.0 (03 June 2025)
 
 - Add `briefHangPoint` modifier. This allows one to specify the command length

optparse-applicative.cabal

@@ -45,6 +45,9 @@ extra-source-files:  CHANGELOG.md
                      tests/parser_group_duplicate_command_groups.err.txt
                      tests/parser_group_duplicates.err.txt
                      tests/parser_group_nested.err.txt
+                     tests/prop_cmd_alias_dupes.err.txt
+                     tests/prop_cmd_aliases.err.txt
+                     tests/prop_cmd_dupes.err.txt
                      tests/nested_optional.err.txt
                      tests/subparsers.err.txt
 
@@ -135,7 +138,10 @@ test-suite tests
 
   other-modules:       Examples.Alternatives
                      , Examples.Cabal
+                     , Examples.CommandAliasDupes
+                     , Examples.CommandDupes
                      , Examples.Commands
+                     , Examples.CommandAliases
                      , Examples.Formatting
                      , Examples.Hello
                      , Examples.LongSub

src/Options/Applicative.hs

@@ -99,6 +99,7 @@ module Options.Applicative (
   internal,
   style,
   command,
+  commandWithAliases,
   commandGroup,
   completeWith,
   action,

src/Options/Applicative/BashCompletion.hs

@@ -17,8 +17,11 @@ import Prelude
 #if !defined(__MHS__)
 import Data.Foldable ( asum )
 #endif
+
+import qualified Data.Foldable as Foldable
 import Data.List ( isPrefixOf )
-import Data.Maybe ( fromMaybe, listToMaybe )
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe ( fromMaybe, listToMaybe, mapMaybe )
 
 import Options.Applicative.Builder
 import Options.Applicative.Common
@@ -120,7 +123,7 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre
          | argumentIsUnreachable reachability
         -> return []
          | otherwise
-        -> return . with_cmd_help $ filter (is_completion . fst) ns
+        -> return . with_cmd_help $ filter_completions ns
 
     -- When doing enriched completions, add any help specified
     -- to the completion variables (tab separated).
@@ -148,6 +151,30 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre
     show_names :: [OptName] -> [String]
     show_names = filter is_completion . map showOption
 
+    -- Filter commands and aliases matching the completion e.g. if we have
+    -- commands:
+    --
+    --   - ([retry], p1)
+    --   - ([run, r, go], p2)
+    --   - ([search], p3)
+    --
+    -- and the user types 'r', we should return
+    --
+    --   [(retry, p1), (run, p2)]
+    --
+    -- If the first entry (command name) is the canonical one, we should
+    -- favour it in completions, as if we were to provide all options there
+    -- would be a good chance we'd be forcing the user to tab through and
+    -- disambiguate between functionally identical options.
+    --
+    -- In zsh and fish we also provide the help doc in the completions, which
+    -- we don't want to repeat a whole bunch of times.
+    filter_completions :: [(NonEmpty String, ParserInfo a)] -> [(String, ParserInfo a)]
+    filter_completions =
+      let findAlias :: (NonEmpty String, b) -> Maybe (String, b)
+          findAlias (aliases, painfo) = (\x -> (x, painfo)) <$> Foldable.find is_completion aliases
+      in mapMaybe findAlias
+
     -- We only want to show a single line in the completion results description.
     -- If there was a line break, it would come across as a different completion
     -- possibility.

src/Options/Applicative/Builder.hs

@@ -43,6 +43,7 @@ module Options.Applicative.Builder (
   internal,
   style,
   command,
+  commandWithAliases,
   commandGroup,
   completeWith,
   action,
@@ -107,6 +108,7 @@ module Options.Applicative.Builder (
   ) where
 
 import Control.Applicative
+import Data.List.NonEmpty (NonEmpty ((:|)))
 #if __GLASGOW_HASKELL__ < 804
 import Data.Semigroup hiding (Option, option)
 #endif
@@ -240,7 +242,28 @@ style x = optionMod $ \p ->
 -- @
 command :: String -> ParserInfo a -> Mod CommandFields a
 command cmd pinfo = fieldMod $ \p ->
-  p { cmdCommands = (cmd, pinfo) : cmdCommands p }
+  p { cmdCommands = (cmd :| [], pinfo) : cmdCommands p }
+
+-- | Add a command and possible aliases to a subparser option.
+--
+-- @
+-- sample :: Parser Sample
+-- sample = subparser
+--        ( commandWithAliases ("hello" :| ["hi"])
+--          (info hello (progDesc "Print greeting"))
+--       <> command "goodbye"
+--          (info goodbye (progDesc "Say goodbye"))
+--        )
+-- @
+--
+-- > Available commands:
+-- >   hello, hi                Print greeting
+-- >   goodbye                  Say goodbye
+--
+-- @since 0.20.0.0
+commandWithAliases :: NonEmpty String -> ParserInfo a -> Mod CommandFields a
+commandWithAliases aliases pinfo = fieldMod $ \p ->
+  p { cmdCommands = (aliases, pinfo) : cmdCommands p }
 
 -- | Add a description to a group of commands.
 --

src/Options/Applicative/Builder/Internal.hs

@@ -26,6 +26,7 @@ module Options.Applicative.Builder.Internal (
 
 import Control.Applicative
 import Control.Monad (mplus)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Semigroup hiding (Option)
 import Prelude
 
@@ -42,7 +43,7 @@ data FlagFields a = FlagFields
   , flagActive :: a }
 
 data CommandFields a = CommandFields
-  { cmdCommands :: [(String, ParserInfo a)]
+  { cmdCommands :: [(NonEmpty String, ParserInfo a)]
   , cmdGroup :: Maybe String }
 
 data ArgumentFields a = ArgumentFields
@@ -154,7 +155,7 @@ baseProps = OptProperties
   , propGroup = OptGroup []
   }
 
-mkCommand :: Mod CommandFields a -> (Maybe String, [(String, ParserInfo a)])
+mkCommand :: Mod CommandFields a -> (Maybe String, [(NonEmpty String, ParserInfo a)])
 mkCommand m = (group, cmds)
   where
     Mod f _ _ = m

src/Options/Applicative/Common.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE Rank2Types #-}
+
 module Options.Applicative.Common (
   -- * Option parsers
   --
@@ -55,7 +56,9 @@ import Control.Applicative
 import Control.Monad (guard, mzero, msum, when)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State (StateT(..), get, put, runStateT)
+import qualified Data.Foldable as F
 import Data.List (isPrefixOf)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (maybeToList, isJust, isNothing)
 import Prelude
 
@@ -195,8 +198,16 @@ searchArg prefs arg =
 
   where
     cmdMatches cs
-      | prefDisambiguate prefs = snd <$> filter (isPrefixOf arg . fst) cs
-      | otherwise = maybeToList (lookup arg cs)
+      | prefDisambiguate prefs = snd <$> filter (F.any (isPrefixOf arg) . fst) cs
+      | otherwise = maybeToList (lookupCmd arg cs)
+
+lookupCmd :: String -> [(NonEmpty String, a)] -> Maybe a
+lookupCmd k = foldr go Nothing
+  where
+    go (aliases, y) acc =
+      if F.any (== k) aliases
+        then Just y
+        else acc
 
 stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String
            -> Parser a -> NondetT (StateT Args m) (Parser a)

src/Options/Applicative/Extra.hs

@@ -25,6 +25,7 @@ import Control.Applicative
 import Control.Monad (void)
 import Data.Monoid
 import Data.Foldable (traverse_)
+import qualified Data.List.NonEmpty as NE
 import Prelude
 import System.Environment (getArgs, getProgName)
 import System.Exit (exitSuccess, exitWith, ExitCode(..))
@@ -320,7 +321,7 @@ parserFailure pprefs pinfo msg ctx0 = ParserFailure $ \progn ->
               CmdReader _ ns    | argumentIsUnreachable reachability
                                -> []
                                 | otherwise
-                               -> fst <$> ns
+                               -> ns >>= NE.toList . fst
       _
         -> mempty
 

src/Options/Applicative/Help/Core.hs

@@ -96,11 +96,16 @@ cmdDesc pprefs = mapParser desc
         CmdReader gn cmds ->
           (,) gn $
             tabulate (prefTabulateFill pprefs)
-              [ (pretty nm, align (extractChunk (infoProgDesc cmd)))
+              [ (pCmds nm, align (extractChunk (infoProgDesc cmd)))
               | (nm, cmd) <- reverse cmds
               ]
         _ -> mempty
 
+    pCmds =
+      pretty
+        . List.intercalate ","
+        . NE.toList
+
 -- | Generate a brief help text for a parser.
 briefDesc :: ParserPrefs -> Parser a -> Chunk Doc
 briefDesc = briefDesc' True

src/Options/Applicative/Types.hs

@@ -56,6 +56,7 @@ import Control.Monad.Trans.Except (Except, throwE)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (ReaderT, ask)
 import qualified Control.Monad.Fail as Fail
+import Data.List.NonEmpty (NonEmpty)
 import Data.Semigroup hiding (Option)
 import Prelude
 
@@ -273,7 +274,7 @@ data OptReader a
   -- ^ flag reader
   | ArgReader (CReader a)
   -- ^ argument reader
-  | CmdReader (Maybe String) [(String, ParserInfo a)]
+  | CmdReader (Maybe String) [(NonEmpty String, ParserInfo a)]
   -- ^ command reader
 
 instance Functor OptReader where