Skip to content

Commit 118cb3e

Browse files
chrisdonechrisdone
committed
Add --no-terminal flag (#338)
1 parent 0af6995 commit 118cb3e

File tree

5 files changed

+61
-39
lines changed

5 files changed

+61
-39
lines changed

‎src/Stack/Build.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -47,7 +47,7 @@ import System.Posix.Files (createSymbolicLink,removeLink)
4747
#endif
4848
--}
4949

50-
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env)
50+
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
5151

5252
-- | Build
5353
build :: M env m => BuildOpts -> m ()

‎src/Stack/Build/Execute.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -70,7 +70,7 @@ import System.Process.Internals (createProcess_)
7070
import System.Process.Read
7171
import System.Process.Log (showProcessArgDebug)
7272

73-
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env)
73+
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
7474

7575
preFetch :: M env m => Plan -> m ()
7676
preFetch plan
@@ -312,13 +312,15 @@ executePlan' plan ee = do
312312
(planTasks plan)
313313
(planFinals plan)
314314
threads <- asks $ configJobs . getConfig
315+
terminal <- asks getTerminal
315316
errs <- liftIO $ runActions threads actions $ \doneVar -> do
316317
let total = length actions
317318
loop prev
318319
| prev == total =
319320
runInBase $ $logStickyDone ("Completed all " <> T.pack (show total) <> " actions.")
320321
| otherwise = do
321-
runInBase $ $logSticky ("Progress: " <> T.pack (show prev) <> "/" <> T.pack (show total))
322+
when terminal $ runInBase $
323+
$logSticky ("Progress: " <> T.pack (show prev) <> "/" <> T.pack (show total))
322324
done <- atomically $ do
323325
done <- readTVar doneVar
324326
check $ done /= prev

‎src/Stack/Types/Internal.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ import Stack.Types.Config
1212
data Env config =
1313
Env {envConfig :: !config
1414
,envLogLevel :: !LogLevel
15+
,envTerminal :: !Bool
1516
,envManager :: !Manager
1617
,envSticky :: !Sticky}
1718

@@ -38,6 +39,12 @@ instance HasLogLevel (Env config) where
3839
instance HasLogLevel LogLevel where
3940
getLogLevel = id
4041

42+
class HasTerminal r where
43+
getTerminal :: r -> Bool
44+
45+
instance HasTerminal (Env config) where
46+
getTerminal = envTerminal
47+
4148
newtype Sticky = Sticky
4249
{ unSticky :: Maybe (MVar (Maybe Text))
4350
}

‎src/Stack/Types/StackT.hs‎

Lines changed: 19 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -81,10 +81,14 @@ instance (MonadIO m) => MonadLogger (StackT config m) where
8181

8282
-- | Run a Stack action.
8383
runStackT :: (MonadIO m,MonadBaseControl IO m)
84-
=> Manager -> LogLevel -> config -> StackT config m a -> m a
85-
runStackT manager logLevel config m =
86-
withSticky (\sticky -> runReaderT (unStackT m)
87-
(Env config logLevel manager sticky))
84+
=> Manager -> LogLevel -> config -> Bool -> StackT config m a -> m a
85+
runStackT manager logLevel config terminal m =
86+
withSticky
87+
terminal
88+
(\sticky ->
89+
runReaderT
90+
(unStackT m)
91+
(Env config logLevel terminal manager sticky))
8892

8993
--------------------------------------------------------------------------------
9094
-- Logging only StackLoggingT monad transformer
@@ -122,11 +126,14 @@ instance HasHttpManager (LogLevel,Manager,Sticky) where
122126

123127
-- | Run the logging monad.
124128
runStackLoggingT :: MonadIO m
125-
=> Manager -> LogLevel -> StackLoggingT m a -> m a
126-
runStackLoggingT manager logLevel m =
127-
withSticky (\sticky ->
128-
runReaderT (unStackLoggingT m)
129-
(logLevel,manager,sticky))
129+
=> Manager -> LogLevel -> Bool -> StackLoggingT m a -> m a
130+
runStackLoggingT manager logLevel terminal m =
131+
withSticky
132+
terminal
133+
(\sticky ->
134+
runReaderT
135+
(unStackLoggingT m)
136+
(logLevel, manager, sticky))
130137

131138
-- | Convenience for getting a 'Manager'
132139
newTLSManager :: MonadIO m => m Manager
@@ -237,10 +244,9 @@ loggerFunc loc _src level msg =
237244
char = show . snd . loc_start
238245

