From a56f43eacefaed9fafc042aabde6dfcf99f2edc9 Mon Sep 17 00:00:00 2001 From: waddlaw Date: Sun, 19 Aug 2018 19:04:32 +0900 Subject: [PATCH 1/3] Add the ddump-dir option/config value #4225 --- ChangeLog.md | 1 + doc/yaml_configuration.md | 3 +++ src/Stack/Build/Execute.hs | 23 +++++++++++++++++++++++ src/Stack/Config/Build.hs | 1 + src/Stack/Options/BuildMonoidParser.hs | 8 +++++++- src/Stack/Types/Config/Build.hs | 7 +++++++ 6 files changed, 42 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index a99d32cc00..44ce55427a 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -22,6 +22,7 @@ Other enhancements: non-project-specific yaml configuration parameter, allows a stack user to redefine the default styles that stack uses to color some of its output. See `stack --help` for more information. +* New build option `--ddump-dir`. (See [#4225](https://github.com/commercialhaskell/stack/issues/4225)) Bug fixes: diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index f6f515c83b..7c6bca7b18 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -790,6 +790,9 @@ build: # Since 1.8 interleaved-output: false + + # Since 1.10 + ddump-dir: "" ``` The meanings of these settings correspond directly with the CLI flags of the diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index febd276109..765a2943d2 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -35,6 +35,7 @@ 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.Filesystem as CF import qualified Data.Conduit.List as CL import Data.Conduit.Process.Typed (ExitCodeException (..), waitExitCode, @@ -1532,6 +1533,28 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap _ -> return () when hasLibrary $ cabal KeepTHLoading ["register"] + -- copy ddump-* files + let enableDdumpDir = isJust $ boptsDdumpDir eeBuildOpts + ddumpPath = maybe "" T.unpack $ boptsDdumpDir eeBuildOpts + when (buildingFinals && enableDdumpDir && not (null ddumpPath)) $ do + distDir <- distRelativeDir + ddumpDir <- parseRelDir ddumpPath + + logDebug $ fromString ("ddump-dir: " <> toFilePath ddumpDir) + logDebug $ fromString ("dist-dir: " <> toFilePath distDir) + + runConduitRes + $ CF.sourceDirectoryDeep False (toFilePath distDir) + .| CL.filter (isInfixOf ".dump-") + .| CL.mapM_ (\src -> liftIO $ do + parentDir <- parent <$> parseRelDir src + destBaseDir <- (ddumpDir ) <$> stripProperPrefix distDir parentDir + -- exclude .stack-work dir + when (not (".stack-work" `isInfixOf` (toFilePath destBaseDir))) $ do + ensureDir destBaseDir + src' <- parseRelFile src + copyFile src' (destBaseDir filename src')) + let (installedPkgDb, installedDumpPkgsTVar) = case taskLocation task of Snap -> diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs index fb5d0a6f21..8c744d614f 100644 --- a/src/Stack/Config/Build.hs +++ b/src/Stack/Config/Build.hs @@ -75,6 +75,7 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts , boptsInterleavedOutput = fromFirst (boptsInterleavedOutput defaultBuildOpts) buildMonoidInterleavedOutput + , boptsDdumpDir = getFirst buildMonoidDdumpDir } where -- These options are not directly used in bopts, instead they diff --git a/src/Stack/Options/BuildMonoidParser.hs b/src/Stack/Options/BuildMonoidParser.hs index c89be1df6e..ac47f21a0c 100644 --- a/src/Stack/Options/BuildMonoidParser.hs +++ b/src/Stack/Options/BuildMonoidParser.hs @@ -22,7 +22,7 @@ buildOptsMonoidParser hide0 = preFetch <*> keepGoing <*> keepTmpFiles <*> forceDirty <*> tests <*> testOptsParser hideBool <*> benches <*> benchOptsParser hideBool <*> reconfigure <*> cabalVerbose <*> splitObjs <*> skipComponents <*> - interleavedOutput + interleavedOutput <*> ddumpDir where hideBool = hide0 /= BuildCmdGlobalOpts hide = @@ -173,3 +173,9 @@ buildOptsMonoidParser hide0 = "interleaved-output" "Print concurrent GHC output to the console with a prefix for the package name" hide + ddumpDir = + optionalFirst + (strOption + (long "ddump-dir" <> + help "Specify output ddump-files" <> + hide)) diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs index e0b9dec22d..296379d225 100644 --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -91,6 +91,7 @@ data BuildOpts = ,boptsInterleavedOutput :: !Bool -- ^ Should we use the interleaved GHC output when building -- multiple packages? + ,boptsDdumpDir :: !(Maybe Text) } deriving (Show) @@ -121,6 +122,7 @@ defaultBuildOpts = BuildOpts , boptsSplitObjs = False , boptsSkipComponents = [] , boptsInterleavedOutput = False + , boptsDdumpDir = Nothing } defaultBuildOptsCLI ::BuildOptsCLI @@ -190,6 +192,7 @@ data BuildOptsMonoid = BuildOptsMonoid , buildMonoidSplitObjs :: !(First Bool) , buildMonoidSkipComponents :: ![Text] , buildMonoidInterleavedOutput :: !(First Bool) + , buildMonoidDdumpDir :: !(First Text) } deriving (Show, Generic) instance FromJSON (WithJSONWarnings BuildOptsMonoid) where @@ -222,6 +225,7 @@ instance FromJSON (WithJSONWarnings BuildOptsMonoid) where buildMonoidSplitObjs <- First <$> o ..:? buildMonoidSplitObjsName buildMonoidSkipComponents <- o ..:? buildMonoidSkipComponentsName ..!= mempty buildMonoidInterleavedOutput <- First <$> o ..:? buildMonoidInterleavedOutputName + buildMonoidDdumpDir <- o ..:? buildMonoidDdumpDirName ..!= mempty return BuildOptsMonoid{..}) buildMonoidLibProfileArgName :: Text @@ -299,6 +303,9 @@ buildMonoidSkipComponentsName = "skip-components" buildMonoidInterleavedOutputName :: Text buildMonoidInterleavedOutputName = "interleaved-output" +buildMonoidDdumpDirName :: Text +buildMonoidDdumpDirName = "ddump-dir" + instance Semigroup BuildOptsMonoid where (<>) = mappenddefault From 539221f1856f8926a7b42d8087f6b8a3b0c5c5cf Mon Sep 17 00:00:00 2001 From: waddlaw Date: Sun, 19 Aug 2018 21:30:11 +0900 Subject: [PATCH 2/3] Fix hlint suggestion --- src/Stack/Build/Execute.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 765a2943d2..866afa5953 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1550,7 +1550,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap parentDir <- parent <$> parseRelDir src destBaseDir <- (ddumpDir ) <$> stripProperPrefix distDir parentDir -- exclude .stack-work dir - when (not (".stack-work" `isInfixOf` (toFilePath destBaseDir))) $ do + unless (".stack-work" `isInfixOf` toFilePath destBaseDir) $ do ensureDir destBaseDir src' <- parseRelFile src copyFile src' (destBaseDir filename src')) From c15ef19ff9b3374b142b97541b637af5341075c7 Mon Sep 17 00:00:00 2001 From: waddlaw Date: Mon, 20 Aug 2018 15:46:12 +0900 Subject: [PATCH 3/3] Improve more readable. --- src/Stack/Build/Execute.hs | 40 +++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 866afa5953..9b96ea2180 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1534,26 +1534,26 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap when hasLibrary $ cabal KeepTHLoading ["register"] -- copy ddump-* files - let enableDdumpDir = isJust $ boptsDdumpDir eeBuildOpts - ddumpPath = maybe "" T.unpack $ boptsDdumpDir eeBuildOpts - when (buildingFinals && enableDdumpDir && not (null ddumpPath)) $ do - distDir <- distRelativeDir - ddumpDir <- parseRelDir ddumpPath - - logDebug $ fromString ("ddump-dir: " <> toFilePath ddumpDir) - logDebug $ fromString ("dist-dir: " <> toFilePath distDir) - - runConduitRes - $ CF.sourceDirectoryDeep False (toFilePath distDir) - .| CL.filter (isInfixOf ".dump-") - .| CL.mapM_ (\src -> liftIO $ do - parentDir <- parent <$> parseRelDir src - destBaseDir <- (ddumpDir ) <$> stripProperPrefix distDir parentDir - -- exclude .stack-work dir - unless (".stack-work" `isInfixOf` toFilePath destBaseDir) $ do - ensureDir destBaseDir - src' <- parseRelFile src - copyFile src' (destBaseDir filename src')) + case T.unpack <$> boptsDdumpDir eeBuildOpts of + Just ddumpPath | buildingFinals && not (null ddumpPath) -> do + distDir <- distRelativeDir + ddumpDir <- parseRelDir ddumpPath + + logDebug $ fromString ("ddump-dir: " <> toFilePath ddumpDir) + logDebug $ fromString ("dist-dir: " <> toFilePath distDir) + + runConduitRes + $ CF.sourceDirectoryDeep False (toFilePath distDir) + .| CL.filter (isInfixOf ".dump-") + .| CL.mapM_ (\src -> liftIO $ do + parentDir <- parent <$> parseRelDir src + destBaseDir <- (ddumpDir ) <$> stripProperPrefix distDir parentDir + -- exclude .stack-work dir + unless (".stack-work" `isInfixOf` toFilePath destBaseDir) $ do + ensureDir destBaseDir + src' <- parseRelFile src + copyFile src' (destBaseDir filename src')) + _ -> pure () let (installedPkgDb, installedDumpPkgsTVar) = case taskLocation task of