module GHC.Driver.Plugins (
Plugin(..)
, defaultPlugin
, CommandLineOption
, purePlugin, impurePlugin, flagRecompile
, PluginRecompile(..)
, FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction
, CorePlugin
, TcPlugin
, keepRenamedSource
, HoleFitPluginR
, PluginWithArgs(..), plugins, pluginRecompile'
, LoadedPlugin(..), lpModuleName
, StaticPlugin(..)
, mapPlugins, withPlugins, withPlugins_
) where
import GHC.Prelude
import GHC.Core.Opt.Monad ( CoreToDo, CoreM )
import qualified GHC.Tc.Types
import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports )
import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR )
import GHC.Hs
import GHC.Driver.Session
import GHC.Driver.Types
import GHC.Driver.Monad
import GHC.Driver.Phases
import GHC.Unit.Module
import GHC.Utils.Fingerprint
import Data.List (sort)
import GHC.Utils.Outputable (Outputable(..), text, (<+>))
import qualified Data.Semigroup
import Control.Monad
type CommandLineOption = String
data Plugin = Plugin {
installCoreToDos :: CorePlugin
, tcPlugin :: TcPlugin
, holeFitPlugin :: HoleFitPlugin
, dynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
, parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule
-> Hsc HsParsedModule
, renamedResultAction :: [CommandLineOption] -> TcGblEnv
-> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
, typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv
-> TcM TcGblEnv
, spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc
-> TcM (LHsExpr GhcTc)
, interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface
-> IfM lcl ModIface
}
data PluginWithArgs = PluginWithArgs
{ paPlugin :: Plugin
, paArguments :: [CommandLineOption]
}
data LoadedPlugin = LoadedPlugin
{ lpPlugin :: PluginWithArgs
, lpModule :: ModIface
}
data StaticPlugin = StaticPlugin
{ spPlugin :: PluginWithArgs
}
lpModuleName :: LoadedPlugin -> ModuleName
lpModuleName = moduleName . mi_module . lpModule
pluginRecompile' :: PluginWithArgs -> IO PluginRecompile
pluginRecompile' (PluginWithArgs plugin args) = pluginRecompile plugin args
data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint
instance Outputable PluginRecompile where
ppr ForceRecompile = text "ForceRecompile"
ppr NoForceRecompile = text "NoForceRecompile"
ppr (MaybeRecompile fp) = text "MaybeRecompile" <+> ppr fp
instance Semigroup PluginRecompile where
ForceRecompile <> _ = ForceRecompile
NoForceRecompile <> r = r
MaybeRecompile fp <> NoForceRecompile = MaybeRecompile fp
MaybeRecompile fp <> MaybeRecompile fp' = MaybeRecompile (fingerprintFingerprints [fp, fp'])
MaybeRecompile _fp <> ForceRecompile = ForceRecompile
instance Monoid PluginRecompile where
mempty = NoForceRecompile
type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin
type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR
purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile
purePlugin _args = return NoForceRecompile
impurePlugin _args = return ForceRecompile
flagRecompile =
return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort
defaultPlugin :: Plugin
defaultPlugin = Plugin {
installCoreToDos = const return
, tcPlugin = const Nothing
, holeFitPlugin = const Nothing
, dynflagsPlugin = const return
, pluginRecompile = impurePlugin
, renamedResultAction = \_ env grp -> return (env, grp)
, parsedResultAction = \_ _ -> return
, typeCheckResultAction = \_ _ -> return
, spliceRunAction = \_ -> return
, interfaceLoadAction = \_ -> return
}
keepRenamedSource :: [CommandLineOption] -> TcGblEnv
-> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
keepRenamedSource _ gbl_env group =
return (gbl_env { tcg_rn_decls = update (tcg_rn_decls gbl_env)
, tcg_rn_exports = update_exports (tcg_rn_exports gbl_env) }, group)
where
update_exports Nothing = Just []
update_exports m = m
update Nothing = Just emptyRnGroup
update m = m
type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a
type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m ()
plugins :: DynFlags -> [PluginWithArgs]
plugins df =
map lpPlugin (cachedPlugins df) ++
map spPlugin (staticPlugins df)
withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a
withPlugins df transformation input = foldM go input (plugins df)
where
go arg (PluginWithArgs p opts) = transformation p opts arg
mapPlugins :: DynFlags -> (Plugin -> [CommandLineOption] -> a) -> [a]
mapPlugins df f = map (\(PluginWithArgs p opts) -> f p opts) (plugins df)
withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m ()
withPlugins_ df transformation input
= mapM_ (\(PluginWithArgs p opts) -> transformation p opts input)
(plugins df)
type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc ()
data FrontendPlugin = FrontendPlugin {
frontend :: FrontendPluginAction
}
defaultFrontendPlugin :: FrontendPlugin
defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () }