[cabal-7825] Implement external command system

Fix haskell#2349 and haskell#7825

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

@@ -157,7 +157,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
@@ -166,6 +168,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

@@ -84,12 +84,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
@@ -588,11 +591,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
@@ -623,25 +628,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
@@ -671,6 +689,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

@@ -297,8 +297,10 @@ warnIfAssertionsAreEnabled =
 
 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
@@ -309,6 +311,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)