From 288acca209fb80ff5914ce42ebf0290a80ae8cbd Mon Sep 17 00:00:00 2001 From: Mikhail Glushenkov Date: Thu, 8 Nov 2018 21:07:32 +0000 Subject: [PATCH] Merge pull request #5589 from merijn/master Cleans up the `-Werror` check, adds GHC 8.6.1 support and also filters RTS flags, fixing #5575 (cherry picked from commit e263e8cb911ecc300610df082faf77e00aff5372) --- Cabal/Distribution/Simple/Program/GHC.hs | 139 +++++++++++++++++------ 1 file changed, 107 insertions(+), 32 deletions(-) diff --git a/Cabal/Distribution/Simple/Program/GHC.hs b/Cabal/Distribution/Simple/Program/GHC.hs index 8d8c052968a..fc450229b27 100644 --- a/Cabal/Distribution/Simple/Program/GHC.hs +++ b/Cabal/Distribution/Simple/Program/GHC.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Simple.Program.GHC ( GhcOptions(..), @@ -42,58 +43,73 @@ import Language.Haskell.Extension import Data.List (stripPrefix) import qualified Data.Map as Map -import Data.Monoid (All(..), Any(..), Endo(..), First(..)) +import Data.Monoid (All(..), Any(..), Endo(..), First(..), Last(..)) import Data.Set (Set) import qualified Data.Set as Set normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs | ghcVersion `withinRange` supportedGHCVersions - = argumentFilters $ filter simpleFilters ghcArgs + = argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs where supportedGHCVersions :: VersionRange supportedGHCVersions = intersectVersionRanges (orLaterVersion (mkVersion [8,0])) - (earlierVersion (mkVersion [8,5])) + (earlierVersion (mkVersion [8,7])) from :: Monoid m => [Int] -> m -> m from version flags | ghcVersion `withinRange` orLaterVersion (mkVersion version) = flags | otherwise = mempty - checkComponentWarnings :: (a -> BuildInfo) -> [a] -> All - checkComponentWarnings getInfo = foldMap $ checkComponent . getInfo - where - checkComponent :: BuildInfo -> All - checkComponent = - foldMap checkWarnings . filterGhcOptions . allBuildInfoOptions + to :: Monoid m => [Int] -> m -> m + to version flags + | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags + | otherwise = mempty - allBuildInfoOptions :: BuildInfo -> [(CompilerFlavor, [String])] - allBuildInfoOptions = - mconcat [options, profOptions, sharedOptions, staticOptions] + checkGhcFlags :: forall m . Monoid m => ([String] -> m) -> m + checkGhcFlags fun = mconcat + [ fun ghcArgs + , checkComponentFlags libBuildInfo pkgLibs + , checkComponentFlags buildInfo executables + , checkComponentFlags testBuildInfo testSuites + , checkComponentFlags benchmarkBuildInfo benchmarks + ] + where + pkgLibs = maybeToList library ++ subLibraries - filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]] - filterGhcOptions l = [opts | (GHC, opts) <- l] + checkComponentFlags :: (a -> BuildInfo) -> [a] -> m + checkComponentFlags getInfo = foldMap (checkComponent . getInfo) + where + checkComponent :: BuildInfo -> m + checkComponent = foldMap fun . filterGhcOptions . allGhcOptions - libs, exes, tests, benches :: All - libs = checkComponentWarnings libBuildInfo $ - maybeToList library ++ subLibraries + allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])] + allGhcOptions = + mconcat [options, profOptions, sharedOptions, staticOptions] - exes = checkComponentWarnings buildInfo $ executables - tests = checkComponentWarnings testBuildInfo $ testSuites - benches = checkComponentWarnings benchmarkBuildInfo $ benchmarks + filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]] + filterGhcOptions l = [opts | (GHC, opts) <- l] safeToFilterWarnings :: Bool - safeToFilterWarnings = getAll $ mconcat - [checkWarnings ghcArgs, libs, exes, tests, benches] - - checkWarnings :: [String] -> All - checkWarnings = All . Set.null . foldr alter Set.empty + safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings where + checkWarnings :: [String] -> All + checkWarnings = All . Set.null . foldr alter Set.empty + alter :: String -> Set String -> Set String alter flag = appEndo $ mconcat [ \s -> Endo $ if s == "-Werror" then Set.insert s else id , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id + , \s -> from [8,6] . Endo $ + if s == "-Werror=compat" + then Set.union compatWarningSet else id + , \s -> from [8,6] . Endo $ + if s == "-Wno-error=compat" + then (`Set.difference` compatWarningSet) else id + , \s -> from [8,6] . Endo $ + if s == "-Wwarn=compat" + then (`Set.difference` compatWarningSet) else id , from [8,4] $ markFlag "-Werror=" Set.insert , from [8,4] $ markFlag "-Wwarn=" Set.delete , from [8,4] $ markFlag "-Wno-error=" Set.delete @@ -105,7 +121,7 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs -> String -> Endo (Set String) markFlag name update flag = Endo $ case stripPrefix name flag of - Just rest | not (null rest) -> update rest + Just rest | not (null rest) && rest /= "compat" -> update rest _ -> id flagArgumentFilter :: [String] -> [String] -> [String] @@ -128,7 +144,20 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs Nothing -> arg : go args argumentFilters :: [String] -> [String] - argumentFilters = flagArgumentFilter ["-ghci-script", "-H"] + argumentFilters = flagArgumentFilter + ["-ghci-script", "-H", "-interactive-print"] + + filterRtsOpts :: [String] -> [String] + filterRtsOpts = go False + where + go :: Bool -> [String] -> [String] + go _ [] = [] + go _ ("+RTS":opts) = go True opts + go _ ("-RTS":opts) = go False opts + go isRTSopts (opt:opts) = addOpt $ go isRTSopts opts + where + addOpt | isRTSopts = id + | otherwise = (opt:) simpleFilters :: String -> Bool simpleFilters = not . getAny . mconcat @@ -138,13 +167,17 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs , Any . isPrefixOf "-dno-suppress-" , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"] , flagIn . invertibleFlagSet "-f" . mconcat $ - [ [ "reverse-errors", "warn-unused-binds" ] + [ [ "reverse-errors", "warn-unused-binds", "break-on-error" + , "break-on-exception", "print-bind-result" + , "print-bind-contents", "print-evld-with-show" + , "implicit-import-qualified" ] , from [8,2] [ "diagnostics-show-caret", "local-ghci-history" , "show-warning-groups", "hide-source-paths" , "show-hole-constraints" ] , from [8,4] ["show-loaded-modules"] + , from [8,6] [ "ghci-leak-check", "no-it" ] ] , flagIn . invertibleFlagSet "-d" $ [ "ppr-case-as-let", "ppr-ticks" ] , isOptIntFlag @@ -152,6 +185,10 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs , if safeToFilterWarnings then isWarning <> (Any . ("-w"==)) else mempty + , from [8,6] $ + if safeToFilterHoles + then isTypedHoleFlag + else mempty ] flagIn :: Set String -> String -> Any @@ -168,7 +205,7 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs , "-dverbose-stg2stg", "-dcore-lint", "-dstg-lint", "-dcmm-lint" , "-dasm-lint", "-dannot-lint", "-dshow-passes", "-dfaststring-stats" , "-fno-max-relevant-binds", "-recomp", "-no-recomp", "-fforce-recomp" - , "-fno-force-recomp", "-interactive-print" + , "-fno-force-recomp" ] , from [8,2] @@ -177,8 +214,9 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs , "-dppr-debug", "-dno-debug-output" ] - , from [8,4] - [ "-ddebug-output", "-fno-max-valid-substitutions" ] + , from [8,4] [ "-ddebug-output" ] + , from [8,4] $ to [8,6] [ "-fno-max-valid-substitutions" ] + , from [8,6] [ "-dhex-word-literals" ] ] isOptIntFlag :: String -> Any @@ -189,7 +227,7 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs [ [ "-fmax-relevant-binds", "-ddpr-user-length", "-ddpr-cols" , "-dtrace-level", "-fghci-hist-size" ] , from [8,2] ["-fmax-uncovered-patterns", "-fmax-errors"] - , from [8,4] ["-fmax-valid-substitutions"] + , from [8,4] $ to [8,6] ["-fmax-valid-substitutions"] ] dropIntFlag :: Bool -> String -> String -> Any @@ -216,6 +254,43 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs invertibleFlagSet prefix flagNames = Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames + compatWarningSet :: Set String + compatWarningSet = Set.fromList $ mconcat + [ from [8,6] + [ "missing-monadfail-instances", "semigroup" + , "noncanonical-monoid-instances", "implicit-kind-vars" ] + ] + + safeToFilterHoles :: Bool + safeToFilterHoles = getAll . checkGhcFlags $ fromLast . foldMap notDeferred + where + fromLast :: Last All -> All + fromLast = fromMaybe (All True) . getLast + + notDeferred :: String -> Last All + notDeferred "-fdefer-typed-holes" = Last . Just . All $ False + notDeferred "-fno-defer-typed-holes" = Last . Just . All $ True + notDeferred _ = Last Nothing + + isTypedHoleFlag :: String -> Any + isTypedHoleFlag = mconcat + [ flagIn . invertibleFlagSet "-f" $ + [ "show-hole-constraints", "show-valid-substitutions" + , "show-valid-hole-fits", "sort-valid-hole-fits" + , "sort-by-size-hole-fits", "sort-by-subsumption-hole-fits" + , "abstract-refinement-hole-fits", "show-provenance-of-hole-fits" + , "show-hole-matches-of-hole-fits", "show-type-of-hole-fits" + , "show-type-app-of-hole-fits", "show-type-app-vars-of-hole-fits" + , "unclutter-valid-hole-fits" + ] + , flagIn . Set.fromList $ + [ "-fno-max-valid-hole-fits", "-fno-max-refinement-hole-fits" + , "-fno-refinement-level-hole-fits" ] + , mconcat . map (dropIntFlag False) $ + [ "-fmax-valid-hole-fits", "-fmax-refinement-hole-fits" + , "-frefinement-level-hole-fits" ] + ] + normaliseGhcArgs _ _ args = args -- | A structured set of GHC options/flags