Prototype flag normalisation for GHC 8.0-8.4

Cabal/Cabal.cabal

@@ -254,6 +254,7 @@ library
     Distribution.Simple.Command
     Distribution.Simple.Compiler
     Distribution.Simple.Configure
+    Distribution.Simple.Flag
     Distribution.Simple.GHC
     Distribution.Simple.GHCJS
     Distribution.Simple.Haddock

Cabal/Distribution/Simple/Flag.hs

@@ -0,0 +1,119 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Distribution.Simple.Flag
+-- Copyright   :  Isaac Jones 2003-2004
+--                Duncan Coutts 2007
+-- License     :  BSD3
+--
+-- Maintainer  :  [email protected]
+-- Portability :  portable
+--
+-- Defines the 'Flag' type and it's 'Monoid' instance,  see
+-- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>
+-- for an explanation.
+--
+-- Split off from "Distribution.Simple.Setup" to break import cycles.
+module Distribution.Simple.Flag (
+  Flag(..),
+  allFlags,
+  toFlag,
+  fromFlag,
+  fromFlagOrDefault,
+  flagToMaybe,
+  flagToList,
+  maybeToFlag,
+  BooleanFlag(..) ) where
+
+import Prelude ()
+import Distribution.Compat.Prelude hiding (get)
+import Distribution.Compat.Stack
+
+-- ------------------------------------------------------------
+-- * Flag type
+-- ------------------------------------------------------------
+
+-- | All flags are monoids, they come in two flavours:
+--
+-- 1. list flags eg
+--
+-- > --ghc-option=foo --ghc-option=bar
+--
+-- gives us all the values ["foo", "bar"]
+--
+-- 2. singular value flags, eg:
+--
+-- > --enable-foo --disable-foo
+--
+-- gives us Just False
+-- So this Flag type is for the latter singular kind of flag.
+-- Its monoid instance gives us the behaviour where it starts out as
+-- 'NoFlag' and later flags override earlier ones.
+--
+data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read)
+
+instance Binary a => Binary (Flag a)
+
+instance Functor Flag where
+  fmap f (Flag x) = Flag (f x)
+  fmap _ NoFlag  = NoFlag
+
+instance Monoid (Flag a) where
+  mempty = NoFlag
+  mappend = (<>)
+
+instance Semigroup (Flag a) where
+  _ <> f@(Flag _) = f
+  f <> NoFlag     = f
+
+instance Bounded a => Bounded (Flag a) where
+  minBound = toFlag minBound
+  maxBound = toFlag maxBound
+
+instance Enum a => Enum (Flag a) where
+  fromEnum = fromEnum . fromFlag
+  toEnum   = toFlag   . toEnum
+  enumFrom (Flag a) = map toFlag . enumFrom $ a
+  enumFrom _        = []
+  enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b
+  enumFromThen _        _        = []
+  enumFromTo   (Flag a) (Flag b) = toFlag `map` enumFromTo a b
+  enumFromTo   _        _        = []
+  enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c
+  enumFromThenTo _        _        _        = []
+
+toFlag :: a -> Flag a
+toFlag = Flag
+
+fromFlag :: WithCallStack (Flag a -> a)
+fromFlag (Flag x) = x
+fromFlag NoFlag   = error "fromFlag NoFlag. Use fromFlagOrDefault"
+
+fromFlagOrDefault :: a -> Flag a -> a
+fromFlagOrDefault _   (Flag x) = x
+fromFlagOrDefault def NoFlag   = def
+
+flagToMaybe :: Flag a -> Maybe a
+flagToMaybe (Flag x) = Just x
+flagToMaybe NoFlag   = Nothing
+
+flagToList :: Flag a -> [a]
+flagToList (Flag x) = [x]
+flagToList NoFlag   = []
+
+allFlags :: [Flag Bool] -> Flag Bool
+allFlags flags = if all (\f -> fromFlagOrDefault False f) flags
+                 then Flag True
+                 else NoFlag
+
+maybeToFlag :: Maybe a -> Flag a
+maybeToFlag Nothing  = NoFlag
+maybeToFlag (Just x) = Flag x
+
+-- | Types that represent boolean flags.
+class BooleanFlag a where
+    asBool :: a -> Bool
+
+instance BooleanFlag Bool where
+  asBool = id

