From 47759559222cc501b5e2bbd0080963cc3229f489 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Wed, 4 May 2016 03:16:21 +0200 Subject: [PATCH 1/4] Use monoidal newtype wrappers and derived Monoid instances for config monoids --- src/Data/Monoid/Extra.hs | 12 ++ src/Options/Applicative/Builder/Extra.hs | 15 +- src/Stack/Config.hs | 58 +++--- src/Stack/Config/Build.hs | 40 ++-- src/Stack/Config/Docker.hs | 30 +-- src/Stack/Config/Nix.hs | 15 +- src/Stack/Config/Urls.hs | 8 +- src/Stack/Options.hs | 244 +++++++++++----------- src/Stack/Setup.hs | 4 +- src/Stack/Types/Config.hs | 246 ++++++++--------------- src/Stack/Types/Config/Build.hs | 153 +++++--------- src/Stack/Types/Docker.hs | 110 ++++------ src/Stack/Types/Image.hs | 13 +- src/Stack/Types/Internal.hs | 17 +- src/Stack/Types/Nix.hs | 53 ++--- src/Stack/Types/Urls.hs | 22 +- src/Stack/Types/Version.hs | 11 + src/Stack/Upgrade.hs | 4 +- stack.cabal | 2 + 19 files changed, 477 insertions(+), 580 deletions(-) create mode 100644 src/Data/Monoid/Extra.hs diff --git a/src/Data/Monoid/Extra.hs b/src/Data/Monoid/Extra.hs new file mode 100644 index 0000000000..2bd2de7ea7 --- /dev/null +++ b/src/Data/Monoid/Extra.hs @@ -0,0 +1,12 @@ +-- | Extra Monoid utilities. + +module Data.Monoid.Extra + ( fromFirst + , module Data.Monoid + ) where + +import Data.Maybe +import Data.Monoid + +fromFirst :: a -> First a -> a +fromFirst x = fromMaybe x . getFirst diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs index 70f2a4c07a..8201c05290 100644 --- a/src/Options/Applicative/Builder/Extra.hs +++ b/src/Options/Applicative/Builder/Extra.hs @@ -4,15 +4,18 @@ module Options.Applicative.Builder.Extra (boolFlags ,boolFlagsNoDefault ,maybeBoolFlags + ,firstBoolFlags ,enableDisableFlags ,enableDisableFlagsNoDefault ,extraHelpOption ,execExtraHelp ,textOption - ,textArgument) - where + ,textArgument + ,optionalFirst + ) where import Control.Monad (when) +import Data.Monoid import Options.Applicative import Options.Applicative.Types (readerAsk) import System.Environment (withArgs) @@ -42,6 +45,10 @@ maybeBoolFlags :: String -- ^ Flag name -> Parser (Maybe Bool) maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False) +-- | Like 'maybeBoolFlags', but parsing a 'First'. +firstBoolFlags :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (First Bool) +firstBoolFlags long0 help0 mod0 = First <$> maybeBoolFlags long0 help0 mod0 + -- | Enable/disable flags for any type. enableDisableFlags :: (Eq a) => a -- ^ Default value @@ -127,3 +134,7 @@ textOption = option (T.pack <$> readerAsk) -- | 'argument', specialized to 'Text'. textArgument :: Mod ArgumentFields Text -> Parser Text textArgument = argument (T.pack <$> readerAsk) + +-- | Like 'optional', but returning a 'First'. +optionalFirst :: Alternative f => f a -> f (First a) +optionalFirst = fmap First . optional diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index eebadab5db..5868a35065 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -58,7 +58,7 @@ import qualified Data.IntMap as IntMap import Data.IORef (newIORef) import qualified Data.Map as Map import Data.Maybe -import Data.Monoid +import Data.Monoid.Extra import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) @@ -200,16 +200,16 @@ configFromConfigMonoid -> ConfigMonoid -> m Config configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject configMonoid@ConfigMonoid{..} = do - configWorkDir <- parseRelDir (fromMaybe ".stack-work" configMonoidWorkDir) + configWorkDir <- parseRelDir (fromFirst ".stack-work" configMonoidWorkDir) -- This code is to handle the deprecation of latest-snapshot-url - configUrls <- case (configMonoidLatestSnapshotUrl, urlsMonoidLatestSnapshot configMonoidUrls) of + configUrls <- case (getFirst configMonoidLatestSnapshotUrl, getFirst (urlsMonoidLatestSnapshot configMonoidUrls)) of (Just url, Nothing) -> do $logWarn "The latest-snapshot-url field is deprecated in favor of 'urls' configuration" return (urlsFromMonoid configMonoidUrls) { urlsLatestSnapshot = url } _ -> return (urlsFromMonoid configMonoidUrls) - let configConnectionCount = fromMaybe 8 configMonoidConnectionCount - configHideTHLoading = fromMaybe True configMonoidHideTHLoading - configPackageIndices = fromMaybe + let configConnectionCount = fromFirst 8 configMonoidConnectionCount + configHideTHLoading = fromFirst True configMonoidHideTHLoading + configPackageIndices = fromFirst [PackageIndex { indexName = IndexName "Hackage" , indexLocation = ILGitHttp @@ -221,12 +221,12 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject c }] configMonoidPackageIndices - configGHCVariant0 = configMonoidGHCVariant + configGHCVariant0 = getFirst configMonoidGHCVariant - configSystemGHC = fromMaybe (isNothing configGHCVariant0) configMonoidSystemGHC - configInstallGHC = fromMaybe False configMonoidInstallGHC - configSkipGHCCheck = fromMaybe False configMonoidSkipGHCCheck - configSkipMsys = fromMaybe False configMonoidSkipMsys + configSystemGHC = fromFirst (isNothing configGHCVariant0) configMonoidSystemGHC + configInstallGHC = fromFirst False configMonoidInstallGHC + configSkipGHCCheck = fromFirst False configMonoidSkipGHCCheck + configSkipMsys = fromFirst False configMonoidSkipMsys configExtraIncludeDirs = configMonoidExtraIncludeDirs configExtraLibDirs = configMonoidExtraLibDirs @@ -235,18 +235,18 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject c -- in the future, allow it to be configured. (Platform defArch defOS) = buildPlatform arch = fromMaybe defArch - $ configMonoidArch >>= Distribution.Text.simpleParse + $ (getFirst configMonoidArch) >>= Distribution.Text.simpleParse os = fromMaybe defOS - $ configMonoidOS >>= Distribution.Text.simpleParse + $ (getFirst configMonoidOS) >>= Distribution.Text.simpleParse configPlatform = Platform arch os - configRequireStackVersion = simplifyVersionRange configMonoidRequireStackVersion + configRequireStackVersion = simplifyVersionRange (getIntersectingVersionRange configMonoidRequireStackVersion) configConfigMonoid = configMonoid configImage = Image.imgOptsFromMonoid configMonoidImageOpts - configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck + configCompilerCheck = fromFirst MatchMinor configMonoidCompilerCheck configPlatformVariant <- liftIO $ maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar @@ -274,7 +274,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject c let configLocalPrograms = configLocalProgramsBase platformOnlyDir configLocalBin <- - case configMonoidLocalBinPath of + case getFirst configMonoidLocalBinPath of Nothing -> do localDir <- getAppUserDataDir "local" return $ localDir $(mkRelDir "bin") @@ -291,25 +291,25 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject c const (throwM (NoSuchDirectory userPath)) configJobs <- - case configMonoidJobs of + case getFirst configMonoidJobs of Nothing -> liftIO getNumProcessors Just i -> return i - let configConcurrentTests = fromMaybe True configMonoidConcurrentTests + let configConcurrentTests = fromFirst True configMonoidConcurrentTests let configTemplateParams = configMonoidTemplateParameters - configScmInit = configMonoidScmInit - configGhcOptions = configMonoidGhcOptions + configScmInit = getFirst configMonoidScmInit + configGhcOptions = getCliOptionMap configMonoidGhcOptions configSetupInfoLocations = configMonoidSetupInfoLocations - configPvpBounds = fromMaybe PvpBoundsNone configMonoidPvpBounds - configModifyCodePage = fromMaybe True configMonoidModifyCodePage + configPvpBounds = fromFirst PvpBoundsNone configMonoidPvpBounds + configModifyCodePage = fromFirst True configMonoidModifyCodePage configExplicitSetupDeps = configMonoidExplicitSetupDeps - configRebuildGhcOptions = fromMaybe False configMonoidRebuildGhcOptions - configApplyGhcOptions = fromMaybe AGOLocals configMonoidApplyGhcOptions - configAllowNewer = fromMaybe False configMonoidAllowNewer - configDefaultTemplate = configMonoidDefaultTemplate + configRebuildGhcOptions = fromFirst False configMonoidRebuildGhcOptions + configApplyGhcOptions = fromFirst AGOLocals configMonoidApplyGhcOptions + configAllowNewer = fromFirst False configMonoidAllowNewer + configDefaultTemplate = getFirst configMonoidDefaultTemplate configAllowDifferentUser <- - case configMonoidAllowDifferentUser of + case getFirst configMonoidAllowDifferentUser of Just True -> return True _ -> getInContainer @@ -404,7 +404,7 @@ loadConfig configArgs mstackYaml mresolver = do -- non-project config files' existence of a docker section should never default docker -- to enabled, so make it look like they didn't exist map (\c -> c {configMonoidDockerOpts = - (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = False}}) + (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = Any False}}) extraConfigs0 mproject <- loadProjectConfig mstackYaml @@ -654,7 +654,7 @@ determineStackRootAndOwnership -> m (Path Abs Dir, Bool) determineStackRootAndOwnership clArgs = do stackRoot <- do - case configMonoidStackRoot clArgs of + case getFirst (configMonoidStackRoot clArgs) of Just x -> return x Nothing -> do mstackRoot <- liftIO $ lookupEnv stackRootEnvVar diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs index 83b4d4cc2b..6c862c93af 100644 --- a/src/Stack/Config/Build.hs +++ b/src/Stack/Config/Build.hs @@ -3,48 +3,48 @@ -- | Build configuration module Stack.Config.Build where -import Data.Maybe (fromMaybe) +import Data.Monoid.Extra import Stack.Types -- | Interprets BuildOptsMonoid options. buildOptsFromMonoid :: BuildOptsMonoid -> BuildOpts buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts - { boptsLibProfile = fromMaybe + { boptsLibProfile = fromFirst (boptsLibProfile defaultBuildOpts) buildMonoidLibProfile - , boptsExeProfile = fromMaybe + , boptsExeProfile = fromFirst (boptsExeProfile defaultBuildOpts) buildMonoidExeProfile - , boptsHaddock = fromMaybe + , boptsHaddock = fromFirst (boptsHaddock defaultBuildOpts) buildMonoidHaddock - , boptsOpenHaddocks = fromMaybe + , boptsOpenHaddocks = fromFirst (boptsOpenHaddocks defaultBuildOpts) buildMonoidOpenHaddocks - , boptsHaddockDeps = buildMonoidHaddockDeps - , boptsInstallExes = fromMaybe + , boptsHaddockDeps = getFirst buildMonoidHaddockDeps + , boptsInstallExes = fromFirst (boptsInstallExes defaultBuildOpts) buildMonoidInstallExes - , boptsPreFetch = fromMaybe + , boptsPreFetch = fromFirst (boptsPreFetch defaultBuildOpts) buildMonoidPreFetch - , boptsKeepGoing = buildMonoidKeepGoing - , boptsForceDirty = fromMaybe + , boptsKeepGoing = getFirst buildMonoidKeepGoing + , boptsForceDirty = fromFirst (boptsForceDirty defaultBuildOpts) buildMonoidForceDirty - , boptsTests = fromMaybe (boptsTests defaultBuildOpts) buildMonoidTests + , boptsTests = fromFirst (boptsTests defaultBuildOpts) buildMonoidTests , boptsTestOpts = testOptsFromMonoid buildMonoidTestOpts - , boptsBenchmarks = fromMaybe + , boptsBenchmarks = fromFirst (boptsBenchmarks defaultBuildOpts) buildMonoidBenchmarks , boptsBenchmarkOpts = benchmarkOptsFromMonoid buildMonoidBenchmarkOpts - , boptsReconfigure = fromMaybe + , boptsReconfigure = fromFirst (boptsReconfigure defaultBuildOpts) buildMonoidReconfigure - , boptsCabalVerbose = fromMaybe + , boptsCabalVerbose = fromFirst (boptsCabalVerbose defaultBuildOpts) buildMonoidCabalVerbose - , boptsSplitObjs = fromMaybe + , boptsSplitObjs = fromFirst (boptsSplitObjs defaultBuildOpts) buildMonoidSplitObjs } @@ -52,17 +52,17 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts testOptsFromMonoid :: TestOptsMonoid -> TestOpts testOptsFromMonoid TestOptsMonoid{..} = defaultTestOpts - { toRerunTests = fromMaybe (toRerunTests defaultTestOpts) toMonoidRerunTests + { toRerunTests = fromFirst (toRerunTests defaultTestOpts) toMonoidRerunTests , toAdditionalArgs = toMonoidAdditionalArgs - , toCoverage = fromMaybe (toCoverage defaultTestOpts) toMonoidCoverage - , toDisableRun = fromMaybe (toDisableRun defaultTestOpts) toMonoidDisableRun + , toCoverage = fromFirst (toCoverage defaultTestOpts) toMonoidCoverage + , toDisableRun = fromFirst (toDisableRun defaultTestOpts) toMonoidDisableRun } benchmarkOptsFromMonoid :: BenchmarkOptsMonoid -> BenchmarkOpts benchmarkOptsFromMonoid BenchmarkOptsMonoid{..} = defaultBenchmarkOpts - { beoAdditionalArgs = beoMonoidAdditionalArgs - , beoDisableRun = fromMaybe + { beoAdditionalArgs = getFirst beoMonoidAdditionalArgs + , beoDisableRun = fromFirst (beoDisableRun defaultBenchmarkOpts) beoMonoidDisableRun } diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs index 4c29f419d8..db902f82f2 100644 --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -8,6 +8,7 @@ import Control.Monad import Control.Monad.Catch (throwM, MonadThrow) import Data.List (find) import Data.Maybe +import Data.Monoid.Extra import qualified Data.Text as T import Data.Typeable (Typeable) import Distribution.Version (simplifyVersionRange) @@ -24,7 +25,7 @@ dockerOptsFromMonoid -> m DockerOpts dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do let dockerEnable = - fromMaybe dockerMonoidDefaultEnable dockerMonoidEnable + fromFirst (getAny dockerMonoidDefaultEnable) dockerMonoidEnable dockerImage = let mresolver = case maresolver of @@ -47,7 +48,7 @@ dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do throw (ResolverNotSupportedException $ show resolver) - in case dockerMonoidRepoOrImage of + in case getFirst dockerMonoidRepoOrImage of Nothing -> "fpco/stack-build" ++ defaultTag Just (DockerMonoidImage image) -> image Just (DockerMonoidRepo repo) -> @@ -57,29 +58,30 @@ dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do repo Nothing -> repo ++ defaultTag dockerRegistryLogin = - fromMaybe - (isJust (emptyToNothing dockerMonoidRegistryUsername)) + fromFirst + (isJust (emptyToNothing (getFirst dockerMonoidRegistryUsername))) dockerMonoidRegistryLogin - dockerRegistryUsername = emptyToNothing dockerMonoidRegistryUsername - dockerRegistryPassword = emptyToNothing dockerMonoidRegistryPassword - dockerAutoPull = fromMaybe False dockerMonoidAutoPull - dockerDetach = fromMaybe False dockerMonoidDetach - dockerPersist = fromMaybe False dockerMonoidPersist - dockerContainerName = emptyToNothing dockerMonoidContainerName + dockerRegistryUsername = emptyToNothing (getFirst dockerMonoidRegistryUsername) + dockerRegistryPassword = emptyToNothing (getFirst dockerMonoidRegistryPassword) + dockerAutoPull = fromFirst False dockerMonoidAutoPull + dockerDetach = fromFirst False dockerMonoidDetach + dockerPersist = fromFirst False dockerMonoidPersist + dockerContainerName = emptyToNothing (getFirst dockerMonoidContainerName) dockerRunArgs = dockerMonoidRunArgs dockerMount = dockerMonoidMount dockerEnv = dockerMonoidEnv - dockerSetUser = dockerMonoidSetUser - dockerRequireDockerVersion = simplifyVersionRange dockerMonoidRequireDockerVersion + dockerSetUser = getFirst dockerMonoidSetUser + dockerRequireDockerVersion = + simplifyVersionRange (getIntersectingVersionRange dockerMonoidRequireDockerVersion) dockerDatabasePath <- - case dockerMonoidDatabasePath of + case getFirst dockerMonoidDatabasePath of Nothing -> return $ stackRoot $(mkRelFile "docker.db") Just fp -> case parseAbsFile fp of Left e -> throwM (InvalidDatabasePathException e) Right p -> return p dockerStackExe <- - case dockerMonoidStackExe of + case getFirst dockerMonoidStackExe of Just e -> liftM Just (parseDockerStackExe e) Nothing -> return Nothing return DockerOpts{..} diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index 0018ef00e5..ed302ca948 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -9,8 +9,9 @@ module Stack.Config.Nix import Control.Applicative import Control.Monad (join, when) -import qualified Data.Text as T import Data.Maybe +import Data.Monoid.Extra +import qualified Data.Text as T import Data.Typeable import Distribution.System (OS (..)) import Stack.Types @@ -25,15 +26,15 @@ nixOptsFromMonoid -> OS -> m NixOpts nixOptsFromMonoid NixOptsMonoid{..} os = do - let nixEnable = fromMaybe nixMonoidDefaultEnable nixMonoidEnable + let nixEnable = fromFirst (getAny nixMonoidDefaultEnable) nixMonoidEnable defaultPure = case os of OSX -> False _ -> True - nixPureShell = fromMaybe defaultPure nixMonoidPureShell - nixPackages = fromMaybe [] nixMonoidPackages - nixInitFile = nixMonoidInitFile - nixShellOptions = fromMaybe [] nixMonoidShellOptions - ++ prefixAll (T.pack "-I") (fromMaybe [] nixMonoidPath) + nixPureShell = fromFirst defaultPure nixMonoidPureShell + nixPackages = fromFirst [] nixMonoidPackages + nixInitFile = getFirst nixMonoidInitFile + nixShellOptions = fromFirst [] nixMonoidShellOptions + ++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath) when (not (null nixPackages) && isJust nixInitFile) $ throwM NixCannotUseShellFileAndPackagesException return NixOpts{..} diff --git a/src/Stack/Config/Urls.hs b/src/Stack/Config/Urls.hs index 81ee90d023..a66edc64df 100644 --- a/src/Stack/Config/Urls.hs +++ b/src/Stack/Config/Urls.hs @@ -3,14 +3,14 @@ module Stack.Config.Urls (urlsFromMonoid) where import Stack.Types -import Data.Maybe +import Data.Monoid.Extra urlsFromMonoid :: UrlsMonoid -> Urls urlsFromMonoid monoid = Urls - (fromMaybe defaultLatestSnapshot $ urlsMonoidLatestSnapshot monoid) - (fromMaybe defaultLtsBuildPlans $ urlsMonoidLtsBuildPlans monoid) - (fromMaybe defaultNightlyBuildPlans $ urlsMonoidNightlyBuildPlans monoid) + (fromFirst defaultLatestSnapshot $ urlsMonoidLatestSnapshot monoid) + (fromFirst defaultLtsBuildPlans $ urlsMonoidLtsBuildPlans monoid) + (fromFirst defaultNightlyBuildPlans $ urlsMonoidNightlyBuildPlans monoid) where defaultLatestSnapshot = "https://www.stackage.org/download/snapshots.json" diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 3c3e814c7d..1dd6e4e41f 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -36,7 +36,7 @@ import qualified Data.Map as Map import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe -import Data.Monoid +import Data.Monoid.Extra import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Read (decimal) @@ -77,12 +77,12 @@ data GlobalOptsContext -- FIXME hiding options benchOptsParser :: Bool -> Parser BenchmarkOptsMonoid benchOptsParser hide0 = BenchmarkOptsMonoid - <$> optional (strOption (long "benchmark-arguments" <> + <$> optionalFirst (strOption (long "benchmark-arguments" <> metavar "BENCH_ARGS" <> help ("Forward BENCH_ARGS to the benchmark suite. " <> "Supports templates from `cabal bench`") <> hide)) - <*> optional (switch (long "no-run-benchmarks" <> + <*> optionalFirst (switch (long "no-run-benchmarks" <> help "Disable running of benchmarks. (Benchmarks will still be built.)" <> hide)) where hide = hideMods hide0 @@ -222,14 +222,14 @@ configOptsParser hide0 = , configMonoidModifyCodePage = modifyCodePage , configMonoidAllowDifferentUser = allowDifferentUser }) - <$> optional (option readAbsDir + <$> optionalFirst (option readAbsDir ( long stackRootOptionName <> metavar (map toUpper stackRootOptionName) <> help ("Absolute path to the global stack root directory " ++ "(Overrides any STACK_ROOT environment variable)") <> hide )) - <*> optional (strOption + <*> optionalFirst (strOption ( long "work-dir" <> metavar "WORK-DIR" <> help "Override work directory (default: .stack-work)" @@ -238,28 +238,28 @@ configOptsParser hide0 = <*> buildOptsMonoidParser (hide0 /= BuildCmdGlobalOpts) <*> dockerOptsParser True <*> nixOptsParser True - <*> maybeBoolFlags + <*> firstBoolFlags "system-ghc" "using the system installed GHC (on the PATH) if available and a matching version" hide - <*> maybeBoolFlags + <*> firstBoolFlags "install-ghc" "downloading and installing GHC if necessary (can be done manually with stack setup)" hide - <*> optional (strOption + <*> optionalFirst (strOption ( long "arch" <> metavar "ARCH" <> help "System architecture, e.g. i386, x86_64" <> hide )) - <*> optional (strOption + <*> optionalFirst (strOption ( long "os" <> metavar "OS" <> help "Operating system, e.g. linux, windows" <> hide )) - <*> optional (ghcVariantParser (hide0 /= OuterGlobalOpts)) - <*> optional (option auto + <*> optionalFirst (ghcVariantParser (hide0 /= OuterGlobalOpts)) + <*> optionalFirst (option auto ( long "jobs" <> short 'j' <> metavar "JOBS" @@ -278,25 +278,25 @@ configOptsParser hide0 = <> help "Extra directories to check for libraries" <> hide ))) - <*> maybeBoolFlags + <*> firstBoolFlags "skip-ghc-check" "skipping the GHC version and architecture check" hide - <*> maybeBoolFlags + <*> firstBoolFlags "skip-msys" "skipping the local MSYS installation (Windows only)" hide - <*> optional (strOption + <*> optionalFirst (strOption ( long "local-bin-path" <> metavar "DIR" <> help "Install binaries to DIR" <> hide )) - <*> maybeBoolFlags + <*> firstBoolFlags "modify-code-page" "setting the codepage to support UTF-8 (Windows only)" hide - <*> maybeBoolFlags + <*> firstBoolFlags "allow-different-user" ("permission for users other than the owner of the stack root " ++ "directory to use a stack installation (POSIX only)") @@ -324,11 +324,11 @@ buildOptsMonoidParser hide0 = enable opts | tracing || profiling = opts - { buildMonoidLibProfile = Just True - , buildMonoidExeProfile = Just True + { buildMonoidLibProfile = First (Just True) + , buildMonoidExeProfile = First (Just True) , buildMonoidBenchmarkOpts = bopts - { beoMonoidAdditionalArgs = beoMonoidAdditionalArgs bopts <> - Just (" " <> unwords additionalArgs) + { beoMonoidAdditionalArgs = First (getFirst (beoMonoidAdditionalArgs bopts) <> + Just (" " <> unwords additionalArgs)) } , buildMonoidTestOpts = topts { toMonoidAdditionalArgs = (toMonoidAdditionalArgs topts) <> @@ -379,69 +379,69 @@ buildOptsMonoidParser hide0 = tests <*> testOptsParser hide0 <*> benches <*> benchOptsParser hide0 <*> reconfigure <*> cabalVerbose <*> splitObjs libProfiling = - maybeBoolFlags + firstBoolFlags "library-profiling" "library profiling for TARGETs and all its dependencies" hide exeProfiling = - maybeBoolFlags + firstBoolFlags "executable-profiling" "executable profiling for TARGETs and all its dependencies" hide haddock = - maybeBoolFlags + firstBoolFlags "haddock" "generating Haddocks the package(s) in this directory/configuration" hide openHaddocks = - maybeBoolFlags + firstBoolFlags "open" "opening the local Haddock documentation in the browser" hide haddockDeps = - maybeBoolFlags "haddock-deps" "building Haddocks for dependencies" hide + firstBoolFlags "haddock-deps" "building Haddocks for dependencies" hide copyBins = - maybeBoolFlags + firstBoolFlags "copy-bins" "copying binaries to the local-bin-path (see 'stack path')" hide keepGoing = - maybeBoolFlags + firstBoolFlags "keep-going" "continue running after a step fails (default: false for build, true for test/bench)" hide preFetch = - maybeBoolFlags + firstBoolFlags "prefetch" "Fetch packages necessary for the build immediately, useful with --dry-run" hide forceDirty = - maybeBoolFlags + firstBoolFlags "force-dirty" "Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change" hide tests = - maybeBoolFlags + firstBoolFlags "test" "testing the package(s) in this directory/configuration" hide benches = - maybeBoolFlags + firstBoolFlags "bench" "benchmarking the package(s) in this directory/configuration" hide reconfigure = - maybeBoolFlags + firstBoolFlags "reconfigure" "Perform the configure step even if unnecessary. Useful in some corner cases with custom Setup.hs files" hide cabalVerbose = - maybeBoolFlags + firstBoolFlags "cabal-verbose" "Ask Cabal to be verbose in its output" hide splitObjs = - maybeBoolFlags + firstBoolFlags "split-objs" ("Enable split-objs, to reduce output size (at the cost of build time). " ++ splitObjsWarning) hide @@ -449,77 +449,85 @@ buildOptsMonoidParser hide0 = nixOptsParser :: Bool -> Parser NixOptsMonoid nixOptsParser hide0 = overrideActivation <$> (NixOptsMonoid - <$> pure False - <*> maybeBoolFlags nixCmdName + <$> pure (Any False) + <*> firstBoolFlags nixCmdName "use of a Nix-shell" hide - <*> maybeBoolFlags "nix-pure" + <*> firstBoolFlags "nix-pure" "use of a pure Nix-shell" hide - <*> (fmap (map T.pack) - <$> optional (argsOption (long "nix-packages" <> - metavar "NAMES" <> - help "List of packages that should be available in the nix-shell (space separated)" <> - hide))) - <*> optional (option str (long "nix-shell-file" <> - metavar "FILEPATH" <> - help "Nix file to be used to launch a nix-shell (for regular Nix users)" <> - hide)) - <*> (fmap (map T.pack) - <$> optional (argsOption (long "nix-shell-options" <> - metavar "OPTIONS" <> - help "Additional options passed to nix-shell" <> - hide))) - <*> (fmap (map T.pack) - <$> optional (argsOption (long "nix-path" <> - metavar "PATH_OPTIONS" <> - help "Additional options to override NIX_PATH parts (notably 'nixpkgs')" <> - hide))) + <*> optionalFirst + (textArgsOption + (long "nix-packages" <> + metavar "NAMES" <> + help "List of packages that should be available in the nix-shell (space separated)" <> + hide)) + <*> optionalFirst + (option + str + (long "nix-shell-file" <> + metavar "FILEPATH" <> + help "Nix file to be used to launch a nix-shell (for regular Nix users)" <> + hide)) + <*> optionalFirst + (textArgsOption + (long "nix-shell-options" <> + metavar "OPTIONS" <> + help "Additional options passed to nix-shell" <> + hide)) + <*> optionalFirst + (textArgsOption + (long "nix-path" <> + metavar "PATH_OPTIONS" <> + help "Additional options to override NIX_PATH parts (notably 'nixpkgs')" <> + hide)) ) where hide = hideMods hide0 overrideActivation m = - if m /= mempty then m { nixMonoidEnable = Just . fromMaybe True $ nixMonoidEnable m } + if m /= mempty then m { nixMonoidEnable = (First . Just . fromFirst True) (nixMonoidEnable m) } else m + textArgsOption = fmap (map T.pack) . argsOption -- | Options parser configuration for Docker. dockerOptsParser :: Bool -> Parser DockerOptsMonoid dockerOptsParser hide0 = DockerOptsMonoid - <$> pure False - <*> maybeBoolFlags dockerCmdName + <$> pure (Any False) + <*> firstBoolFlags dockerCmdName "using a Docker container" hide - <*> ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <> - hide <> - metavar "NAME" <> - help "Docker repository name") <|> - (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <> - hide <> - metavar "IMAGE" <> - help "Exact Docker image ID (overrides docker-repo)") <|> + <*> fmap First + ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <> + hide <> + metavar "NAME" <> + help "Docker repository name") <|> + (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <> + hide <> + metavar "IMAGE" <> + help "Exact Docker image ID (overrides docker-repo)") <|> pure Nothing) - <*> maybeBoolFlags (dockerOptName dockerRegistryLoginArgName) + <*> firstBoolFlags (dockerOptName dockerRegistryLoginArgName) "registry requires login" hide - <*> maybeStrOption (long (dockerOptName dockerRegistryUsernameArgName) <> + <*> firstStrOption (long (dockerOptName dockerRegistryUsernameArgName) <> hide <> metavar "USERNAME" <> help "Docker registry username") - <*> maybeStrOption (long (dockerOptName dockerRegistryPasswordArgName) <> + <*> firstStrOption (long (dockerOptName dockerRegistryPasswordArgName) <> hide <> metavar "PASSWORD" <> help "Docker registry password") - <*> maybeBoolFlags (dockerOptName dockerAutoPullArgName) + <*> firstBoolFlags (dockerOptName dockerAutoPullArgName) "automatic pulling latest version of image" hide - <*> maybeBoolFlags (dockerOptName dockerDetachArgName) + <*> firstBoolFlags (dockerOptName dockerDetachArgName) "running a detached Docker container" hide - <*> maybeBoolFlags (dockerOptName dockerPersistArgName) + <*> firstBoolFlags (dockerOptName dockerPersistArgName) "not deleting container after it exits" hide - <*> maybeStrOption (long (dockerOptName dockerContainerNameArgName) <> + <*> firstStrOption (long (dockerOptName dockerContainerNameArgName) <> hide <> metavar "NAME" <> help "Docker container name") @@ -538,11 +546,11 @@ dockerOptsParser hide0 = metavar "NAME=VALUE" <> help ("Set environment variable in container " ++ "(may specify multiple times)"))) - <*> maybeStrOption (long (dockerOptName dockerDatabasePathArgName) <> + <*> firstStrOption (long (dockerOptName dockerDatabasePathArgName) <> hide <> metavar "PATH" <> help "Location of image usage tracking database") - <*> maybeStrOption + <*> firstStrOption (long(dockerOptName dockerStackExeArgName) <> hide <> metavar (intercalate "|" @@ -553,13 +561,13 @@ dockerOptsParser hide0 = help (concat [ "Location of " , stackProgName , " executable used in container" ])) - <*> maybeBoolFlags (dockerOptName dockerSetUserArgName) + <*> firstBoolFlags (dockerOptName dockerSetUserArgName) "setting user in container to match host" hide - <*> pure anyVersion + <*> pure (IntersectingVersionRange anyVersion) where dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName - maybeStrOption = optional . option str + firstStrOption = optionalFirst . option str hide = hideMods hide0 -- | Parser for docker cleanup arguments. @@ -715,21 +723,23 @@ execOptsExtraParser = eoPlainParser <|> globalOptsParser :: GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid globalOptsParser kind defLogLevel = GlobalOptsMonoid <$> - optional (strOption (long Docker.reExecArgName <> hidden <> internal)) <*> - optional (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*> - logLevelOptsParser hide0 defLogLevel <*> + optionalFirst (strOption (long Docker.reExecArgName <> hidden <> internal)) <*> + optionalFirst (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*> + (First <$> logLevelOptsParser hide0 defLogLevel) <*> configOptsParser kind <*> - optional (abstractResolverOptsParser hide0) <*> - optional (compilerOptsParser hide0) <*> - maybeBoolFlags + optionalFirst (abstractResolverOptsParser hide0) <*> + optionalFirst (compilerOptsParser hide0) <*> + firstBoolFlags "terminal" "overriding terminal detection in the case of running in a false terminal" hide <*> - optional (strOption (long "stack-yaml" <> - metavar "STACK-YAML" <> - help ("Override project stack.yaml file " <> - "(overrides any STACK_YAML environment variable)") <> - hide)) + optionalFirst + (strOption + (long "stack-yaml" <> + metavar "STACK-YAML" <> + help ("Override project stack.yaml file " <> + "(overrides any STACK_YAML environment variable)") <> + hide)) where hide = hideMods hide0 hide0 = kind /= OuterGlobalOpts @@ -737,14 +747,14 @@ globalOptsParser kind defLogLevel = -- | Create GlobalOpts from GlobalOptsMonoid. globalOptsFromMonoid :: Bool -> GlobalOptsMonoid -> GlobalOpts globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts - { globalReExecVersion = globalMonoidReExecVersion - , globalDockerEntrypoint = globalMonoidDockerEntrypoint - , globalLogLevel = fromMaybe defaultLogLevel globalMonoidLogLevel + { globalReExecVersion = getFirst globalMonoidReExecVersion + , globalDockerEntrypoint = getFirst globalMonoidDockerEntrypoint + , globalLogLevel = fromFirst defaultLogLevel globalMonoidLogLevel , globalConfigMonoid = globalMonoidConfigMonoid - , globalResolver = globalMonoidResolver - , globalCompiler = globalMonoidCompiler - , globalTerminal = fromMaybe defaultTerminal globalMonoidTerminal - , globalStackYaml = globalMonoidStackYaml } + , globalResolver = getFirst globalMonoidResolver + , globalCompiler = getFirst globalMonoidCompiler + , globalTerminal = fromFirst defaultTerminal globalMonoidTerminal + , globalStackYaml = getFirst globalMonoidStackYaml } initOptsParser :: Parser InitOpts initOptsParser = @@ -864,22 +874,30 @@ solverOptsParser = boolFlags False -- | Parser for test arguments. -- FIXME hide args testOptsParser :: Bool -> Parser TestOptsMonoid -testOptsParser hide0 = TestOptsMonoid - <$> maybeBoolFlags - "rerun-tests" - "running already successful tests" - hide - <*> fmap (fromMaybe []) - (optional (argsOption(long "test-arguments" <> - metavar "TEST_ARGS" <> - help "Arguments passed in to the test suite program" - <> hide))) - <*> optional (switch (long "coverage" <> - help "Generate a code coverage report" - <> hide)) - <*> optional (switch (long "no-run-tests" <> - help "Disable running of tests. (Tests will still be built.)" - <> hide)) +testOptsParser hide0 = + TestOptsMonoid + <$> firstBoolFlags + "rerun-tests" + "running already successful tests" + hide + <*> fmap + (fromMaybe []) + (optional + (argsOption + (long "test-arguments" <> + metavar "TEST_ARGS" <> + help "Arguments passed in to the test suite program" <> + hide))) + <*> optionalFirst + (switch + (long "coverage" <> + help "Generate a code coverage report" <> + hide)) + <*> optionalFirst + (switch + (long "no-run-tests" <> + help "Disable running of tests. (Tests will still be built.)" <> + hide)) where hide = hideMods hide0 -- | Parser for @stack new@. diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 8378b4bd45..89f336f1cc 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -1012,8 +1012,8 @@ loadGhcjsEnvConfig :: (MonadIO m, HasHttpManager r, MonadReader r m, HasTerminal loadGhcjsEnvConfig stackYaml binPath = runInnerStackLoggingT $ do lc <- loadConfig (mempty - { configMonoidInstallGHC = Just True - , configMonoidLocalBinPath = Just (toFilePath binPath) + { configMonoidInstallGHC = First (Just True) + , configMonoidLocalBinPath = First (Just (toFilePath binPath)) }) (Just stackYaml) Nothing diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index e3e8aa1fb1..9436d99e68 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiWayIf #-} @@ -51,6 +52,7 @@ module Stack.Types.Config ,ConfigException(..) -- ** ConfigMonoid ,ConfigMonoid(..) + ,CliOptionMap(..) -- ** EnvSettings ,EnvSettings(..) ,minimalEnvSettings @@ -150,7 +152,7 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Map.Strict as M import Data.Maybe -import Data.Monoid +import Data.Monoid.Extra import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -161,6 +163,8 @@ import Data.Yaml (ParseException) import Distribution.System (Platform) import qualified Distribution.Text import Distribution.Version (anyVersion) +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Network.HTTP.Client (parseUrl) import Path import qualified Paths_stack as Meta @@ -423,29 +427,20 @@ data GlobalOpts = GlobalOpts -- | Parsed global command-line options monoid. data GlobalOptsMonoid = GlobalOptsMonoid - { globalMonoidReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version - , globalMonoidDockerEntrypoint :: !(Maybe DockerEntrypoint) + { globalMonoidReExecVersion :: !(First String) -- ^ Expected re-exec in container version + , globalMonoidDockerEntrypoint :: !(First DockerEntrypoint) -- ^ Data used when stack is acting as a Docker entrypoint (internal use only) - , globalMonoidLogLevel :: !(Maybe LogLevel) -- ^ Log level + , globalMonoidLogLevel :: !(First LogLevel) -- ^ Log level , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' - , globalMonoidResolver :: !(Maybe AbstractResolver) -- ^ Resolver override - , globalMonoidCompiler :: !(Maybe CompilerVersion) -- ^ Compiler override - , globalMonoidTerminal :: !(Maybe Bool) -- ^ We're in a terminal? - , globalMonoidStackYaml :: !(Maybe FilePath) -- ^ Override project stack.yaml - } deriving (Show) + , globalMonoidResolver :: !(First AbstractResolver) -- ^ Resolver override + , globalMonoidCompiler :: !(First CompilerVersion) -- ^ Compiler override + , globalMonoidTerminal :: !(First Bool) -- ^ We're in a terminal? + , globalMonoidStackYaml :: !(First FilePath) -- ^ Override project stack.yaml + } deriving (Show, Generic) instance Monoid GlobalOptsMonoid where - mempty = GlobalOptsMonoid Nothing Nothing Nothing mempty Nothing Nothing Nothing Nothing - mappend l r = GlobalOptsMonoid - { globalMonoidReExecVersion = globalMonoidReExecVersion l <|> globalMonoidReExecVersion r - , globalMonoidDockerEntrypoint = - globalMonoidDockerEntrypoint l <|> globalMonoidDockerEntrypoint r - , globalMonoidLogLevel = globalMonoidLogLevel l <|> globalMonoidLogLevel r - , globalMonoidConfigMonoid = globalMonoidConfigMonoid l <> globalMonoidConfigMonoid r - , globalMonoidResolver = globalMonoidResolver l <|> globalMonoidResolver r - , globalMonoidCompiler = globalMonoidCompiler l <|> globalMonoidCompiler r - , globalMonoidTerminal = globalMonoidTerminal l <|> globalMonoidTerminal r - , globalMonoidStackYaml = globalMonoidStackYaml l <|> globalMonoidStackYaml r } + mempty = memptydefault + mappend = mappenddefault -- | Either an actual resolver value, or an abstract description of one (e.g., -- latest nightly). @@ -744,9 +739,9 @@ instance HasBuildConfig BuildConfig where -- Configurations may be "cascaded" using mappend (left-biased). data ConfigMonoid = ConfigMonoid - { configMonoidStackRoot :: !(Maybe (Path Abs Dir)) + { configMonoidStackRoot :: !(First (Path Abs Dir)) -- ^ See: 'configStackRoot' - , configMonoidWorkDir :: !(Maybe FilePath) + , configMonoidWorkDir :: !(First FilePath) -- ^ See: 'configWorkDir'. , configMonoidBuildOpts :: !BuildOptsMonoid -- ^ build options. @@ -754,159 +749,80 @@ data ConfigMonoid = -- ^ Docker options. , configMonoidNixOpts :: !NixOptsMonoid -- ^ Options for the execution environment (nix-shell or container) - , configMonoidConnectionCount :: !(Maybe Int) + , configMonoidConnectionCount :: !(First Int) -- ^ See: 'configConnectionCount' - , configMonoidHideTHLoading :: !(Maybe Bool) + , configMonoidHideTHLoading :: !(First Bool) -- ^ See: 'configHideTHLoading' - , configMonoidLatestSnapshotUrl :: !(Maybe Text) + , configMonoidLatestSnapshotUrl :: !(First Text) -- ^ Deprecated in favour of 'urlsMonoidLatestSnapshot' , configMonoidUrls :: !UrlsMonoid -- ^ See: 'configUrls - , configMonoidPackageIndices :: !(Maybe [PackageIndex]) + , configMonoidPackageIndices :: !(First [PackageIndex]) -- ^ See: 'configPackageIndices' - , configMonoidSystemGHC :: !(Maybe Bool) + , configMonoidSystemGHC :: !(First Bool) -- ^ See: 'configSystemGHC' - ,configMonoidInstallGHC :: !(Maybe Bool) + ,configMonoidInstallGHC :: !(First Bool) -- ^ See: 'configInstallGHC' - ,configMonoidSkipGHCCheck :: !(Maybe Bool) + ,configMonoidSkipGHCCheck :: !(First Bool) -- ^ See: 'configSkipGHCCheck' - ,configMonoidSkipMsys :: !(Maybe Bool) + ,configMonoidSkipMsys :: !(First Bool) -- ^ See: 'configSkipMsys' - ,configMonoidCompilerCheck :: !(Maybe VersionCheck) + ,configMonoidCompilerCheck :: !(First VersionCheck) -- ^ See: 'configCompilerCheck' - ,configMonoidRequireStackVersion :: !VersionRange + ,configMonoidRequireStackVersion :: !IntersectingVersionRange -- ^ See: 'configRequireStackVersion' - ,configMonoidOS :: !(Maybe String) + ,configMonoidOS :: !(First String) -- ^ Used for overriding the platform - ,configMonoidArch :: !(Maybe String) + ,configMonoidArch :: !(First String) -- ^ Used for overriding the platform - ,configMonoidGHCVariant :: !(Maybe GHCVariant) + ,configMonoidGHCVariant :: !(First GHCVariant) -- ^ Used for overriding the GHC variant - ,configMonoidJobs :: !(Maybe Int) + ,configMonoidJobs :: !(First Int) -- ^ See: 'configJobs' ,configMonoidExtraIncludeDirs :: !(Set Text) -- ^ See: 'configExtraIncludeDirs' ,configMonoidExtraLibDirs :: !(Set Text) -- ^ See: 'configExtraLibDirs' - ,configMonoidConcurrentTests :: !(Maybe Bool) + ,configMonoidConcurrentTests :: !(First Bool) -- ^ See: 'configConcurrentTests' - ,configMonoidLocalBinPath :: !(Maybe FilePath) + ,configMonoidLocalBinPath :: !(First FilePath) -- ^ Used to override the binary installation dir ,configMonoidImageOpts :: !ImageOptsMonoid -- ^ Image creation options. ,configMonoidTemplateParameters :: !(Map Text Text) -- ^ Template parameters. - ,configMonoidScmInit :: !(Maybe SCM) + ,configMonoidScmInit :: !(First SCM) -- ^ Initialize SCM (e.g. git init) when making new projects? - ,configMonoidGhcOptions :: !(Map (Maybe PackageName) [Text]) + ,configMonoidGhcOptions :: !(CliOptionMap (Maybe PackageName) Text) -- ^ See 'configGhcOptions' ,configMonoidExtraPath :: ![Path Abs Dir] -- ^ Additional paths to search for executables in ,configMonoidSetupInfoLocations :: ![SetupInfoLocation] -- ^ Additional setup info (inline or remote) to use for installing tools - ,configMonoidPvpBounds :: !(Maybe PvpBounds) + ,configMonoidPvpBounds :: !(First PvpBounds) -- ^ See 'configPvpBounds' - ,configMonoidModifyCodePage :: !(Maybe Bool) + ,configMonoidModifyCodePage :: !(First Bool) -- ^ See 'configModifyCodePage' ,configMonoidExplicitSetupDeps :: !(Map (Maybe PackageName) Bool) -- ^ See 'configExplicitSetupDeps' - ,configMonoidRebuildGhcOptions :: !(Maybe Bool) + ,configMonoidRebuildGhcOptions :: !(First Bool) -- ^ See 'configMonoidRebuildGhcOptions' - ,configMonoidApplyGhcOptions :: !(Maybe ApplyGhcOptions) + ,configMonoidApplyGhcOptions :: !(First ApplyGhcOptions) -- ^ See 'configApplyGhcOptions' - ,configMonoidAllowNewer :: !(Maybe Bool) + ,configMonoidAllowNewer :: !(First Bool) -- ^ See 'configMonoidAllowNewer' - ,configMonoidDefaultTemplate :: !(Maybe TemplateName) + ,configMonoidDefaultTemplate :: !(First TemplateName) -- ^ The default template to use when none is specified. -- (If Nothing, the default default is used.) - , configMonoidAllowDifferentUser :: !(Maybe Bool) + , configMonoidAllowDifferentUser :: !(First Bool) -- ^ Allow users other than the stack root owner to use the stack -- installation. } - deriving Show + deriving (Show, Generic) instance Monoid ConfigMonoid where - mempty = ConfigMonoid - { configMonoidStackRoot = Nothing - , configMonoidWorkDir = Nothing - , configMonoidBuildOpts = mempty - , configMonoidDockerOpts = mempty - , configMonoidNixOpts = mempty - , configMonoidConnectionCount = Nothing - , configMonoidHideTHLoading = Nothing - , configMonoidLatestSnapshotUrl = Nothing - , configMonoidUrls = mempty - , configMonoidPackageIndices = Nothing - , configMonoidSystemGHC = Nothing - , configMonoidInstallGHC = Nothing - , configMonoidSkipGHCCheck = Nothing - , configMonoidSkipMsys = Nothing - , configMonoidRequireStackVersion = anyVersion - , configMonoidOS = Nothing - , configMonoidArch = Nothing - , configMonoidGHCVariant = Nothing - , configMonoidJobs = Nothing - , configMonoidExtraIncludeDirs = Set.empty - , configMonoidExtraLibDirs = Set.empty - , configMonoidConcurrentTests = Nothing - , configMonoidLocalBinPath = Nothing - , configMonoidImageOpts = mempty - , configMonoidTemplateParameters = mempty - , configMonoidScmInit = Nothing - , configMonoidCompilerCheck = Nothing - , configMonoidGhcOptions = mempty - , configMonoidExtraPath = [] - , configMonoidSetupInfoLocations = mempty - , configMonoidPvpBounds = Nothing - , configMonoidModifyCodePage = Nothing - , configMonoidExplicitSetupDeps = mempty - , configMonoidRebuildGhcOptions = Nothing - , configMonoidApplyGhcOptions = Nothing - , configMonoidAllowNewer = Nothing - , configMonoidDefaultTemplate = Nothing - , configMonoidAllowDifferentUser = Nothing - } - mappend l r = ConfigMonoid - { configMonoidStackRoot = configMonoidStackRoot l <|> configMonoidStackRoot r - , configMonoidWorkDir = configMonoidWorkDir l <|> configMonoidWorkDir r - , configMonoidBuildOpts = configMonoidBuildOpts l <> configMonoidBuildOpts r - , configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r - , configMonoidNixOpts = configMonoidNixOpts l <> configMonoidNixOpts r - , configMonoidConnectionCount = configMonoidConnectionCount l <|> configMonoidConnectionCount r - , configMonoidHideTHLoading = configMonoidHideTHLoading l <|> configMonoidHideTHLoading r - , configMonoidLatestSnapshotUrl = configMonoidLatestSnapshotUrl l <|> configMonoidLatestSnapshotUrl r - , configMonoidUrls = configMonoidUrls l <> configMonoidUrls r - , configMonoidPackageIndices = configMonoidPackageIndices l <|> configMonoidPackageIndices r - , configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r - , configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r - , configMonoidSkipGHCCheck = configMonoidSkipGHCCheck l <|> configMonoidSkipGHCCheck r - , configMonoidSkipMsys = configMonoidSkipMsys l <|> configMonoidSkipMsys r - , configMonoidRequireStackVersion = intersectVersionRanges (configMonoidRequireStackVersion l) - (configMonoidRequireStackVersion r) - , configMonoidOS = configMonoidOS l <|> configMonoidOS r - , configMonoidArch = configMonoidArch l <|> configMonoidArch r - , configMonoidGHCVariant = configMonoidGHCVariant l <|> configMonoidGHCVariant r - , configMonoidJobs = configMonoidJobs l <|> configMonoidJobs r - , configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r) - , configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r) - , configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r - , configMonoidLocalBinPath = configMonoidLocalBinPath l <|> configMonoidLocalBinPath r - , configMonoidImageOpts = configMonoidImageOpts l <> configMonoidImageOpts r - , configMonoidTemplateParameters = configMonoidTemplateParameters l <> configMonoidTemplateParameters r - , configMonoidScmInit = configMonoidScmInit l <|> configMonoidScmInit r - , configMonoidCompilerCheck = configMonoidCompilerCheck l <|> configMonoidCompilerCheck r - , configMonoidGhcOptions = Map.unionWith (++) (configMonoidGhcOptions l) (configMonoidGhcOptions r) - , configMonoidExtraPath = configMonoidExtraPath l ++ configMonoidExtraPath r - , configMonoidSetupInfoLocations = configMonoidSetupInfoLocations l ++ configMonoidSetupInfoLocations r - , configMonoidPvpBounds = configMonoidPvpBounds l <|> configMonoidPvpBounds r - , configMonoidModifyCodePage = configMonoidModifyCodePage l <|> configMonoidModifyCodePage r - , configMonoidExplicitSetupDeps = configMonoidExplicitSetupDeps l <> configMonoidExplicitSetupDeps r - , configMonoidRebuildGhcOptions = configMonoidRebuildGhcOptions l <|> configMonoidRebuildGhcOptions r - , configMonoidApplyGhcOptions = configMonoidApplyGhcOptions l <|> configMonoidApplyGhcOptions r - , configMonoidAllowNewer = configMonoidAllowNewer l <|> configMonoidAllowNewer r - , configMonoidDefaultTemplate = configMonoidDefaultTemplate l <|> configMonoidDefaultTemplate r - , configMonoidAllowDifferentUser = configMonoidAllowDifferentUser l <|> configMonoidAllowDifferentUser r - } + mempty = memptydefault + mappend = mappenddefault instance FromJSON (WithJSONWarnings ConfigMonoid) where parseJSON = withObjectWarnings "ConfigMonoid" parseConfigMonoidJSON @@ -917,47 +833,48 @@ instance FromJSON (WithJSONWarnings ConfigMonoid) where parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid parseConfigMonoidJSON obj = do -- Parsing 'stackRoot' from 'stackRoot'/config.yaml would be nonsensical - let configMonoidStackRoot = Nothing - configMonoidWorkDir <- obj ..:? configMonoidWorkDirName + let configMonoidStackRoot = First Nothing + configMonoidWorkDir <- First <$> obj ..:? configMonoidWorkDirName configMonoidBuildOpts <- jsonSubWarnings (obj ..:? configMonoidBuildOptsName ..!= mempty) configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty) configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixOptsName ..!= mempty) - configMonoidConnectionCount <- obj ..:? configMonoidConnectionCountName - configMonoidHideTHLoading <- obj ..:? configMonoidHideTHLoadingName - configMonoidLatestSnapshotUrl <- obj ..:? configMonoidLatestSnapshotUrlName + configMonoidConnectionCount <- First <$> obj ..:? configMonoidConnectionCountName + configMonoidHideTHLoading <- First <$> obj ..:? configMonoidHideTHLoadingName + configMonoidLatestSnapshotUrl <- First <$> obj ..:? configMonoidLatestSnapshotUrlName configMonoidUrls <- jsonSubWarnings (obj ..:? configMonoidUrlsName ..!= mempty) - configMonoidPackageIndices <- jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName) - configMonoidSystemGHC <- obj ..:? configMonoidSystemGHCName - configMonoidInstallGHC <- obj ..:? configMonoidInstallGHCName - configMonoidSkipGHCCheck <- obj ..:? configMonoidSkipGHCCheckName - configMonoidSkipMsys <- obj ..:? configMonoidSkipMsysName - configMonoidRequireStackVersion <- unVersionRangeJSON <$> + configMonoidPackageIndices <- First <$> jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName) + configMonoidSystemGHC <- First <$> obj ..:? configMonoidSystemGHCName + configMonoidInstallGHC <- First <$> obj ..:? configMonoidInstallGHCName + configMonoidSkipGHCCheck <- First <$> obj ..:? configMonoidSkipGHCCheckName + configMonoidSkipMsys <- First <$> obj ..:? configMonoidSkipMsysName + configMonoidRequireStackVersion <- IntersectingVersionRange <$> unVersionRangeJSON <$> obj ..:? configMonoidRequireStackVersionName ..!= VersionRangeJSON anyVersion - configMonoidOS <- obj ..:? configMonoidOSName - configMonoidArch <- obj ..:? configMonoidArchName - configMonoidGHCVariant <- obj ..:? configMonoidGHCVariantName - configMonoidJobs <- obj ..:? configMonoidJobsName + configMonoidOS <- First <$> obj ..:? configMonoidOSName + configMonoidArch <- First <$> obj ..:? configMonoidArchName + configMonoidGHCVariant <- First <$> obj ..:? configMonoidGHCVariantName + configMonoidJobs <- First <$> obj ..:? configMonoidJobsName configMonoidExtraIncludeDirs <- obj ..:? configMonoidExtraIncludeDirsName ..!= Set.empty configMonoidExtraLibDirs <- obj ..:? configMonoidExtraLibDirsName ..!= Set.empty - configMonoidConcurrentTests <- obj ..:? configMonoidConcurrentTestsName - configMonoidLocalBinPath <- obj ..:? configMonoidLocalBinPathName + configMonoidConcurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName + configMonoidLocalBinPath <- First <$> obj ..:? configMonoidLocalBinPathName configMonoidImageOpts <- jsonSubWarnings (obj ..:? configMonoidImageOptsName ..!= mempty) templates <- obj ..:? "templates" (configMonoidScmInit,configMonoidTemplateParameters) <- case templates of - Nothing -> return (Nothing,M.empty) + Nothing -> return (First Nothing,M.empty) Just tobj -> do scmInit <- tobj ..:? configMonoidScmInitName params <- tobj ..:? configMonoidTemplateParametersName - return (scmInit,fromMaybe M.empty params) - configMonoidCompilerCheck <- obj ..:? configMonoidCompilerCheckName + return (First scmInit,fromMaybe M.empty params) + configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName mghcoptions <- obj ..:? configMonoidGhcOptionsName configMonoidGhcOptions <- - case mghcoptions of - Nothing -> return mempty - Just m -> fmap Map.fromList $ mapM handleGhcOptions $ Map.toList m + CliOptionMap <$> + case mghcoptions of + Nothing -> return mempty + Just m -> fmap Map.fromList $ mapM handleGhcOptions $ Map.toList m extraPath <- obj ..:? configMonoidExtraPathName ..!= [] configMonoidExtraPath <- forM extraPath $ @@ -965,16 +882,16 @@ parseConfigMonoidJSON obj = do configMonoidSetupInfoLocations <- maybeToList <$> jsonSubWarningsT (obj ..:? configMonoidSetupInfoLocationsName) - configMonoidPvpBounds <- obj ..:? configMonoidPvpBoundsName - configMonoidModifyCodePage <- obj ..:? configMonoidModifyCodePageName + configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName + configMonoidModifyCodePage <- First <$> obj ..:? configMonoidModifyCodePageName configMonoidExplicitSetupDeps <- (obj ..:? configMonoidExplicitSetupDepsName ..!= mempty) >>= fmap Map.fromList . mapM handleExplicitSetupDep . Map.toList - configMonoidRebuildGhcOptions <- obj ..:? configMonoidRebuildGhcOptionsName - configMonoidApplyGhcOptions <- obj ..:? configMonoidApplyGhcOptionsName - configMonoidAllowNewer <- obj ..:? configMonoidAllowNewerName - configMonoidDefaultTemplate <- obj ..:? configMonoidDefaultTemplateName - configMonoidAllowDifferentUser <- obj ..:? configMonoidAllowDifferentUserName + configMonoidRebuildGhcOptions <- First <$> obj ..:? configMonoidRebuildGhcOptionsName + configMonoidApplyGhcOptions <- First <$> obj ..:? configMonoidApplyGhcOptionsName + configMonoidAllowNewer <- First <$> obj ..:? configMonoidAllowNewerName + configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName + configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName return ConfigMonoid {..} where @@ -1112,6 +1029,17 @@ configMonoidDefaultTemplateName = "default-template" configMonoidAllowDifferentUserName :: Text configMonoidAllowDifferentUserName = "allow-different-user" +-- | 'Map' monoid under @'Map.unionWith' '(++)'@ for collecting command line options. +newtype CliOptionMap k option = CliOptionMap { getCliOptionMap :: Map k [option] } + deriving Show + +instance Ord k => Monoid (CliOptionMap k option) where + mempty = CliOptionMap Map.empty + -- FIXME: Should 'mappend' be defined with @'Map.unionWith' ('flip' '(++)')@ + -- instead, so the options from the left argument override the ones on the right? + -- See https://github.com/commercialhaskell/stack/issues/2078. + mappend (CliOptionMap l) (CliOptionMap r) = CliOptionMap (Map.unionWith (++) l r) + data ConfigException = ParseConfigFileException (Path Abs File) ParseException | ParseResolverException Text diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs index 18bdc30d4c..b743ae1701 100644 --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE FlexibleInstances, RecordWildCards, OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Configuration options for building. @@ -21,14 +24,17 @@ module Stack.Types.Config.Build ) where +import Control.Applicative import Data.Aeson.Extended import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Monoid import Data.Text (Text) +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (memptydefault, mappenddefault) +import Prelude -- Fix AMP warning import Stack.Types.FlagName import Stack.Types.PackageName -import Control.Applicative -- | Build options that is interpreted by the build command. -- This is built up from BuildOptsCLI and BuildOptsMonoid @@ -128,42 +134,42 @@ data BuildCommand -- | Build options that may be specified in the stack.yaml or from the CLI data BuildOptsMonoid = BuildOptsMonoid - { buildMonoidLibProfile :: !(Maybe Bool) - , buildMonoidExeProfile :: !(Maybe Bool) - , buildMonoidHaddock :: !(Maybe Bool) - , buildMonoidOpenHaddocks :: !(Maybe Bool) - , buildMonoidHaddockDeps :: !(Maybe Bool) - , buildMonoidInstallExes :: !(Maybe Bool) - , buildMonoidPreFetch :: !(Maybe Bool) - , buildMonoidKeepGoing :: !(Maybe Bool) - , buildMonoidForceDirty :: !(Maybe Bool) - , buildMonoidTests :: !(Maybe Bool) + { buildMonoidLibProfile :: !(First Bool) + , buildMonoidExeProfile :: !(First Bool) + , buildMonoidHaddock :: !(First Bool) + , buildMonoidOpenHaddocks :: !(First Bool) + , buildMonoidHaddockDeps :: !(First Bool) + , buildMonoidInstallExes :: !(First Bool) + , buildMonoidPreFetch :: !(First Bool) + , buildMonoidKeepGoing :: !(First Bool) + , buildMonoidForceDirty :: !(First Bool) + , buildMonoidTests :: !(First Bool) , buildMonoidTestOpts :: !TestOptsMonoid - , buildMonoidBenchmarks :: !(Maybe Bool) + , buildMonoidBenchmarks :: !(First Bool) , buildMonoidBenchmarkOpts :: !BenchmarkOptsMonoid - , buildMonoidReconfigure :: !(Maybe Bool) - , buildMonoidCabalVerbose :: !(Maybe Bool) - , buildMonoidSplitObjs :: !(Maybe Bool) - } deriving (Show) + , buildMonoidReconfigure :: !(First Bool) + , buildMonoidCabalVerbose :: !(First Bool) + , buildMonoidSplitObjs :: !(First Bool) + } deriving (Show, Generic) instance FromJSON (WithJSONWarnings BuildOptsMonoid) where parseJSON = withObjectWarnings "BuildOptsMonoid" - (\o -> do buildMonoidLibProfile <- o ..:? buildMonoidLibProfileArgName - buildMonoidExeProfile <- o ..:? buildMonoidExeProfileArgName - buildMonoidHaddock <- o ..:? buildMonoidHaddockArgName - buildMonoidOpenHaddocks <- o ..:? buildMonoidOpenHaddocksArgName - buildMonoidHaddockDeps <- o ..:? buildMonoidHaddockDepsArgName - buildMonoidInstallExes <- o ..:? buildMonoidInstallExesArgName - buildMonoidPreFetch <- o ..:? buildMonoidPreFetchArgName - buildMonoidKeepGoing <- o ..:? buildMonoidKeepGoingArgName - buildMonoidForceDirty <- o ..:? buildMonoidForceDirtyArgName - buildMonoidTests <- o ..:? buildMonoidTestsArgName + (\o -> do buildMonoidLibProfile <- First <$> o ..:? buildMonoidLibProfileArgName + buildMonoidExeProfile <-First <$> o ..:? buildMonoidExeProfileArgName + buildMonoidHaddock <- First <$> o ..:? buildMonoidHaddockArgName + buildMonoidOpenHaddocks <- First <$> o ..:? buildMonoidOpenHaddocksArgName + buildMonoidHaddockDeps <- First <$> o ..:? buildMonoidHaddockDepsArgName + buildMonoidInstallExes <- First <$> o ..:? buildMonoidInstallExesArgName + buildMonoidPreFetch <- First <$> o ..:? buildMonoidPreFetchArgName + buildMonoidKeepGoing <- First <$> o ..:? buildMonoidKeepGoingArgName + buildMonoidForceDirty <- First <$> o ..:? buildMonoidForceDirtyArgName + buildMonoidTests <- First <$> o ..:? buildMonoidTestsArgName buildMonoidTestOpts <- jsonSubWarnings (o ..:? buildMonoidTestOptsArgName ..!= mempty) - buildMonoidBenchmarks <- o ..:? buildMonoidBenchmarksArgName + buildMonoidBenchmarks <- First <$> o ..:? buildMonoidBenchmarksArgName buildMonoidBenchmarkOpts <- jsonSubWarnings (o ..:? buildMonoidBenchmarkOptsArgName ..!= mempty) - buildMonoidReconfigure <- o ..:? buildMonoidReconfigureArgName - buildMonoidCabalVerbose <- o ..:? buildMonoidCabalVerboseArgName - buildMonoidSplitObjs <- o ..:? buildMonoidSplitObjsName + buildMonoidReconfigure <- First <$> o ..:? buildMonoidReconfigureArgName + buildMonoidCabalVerbose <- First <$> o ..:? buildMonoidCabalVerboseArgName + buildMonoidSplitObjs <- First <$> o ..:? buildMonoidSplitObjsName return BuildOptsMonoid{..}) buildMonoidLibProfileArgName :: Text @@ -215,43 +221,8 @@ buildMonoidSplitObjsName :: Text buildMonoidSplitObjsName = "split-objs" instance Monoid BuildOptsMonoid where - mempty = BuildOptsMonoid - {buildMonoidLibProfile = Nothing - ,buildMonoidExeProfile = Nothing - ,buildMonoidHaddock = Nothing - ,buildMonoidOpenHaddocks = Nothing - ,buildMonoidHaddockDeps = Nothing - ,buildMonoidInstallExes = Nothing - ,buildMonoidPreFetch = Nothing - ,buildMonoidKeepGoing = Nothing - ,buildMonoidForceDirty = Nothing - ,buildMonoidTests = Nothing - ,buildMonoidTestOpts = mempty - ,buildMonoidBenchmarks = Nothing - ,buildMonoidBenchmarkOpts = mempty - ,buildMonoidReconfigure = Nothing - ,buildMonoidCabalVerbose = Nothing - ,buildMonoidSplitObjs = Nothing - } - - mappend l r = BuildOptsMonoid - {buildMonoidLibProfile = buildMonoidLibProfile l <|> buildMonoidLibProfile r - ,buildMonoidExeProfile = buildMonoidExeProfile l <|> buildMonoidExeProfile r - ,buildMonoidHaddock = buildMonoidHaddock l <|> buildMonoidHaddock r - ,buildMonoidOpenHaddocks = buildMonoidOpenHaddocks l <|> buildMonoidOpenHaddocks r - ,buildMonoidHaddockDeps = buildMonoidHaddockDeps l <|> buildMonoidHaddockDeps r - ,buildMonoidInstallExes = buildMonoidInstallExes l <|> buildMonoidInstallExes r - ,buildMonoidPreFetch = buildMonoidPreFetch l <|> buildMonoidPreFetch r - ,buildMonoidKeepGoing = buildMonoidKeepGoing l <|> buildMonoidKeepGoing r - ,buildMonoidForceDirty = buildMonoidForceDirty l <|> buildMonoidForceDirty r - ,buildMonoidTests = buildMonoidTests l <|> buildMonoidTests r - ,buildMonoidTestOpts = buildMonoidTestOpts l <> buildMonoidTestOpts r - ,buildMonoidBenchmarks = buildMonoidBenchmarks l <|> buildMonoidBenchmarks r - ,buildMonoidBenchmarkOpts = buildMonoidBenchmarkOpts l <> buildMonoidBenchmarkOpts r - ,buildMonoidReconfigure = buildMonoidReconfigure l <|> buildMonoidReconfigure r - ,buildMonoidCabalVerbose = buildMonoidCabalVerbose l <|> buildMonoidCabalVerbose r - ,buildMonoidSplitObjs = buildMonoidSplitObjs l <|> buildMonoidSplitObjs r - } + mempty = memptydefault + mappend = mappenddefault -- | Which subset of packages to build data BuildSubset @@ -280,18 +251,18 @@ defaultTestOpts = TestOpts data TestOptsMonoid = TestOptsMonoid - { toMonoidRerunTests :: !(Maybe Bool) + { toMonoidRerunTests :: !(First Bool) , toMonoidAdditionalArgs :: ![String] - , toMonoidCoverage :: !(Maybe Bool) - , toMonoidDisableRun :: !(Maybe Bool) - } deriving (Show) + , toMonoidCoverage :: !(First Bool) + , toMonoidDisableRun :: !(First Bool) + } deriving (Show, Generic) instance FromJSON (WithJSONWarnings TestOptsMonoid) where parseJSON = withObjectWarnings "TestOptsMonoid" - (\o -> do toMonoidRerunTests <- o ..:? toMonoidRerunTestsArgName + (\o -> do toMonoidRerunTests <- First <$> o ..:? toMonoidRerunTestsArgName toMonoidAdditionalArgs <- o ..:? toMonoidAdditionalArgsName ..!= [] - toMonoidCoverage <- o ..:? toMonoidCoverageArgName - toMonoidDisableRun <- o ..:? toMonoidDisableRunArgName + toMonoidCoverage <- First <$> o ..:? toMonoidCoverageArgName + toMonoidDisableRun <- First <$> o ..:? toMonoidDisableRunArgName return TestOptsMonoid{..}) toMonoidRerunTestsArgName :: Text @@ -307,18 +278,8 @@ toMonoidDisableRunArgName :: Text toMonoidDisableRunArgName = "no-run-tests" instance Monoid TestOptsMonoid where - mempty = TestOptsMonoid - { toMonoidRerunTests = Nothing - , toMonoidAdditionalArgs = [] - , toMonoidCoverage = Nothing - , toMonoidDisableRun = Nothing - } - mappend l r = TestOptsMonoid - { toMonoidRerunTests = toMonoidRerunTests l <|> toMonoidRerunTests r - , toMonoidAdditionalArgs = toMonoidAdditionalArgs l <> toMonoidAdditionalArgs r - , toMonoidCoverage = toMonoidCoverage l <|> toMonoidCoverage r - , toMonoidDisableRun = toMonoidDisableRun l <|> toMonoidDisableRun r - } + mempty = memptydefault + mappend = mappenddefault -- | Options for the 'FinalAction' 'DoBenchmarks' data BenchmarkOpts = @@ -335,14 +296,14 @@ defaultBenchmarkOpts = BenchmarkOpts data BenchmarkOptsMonoid = BenchmarkOptsMonoid - { beoMonoidAdditionalArgs :: !(Maybe String) - , beoMonoidDisableRun :: !(Maybe Bool) - } deriving (Show) + { beoMonoidAdditionalArgs :: !(First String) + , beoMonoidDisableRun :: !(First Bool) + } deriving (Show, Generic) instance FromJSON (WithJSONWarnings BenchmarkOptsMonoid) where parseJSON = withObjectWarnings "BenchmarkOptsMonoid" - (\o -> do beoMonoidAdditionalArgs <- o ..:? beoMonoidAdditionalArgsArgName - beoMonoidDisableRun <- o ..:? beoMonoidDisableRunArgName + (\o -> do beoMonoidAdditionalArgs <- First <$> o ..:? beoMonoidAdditionalArgsArgName + beoMonoidDisableRun <- First <$> o ..:? beoMonoidDisableRunArgName return BenchmarkOptsMonoid{..}) beoMonoidAdditionalArgsArgName :: Text @@ -352,12 +313,8 @@ beoMonoidDisableRunArgName :: Text beoMonoidDisableRunArgName = "no-run-benchmarks" instance Monoid BenchmarkOptsMonoid where - mempty = BenchmarkOptsMonoid - { beoMonoidAdditionalArgs = Nothing - , beoMonoidDisableRun = Nothing} - mappend l r = BenchmarkOptsMonoid - { beoMonoidAdditionalArgs = beoMonoidAdditionalArgs l <|> beoMonoidAdditionalArgs r - , beoMonoidDisableRun = beoMonoidDisableRun l <|> beoMonoidDisableRun r} + mempty = memptydefault + mappend = mappenddefault data FileWatchOpts = NoFileWatch diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs index a9515f2087..d02691fabf 100644 --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Docker types. @@ -13,6 +16,8 @@ import Data.Text (Text) import qualified Data.Text as T import Distribution.Text (simpleParse) import Distribution.Version (anyVersion) +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path import Stack.Types.Version @@ -58,26 +63,26 @@ data DockerOpts = DockerOpts -- | An uninterpreted representation of docker options. -- Configurations may be "cascaded" using mappend (left-biased). data DockerOptsMonoid = DockerOptsMonoid - {dockerMonoidDefaultEnable :: !Bool + {dockerMonoidDefaultEnable :: !Any -- ^ Should Docker be defaulted to enabled (does @docker:@ section exist in the config)? - ,dockerMonoidEnable :: !(Maybe Bool) + ,dockerMonoidEnable :: !(First Bool) -- ^ Is using Docker enabled? - ,dockerMonoidRepoOrImage :: !(Maybe DockerMonoidRepoOrImage) + ,dockerMonoidRepoOrImage :: !(First DockerMonoidRepoOrImage) -- ^ Docker repository name (e.g. @fpco/stack-build@ or @fpco/stack-full:lts-2.8@) - ,dockerMonoidRegistryLogin :: !(Maybe Bool) + ,dockerMonoidRegistryLogin :: !(First Bool) -- ^ Does registry require login for pulls? - ,dockerMonoidRegistryUsername :: !(Maybe String) + ,dockerMonoidRegistryUsername :: !(First String) -- ^ Optional username for Docker registry. - ,dockerMonoidRegistryPassword :: !(Maybe String) + ,dockerMonoidRegistryPassword :: !(First String) -- ^ Optional password for Docker registry. - ,dockerMonoidAutoPull :: !(Maybe Bool) + ,dockerMonoidAutoPull :: !(First Bool) -- ^ Automatically pull new images. - ,dockerMonoidDetach :: !(Maybe Bool) + ,dockerMonoidDetach :: !(First Bool) -- ^ Whether to run a detached container - ,dockerMonoidPersist :: !(Maybe Bool) + ,dockerMonoidPersist :: !(First Bool) -- ^ Create a persistent container (don't remove it when finished). Implied by -- `dockerDetach`. - ,dockerMonoidContainerName :: !(Maybe String) + ,dockerMonoidContainerName :: !(First String) -- ^ Container name to use, only makes sense from command-line with `dockerPersist` -- or `dockerDetach`. ,dockerMonoidRunArgs :: ![String] @@ -86,86 +91,49 @@ data DockerOptsMonoid = DockerOptsMonoid -- ^ Volumes to mount in the container ,dockerMonoidEnv :: ![String] -- ^ Environment variables to set in the container - ,dockerMonoidDatabasePath :: !(Maybe String) + ,dockerMonoidDatabasePath :: !(First String) -- ^ Location of image usage database. - ,dockerMonoidStackExe :: !(Maybe String) + ,dockerMonoidStackExe :: !(First String) -- ^ Location of container-compatible stack executable - ,dockerMonoidSetUser :: !(Maybe Bool) + ,dockerMonoidSetUser :: !(First Bool) -- ^ Set in-container user to match host's - ,dockerMonoidRequireDockerVersion :: !VersionRange + ,dockerMonoidRequireDockerVersion :: !IntersectingVersionRange -- ^ See: 'dockerRequireDockerVersion' } - deriving (Show) + deriving (Show, Generic) -- | Decode uninterpreted docker options from JSON/YAML. instance FromJSON (WithJSONWarnings DockerOptsMonoid) where parseJSON = withObjectWarnings "DockerOptsMonoid" - (\o -> do dockerMonoidDefaultEnable <- pure True - dockerMonoidEnable <- o ..:? dockerEnableArgName - dockerMonoidRepoOrImage <- ((Just . DockerMonoidImage) <$> o ..: dockerImageArgName) <|> + (\o -> do dockerMonoidDefaultEnable <- pure (Any True) + dockerMonoidEnable <- First <$> o ..:? dockerEnableArgName + dockerMonoidRepoOrImage <- First <$> + (((Just . DockerMonoidImage) <$> o ..: dockerImageArgName) <|> ((Just . DockerMonoidRepo) <$> o ..: dockerRepoArgName) <|> - pure Nothing - dockerMonoidRegistryLogin <- o ..:? dockerRegistryLoginArgName - dockerMonoidRegistryUsername <- o ..:? dockerRegistryUsernameArgName - dockerMonoidRegistryPassword <- o ..:? dockerRegistryPasswordArgName - dockerMonoidAutoPull <- o ..:? dockerAutoPullArgName - dockerMonoidDetach <- o ..:? dockerDetachArgName - dockerMonoidPersist <- o ..:? dockerPersistArgName - dockerMonoidContainerName <- o ..:? dockerContainerNameArgName + pure Nothing) + dockerMonoidRegistryLogin <- First <$> o ..:? dockerRegistryLoginArgName + dockerMonoidRegistryUsername <- First <$> o ..:? dockerRegistryUsernameArgName + dockerMonoidRegistryPassword <- First <$> o ..:? dockerRegistryPasswordArgName + dockerMonoidAutoPull <- First <$> o ..:? dockerAutoPullArgName + dockerMonoidDetach <- First <$> o ..:? dockerDetachArgName + dockerMonoidPersist <- First <$> o ..:? dockerPersistArgName + dockerMonoidContainerName <- First <$> o ..:? dockerContainerNameArgName dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= [] dockerMonoidMount <- o ..:? dockerMountArgName ..!= [] dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= [] - dockerMonoidDatabasePath <- o ..:? dockerDatabasePathArgName - dockerMonoidStackExe <- o ..:? dockerStackExeArgName - dockerMonoidSetUser <- o ..:? dockerSetUserArgName + dockerMonoidDatabasePath <- First <$> o ..:? dockerDatabasePathArgName + dockerMonoidStackExe <- First <$> o ..:? dockerStackExeArgName + dockerMonoidSetUser <- First <$> o ..:? dockerSetUserArgName dockerMonoidRequireDockerVersion - <- unVersionRangeJSON <$> + <- IntersectingVersionRange <$> unVersionRangeJSON <$> o ..:? dockerRequireDockerVersionArgName ..!= VersionRangeJSON anyVersion return DockerOptsMonoid{..}) -- | Left-biased combine Docker options instance Monoid DockerOptsMonoid where - mempty = DockerOptsMonoid - {dockerMonoidDefaultEnable = False - ,dockerMonoidEnable = Nothing - ,dockerMonoidRepoOrImage = Nothing - ,dockerMonoidRegistryLogin = Nothing - ,dockerMonoidRegistryUsername = Nothing - ,dockerMonoidRegistryPassword = Nothing - ,dockerMonoidAutoPull = Nothing - ,dockerMonoidDetach = Nothing - ,dockerMonoidPersist = Nothing - ,dockerMonoidContainerName = Nothing - ,dockerMonoidRunArgs = [] - ,dockerMonoidMount = [] - ,dockerMonoidEnv = [] - ,dockerMonoidDatabasePath = Nothing - ,dockerMonoidStackExe = Nothing - ,dockerMonoidSetUser = Nothing - ,dockerMonoidRequireDockerVersion = anyVersion - } - mappend l r = DockerOptsMonoid - {dockerMonoidDefaultEnable = dockerMonoidDefaultEnable l || dockerMonoidDefaultEnable r - ,dockerMonoidEnable = dockerMonoidEnable l <|> dockerMonoidEnable r - ,dockerMonoidRepoOrImage = dockerMonoidRepoOrImage l <|> dockerMonoidRepoOrImage r - ,dockerMonoidRegistryLogin = dockerMonoidRegistryLogin l <|> dockerMonoidRegistryLogin r - ,dockerMonoidRegistryUsername = dockerMonoidRegistryUsername l <|> dockerMonoidRegistryUsername r - ,dockerMonoidRegistryPassword = dockerMonoidRegistryPassword l <|> dockerMonoidRegistryPassword r - ,dockerMonoidAutoPull = dockerMonoidAutoPull l <|> dockerMonoidAutoPull r - ,dockerMonoidDetach = dockerMonoidDetach l <|> dockerMonoidDetach r - ,dockerMonoidPersist = dockerMonoidPersist l <|> dockerMonoidPersist r - ,dockerMonoidContainerName = dockerMonoidContainerName l <|> dockerMonoidContainerName r - ,dockerMonoidRunArgs = dockerMonoidRunArgs r <> dockerMonoidRunArgs l - ,dockerMonoidMount = dockerMonoidMount r <> dockerMonoidMount l - ,dockerMonoidEnv = dockerMonoidEnv r <> dockerMonoidEnv l - ,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r - ,dockerMonoidStackExe = dockerMonoidStackExe l <|> dockerMonoidStackExe r - ,dockerMonoidSetUser = dockerMonoidSetUser l <|> dockerMonoidSetUser r - ,dockerMonoidRequireDockerVersion - = intersectVersionRanges (dockerMonoidRequireDockerVersion l) - (dockerMonoidRequireDockerVersion r) - } + mempty = memptydefault + mappend = mappenddefault -- | Where to get the `stack` executable to run in Docker containers data DockerStackExe diff --git a/src/Stack/Types/Image.hs b/src/Stack/Types/Image.hs index f90f28ba51..c3a65d0903 100644 --- a/src/Stack/Types/Image.hs +++ b/src/Stack/Types/Image.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -11,6 +12,8 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (maybeToList) import Data.Text (Text) +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Prelude -- Fix redundant import warnings -- | Image options. Currently only Docker image options. @@ -37,7 +40,7 @@ data ImageDockerOpts = ImageDockerOpts data ImageOptsMonoid = ImageOptsMonoid { imgMonoidDockers :: ![ImageDockerOpts] - } deriving (Show) + } deriving (Show, Generic) instance FromJSON (WithJSONWarnings ImageOptsMonoid) where parseJSON = withObjectWarnings @@ -52,12 +55,8 @@ instance FromJSON (WithJSONWarnings ImageOptsMonoid) where }) instance Monoid ImageOptsMonoid where - mempty = ImageOptsMonoid - { imgMonoidDockers = [] - } - mappend l r = ImageOptsMonoid - { imgMonoidDockers = imgMonoidDockers l <> imgMonoidDockers r - } + mempty = memptydefault + mappend = mappenddefault instance FromJSON (WithJSONWarnings ImageDockerOpts) where parseJSON = withObjectWarnings diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs index dc13f20c55..4fa22b6ac7 100644 --- a/src/Stack/Types/Internal.hs +++ b/src/Stack/Types/Internal.hs @@ -6,6 +6,7 @@ module Stack.Types.Internal where import Control.Concurrent.MVar import Control.Monad.Logger (LogLevel) +import Data.Monoid.Extra import Data.Text (Text) import Lens.Micro import Network.HTTP.Client.Conduit (Manager,HasHttpManager(..)) @@ -80,21 +81,21 @@ envEnvConfig = lens (envConfig) (\s t -> s {envConfig = t}) buildOptsMonoidHaddock :: Lens' BuildOptsMonoid (Maybe Bool) -buildOptsMonoidHaddock = lens (buildMonoidHaddock) - (\buildMonoid t -> buildMonoid {buildMonoidHaddock = t}) +buildOptsMonoidHaddock = lens (getFirst . buildMonoidHaddock) + (\buildMonoid t -> buildMonoid {buildMonoidHaddock = First t}) buildOptsMonoidTests :: Lens' BuildOptsMonoid (Maybe Bool) -buildOptsMonoidTests = lens (buildMonoidTests) - (\buildMonoid t -> buildMonoid {buildMonoidTests = t}) +buildOptsMonoidTests = lens (getFirst . buildMonoidTests) + (\buildMonoid t -> buildMonoid {buildMonoidTests = First t}) buildOptsMonoidBenchmarks :: Lens' BuildOptsMonoid (Maybe Bool) -buildOptsMonoidBenchmarks = lens (buildMonoidBenchmarks) - (\buildMonoid t -> buildMonoid {buildMonoidBenchmarks = t}) +buildOptsMonoidBenchmarks = lens (getFirst . buildMonoidBenchmarks) + (\buildMonoid t -> buildMonoid {buildMonoidBenchmarks = First t}) buildOptsMonoidInstallExes :: Lens' BuildOptsMonoid (Maybe Bool) buildOptsMonoidInstallExes = - lens (buildMonoidInstallExes) - (\buildMonoid t -> buildMonoid {buildMonoidInstallExes = t}) + lens (getFirst . buildMonoidInstallExes) + (\buildMonoid t -> buildMonoid {buildMonoidInstallExes = First t}) buildOptsInstallExes :: Lens' BuildOpts Bool buildOptsInstallExes = diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs index 00c82749c2..c297e27187 100644 --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -10,6 +11,8 @@ import Control.Applicative import Data.Aeson.Extended import Data.Text (Text) import Data.Monoid +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Prelude -- | Nix configuration. Parameterize by resolver type to avoid cyclic @@ -29,55 +32,39 @@ data NixOpts = NixOpts -- | An uninterpreted representation of nix options. -- Configurations may be "cascaded" using mappend (left-biased). data NixOptsMonoid = NixOptsMonoid - {nixMonoidDefaultEnable :: !Bool + {nixMonoidDefaultEnable :: !Any -- ^ Should nix-shell be defaulted to enabled (does @nix:@ section exist in the config)? - ,nixMonoidEnable :: !(Maybe Bool) + ,nixMonoidEnable :: !(First Bool) -- ^ Is using nix-shell enabled? - ,nixMonoidPureShell :: !(Maybe Bool) + ,nixMonoidPureShell :: !(First Bool) -- ^ Should the nix-shell be pure - ,nixMonoidPackages :: !(Maybe [Text]) + ,nixMonoidPackages :: !(First [Text]) -- ^ System packages to use (given to nix-shell) - ,nixMonoidInitFile :: !(Maybe FilePath) + ,nixMonoidInitFile :: !(First FilePath) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) - ,nixMonoidShellOptions :: !(Maybe [Text]) + ,nixMonoidShellOptions :: !(First [Text]) -- ^ Options to be given to the nix-shell command line - ,nixMonoidPath :: !(Maybe [Text]) + ,nixMonoidPath :: !(First [Text]) -- ^ Override parts of NIX_PATH (notably 'nixpkgs') } - deriving (Eq, Show) + deriving (Eq, Show, Generic) -- | Decode uninterpreted nix options from JSON/YAML. instance FromJSON (WithJSONWarnings NixOptsMonoid) where parseJSON = withObjectWarnings "NixOptsMonoid" - (\o -> do nixMonoidDefaultEnable <- pure False - nixMonoidEnable <- o ..:? nixEnableArgName - nixMonoidPureShell <- o ..:? nixPureShellArgName - nixMonoidPackages <- o ..:? nixPackagesArgName - nixMonoidInitFile <- o ..:? nixInitFileArgName - nixMonoidShellOptions <- o ..:? nixShellOptsArgName - nixMonoidPath <- o ..:? nixPathArgName + (\o -> do nixMonoidDefaultEnable <- pure (Any False) + nixMonoidEnable <- First <$> o ..:? nixEnableArgName + nixMonoidPureShell <- First <$> o ..:? nixPureShellArgName + nixMonoidPackages <- First <$> o ..:? nixPackagesArgName + nixMonoidInitFile <- First <$> o ..:? nixInitFileArgName + nixMonoidShellOptions <- First <$> o ..:? nixShellOptsArgName + nixMonoidPath <- First <$> o ..:? nixPathArgName return NixOptsMonoid{..}) -- | Left-biased combine Nix options instance Monoid NixOptsMonoid where - mempty = NixOptsMonoid - {nixMonoidDefaultEnable = False - ,nixMonoidEnable = Nothing - ,nixMonoidPureShell = Nothing - ,nixMonoidPackages = Nothing - ,nixMonoidInitFile = Nothing - ,nixMonoidShellOptions = Nothing - ,nixMonoidPath = Nothing - } - mappend l r = NixOptsMonoid - {nixMonoidDefaultEnable = nixMonoidDefaultEnable l || nixMonoidDefaultEnable r - ,nixMonoidEnable = nixMonoidEnable l <|> nixMonoidEnable r - ,nixMonoidPureShell = nixMonoidPureShell l <|> nixMonoidPureShell r - ,nixMonoidPackages = nixMonoidPackages l <|> nixMonoidPackages r - ,nixMonoidInitFile = nixMonoidInitFile l <|> nixMonoidInitFile r - ,nixMonoidShellOptions = nixMonoidShellOptions l <|> nixMonoidShellOptions r - ,nixMonoidPath = nixMonoidPath l <|> nixMonoidPath r - } + mempty = memptydefault + mappend = mappenddefault -- | Nix enable argument name. nixEnableArgName :: Text diff --git a/src/Stack/Types/Urls.hs b/src/Stack/Types/Urls.hs index 0728b3c178..0df52f6897 100644 --- a/src/Stack/Types/Urls.hs +++ b/src/Stack/Types/Urls.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Stack.Types.Urls where @@ -6,6 +8,8 @@ import Control.Applicative import Data.Aeson.Extended import Data.Text (Text) import Data.Monoid +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Prelude data Urls = Urls @@ -24,11 +28,11 @@ instance FromJSON (WithJSONWarnings Urls) where <*> o ..: "nightly-build-plans" data UrlsMonoid = UrlsMonoid - { urlsMonoidLatestSnapshot :: !(Maybe Text) - , urlsMonoidLtsBuildPlans :: !(Maybe Text) - , urlsMonoidNightlyBuildPlans :: !(Maybe Text) + { urlsMonoidLatestSnapshot :: !(First Text) + , urlsMonoidLtsBuildPlans :: !(First Text) + , urlsMonoidNightlyBuildPlans :: !(First Text) } - deriving Show + deriving (Show, Generic) instance FromJSON (WithJSONWarnings UrlsMonoid) where parseJSON = withObjectWarnings "UrlsMonoid" $ \o -> do @@ -38,9 +42,5 @@ instance FromJSON (WithJSONWarnings UrlsMonoid) where <*> o ..: "nightly-build-plans" instance Monoid UrlsMonoid where - mempty = UrlsMonoid Nothing Nothing Nothing - mappend l r = UrlsMonoid - { urlsMonoidLatestSnapshot = urlsMonoidLatestSnapshot l <|> urlsMonoidLatestSnapshot r - , urlsMonoidLtsBuildPlans = urlsMonoidLtsBuildPlans l <|> urlsMonoidLtsBuildPlans r - , urlsMonoidNightlyBuildPlans = urlsMonoidNightlyBuildPlans l <|> urlsMonoidNightlyBuildPlans r - } + mempty = memptydefault + mappend = mappenddefault diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index e3f3fb3ed2..50f0f10bea 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -11,6 +11,7 @@ module Stack.Types.Version (Version ,Cabal.VersionRange -- TODO in the future should have a newtype wrapper + ,IntersectingVersionRange(..) ,VersionCheck(..) ,versionParser ,parseVersion @@ -41,6 +42,7 @@ import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (listToMaybe) +import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -105,6 +107,15 @@ instance FromJSON a => FromJSON (Map Version a) where k' <- either (fail . show) return $ parseVersionFromString k return (k', v) +newtype IntersectingVersionRange = + IntersectingVersionRange { getIntersectingVersionRange :: Cabal.VersionRange } + deriving Show + +instance Monoid IntersectingVersionRange where + mempty = IntersectingVersionRange Cabal.anyVersion + mappend (IntersectingVersionRange l) (IntersectingVersionRange r) = + IntersectingVersionRange (l `Cabal.intersectVersionRanges` r) + -- | Attoparsec parser for a package version. versionParser :: Parser Version versionParser = diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 77d2df2bd8..7308c387ed 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -13,7 +13,7 @@ import Control.Monad.Trans.Control import Data.Foldable (forM_) import qualified Data.Map as Map import Data.Maybe (isNothing) -import Data.Monoid ((<>)) +import Data.Monoid.Extra import qualified Data.Monoid import qualified Data.Set as Set import qualified Data.Text as T @@ -93,7 +93,7 @@ upgrade gitRepo mresolver builtHash = bconfig <- runInnerStackLoggingT $ do lc <- loadConfig (configConfigMonoid config <> Data.Monoid.mempty - { configMonoidInstallGHC = Just True + { configMonoidInstallGHC = First (Just True) }) (Just $ dir $(mkRelFile "stack.yaml")) mresolver diff --git a/stack.cabal b/stack.cabal index c078223ae7..36a24a58c9 100644 --- a/stack.cabal +++ b/stack.cabal @@ -60,6 +60,7 @@ library Data.Binary.VersionTagged Data.IORef.RunOnce Data.Maybe.Extra + Data.Monoid.Extra Distribution.Version.Extra Network.HTTP.Download Network.HTTP.Download.Verified @@ -168,6 +169,7 @@ library , filelock >= 0.1.0.1 , filepath >= 1.3.0.2 , fsnotify >= 0.2.1 + , generic-deriving , hashable >= 1.2.3.2 , hpc , http-client >= 0.4.17 From fab47338ddf5cb447b1fd7e1ba60c3e93205e407 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Wed, 4 May 2016 17:17:53 +0200 Subject: [PATCH 2/4] Derive Monoid instance for Stack.Build.ConstructPlan.W --- src/Stack/Build/ConstructPlan.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 74378b4d28..dd545d9c90 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -34,6 +35,8 @@ import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import qualified Distribution.Package as Cabal import qualified Distribution.Version as Cabal +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Network.HTTP.Client.Conduit (HasHttpManager) import Prelude hiding (pi, writeFile) import Stack.Build.Cache @@ -85,10 +88,10 @@ data W = W -- ^ Packages which count as dependencies , wWarnings :: !([Text] -> [Text]) -- ^ Warnings - } + } deriving Generic instance Monoid W where - mempty = W mempty mempty mempty mempty mempty - mappend (W a b c d e) (W w x y z z') = W (mappend a w) (mappend b x) (mappend c y) (mappend d z) (mappend e z') + mempty = memptydefault + mappend = mappenddefault type M = RWST Ctx From ff9a8d07280410c7db339228efe2d5fd2cf7e56b Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Wed, 4 May 2016 17:20:22 +0200 Subject: [PATCH 3/4] Derive Monoid instance for ExtraDirs --- src/Stack/Setup/Installed.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index 50e8f09c3a..9e049d6991 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -31,6 +32,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Distribution.System (Platform (..)) import qualified Distribution.System as Cabal +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO @@ -167,13 +170,10 @@ data ExtraDirs = ExtraDirs { edBins :: ![FilePath] , edInclude :: ![FilePath] , edLib :: ![FilePath] - } deriving (Show) + } deriving (Show, Generic) instance Monoid ExtraDirs where - mempty = ExtraDirs [] [] [] - mappend (ExtraDirs a b c) (ExtraDirs x y z) = ExtraDirs - (a ++ x) - (b ++ y) - (c ++ z) + mempty = memptydefault + mappend = mappenddefault installDir :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m) => Path Abs Dir From 1ff8683006563f4bde012d4615acefbe0937c2d1 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Wed, 4 May 2016 17:26:45 +0200 Subject: [PATCH 4/4] Derive Monoid instances in Data.Aeson.Extended --- src/Data/Aeson/Extended.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs index 7e1d712356..dccb41c3c8 100644 --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, TemplateHaskell, TupleSections #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} -- | Extensions to Aeson parsing of objects. module Data.Aeson.Extended ( @@ -37,6 +41,8 @@ import Data.Text (unpack, Text) import qualified Data.Text as T import Data.Traversable import qualified Data.Traversable as Traversable +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Prelude -- Fix redundant import warnings -- | Extends @.:@ warning to include field name. @@ -143,24 +149,19 @@ type WarningParser a = WriterT WarningParserMonoid Parser a data WarningParserMonoid = WarningParserMonoid { wpmExpectedFields :: !(Set Text) , wpmWarnings :: [JSONWarning] - } + } deriving Generic instance Monoid WarningParserMonoid where - mempty = WarningParserMonoid Set.empty [] - mappend a b = - WarningParserMonoid - { wpmExpectedFields = Set.union - (wpmExpectedFields a) - (wpmExpectedFields b) - , wpmWarnings = wpmWarnings a ++ wpmWarnings b - } + mempty = memptydefault + mappend = mappenddefault -- Parsed JSON value with its warnings data WithJSONWarnings a = WithJSONWarnings a [JSONWarning] + deriving Generic instance Functor WithJSONWarnings where fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w instance Monoid a => Monoid (WithJSONWarnings a) where - mempty = noJSONWarnings mempty - mappend (WithJSONWarnings a aw) (WithJSONWarnings b bw) = WithJSONWarnings (mappend a b) (mappend aw bw) + mempty = memptydefault + mappend = mappenddefault -- | Warning output from 'WarningParser'. data JSONWarning = JSONUnrecognizedFields String [Text]