diff --git a/ChangeLog.md b/ChangeLog.md index 9bfe73bd94..b85d100b48 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -14,6 +14,9 @@ Other enhancements: [#1412](https://github.com/commercialhaskell/stack/issues/1412) * Add optional GPG signing on `stack upload --sign` or with `stack sig sign ...` +* Support git-style executable fall-through (`stack something` executes + `stack-something` if present) + [#1433](https://github.com/commercialhaskell/stack/issues/1433) Bug fixes: diff --git a/src/Options/Applicative/Complicated.hs b/src/Options/Applicative/Complicated.hs index d79f376748..9e1fe2507a 100644 --- a/src/Options/Applicative/Complicated.hs +++ b/src/Options/Applicative/Complicated.hs @@ -35,13 +35,18 @@ complicatedOptions -- ^ program description -> Parser a -- ^ common settings + -> Maybe (ParserFailure ParserHelp -> [String] -> IO (a,(b,a))) + -- ^ optional handler for parser failure; 'handleParseResult' is called by + -- default -> EitherT b (Writer (Mod CommandFields (b,a))) () -- ^ commands (use 'addCommand') -> IO (a,b) -complicatedOptions numericVersion versionString h pd commonParser commandParser = +complicatedOptions numericVersion versionString h pd commonParser mOnFailure commandParser = do args <- getArgs (a,(b,c)) <- case execParserPure (prefs noBacktrack) parser args of Failure _ | null args -> withArgs ["--help"] (execParser parser) + -- call onFailure handler if it's present and parsing options failed + Failure f | Just onFailure <- mOnFailure -> onFailure f args parseResult -> handleParseResult parseResult return (mappend c a,b) where parser = info (helpOption <*> versionOptions <*> complicatedParser commonParser commandParser) desc diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs index 69b82650fa..a6e55736a6 100644 --- a/src/Stack/Exec.hs +++ b/src/Stack/Exec.hs @@ -14,6 +14,7 @@ import Control.Monad.Catch hiding (try) import Control.Monad.Trans.Control (MonadBaseControl) import Stack.Types import System.Process.Log +import System.Process.Read (EnvOverride) #ifdef WINDOWS import Control.Exception.Lifted @@ -44,11 +45,9 @@ plainEnvSettings = EnvSettings } -- | Execute a process within the Stack configured environment. -exec :: (HasConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m) - => EnvSettings -> String -> [String] -> m b -exec envSettings cmd0 args = do - config <- asks getConfig - menv <- liftIO (configEnvOverride config envSettings) +exec :: (MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m) + => EnvOverride -> String -> [String] -> m b +exec menv cmd0 args = do $logProcessRun cmd0 args #ifdef WINDOWS e <- try (callProcess Nothing menv cmd0 args) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index b2f35cddde..8edab22247 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -116,8 +116,9 @@ ghci GhciOpts{..} = do $logInfo ("Configuring GHCi with the following packages: " <> T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs)) - let execGhci extras = - exec defaultEnvSettings + let execGhci extras = do + menv <- liftIO $ configEnvOverride config defaultEnvSettings + exec menv (fromMaybe (compilerExeName wc) ghciGhcCommand) ("--interactive" : -- This initial "-i" resets the include directories to not diff --git a/src/main/Main.hs b/src/main/Main.hs index b1f9d87372..6606dac1ce 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -37,7 +37,7 @@ import Data.Version (showVersion) #ifdef USE_GIT_INFO import Development.GitRev (gitCommitCount, gitHash) #endif -import Distribution.System (buildArch) +import Distribution.System (buildArch, buildPlatform) import Distribution.Text (display) import GHC.IO.Encoding (mkTextEncoding, textEncodingName) import Network.HTTP.Client @@ -84,6 +84,7 @@ import Stack.Types.StackT import Stack.Upgrade import qualified Stack.Upload as Upload import System.Directory (canonicalizePath, doesFileExist, doesDirectoryExist, createDirectoryIfMissing) +import qualified System.Directory as Directory (findExecutable) import System.Environment (getEnvironment, getProgName) import System.Exit import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock) @@ -147,6 +148,21 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do "stack - The Haskell Tool Stack" "" (globalOpts False) + -- when there's a parse failure + (Just $ \f as -> + -- fall-through to external executables in `git` style if they exist + -- (i.e. `stack something` looks for `stack-something` before + -- failing with "Invalid argument `something'") + case stripPrefix "Invalid argument" (fst (renderFailure f "")) of + Just _ -> do + mExternalExec <- Directory.findExecutable ("stack-" ++ head as) + case mExternalExec of + Just ex -> do + menv <- getEnvOverride buildPlatform + runNoLoggingT (exec menv ex (tail as)) + Nothing -> handleParseResult (Failure f) + Nothing -> handleParseResult (Failure f) + ) (do addCommand' "build" "Build the package(s) in this directory/configuration" cmdFooter @@ -912,17 +928,20 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = (ExecRunGhc, args) -> return ("runghc", args) (manager,lc) <- liftIO $ loadConfigWithOpts go withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> - runStackTGlobal manager (lcConfig lc) go $ + runStackTGlobal manager (lcConfig lc) go $ Docker.reexecWithOptionalContainer (lcProjectRoot lc) -- Unlock before transferring control away, whether using docker or not: (Just $ munlockFile lk) - (runStackTGlobal manager (lcConfig lc) go $ - exec plainEnvSettings cmd args) + (runStackTGlobal manager (lcConfig lc) go $ do + config <- asks getConfig + menv <- liftIO $ configEnvOverride config plainEnvSettings + exec menv cmd args) Nothing Nothing -- Unlocked already above. ExecOptsEmbellished {..} -> withBuildConfigAndLock go $ \lk -> do + config <- asks getConfig (cmd, args) <- case (eoCmd, eoArgs) of (ExecCmd cmd, args) -> return (cmd, args) (ExecGhc, args) -> execCompiler "" args @@ -935,7 +954,8 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = { boptsTargets = map T.pack targets } munlockFile lk -- Unlock before transferring control away. - exec eoEnvSettings cmd args + menv <- liftIO $ configEnvOverride config eoEnvSettings + exec menv cmd args where execCompiler cmdPrefix args = do wc <- getWhichCompiler