-- GHC 6.8.1
{-# LANGUAGE CPP #-}
-- GHC 7.2.1
{-# LANGUAGE Trustworthy #-}
-- GHC 6.10
{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}
-- |
-- Copyright: 2026 Greg Pfeil
-- License: AGPL-3.0-only WITH Universal-FOSS-exception-1.0 OR LicenseRef-commercial
--
-- The implementation of the plugin, but this module is only loaded on GHC 7.10+
-- currently.
module GhcCompat
( plugin,
-- exported purely for documentation
Opts (..),
ReportLevel (..),
)
where
import safe "base" Control.Applicative (pure)
import safe "base" Control.Category ((.))
import safe "base" Control.Monad ((=<<))
import safe "base" Data.Bifunctor (first)
import safe "base" Data.Char (isUpper, toLower)
import safe "base" Data.Either (either)
import safe qualified "base" Data.Foldable as Foldable
import safe "base" Data.Function (flip, ($))
import safe "base" Data.Functor (fmap, (<$>))
import safe qualified "base" Data.List as List
import safe "base" Data.Maybe (maybe)
import safe "base" Data.Monoid (mconcat, (<>))
import safe "base" Data.Ord ((<))
import safe "base" Data.String (String)
import safe "base" Data.Tuple (uncurry)
import safe "base" Data.Version (Version, showVersion)
import safe "base" System.Exit (die)
import safe "base" System.IO (IO, putStr)
import safe "base" Text.Show (show)
import safe "this" GhcCompat.GhcRelease (GhcRelease)
import safe qualified "this" GhcCompat.GhcRelease as GhcRelease
import safe "this" GhcCompat.Opts (Opts (Opts), ReportLevel (Error, Warn))
import safe qualified "this" GhcCompat.Opts as Opts
#if MIN_VERSION_ghc(9, 0, 0)
import "ghc" GHC.Plugins (Plugin, defaultPlugin)
import qualified "ghc" GHC.Plugins as Plugins
#else
import "ghc" GhcPlugins (Plugin, defaultPlugin)
import qualified "ghc" GhcPlugins as Plugins
#endif
-- | The entry-point for the GHC plugin. This is used by passing
-- [@-fplugin=GhcCompat@](https://downloads.haskell.org/ghc/latest/docs/users_guide/extending_ghc.html#ghc-flag-fplugin-module)
-- to GHC.
plugin :: Plugin
plugin =
defaultPlugin
#if MIN_VERSION_ghc(9, 2, 1)
{ Plugins.driverPlugin = \optStrs env ->
fmap (\dflags -> env {Plugins.hsc_dflags = dflags})
. dflagsPlugin optStrs
$ Plugins.hsc_dflags env,
Plugins.pluginRecompile = Plugins.flagRecompile
}
#elif MIN_VERSION_ghc(8, 10, 1)
{ Plugins.dynflagsPlugin = dflagsPlugin,
Plugins.pluginRecompile = Plugins.flagRecompile
}
#elif MIN_VERSION_ghc(8, 6, 1)
{ Plugins.installCoreToDos = install,
Plugins.pluginRecompile = Plugins.purePlugin
}
#else
{ Plugins.installCoreToDos = install
}
#endif
#if MIN_VERSION_ghc(8, 10, 1)
dflagsPlugin ::
[Plugins.CommandLineOption] -> Plugins.DynFlags -> IO Plugins.DynFlags
dflagsPlugin optStrs dflags = do
opts <-
either (die . (errorPrelude optStrs "error" <>)) pure $ Opts.parse optStrs
warnFlags optStrs opts dflags
warnExts optStrs opts dflags
pure $ updateFlags (Opts.minVersion opts) dflags
updateFlags :: Version -> Plugins.DynFlags -> Plugins.DynFlags
updateFlags minVersion dflags =
Foldable.foldl' Plugins.wopt_unset dflags $
warningFlags minVersion GhcRelease.all
#else
install ::
[Plugins.CommandLineOption] ->
[Plugins.CoreToDo] ->
Plugins.CoreM [Plugins.CoreToDo]
install optStrs todos = do
opts <-
Plugins.liftIO . either (die . (errorPrelude optStrs "error" <>)) pure $
Opts.parse optStrs
dflags <- Plugins.getDynFlags
Plugins.liftIO $ warnFlags optStrs opts dflags
Plugins.liftIO $ warnExts optStrs opts dflags
pure todos
#endif
-- | If you support a GHC older than 8.10.1, we can’t disable the flags that
-- were introduced before 8.10.1, because we have no way to modify
-- `Plugins.Dynflags`, so those flags get reported like incompatible
-- extensions.
identifyProblematicFlags :: Version -> Plugins.DynFlags -> [Plugins.WarningFlag]
identifyProblematicFlags minVersion dflags =
List.filter (`Plugins.wopt` dflags) . warningFlags minVersion $
List.filter
((< GhcRelease.version GhcRelease.ghc_8_10_1) . GhcRelease.version)
GhcRelease.all
-- | Try to print a flag the way it looks to a user.
--
-- __FIXME__: `show` on flags doesn’t display them nicely, but I don’t see
-- another way to print them.
--
-- __TODO__: Print out what the user should add to their Cabal file to avoid
-- these warnings (including using `-fno-warn-` for flags added
-- before GHC 8.0).
formatFlag :: Plugins.WarningFlag -> String
formatFlag =
("-W" <>) . List.intercalate "-" . splitWords [] . List.drop 8 . show
where
splitWords :: [String] -> String -> [String]
splitWords acc =
maybe
acc
( \(h, t) ->
uncurry splitWords . first ((acc <>) . pure . (toLower h :)) $
List.break isUpper t
)
. List.uncons
warnFlags :: [Plugins.CommandLineOption] -> Opts -> Plugins.DynFlags -> IO ()
warnFlags optStrs opts dflags =
let minVer = Opts.minVersion opts
in maybe
(pure ())
( \level ->
maybe
(pure ())
( ( case level of
Opts.Warn -> putStr . (errorPrelude optStrs "warning" <>)
Opts.Error -> die . (errorPrelude optStrs "error" <>)
)
. ( ( "You have the following warnings enabled, which require the use of features\n not available in ‘minVersion’ ("
<> showVersion minVer
<> "). Unfortunately, these warnings were\n introduced before plugins could disable warnings automatically, so it must\n be done manually:\n"
)
<>
)
. mconcat
. fmap (\flag -> " • " <> formatFlag flag <> "\n")
. uncurry (:)
)
. List.uncons
$ identifyProblematicFlags minVer dflags
)
$ Opts.reportIncompatibleExtensions opts
warnExts :: [Plugins.CommandLineOption] -> Opts -> Plugins.DynFlags -> IO ()
warnExts optStrs opts dflags =
let minVer = Opts.minVersion opts
in maybe
(pure ())
( \level ->
maybe
(pure ())
( ( case level of
Opts.Warn -> putStr . (errorPrelude optStrs "warning" <>)
Opts.Error -> die . (errorPrelude optStrs "error" <>)
)
. ( ( "You’re using the following extensions, which aren’t compatible with\n ‘minVersion’ ("
<> showVersion minVer
<> "):\n"
)
<>
)
. mconcat
-- FIXME: Most extensions have the same constructor name as
-- the extension name, but not all of them, so `show`
-- doesn’t always do the right thing.
. fmap (\ext -> " • " <> show ext <> "\n")
. uncurry (:)
)
. List.uncons
$ usedIncompatibleExtensions minVer dflags
)
$ Opts.reportIncompatibleExtensions opts
errorPrelude :: [Plugins.CommandLineOption] -> String -> String
errorPrelude optStrs prefix =
"on the commandline: "
<> prefix
<> ": [GhcCompat plugin] ["
<> List.intercalate ", " optStrs
<> "]\n "
-- | A list of extensions incompatible with the provided version that are used
-- (regardless of `Extension.OnOff`).
--
-- __NB__: Prior to GHC 9.6.1, there doesn’t seem to be a way to get all of the
-- extensions regardless of whether they’re off or on (this is helpful,
-- because even @NoFoo@ is going to fail before @Foo@ is added to the
-- compiler).
--
-- __TODO__: These are extensions in the ghc 9.14.1 library that aren’t
-- documented in the manual. I think they’re ones that have been
-- “removed” – but can they still be specified? Should we report
-- their use as well (for forward compatibility)?
--
-- - `Extension.AlternativeLayoutRule`,
-- - `Extension.AlternativeLayoutRuleTransitional`,
-- - `Extension.AutoDeriveTypeable`,
-- - `Extension.JavaScriptFFI`,
-- - `Extension.ParallelArrays`,
-- - `Extension.RelaxedLayout`, and
-- - `Extension.RelaxedPolyRec`.
usedIncompatibleExtensions ::
Version -> Plugins.DynFlags -> [GhcRelease.Extension]
#if MIN_VERSION_ghc(9, 6, 1)
usedIncompatibleExtensions minVersion =
List.intersect (incompatibleExtensions minVersion)
. fmap removeSwitch
. Plugins.extensions
where
removeSwitch onOff = case onOff of
Plugins.Off a -> a
Plugins.On a -> a
#else
usedIncompatibleExtensions minVersion dflags =
List.filter (`Plugins.xopt` dflags) $ incompatibleExtensions minVersion
#endif
-- | A list of /all/ extensions that are incompatible with the provided version.
incompatibleExtensions :: Version -> [GhcRelease.Extension]
incompatibleExtensions minVersion =
( \ghc ->
if minVersion < GhcRelease.version ghc
then GhcRelease.newExtensions ghc
else []
)
=<< GhcRelease.all
warningFlags :: Version -> [GhcRelease] -> [Plugins.WarningFlag]
warningFlags minVersion releases =
mconcat
( disableIfOlder . fmap (first GhcRelease.version) . GhcRelease.newWarnings
<$> releases
)
minVersion
whenOlder ::
Version -> Version -> [Plugins.WarningFlag] -> [Plugins.WarningFlag]
whenOlder minVersion flagAddedVersion flags =
if minVersion < flagAddedVersion then flags else []
disableIfOlder ::
[(Version, [Plugins.WarningFlag])] -> Version -> [Plugins.WarningFlag]
disableIfOlder = flip $ Foldable.concatMap . uncurry . whenOlder