Skip to content

Commit e95bed4

Browse files
snoybergsnoyberg
committed
More consistent types in Stack.Runners
1 parent 7f8f936 commit e95bed4

10 files changed

Lines changed: 119 additions & 128 deletions

File tree

‎src/Stack/Docker.hs‎

Lines changed: 9 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -92,10 +92,10 @@ reexecWithOptionalContainer
9292
:: HasConfig env
9393
=> Maybe (Path Abs Dir)
9494
-> Maybe (RIO env ())
95-
-> IO ()
95+
-> RIO env a
9696
-> Maybe (RIO env ())
9797
-> Maybe (RIO env ())
98-
-> RIO env ()
98+
-> RIO env a
9999
reexecWithOptionalContainer mprojectRoot =
100100
execWithOptionalContainer mprojectRoot getCmdArgs
101101
where
@@ -193,24 +193,21 @@ execWithOptionalContainer
193193
=> Maybe (Path Abs Dir)
194194
-> GetCmdArgs env
195195
-> Maybe (RIO env ())
196-
-> IO ()
196+
-> RIO env a
197197
-> Maybe (RIO env ())
198198
-> Maybe (RIO env ())
199-
-> RIO env ()
199+
-> RIO env a
200200
execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease =
201201
do config <- view configL
202202
inContainer <- getInContainer
203203
isReExec <- view reExecL
204204
if | inContainer && not isReExec && (isJust mbefore || isJust mafter) ->
205205
throwIO OnlyOnHostException
206-
| inContainer ->
207-
liftIO (do inner
208-
exitSuccess)
206+
| inContainer -> inner
209207
| not (dockerEnable (configDocker config)) ->
210-
do fromMaybeAction mbefore
211-
liftIO inner
212-
fromMaybeAction mafter
213-
liftIO exitSuccess
208+
fromMaybeAction mbefore *>
209+
inner <*
210+
fromMaybeAction mafter
214211
| otherwise ->
215212
do fromMaybeAction mrelease
216213
runContainerAndExit
@@ -237,7 +234,7 @@ runContainerAndExit
237234
-> Maybe (Path Abs Dir) -- ^ Project root (maybe)
238235
-> RIO env () -- ^ Action to run before
239236
-> RIO env () -- ^ Action to run after
240-
-> RIO env ()
237+
-> RIO env void
241238
runContainerAndExit getCmdArgs
242239
mprojectRoot
243240
before

‎src/Stack/Ls.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -310,16 +310,17 @@ lsViewRemoteCmd =
310310
(OA.info (pure Remote) (OA.progDesc "View remote snapshot"))
311311

312312
-- | List stack's output styles
313-
listStylesCmd :: ListStylesOpts -> Config -> IO ()
314-
listStylesCmd opts lc = do
313+
listStylesCmd :: ListStylesOpts -> RIO Config ()
314+
listStylesCmd opts = do
315+
lc <- ask
315316
-- This is the same test as is used in Stack.Types.Runner.withRunner
316317
let useColor = view useColorL lc
317318
styles = elems $ defaultStyles // stylesUpdate (view stylesUpdateL lc)
318319
isComplex = not (coptBasic opts)
319320
showSGR = isComplex && coptSGR opts
320321
showExample = isComplex && coptExample opts && useColor
321322
styleReports = L.map (styleReport showSGR showExample) styles
322-
T.putStrLn $ T.intercalate (if isComplex then "\n" else ":") styleReports
323+
liftIO $ T.putStrLn $ T.intercalate (if isComplex then "\n" else ":") styleReports
323324
where
324325
styleReport :: Bool -> Bool -> StyleSpec -> Text
325326
styleReport showSGR showExample (k, sgrs) = k <> "=" <> codes

‎src/Stack/Nix.hs‎

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -33,9 +33,9 @@ import RIO.Process (processContextL, exec)
3333
reexecWithOptionalShell
3434
:: HasConfig env
3535
=> Maybe (Path Abs Dir)
36-
-> IO WantedCompiler
37-
-> IO ()
38-
-> RIO env ()
36+
-> RIO env WantedCompiler
37+
-> RIO env a
38+
-> RIO env a
3939
reexecWithOptionalShell mprojectRoot getCompilerVersion inner =
4040
do config <- view configL
4141
inShell <- getInNixShell
@@ -51,15 +51,15 @@ reexecWithOptionalShell mprojectRoot getCompilerVersion inner =
5151
return (exePath, args)
5252
if nixEnable (configNix config) && not inShell && (not isReExec || inContainer)
5353
then runShellAndExit mprojectRoot getCompilerVersion getCmdArgs
54-
else liftIO inner
54+
else inner
5555