239246
-- | With a sticky state, do the thing.
240-
withSticky :: MonadIO m
241-
=> (Sticky -> m b) -> m b
242-
withSticky m = do
243-
terminal <- liftIO (hIsTerminalDevice stdout)
247+
withSticky :: (MonadIO m)
248+
=> Bool -> (Sticky -> m b) -> m b
249+
withSticky terminal m = do
244250
if terminal
245251
then do state <- liftIO (newMVar Nothing)
246252
originalMode <- liftIO (hGetBuffering stdout)

‎src/main/Main.hs‎

Lines changed: 30 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -204,10 +204,9 @@ main =
204204
pathCmd :: PathArg -> GlobalOpts -> IO ()
205205
pathCmd pathArg go@GlobalOpts{..} = do
206206
(manager,lc) <- loadConfigWithOpts go
207-
buildConfig <- runStackLoggingT manager globalLogLevel
207+
buildConfig <- runStackLoggingT manager globalLogLevel globalTerminal
208208
(lcLoadBuildConfig lc globalResolver ExecStrategy)
209-
runStackT manager globalLogLevel buildConfig (pathString pathArg) >>= putStrLn
210-
209+
runStackT manager globalLogLevel buildConfig globalTerminal (pathString pathArg) >>= putStrLn
211210

