From baa24e0b74771c1ff059b714bae131ba0e006b8f 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 | 26 ++++++++++++++++++++++++++ Cabal/Distribution/Simple.hs | 2 +- Cabal/Distribution/Simple/Configure.hs | 8 +++++++- Cabal/Distribution/Simple/Setup.hs | 10 +++++----- 4 files changed, 39 insertions(+), 7 deletions(-) diff --git a/Cabal/Distribution/Compat/Semigroup.hs b/Cabal/Distribution/Compat/Semigroup.hs index 04b30a87f00..cafb98b1be0 100644 --- a/Cabal/Distribution/Compat/Semigroup.hs +++ b/Cabal/Distribution/Compat/Semigroup.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Compatibility layer for "Data.Semigroup" module Distribution.Compat.Semigroup @@ -6,8 +8,13 @@ module Distribution.Compat.Semigroup , Mon.Monoid(..) , All(..) , Any(..) + + , Last'(..) ) where +import GHC.Generics (Generic) +import Data.Binary (Binary) +import Control.Applicative as App #if __GLASGOW_HASKELL__ >= 711 -- Data.Semigroup is available since GHC 8.0/base-4.9 import Data.Semigroup @@ -68,3 +75,22 @@ instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e') #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 = (<>) diff --git a/Cabal/Distribution/Simple.hs b/Cabal/Distribution/Simple.hs index ef58a11a877..2f69dfcd393 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), + <$> 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,