module Plugins (
FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction
, Plugin(..), CommandLineOption, LoadedPlugin(..), lpModuleName
, defaultPlugin, keepRenamedSource, withPlugins, withPlugins_
, PluginRecompile(..)
, purePlugin, impurePlugin, flagRecompile
) where
import GhcPrelude
import CoreMonad ( CoreToDo, CoreM )
import qualified TcRnTypes
import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports )
import HsSyn
import DynFlags
import HscTypes
import GhcMonad
import DriverPhases
import Module ( ModuleName, Module(moduleName))
import Fingerprint
import Data.List
import Outputable (Outputable(..), text, (<+>))
#if __GLASGOW_HASKELL__ < 840
import qualified Data.Semigroup
#endif
import Control.Monad
type CommandLineOption = String
data Plugin = Plugin {
installCoreToDos :: CorePlugin
, tcPlugin :: TcPlugin
, 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 LoadedPlugin = LoadedPlugin {
lpPlugin :: Plugin
, lpModule :: ModIface
, lpArguments :: [CommandLineOption]
}
lpModuleName :: LoadedPlugin -> ModuleName
lpModuleName = moduleName . mi_module . lpModule
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
#if __GLASGOW_HASKELL__ < 840
mappend = (Data.Semigroup.<>)
#endif
type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin
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
, 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 ()
withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a
withPlugins df transformation input
= foldM (\arg (LoadedPlugin p _ opts) -> transformation p opts arg)
input (plugins df)
withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m ()
withPlugins_ df transformation input
= mapM_ (\(LoadedPlugin 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 () }