Use a shim to invoke initialBuildSteps for ghci #1364

mgsloan · mgsloan · commit a788daee53af · 2016-10-10T02:25:10.000-07:00
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -6,6 +6,12 @@ Release notes:
 
 Major changes:
 
+* `stack ghci` now defaults to skipping the build of target packages, because
+  support has been added for invoking "initial build steps", which create
+  autogen files and run preprocessors. The `--no-build` flag is now deprecated
+  because it should no longer be necessary. See
+  [#1364](https://github.com/commercialhaskell/stack/issues/1364)
+
 Behavior changes:
 
 * Switch the "Run from outside project" messages to debug-level, to
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -32,14 +32,17 @@ import           Control.Monad.Logger
 import           Control.Monad.Reader (MonadReader, asks)
 import           Control.Monad.Trans.Control (liftBaseWith)
 import           Control.Monad.Trans.Resource
+import qualified Crypto.Hash.SHA256 as SHA256
 import           Data.Attoparsec.Text hiding (try)
 import qualified Data.ByteString as S
+import qualified Data.ByteString.Base64.URL as B64URL
 import           Data.Char (isSpace)
 import           Data.Conduit
 import qualified Data.Conduit.Binary as CB
 import qualified Data.Conduit.List as CL
 import qualified Data.Conduit.Text as CT
 import           Data.Either (isRight)
+import           Data.FileEmbed (embedFile, makeRelativeToProject)
 import           Data.Foldable (forM_, any)
 import           Data.Function
 import           Data.IORef.RunOnce (runOnce)
@@ -55,7 +58,7 @@ import           Data.Streaming.Process hiding (callProcess, env)
 import           Data.String
 import           Data.Text (Text)
 import qualified Data.Text as T
-import           Data.Text.Encoding (decodeUtf8)
+import           Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import           Data.Text.Extra (stripCR)
 import           Data.Time.Clock (getCurrentTime)
 import           Data.Traversable (forM)
@@ -218,6 +221,8 @@ data ExecuteEnv = ExecuteEnv
     , eeTempDir        :: !(Path Abs Dir)
     , eeSetupHs        :: !(Path Abs File)
     -- ^ Temporary Setup.hs for simple builds
+    , eeSetupShimHs    :: !(Path Abs File)
+    -- ^ Temporary SetupShim.hs, to provide access to initial-build-steps
     , eeSetupExe       :: !(Maybe (Path Abs File))
     -- ^ Compiled version of eeSetupHs
     , eeCabalPkgVer    :: !Version
@@ -231,20 +236,46 @@ data ExecuteEnv = ExecuteEnv
     , eeLogFiles       :: !(TChan (Path Abs Dir, Path Abs File))
     }
 
+buildSetupArgs :: [String]
+buildSetupArgs =
+     [ "-rtsopts"
+     , "-threaded"
+     , "-clear-package-db"
+     , "-global-package-db"
+     , "-hide-all-packages"
+     , "-package"
+     , "base"
+     , "-main-is"
+     , "StackSetupShim.mainOverride"
+     ]
+
+setupGhciShimCode :: S.ByteString
+setupGhciShimCode = $(do
+    path <- makeRelativeToProject "src/setup-shim/StackSetupShim.hs"
+    embedFile path)
+
+simpleSetupHash :: String
+simpleSetupHash =
+    T.unpack $ decodeUtf8 $ S.take 8 $ B64URL.encode $ SHA256.hash $
+    encodeUtf8 (T.pack (unwords buildSetupArgs)) <> setupGhciShimCode
+
 -- | Get a compiled Setup exe
 getSetupExe :: M env m
             => Path Abs File -- ^ Setup.hs input file
+            -> Path Abs File -- ^ SetupShim.hs input file
             -> Path Abs Dir -- ^ temporary directory
             -> m (Maybe (Path Abs File))
-getSetupExe setupHs tmpdir = do
+getSetupExe setupHs setupShimHs tmpdir = do
     wc <- getWhichCompiler
     econfig <- asks getEnvConfig
     platformDir <- platformGhcRelDir
     let config = getConfig econfig
         baseNameS = concat
