Skip to content

Commit a788dae

Browse files
mgsloanmgsloan
committed
Use a shim to invoke initialBuildSteps for ghci commercialhaskell#1364 
1 parent 4c4d8ae commit a788dae

9 files changed

Lines changed: 118 additions & 23 deletions

File tree

‎ChangeLog.md‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,12 @@ Release notes:
66

77
Major changes:
88

9+
* `stack ghci` now defaults to skipping the build of target packages, because
10+
support has been added for invoking "initial build steps", which create
11+
autogen files and run preprocessors. The `--no-build` flag is now deprecated
12+
because it should no longer be necessary. See
13+
[#1364](https://github.com/commercialhaskell/stack/issues/1364)
14+
915
Behavior changes:
1016

1117
* Switch the "Run from outside project" messages to debug-level, to

‎src/Stack/Build/Execute.hs‎

Lines changed: 61 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -32,14 +32,17 @@ import Control.Monad.Logger
3232
import Control.Monad.Reader (MonadReader, asks)
3333
import Control.Monad.Trans.Control (liftBaseWith)
3434
import Control.Monad.Trans.Resource
35+
import qualified Crypto.Hash.SHA256 as SHA256
3536
import Data.Attoparsec.Text hiding (try)
3637
import qualified Data.ByteString as S
38+
import qualified Data.ByteString.Base64.URL as B64URL
3739
import Data.Char (isSpace)
3840
import Data.Conduit
3941
import qualified Data.Conduit.Binary as CB
4042
import qualified Data.Conduit.List as CL
4143
import qualified Data.Conduit.Text as CT
4244
import Data.Either (isRight)
45+
import Data.FileEmbed (embedFile, makeRelativeToProject)
4346
import Data.Foldable (forM_, any)
4447
import Data.Function
4548
import Data.IORef.RunOnce (runOnce)
@@ -55,7 +58,7 @@ import Data.Streaming.Process hiding (callProcess, env)
5558
import Data.String
5659
import Data.Text (Text)
5760
import qualified Data.Text as T
58-
import Data.Text.Encoding (decodeUtf8)
61+
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
5962
import Data.Text.Extra (stripCR)
6063
import Data.Time.Clock (getCurrentTime)
6164
import Data.Traversable (forM)
@@ -218,6 +221,8 @@ data ExecuteEnv = ExecuteEnv
218221
, eeTempDir :: !(Path Abs Dir)
219222
, eeSetupHs :: !(Path Abs File)
220223
-- ^ Temporary Setup.hs for simple builds
224+
, eeSetupShimHs :: !(Path Abs File)
225+
-- ^ Temporary SetupShim.hs, to provide access to initial-build-steps
221226
, eeSetupExe :: !(Maybe (Path Abs File))
222227
-- ^ Compiled version of eeSetupHs
223228
, eeCabalPkgVer :: !Version
@@ -231,20 +236,46 @@ data ExecuteEnv = ExecuteEnv
231236
, eeLogFiles :: !(TChan (Path Abs Dir, Path Abs File))
232237
}
233238