Cabal/Distribution/Simple/Program/Builtin.hs

@@ -48,6 +48,7 @@ module Distribution.Simple.Program.Builtin (
 import Prelude ()
 import Distribution.Compat.Prelude
 
+import Distribution.Simple.Program.GHC
 import Distribution.Simple.Program.Find
 import Distribution.Simple.Program.Internal
 import Distribution.Simple.Program.Run
@@ -118,7 +119,9 @@ ghcProgram = (simpleProgram "ghc") {
        return $ maybe ghcProg
          (\v -> if withinRange v affectedVersionRange
                 then ghcProg' else ghcProg)
-         (programVersion ghcProg)
+         (programVersion ghcProg),
+
+    programNormaliseArgs = normaliseGhcArgs
   }
 
 runghcProgram :: Program
@@ -311,7 +314,9 @@ haddockProgram = (simpleProgram "haddock") {
       -- "Haddock version 0.8, (c) Simon Marlow 2006"
       case words str of
         (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver
-        _           -> ""
+        _           -> "",
+
+    programNormaliseArgs = \_ _ _ -> []
   }
 
 greencardProgram :: Program

Cabal/Distribution/Simple/Program/GHC.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Distribution.Simple.Program.GHC (
     GhcOptions(..),
@@ -15,6 +16,7 @@ module Distribution.Simple.Program.GHC (
     runGHC,
 
     packageDbArgsDb,
+    normaliseGhcArgs
 
   ) where
 
@@ -27,17 +29,194 @@ import Distribution.PackageDescription hiding (Flag)
 import Distribution.ModuleName
 import Distribution.Simple.Compiler hiding (Flag)
 import qualified Distribution.Simple.Compiler as Compiler (Flag)
-import Distribution.Simple.Setup
+import Distribution.Simple.Flag
 import Distribution.Simple.Program.Types
 import Distribution.Simple.Program.Run
 import Distribution.System
 import Distribution.Text
 import Distribution.Types.ComponentId
 import Distribution.Verbosity
+import Distribution.Version
 import Distribution.Utils.NubList
 import Language.Haskell.Extension
 
+import Data.List (stripPrefix)
 import qualified Data.Map as Map
+import Data.Monoid (All(..), Any(..), Endo(..), First(..))
+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
+  where
+    supportedGHCVersions :: VersionRange
+    supportedGHCVersions = intersectVersionRanges
+        (orLaterVersion (mkVersion [8,0]))
+        (earlierVersion (mkVersion [8,5]))
+
+    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
+
+        allBuildInfoOptions :: BuildInfo -> [(CompilerFlavor, [String])]
+        allBuildInfoOptions =
+            mconcat [options, profOptions, sharedOptions, staticOptions]
+
+        filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]]
+        filterGhcOptions l = [opts | (GHC, opts) <- l]
+
+    libs, exes, tests, benches :: All
+    libs = checkComponentWarnings libBuildInfo $
+                maybeToList library ++ subLibraries
+
+    exes = checkComponentWarnings buildInfo $ executables
+    tests = checkComponentWarnings testBuildInfo $ testSuites
+    benches = checkComponentWarnings benchmarkBuildInfo $ benchmarks
+
+    safeToFilterWarnings :: Bool
+    safeToFilterWarnings = getAll $ mconcat
+        [checkWarnings ghcArgs, libs, exes, tests, benches]
+
+    checkWarnings :: [String] -> All
+    checkWarnings = All . Set.null . foldr alter Set.empty
+      where
+        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
+            , from [8,4] $ markFlag "-Werror=" Set.insert
+            , from [8,4] $ markFlag "-Wwarn=" Set.delete
+            , from [8,4] $ markFlag "-Wno-error=" Set.delete
+            ] flag
+
+        markFlag
+            :: String
+            -> (String -> Set String -> Set String)
+            -> String
+            -> Endo (Set String)
+        markFlag name update flag = Endo $ case stripPrefix name flag of
+            Just rest | not (null rest) -> update rest
+            _ -> id
+
+    flagArgumentFilter :: [String] -> [String] -> [String]
+    flagArgumentFilter flags = go
+      where
+        makeFilter :: String -> String -> First ([String] -> [String])
+        makeFilter flag arg = First $ filterRest <$> stripPrefix flag arg
+          where
+            filterRest leftOver = case dropEq leftOver of
+                [] -> drop 1
+                _ -> id
+
+        checkFilter :: String -> Maybe ([String] -> [String])
+        checkFilter = getFirst . mconcat (map makeFilter flags)
+
+        go :: [String] -> [String]
+        go [] = []
+        go (arg:args) = case checkFilter arg of
+            Just f -> go (f args)
+            Nothing -> arg : go args
+
+    argumentFilters :: [String] -> [String]
+    argumentFilters = flagArgumentFilter ["-ghci-script", "-H"]
+
+    simpleFilters :: String -> Bool
+    simpleFilters = not . getAny . mconcat
+      [ flagIn simpleFlags
+      , Any . isPrefixOf "-ddump-"
+      , Any . isPrefixOf "-dsuppress-"
+      , Any . isPrefixOf "-dno-suppress-"
+      , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"]
+      , flagIn . invertibleFlagSet "-f" . mconcat $
+            [ [ "reverse-errors", "warn-unused-binds" ]
+            , from [8,2]
+                [ "diagnostics-show-caret", "local-ghci-history"
+                , "show-warning-groups", "hide-source-paths"
+                , "show-hole-constraints"
+                ]
+            , from [8,4] ["show-loaded-modules"]
+            ]
+      , flagIn . invertibleFlagSet "-d" $ [ "ppr-case-as-let", "ppr-ticks" ]
+      , isOptIntFlag
+      , isIntFlag
+      , if safeToFilterWarnings
+           then isWarning <> (Any . ("-w"==))
+           else mempty
+      ]
+
+    flagIn :: Set String -> String -> Any
+    flagIn set flag = Any $ Set.member flag set
+
+    isWarning :: String -> Any
+    isWarning = mconcat $ map ((Any .) . isPrefixOf)
+        ["-fwarn-", "-fno-warn-", "-W", "-Wno-"]
+
+    simpleFlags :: Set String
+    simpleFlags = Set.fromList . mconcat $
+      [ [ "-n", "-#include", "-Rghc-timing", "-dsuppress-all", "-dstg-stats"
+        , "-dth-dec-file", "-dsource-stats", "-dverbose-core2core"
+        , "-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"
+        ]
+
+      , from [8,2]
+          [ "-fno-max-errors", "-fdiagnostics-color=auto"
+          , "-fdiagnostics-color=always", "-fdiagnostics-color=never"
+          , "-dppr-debug", "-dno-debug-output"
+          ]
+
+      , from [8,4]
+          [ "-ddebug-output", "-fno-max-valid-substitutions" ]
+      ]
+
+    isOptIntFlag :: String -> Any
+    isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"]
+
+    isIntFlag :: String -> Any
+    isIntFlag = mconcat . map (dropIntFlag False) . mconcat $
+        [ [ "-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"]
+        ]
+
+    dropIntFlag :: Bool -> String -> String -> Any
+    dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of
+        Nothing -> False
+        Just rest | isOpt && null rest -> True
+                  | otherwise -> case parseInt rest of
+                        Just _ -> True
+                        Nothing -> False
+      where
+        parseInt :: String -> Maybe Int
+        parseInt = readMaybe . dropEq
+
+        readMaybe :: Read a => String -> Maybe a
+        readMaybe s = case reads s of
+            [(x, "")] -> Just x
+            _ -> Nothing
+
+    dropEq :: String -> String
+    dropEq ('=':s) = s
+    dropEq s = s
+
+    invertibleFlagSet :: String -> [String] -> Set String
+    invertibleFlagSet prefix flagNames =
+      Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames
+
+normaliseGhcArgs _ _ args = args
 
 -- | A structured set of GHC options/flags
 --