-            [ "setup-Simple-Cabal-"
+            [ "Cabal-simple_"
+            , simpleSetupHash
+            , "_"
             , versionString $ envConfigCabalVersion econfig
-            , "-"
+            , "_"
             , compilerVersionString $ envConfigCompilerVersion econfig
             ]
         exeNameS = baseNameS ++
@@ -277,19 +308,13 @@ getSetupExe setupHs tmpdir = do
             liftIO $ D.createDirectoryIfMissing True $ toFilePath setupDir
 
             menv <- getMinimalEnvOverride
-            let args =
-                    [ "-clear-package-db"
-                    , "-global-package-db"
-                    , "-hide-all-packages"
-                    , "-package"
-                    , "base"
-                    , "-package"
+            let args = buildSetupArgs ++
+                    [ "-package"
                     , "Cabal-" ++ versionString (envConfigCabalVersion econfig)
                     , toFilePath setupHs
+                    , toFilePath setupShimHs
                     , "-o"
                     , toFilePath tmpOutputPath
-                    , "-rtsopts"
-                    , "-threaded"
                     ] ++
                     ["-build-runner" | wc == Ghcjs]
             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
         configLock <- newMVar ()
         installLock <- newMVar ()
         idMap <- liftIO $ newTVarIO Map.empty
-        let setupHs = tmpdir </> $(mkRelFile "Setup.hs")
+        let setupHs = tmpdir </> $(mkRelFile "Main.hs")
         liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"
-        setupExe <- getSetupExe setupHs tmpdir
+        let setupShimHs = tmpdir </> $(mkRelFile "SetupShim.hs")
+        liftIO $ S.writeFile (toFilePath setupShimHs) setupGhciShimCode
+        setupExe <- getSetupExe setupHs setupShimHs tmpdir
         cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
         globalDB <- getGlobalDB menv =<< getWhichCompiler
         snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)
@@ -337,6 +364,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot
             , eeGhcPkgIds = idMap
             , eeTempDir = tmpdir
             , eeSetupHs = setupHs
+            , eeSetupShimHs = setupShimHs
             , eeSetupExe = setupExe
             , eeCabalPkgVer = cabalPkgVer
             , eeTotalWanted = totalWanted
@@ -996,6 +1024,9 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
                         , "-i", "-i."
                         ] ++ packageArgs ++
                         [ toFilePath setuphs
+                        , toFilePath eeSetupShimHs
+                        , "-main-is"
+                        , "StackSetupShim.mainOverride"
                         , "-o", toFilePath outputFile
                         , "-threaded"
                         ] ++
@@ -1140,9 +1171,21 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
         $ \package cabalfp pkgDir cabal announce _console _mlogFile -> do
             _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix)) cabal cabalfp
 
-            if boptsCLIOnlyConfigure eeBuildOptsCLI
-                then return Nothing
-                else liftM Just $ realBuild cache package pkgDir cabal announce
+            case ( boptsCLIOnlyConfigure eeBuildOptsCLI
+                 , boptsCLIInitialBuildSteps eeBuildOptsCLI && isTarget) of
+                (True, _) -> return Nothing
+                (_, True) -> do
+                    initialBuildSteps cabal announce
+                    return Nothing
+                _ -> liftM Just $ realBuild cache package pkgDir cabal announce
+
+    isTarget = case taskType of
+        TTLocal lp -> lpWanted lp
+        _ -> False
+
+    initialBuildSteps cabal announce = do
+        () <- announce ("initial-build-steps" <> annSuffix)
+        cabal False ["repl", "stack-initial-build-steps"]
 
     realBuild cache package pkgDir cabal announce = do
         wc <- getWhichCompiler
diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs
@@ -77,8 +77,7 @@ import qualified System.Posix.Files as Posix
 
 -- | Command-line options for GHC.
 data GhciOpts = GhciOpts
