Add verbosity patterns

Cabal/src/Distribution/Make.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -----------------------------------------------------------------------------
 
@@ -65,6 +67,7 @@ module Distribution.Make
   , defaultMainArgsWithHandles
   ) where
 
+import Data.Monoid (Last (..))
 import Distribution.Compat.Prelude
 import Prelude ()
 
@@ -149,7 +152,7 @@ defaultMainHelperWithHandles verbHandles args = do
 configureAction :: VerbosityHandles -> ConfigFlags -> [String] -> IO ()
 configureAction verbHandles flags args = do
   noExtraFlags args
-  let verbosity = mkVerbosity verbHandles $ fromFlag $ configVerbosity flags
+  let FlagVerbosity verbosity = (verbHandles, configVerbosity flags)
       mbWorkDir = flagToMaybe $ configWorkingDir flags
   rawSystemExit verbosity mbWorkDir "sh" $
     "configure"
@@ -160,7 +163,7 @@ configureAction verbHandles flags args = do
 copyAction :: VerbosityHandles -> CopyFlags -> [String] -> IO ()
 copyAction verbHandles flags args = do
   noExtraFlags args
-  let verbosity = mkVerbosity verbHandles $ fromFlag $ copyVerbosity flags
+  let FlagVerbosity verbosity = (verbHandles, copyVerbosity flags)
       mbWorkDir = flagToMaybe $ copyWorkingDir flags
       destArgs = case fromFlag $ copyDest flags of
         NoCopyDest -> ["install"]
@@ -172,15 +175,15 @@ copyAction verbHandles flags args = do
 installAction :: VerbosityHandles -> InstallFlags -> [String] -> IO ()
 installAction verbHandles flags args = do
   noExtraFlags args
-  let verbosity = mkVerbosity verbHandles $ fromFlag $ installVerbosity flags
+  let FlagVerbosity verbosity = (verbHandles, installVerbosity flags)
       mbWorkDir = flagToMaybe $ installWorkingDir flags
   rawSystemExit verbosity mbWorkDir "make" ["install"]
   rawSystemExit verbosity mbWorkDir "make" ["register"]
 
 haddockAction :: VerbosityHandles -> HaddockFlags -> [String] -> IO ()
 haddockAction verbHandles flags args = do
   noExtraFlags args
-  let verbosity = mkVerbosity verbHandles $ fromFlag $ haddockVerbosity flags
+  let FlagVerbosity verbosity = (verbHandles, haddockVerbosity flags)
       mbWorkDir = flagToMaybe $ haddockWorkingDir flags
   rawSystemExit verbosity mbWorkDir "make" ["docs"]
     `catchIO` \_ ->
@@ -189,34 +192,38 @@ haddockAction verbHandles flags args = do
 buildAction :: VerbosityHandles -> BuildFlags -> [String] -> IO ()
 buildAction verbHandles flags args = do
   noExtraFlags args
-  let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags
+  let FlagVerbosity verbosity = (verbHandles, buildVerbosity flags)
       mbWorkDir = flagToMaybe $ buildWorkingDir flags
   rawSystemExit verbosity mbWorkDir "make" []
 
 cleanAction :: VerbosityHandles -> CleanFlags -> [String] -> IO ()
 cleanAction verbHandles flags args = do
   noExtraFlags args
-  let verbosity = mkVerbosity verbHandles $ fromFlag $ cleanVerbosity flags
+  let FlagVerbosity verbosity = (verbHandles, cleanVerbosity flags)
       mbWorkDir = flagToMaybe $ cleanWorkingDir flags
   rawSystemExit verbosity mbWorkDir "make" ["clean"]
 
 sdistAction :: VerbosityHandles -> SDistFlags -> [String] -> IO ()
 sdistAction verbHandles flags args = do
   noExtraFlags args
-  let verbosity = mkVerbosity verbHandles $ fromFlag $ sDistVerbosity flags
+  let FlagVerbosity verbosity = (verbHandles, sDistVerbosity flags)
       mbWorkDir = flagToMaybe $ sDistWorkingDir flags
   rawSystemExit verbosity mbWorkDir "make" ["dist"]
 
 registerAction :: VerbosityHandles -> RegisterFlags -> [String] -> IO ()
 registerAction verbHandles flags args = do
   noExtraFlags args
-  let verbosity = mkVerbosity verbHandles $ fromFlag $ registerVerbosity flags
+  let FlagVerbosity verbosity = (verbHandles, registerVerbosity flags)
       mbWorkDir = flagToMaybe $ registerWorkingDir flags
   rawSystemExit verbosity mbWorkDir "make" ["register"]
 
 unregisterAction :: VerbosityHandles -> RegisterFlags -> [String] -> IO ()
 unregisterAction verbHandles flags args = do
   noExtraFlags args
