{-# LANGUAGE RankNTypes #-}
module GHC.Driver.Plugins (
Plugins (..)
, emptyPlugins
, Plugin(..)
, defaultPlugin
, CommandLineOption
, PsMessages(..)
, ParsedResult(..)
, purePlugin, impurePlugin, flagRecompile
, PluginRecompile(..)
, FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction
, CorePlugin
, TcPlugin
, keepRenamedSource
, DefaultingPlugin
, HoleFitPluginR
, PluginWithArgs(..), pluginsWithArgs, pluginRecompile'
, LoadedPlugin(..), lpModuleName
, StaticPlugin(..)
, mapPlugins, withPlugins, withPlugins_
) where
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Monad
import GHC.Driver.Phases
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Parser.Errors.Types (PsWarning, PsError)
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.Core.Opt.Monad ( CoreToDo, CoreM )
import GHC.Hs
import GHC.Types.Error (Messages)
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable (Outputable(..), text, (<+>))
import Data.List (sort)
import qualified Data.Semigroup
import Control.Monad
import GHC.Linker.Types
import GHC.Types.Unique.DFM
type CommandLineOption = String
data PsMessages = PsMessages { PsMessages -> Messages PsWarning
psWarnings :: Messages PsWarning
, PsMessages -> Messages PsWarning
psErrors :: Messages PsError
}
data ParsedResult = ParsedResult
{
ParsedResult -> HsParsedModule
parsedResultModule :: HsParsedModule
,
ParsedResult -> PsMessages
parsedResultMessages :: PsMessages
}
data Plugin = Plugin {
Plugin -> CorePlugin
installCoreToDos :: CorePlugin
, Plugin -> TcPlugin
tcPlugin :: TcPlugin
, Plugin -> DefaultingPlugin
defaultingPlugin :: DefaultingPlugin
, Plugin -> HoleFitPlugin
holeFitPlugin :: HoleFitPlugin
, Plugin -> [CommandLineOption] -> HscEnv -> IO HscEnv
driverPlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv
, Plugin -> [CommandLineOption] -> IO PluginRecompile
pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
, Plugin
-> [CommandLineOption]
-> ModSummary
-> ParsedResult
-> Hsc ParsedResult
parsedResultAction :: [CommandLineOption] -> ModSummary
-> ParsedResult -> Hsc ParsedResult
, Plugin
-> [CommandLineOption]
-> TcGblEnv
-> HsGroup GhcRn
-> TcM (TcGblEnv, HsGroup GhcRn)
renamedResultAction :: [CommandLineOption] -> TcGblEnv
-> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
, Plugin
-> [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv
-> TcM TcGblEnv
, Plugin
-> [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc
-> TcM (LHsExpr GhcTc)
, Plugin
-> forall lcl. [CommandLineOption] -> ModIface -> IfM lcl ModIface
interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface
-> IfM lcl ModIface
}
data PluginWithArgs = PluginWithArgs
{ PluginWithArgs -> Plugin
paPlugin :: Plugin
, PluginWithArgs -> [CommandLineOption]
paArguments :: [CommandLineOption]
}
data LoadedPlugin = LoadedPlugin
{ LoadedPlugin -> PluginWithArgs
lpPlugin :: PluginWithArgs
, LoadedPlugin -> ModIface
lpModule :: ModIface
}
data StaticPlugin = StaticPlugin
{ StaticPlugin -> PluginWithArgs
spPlugin :: PluginWithArgs
}
lpModuleName :: LoadedPlugin -> ModuleName
lpModuleName :: LoadedPlugin -> ModuleName
lpModuleName = GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> ModuleName)
-> (LoadedPlugin -> GenModule Unit) -> LoadedPlugin -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> GenModule Unit
forall (phase :: ModIfacePhase). ModIface_ phase -> GenModule Unit
mi_module (ModIface -> GenModule Unit)
-> (LoadedPlugin -> ModIface) -> LoadedPlugin -> GenModule Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedPlugin -> ModIface
lpModule
pluginRecompile' :: PluginWithArgs -> IO PluginRecompile
pluginRecompile' :: PluginWithArgs -> IO PluginRecompile
pluginRecompile' (PluginWithArgs Plugin
plugin [CommandLineOption]
args) = Plugin -> [CommandLineOption] -> IO PluginRecompile
pluginRecompile Plugin
plugin [CommandLineOption]
args
data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint
instance Outputable PluginRecompile where
ppr :: PluginRecompile -> SDoc
ppr PluginRecompile
ForceRecompile = CommandLineOption -> SDoc
text CommandLineOption
"ForceRecompile"
ppr PluginRecompile
NoForceRecompile = CommandLineOption -> SDoc
text CommandLineOption
"NoForceRecompile"
ppr (MaybeRecompile Fingerprint
fp) = CommandLineOption -> SDoc
text CommandLineOption
"MaybeRecompile" SDoc -> SDoc -> SDoc
<+> Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
fp
instance Semigroup PluginRecompile where
PluginRecompile
ForceRecompile <> :: PluginRecompile -> PluginRecompile -> PluginRecompile
<> PluginRecompile
_ = PluginRecompile
ForceRecompile
PluginRecompile
NoForceRecompile <> PluginRecompile
r = PluginRecompile
r
MaybeRecompile Fingerprint
fp <> PluginRecompile
NoForceRecompile = Fingerprint -> PluginRecompile
MaybeRecompile Fingerprint
fp
MaybeRecompile Fingerprint
fp <> MaybeRecompile Fingerprint
fp' = Fingerprint -> PluginRecompile
MaybeRecompile ([Fingerprint] -> Fingerprint
fingerprintFingerprints [Fingerprint
fp, Fingerprint
fp'])
MaybeRecompile Fingerprint
_fp <> PluginRecompile
ForceRecompile = PluginRecompile
ForceRecompile
instance Monoid PluginRecompile where
mempty :: PluginRecompile
mempty = PluginRecompile
NoForceRecompile
type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin
type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin
type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR
purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile
purePlugin :: [CommandLineOption] -> IO PluginRecompile
purePlugin [CommandLineOption]
_args = PluginRecompile -> IO PluginRecompile
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PluginRecompile
NoForceRecompile
impurePlugin :: [CommandLineOption] -> IO PluginRecompile
impurePlugin [CommandLineOption]
_args = PluginRecompile -> IO PluginRecompile
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PluginRecompile
ForceRecompile
flagRecompile :: [CommandLineOption] -> IO PluginRecompile
flagRecompile =
PluginRecompile -> IO PluginRecompile
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PluginRecompile -> IO PluginRecompile)
-> ([CommandLineOption] -> PluginRecompile)
-> [CommandLineOption]
-> IO PluginRecompile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fingerprint -> PluginRecompile
MaybeRecompile (Fingerprint -> PluginRecompile)
-> ([CommandLineOption] -> Fingerprint)
-> [CommandLineOption]
-> PluginRecompile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Fingerprint] -> Fingerprint
fingerprintFingerprints ([Fingerprint] -> Fingerprint)
-> ([CommandLineOption] -> [Fingerprint])
-> [CommandLineOption]
-> Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommandLineOption -> Fingerprint)
-> [CommandLineOption] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map CommandLineOption -> Fingerprint
fingerprintString ([CommandLineOption] -> [Fingerprint])
-> ([CommandLineOption] -> [CommandLineOption])
-> [CommandLineOption]
-> [Fingerprint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CommandLineOption] -> [CommandLineOption]
forall a. Ord a => [a] -> [a]
sort
defaultPlugin :: Plugin
defaultPlugin :: Plugin
defaultPlugin = Plugin {
installCoreToDos :: CorePlugin
installCoreToDos = ([CoreToDo] -> CoreM [CoreToDo]) -> CorePlugin
forall a b. a -> b -> a
const [CoreToDo] -> CoreM [CoreToDo]
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return
, tcPlugin :: TcPlugin
tcPlugin = Maybe TcPlugin -> TcPlugin
forall a b. a -> b -> a
const Maybe TcPlugin
forall a. Maybe a
Nothing
, defaultingPlugin :: DefaultingPlugin
defaultingPlugin = Maybe DefaultingPlugin -> DefaultingPlugin
forall a b. a -> b -> a
const Maybe DefaultingPlugin
forall a. Maybe a
Nothing
, holeFitPlugin :: HoleFitPlugin
holeFitPlugin = Maybe HoleFitPluginR -> HoleFitPlugin
forall a b. a -> b -> a
const Maybe HoleFitPluginR
forall a. Maybe a
Nothing
, driverPlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv
driverPlugin = (HscEnv -> IO HscEnv) -> [CommandLineOption] -> HscEnv -> IO HscEnv
forall a b. a -> b -> a
const HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile = [CommandLineOption] -> IO PluginRecompile
impurePlugin
, renamedResultAction :: [CommandLineOption]
-> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
renamedResultAction = \[CommandLineOption]
_ TcGblEnv
env HsGroup GhcRn
grp -> (TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
env, HsGroup GhcRn
grp)
, parsedResultAction :: [CommandLineOption]
-> ModSummary -> ParsedResult -> Hsc ParsedResult
parsedResultAction = \[CommandLineOption]
_ ModSummary
_ -> ParsedResult -> Hsc ParsedResult
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return
, typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typeCheckResultAction = \[CommandLineOption]
_ ModSummary
_ -> TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return
, spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
spliceRunAction = \[CommandLineOption]
_ -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return
, interfaceLoadAction :: forall lcl. [CommandLineOption] -> ModIface -> IfM lcl ModIface
interfaceLoadAction = \[CommandLineOption]
_ -> ModIface -> IfM lcl ModIface
forall a. a -> IOEnv (Env IfGblEnv lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return
}
keepRenamedSource :: [CommandLineOption] -> TcGblEnv
-> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
keepRenamedSource :: [CommandLineOption]
-> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
keepRenamedSource [CommandLineOption]
_ TcGblEnv
gbl_env HsGroup GhcRn
group =
(TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env { tcg_rn_decls :: Maybe (HsGroup GhcRn)
tcg_rn_decls = Maybe (HsGroup GhcRn) -> Maybe (HsGroup GhcRn)
forall {p :: Pass}.
Maybe (HsGroup (GhcPass p)) -> Maybe (HsGroup (GhcPass p))
update (TcGblEnv -> Maybe (HsGroup GhcRn)
tcg_rn_decls TcGblEnv
gbl_env)
, tcg_rn_exports :: Maybe [(LIE GhcRn, Avails)]
tcg_rn_exports = Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)]
-> Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)]
forall {a}. Maybe [a] -> Maybe [a]
update_exports (TcGblEnv -> Maybe [(LIE GhcRn, Avails)]
tcg_rn_exports TcGblEnv
gbl_env) }, HsGroup GhcRn
group)
where
update_exports :: Maybe [a] -> Maybe [a]
update_exports Maybe [a]
Nothing = [a] -> Maybe [a]
forall a. a -> Maybe a
Just []
update_exports Maybe [a]
m = Maybe [a]
m
update :: Maybe (HsGroup (GhcPass p)) -> Maybe (HsGroup (GhcPass p))
update Maybe (HsGroup (GhcPass p))
Nothing = HsGroup (GhcPass p) -> Maybe (HsGroup (GhcPass p))
forall a. a -> Maybe a
Just HsGroup (GhcPass p)
forall (p :: Pass). HsGroup (GhcPass p)
emptyRnGroup
update Maybe (HsGroup (GhcPass p))
m = Maybe (HsGroup (GhcPass p))
m
type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a
type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m ()
data Plugins = Plugins
{ Plugins -> [StaticPlugin]
staticPlugins :: ![StaticPlugin]
, Plugins -> [LoadedPlugin]
loadedPlugins :: ![LoadedPlugin]
, Plugins -> ([Linkable], PkgsLoaded)
loadedPluginDeps :: !([Linkable], PkgsLoaded)
}
emptyPlugins :: Plugins
emptyPlugins :: Plugins
emptyPlugins = [StaticPlugin]
-> [LoadedPlugin] -> ([Linkable], PkgsLoaded) -> Plugins
Plugins [] [] ([], PkgsLoaded
forall key elt. UniqDFM key elt
emptyUDFM)
pluginsWithArgs :: Plugins -> [PluginWithArgs]
pluginsWithArgs :: Plugins -> [PluginWithArgs]
pluginsWithArgs Plugins
plugins =
(LoadedPlugin -> PluginWithArgs)
-> [LoadedPlugin] -> [PluginWithArgs]
forall a b. (a -> b) -> [a] -> [b]
map LoadedPlugin -> PluginWithArgs
lpPlugin (Plugins -> [LoadedPlugin]
loadedPlugins Plugins
plugins) [PluginWithArgs] -> [PluginWithArgs] -> [PluginWithArgs]
forall a. [a] -> [a] -> [a]
++
(StaticPlugin -> PluginWithArgs)
-> [StaticPlugin] -> [PluginWithArgs]
forall a b. (a -> b) -> [a] -> [b]
map StaticPlugin -> PluginWithArgs
spPlugin (Plugins -> [StaticPlugin]
staticPlugins Plugins
plugins)
withPlugins :: Monad m => Plugins -> PluginOperation m a -> a -> m a
withPlugins :: forall (m :: * -> *) a.
Monad m =>
Plugins -> PluginOperation m a -> a -> m a
withPlugins Plugins
plugins PluginOperation m a
transformation a
input = (a -> PluginWithArgs -> m a) -> a -> [PluginWithArgs] -> m a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM a -> PluginWithArgs -> m a
go a
input (Plugins -> [PluginWithArgs]
pluginsWithArgs Plugins
plugins)
where
go :: a -> PluginWithArgs -> m a
go a
arg (PluginWithArgs Plugin
p [CommandLineOption]
opts) = PluginOperation m a
transformation Plugin
p [CommandLineOption]
opts a
arg
mapPlugins :: Plugins -> (Plugin -> [CommandLineOption] -> a) -> [a]
mapPlugins :: forall a. Plugins -> (Plugin -> [CommandLineOption] -> a) -> [a]
mapPlugins Plugins
plugins Plugin -> [CommandLineOption] -> a
f = (PluginWithArgs -> a) -> [PluginWithArgs] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\(PluginWithArgs Plugin
p [CommandLineOption]
opts) -> Plugin -> [CommandLineOption] -> a
f Plugin
p [CommandLineOption]
opts) (Plugins -> [PluginWithArgs]
pluginsWithArgs Plugins
plugins)
withPlugins_ :: Monad m => Plugins -> ConstPluginOperation m a -> a -> m ()
withPlugins_ :: forall (m :: * -> *) a.
Monad m =>
Plugins -> ConstPluginOperation m a -> a -> m ()
withPlugins_ Plugins
plugins ConstPluginOperation m a
transformation a
input
= (PluginWithArgs -> m ()) -> [PluginWithArgs] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(PluginWithArgs Plugin
p [CommandLineOption]
opts) -> ConstPluginOperation m a
transformation Plugin
p [CommandLineOption]
opts a
input)
(Plugins -> [PluginWithArgs]
pluginsWithArgs Plugins
plugins)
type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc ()
data FrontendPlugin = FrontendPlugin {
FrontendPlugin -> FrontendPluginAction
frontend :: FrontendPluginAction
}
defaultFrontendPlugin :: FrontendPlugin
defaultFrontendPlugin :: FrontendPlugin
defaultFrontendPlugin = FrontendPlugin { frontend :: FrontendPluginAction
frontend = \[CommandLineOption]
_ [(CommandLineOption, Maybe Phase)]
_ -> () -> Ghc ()
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return () }