Merge pull request #803 from commercialhaskell/801-cache-setup-exe

Use a cached Setup exe #801

ChangeLog.md

@@ -11,6 +11,7 @@ Other enhancements:
 * Added the `extra-path` field to stack.yaml
 * Code page changes on Windows only apply to the build command (and its synonyms), and can be controlled via a command line flag (still defaults to on) [#757](https://github.com/commercialhaskell/stack/issues/757)
 * Implicitly add packages to extra-deps when a flag for them is set [#807](https://github.com/commercialhaskell/stack/issues/807)
+* Use a precompiled Setup.hs for simple build types [#801](https://github.com/commercialhaskell/stack/issues/801)
 
 Bug fixes:
 
@@ -63,7 +64,7 @@ Bug fixes:
 * Fix: stack fails on Windows with git package in stack.yaml and no git binary on path [#712](https://github.com/commercialhaskell/stack/issues/712)
 * Fixed GHCi issue: Specifying explicit package versions (#678)
 * Fixed GHCi issue: Specifying -odir and -hidir as .stack-work/odir (#529)
-* Fixed GHCi issue: Specifying A instead of A.ext for modules (#498) 
+* Fixed GHCi issue: Specifying A instead of A.ext for modules (#498)
 
 ## 0.1.2.0
 

src/Stack/Build/Execute.hs

@@ -55,6 +55,7 @@ import           Data.Text.Encoding             (encodeUtf8)
 import           Data.Word8                     (_colon)
 import           Distribution.System            (OS (Windows),
                                                  Platform (Platform))
+import qualified Distribution.Text
 import           Language.Haskell.TH            as TH (location)
 import           Network.HTTP.Client.Conduit    (HasHttpManager)
 import           Path
@@ -191,6 +192,9 @@ data ExecuteEnv = ExecuteEnv
     , eeGhcPkgIds      :: !(TVar (Map PackageIdentifier Installed))
     , eeTempDir        :: !(Path Abs Dir)
     , eeSetupHs        :: !(Path Abs File)
+    -- ^ Temporary Setup.hs for simple builds
+    , eeSetupExe       :: !(Maybe (Path Abs File))
+    -- ^ Compiled version of eeSetupHs
     , eeCabalPkgVer    :: !Version
     , eeTotalWanted    :: !Int
     , eeWanted         :: !(Set PackageName)
@@ -199,6 +203,72 @@ data ExecuteEnv = ExecuteEnv
     , eeGlobalDB       :: !(Path Abs Dir)
     }
 
+-- | Get a compiled Setup exe
+getSetupExe :: M env m
+            => Path Abs File -- ^ Setup.hs input file
+            -> Path Abs Dir -- ^ temporary directory
+            -> m (Maybe (Path Abs File))
+getSetupExe setupHs tmpdir = do
+    wc <- getWhichCompiler
+    econfig <- asks getEnvConfig
+    let config = getConfig econfig
+        baseNameS = concat
+            [ "setup-Simple-Cabal-"
+            , versionString $ envConfigCabalVersion econfig
+            , "-"
+            , Distribution.Text.display $ configPlatform config
+            , "-"
+            , T.unpack $ compilerVersionName
+                       $ envConfigCompilerVersion econfig
+            ]
+        exeNameS = baseNameS ++
+            case configPlatform config of
+                Platform _ Windows -> ".exe"
+                _ -> ""
+        outputNameS =
+            case wc of
+                Ghc -> exeNameS
+                Ghcjs -> baseNameS ++ ".jsexe"
+        jsExeNameS =
+            baseNameS ++ ".jsexe"
+        setupDir =
+            configStackRoot config </>
+            $(mkRelDir "setup-exe-cache")
+
+    exePath <- fmap (setupDir </>) $ parseRelFile exeNameS
+    jsExePath <- fmap (setupDir </>) $ parseRelDir jsExeNameS
+
+    exists <- liftIO $ D.doesFileExist $ toFilePath exePath
+
+    if exists
+        then return $ Just exePath
+        else do
+            tmpExePath <- fmap (setupDir </>) $ parseRelFile $ "tmp-" ++ exeNameS
+            tmpOutputPath <- fmap (setupDir </>) $ parseRelFile $ "tmp-" ++ outputNameS
+            tmpJsExePath <- fmap (setupDir </>) $ parseRelDir $ "tmp-" ++ jsExeNameS
+
+            liftIO $ D.createDirectoryIfMissing True $ toFilePath setupDir
+
+            menv <- getMinimalEnvOverride
+            wc <- getWhichCompiler
+            let args =
+                    [ "-clear-package-db"
+                    , "-global-package-db"
+                    , "-hide-all-packages"
+                    , "-package"
+                    , "base"
+                    , "-package"
+                    , "Cabal-" ++ versionString (envConfigCabalVersion econfig)
+                    , toFilePath setupHs
+                    , "-o"
+                    , toFilePath tmpOutputPath
+                    ] ++
+                    ["-build-runner" | wc == Ghcjs]
+            runIn tmpdir (compilerExeName wc) menv args Nothing
+            when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath
+            renameFile tmpExePath exePath
+            return $ Just exePath
+
 withExecuteEnv :: M env m
                => EnvOverride
                -> BuildOpts
@@ -215,6 +285,7 @@ withExecuteEnv menv bopts baseConfigOpts locals sourceMap inner = do
         idMap <- liftIO $ newTVarIO Map.empty
         let setupHs = tmpdir' </> $(mkRelFile "Setup.hs")
         liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"
+        setupExe <- getSetupExe setupHs tmpdir'
         cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
         globalDB <- getGlobalDB menv =<< getWhichCompiler
         inner ExecuteEnv
@@ -230,6 +301,7 @@ withExecuteEnv menv bopts baseConfigOpts locals sourceMap inner = do
             , eeGhcPkgIds = idMap
             , eeTempDir = tmpdir'
             , eeSetupHs = setupHs
+            , eeSetupExe = setupExe
             , eeCabalPkgVer = cabalPkgVer
             , eeTotalWanted = length $ filter lpWanted locals
             , eeWanted = wantedLocalPackages locals
@@ -560,13 +632,13 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} msuffix inne
         getRunhaskellPath <- runOnce $ liftIO $ join $ findExecutable menv "runhaskell"
         getGhcjsPath <- runOnce $ liftIO $ join $ findExecutable menv "ghcjs"
         distRelativeDir' <- distRelativeDir
-        setuphs <-
+        esetupexehs <-
             -- Avoid broken Setup.hs files causing problems for simple build
             -- types, see:
             -- https://github.com/commercialhaskell/stack/issues/370
-            if packageSimpleType package
-                then return eeSetupHs
-                else liftIO $ getSetupHs pkgDir
+            case (packageSimpleType package, eeSetupExe) of
+                (True, Just setupExe) -> return $ Left setupExe
+                _ -> liftIO $ fmap Right $ getSetupHs pkgDir
         inner $ \stripTHLoading args -> do
             let packageArgs =
                       ("-package=" ++
@@ -643,12 +715,13 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} msuffix inne
                         }
 
             wc <- getWhichCompiler
-            (exeName, fullArgs) <- case wc of
-                Ghc -> do
+            (exeName, fullArgs) <- case (esetupexehs, wc) of
+                (Left setupExe, _) -> return (setupExe, setupArgs)
+                (Right setuphs, Ghc) -> do
                     exeName <- getRunhaskellPath
                     let fullArgs = packageArgs ++ (toFilePath setuphs : setupArgs)
                     return (exeName, fullArgs)
-                Ghcjs -> do
+                (Right setuphs, Ghcjs) -> do
                     distDir <- distDirFromDir pkgDir
                     let setupDir = distDir </> $(mkRelDir "setup")
                         outputFile = setupDir </> $(mkRelFile "setup")

src/Stack/Build/Haddock.hs

@@ -203,12 +203,9 @@ generateHaddockIndex descr envOverride wc packageIDs docRelDir destDir = do
                    readProcessNull
                        (Just destDir)
                        envOverride
-                       exeName
+                       (compilerExeName wc)
                        (["--gen-contents", "--gen-index"] ++ concatMap fst interfaceOpts)
   where
-    exeName = case wc of
-        Ghc -> "haddock"
-        Ghcjs -> "haddock-ghcjs"
     toInterfaceOpt pid@(PackageIdentifier name _) = do
         let interfaceRelFile =
                 docRelDir FP.</> packageIdentifierString pid FP.</>

src/Stack/Ghci.hs

@@ -78,15 +78,12 @@ ghci GhciOpts{..} = do
         odir =
             [ "-odir=" <> toFilePath (objectInterfaceDir bconfig)
             , "-hidir=" <> toFilePath (objectInterfaceDir bconfig)]
-        defaultCommand = case wc of
-            Ghc -> "ghc"
-            Ghcjs -> "ghcjs"
     $logInfo
         ("Configuring GHCi with the following packages: " <>
          T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs))
     exec
         defaultEnvSettings
-        (fromMaybe defaultCommand ghciGhcCommand)
+        (fromMaybe (compilerExeName wc) ghciGhcCommand)
         ("--interactive" : odir <> pkgopts <> srcfiles <> ghciArgs)
 
 -- | Figure out the main-is file to load based on the targets. Sometimes there

src/Stack/Setup.hs

@@ -379,10 +379,7 @@ upgradeCabal menv wc = do
             let ident = PackageIdentifier name newest
             m <- unpackPackageIdents menv tmpdir' Nothing (Set.singleton ident)
 
-            let compilerName = case wc of
-                    Ghc -> "ghc"
-                    Ghcjs -> "ghcjs"
-            compilerPath <- join $ findExecutable menv compilerName
+            compilerPath <- join $ findExecutable menv (compilerExeName wc)
             newestDir <- parseRelDir $ versionString newest
             let installRoot = toFilePath $ parent (parent compilerPath)
                                        </> $(mkRelDir "new-cabal")
@@ -393,7 +390,7 @@ upgradeCabal menv wc = do
                     Nothing -> error $ "upgradeCabal: Invariant violated, dir missing"
                     Just dir -> return dir
 
-            runIn dir compilerName menv ["Setup.hs"] Nothing
+            runIn dir (compilerExeName wc) menv ["Setup.hs"] Nothing
             let setupExe = toFilePath $ dir </> $(mkRelFile "Setup")
                 dirArgument name' = concat
                     [ "--"

src/Stack/Types/Compiler.hs

@@ -71,3 +71,7 @@ isWantedCompiler check (GhcVersion wanted) (GhcVersion actual) =
 isWantedCompiler check (GhcjsVersion wanted wantedGhc) (GhcjsVersion actual actualGhc) =
     checkVersion check wanted actual && checkVersion check wantedGhc actualGhc
 isWantedCompiler _ _ _ = False
+
+compilerExeName :: WhichCompiler -> String
+compilerExeName Ghc = "ghc"
+compilerExeName Ghcjs = "ghcjs"