Skip to content

Commit

Permalink
Merge pull request haskell#9063 from yvan-sraka/fix-7825
Browse files Browse the repository at this point in the history
[cabal-7825] Implement external command system
  • Loading branch information
mergify[bot] authored Nov 2, 2023
2 parents afe3b6a + b27fd21 commit f6565d2
Show file tree
Hide file tree
Showing 7 changed files with 51 additions and 13 deletions.
7 changes: 5 additions & 2 deletions Cabal/src/Distribution/Make.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
5 changes: 4 additions & 1 deletion Cabal/src/Distribution/Simple.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
35 changes: 27 additions & 8 deletions Cabal/src/Distribution/Simple/Command.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
7 changes: 5 additions & 2 deletions cabal-install/src/Distribution/Client/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
1 change: 1 addition & 0 deletions cabal-install/src/Distribution/Client/SavedFlags.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
8 changes: 8 additions & 0 deletions doc/external-commands.rst
Original file line number Diff line number Diff line change
@@ -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>`_.
1 change: 1 addition & 0 deletions doc/index.rst
Original file line number Diff line number Diff line change
Expand Up @@ -18,3 +18,4 @@ Welcome to the Cabal User Guide
buildinfo-fields-reference
bugs-and-stability
nix-integration
external-commands

0 comments on commit f6565d2

Please sign in to comment.