5656

5757
runShellAndExit
5858
:: HasConfig env
5959
=> Maybe (Path Abs Dir)
60-
-> IO WantedCompiler
60+
-> RIO env WantedCompiler
6161
-> RIO env (String, [String])
62-
-> RIO env ()
62+
-> RIO env void
6363
runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do
6464
config <- view configL
6565
envOverride <- view processContextL
@@ -68,7 +68,7 @@ runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do
6868
mshellFile <-
6969
traverse (resolveFile (fromMaybeProjectRoot mprojectRoot)) $
7070
nixInitFile (configNix config)
71-
compilerVersion <- liftIO getCompilerVersion
71+
compilerVersion <- getCompilerVersion
7272
inContainer <- getInContainer
7373
ghc <- either throwIO return $ nixCompiler compilerVersion
7474
let pkgsInConfig = nixPackages (configNix config)

‎src/Stack/Options/Completion.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -54,8 +54,8 @@ buildConfigCompleter inner = mkCompleter $ \inputRaw -> do
5454
_ -> do
5555
go' <- globalOptsFromMonoid False mempty
5656
let go = go' { globalLogLevel = LevelOther "silent" }
57-
withConfig go $ \config -> do
58-
bconfig <- runRIO config loadBuildConfig
57+
withConfig go $ do
58+
bconfig <- loadBuildConfig
5959
envConfig <- runRIO bconfig (setupEnv AllowNoTargets defaultBuildOptsCLI Nothing)
6060
runRIO envConfig (inner input)
6161

‎src/Stack/Runners.hs‎

Lines changed: 57 additions & 63 deletions
Original file line numberDiff line numberDiff line change
@@ -36,16 +36,13 @@ import Stack.Setup
3636
import Stack.Types.Config
3737
import System.Console.ANSI (hSupportsANSIWithoutEmulation)
3838
import System.Environment (getEnvironment)
39-
import System.IO
4039
import System.FileLock
4140
import System.Terminal (getTerminalWidth)
4241
import Stack.Dot
4342

4443
-- FIXME it seems wrong that we call loadBuildConfig multiple times
45-
loadCompilerVersion :: Config
46-
-> IO WantedCompiler
47-
loadCompilerVersion config =
48-
view wantedCompilerVersionL <$> runRIO config loadBuildConfig
44+
loadCompilerVersion :: RIO Config WantedCompiler
45+
loadCompilerVersion = view wantedCompilerVersionL <$> loadBuildConfig
4946

