Add TcRef to allow internal state of plugin
authorMatthías Páll Gissurarson <pallm@chalmers.se>
Wed, 22 May 2019 16:22:34 +0000 (18:22 +0200)
committerMatthías Páll Gissurarson <pallm@chalmers.se>
Wed, 22 May 2019 16:25:16 +0000 (18:25 +0200)
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

index eed8833..971a6c0 100644 (file)
@@ -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
index d1bb0c9..70d1df3 100644 (file)
@@ -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,
index d727d6b..16e0c95 100644 (file)
@@ -10,5 +10,3 @@ import VarEnv     ( TidyEnv )
 
 findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct
                   -> TcM (TidyEnv, SDoc)
-
-data HoleFitPlugin
index 9c60709..3a551b5 100644 (file)
@@ -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)
index 8b720d6..a74b23d 100644 (file)
@@ -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 = [],
index 9cf338b..30a9a2c 100644 (file)
@@ -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.