Merge pull request #9063 from yvan-sraka/fix-7825

[cabal-7825] Implement external command system

Author: mergify[bot]

Cabal/src/Distribution/Make.hs

@@ -88,8 +88,10 @@ defaultMainArgs :: [String] -> IO ()
 defaultMainArgs = defaultMainHelper
 
 defaultMainHelper :: [String] -> IO ()
-defaultMainHelper args =
-  case commandsRun (globalCommand commands) commands args of
+defaultMainHelper args = do
+  command <- commandsRun (globalCommand commands) commands args
+  case command of
+    CommandDelegate -> pure ()
     CommandHelp help -> printHelp help
     CommandList opts -> printOptionsList opts
     CommandErrors errs -> printErrors errs
@@ -98,6 +100,7 @@ defaultMainHelper args =
         _
           | fromFlag (globalVersion flags) -> printVersion
           | fromFlag (globalNumericVersion flags) -> printNumericVersion
+        CommandDelegate -> pure ()
         CommandHelp help -> printHelp help
         CommandList opts -> printOptionsList opts
         CommandErrors errs -> printErrors errs

Cabal/src/Distribution/Simple.hs

@@ -168,7 +168,9 @@ defaultMainWithHooksNoReadArgs hooks pkg_descr =
 defaultMainHelper :: UserHooks -> Args -> IO ()
 defaultMainHelper hooks args = topHandler $ do
   args' <- expandResponse args
-  case commandsRun (globalCommand commands) commands args' of
+  command <- commandsRun (globalCommand commands) commands args'
+  case command of
+    CommandDelegate -> pure ()
     CommandHelp help -> printHelp help
     CommandList opts -> printOptionsList opts
     CommandErrors errs -> printErrors errs
@@ -177,6 +179,7 @@ defaultMainHelper hooks args = topHandler $ do
         _
           | fromFlag (globalVersion flags) -> printVersion
           | fromFlag (globalNumericVersion flags) -> printNumericVersion
+        CommandDelegate -> pure ()
         CommandHelp help -> printHelp help
         CommandList opts -> printOptionsList opts
         CommandErrors errs -> printErrors errs

Cabal/src/Distribution/Simple/Command.hs

@@ -85,12 +85,15 @@ module Distribution.Simple.Command
 import Distribution.Compat.Prelude hiding (get)
 import Prelude ()
 
