Build all exes once; then only specified (#3229)

src/Stack/Build/Execute.hs

@@ -25,8 +25,8 @@ import           Control.Arrow ((&&&), second)
 import           Control.Concurrent.Execute
 import           Control.Concurrent.MVar.Lifted
 import           Control.Concurrent.STM
-import           Control.Exception.Safe (catchIO)
 import           Control.Exception.Lifted
+import           Control.Exception.Safe (catchIO)
 import           Control.Monad (liftM, when, unless, void)
 import           Control.Monad.Catch (MonadCatch)
 import           Control.Monad.IO.Class
@@ -51,6 +51,7 @@ import           Data.IORef
 import           Data.IORef.RunOnce (runOnce)
 import           Data.List hiding (any)
 import           Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
 import           Data.Maybe.Extra (forMaybeM)
@@ -114,6 +115,12 @@ import           System.Process.Run
 import           System.Process.Internals (createProcess_)
 #endif
 
+-- | Has an executable been built or not?
+data ExecutableBuildStatus
+    = ExecutableBuilt
+    | ExecutableNotBuilt
+  deriving (Show, Eq, Ord)
+
 -- | Fetch the packages necessary for a build, for example in combination with a dry run.
 preFetch :: (StackM env m, HasEnvConfig env) => Plan -> m ()
 preFetch plan
@@ -1187,7 +1194,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
     enableTests = buildingFinals && any isCTest (taskComponents task)
     enableBenchmarks = buildingFinals && any isCBench (taskComponents task)
 
-    annSuffix = if result == "" then "" else " (" <> result <> ")"
+    annSuffix executableBuildStatuses = if result == "" then "" else " (" <> result <> ")"
       where
         result = T.intercalate " + " $ concat
             [ ["lib" | taskAllInOne && hasLib]
@@ -1196,7 +1203,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
             , ["bench" | enableBenchmarks]
             ]
         (hasLib, hasExe) = case taskType of
-            TTLocal lp -> (packageHasLibrary (lpPackage lp), not (Set.null (exesToBuild lp)))
+            TTLocal lp -> (packageHasLibrary (lpPackage lp), not (Set.null (exesToBuild executableBuildStatuses lp)))
             -- This isn't true, but we don't want to have this info for
             -- upstream deps.
             TTUpstream{} -> (False, False)
@@ -1287,7 +1294,10 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
 
     realConfigAndBuild cache allDepsMap = withSingleContext runInBase ac ee task (Just allDepsMap) Nothing
         $ \package cabalfp pkgDir cabal announce _console _mlogFile -> do
-            _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix)) cabal cabalfp
+            executableBuildStatuses <- getExecutableBuildStatuses package pkgDir
+            when (not (cabalIsSatisfied executableBuildStatuses) && taskIsTarget task)
+                 ($logInfo "Building all executables once. After a successful build of all of them, only specified executables will be rebuilt.")
+            _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix executableBuildStatuses)) cabal cabalfp
 
             let installedMapHasThisPkg :: Bool
                 installedMapHasThisPkg =
@@ -1304,12 +1314,12 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
                 -- https://github.com/commercialhaskell/stack/issues/2787
                 (True, _) | null acDownstream -> return Nothing
                 (_, True) | null acDownstream || installedMapHasThisPkg -> do
-                    initialBuildSteps cabal announce
+                    initialBuildSteps executableBuildStatuses cabal announce
                     return Nothing
-                _ -> liftM Just $ realBuild cache package pkgDir cabal announce
+                _ -> liftM Just $ realBuild cache package pkgDir cabal announce executableBuildStatuses
 
-    initialBuildSteps cabal announce = do
-        () <- announce ("initial-build-steps" <> annSuffix)
+    initialBuildSteps executableBuildStatuses cabal announce = do
+        () <- announce ("initial-build-steps" <> annSuffix executableBuildStatuses)
         cabal KeepTHLoading ["repl", "stack-initial-build-steps"]
 
     realBuild
@@ -1318,8 +1328,9 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
         -> Path Abs Dir
         -> (ExcludeTHLoading -> [String] -> m ())
         -> (Text -> m ())
+        -> Map Text ExecutableBuildStatus
         -> m Installed
-    realBuild cache package pkgDir cabal announce = do
+    realBuild cache package pkgDir cabal announce executableBuildStatuses = do
         wc <- view $ actualCompilerVersionL.whichCompilerL
 
         markExeNotInstalled (taskLocation task) taskProvides
