From 723b1f56468b5966fae22f603ac8c67a1d6a374b Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 30 Dec 2022 16:39:19 -0500 Subject: [PATCH] Factor out configure script logic to separate module for clarity The new module is private for now. --- Cabal/Cabal.cabal | 1 + Cabal/src/Distribution/Simple.hs | 164 +-------------- .../Distribution/Simple/ConfigureScript.hs | 195 ++++++++++++++++++ changelog.d/pr-8648 | 12 ++ 4 files changed, 210 insertions(+), 162 deletions(-) create mode 100644 Cabal/src/Distribution/Simple/ConfigureScript.hs create mode 100644 changelog.d/pr-8648 diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index b03d460ac24..c75d24df967 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -325,6 +325,7 @@ library Distribution.Simple.GHC.EnvironmentParser Distribution.Simple.GHC.Internal Distribution.Simple.GHC.ImplInfo + Distribution.Simple.ConfigureScript Distribution.ZinzaPrelude Paths_Cabal diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs index 1e6a9b00ef6..77ba089fa98 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/Cabal/src/Distribution/Simple.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple @@ -70,7 +69,6 @@ import Distribution.PackageDescription import Distribution.PackageDescription.Configuration import Distribution.Simple.PackageDescription import Distribution.Simple.Program -import Distribution.Simple.Program.Db import Distribution.Simple.PreProcess import Distribution.Simple.Setup import Distribution.Simple.Command @@ -81,6 +79,7 @@ import Distribution.Simple.Register import Distribution.Simple.Configure +import Distribution.Simple.ConfigureScript import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Bench import Distribution.Simple.BuildPaths @@ -88,33 +87,21 @@ import Distribution.Simple.Test import Distribution.Simple.Install import Distribution.Simple.Haddock import Distribution.Simple.Utils -import Distribution.Utils.NubList import Distribution.Verbosity import Language.Haskell.Extension import Distribution.Version import Distribution.License import Distribution.Pretty -import Distribution.System (buildPlatform) -- Base import System.Environment (getArgs, getProgName) import System.Directory (removeFile, doesFileExist ,doesDirectoryExist, removeDirectoryRecursive) -import System.FilePath (searchPathSeparator, takeDirectory, (), - splitDirectories, dropDrive) -#ifdef mingw32_HOST_OS -import System.FilePath (normalise, splitDrive) -#endif +import System.FilePath (takeDirectory, ()) import Distribution.Compat.ResponseFile (expandResponse) -import Distribution.Compat.Directory (makeAbsolute) -import Distribution.Compat.Environment (getEnvironment) -import Distribution.Compat.GetShortPathName (getShortPathName) import Data.List (unionBy, (\\)) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map as Map - -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the -- action specified on the command line. @@ -648,153 +635,6 @@ autoconfUserHooks where verbosity = fromFlag (get_verbosity flags) -runConfigureScript :: Verbosity -> ConfigFlags -> LocalBuildInfo - -> IO () -runConfigureScript verbosity flags lbi = do - env <- getEnvironment - let programDb = withPrograms lbi - (ccProg, ccFlags) <- configureCCompiler verbosity programDb - ccProgShort <- getShortPathName ccProg - -- The C compiler's compilation and linker flags (e.g. - -- "C compiler flags" and "Gcc Linker flags" from GHC) have already - -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS - -- to ccFlags - -- We don't try and tell configure which ld to use, as we don't have - -- a way to pass its flags too - configureFile <- makeAbsolute $ - fromMaybe "." (takeDirectory <$> cabalFilePath lbi) "configure" - -- autoconf is fussy about filenames, and has a set of forbidden - -- characters that can't appear in the build directory, etc: - -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions - -- - -- This has caused hard-to-debug failures in the past (#5368), so we - -- detect some cases early and warn with a clear message. Windows's - -- use of backslashes is problematic here, so we'll switch to - -- slashes, but we do still want to fail on backslashes in POSIX - -- paths. - -- - -- TODO: We don't check for colons, tildes or leading dashes. We - -- also should check the builddir's path, destdir, and all other - -- paths as well. - let configureFile' = toUnix configureFile - for_ badAutoconfCharacters $ \(c, cname) -> - when (c `elem` dropDrive configureFile') $ - warn verbosity $ concat - [ "The path to the './configure' script, '", configureFile' - , "', contains the character '", [c], "' (", cname, ")." - , " This may cause the script to fail with an obscure error, or for" - , " building the package to fail later." - ] - - let -- Convert a flag name to name of environment variable to represent its - -- value for the configure script. - flagEnvVar :: FlagName -> String - flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag) - where f c - | isAlphaNum c = c - | otherwise = '_' - -- A map from such env vars to every flag name and value where the name - -- name maps to that that env var. - cabalFlagMap :: Map String (NonEmpty (FlagName, Bool)) - cabalFlagMap = Map.fromListWith (<>) - [ (flagEnvVar flag, (flag, bool) :| []) - | (flag, bool) <- unFlagAssignment $ flagAssignment lbi - ] - -- A map from env vars to flag names to the single flag we will go with - cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <- - flip Map.traverseWithKey cabalFlagMap $ \ envVar -> \case - -- No conflict: no problem - singleFlag :| [] -> pure singleFlag - -- Conflict: warn and discard all but first - collidingFlags@(firstFlag :| _ : _) -> do - let quote s = "'" ++ s ++ "'" - toName = quote . unFlagName . fst - renderedList = intercalate ", " $ NonEmpty.toList $ toName <$> collidingFlags - warn verbosity $ unwords - [ "Flags", renderedList, "all map to the same environment variable" - , quote envVar, "causing a collision." - , "The value first flag", toName firstFlag, "will be used." - ] - pure firstFlag - - let cabalFlagEnv = [ (envVar, Just val) - | (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted - , let val = if bool then "1" else "0" - ] ++ - [ ( "CABAL_FLAGS" - , Just $ unwords [ showFlagValue fv | fv <- unFlagAssignment $ flagAssignment lbi ] - ) - ] - let extraPath = fromNubList $ configProgramPathExtra flags - let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) - $ lookup "CFLAGS" env - spSep = [searchPathSeparator] - pathEnv = maybe (intercalate spSep extraPath) - ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env - overEnv = ("CFLAGS", Just cflagsEnv) : - [("PATH", Just pathEnv) | not (null extraPath)] ++ - cabalFlagEnv - hp = hostPlatform lbi - maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] - args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag - shProg = simpleProgram "sh" - progDb = modifyProgramSearchPath - (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb - shConfiguredProg <- lookupProgram shProg - `fmap` configureProgram verbosity shProg progDb - case shConfiguredProg of - Just sh -> runProgramInvocation verbosity $ - (programInvocation (sh {programOverrideEnv = overEnv}) args') - { progInvokeCwd = Just (buildDir lbi) } - Nothing -> die' verbosity notFoundMsg - where - args = configureArgs backwardsCompatHack flags - backwardsCompatHack = False - - notFoundMsg = "The package has a './configure' script. " - ++ "If you are on Windows, This requires a " - ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. " - ++ "If you are not on Windows, ensure that an 'sh' command " - ++ "is discoverable in your path." - --- | Convert Windows path to Unix ones -toUnix :: String -> String -#ifdef mingw32_HOST_OS -toUnix s = let tmp = normalise s - (l, rest) = case splitDrive tmp of - ([], x) -> ("/" , x) - (h:_, x) -> ('/':h:"/", x) - parts = splitDirectories rest - in l ++ intercalate "/" parts -#else -toUnix s = intercalate "/" $ splitDirectories s -#endif - -badAutoconfCharacters :: [(Char, String)] -badAutoconfCharacters = - [ (' ', "space") - , ('\t', "tab") - , ('\n', "newline") - , ('\0', "null") - , ('"', "double quote") - , ('#', "hash") - , ('$', "dollar sign") - , ('&', "ampersand") - , ('\'', "single quote") - , ('(', "left bracket") - , (')', "right bracket") - , ('*', "star") - , (';', "semicolon") - , ('<', "less-than sign") - , ('=', "equals sign") - , ('>', "greater-than sign") - , ('?', "question mark") - , ('[', "left square bracket") - , ('\\', "backslash") - , ('`', "backtick") - , ('|', "pipe") - ] - getHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo getHookedBuildInfo verbosity build_dir = do maybe_infoFile <- findHookedPackageDesc verbosity build_dir diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs new file mode 100644 index 00000000000..9c3e5c8874b --- /dev/null +++ b/Cabal/src/Distribution/Simple/ConfigureScript.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.ConfigureScript +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Distribution.Simple.ConfigureScript ( + runConfigureScript + ) where + +import Prelude () +import Distribution.Compat.Prelude + +-- local +import Distribution.PackageDescription +import Distribution.Simple.Program +import Distribution.Simple.Program.Db +import Distribution.Simple.Setup + +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Utils +import Distribution.Utils.NubList +import Distribution.Verbosity +import Distribution.Pretty +import Distribution.System (buildPlatform) + +-- Base +import System.FilePath (searchPathSeparator, takeDirectory, (), + splitDirectories, dropDrive) +#ifdef mingw32_HOST_OS +import System.FilePath (normalise, splitDrive) +#endif +import Distribution.Compat.Directory (makeAbsolute) +import Distribution.Compat.Environment (getEnvironment) +import Distribution.Compat.GetShortPathName (getShortPathName) + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map + +runConfigureScript :: Verbosity -> ConfigFlags -> LocalBuildInfo + -> IO () +runConfigureScript verbosity flags lbi = do + env <- getEnvironment + let programDb = withPrograms lbi + (ccProg, ccFlags) <- configureCCompiler verbosity programDb + ccProgShort <- getShortPathName ccProg + -- The C compiler's compilation and linker flags (e.g. + -- "C compiler flags" and "Gcc Linker flags" from GHC) have already + -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS + -- to ccFlags + -- We don't try and tell configure which ld to use, as we don't have + -- a way to pass its flags too + configureFile <- makeAbsolute $ + fromMaybe "." (takeDirectory <$> cabalFilePath lbi) "configure" + -- autoconf is fussy about filenames, and has a set of forbidden + -- characters that can't appear in the build directory, etc: + -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions + -- + -- This has caused hard-to-debug failures in the past (#5368), so we + -- detect some cases early and warn with a clear message. Windows's + -- use of backslashes is problematic here, so we'll switch to + -- slashes, but we do still want to fail on backslashes in POSIX + -- paths. + -- + -- TODO: We don't check for colons, tildes or leading dashes. We + -- also should check the builddir's path, destdir, and all other + -- paths as well. + let configureFile' = toUnix configureFile + for_ badAutoconfCharacters $ \(c, cname) -> + when (c `elem` dropDrive configureFile') $ + warn verbosity $ concat + [ "The path to the './configure' script, '", configureFile' + , "', contains the character '", [c], "' (", cname, ")." + , " This may cause the script to fail with an obscure error, or for" + , " building the package to fail later." + ] + + let -- Convert a flag name to name of environment variable to represent its + -- value for the configure script. + flagEnvVar :: FlagName -> String + flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag) + where f c + | isAlphaNum c = c + | otherwise = '_' + -- A map from such env vars to every flag name and value where the name + -- name maps to that that env var. + cabalFlagMap :: Map String (NonEmpty (FlagName, Bool)) + cabalFlagMap = Map.fromListWith (<>) + [ (flagEnvVar flag, (flag, bool) :| []) + | (flag, bool) <- unFlagAssignment $ flagAssignment lbi + ] + -- A map from env vars to flag names to the single flag we will go with + cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <- + flip Map.traverseWithKey cabalFlagMap $ \ envVar -> \case + -- No conflict: no problem + singleFlag :| [] -> pure singleFlag + -- Conflict: warn and discard all but first + collidingFlags@(firstFlag :| _ : _) -> do + let quote s = "'" ++ s ++ "'" + toName = quote . unFlagName . fst + renderedList = intercalate ", " $ NonEmpty.toList $ toName <$> collidingFlags + warn verbosity $ unwords + [ "Flags", renderedList, "all map to the same environment variable" + , quote envVar, "causing a collision." + , "The value first flag", toName firstFlag, "will be used." + ] + pure firstFlag + + let cabalFlagEnv = [ (envVar, Just val) + | (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted + , let val = if bool then "1" else "0" + ] ++ + [ ( "CABAL_FLAGS" + , Just $ unwords [ showFlagValue fv | fv <- unFlagAssignment $ flagAssignment lbi ] + ) + ] + let extraPath = fromNubList $ configProgramPathExtra flags + let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) + $ lookup "CFLAGS" env + spSep = [searchPathSeparator] + pathEnv = maybe (intercalate spSep extraPath) + ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env + overEnv = ("CFLAGS", Just cflagsEnv) : + [("PATH", Just pathEnv) | not (null extraPath)] ++ + cabalFlagEnv + hp = hostPlatform lbi + maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] + args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag + shProg = simpleProgram "sh" + progDb = modifyProgramSearchPath + (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + shConfiguredProg <- lookupProgram shProg + `fmap` configureProgram verbosity shProg progDb + case shConfiguredProg of + Just sh -> runProgramInvocation verbosity $ + (programInvocation (sh {programOverrideEnv = overEnv}) args') + { progInvokeCwd = Just (buildDir lbi) } + Nothing -> die' verbosity notFoundMsg + where + args = configureArgs backwardsCompatHack flags + backwardsCompatHack = False + + notFoundMsg = "The package has a './configure' script. " + ++ "If you are on Windows, This requires a " + ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. " + ++ "If you are not on Windows, ensure that an 'sh' command " + ++ "is discoverable in your path." + +-- | Convert Windows path to Unix ones +toUnix :: String -> String +#ifdef mingw32_HOST_OS +toUnix s = let tmp = normalise s + (l, rest) = case splitDrive tmp of + ([], x) -> ("/" , x) + (h:_, x) -> ('/':h:"/", x) + parts = splitDirectories rest + in l ++ intercalate "/" parts +#else +toUnix s = intercalate "/" $ splitDirectories s +#endif + +badAutoconfCharacters :: [(Char, String)] +badAutoconfCharacters = + [ (' ', "space") + , ('\t', "tab") + , ('\n', "newline") + , ('\0', "null") + , ('"', "double quote") + , ('#', "hash") + , ('$', "dollar sign") + , ('&', "ampersand") + , ('\'', "single quote") + , ('(', "left bracket") + , (')', "right bracket") + , ('*', "star") + , (';', "semicolon") + , ('<', "less-than sign") + , ('=', "equals sign") + , ('>', "greater-than sign") + , ('?', "question mark") + , ('[', "left square bracket") + , ('\\', "backslash") + , ('`', "backtick") + , ('|', "pipe") + ] diff --git a/changelog.d/pr-8648 b/changelog.d/pr-8648 new file mode 100644 index 00000000000..4a5a4693e15 --- /dev/null +++ b/changelog.d/pr-8648 @@ -0,0 +1,12 @@ +synopsis: Tiny refactor of how Cabal handles configure scripts +packages: Cabal +prs: #8648 + +description: { +None of this is visible downstream + +- Remove needless parameter on one private function. + +- Move another internal function (and ones that only it uses from the same module) to new private module. + +}