Rodrigo Mesquita pushed to branch wip/romes/24212 at Glasgow Haskell Compiler / GHC

Commits:

8 changed files:

Changes:

  • compiler/GHC/Driver/Session.hs
    ... ... @@ -279,7 +279,6 @@ import GHC.Parser (parseIdentifier)
    279 279 
     import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..))
    280 280
    281 281 
     import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )
    282 
    -import GHC.ResponseFile
    283 282
    284 283 
     import GHC.Toolchain
    285 284 
     import GHC.Toolchain.Program
    ... ... @@ -3570,13 +3569,13 @@ compilerInfo dflags
    3570 3569 
         expandDirectories = expandToolDir (toolDir dflags) . expandTopDir (topDir dflags)
    3571 3570 
         query :: (Target -> a) -> a
    3572 3571 
         query f = f (rawTarget dflags)
    3573 
    -    queryFlags f = query (escapeArgs . prgFlags . f)
    3572 
    +    queryFlags f = query (unwords . map escapeArg . prgFlags . f)
    3574 3573 
         queryCmd f = expandDirectories (query (prgPath . f))
    3575 3574 
         queryBool = showBool . query
    3576 3575
    3577 3576 
         queryCmdMaybe, queryFlagsMaybe :: (a -> Program) -> (Target -> Maybe a) -> String
    3578 3577 
         queryCmdMaybe p f = expandDirectories (query (maybe "" (prgPath . p) . f))
    3579 
    -    queryFlagsMaybe p f = query (maybe "" (escapeArgs . prgFlags . p) . f)
    3578 
    +    queryFlagsMaybe p f = query (maybe "" (unwords . map escapeArg . prgFlags . p) . f)
    3580 3579
    3581 3580 
     -- Note [Special unit-ids]
    3582 3581 
     -- ~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -3904,3 +3903,19 @@ updatePlatformConstants dflags mconstants = do
    3904 3903 
       let platform1 = (targetPlatform dflags) { platform_constants = mconstants }
    3905 3904 
       let dflags1   = dflags { targetPlatform = platform1 }
    3906 3905 
       return dflags1
    3906 
    +
    3907 
    +-- ----------------------------------------------------------------------------
    3908 
    +-- Escape Args helpers
    3909 
    +-- ----------------------------------------------------------------------------
    3910 
    +
    3911 
    +-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base.
    3912 
    +escapeArg :: String -> String
    3913 
    +escapeArg = reverse . foldl' escape []
    3914 
    +
    3915 
    +escape :: String -> Char -> String
    3916 
    +escape cs c
    3917 
    +  |    isSpace c
    3918 
    +    || '\\' == c
    3919 
    +    || '\'' == c
    3920 
    +    || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result
    3921 
    +  | otherwise    = c:cs

  • compiler/GHC/SysTools/BaseDir.hs
    ... ... @@ -124,7 +124,6 @@ expandToolDir
    124 124 
     #if defined(mingw32_HOST_OS)
    125 125 
     expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s
    126 126 
     expandToolDir Nothing         _ = panic "Could not determine $tooldir"
    127 
    -expandToolDir _               s = s
    128 127 
     #else
    129 128 
     expandToolDir _ s = s
    130 129 
     #endif
    ... ... @@ -179,7 +178,6 @@ findToolDir top_dir = go 0 (top_dir </> "..") []
    179 178 
                   if oneLevel
    180 179 
                     then return (Just path)
    181 180 
                     else go (k+1) (path </> "..") tried'
    182 
    -findToolDir _ = return Nothing
    183 181 
     #else
    184 182 
     findToolDir _ = return Nothing
    185 183 
     #endif

  • libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs
    ... ... @@ -20,7 +20,7 @@
    20 20 
     module GHC.Internal.ResponseFile (
    21 21 
         getArgsWithResponseFiles,
    22 22 
         unescapeArgs,
    23 
    -    escapeArgs,
    23 
    +    escapeArgs, escapeArg,
    24 24 
         expandResponse
    25 25 
       ) where
    26 26

  • testsuite/tests/ghc-api/settings-escape/T24265.hs
    ... ... @@ -16,6 +16,13 @@ import System.Environment
    16 16 
     import System.IO (hPutStrLn, stderr)
    17 17 
     import System.Exit (exitWith, ExitCode(ExitFailure))
    18 18
    19 
    +import GHC.Toolchain
    20 
    +import GHC.Toolchain.Program
    21 
    +import GHC.Toolchain.Tools.Cc
    22 
    +import GHC.Toolchain.Tools.Cpp
    23 
    +import GHC.Toolchain.Tools.Cxx
    24 
    +import GHC.Toolchain.Lens
    25 
    +
    19 26 
     -- Precondition: this test case must be executed in a directory with a space.
    20 27 
     --
    21 28 
     -- First we get the current settings file and amend it with extra arguments that we *know*
    ... ... @@ -30,35 +37,29 @@ main :: IO ()
    30 37 
     main = do
    31 38 
       libdir:_args <- getArgs
    32 39
    33 
    -  (rawSettingOpts, originalSettings) <- runGhc (Just libdir) $ do
    40 
    +  (rawSettingOpts, rawTargetOpts, originalSettings) <- runGhc (Just libdir) $ do
    34 41 
         dflags <- hsc_dflags <$> getSession
    35 
    -    pure (rawSettings dflags, settings dflags)
    42 
    +    pure (rawSettings dflags, rawTarget dflags, settings dflags)
    36 43
    37 44 
       top_dir <- makeAbsolute "./ghc-install-folder/lib with spaces"
    38 45
    39 
    -  let argsWithSpaces = "\"-some option\" -some\\ other"
    40 
    -      numberOfExtraArgs = length $ unescapeArgs argsWithSpaces
    41 
    -      -- These are all options that can have multiple 'String' or 'Option' values.
    42 
    -      -- We explicitly do not add 'C compiler link flags' here, as 'initSettings'
    43 
    -      -- already adds the options of "C compiler flags" to this config field.
    44 
    -      multipleArguments = Set.fromList
    45 
    -        [ "Haskell CPP flags"
    46 
    -        , "JavaScript CPP flags"
    47 
    -        , "C-- CPP flags"
    48 
    -        , "C compiler flags"
    49 
    -        , "C++ compiler flags"
    50 
    -        , "CPP flags"
    51 
    -        , "Merge objects flags"
    46 
    +  let argsWithSpaces l = over l (++["-some option", "-some\\ other"])
    47 
    +      numberOfExtraArgs = 2
    48 
    +      -- Test it on a handfull of list of flags
    49 
    +      multipleArguments =
    50 
    +        [ _tgtHsCpp % _hsCppProg  % _prgFlags -- "Haskell CPP flags"
    51 
    +        , _tgtCC    % _ccProgram  % _prgFlags -- "C compiler flags"
    52 
    +        , _tgtCxx   % _cxxProgram % _prgFlags -- "C++ compiler flags"
    53 
    +        , _tgtCpp   % _cppProg    % _prgFlags -- "CPP flags"
    52 54 
             ]
    53 55
    54 
    -  let rawSettingOptsWithExtraArgs =
    55 
    -        map (\(name, args) -> if Set.member name multipleArguments
    56 
    -          then (name, args ++ " " ++ argsWithSpaces)
    57 
    -          else (name, args)) rawSettingOpts
    56 
    +      targetWithExtraArgs = foldr argsWithSpaces rawTargetOpts multipleArguments
    58 57
    59 58 
       -- write out the modified settings. We try to keep it legible
    60 59 
       writeFile (top_dir ++ "/settings") $
    61 
    -    "[" ++ (intercalate "\n," (map show rawSettingOptsWithExtraArgs)) ++ "]"
    60 
    +    "[" ++ (intercalate "\n," (map show rawSettingOpts)) ++ "]"
    61 
    +  writeFile (top_dir ++ "/targets/default.target") $
    62 
    +    show targetWithExtraArgs
    62 63
    63 64 
       settingsm <- runExceptT $ initSettings top_dir
    64 65
    ... ... @@ -113,12 +114,6 @@ main = do
    113 114 
           -- Setting 'Haskell CPP flags' contains '$topdir' reference.
    114 115 
           -- Resolving those while containing spaces, should not introduce more options.
    115 116 
           recordSetting "Haskell CPP flags" (map showOpt . snd . toolSettings_pgm_P . sToolSettings)
    116 
    -      -- Setting 'JavaScript CPP flags' contains '$topdir' reference.
    117 
    -      -- Resolving those while containing spaces, should not introduce more options.
    118 
    -      recordSetting "JavaScript CPP flags" (map showOpt . snd . toolSettings_pgm_JSP . sToolSettings)
    119 
    -      -- Setting 'C-- CPP flags' contains '$topdir' reference.
    120 
    -      -- Resolving those while containing spaces, should not introduce more options.
    121 
    -      recordSetting "C-- CPP flags" (map showOpt . snd . toolSettings_pgm_CmmP . sToolSettings)
    122 117 
           -- Setting 'C compiler flags' contains strings with spaces.
    123 118 
           -- GHC should not split these by word.
    124 119 
           recordSetting "C compiler flags" (toolSettings_opt_c . sToolSettings)
    ... ... @@ -133,10 +128,6 @@ main = do
    133 128 
           -- Setting 'CPP flags' contains strings with spaces.
    134 129 
           -- GHC should not split these by word.
    135 130 
           recordSetting "CPP flags" (map showOpt . snd . toolSettings_pgm_cpp . sToolSettings)
    136 
    -      -- Setting 'Merge objects flags' contains strings with spaces.
    137 
    -      -- GHC should not split these by word.
    138 
    -      -- If 'Nothing', ignore this test, otherwise the same assertion holds as before.
    139 
    -      recordSettingM "Merge objects flags" (fmap (map showOpt . snd) . toolSettings_pgm_lm . sToolSettings)
    140 131 
           -- Setting 'C compiler command' contains '$topdir' reference.
    141 132 
           -- Spaces in the final filepath should not be escaped.
    142 133 
           recordFpSetting "C compiler" (toolSettings_pgm_c . sToolSettings)

  • testsuite/tests/ghc-api/settings-escape/T24265.stderr
    1 1 
     === 'Haskell CPP flags' contains 2 new entries: True
    2 2 
         Contains spaces: True
    3 
    -=== 'JavaScript CPP flags' contains 2 new entries: True
    4 
    -    Contains spaces: True
    5 
    -=== 'C-- CPP flags' contains 2 new entries: True
    6 
    -    Contains spaces: True
    7 3 
     === 'C compiler flags' contains 2 new entries: True
    8 4 
         Contains spaces: True
    9 5 
     === 'C compiler link flags' contains 2 new entries: True
    ... ... @@ -12,5 +8,4 @@
    12 8 
         Contains spaces: True
    13 9 
     === 'CPP flags' contains 2 new entries: True
    14 10 
         Contains spaces: True
    15 
    -=== 'Merge objects flags' contains expected entries: True
    16 11 
     === FilePath 'C compiler' contains escaped spaces: False

  • utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
    ... ... @@ -7,6 +7,9 @@ module GHC.Toolchain.Target
    7 7
    8 8 
       , WordSize(..), wordSize2Bytes
    9 9
    10 
    +    -- ** Lenses
    11 
    +  , _tgtCC, _tgtCxx, _tgtCpp, _tgtHsCpp
    12 
    +
    10 13 
         -- * Re-exports
    11 14 
       , ByteOrder(..)
    12 15 
       ) where
    ... ... @@ -137,3 +140,29 @@ instance Show Target where
    137 140 
         , ", tgtInstallNameTool = " ++ show tgtInstallNameTool
    138 141 
         , "}"
    139 142 
         ]
    143 
    +
    144 
    +--------------------------------------------------------------------------------
    145 
    +-- Lenses
    146 
    +--------------------------------------------------------------------------------
    147 
    +
    148 
    +_tgtCC :: Lens Target Cc
    149 
    +_tgtCC = Lens tgtCCompiler (\x o -> o {tgtCCompiler = x})
    150 
    +
    151 
    +_tgtCxx :: Lens Target Cxx
    152 
    +_tgtCxx = Lens tgtCxxCompiler (\x o -> o {tgtCxxCompiler = x})
    153 
    +
    154 
    +_tgtCpp :: Lens Target Cpp
    155 
    +_tgtCpp = Lens tgtCPreprocessor (\x o -> o {tgtCPreprocessor = x})
    156 
    +
    157 
    +_tgtHsCpp :: Lens Target HsCpp
    158 
    +_tgtHsCpp = Lens tgtHsCPreprocessor (\x o -> o {tgtHsCPreprocessor = x})
    159 
    +
    160 
    +_tgtJsCpp :: Lens Target (Maybe JsCpp)
    161 
    +_tgtJsCpp = Lens tgtJsCPreprocessor (\x o -> o {tgtJsCPreprocessor = x})
    162 
    +
    163 
    +_tgtCmmCpp :: Lens Target CmmCpp
    164 
    +_tgtCmmCpp = Lens tgtCmmCPreprocessor (\x o -> o {tgtCmmCPreprocessor = x})
    165 
    +
    166 
    +_tgtMergeObjs :: Lens Target (Maybe MergeObjs)
    167 
    +_tgtMergeObjs = Lens tgtMergeObjs (\x o -> o {tgtMergeObjs = x})
    168 
    +

  • utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs
    ... ... @@ -5,6 +5,9 @@ module GHC.Toolchain.Tools.Cpp
    5 5 
       , Cpp(..), findCpp
    6 6 
       , JsCpp(..), findJsCpp
    7 7 
       , CmmCpp(..), findCmmCpp
    8 
    +
    9 
    +    -- * Lenses
    10 
    +  , _cppProg, _hsCppProg, _jsCppProg, _cmmCppProg
    8 11 
       ) where
    9 12
    10 13 
     import Control.Monad
    ... ... @@ -188,3 +191,18 @@ findCpp progOpt cc = checking "for C preprocessor" $ do
    188 191 
       let cppProgram = addFlagIfNew "-E" cpp2
    189 192 
       return Cpp{cppProgram}
    190 193
    194 
    +--------------------------------------------------------------------------------
    195 
    +-- Lenses
    196 
    +--------------------------------------------------------------------------------
    197 
    +
    198 
    +_cppProg :: Lens Cpp Program
    199 
    +_cppProg = Lens cppProgram (\x o -> o{cppProgram = x})
    200 
    +
    201 
    +_hsCppProg :: Lens HsCpp Program
    202 
    +_hsCppProg = Lens hsCppProgram (\x o -> o{hsCppProgram = x})
    203 
    +
    204 
    +_jsCppProg :: Lens JsCpp Program
    205 
    +_jsCppProg = Lens jsCppProgram (\x o -> o{jsCppProgram = x})
    206 
    +
    207 
    +_cmmCppProg :: Lens CmmCpp Program
    208 
    +_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
    4 4 
         ( Cxx(..)
    5 5 
         , findCxx
    6 6 
           -- * Helpful utilities
    7 
    -    , compileCxx
    7 
    +    , compileCxx, _cxxProgram
    8 8 
         ) where
    9 9
    10 10 
     import System.FilePath

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help