239+
buildSetupArgs :: [String]
240+
buildSetupArgs =
241+
[ "-rtsopts"
242+
, "-threaded"
243+
, "-clear-package-db"
244+
, "-global-package-db"
245+
, "-hide-all-packages"
246+
, "-package"
247+
, "base"
248+
, "-main-is"
249+
, "StackSetupShim.mainOverride"
250+
]
251+
252+
setupGhciShimCode :: S.ByteString
253+
setupGhciShimCode = $(do
254+
path <- makeRelativeToProject "src/setup-shim/StackSetupShim.hs"
255+
embedFile path)
256+
257+
simpleSetupHash :: String
258+
simpleSetupHash =
259+
T.unpack $ decodeUtf8 $ S.take 8 $ B64URL.encode $ SHA256.hash $
260+
encodeUtf8 (T.pack (unwords buildSetupArgs)) <> setupGhciShimCode
261+
234262
-- | Get a compiled Setup exe
235263
getSetupExe :: M env m
236264
=> Path Abs File -- ^ Setup.hs input file
265+
-> Path Abs File -- ^ SetupShim.hs input file
237266
-> Path Abs Dir -- ^ temporary directory
238267
-> m (Maybe (Path Abs File))
239-
getSetupExe setupHs tmpdir = do
268+
getSetupExe setupHs setupShimHs tmpdir = do
240269
wc <- getWhichCompiler
241270
econfig <- asks getEnvConfig
242271
platformDir <- platformGhcRelDir
243272
let config = getConfig econfig
244273
baseNameS = concat
245-
[ "setup-Simple-Cabal-"
274+
[ "Cabal-simple_"
275+
, simpleSetupHash
276+
, "_"
246277
, versionString $ envConfigCabalVersion econfig
247-
, "-"
278+
, "_"
248279
, compilerVersionString $ envConfigCompilerVersion econfig
249280
]
250281
exeNameS = baseNameS ++
@@ -277,19 +308,13 @@ getSetupExe setupHs tmpdir = do
277308
liftIO $ D.createDirectoryIfMissing True $ toFilePath setupDir
278309

279310
menv <- getMinimalEnvOverride
280-
let args =
281-
[ "-clear-package-db"
282-
, "-global-package-db"
283-
, "-hide-all-packages"
284-
, "-package"
285-
, "base"
286-
, "-package"
311+
let args = buildSetupArgs ++
312+
[ "-package"
287313
, "Cabal-" ++ versionString (envConfigCabalVersion econfig)
288314
, toFilePath setupHs
315+
, toFilePath setupShimHs
289316
, "-o"
290317
, toFilePath tmpOutputPath
291-
, "-rtsopts"
292-
, "-threaded"
293318
] ++
294319
["-build-runner" | wc == Ghcjs]
295320
runCmd' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) Nothing
@@ -314,9 +339,11 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot
314339
configLock <- newMVar ()
315340
installLock <- newMVar ()
316341
idMap <- liftIO $ newTVarIO Map.empty
317-
let setupHs = tmpdir </> $(mkRelFile "Setup.hs")
342+
let setupHs = tmpdir </> $(mkRelFile "Main.hs")
318343
liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"
319-
setupExe <- getSetupExe setupHs tmpdir
344+
let setupShimHs = tmpdir </> $(mkRelFile "SetupShim.hs")
345+
liftIO $ S.writeFile (toFilePath setupShimHs) setupGhciShimCode
346+
setupExe <- getSetupExe setupHs setupShimHs tmpdir
320347
cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
321348
globalDB <- getGlobalDB menv =<< getWhichCompiler
322349
snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)
@@ -337,6 +364,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot
337364
, eeGhcPkgIds = idMap
338365
, eeTempDir = tmpdir
339366
, eeSetupHs = setupHs
367+
, eeSetupShimHs = setupShimHs
340368
, eeSetupExe = setupExe
341369
, eeCabalPkgVer = cabalPkgVer
342370
, eeTotalWanted = totalWanted
@@ -996,6 +1024,9 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
9961024
, "-i", "-i."
9971025
] ++ packageArgs ++
9981026
[ toFilePath setuphs
1027+
, toFilePath eeSetupShimHs
1028+
, "-main-is"
1029+
, "StackSetupShim.mainOverride"
9991030
, "-o", toFilePath outputFile
10001031
, "-threaded"
10011032
] ++
@@ -1140,9 +1171,21 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
11401171
$ \package cabalfp pkgDir cabal announce _console _mlogFile -> do
11411172
_neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix)) cabal cabalfp
11421173

1143-
if boptsCLIOnlyConfigure eeBuildOptsCLI
1144-
then return Nothing
1145-
else liftM Just $ realBuild cache package pkgDir cabal announce
1174+
case ( boptsCLIOnlyConfigure eeBuildOptsCLI
1175+
, boptsCLIInitialBuildSteps eeBuildOptsCLI && isTarget) of
1176+
(True, _) -> return Nothing
1177+
(_, True) -> do
1178+
initialBuildSteps cabal announce
1179+
return Nothing
1180+
_ -> liftM Just $ realBuild cache package pkgDir cabal announce
1181+
1182+
isTarget = case taskType of
1183+
TTLocal lp -> lpWanted lp
1184+
_ -> False
1185+
1186+
initialBuildSteps cabal announce = do
1187+
() <- announce ("initial-build-steps" <> annSuffix)
1188+
cabal False ["repl", "stack-initial-build-steps"]
11461189

11471190
realBuild cache package pkgDir cabal announce = do
11481191
wc <- getWhichCompiler

‎src/Stack/Ghci.hs‎

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -77,8 +77,7 @@ import qualified System.Posix.Files as Posix
7777

