From 62c3aa627c99aefb09605bb59507b925151625dc Mon Sep 17 00:00:00 2001
From: Herbert Valerio Riedel <hvr@gnu.org>
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 b0df0a8aea..358f6223b6 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 ef58a11a87..47c25d5470 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 ae4ae4e97b..cdf74faf99 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 03969cc71f..bfad488e1a 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,
--
GitLab