@@ -1355,7 +1366,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
                         line <> line <>
                         "Missing modules in the cabal file are likely to cause undefined reference errors from the linker, along with other problems."
 
-        () <- announce ("build" <> annSuffix)
+        () <- announce ("build" <> annSuffix executableBuildStatuses)
         config <- view configL
         extraOpts <- extraBuildOptions wc eeBuildOpts
         let stripTHLoading
@@ -1364,9 +1375,9 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
         cabal stripTHLoading (("build" :) $ (++ extraOpts) $
             case (taskType, taskAllInOne, isFinalBuild) of
                 (_, True, True) -> error "Invariant violated: cannot have an all-in-one build that also has a final build step."
-                (TTLocal lp, False, False) -> primaryComponentOptions lp
+                (TTLocal lp, False, False) -> primaryComponentOptions executableBuildStatuses lp
                 (TTLocal lp, False, True) -> finalComponentOptions lp
-                (TTLocal lp, True, False) -> primaryComponentOptions lp ++ finalComponentOptions lp
+                (TTLocal lp, True, False) -> primaryComponentOptions executableBuildStatuses lp ++ finalComponentOptions lp
                 (TTUpstream{}, _, _) -> [])
           `catch` \ex -> case ex of
               CabalExitedUnsuccessfully{} -> postBuildCheck False >> throwM ex
@@ -1453,6 +1464,56 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
                 return $ Just (dpGhcPkgId dp)
             _ -> error "singleBuild: invariant violated: multiple results when describing installed package"
 
+-- | Get the build status of all the package executables. Do so by
+-- testing whether their expected output file exists, e.g.
+--
+-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha
+-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.exe
+-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.jsexe/ (NOTE: a dir)
+getExecutableBuildStatuses
+    :: (StackM env m, HasEnvConfig env)
+    => Package -> Path Abs Dir -> m (Map Text ExecutableBuildStatus)
+getExecutableBuildStatuses package pkgDir = do
+    compiler <- view $ actualCompilerVersionL.whichCompilerL
+    distDir <- distDirFromDir pkgDir
+    platform <- view platformL
+    fmap
+        M.fromList
+        (mapM (checkExeStatus compiler platform distDir) (Set.toList (packageExes package)))
+
+-- | Check whether the given executable is defined in the given dist directory.
+checkExeStatus
+    :: (MonadLogger m, MonadIO m, MonadThrow m)
+    => WhichCompiler
+    -> Platform
+    -> Path b Dir
+    -> Text
+    -> m (Text, ExecutableBuildStatus)
+checkExeStatus compiler platform distDir name = do
+    exename <- parseRelDir (T.unpack name)
+    exists <- checkPath (distDir </> $(mkRelDir "build") </> exename)
+    pure
+        ( name
+        , if exists
+              then ExecutableBuilt
+              else ExecutableNotBuilt)
+  where
+    checkPath base =
+        case compiler of
+            Ghcjs -> do
+                dir <- parseRelDir (file ++ ".jsexe")
+                doesDirExist (base </> dir)
+            _ ->
+                case platform of
+                    Platform _ Windows -> do
+                        fileandext <- parseRelFile (file ++ ".exe")
+                        doesFileExist (base </> fileandext)
+                    _ -> do
+                        fileandext <- parseRelFile file
+                        doesFileExist (base </> fileandext)
+      where
+        file = T.unpack name
+
 -- | Check if any unlisted files have been found, and add them to the build cache.
 checkForUnlistedFiles :: (StackM env m, HasEnvConfig env) => TaskType -> ModTime -> Path Abs Dir -> m [PackageWarning]
 checkForUnlistedFiles (TTLocal lp) preBuildTime pkgDir = do
@@ -1754,27 +1815,36 @@ extraBuildOptions wc bopts = do
         return [optsFlag, ddumpOpts]
 
 -- Library and executable build components.
