[Git][ghc/ghc][wip/D5373] Add TcRef to allow internal state of plugin
Matthías Páll Gissurarson
gitlab at gitlab.haskell.org
Wed May 22 16:30:54 UTC 2019
Matthías Páll Gissurarson pushed to branch wip/D5373 at Glasgow Haskell Compiler / GHC
Commits:
8fe4f8a3 by Matthías Páll Gissurarson at 2019-05-22T16:25:16Z
Add TcRef to allow internal state of plugin
- - - - -
6 changed files:
- compiler/main/Plugins.hs
- compiler/typecheck/TcHoleErrors.hs
- compiler/typecheck/TcHoleErrors.hs-boot
- compiler/typecheck/TcRnDriver.hs
- compiler/typecheck/TcRnMonad.hs
- compiler/typecheck/TcRnTypes.hs
Changes:
=====================================
compiler/main/Plugins.hs
=====================================
@@ -42,7 +42,8 @@ import GhcPrelude
import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM )
import qualified TcRnTypes
-import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports )
+import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports
+ , HoleFitPluginR )
import HsSyn
import DynFlags
import HscTypes
@@ -53,8 +54,6 @@ import Fingerprint
import Data.List
import Outputable (Outputable(..), text, (<+>))
-import {-# SOURCE #-} qualified TcHoleErrors (HoleFitPlugin)
-
--Qualified import so we can define a Semigroup instance
-- but it doesn't clash with Outputable.<>
import qualified Data.Semigroup
@@ -83,7 +82,7 @@ data Plugin = Plugin {
-- behaviour of the constraint solver.
, holeFitPlugin :: HoleFitPlugin
-- ^ An optional plugin to handle hole fits, which may re-order
- -- or change the list of valid hole fits and refinement hole fits
+ -- or change the list of valid hole fits and refinement hole fits.
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
-- ^ Specify how the plugin should affect recompilation.
, parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule
@@ -174,7 +173,7 @@ instance Monoid PluginRecompile where
type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin
-type HoleFitPlugin = [CommandLineOption] -> Maybe TcHoleErrors.HoleFitPlugin
+type HoleFitPlugin = [CommandLineOption] -> Maybe TcRnTypes.HoleFitPluginR
purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile
purePlugin _args = return NoForceRecompile
=====================================
compiler/typecheck/TcHoleErrors.hs
=====================================
@@ -1,8 +1,14 @@
{-# LANGUAGE RecordWildCards #-}
-module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits, HoleFit (..)
- , HoleFitCandidate (..), tcCheckHoleFit, tcSubsumes
+{-# LANGUAGE ExistentialQuantification #-}
+module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits
+ , tcCheckHoleFit, tcSubsumes
, withoutUnification
- , HoleFitPlugin (..), TypedHole (..), CandPlugin, FitPlugin
+ , fromPurePlugin
+
+ -- Re-exported from TcRnTypes
+ , TypedHole (..), HoleFit (..), HoleFitCandidate (..)
+ , CandPlugin, FitPlugin
+ , HoleFitPlugin (..), HoleFitPluginR (..)
) where
import GhcPrelude
@@ -42,15 +48,12 @@ import TcUnify ( tcSubType_NC )
import ExtractDocs ( extractDocs )
import qualified Data.Map as Map
-import HsDoc ( HsDocString, unpackHDS, DeclDocMap(..) )
+import HsDoc ( unpackHDS, DeclDocMap(..) )
import HscTypes ( ModIface(..) )
import LoadIface ( loadInterfaceForNameMaybe )
import PrelInfo (knownKeyNames)
-import Plugins (holeFitPlugin, plugins, paPlugin, paArguments)
-
-
{-
Note [Valid hole fits include ...]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -426,44 +429,6 @@ getSortingAlg =
else NoSorting }
--- | HoleFitCandidates are passed to the filter and checked whether they can be
--- made to fit.
-data HoleFitCandidate = IdHFCand Id -- An id, like locals.
- | NameHFCand Name -- A name, like built-in syntax.
- | GreHFCand GlobalRdrElt -- A global, like imported ids.
- deriving (Eq)
-instance Outputable HoleFitCandidate where
- ppr = pprHoleFitCand
-
-pprHoleFitCand :: HoleFitCandidate -> SDoc
-pprHoleFitCand (IdHFCand id) = text "Id HFC: " <> ppr id
-pprHoleFitCand (NameHFCand name) = text "Name HFC: " <> ppr name
-pprHoleFitCand (GreHFCand gre) = text "Gre HFC: " <> ppr gre
-
-instance HasOccName HoleFitCandidate where
- occName hfc = case hfc of
- IdHFCand id -> occName id
- NameHFCand name -> occName name
- GreHFCand gre -> occName (gre_name gre)
-
--- | HoleFit is the type we use for valid hole fits. It contains the
--- element that was checked, the Id of that element as found by `tcLookup`,
--- and the refinement level of the fit, which is the number of extra argument
--- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).
-data HoleFit =
- HoleFit { hfId :: Id -- The elements id in the TcM
- , hfCand :: HoleFitCandidate -- The candidate that was checked.
- , hfType :: TcType -- The type of the id, possibly zonked.
- , hfRefLvl :: Int -- The number of holes in this fit.
- , hfWrap :: [TcType] -- The wrapper for the match.
- , hfMatches :: [TcType] -- What the refinement variables got matched
- -- with, if anything
- , hfDoc :: Maybe HsDocString } -- Documentation of this HoleFit, if
- -- available.
- | RawHoleFit SDoc
- -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins
- -- can inject any fit they want.
-
hfName :: HoleFit -> Maybe Name
hfName hf@(HoleFit {}) = Just $ case hfCand hf of
IdHFCand id -> idName id
@@ -604,12 +569,12 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
; hfdc <- getHoleFitDispConfig
; sortingAlg <- getSortingAlg
; dflags <- getDynFlags
+ ; hfPlugs <- tcg_hf_plugins <$> getGblEnv
; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs
refLevel = refLevelHoleFits dflags
hole = TyH (listToBag relevantCts) implics (Just ct)
(candidatePlugins, fitPlugins) =
- mapAndUnzip (\p -> ((candPlugin p) hole, (fitPlugin p) hole)) $
- getHoleFitPlugins dflags
+ unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs
; traceTc "findingValidHoleFitsFor { " $ ppr hole
; traceTc "hole_lvl is:" $ ppr hole_lvl
; traceTc "locals are: " $ ppr lclBinds
@@ -963,10 +928,6 @@ refSubsDiscardMsg =
text "or -fno-max-refinement-hole-fits)"
-getHoleFitPlugins :: DynFlags -> [HoleFitPlugin]
-getHoleFitPlugins dflags = catMaybes $ map get_plugin (plugins dflags)
- where get_plugin p = holeFitPlugin (paPlugin p) (paArguments p)
-
-- | Checks whether a MetaTyVar is flexible or not.
isFlexiTyVar :: TcTyVar -> TcM Bool
isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv
@@ -992,26 +953,14 @@ tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b
where dummyHole = TyH emptyBag [] Nothing
-type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit]
-type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]
-data HoleFitPlugin = HoleFitPlugin { candPlugin :: CandPlugin
- , fitPlugin :: FitPlugin }
-
-data TypedHole = TyH { relevantCts :: Cts
- -- ^ Any relevant Cts to the hole
- , implics :: [Implication]
- -- ^ The nested implications of the hole with the
- -- innermost implication first.
- , holeCt :: Maybe Ct
- -- ^ The hole constraint itself, if available.
- }
-instance Outputable TypedHole where
- ppr (TyH rels implics ct)
- = hang (text "TypedHole") 2
- (ppr rels $+$ ppr implics $+$ ppr ct)
+fromPurePlugin :: HoleFitPlugin -> HoleFitPluginR
+fromPurePlugin plug =
+ HoleFitPluginR { hfPluginInit = newTcRef ()
+ , holeFitPluginR = const plug
+ , hfPluginStop = const $ return () }
-- | A tcSubsumes which takes into account relevant constraints, to fix trac
-- #14273. This makes sure that when checking whether a type fits the hole,
=====================================
compiler/typecheck/TcHoleErrors.hs-boot
=====================================
@@ -10,5 +10,3 @@ import VarEnv ( TidyEnv )
findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct
-> TcM (TidyEnv, SDoc)
-
-data HoleFitPlugin
=====================================
compiler/typecheck/TcRnDriver.hs
=====================================
@@ -141,6 +141,7 @@ import qualified Data.Set as S
import Control.DeepSeq
import Control.Monad
+
#include "HsVersions.h"
{-
@@ -165,7 +166,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax
(text "Renamer/typechecker"<+>brackets (ppr this_mod))
(const ()) $
initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
- withTcPlugins hsc_env $
+ withTcPlugins hsc_env $ withHfPlugins hsc_env $
tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
@@ -1841,7 +1842,7 @@ runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
-- Initialise the tcg_inst_env with instances from all home modules.
-- This mimics the more selective call to hptInstances in tcRnImports
runTcInteractive hsc_env thing_inside
- = initTcInteractive hsc_env $ withTcPlugins hsc_env $
+ = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHfPlugins hsc_env $
do { traceTc "setInteractiveContext" $
vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
, text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)
@@ -2875,6 +2876,30 @@ withTcPlugins hsc_env m =
getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin]
getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args)
+
+withHfPlugins :: HscEnv -> TcM a -> TcM a
+withHfPlugins hsc_env m =
+ case (getHfPlugins (hsc_dflags hsc_env)) of
+ [] -> m -- Common fast case
+ plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins
+ -- This ensures that hfPluginStop is called even if a type
+ -- error occurs during compilation.
+ eitherRes <- tryM $ do
+ updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m
+ sequence_ stops
+ case eitherRes of
+ Left _ -> failM
+ Right res -> return res
+ where
+ startPlugin (HoleFitPluginR init plugin stop) =
+ do ref <- init
+ return (plugin ref, stop ref)
+
+getHfPlugins :: DynFlags -> [HoleFitPluginR]
+getHfPlugins dflags =
+ catMaybes $ mapPlugins dflags (\p args -> holeFitPlugin p args)
+
+
runRenamerPlugin :: TcGblEnv
-> HsGroup GhcRn
-> TcM (TcGblEnv, HsGroup GhcRn)
=====================================
compiler/typecheck/TcRnMonad.hs
=====================================
@@ -312,6 +312,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
tcg_safeInfer = infer_var,
tcg_dependent_files = dependent_files_var,
tcg_tc_plugins = [],
+ tcg_hf_plugins = [],
tcg_top_loc = loc,
tcg_static_wc = static_wc_var,
tcg_complete_matches = [],
=====================================
compiler/typecheck/TcRnTypes.hs
=====================================
@@ -130,6 +130,10 @@ module TcRnTypes(
eqCanDischargeFR,
funEqCanDischarge, funEqCanDischargeF,
+ -- Hole Fit Plugins
+ TypedHole (..), HoleFit (..), HoleFitCandidate (..),
+ CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..),
+
-- Pretty printing
pprEvVarTheta,
pprEvVars, pprEvVarWithType,
@@ -685,6 +689,8 @@ data TcGblEnv
tcg_tc_plugins :: [TcPluginSolver],
-- ^ A list of user-defined plugins for the constraint solver.
+ tcg_hf_plugins :: [HoleFitPlugin],
+ -- ^ A list of user-defined plugins for hole fit suggestions.
tcg_top_loc :: RealSrcSpan,
-- ^ The RealSrcSpan this module came from
@@ -1020,7 +1026,7 @@ splice. In particular it is not set when the splice is renamed or typechecked.
'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert
the finalizer (see Note [Delaying modFinalizers in untyped splices]), and
'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to
-set 'RunSplice' when renaming or typechecking the splice, where 'Splice',
+set 'RunSplice' when renaming or typechecking the splice, where 'Splice',
'Brack' or 'Comp' are used instead.
-}
@@ -3916,3 +3922,75 @@ getRoleAnnots :: [Name] -> RoleAnnotEnv
getRoleAnnots bndrs role_env
= ( mapMaybe (lookupRoleAnnot role_env) bndrs
, delListFromNameEnv role_env bndrs )
+
+{-
+Hole Fit Plugins
+-------------------------
+-}
+
+data TypedHole = TyH { relevantCts :: Cts
+ -- ^ Any relevant Cts to the hole
+ , implics :: [Implication]
+ -- ^ The nested implications of the hole with the
+ -- innermost implication first.
+ , holeCt :: Maybe Ct
+ -- ^ The hole constraint itself, if available.
+ }
+
+instance Outputable TypedHole where
+ ppr (TyH rels implics ct)
+ = hang (text "TypedHole") 2
+ (ppr rels $+$ ppr implics $+$ ppr ct)
+
+-- | A plugin for modifying the candidate hole fits *before* they're checked.
+type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]
+
+-- | A plugin for modifying hole fits *after* they've been found.
+type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit]
+
+data HoleFitPlugin = HoleFitPlugin
+ { candPlugin :: CandPlugin
+ , fitPlugin :: FitPlugin }
+
+data HoleFitPluginR = forall s. HoleFitPluginR
+ { hfPluginInit :: TcM (TcRef s)
+ , holeFitPluginR :: TcRef s -> HoleFitPlugin
+ , hfPluginStop :: TcRef s -> TcM () }
+
+-- | HoleFitCandidates are passed to the filter and checked whether they can be
+-- made to fit.
+data HoleFitCandidate = IdHFCand Id -- An id, like locals.
+ | NameHFCand Name -- A name, like built-in syntax.
+ | GreHFCand GlobalRdrElt -- A global, like imported ids.
+ deriving (Eq)
+instance Outputable HoleFitCandidate where
+ ppr = pprHoleFitCand
+
+pprHoleFitCand :: HoleFitCandidate -> SDoc
+pprHoleFitCand (IdHFCand id) = text "Id HFC: " <> ppr id
+pprHoleFitCand (NameHFCand name) = text "Name HFC: " <> ppr name
+pprHoleFitCand (GreHFCand gre) = text "Gre HFC: " <> ppr gre
+
+instance HasOccName HoleFitCandidate where
+ occName hfc = case hfc of
+ IdHFCand id -> occName id
+ NameHFCand name -> occName name
+ GreHFCand gre -> occName (gre_name gre)
+
+-- | HoleFit is the type we use for valid hole fits. It contains the
+-- element that was checked, the Id of that element as found by `tcLookup`,
+-- and the refinement level of the fit, which is the number of extra argument
+-- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).
+data HoleFit =
+ HoleFit { hfId :: Id -- The elements id in the TcM
+ , hfCand :: HoleFitCandidate -- The candidate that was checked.
+ , hfType :: TcType -- The type of the id, possibly zonked.
+ , hfRefLvl :: Int -- The number of holes in this fit.
+ , hfWrap :: [TcType] -- The wrapper for the match.
+ , hfMatches :: [TcType] -- What the refinement variables got matched
+ -- with, if anything
+ , hfDoc :: Maybe HsDocString } -- Documentation of this HoleFit, if
+ -- available.
+ | RawHoleFit SDoc
+ -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins
+ -- can inject any fit they want.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/8fe4f8a316d721940fbd05865267bea14e52e3e2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/8fe4f8a316d721940fbd05865267bea14e52e3e2
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190522/6bd2a8a0/attachment-0001.html>
More information about the ghc-commits
mailing list