-  let verbosity = mkVerbosity verbHandles $ fromFlag $ registerVerbosity flags
+  let FlagVerbosity verbosity = (verbHandles, registerVerbosity flags)
       mbWorkDir = flagToMaybe $ registerWorkingDir flags
   rawSystemExit verbosity mbWorkDir "make" ["unregister"]
+
+pattern FlagVerbosity :: Verbosity -> (VerbosityHandles, Last VerbosityFlags)
+pattern FlagVerbosity v <- (uncurry mkVerbosity . fmap fromFlag -> v)
+{-# COMPLETE FlagVerbosity #-}

Cabal/src/Distribution/Simple.hs

@@ -416,7 +416,7 @@ configureAction verbHandles globalFlags hooks flags args = do
           { configCommonFlags = commonFlags'
           }
       mbWorkDir = flagToMaybe $ setupWorkingDir commonFlags'
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags')
+      CommonSetupVerbosity verbosity = (verbHandles, commonFlags')
 
   -- See docs for 'HookedBuildInfo'
   pbi <- preConf hooks args flags'
@@ -472,7 +472,7 @@ getCommonFlags
   -> IO (LocalBuildInfo, CommonSetupFlags)
 getCommonFlags verbHandles globalFlags hooks commonFlags args = do
   distPref <- findDistPrefOrDefault (setupDistPref commonFlags)
-  let verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags)
+  let CommonSetupVerbosity verbosity = (verbHandles, commonFlags)
   lbi <- getBuildConfig globalFlags hooks verbosity distPref
   let common' = configCommonFlags $ configFlags lbi
   return
@@ -491,7 +491,7 @@ getCommonFlags verbHandles globalFlags hooks commonFlags args = do
 buildAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> BuildFlags -> Args -> IO ()
 buildAction verbHandles globalFlags hooks flags args = do
   let common = buildCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
   (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args
   let flags' = flags{buildCommonFlags = common'}
 
@@ -515,7 +515,7 @@ buildAction verbHandles globalFlags hooks flags args = do
 replAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> ReplFlags -> Args -> IO ()
 replAction verbHandles globalFlags hooks flags args = do
   let common = replCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
   (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args
   let flags' = flags{replCommonFlags = common'}
   progs <-
@@ -543,7 +543,7 @@ replAction verbHandles globalFlags hooks flags args = do
 hscolourAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> HscolourFlags -> Args -> IO ()
 hscolourAction verbHandles globalFlags hooks flags args = do
   let common = hscolourCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
   (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args
   let flags' = flags{hscolourCommonFlags = common'}
       distPref = fromFlag $ setupDistPref common'
@@ -561,7 +561,7 @@ hscolourAction verbHandles globalFlags hooks flags args = do
 haddockAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> HaddockFlags -> Args -> IO ()
 haddockAction verbHandles globalFlags hooks flags args = do
   let common = haddockCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
   (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args
   let flags' = flags{haddockCommonFlags = common'}
 
@@ -585,7 +585,7 @@ haddockAction verbHandles globalFlags hooks flags args = do
 cleanAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> CleanFlags -> Args -> IO ()
 cleanAction verbHandles globalFlags hooks flags args = do
   let common = cleanCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
   distPref <- findDistPrefOrDefault (setupDistPref common)
   elbi <- tryGetBuildConfig globalFlags hooks verbosity distPref
   let common' =
@@ -633,7 +633,7 @@ cleanAction verbHandles globalFlags hooks flags args = do
 copyAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> CopyFlags -> Args -> IO ()
 copyAction verbHandles globalFlags hooks flags args = do
   let common = copyCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
   (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args
   let flags' = flags{copyCommonFlags = common'}
       distPref = fromFlag $ setupDistPref common'
@@ -650,7 +650,7 @@ copyAction verbHandles globalFlags hooks flags args = do
 installAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> InstallFlags -> Args -> IO ()
 installAction verbHandles globalFlags hooks flags args = do
   let common = installCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
   (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args
   let flags' = flags{installCommonFlags = common'}
       distPref = fromFlag $ setupDistPref common'
@@ -672,12 +672,12 @@ sdistAction verbHandles _globalFlags _hooks flags _args = do
   let pkg_descr = flattenPackageDescription ppd
   sdist verbHandles pkg_descr flags srcPref knownSuffixHandlers
   where
-    verbosity = mkVerbosity verbHandles $ fromFlag (setupVerbosity $ sDistCommonFlags flags)
+    CommonSetupVerbosity verbosity = (verbHandles, sDistCommonFlags flags)
 
 testAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> TestFlags -> Args -> IO ()
 testAction verbHandles globalFlags hooks flags args = do
   let common = testCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
   (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args
   let flags' = flags{testCommonFlags = common'}
       distPref = fromFlag $ setupDistPref common'
@@ -694,7 +694,7 @@ testAction verbHandles globalFlags hooks flags args = do
 benchAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> BenchmarkFlags -> Args -> IO ()
 benchAction verbHandles globalFlags hooks flags args = do
   let common = benchmarkCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
   (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args
   let flags' = flags{benchmarkCommonFlags = common'}
       distPref = fromFlag $ setupDistPref common'
@@ -711,7 +711,7 @@ benchAction verbHandles globalFlags hooks flags args = do
 registerAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO ()
 registerAction verbHandles globalFlags hooks flags args = do
   let common = registerCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
   (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args
   let flags' = flags{registerCommonFlags = common'}
       distPref = fromFlag $ setupDistPref common'
@@ -728,7 +728,7 @@ registerAction verbHandles globalFlags hooks flags args = do
 unregisterAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO ()
 unregisterAction verbHandles globalFlags hooks flags args = do
   let common = registerCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
   (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args
   let flags' = flags{registerCommonFlags = common'}
       distPref = fromFlag $ setupDistPref common'
@@ -898,7 +898,7 @@ getBuildConfig globalFlags hooks verbosity distPref = do
 clean :: VerbosityHandles -> PackageDescription -> CleanFlags -> IO ()
 clean verbHandles pkg_descr flags = do
   let common = cleanCommonFlags flags
-      verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common))
+      CommonSetupVerbosity verbosity = (verbHandles, common)
       distPref = fromFlagOrDefault defaultDistPref $ setupDistPref common
       mbWorkDir = flagToMaybe $ setupWorkingDir common
       i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path