-primaryComponentOptions :: LocalPackage -> [String]
-primaryComponentOptions lp = ["lib:" ++ packageNameString (packageName (lpPackage lp))
+primaryComponentOptions :: Map Text ExecutableBuildStatus -> LocalPackage -> [String]
+primaryComponentOptions executableBuildStatuses lp = ["lib:" ++ packageNameString (packageName (lpPackage lp))
       -- TODO: get this information from target parsing instead,
       -- which will allow users to turn off library building if
       -- desired
       | packageHasLibrary (lpPackage lp)] ++
-      map (T.unpack . T.append "exe:") (Set.toList $ exesToBuild lp)
-
-exesToBuild :: LocalPackage -> Set Text
-exesToBuild lp = packageExes (lpPackage lp)
-    -- NOTE: Ideally we'd do something like the following code, allowing
-    -- the user to control which executables get built. However, due to
-    -- https://github.com/haskell/cabal/issues/2780 we must build all
-    -- exes...
-    --
-    -- if lpWanted lp
-    --     then exeComponents (lpComponents lp)
-    --     -- Build all executables in the event that no
-    --     -- specific list is provided (as happens with
-    --     -- extra-deps).
-    --     else packageExes (lpPackage lp)
+      map (T.unpack . T.append "exe:") (Set.toList $ exesToBuild executableBuildStatuses lp)
+
+-- | History of this function:
+--
+-- * Normally it would do either all executables or if the user
+--   specified requested components, just build them. Afterwards, due
+--   to this Cabal bug <https://github.com/haskell/cabal/issues/2780>,
+--   we had to make Stack build all executables every time.
+--
+-- * In <https://github.com/commercialhaskell/stack/issues/3229> this
+--   was flagged up as very undesirable behavior on a large project,
+--   hence the behavior below that we build all executables once
+--   (modulo success), and thereafter pay attention to user-wanted
+--   components.
+--
+exesToBuild :: Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
+exesToBuild executableBuildStatuses lp =
+    if cabalIsSatisfied executableBuildStatuses && lpWanted lp
+        then exeComponents (lpComponents lp)
+        else packageExes (lpPackage lp)
+
+-- | Do the current executables satisfy Cabal's bugged out requirements?
+cabalIsSatisfied :: Map k ExecutableBuildStatus -> Bool
+cabalIsSatisfied = all (== ExecutableBuilt) . M.elems
 
 -- Test-suite and benchmark build components.
 finalComponentOptions :: LocalPackage -> [String]

test/integration/tests/3229-exe-targets/Main.hs

@@ -0,0 +1,46 @@
+-- | Stack should build all executables once, and in subsequent
+-- invocations only build those executables requested by the program
+-- arguments.
+--
+-- Issue: https://github.com/commercialhaskell/stack/issues/3229
+
+module Main where
+
+import           Control.Exception
+import           Control.Monad (unless, when)
+import qualified Data.ByteString as S
+import           Data.List (isInfixOf)
+import           StackTest
+
+main :: IO ()
+main = do
+    stack [defaultResolverArg, "clean", "--full"]
+    stack [defaultResolverArg, "init", "--force"]
+    stackCheckStderr
+        ["build", ":alpha"]
+        (expectMessage
+             (unlines
+                  [ "Building all executables once. After a successful build of all of them, only specified executables will be rebuilt."
+                  ]))
+    bracket
+        (S.readFile alphaFile)
+        (S.writeFile alphaFile)
+        (const
+             (do appendFile alphaFile "\n--"
+                 stackCheckStderr
+                     ["build", ":alpha"]
+                     (rejectMessage
+                          (unlines
+                               ["Preprocessing executable 'beta' for foo-0..."]))))
+  where
+    alphaFile = "app/Alpha.hs"
+
+expectMessage :: String -> String -> IO ()
+expectMessage msg stderr =
+    unless (msg `isInfixOf` stderr)
+        (error $ "Expected in output: \n" ++ show msg)
+
+rejectMessage :: String -> String -> IO ()
+rejectMessage msg stderr =
+    when (msg `isInfixOf` stderr)
+            (error $ "Did not expect message here: \n" ++ show msg)

test/integration/tests/3229-exe-targets/files/app/Alpha.hs

@@ -0,0 +1 @@
+main = return ()

test/integration/tests/3229-exe-targets/files/app/Beta.hs

@@ -0,0 +1 @@
+main = return ()

test/integration/tests/3229-exe-targets/files/foo.cabal

@@ -0,0 +1,22 @@
+name:                foo
+version:             0
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Foo
+  build-depends:       base >= 4.7 && < 5
+  default-language:    Haskell2010
+
+executable alpha
+  hs-source-dirs:      app
+  main-is:             Alpha.hs
+  build-depends:       base, foo
+  default-language:    Haskell2010
+
+executable beta
+  hs-source-dirs:      app
+  main-is:             Beta.hs
+  build-depends:       base, foo
+  default-language:    Haskell2010

test/integration/tests/3229-exe-targets/files/src/Foo.hs

@@ -0,0 +1 @@
+module Foo where