Merge pull request #2095 from sjakobi/2078-derived-monoids

Derive various Monoid instances with generic-deriving

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]

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

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

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

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

src/Stack/Config/Build.hs

@@ -3,66 +3,66 @@
 -- | 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
     }
 
 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
     }