@@ -956,9 +956,7 @@ simpleUserHooksWithHandles verbHandles =
     finalChecks _args flags pkg_descr lbi =
       checkForeignDeps pkg_descr lbi (modifyVerbosityFlags lessVerbose verbosity)
       where
-        verbosity =
-          mkVerbosity verbHandles $
-            fromFlag (setupVerbosity $ configCommonFlags flags)
+        CommonSetupVerbosity verbosity = (verbHandles, configCommonFlags flags)
 
 -- | Basic autoconf 'UserHooks':
 --
@@ -995,7 +993,7 @@ autoconfUserHooks =
     defaultPostConf args flags pkg_descr lbi =
       do
         let common = configCommonFlags flags
-            verbosity = mkVerbosity defaultVerbosityHandles (fromFlag $ setupVerbosity common)
+            CommonSetupVerbosity verbosity = (defaultVerbosityHandles, common)
             mbWorkDir = flagToMaybe $ setupWorkingDir common
         runConfigureScript
           defaultVerbosityHandles
@@ -1016,7 +1014,7 @@ autoconfUserHooks =
       -> IO HookedBuildInfo
     readHookWithArgs get_common_flags _args flags = do
       let common = get_common_flags flags
-          verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (setupVerbosity common))
+          CommonSetupVerbosity verbosity = (defaultVerbosityHandles, common)
           mbWorkDir = flagToMaybe $ setupWorkingDir common
           distPref = setupDistPref common
       dist_dir <- findDistPrefOrDefault distPref
@@ -1029,7 +1027,7 @@ autoconfUserHooks =
       -> IO HookedBuildInfo
     readHook get_common_flags args flags = do
       let common = get_common_flags flags
-          verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (setupVerbosity common))
+          CommonSetupVerbosity verbosity = (defaultVerbosityHandles, common)
           mbWorkDir = flagToMaybe $ setupWorkingDir common
           distPref = setupDistPref common
       noExtraFlags args
@@ -1216,6 +1214,4 @@ defaultRegHook verbHandles pkg_descr localbuildinfo _ flags
         "Package contains no library to register:"
         (packageId pkg_descr)
   where
-    verbosity =
-      mkVerbosity verbHandles $
-        fromFlag (setupVerbosity $ registerCommonFlags flags)
+    CommonSetupVerbosity verbosity = (verbHandles, registerCommonFlags flags)

Cabal/src/Distribution/Simple/Configure.hs

@@ -2,10 +2,12 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -----------------------------------------------------------------------------
 
@@ -197,6 +199,10 @@ import qualified Data.Maybe as M
 import qualified Data.Set as Set
 import qualified Distribution.Compat.NonEmptySet as NES
 
