From 8767419ebf76095ce59b7e578a9210676ee6274f Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Wed, 22 Mar 2017 14:29:02 -0700 Subject: [PATCH] Apply args like --profile when converting from options Monoid #2399 --- src/Stack/Config/Build.hs | 53 +++++++++--- src/Stack/Options/BuildMonoidParser.hs | 109 +++++++------------------ src/Stack/Types/Config/Build.hs | 10 ++- 3 files changed, 78 insertions(+), 94 deletions(-) diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs index 0412f03b29..ffaece2a4f 100644 --- a/src/Stack/Config/Build.hs +++ b/src/Stack/Config/Build.hs @@ -3,6 +3,7 @@ -- | Build configuration module Stack.Config.Build where +import Data.Maybe import Data.Monoid.Extra import Stack.Types.Config @@ -11,16 +12,20 @@ buildOptsFromMonoid :: BuildOptsMonoid -> BuildOpts buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts { boptsLibProfile = fromFirst (boptsLibProfile defaultBuildOpts) - buildMonoidLibProfile + (buildMonoidLibProfile <> + First (if tracing || profiling then Just True else Nothing)) , boptsExeProfile = fromFirst (boptsExeProfile defaultBuildOpts) - buildMonoidExeProfile + (buildMonoidExeProfile <> + First (if tracing || profiling then Just True else Nothing)) , boptsLibStrip = fromFirst (boptsLibStrip defaultBuildOpts) - buildMonoidLibStrip + (buildMonoidLibStrip <> + First (if noStripping then Just False else Nothing)) , boptsExeStrip = fromFirst (boptsExeStrip defaultBuildOpts) - buildMonoidExeStrip + (buildMonoidExeStrip <> + First (if noStripping then Just False else Nothing)) , boptsHaddock = fromFirst (boptsHaddock defaultBuildOpts) buildMonoidHaddock @@ -43,11 +48,13 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts (boptsForceDirty defaultBuildOpts) buildMonoidForceDirty , boptsTests = fromFirst (boptsTests defaultBuildOpts) buildMonoidTests - , boptsTestOpts = testOptsFromMonoid buildMonoidTestOpts + , boptsTestOpts = + testOptsFromMonoid buildMonoidTestOpts additionalArgs , boptsBenchmarks = fromFirst (boptsBenchmarks defaultBuildOpts) buildMonoidBenchmarks - , boptsBenchmarkOpts = benchmarkOptsFromMonoid buildMonoidBenchmarkOpts + , boptsBenchmarkOpts = + benchmarkOptsFromMonoid buildMonoidBenchmarkOpts additionalArgs , boptsReconfigure = fromFirst (boptsReconfigure defaultBuildOpts) buildMonoidReconfigure @@ -58,26 +65,46 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts (boptsSplitObjs defaultBuildOpts) buildMonoidSplitObjs } - + where + -- These options are not directly used in bopts, instead they + -- transform other options. + tracing = fromFirst False buildMonoidTrace + profiling = fromFirst False buildMonoidProfile + noStripping = getAny buildMonoidNoStrip + -- Additional args for tracing / profiling + additionalArgs = + if tracing || profiling + then Just $ "+RTS" : catMaybes [trac, prof, Just "-RTS"] + else Nothing + trac = + if tracing + then Just "-xc" + else Nothing + prof = + if profiling + then Just "-p" + else Nothing haddockOptsFromMonoid :: HaddockOptsMonoid -> HaddockOpts haddockOptsFromMonoid HaddockOptsMonoid{..} = defaultHaddockOpts {hoAdditionalArgs = hoMonoidAdditionalArgs} -testOptsFromMonoid :: TestOptsMonoid -> TestOpts -testOptsFromMonoid TestOptsMonoid{..} = +testOptsFromMonoid :: TestOptsMonoid -> Maybe [String] -> TestOpts +testOptsFromMonoid TestOptsMonoid{..} madditional = defaultTestOpts { toRerunTests = fromFirst (toRerunTests defaultTestOpts) toMonoidRerunTests - , toAdditionalArgs = toMonoidAdditionalArgs + , toAdditionalArgs = fromMaybe [] madditional <> toMonoidAdditionalArgs , toCoverage = fromFirst (toCoverage defaultTestOpts) toMonoidCoverage , toDisableRun = fromFirst (toDisableRun defaultTestOpts) toMonoidDisableRun } -benchmarkOptsFromMonoid :: BenchmarkOptsMonoid -> BenchmarkOpts -benchmarkOptsFromMonoid BenchmarkOptsMonoid{..} = +benchmarkOptsFromMonoid :: BenchmarkOptsMonoid -> Maybe [String] -> BenchmarkOpts +benchmarkOptsFromMonoid BenchmarkOptsMonoid{..} madditional = defaultBenchmarkOpts - { beoAdditionalArgs = getFirst beoMonoidAdditionalArgs + { beoAdditionalArgs = + (fmap (\args -> unwords args <> " ") madditional) <> + getFirst beoMonoidAdditionalArgs , beoDisableRun = fromFirst (beoDisableRun defaultBenchmarkOpts) beoMonoidDisableRun diff --git a/src/Stack/Options/BuildMonoidParser.hs b/src/Stack/Options/BuildMonoidParser.hs index 67abc86379..13b5900c4f 100644 --- a/src/Stack/Options/BuildMonoidParser.hs +++ b/src/Stack/Options/BuildMonoidParser.hs @@ -1,6 +1,5 @@ module Stack.Options.BuildMonoidParser where -import Data.Maybe (catMaybes) import Data.Monoid.Extra import Options.Applicative import Options.Applicative.Builder.Extra @@ -13,94 +12,46 @@ import Stack.Types.Config.Build buildOptsMonoidParser :: GlobalOptsContext -> Parser BuildOptsMonoid buildOptsMonoidParser hide0 = - transform <$> trace <*> profile <*> noStrip <*> options + BuildOptsMonoid <$> trace <*> profile <*> noStrip <*> + libProfiling <*> exeProfiling <*> libStripping <*> + exeStripping <*> haddock <*> haddockOptsParser hideBool <*> + openHaddocks <*> haddockDeps <*> haddockInternal <*> copyBins <*> + preFetch <*> keepGoing <*> forceDirty <*> tests <*> + testOptsParser hideBool <*> benches <*> benchOptsParser hideBool <*> + reconfigure <*> cabalVerbose <*> splitObjs where hideBool = hide0 /= BuildCmdGlobalOpts hide = hideMods hideBool hideExceptGhci = hideMods (hide0 `notElem` [BuildCmdGlobalOpts, GhciCmdGlobalOpts]) - transform tracing profiling noStripping = - enable - where - enable opts - | tracing || profiling = - opts - { buildMonoidLibProfile = First (Just True) - , buildMonoidExeProfile = First (Just True) - , buildMonoidBenchmarkOpts = bopts - { beoMonoidAdditionalArgs = First (Just (" " <> unwords additionalArgs) <> - getFirst (beoMonoidAdditionalArgs bopts)) - } - , buildMonoidTestOpts = topts - { toMonoidAdditionalArgs = additionalArgs <> toMonoidAdditionalArgs topts - } - } - | noStripping = - opts - { buildMonoidLibStrip = First (Just False) - , buildMonoidExeStrip = First (Just False) - } - | otherwise = - opts - where - bopts = - buildMonoidBenchmarkOpts opts - topts = - buildMonoidTestOpts opts - additionalArgs = - "+RTS" : catMaybes [trac, prof, Just "-RTS"] - trac = - if tracing - then Just "-xc" - else Nothing - prof = - if profiling - then Just "-p" - else Nothing - profile = - flag - False - True - (long "profile" <> - help - "Enable profiling in libraries, executables, etc. \ - \for all expressions and generate a profiling report\ - \ in tests or benchmarks" <> - hideExceptGhci) trace = + firstBoolFlags + "trace" + "Enable profiling in libraries, executables, etc. \ + \for all expressions and generate a backtrace on \ + \exception" + hideExceptGhci + profile = + firstBoolFlags + "profile" + "profiling in libraries, executables, etc. \ + \for all expressions and generate a profiling report\ + \ in tests or benchmarks" + hideExceptGhci + noStrip = fmap Any $ flag - False - True - (long "trace" <> - help - "Enable profiling in libraries, executables, etc. \ - \for all expressions and generate a backtrace on \ - \exception" <> - hideExceptGhci) - - noStrip = - flag - False - True - (long "no-strip" <> - help - "Disable DWARF debugging symbol stripping in libraries, \ - \executables, etc. for all expressions, producing \ - \larger executables but allowing the use of standard \ - \debuggers/profiling tools/other utilities that use \ - \debugging symbols." <> + False + True + (long "no-strip" <> + help + "Disable DWARF debugging symbol stripping in libraries, \ + \executables, etc. for all expressions, producing \ + \larger executables but allowing the use of standard \ + \debuggers/profiling tools/other utilities that use \ + \debugging symbols." <> hideExceptGhci) - - options = - BuildOptsMonoid <$> libProfiling <*> exeProfiling <*> libStripping <*> - exeStripping <*> haddock <*> haddockOptsParser hideBool <*> - openHaddocks <*> haddockDeps <*> haddockInternal <*> copyBins <*> - preFetch <*> keepGoing <*> forceDirty <*> tests <*> - testOptsParser hideBool <*> benches <*> benchOptsParser hideBool <*> - reconfigure <*> cabalVerbose <*> splitObjs - libProfiling = firstBoolFlags "library-profiling" diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs index 9c80cc6d4c..079614ab6f 100644 --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -149,7 +149,10 @@ data BuildCommand -- | Build options that may be specified in the stack.yaml or from the CLI data BuildOptsMonoid = BuildOptsMonoid - { buildMonoidLibProfile :: !(First Bool) + { buildMonoidTrace :: !(First Bool) + , buildMonoidProfile :: !(First Bool) + , buildMonoidNoStrip :: !Any + , buildMonoidLibProfile :: !(First Bool) , buildMonoidExeProfile :: !(First Bool) , buildMonoidLibStrip :: !(First Bool) , buildMonoidExeStrip :: !(First Bool) @@ -173,7 +176,10 @@ data BuildOptsMonoid = BuildOptsMonoid instance FromJSON (WithJSONWarnings BuildOptsMonoid) where parseJSON = withObjectWarnings "BuildOptsMonoid" - (\o -> do buildMonoidLibProfile <- First <$> o ..:? buildMonoidLibProfileArgName + (\o -> do let buildMonoidTrace = First Nothing + buildMonoidProfile = First Nothing + buildMonoidNoStrip = Any False + buildMonoidLibProfile <- First <$> o ..:? buildMonoidLibProfileArgName buildMonoidExeProfile <-First <$> o ..:? buildMonoidExeProfileArgName buildMonoidLibStrip <- First <$> o ..:? buildMonoidLibStripArgName buildMonoidExeStrip <-First <$> o ..:? buildMonoidExeStripArgName