5047
-- | Enforce mutual exclusion of every action running via this
5148
-- function, on this path, on this users account.
@@ -54,13 +51,12 @@ loadCompilerVersion config =
5451
-- stack uses locks per-snapshot. In the future, stack may refine
5552
-- this to an even more fine-grain locking approach.
5653
--
57-
withUserFileLock :: MonadUnliftIO m
58-
=> GlobalOpts
59-
-> Path Abs Dir
60-
-> (Maybe FileLock -> m a)
61-
-> m a
62-
withUserFileLock go@GlobalOpts{} dir act = do
63-
env <- liftIO getEnvironment
54+
withUserFileLock :: HasRunner env
55+
=> Path Abs Dir
56+
-> (Maybe FileLock -> RIO env a)
57+
-> RIO env a
58+
withUserFileLock dir act = withRunInIO $ \run -> do
59+
env <- getEnvironment
6460
let toLock = lookup "STACK_LOCK" env == Just "true"
6561
if toLock
6662
then do
@@ -69,37 +65,37 @@ withUserFileLock go@GlobalOpts{} dir act = do
6965
ensureDir dir
7066
-- Just in case of asynchronous exceptions, we need to be careful
7167
-- when using tryLockFile here:
72-
bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive)
73-
(maybe (return ()) (liftIO . unlockFile))
68+
bracket (tryLockFile (toFilePath pth) Exclusive)
69+
munlockFile
7470
(\fstTry ->
7571
case fstTry of
76-
Just lk -> finally (act $ Just lk) (liftIO $ unlockFile lk)
72+
Just lk -> run $ act $ Just lk
7773
Nothing ->
78-
do let chatter = globalLogLevel go /= LevelOther "silent"
79-
when chatter $
80-
liftIO $ hPutStrLn stderr $ "Failed to grab lock ("++show pth++
81-
"); other stack instance running. Waiting..."
82-
bracket (liftIO $ lockFile (toFilePath pth) Exclusive)
83-
(liftIO . unlockFile)
84-
(\lk -> do
85-
when chatter $
86-
liftIO $ hPutStrLn stderr "Lock acquired, proceeding."
74+
do run $ logError $
75+
"Failed to grab lock (" <>
76+
displayShow pth <>
77+
"); other stack instance running. Waiting..."
78+
bracket (lockFile (toFilePath pth) Exclusive)
79+
unlockFile
80+
(\lk -> run $ do
81+
logError "Lock acquired, proceeding."
8782
act $ Just lk))
88-
else act Nothing
83+
else run $ act Nothing
8984

9085
withConfigAndLock
9186
:: GlobalOpts
9287
-> RIO Config ()
9388
-> IO ()
94-
withConfigAndLock go@GlobalOpts{..} inner = withConfig go $ \config -> do
95-
withUserFileLock go (view stackRootL config) $ \lk ->
96-
runRIO config $
97-
Docker.reexecWithOptionalContainer
98-
(configProjectRoot config)
99-
Nothing
100-
(runRIO config inner)
101-
Nothing
102-
(Just $ munlockFile lk)
89+
withConfigAndLock go@GlobalOpts{..} inner = withConfig go $ do
90+
stackRoot <- view stackRootL
91+
projectRoot <- view $ to configProjectRoot
92+
withUserFileLock stackRoot $ \lk ->
93+
Docker.reexecWithOptionalContainer
94+
projectRoot
95+
Nothing
96+
inner
97+
Nothing
98+
(Just $ munlockFile lk)
10399

104100
-- | Loads global config, ignoring any configuration which would be
105101
-- loaded due to $PWD.
@@ -108,12 +104,12 @@ withGlobalConfigAndLock
108104
-> RIO Config ()
109105
-> IO ()
110106
withGlobalConfigAndLock go@GlobalOpts{..} inner =
111-
withRunnerGlobal go $ \runner ->
112-
runRIO runner $ loadConfigMaybeProject
107+
withRunnerGlobal go $
108+
loadConfigMaybeProject
113109
globalConfigMonoid
114110
globalResolver
115111
PCNoProject $ \lc ->
116-
withUserFileLock go (view stackRootL lc) $ \_lk ->
112+
withUserFileLock (view stackRootL lc) $ \_lk ->
117113
runRIO lc inner
118114

119115
-- For now the non-locking version just unlocks immediately.
@@ -163,12 +159,13 @@ withEnvConfigAndLock go needTargets boptsCLI inner =
163159
-- since it does not need to run any commands to get information on
164160
-- the project. This is a change as of #4480. For previous behavior,
165161
-- see issue #2010.
166-
withCleanConfig :: GlobalOpts -> RIO BuildConfig () -> IO ()
162+
withCleanConfig :: GlobalOpts -> RIO BuildConfig a -> IO a
167163
withCleanConfig go inner =
168-
withConfig go $ \config ->
169-
withUserFileLock go (view stackRootL config) $ \_lk0 -> do
170-
bconfig <- runRIO config loadBuildConfig
171-
runRIO bconfig inner
164+
withConfig go $ do
165+
root <- view stackRootL
166+
withUserFileLock root $ \_lk0 -> do
167+
bconfig <- loadBuildConfig
168+
runRIO bconfig inner
172169

173170
withEnvConfigExt
174171
:: GlobalOpts
@@ -188,8 +185,9 @@ withEnvConfigExt
188185
-- available in this action, since that would require build tools to be
189186
-- installed on the host OS.
190187
-> IO ()
191-
withEnvConfigExt go@GlobalOpts{..} needTargets boptsCLI mbefore inner mafter = withConfig go $ \config -> do
192-
withUserFileLock go (view stackRootL config) $ \lk0 -> do
188+
withEnvConfigExt go@GlobalOpts{..} needTargets boptsCLI mbefore inner mafter = withConfig go $ do
189+
config <- ask
190+
withUserFileLock (view stackRootL config) $ \lk0 -> do
193191
-- A local bit of state for communication between callbacks:
194192
curLk <- newIORef lk0
195193
let inner' lk =
@@ -198,7 +196,7 @@ withEnvConfigExt go@GlobalOpts{..} needTargets boptsCLI mbefore inner mafter = w
198196
-- trade in the lock here.
199197
do dir <- installationRootDeps
200198
-- Hand-over-hand locking:
201-
withUserFileLock go dir $ \lk2 -> do
199+
withUserFileLock dir $ \lk2 -> do
202200
liftIO $ writeIORef curLk lk2
203201
liftIO $ munlockFile lk
204202
logDebug "Starting to execute command inside EnvConfig"
@@ -209,13 +207,10 @@ withEnvConfigExt go@GlobalOpts{..} needTargets boptsCLI mbefore inner mafter = w
209207
envConfig <- runRIO bconfig (setupEnv needTargets boptsCLI Nothing)
210208
runRIO envConfig (inner' lk)
211209

212-
let getCompilerVersion = loadCompilerVersion config
213-
runRIO config $
214-
Docker.reexecWithOptionalContainer
210+
Docker.reexecWithOptionalContainer
215211
(configProjectRoot config)
216212
mbefore
217-
(runRIO config $
218-
Nix.reexecWithOptionalShell (configProjectRoot config) getCompilerVersion (inner'' lk0))
213+
(Nix.reexecWithOptionalShell (configProjectRoot config) loadCompilerVersion (inner'' lk0))
219214
mafter
220215
(Just $ liftIO $
221216
do lk' <- readIORef curLk
@@ -225,20 +220,19 @@ withEnvConfigExt go@GlobalOpts{..} needTargets boptsCLI mbefore inner mafter = w
225220
-- throughout this module.
226221
withConfig
227222
:: GlobalOpts
228-
-> (Config -> IO a)
223+
-> RIO Config a
229224
-> IO a
230-
withConfig go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do
225+
withConfig go@GlobalOpts{..} inner = withRunnerGlobal go $ do
231226
mstackYaml <- forM globalStackYaml resolveFile'
232-
runRIO runner $
233-
loadConfig globalConfigMonoid globalResolver mstackYaml $ \config -> do
234-
-- If we have been relaunched in a Docker container, perform in-container initialization
235-
-- (switch UID, etc.). We do this after first loading the configuration since it must
236-
-- happen ASAP but needs a configuration.
237-
forM_ globalDockerEntrypoint $ Docker.entrypoint config
238-
liftIO $ inner config
227+
loadConfig globalConfigMonoid globalResolver mstackYaml $ \config -> do
228+
-- If we have been relaunched in a Docker container, perform in-container initialization
229+
-- (switch UID, etc.). We do this after first loading the configuration since it must
230+
-- happen ASAP but needs a configuration.
231+
forM_ globalDockerEntrypoint $ Docker.entrypoint config
232+
runRIO config inner
239233

240-
withRunnerGlobal :: GlobalOpts -> (Runner -> IO a) -> IO a
241-
withRunnerGlobal go inner = liftIO $ do
234+
withRunnerGlobal :: GlobalOpts -> RIO Runner a -> IO a
235+
withRunnerGlobal go inner = do
242236
colorWhen <-
243237
case getFirst $ configMonoidColorWhen $ globalConfigMonoid go of
244238
Nothing -> defaultColorWhen
@@ -260,13 +254,13 @@ withRunnerGlobal go inner = liftIO $ do
260254
$ setLogVerboseFormat (globalLogLevel go <= LevelDebug)
261255
$ setLogTerminal (globalTerminal go)
262256
logOptions0
263-
withLogFunc logOptions $ \logFunc -> inner Runner
257+
withLogFunc logOptions $ \logFunc -> runRIO Runner
264258
{ runnerGlobalOpts = go
265259
, runnerUseColor = useColor
266260
, runnerLogFunc = logFunc
267261
, runnerTermWidth = termWidth
268262
, runnerProcessContext = menv
269-
}
263+
} inner
270264
where clipWidth w
271265
| w < minTerminalWidth = minTerminalWidth
272266
| w > maxTerminalWidth = maxTerminalWidth

‎src/Stack/Script.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -56,8 +56,7 @@ scriptCmd opts go' = do
5656
srcMod <- getModificationTime file
5757
exeMod <- Dir.getModificationTime $ toExeName $ toFilePath file
5858
if srcMod < exeMod
59-
then withRunnerGlobal go' $ \runner ->
60-
runRIO runner $
59+
then withRunnerGlobal go' $
6160
exec (toExeName $ toFilePath file) (soArgs opts)
6261
else longWay file scriptDir go
6362

0 commit comments

Comments
 (0)