Rodrigo Mesquita pushed to branch wip/romes/24212 at Glasgow Haskell Compiler / GHC Commits: 2594f295 by Rodrigo Mesquita at 2025-07-11T16:07:58+01:00 Fix testsuite and more - - - - - 8 changed files: - compiler/GHC/Driver/Session.hs - compiler/GHC/SysTools/BaseDir.hs - libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - testsuite/tests/ghc-api/settings-escape/T24265.hs - testsuite/tests/ghc-api/settings-escape/T24265.stderr - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -279,7 +279,6 @@ import GHC.Parser (parseIdentifier) import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..)) import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) -import GHC.ResponseFile import GHC.Toolchain import GHC.Toolchain.Program @@ -3570,13 +3569,13 @@ compilerInfo dflags expandDirectories = expandToolDir (toolDir dflags) . expandTopDir (topDir dflags) query :: (Target -> a) -> a query f = f (rawTarget dflags) - queryFlags f = query (escapeArgs . prgFlags . f) + queryFlags f = query (unwords . map escapeArg . prgFlags . f) queryCmd f = expandDirectories (query (prgPath . f)) queryBool = showBool . query queryCmdMaybe, queryFlagsMaybe :: (a -> Program) -> (Target -> Maybe a) -> String queryCmdMaybe p f = expandDirectories (query (maybe "" (prgPath . p) . f)) - queryFlagsMaybe p f = query (maybe "" (escapeArgs . prgFlags . p) . f) + queryFlagsMaybe p f = query (maybe "" (unwords . map escapeArg . prgFlags . p) . f) -- Note [Special unit-ids] -- ~~~~~~~~~~~~~~~~~~~~~~~ @@ -3904,3 +3903,19 @@ updatePlatformConstants dflags mconstants = do let platform1 = (targetPlatform dflags) { platform_constants = mconstants } let dflags1 = dflags { targetPlatform = platform1 } return dflags1 + +-- ---------------------------------------------------------------------------- +-- Escape Args helpers +-- ---------------------------------------------------------------------------- + +-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base. +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs ===================================== compiler/GHC/SysTools/BaseDir.hs ===================================== @@ -124,7 +124,6 @@ expandToolDir #if defined(mingw32_HOST_OS) expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s expandToolDir Nothing _ = panic "Could not determine $tooldir" -expandToolDir _ s = s #else expandToolDir _ s = s #endif @@ -179,7 +178,6 @@ findToolDir top_dir = go 0 (top_dir "..") [] if oneLevel then return (Just path) else go (k+1) (path "..") tried' -findToolDir _ = return Nothing #else findToolDir _ = return Nothing #endif ===================================== libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs ===================================== @@ -20,7 +20,7 @@ module GHC.Internal.ResponseFile ( getArgsWithResponseFiles, unescapeArgs, - escapeArgs, + escapeArgs, escapeArg, expandResponse ) where ===================================== testsuite/tests/ghc-api/settings-escape/T24265.hs ===================================== @@ -16,6 +16,13 @@ import System.Environment import System.IO (hPutStrLn, stderr) import System.Exit (exitWith, ExitCode(ExitFailure)) +import GHC.Toolchain +import GHC.Toolchain.Program +import GHC.Toolchain.Tools.Cc +import GHC.Toolchain.Tools.Cpp +import GHC.Toolchain.Tools.Cxx +import GHC.Toolchain.Lens + -- Precondition: this test case must be executed in a directory with a space. -- -- First we get the current settings file and amend it with extra arguments that we *know* @@ -30,35 +37,29 @@ main :: IO () main = do libdir:_args <- getArgs - (rawSettingOpts, originalSettings) <- runGhc (Just libdir) $ do + (rawSettingOpts, rawTargetOpts, originalSettings) <- runGhc (Just libdir) $ do dflags <- hsc_dflags <$> getSession - pure (rawSettings dflags, settings dflags) + pure (rawSettings dflags, rawTarget dflags, settings dflags) top_dir <- makeAbsolute "./ghc-install-folder/lib with spaces" - let argsWithSpaces = "\"-some option\" -some\\ other" - numberOfExtraArgs = length $ unescapeArgs argsWithSpaces - -- These are all options that can have multiple 'String' or 'Option' values. - -- We explicitly do not add 'C compiler link flags' here, as 'initSettings' - -- already adds the options of "C compiler flags" to this config field. - multipleArguments = Set.fromList - [ "Haskell CPP flags" - , "JavaScript CPP flags" - , "C-- CPP flags" - , "C compiler flags" - , "C++ compiler flags" - , "CPP flags" - , "Merge objects flags" + let argsWithSpaces l = over l (++["-some option", "-some\\ other"]) + numberOfExtraArgs = 2 + -- Test it on a handfull of list of flags + multipleArguments = + [ _tgtHsCpp % _hsCppProg % _prgFlags -- "Haskell CPP flags" + , _tgtCC % _ccProgram % _prgFlags -- "C compiler flags" + , _tgtCxx % _cxxProgram % _prgFlags -- "C++ compiler flags" + , _tgtCpp % _cppProg % _prgFlags -- "CPP flags" ] - let rawSettingOptsWithExtraArgs = - map (\(name, args) -> if Set.member name multipleArguments - then (name, args ++ " " ++ argsWithSpaces) - else (name, args)) rawSettingOpts + targetWithExtraArgs = foldr argsWithSpaces rawTargetOpts multipleArguments -- write out the modified settings. We try to keep it legible writeFile (top_dir ++ "/settings") $ - "[" ++ (intercalate "\n," (map show rawSettingOptsWithExtraArgs)) ++ "]" + "[" ++ (intercalate "\n," (map show rawSettingOpts)) ++ "]" + writeFile (top_dir ++ "/targets/default.target") $ + show targetWithExtraArgs settingsm <- runExceptT $ initSettings top_dir @@ -113,12 +114,6 @@ main = do -- Setting 'Haskell CPP flags' contains '$topdir' reference. -- Resolving those while containing spaces, should not introduce more options. recordSetting "Haskell CPP flags" (map showOpt . snd . toolSettings_pgm_P . sToolSettings) - -- Setting 'JavaScript CPP flags' contains '$topdir' reference. - -- Resolving those while containing spaces, should not introduce more options. - recordSetting "JavaScript CPP flags" (map showOpt . snd . toolSettings_pgm_JSP . sToolSettings) - -- Setting 'C-- CPP flags' contains '$topdir' reference. - -- Resolving those while containing spaces, should not introduce more options. - recordSetting "C-- CPP flags" (map showOpt . snd . toolSettings_pgm_CmmP . sToolSettings) -- Setting 'C compiler flags' contains strings with spaces. -- GHC should not split these by word. recordSetting "C compiler flags" (toolSettings_opt_c . sToolSettings) @@ -133,10 +128,6 @@ main = do -- Setting 'CPP flags' contains strings with spaces. -- GHC should not split these by word. recordSetting "CPP flags" (map showOpt . snd . toolSettings_pgm_cpp . sToolSettings) - -- Setting 'Merge objects flags' contains strings with spaces. - -- GHC should not split these by word. - -- If 'Nothing', ignore this test, otherwise the same assertion holds as before. - recordSettingM "Merge objects flags" (fmap (map showOpt . snd) . toolSettings_pgm_lm . sToolSettings) -- Setting 'C compiler command' contains '$topdir' reference. -- Spaces in the final filepath should not be escaped. recordFpSetting "C compiler" (toolSettings_pgm_c . sToolSettings) ===================================== testsuite/tests/ghc-api/settings-escape/T24265.stderr ===================================== @@ -1,9 +1,5 @@ === 'Haskell CPP flags' contains 2 new entries: True Contains spaces: True -=== 'JavaScript CPP flags' contains 2 new entries: True - Contains spaces: True -=== 'C-- CPP flags' contains 2 new entries: True - Contains spaces: True === 'C compiler flags' contains 2 new entries: True Contains spaces: True === 'C compiler link flags' contains 2 new entries: True @@ -12,5 +8,4 @@ Contains spaces: True === 'CPP flags' contains 2 new entries: True Contains spaces: True -=== 'Merge objects flags' contains expected entries: True === FilePath 'C compiler' contains escaped spaces: False ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -7,6 +7,9 @@ module GHC.Toolchain.Target , WordSize(..), wordSize2Bytes + -- ** Lenses + , _tgtCC, _tgtCxx, _tgtCpp, _tgtHsCpp + -- * Re-exports , ByteOrder(..) ) where @@ -137,3 +140,29 @@ instance Show Target where , ", tgtInstallNameTool = " ++ show tgtInstallNameTool , "}" ] + +-------------------------------------------------------------------------------- +-- Lenses +-------------------------------------------------------------------------------- + +_tgtCC :: Lens Target Cc +_tgtCC = Lens tgtCCompiler (\x o -> o {tgtCCompiler = x}) + +_tgtCxx :: Lens Target Cxx +_tgtCxx = Lens tgtCxxCompiler (\x o -> o {tgtCxxCompiler = x}) + +_tgtCpp :: Lens Target Cpp +_tgtCpp = Lens tgtCPreprocessor (\x o -> o {tgtCPreprocessor = x}) + +_tgtHsCpp :: Lens Target HsCpp +_tgtHsCpp = Lens tgtHsCPreprocessor (\x o -> o {tgtHsCPreprocessor = x}) + +_tgtJsCpp :: Lens Target (Maybe JsCpp) +_tgtJsCpp = Lens tgtJsCPreprocessor (\x o -> o {tgtJsCPreprocessor = x}) + +_tgtCmmCpp :: Lens Target CmmCpp +_tgtCmmCpp = Lens tgtCmmCPreprocessor (\x o -> o {tgtCmmCPreprocessor = x}) + +_tgtMergeObjs :: Lens Target (Maybe MergeObjs) +_tgtMergeObjs = Lens tgtMergeObjs (\x o -> o {tgtMergeObjs = x}) + ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs ===================================== @@ -5,6 +5,9 @@ module GHC.Toolchain.Tools.Cpp , Cpp(..), findCpp , JsCpp(..), findJsCpp , CmmCpp(..), findCmmCpp + + -- * Lenses + , _cppProg, _hsCppProg, _jsCppProg, _cmmCppProg ) where import Control.Monad @@ -188,3 +191,18 @@ findCpp progOpt cc = checking "for C preprocessor" $ do let cppProgram = addFlagIfNew "-E" cpp2 return Cpp{cppProgram} +-------------------------------------------------------------------------------- +-- Lenses +-------------------------------------------------------------------------------- + +_cppProg :: Lens Cpp Program +_cppProg = Lens cppProgram (\x o -> o{cppProgram = x}) + +_hsCppProg :: Lens HsCpp Program +_hsCppProg = Lens hsCppProgram (\x o -> o{hsCppProgram = x}) + +_jsCppProg :: Lens JsCpp Program +_jsCppProg = Lens jsCppProgram (\x o -> o{jsCppProgram = x}) + +_cmmCppProg :: Lens CmmCpp Program +_cmmCppProg = Lens cmmCppProgram (\x o -> o{cmmCppProgram = x}) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs ===================================== @@ -4,7 +4,7 @@ module GHC.Toolchain.Tools.Cxx ( Cxx(..) , findCxx -- * Helpful utilities - , compileCxx + , compileCxx, _cxxProgram ) where import System.FilePath View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2594f2959e00576254d0c6bb329182d0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2594f2959e00576254d0c6bb329182d0... You're receiving this email because of your account on gitlab.haskell.org.