From 59d6e87c005902ada03e7a0bdadc06ba05680bba Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 8 Sep 2018 22:00:04 +0300 Subject: [PATCH] ApplyCLIFlag This replaces a case of "Maybe blindness" (like boolean blindness), using descriptive data constructors to indicate what the Nothing and Just cases mean. --- src/Stack/Build/Source.hs | 6 +++--- src/Stack/Build/Target.hs | 6 ++---- src/Stack/Dot.hs | 2 +- src/Stack/Ghci.hs | 2 +- src/Stack/Options/BuildParser.hs | 2 +- src/Stack/Options/PackageParser.hs | 7 ++++--- src/Stack/Types/Config/Build.hs | 23 ++++++++++++++++++++++- 7 files changed, 34 insertions(+), 14 deletions(-) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index be6eb9c9e0..ef540c4dec 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -116,8 +116,8 @@ getLocalFlags -> PackageName -> Map FlagName Bool getLocalFlags bconfig boptsCli name = Map.unions - [ Map.findWithDefault Map.empty (Just name) cliFlags - , Map.findWithDefault Map.empty Nothing cliFlags + [ Map.findWithDefault Map.empty (ACFByName name) cliFlags + , Map.findWithDefault Map.empty ACFAllProjectPackages cliFlags , Map.findWithDefault Map.empty name (bcFlags bconfig) ] where @@ -325,7 +325,7 @@ checkFlagsUsed boptsCli lps extraDeps snapshot = do -- Check if flags specified in stack.yaml and the command line are -- used, see https://github.com/commercialhaskell/stack/issues/617 - let flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsCLIFlags boptsCli] + let flags = map (, FSCommandLine) [(k, v) | (ACFByName k, v) <- Map.toList $ boptsCLIFlags boptsCli] ++ map (, FSStackYaml) (Map.toList $ bcFlags bconfig) localNameMap = Map.fromList $ map (packageName . lpPackage &&& lpPackage) lps diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index c09ff3cf5f..f13713a3b6 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -487,10 +487,8 @@ parseTargets needTargets boptscli = do | otherwise -> throwIO $ TargetParseException ["The specified targets matched no packages"] - let dropMaybeKey (Nothing, _) = Map.empty - dropMaybeKey (Just key, value) = Map.singleton key value - flags = Map.unionWith Map.union - (Map.unions (map dropMaybeKey (Map.toList (boptsCLIFlags boptscli)))) + let flags = Map.unionWith Map.union + (boptsCLIFlagsByName boptscli) (bcFlags bconfig) hides = Map.empty -- not supported to add hidden packages diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index b19c5b0710..2e39d76534 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -50,7 +50,7 @@ data DotOpts = DotOpts -- ^ Package names to prune from the graph , dotTargets :: [Text] -- ^ stack TARGETs to trace dependencies for - , dotFlags :: !(Map (Maybe PackageName) (Map FlagName Bool)) + , dotFlags :: !(Map ApplyCLIFlag (Map FlagName Bool)) -- ^ Flags to apply when calculating dependencies , dotTestTargets :: Bool -- ^ Like the "--test" flag for build, affects the meaning of 'dotTargets'. diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 2f948cef86..70a18c4bf9 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -55,7 +55,7 @@ data GhciOpts = GhciOpts { ghciTargets :: ![Text] , ghciArgs :: ![String] , ghciGhcOptions :: ![Text] - , ghciFlags :: !(Map (Maybe PackageName) (Map FlagName Bool)) + , ghciFlags :: !(Map ApplyCLIFlag (Map FlagName Bool)) , ghciGhcCommand :: !(Maybe FilePath) , ghciNoLoadModules :: !Bool , ghciAdditionalPackages :: ![String] diff --git a/src/Stack/Options/BuildParser.hs b/src/Stack/Options/BuildParser.hs index 9a0529fdcb..087f773cd5 100644 --- a/src/Stack/Options/BuildParser.hs +++ b/src/Stack/Options/BuildParser.hs @@ -92,7 +92,7 @@ targetsParser = versionString stackMinorVersion <> "/build_command/#target-syntax for details."))) -flagsParser :: Parser (Map.Map (Maybe PackageName) (Map.Map FlagName Bool)) +flagsParser :: Parser (Map.Map ApplyCLIFlag (Map.Map FlagName Bool)) flagsParser = Map.unionsWith Map.union <$> many diff --git a/src/Stack/Options/PackageParser.hs b/src/Stack/Options/PackageParser.hs index e515c9da67..2ec1121c9e 100644 --- a/src/Stack/Options/PackageParser.hs +++ b/src/Stack/Options/PackageParser.hs @@ -5,9 +5,10 @@ import qualified Data.Map as Map import Options.Applicative import Options.Applicative.Types (readerAsk) import Stack.Prelude +import Stack.Types.Config.Build (ApplyCLIFlag (..)) -- | Parser for package:[-]flag -readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool)) +readFlag :: ReadM (Map ApplyCLIFlag (Map FlagName Bool)) readFlag = do s <- readerAsk case break (== ':') s of @@ -15,9 +16,9 @@ readFlag = do pn' <- case parsePackageName pn of Nothing - | pn == "*" -> return Nothing + | pn == "*" -> return ACFAllProjectPackages | otherwise -> readerError $ "Invalid package name: " ++ pn - Just x -> return $ Just x + Just x -> return $ ACFByName x let (b, flagS) = case mflag of '-':x -> (False, x) diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs index 56b75210b6..1b920764e8 100644 --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -25,6 +25,8 @@ module Stack.Types.Config.Build , BenchmarkOptsMonoid(..) , FileWatchOpts(..) , BuildSubset(..) + , ApplyCLIFlag (..) + , boptsCLIFlagsByName ) where @@ -137,12 +139,31 @@ defaultBuildOptsCLI = BuildOptsCLI , boptsCLIInitialBuildSteps = False } +-- | How to apply a CLI flag +data ApplyCLIFlag + = ACFAllProjectPackages + -- ^ Apply to all project packages which have such a flag name available. + | ACFByName !PackageName + -- ^ Apply to the specified package only. + deriving (Show, Eq, Ord) + +-- | Only flags set via 'ACFByName' +boptsCLIFlagsByName :: BuildOptsCLI -> Map PackageName (Map FlagName Bool) +boptsCLIFlagsByName = + Map.fromList . + mapMaybe go . + Map.toList . + boptsCLIFlags + where + go (ACFAllProjectPackages, _) = Nothing + go (ACFByName name, flags) = Just (name, flags) + -- | Build options that may only be specified from the CLI data BuildOptsCLI = BuildOptsCLI { boptsCLITargets :: ![Text] , boptsCLIDryrun :: !Bool , boptsCLIGhcOptions :: ![Text] - , boptsCLIFlags :: !(Map (Maybe PackageName) (Map FlagName Bool)) + , boptsCLIFlags :: !(Map ApplyCLIFlag (Map FlagName Bool)) , boptsCLIBuildSubset :: !BuildSubset , boptsCLIFileWatch :: !FileWatchOpts , boptsCLIExec :: ![(String, [String])]