212211
-- Try to run a plugin
213212
tryRunPlugin :: Plugins -> IO ()
@@ -255,18 +254,18 @@ setupParser = SetupCmdOpts
255254
setupCmd :: SetupCmdOpts -> GlobalOpts -> IO ()
256255
setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do
257256
(manager,lc) <- loadConfigWithOpts go
258-
runStackLoggingT manager globalLogLevel $
257+
runStackLoggingT manager globalLogLevel globalTerminal $
259258
Docker.rerunWithOptionalContainer
260259
(lcConfig lc)
261260
(lcProjectRoot lc)
262-
(runStackLoggingT manager globalLogLevel $ do
261+
(runStackLoggingT manager globalLogLevel globalTerminal $ do
263262
(ghc, mstack) <-
264263
case scoGhcVersion of
265264
Just v -> return (v, Nothing)
266265
Nothing -> do
267266
bc <- lcLoadBuildConfig lc globalResolver ThrowException
268267
return (bcGhcVersion bc, Just $ bcStackYaml bc)
269-
mpaths <- runStackT manager globalLogLevel (lcConfig lc) $ ensureGHC SetupOpts
268+
mpaths <- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $ ensureGHC SetupOpts
270269
{ soptsInstallIfMissing = True
271270
, soptsUseSystem =
272271
(configSystemGHC $ lcConfig lc)
@@ -288,13 +287,13 @@ withBuildConfig :: GlobalOpts
288287
-> IO ()
289288
withBuildConfig go@GlobalOpts{..} strat inner = do
290289
(manager, lc) <- loadConfigWithOpts go
291-
runStackLoggingT manager globalLogLevel $
290+
runStackLoggingT manager globalLogLevel globalTerminal $
292291
Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $ do
293-
bconfig1 <- runStackLoggingT manager globalLogLevel $
292+
bconfig1 <- runStackLoggingT manager globalLogLevel globalTerminal $
294293
lcLoadBuildConfig lc globalResolver strat
295294
(bconfig2,cabalVer) <-
296295
runStackT
297-
manager globalLogLevel bconfig1
296+
manager globalLogLevel bconfig1 globalTerminal
298297
(do cfg <- setupEnv
299298
menv <- runReaderT getMinimalEnvOverride cfg
300299
cabalVer <- getCabalPkgVer menv
@@ -303,6 +302,7 @@ withBuildConfig go@GlobalOpts{..} strat inner = do
303302
manager
304303
globalLogLevel
305304
(EnvConfig bconfig2 cabalVer)
305+
globalTerminal
306306
inner
307307

308308
cleanCmd :: () -> GlobalOpts -> IO ()
@@ -351,19 +351,19 @@ installCmd opts go@GlobalOpts{..} = withBuildConfig go ExecStrategy $
351351
unpackCmd :: [String] -> GlobalOpts -> IO ()
352352
unpackCmd names go@GlobalOpts{..} = do
353353
(manager,lc) <- loadConfigWithOpts go
354-
runStackLoggingT manager globalLogLevel $
354+
runStackLoggingT manager globalLogLevel globalTerminal $
355355
Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $
356-
runStackT manager globalLogLevel (lcConfig lc) $ do
356+
runStackT manager globalLogLevel (lcConfig lc) globalTerminal $ do
357357
menv <- getMinimalEnvOverride
358358
Stack.Fetch.unpackPackages menv "." names
359359

360360
-- | Update the package index
361361
updateCmd :: () -> GlobalOpts -> IO ()
362362
updateCmd () go@GlobalOpts{..} = do
363363
(manager,lc) <- loadConfigWithOpts go
364-
runStackLoggingT manager globalLogLevel $
364+
runStackLoggingT manager globalLogLevel globalTerminal $
365365
Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $
366-
runStackT manager globalLogLevel (lcConfig lc) $
366+
runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
367367
getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices
368368

369369
-- | Upload to Hackage
@@ -397,28 +397,28 @@ replCmd (targets,args) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do
397397
dockerPullCmd :: () -> GlobalOpts -> IO ()
398398
dockerPullCmd _ go@GlobalOpts{..} = do
399399
(manager,lc) <- liftIO $ loadConfigWithOpts go
400-
runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $
400+
runStackLoggingT manager globalLogLevel globalTerminal $ Docker.preventInContainer $
401401
Docker.pull (lcConfig lc)
402402

403403
-- | Reset the Docker sandbox.
404404
dockerResetCmd :: Bool -> GlobalOpts -> IO ()
405405
dockerResetCmd keepHome go@GlobalOpts{..} = do
406406
(manager,lc) <- liftIO (loadConfigWithOpts go)
407-
runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $
407+
runStackLoggingT manager globalLogLevel globalTerminal$ Docker.preventInContainer $
408408
Docker.reset (lcProjectRoot lc) keepHome
409409

410410
-- | Cleanup Docker images and containers.
411411
dockerCleanupCmd :: Docker.CleanupOpts -> GlobalOpts -> IO ()
412412
dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = do
413413
(manager,lc) <- liftIO $ loadConfigWithOpts go
414-
runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $
414+
runStackLoggingT manager globalLogLevel globalTerminal$ Docker.preventInContainer $
415415
Docker.cleanup (lcConfig lc) cleanupOpts
416416

417417
-- | Execute a command
418418
dockerExecCmd :: (String, [String]) -> GlobalOpts -> IO ()
419419
dockerExecCmd (cmd,args) go@GlobalOpts{..} = do
420420
(manager,lc) <- liftIO $ loadConfigWithOpts go
421-
runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $
421+
runStackLoggingT manager globalLogLevel globalTerminal$ Docker.preventInContainer $
422422
Docker.rerunCmdWithRequiredContainer (lcConfig lc)
423423
(lcProjectRoot lc)
424424
(return (cmd,args,lcConfig lc))
@@ -530,10 +530,15 @@ dockerCleanupOpts =
530530
-- | Parser for global command-line options.
531531
globalOpts :: Parser GlobalOpts
532532
globalOpts =
533-
GlobalOpts
534-
<$> logLevelOpt
535-
<*> configOptsParser False
536-
<*> optional resolverParser
533+
GlobalOpts <$> logLevelOpt <*>
534+
configOptsParser False <*>
535+
optional resolverParser <*>
536+
flag
537+
True
538+
False
539+
(long "no-terminal" <>
540+
help
541+
"Override terminal detection in the case of running in a false terminal")
537542

538543
-- | Parse for a logging level.
539544
logLevelOpt :: Parser LogLevel
@@ -578,6 +583,7 @@ data GlobalOpts = GlobalOpts
578583
{ globalLogLevel :: LogLevel -- ^ Log level
579584
, globalConfigMonoid :: ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'
580585
, globalResolver :: Maybe Resolver -- ^ Resolver override
586+
, globalTerminal :: Bool -- ^ We're in a terminal?
581587
} deriving (Show)
582588

583589
-- | Load the configuration with a manager. Convenience function used
@@ -588,14 +594,15 @@ loadConfigWithOpts GlobalOpts{..} = do
588594
lc <- runStackLoggingT
589595
manager
590596
globalLogLevel
597+
globalTerminal
591598
(loadConfig globalConfigMonoid)
592599
return (manager,lc)
593600

594601
-- | Project initialization
595602
initCmd :: InitOpts -> GlobalOpts -> IO ()
596603
initCmd initOpts go@GlobalOpts{..} = do
597604
(manager,lc) <- loadConfigWithOpts go
598-
runStackLoggingT manager globalLogLevel $
605+
runStackLoggingT manager globalLogLevel globalTerminal $
599606
Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $
600-
runStackT manager globalLogLevel (lcConfig lc) $
607+
runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
601608
initProject globalResolver initOpts

0 commit comments

Comments
 (0)