+pattern ConfigVerbosity :: Verbosity -> (VerbosityHandles, ConfigFlags)
+pattern ConfigVerbosity v <- (fmap configCommonFlags -> CommonSetupVerbosity v)
+{-# COMPLETE ConfigVerbosity #-}
+
 type UseExternalInternalDeps = Bool
 
 -- | The errors that can be thrown when reading the @setup-config@ file.
@@ -784,8 +790,7 @@ computeLocalBuildConfig
   -> ProgramDb
   -> IO LBC.LocalBuildConfig
 computeLocalBuildConfig verbHandles cfg comp programDb = do
-  let common = configCommonFlags cfg
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+  let ConfigVerbosity verbosity = (verbHandles, cfg)
   rawBuildOptions <- buildOptionsFromConfigFlags verbosity cfg comp
   buildOptions <- adjustBuildOptionsAndWarn verbosity comp programDb rawBuildOptions
   return $
@@ -1061,8 +1066,7 @@ configurePackage
   -> PackageDBStack
   -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr)
 configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform packageDbs = do
-  let common = configCommonFlags cfg
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+  let ConfigVerbosity verbosity = (verbHandles, cfg)
       programDb0 = LBC.withPrograms lbc0
 
       -- add extra include/lib dirs as specified in cfg
@@ -1160,9 +1164,8 @@ computePackageInfo
   -> Compiler
   -> IO ([PackageVersionConstraint], PackageInfo)
 computePackageInfo verbHandles cfg lbc0 g_pkg_descr comp = do
-  let common = configCommonFlags cfg
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
-      mbWorkDir = flagToMaybe $ setupWorkingDir common
+  let ConfigVerbosity verbosity = (verbHandles, cfg)
+      mbWorkDir = flagToMaybe . setupWorkingDir $ configCommonFlags cfg
 
   let programDb0 = LBC.withPrograms lbc0
       -- What package database(s) to use
@@ -1235,8 +1238,7 @@ finalizePackageDescription
   -> PackageInfo
   -> IO (PackageDBStack, PackageDescription, FlagAssignment)
 finalizePackageDescription verbHandles cfg g_pkg_descr comp platform enabled allConstraints pkgInfo = do
-  let common = configCommonFlags cfg
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+  let ConfigVerbosity verbosity = (verbHandles, cfg)
 
   -- What package database(s) to use
   let packageDbs :: PackageDBStack
@@ -1351,9 +1353,8 @@ finalCheckPackage
     )
   hookedBuildInfo =
     do
-      let common = configCommonFlags cfg
-          verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
-          cabalFileDir = packageRoot common
+      let ConfigVerbosity verbosity = (verbHandles, cfg)
+          cabalFileDir = packageRoot $ configCommonFlags cfg
 
       checkCompilerProblems verbosity comp pkg_descr enabled
       checkPackageProblems
@@ -1414,8 +1415,7 @@ configureComponents
   promisedDepsSet
   externalPkgDeps =
     do
-      let common = configCommonFlags cfg
-          verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      let ConfigVerbosity verbosity = (verbHandles, cfg)
           use_external_internal_deps =
             case enabled of
               OneComponentRequestedSpec{} -> True
@@ -2649,8 +2649,7 @@ configCompilerAuxEx
   -> IO (Compiler, Platform, ProgramDb)
 configCompilerAuxEx verbHandles cfg = do
   programDb <- mkProgramDb verbHandles cfg defaultProgramDb
-  let common = configCommonFlags cfg
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+  let ConfigVerbosity verbosity = (verbHandles, cfg)
   configCompilerEx
     (flagToMaybe $ configHcFlavor cfg)
     (flagToMaybe $ configHcPath cfg)

Cabal/src/Distribution/Simple/ConfigureScript.hs

@@ -59,7 +59,7 @@ runConfigureScript
   -> IO ()
 runConfigureScript verbHandles cfg flags programDb hp = do
   let commonCfg = configCommonFlags cfg
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonCfg)
+      CommonSetupVerbosity verbosity = (verbHandles, commonCfg)
   dist_dir <- findDistPrefOrDefault $ setupDistPref commonCfg
   let build_dir = dist_dir </> makeRelativePathEx "build"
       mbWorkDir = flagToMaybe $ setupWorkingDir commonCfg

Cabal/src/Distribution/Simple/GHC/Build/Link.hs

@@ -733,7 +733,7 @@ runReplOrWriteFlags ghcProg verbHandles lbi rflags ghcOpts pkg_name target =
       platform = hostPlatform lbi
       common = configCommonFlags $ configFlags lbi
       mbWorkDir = mbWorkDirLBI lbi
-      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      CommonSetupVerbosity verbosity = (verbHandles, common)
       tempFileOptions = commonSetupTempFileOptions common
    in case replOptionsFlagOutput (replReplOptions rflags) of
         NoFlag -> do