7878
-- | Command-line options for GHC.
7979
data GhciOpts = GhciOpts
80-
{ ghciNoBuild :: !Bool
81-
, ghciArgs :: ![String]
80+
{ ghciArgs :: ![String]
8281
, ghciGhcCommand :: !(Maybe FilePath)
8382
, ghciNoLoadModules :: !Bool
8483
, ghciAdditionalPackages :: ![String]
@@ -87,6 +86,7 @@ data GhciOpts = GhciOpts
8786
, ghciSkipIntermediate :: !Bool
8887
, ghciHidePackages :: !Bool
8988
, ghciBuildOptsCLI :: !BuildOptsCLI
89+
, ghciNoBuild :: !Bool
9090
} deriving Show
9191

9292
-- | Necessary information to load a package or its components.
@@ -334,9 +334,16 @@ ghciSetup GhciOpts{..} = do
334334
{ boptsCLITargets = boptsCLITargets ghciBuildOptsCLI ++ map T.pack ghciAdditionalPackages
335335
}
336336
(realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets boptsCli
337+
when ghciNoBuild $ $logInfo $ T.unlines
338+
[ ""
339+
, "NOTE: the --no-build flag should no longer be needed, and is now deprecated."
340+
, "See this resolved issue: https://github.com/commercialhaskell/stack/issues/1364"
341+
]
337342
-- Try to build, but optimistically launch GHCi anyway if it fails (#1065)
338343
when (not ghciNoBuild && not (M.null realTargets)) $ do
339344
eres <- tryAny $ build (const (return ())) Nothing boptsCli
345+
{ boptsCLIInitialBuildSteps = True
346+
}
340347
case eres of
341348
Right () -> return ()
342349
Left err -> do

‎src/Stack/Options/BuildParser.hs‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -76,7 +76,11 @@ buildOptsParser cmd =
7676
(long "only-configure" <>
7777
help
7878
"Only perform the configure step, not any builds. Intended for tool usage, may break when used on multiple packages at once!") <*>
79-
pure cmd
79+
pure cmd <*>
80+
switch
81+
(long "initial-build-steps" <>
82+
help "For target packages, only run initial build steps needed for GHCi" <>
83+
internal)
8084

8185
targetsParser :: Parser [Text]
8286
targetsParser =

‎src/Stack/Options/GhciParser.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -12,8 +12,7 @@ import Stack.Types.Config
1212
-- | Parser for GHCI options
1313
ghciOptsParser :: Parser GhciOpts
1414
ghciOptsParser = GhciOpts
15-
<$> switch (long "no-build" <> help "Don't build before launching GHCi")
16-
<*> fmap concat (many (argsOption (long "ghci-options" <>
15+
<$> fmap concat (many (argsOption (long "ghci-options" <>
1716
metavar "OPTION" <>
1817
help "Additional options passed to GHCi")))
1918
<*> optional
@@ -33,3 +32,4 @@ ghciOptsParser = GhciOpts
3332
<*> switch (long "skip-intermediate-deps" <> help "Skip loading intermediate target dependencies")
3433
<*> boolFlags True "package-hiding" "package hiding" idm
3534
<*> buildOptsParser Build
35+
<*> switch (long "no-build" <> help "Don't build before launching GHCi (deprecated, should be unneeded)")

‎src/Stack/Types/Config/Build.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -117,6 +117,7 @@ defaultBuildOptsCLI = BuildOptsCLI
117117
, boptsCLIExec = []
118118
, boptsCLIOnlyConfigure = False
119119
, boptsCLICommand = Build
120+
, boptsCLIInitialBuildSteps = False
120121
}
121122

122123
-- | Build options that may only be specified from the CLI
@@ -130,6 +131,7 @@ data BuildOptsCLI = BuildOptsCLI
130131
, boptsCLIExec :: ![(String, [String])]
131132
, boptsCLIOnlyConfigure :: !Bool
132133
, boptsCLICommand :: !BuildCommand
134+
, boptsCLIInitialBuildSteps :: !Bool
133135
} deriving Show
134136

135137
-- | Command sum type for conditional arguments.

‎src/setup-shim/StackSetupShim.hs‎

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
module StackSetupShim where
2+
import Main
3+
import Distribution.PackageDescription (PackageDescription, emptyHookedBuildInfo)
4+
import Distribution.Simple
5+
import Distribution.Simple.Build
6+
import Distribution.Simple.Setup (ReplFlags, fromFlag, replDistPref, replVerbosity)
7+
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)
8+
import System.Environment (getArgs)
9+
10+
mainOverride :: IO ()
11+
mainOverride = do
12+
args <- getArgs
13+
if "repl" `elem` args && "stack-initial-build-steps" `elem` args
14+
then do
15+
defaultMainWithHooks simpleUserHooks
16+
{ preRepl = \_ _ -> return emptyHookedBuildInfo
17+
, replHook = stackReplHook
18+
, postRepl = \_ _ _ _ -> return ()
19+
}
20+
else main
21+
22+
stackReplHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO ()
23+
stackReplHook pkg_descr lbi hooks flags args = do
24+
let distPref = fromFlag (replDistPref flags)
25+
verbosity = fromFlag (replVerbosity flags)
26+
case args of
27+
("stack-initial-build-steps":rest)
28+
| null rest -> initialBuildSteps distPref pkg_descr lbi verbosity
29+
| otherwise ->
30+
fail "Misuse of running Setup.hs with stack-initial-build-steps, expected no arguments"
31+
_ -> replHook simpleUserHooks pkg_descr lbi hooks flags args

‎stack-7.8.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -75,6 +75,7 @@ extra-deps:
7575
- optparse-applicative-0.13.0.0
7676
- text-metrics-0.1.0
7777
- pid1-0.1.0.0
78+
- file-embed-0.0.10
7879
flags:
7980
time-locale-compat:
8081
old-locale: false

‎stack.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -263,6 +263,7 @@ library
263263
, hpack >= 0.14.0 && < 0.16
264264
, store >= 0.2.1.0
265265
, annotated-wl-pprint
266+
, file-embed >= 0.0.10
266267
if os(windows)
267268
cpp-options: -DWINDOWS
268269
build-depends: Win32

0 commit comments

Comments
 (0)