Skip to content

Commit

Permalink
[cabal-7825] Implement external command system
Browse files Browse the repository at this point in the history
  • Loading branch information
yvan-sraka committed Jun 21, 2023
1 parent 30af95d commit a79a3c3
Show file tree
Hide file tree
Showing 5 changed files with 42 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 @@ -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
Expand All @@ -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
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 @@ -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
Expand Down Expand Up @@ -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

data CommandType = NormalCommand | HiddenCommand
data Command action
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
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 @@ -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
Expand All @@ -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
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 -> undefined -- This is never evaluated
CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs)
CommandList _ -> throwIO (SavedArgsErrorList savedArgs)
CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs)
Expand Down

0 comments on commit a79a3c3

Please sign in to comment.