From 62c3aa627c99aefb09605bb59507b925151625dc Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sat, 27 Feb 2016 11:52:07 +0100 Subject: [PATCH] Turn 'configPrograms' field into a 'Last'-monoid This implements the suggestions mentioned at https://github.com/haskell/cabal/issues/3169#issuecomment-189281916 The main benefit of this change is turning 'ConfigFlags' into a uniform product-type suitable for generic derivation of pointwise `Semigroup`/`Monoid` instances. NB: This changes the `Binary` serialisation of `ConfigFlags` since there's now an additional `Maybe` inserted in `configPrograms`'s type --- Cabal/Distribution/Compat/Semigroup.hs | 32 +++++++++++++++++++++++--- Cabal/Distribution/Simple.hs | 2 +- Cabal/Distribution/Simple/Configure.hs | 8 ++++++- Cabal/Distribution/Simple/Setup.hs | 10 ++++---- 4 files changed, 42 insertions(+), 10 deletions(-) diff --git a/Cabal/Distribution/Compat/Semigroup.hs b/Cabal/Distribution/Compat/Semigroup.hs index b0df0a8aeaa..358f6223b61 100644 --- a/Cabal/Distribution/Compat/Semigroup.hs +++ b/Cabal/Distribution/Compat/Semigroup.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} -- | Compatibility layer for "Data.Semigroup" module Distribution.Compat.Semigroup @@ -9,10 +11,15 @@ module Distribution.Compat.Semigroup , All(..) , Any(..) + , Last'(..) + , gmappend , gmempty ) where +import Distribution.Compat.Binary (Binary) + +import Control.Applicative as App import GHC.Generics #if __GLASGOW_HASKELL__ >= 711 -- Data.Semigroup is available since GHC 8.0/base-4.9 @@ -93,6 +100,25 @@ instance Ord k => Semigroup (Map k v) where (<>) = mappend #endif +-- | Cabal's own 'Data.Monoid.Last' copy to avoid requiring an orphan +-- 'Binary' instance. +-- +-- Once the oldest `binary` version we support provides a 'Binary' +-- instance for 'Data.Monoid.Last' we can remove this one here. +-- +-- NB: 'Data.Semigroup.Last' is defined differently and not a 'Monoid' +newtype Last' a = Last' { getLast' :: Maybe a } + deriving (Eq, Ord, Read, Show, Binary, + Functor, App.Applicative, Generic) + +instance Semigroup (Last' a) where + x <> Last' Nothing = x + _ <> x = x + +instance Monoid (Last' a) where + mempty = Last' Nothing + mappend = (<>) + ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- Stolen from Edward Kmett's BSD3-licensed `semigroups` package diff --git a/Cabal/Distribution/Simple.hs b/Cabal/Distribution/Simple.hs index ef58a11a877..47c25d5470f 100644 --- a/Cabal/Distribution/Simple.hs +++ b/Cabal/Distribution/Simple.hs @@ -455,7 +455,7 @@ getBuildConfig hooks verbosity distPref = do -- of a configure run: configPrograms = restoreProgramConfiguration (builtinPrograms ++ hookedPrograms hooks) - (configPrograms cFlags), + `fmap` configPrograms cFlags, -- Use the current, not saved verbosity level: configVerbosity = Flag verbosity diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index ae4ae4e97b5..cdf74faf996 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -125,6 +125,7 @@ import Text.PrettyPrint , quotes, punctuate, nest, sep, hsep ) import Distribution.Compat.Environment ( lookupEnv ) import Distribution.Compat.Exception ( catchExit, catchIO ) +import Distribution.Compat.Semigroup ( Last'(..) ) -- | The errors that can be thrown when reading the @setup-config@ file. data ConfigStateFileError @@ -346,7 +347,7 @@ configure (pkg_descr0', pbi) cfg = do (flagToMaybe (configHcFlavor cfg)) (flagToMaybe (configHcPath cfg)) (flagToMaybe (configHcPkg cfg)) - (mkProgramsConfig cfg (configPrograms cfg)) + (mkProgramsConfig cfg (configPrograms' cfg)) (lessVerbose verbosity) -- The InstalledPackageIndex of all installed packages @@ -686,6 +687,11 @@ configure (pkg_descr0', pbi) cfg = do return (Flag ProfDetailDefault) checkProfDetail other = return other + -- | More convenient version of 'configPrograms'. Results in an + -- 'error' if internal invariant is violated. + configPrograms' :: ConfigFlags -> ProgramConfiguration + configPrograms' = maybe (error "FIXME: remove configPrograms") id . getLast' . configPrograms + mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration mkProgramsConfig cfg initialProgramsConfig = programsConfig where diff --git a/Cabal/Distribution/Simple/Setup.hs b/Cabal/Distribution/Simple/Setup.hs index 03969cc71fe..bfad488e1a4 100644 --- a/Cabal/Distribution/Simple/Setup.hs +++ b/Cabal/Distribution/Simple/Setup.hs @@ -327,8 +327,8 @@ data ConfigFlags = ConfigFlags { -- because the type of configure is constrained by the UserHooks. -- when we change UserHooks next we should pass the initial -- ProgramConfiguration directly and not via ConfigFlags - configPrograms :: ProgramConfiguration, -- ^All programs that cabal may - -- run + configPrograms :: Last' ProgramConfiguration, -- ^All programs that + -- @cabal@ may run configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths configProgramArgs :: [(String, [String])], -- ^user specified programs args @@ -404,7 +404,7 @@ configAbsolutePaths f = defaultConfigFlags :: ProgramConfiguration -> ConfigFlags defaultConfigFlags progConf = emptyConfigFlags { - configPrograms = progConf, + configPrograms = pure progConf, configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, configVanillaLib = Flag True, configProfLib = NoFlag, @@ -812,7 +812,7 @@ emptyConfigFlags = mempty instance Monoid ConfigFlags where mempty = ConfigFlags { - configPrograms = error "FIXME: remove configPrograms", + configPrograms = mempty, configProgramPaths = mempty, configProgramArgs = mempty, configProgramPathExtra = mempty, @@ -862,7 +862,7 @@ instance Monoid ConfigFlags where instance Semigroup ConfigFlags where a <> b = ConfigFlags { - configPrograms = configPrograms b, + configPrograms = combine configPrograms, configProgramPaths = combine configProgramPaths, configProgramArgs = combine configProgramArgs, configProgramPathExtra = combine configProgramPathExtra,