+import Control.Exception (try)
 import qualified Data.Array as Array
 import qualified Data.List as List
 import Distribution.Compat.Lens (ALens', (#~), (^#))
 import qualified Distribution.GetOpt as GetOpt
 import Distribution.ReadE
 import Distribution.Simple.Utils
+import System.Directory (findExecutable)
+import System.Process (callProcess)
 
 data CommandUI flags = CommandUI
   { commandName :: String
@@ -596,11 +599,13 @@ data CommandParse flags
   | CommandList [String]
   | CommandErrors [String]
   | CommandReadyToGo flags
+  | CommandDelegate
 instance Functor CommandParse where
   fmap _ (CommandHelp help) = CommandHelp help
   fmap _ (CommandList opts) = CommandList opts
   fmap _ (CommandErrors errs) = CommandErrors errs
   fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags)
+  fmap _ CommandDelegate = CommandDelegate
 
 data CommandType = NormalCommand | HiddenCommand
 data Command action
@@ -631,25 +636,38 @@ commandsRun
   :: CommandUI a
   -> [Command action]
   -> [String]
-  -> CommandParse (a, CommandParse action)
+  -> IO (CommandParse (a, CommandParse action))
 commandsRun globalCommand commands args =
   case commandParseArgs globalCommand True args of
-    CommandHelp help -> CommandHelp help
-    CommandList opts -> CommandList (opts ++ commandNames)
-    CommandErrors errs -> CommandErrors errs
+    CommandDelegate -> pure CommandDelegate
+    CommandHelp help -> pure $ CommandHelp help
+    CommandList opts -> pure $ CommandList (opts ++ commandNames)
+    CommandErrors errs -> pure $ CommandErrors errs
     CommandReadyToGo (mkflags, args') -> case args' of
-      ("help" : cmdArgs) -> handleHelpCommand cmdArgs
+      ("help" : cmdArgs) -> pure $ handleHelpCommand cmdArgs
       (name : cmdArgs) -> case lookupCommand name of
         [Command _ _ action _] ->
-          CommandReadyToGo (flags, action cmdArgs)
-        _ -> CommandReadyToGo (flags, badCommand name)
-      [] -> CommandReadyToGo (flags, noCommand)
+          pure $ CommandReadyToGo (flags, action cmdArgs)
+        _ -> do
+          mCommand <- findExecutable $ "cabal-" <> name
+          case mCommand of
+            Just exec -> callExternal flags exec cmdArgs
+            Nothing -> pure $ CommandReadyToGo (flags, badCommand name)
+      [] -> pure $ CommandReadyToGo (flags, noCommand)
       where
         flags = mkflags (commandDefaultFlags globalCommand)
   where
     lookupCommand cname =
       [ cmd | cmd@(Command cname' _ _ _) <- commands', cname' == cname
       ]
+
+    callExternal :: a -> String -> [String] -> IO (CommandParse (a, CommandParse action))
+    callExternal flags exec cmdArgs = do
+      result <- try $ callProcess exec cmdArgs
+      case result of
+        Left ex -> pure $ CommandErrors ["Error executing external command: " ++ show (ex :: SomeException)]
+        Right _ -> pure $ CommandReadyToGo (flags, CommandDelegate)
+
     noCommand = CommandErrors ["no command given (try --help)\n"]
 
     -- Print suggested command if edit distance is < 5
@@ -679,6 +697,7 @@ commandsRun globalCommand commands args =
     -- furthermore, support "prog help command" as "prog command --help"
     handleHelpCommand cmdArgs =
       case commandParseArgs helpCommandUI True cmdArgs of
+        CommandDelegate -> CommandDelegate
         CommandHelp help -> CommandHelp help
         CommandList list -> CommandList (list ++ commandNames)
         CommandErrors _ -> CommandHelp globalHelp

cabal-install/src/Distribution/Client/Main.hs

@@ -322,8 +322,10 @@ warnIfAssertionsAreEnabled =
 -- into IO actions for execution.
 mainWorker :: [String] -> IO ()
 mainWorker args = do
-  topHandler $
-    case commandsRun (globalCommand commands) commands args of
+  topHandler $ do
+    command <- commandsRun (globalCommand commands) commands args
+    case command of
+      CommandDelegate -> pure ()
       CommandHelp help -> printGlobalHelp help
       CommandList opts -> printOptionsList opts
       CommandErrors errs -> printErrors errs
@@ -334,6 +336,7 @@ mainWorker args = do
                 printVersion
             | fromFlagOrDefault False (globalNumericVersion globalFlags) ->
                 printNumericVersion
+          CommandDelegate -> pure ()
           CommandHelp help -> printCommandHelp help
           CommandList opts -> printOptionsList opts
           CommandErrors errs -> do

cabal-install/src/Distribution/Client/SavedFlags.hs

@@ -51,6 +51,7 @@ readCommandFlags :: FilePath -> CommandUI flags -> IO flags
 readCommandFlags path command = do
   savedArgs <- fmap (fromMaybe []) (readSavedArgs path)
   case (commandParseArgs command True savedArgs) of
+    CommandDelegate -> error "CommandDelegate Flags evaluated, this should never occur"
     CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs)
     CommandList _ -> throwIO (SavedArgsErrorList savedArgs)
     CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs)

doc/external-commands.rst

@@ -0,0 +1,8 @@
+External Commands
+=================
+
+Cabal provides a system for external commands, akin to the ones used by tools like ``git`` or ``cargo``.
+
+If you execute ``cabal my-custom-command``, Cabal will search the path for an executable named ``cabal-my-custom-command`` and execute it, passing any remaining arguments to this external command. An error will be thrown in case the custom command is not found.
+
+For ideas or existing external commands, visit `this Discourse thread <https://discourse.haskell.org/t/an-external-command-system-for-cabal-what-would-you-do-with-it/7114>`_.

doc/index.rst

@@ -18,3 +18,4 @@ Welcome to the Cabal User Guide
    buildinfo-fields-reference
    bugs-and-stability
    nix-integration
+   external-commands