-    { ghciNoBuild            :: !Bool
-    , ghciArgs               :: ![String]
+    { ghciArgs               :: ![String]
     , ghciGhcCommand         :: !(Maybe FilePath)
     , ghciNoLoadModules      :: !Bool
     , ghciAdditionalPackages :: ![String]
@@ -87,6 +86,7 @@ data GhciOpts = GhciOpts
     , ghciSkipIntermediate   :: !Bool
     , ghciHidePackages       :: !Bool
     , ghciBuildOptsCLI       :: !BuildOptsCLI
+    , ghciNoBuild            :: !Bool
     } deriving Show
 
 -- | Necessary information to load a package or its components.
@@ -334,9 +334,16 @@ ghciSetup GhciOpts{..} = do
             { boptsCLITargets = boptsCLITargets ghciBuildOptsCLI ++ map T.pack ghciAdditionalPackages
             }
     (realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets boptsCli
+    when ghciNoBuild $ $logInfo $ T.unlines
+        [ ""
+        , "NOTE: the --no-build flag should no longer be needed, and is now deprecated."
+        , "See this resolved issue: https://github.com/commercialhaskell/stack/issues/1364"
+        ]
     -- Try to build, but optimistically launch GHCi anyway if it fails (#1065)
     when (not ghciNoBuild && not (M.null realTargets)) $ do
         eres <- tryAny $ build (const (return ())) Nothing boptsCli
+            { boptsCLIInitialBuildSteps = True
+            }
         case eres of
             Right () -> return ()
             Left err -> do
diff --git a/src/Stack/Options/BuildParser.hs b/src/Stack/Options/BuildParser.hs
@@ -76,7 +76,11 @@ buildOptsParser cmd =
         (long "only-configure" <>
          help
              "Only perform the configure step, not any builds. Intended for tool usage, may break when used on multiple packages at once!") <*>
-    pure cmd
+    pure cmd <*>
+    switch
+        (long "initial-build-steps" <>
+         help "For target packages, only run initial build steps needed for GHCi" <>
+         internal)
 
 targetsParser :: Parser [Text]
 targetsParser =
diff --git a/src/Stack/Options/GhciParser.hs b/src/Stack/Options/GhciParser.hs
@@ -12,8 +12,7 @@ import           Stack.Types.Config
 -- | Parser for GHCI options
 ghciOptsParser :: Parser GhciOpts
 ghciOptsParser = GhciOpts
-             <$> switch (long "no-build" <> help "Don't build before launching GHCi")
-             <*> fmap concat (many (argsOption (long "ghci-options" <>
+             <$> fmap concat (many (argsOption (long "ghci-options" <>
                                        metavar "OPTION" <>
                                        help "Additional options passed to GHCi")))
              <*> optional
@@ -33,3 +32,4 @@ ghciOptsParser = GhciOpts
              <*> switch (long "skip-intermediate-deps" <> help "Skip loading intermediate target dependencies")
              <*> boolFlags True "package-hiding" "package hiding" idm
              <*> buildOptsParser Build
+             <*> switch (long "no-build" <> help "Don't build before launching GHCi (deprecated, should be unneeded)")
diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs
@@ -117,6 +117,7 @@ defaultBuildOptsCLI = BuildOptsCLI
     , boptsCLIExec = []
     , boptsCLIOnlyConfigure = False
     , boptsCLICommand = Build
+    , boptsCLIInitialBuildSteps = False
     }
 
 -- | Build options that may only be specified from the CLI
@@ -130,6 +131,7 @@ data BuildOptsCLI = BuildOptsCLI
     , boptsCLIExec :: ![(String, [String])]
     , boptsCLIOnlyConfigure :: !Bool
     , boptsCLICommand :: !BuildCommand
+    , boptsCLIInitialBuildSteps :: !Bool
     } deriving Show
 
 -- | Command sum type for conditional arguments.
diff --git a/src/setup-shim/StackSetupShim.hs b/src/setup-shim/StackSetupShim.hs
@@ -0,0 +1,31 @@
+module StackSetupShim where
+import Main
+import Distribution.PackageDescription (PackageDescription, emptyHookedBuildInfo)
+import Distribution.Simple
+import Distribution.Simple.Build
+import Distribution.Simple.Setup (ReplFlags, fromFlag, replDistPref, replVerbosity)
+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)
+import System.Environment (getArgs)
+
+mainOverride :: IO ()
+mainOverride = do
+    args <- getArgs
+    if "repl" `elem` args && "stack-initial-build-steps" `elem` args
+        then do
+            defaultMainWithHooks simpleUserHooks
+                { preRepl = \_ _ -> return emptyHookedBuildInfo
+                , replHook = stackReplHook
+                , postRepl = \_ _ _ _ -> return ()
+                }
+        else main
+
+stackReplHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO ()
+stackReplHook pkg_descr lbi hooks flags args = do
+    let distPref = fromFlag (replDistPref flags)
+        verbosity = fromFlag (replVerbosity flags)
+    case args of
+        ("stack-initial-build-steps":rest)
+            | null rest -> initialBuildSteps distPref pkg_descr lbi verbosity
+            | otherwise ->
+                fail "Misuse of running Setup.hs with stack-initial-build-steps, expected no arguments"
+        _ -> replHook simpleUserHooks pkg_descr lbi hooks flags args
diff --git a/stack-7.8.yaml b/stack-7.8.yaml
@@ -75,6 +75,7 @@ extra-deps:
 - optparse-applicative-0.13.0.0
 - text-metrics-0.1.0
 - pid1-0.1.0.0
+- file-embed-0.0.10
 flags:
   time-locale-compat:
     old-locale: false
diff --git a/stack.cabal b/stack.cabal
@@ -263,6 +263,7 @@ library
                    , hpack >= 0.14.0 && < 0.16
                    , store >= 0.2.1.0
                    , annotated-wl-pprint
+                   , file-embed >= 0.0.10
   if os(windows)
     cpp-options:     -DWINDOWS
     build-depends:   Win32
