summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/main/Plugins.hs14
-rw-r--r--compiler/typecheck/TcHoleErrors.hs282
-rw-r--r--compiler/typecheck/TcHoleFitTypes.hs144
-rw-r--r--compiler/typecheck/TcHoleFitTypes.hs-boot10
-rw-r--r--compiler/typecheck/TcRnDriver.hs31
-rw-r--r--compiler/typecheck/TcRnMonad.hs1
-rw-r--r--compiler/typecheck/TcRnTypes.hs4
-rw-r--r--docs/users_guide/extending_ghc.rst323
-rw-r--r--testsuite/tests/plugins/Makefile4
-rw-r--r--testsuite/tests/plugins/all.T8
-rw-r--r--testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.cabal11
-rw-r--r--testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs89
-rw-r--r--testsuite/tests/plugins/hole-fit-plugin/Makefile18
-rw-r--r--testsuite/tests/plugins/hole-fit-plugin/Setup.hs3
-rw-r--r--testsuite/tests/plugins/test-hole-plugin.hs19
-rw-r--r--testsuite/tests/plugins/test-hole-plugin.stderr66
17 files changed, 864 insertions, 164 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 1a235c4008..35810cc7c5 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -521,6 +521,7 @@ Library
TcRules
TcSimplify
TcHoleErrors
+ TcHoleFitTypes
TcErrors
TcTyClsDecls
TcTyDecls
diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs
index 93297522db..26bd41fd08 100644
--- a/compiler/main/Plugins.hs
+++ b/compiler/main/Plugins.hs
@@ -30,6 +30,10 @@ module Plugins (
-- - access to loaded interface files with 'interfaceLoadAction'
--
, keepRenamedSource
+ -- ** Hole fit plugins
+ -- | hole fit plugins allow plugins to change the behavior of valid hole
+ -- fit suggestions
+ , HoleFitPluginR
-- * Internal
, PluginWithArgs(..), plugins, pluginRecompile'
@@ -42,7 +46,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 )
+import TcHoleFitTypes ( HoleFitPluginR )
import HsSyn
import DynFlags
import HscTypes
@@ -79,6 +84,9 @@ data Plugin = Plugin {
, tcPlugin :: TcPlugin
-- ^ An optional typechecker plugin, which may modify the
-- 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.
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
-- ^ Specify how the plugin should affect recompilation.
, parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule
@@ -169,6 +177,7 @@ instance Monoid PluginRecompile where
type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin
+type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR
purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile
purePlugin _args = return NoForceRecompile
@@ -186,7 +195,8 @@ defaultPlugin :: Plugin
defaultPlugin = Plugin {
installCoreToDos = const return
, tcPlugin = const Nothing
- , pluginRecompile = impurePlugin
+ , holeFitPlugin = const Nothing
+ , pluginRecompile = impurePlugin
, renamedResultAction = \_ env grp -> return (env, grp)
, parsedResultAction = \_ _ -> return
, typeCheckResultAction = \_ _ -> return
diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs
index a5a4cf28d4..8c9cf0285b 100644
--- a/compiler/typecheck/TcHoleErrors.hs
+++ b/compiler/typecheck/TcHoleErrors.hs
@@ -1,6 +1,18 @@
-module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits, HoleFit (..)
- , HoleFitCandidate (..), tcCheckHoleFit, tcSubsumes
- , withoutUnification ) where
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits
+ , tcCheckHoleFit, tcSubsumes
+ , withoutUnification
+ , fromPureHFPlugin
+ -- Re-exports for convenience
+ , hfIsLcl
+ , pprHoleFit, debugHoleFitDispConfig
+
+ -- Re-exported from TcHoleFitTypes
+ , TypedHole (..), HoleFit (..), HoleFitCandidate (..)
+ , CandPlugin, FitPlugin
+ , HoleFitPlugin (..), HoleFitPluginR (..)
+ ) where
import GhcPrelude
@@ -28,10 +40,9 @@ import FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV )
import Control.Arrow ( (&&&) )
-import Control.Monad ( filterM, replicateM )
+import Control.Monad ( filterM, replicateM, foldM )
import Data.List ( partition, sort, sortOn, nubBy )
import Data.Graph ( graphFromEdges, topSort )
-import Data.Function ( on )
import TcSimplify ( simpl_top, runTcSDeriveds )
@@ -39,12 +50,14 @@ 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 TcHoleFitTypes
+
{-
Note [Valid hole fits include ...]
@@ -420,72 +433,6 @@ getSortingAlg =
then BySize
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.
-
-
-hfName :: HoleFit -> Name
-hfName hf = case hfCand hf of
- IdHFCand id -> idName id
- NameHFCand name -> name
- GreHFCand gre -> gre_name gre
-
-hfIsLcl :: HoleFit -> Bool
-hfIsLcl hf = case hfCand hf of
- IdHFCand _ -> True
- NameHFCand _ -> False
- GreHFCand gre -> gre_lcl gre
-
--- We define an Eq and Ord instance to be able to build a graph.
-instance Eq HoleFit where
- (==) = (==) `on` hfId
-
--- We compare HoleFits by their name instead of their Id, since we don't
--- want our tests to be affected by the non-determinism of `nonDetCmpVar`,
--- which is used to compare Ids. When comparing, we want HoleFits with a lower
--- refinement level to come first.
-instance Ord HoleFit where
- compare a b = cmp a b
- where cmp = if hfRefLvl a == hfRefLvl b
- then compare `on` hfName
- else compare `on` hfRefLvl
-
-instance Outputable HoleFit where
- ppr = pprHoleFit debugHoleFitDispConfig
-
-- If enabled, we go through the fits and add any associated documentation,
-- by looking it up in the module or the environment (for local fits)
addDocs :: [HoleFit] -> TcM [HoleFit]
@@ -499,70 +446,70 @@ addDocs fits =
msg = text "TcHoleErrors addDocs"
lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })
= Map.lookup name dmap
- upd lclDocs fit =
- let name = hfName fit in
- do { doc <- if hfIsLcl fit
- then pure (Map.lookup name lclDocs)
- else do { mbIface <- loadInterfaceForNameMaybe msg name
- ; return $ mbIface >>= lookupInIface name }
- ; return $ fit {hfDoc = doc} }
+ upd lclDocs fit@(HoleFit {hfCand = cand}) =
+ do { let name = getName cand
+ ; doc <- if hfIsLcl fit
+ then pure (Map.lookup name lclDocs)
+ else do { mbIface <- loadInterfaceForNameMaybe msg name
+ ; return $ mbIface >>= lookupInIface name }
+ ; return $ fit {hfDoc = doc} }
+ upd _ fit = return fit
-- For pretty printing hole fits, we display the name and type of the fit,
-- with added '_' to represent any extra arguments in case of a non-zero
-- refinement level.
pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
-pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) hf = hang display 2 provenance
- where name = hfName hf
- ty = hfType hf
- matches = hfMatches hf
- wrap = hfWrap hf
- tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars wrap
- where pprArg b arg = case binderArgFlag b of
- Specified -> text "@" <> pprParendType arg
- -- Do not print type application for inferred
- -- variables (#16456)
- Inferred -> empty
- Required -> pprPanic "pprHoleFit: bad Required"
+pprHoleFit _ (RawHoleFit sd) = sd
+pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) =
+ hang display 2 provenance
+ where name = getName hfCand
+ tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap
+ where pprArg b arg = case binderArgFlag b of
+ Specified -> text "@" <> pprParendType arg
+ -- Do not print type application for inferred
+ -- variables (#16456)
+ Inferred -> empty
+ Required -> pprPanic "pprHoleFit: bad Required"
(ppr b <+> ppr arg)
- tyAppVars = sep $ punctuate comma $
- zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+>
- text "~" <+> pprParendType t)
- vars wrap
-
- vars = unwrapTypeVars ty
- where
- -- Attempts to get all the quantified type variables in a type,
- -- e.g.
- -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a)
- -- into [m, a]
- unwrapTypeVars :: Type -> [TyCoVarBinder]
- unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of
- Just (_, unfunned) -> unwrapTypeVars unfunned
- _ -> []
- where (vars, unforalled) = splitForAllVarBndrs t
- holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) matches
- holeDisp = if sMs then holeVs
- else sep $ replicate (length matches) $ text "_"
- occDisp = pprPrefixOcc name
- tyDisp = ppWhen sTy $ dcolon <+> ppr ty
- has = not . null
- wrapDisp = ppWhen (has wrap && (sWrp || sWrpVars))
- $ text "with" <+> if sWrp || not sTy
- then occDisp <+> tyApp
- else tyAppVars
- docs = case hfDoc hf of
- Just d -> text "{-^" <>
- (vcat . map text . lines . unpackHDS) d
- <> text "-}"
- _ -> empty
- funcInfo = ppWhen (has matches && sTy) $
- text "where" <+> occDisp <+> tyDisp
- subDisp = occDisp <+> if has matches then holeDisp else tyDisp
- display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)
- provenance = ppWhen sProv $ parens $
- case hfCand hf of
- GreHFCand gre -> pprNameProvenance gre
- _ -> text "bound at" <+> ppr (getSrcLoc name)
+ tyAppVars = sep $ punctuate comma $
+ zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+>
+ text "~" <+> pprParendType t)
+ vars hfWrap
+
+ vars = unwrapTypeVars hfType
+ where
+ -- Attempts to get all the quantified type variables in a type,
+ -- e.g.
+ -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a)
+ -- into [m, a]
+ unwrapTypeVars :: Type -> [TyCoVarBinder]
+ unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of
+ Just (_, unfunned) -> unwrapTypeVars unfunned
+ _ -> []
+ where (vars, unforalled) = splitForAllVarBndrs t
+ holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches
+ holeDisp = if sMs then holeVs
+ else sep $ replicate (length hfMatches) $ text "_"
+ occDisp = pprPrefixOcc name
+ tyDisp = ppWhen sTy $ dcolon <+> ppr hfType
+ has = not . null
+ wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars))
+ $ text "with" <+> if sWrp || not sTy
+ then occDisp <+> tyApp
+ else tyAppVars
+ docs = case hfDoc of
+ Just d -> text "{-^" <>
+ (vcat . map text . lines . unpackHDS) d
+ <> text "-}"
+ _ -> empty
+ funcInfo = ppWhen (has hfMatches && sTy) $
+ text "where" <+> occDisp <+> tyDisp
+ subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp
+ display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)
+ provenance = ppWhen sProv $ parens $
+ case hfCand of
+ GreHFCand gre -> pprNameProvenance gre
+ _ -> text "bound at" <+> ppr (getSrcLoc name)
getLocalBindings :: TidyEnv -> Ct -> TcM [Id]
getLocalBindings tidy_orig ct
@@ -598,11 +545,15 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
; maxVSubs <- maxValidHoleFits <$> getDynFlags
; hfdc <- getHoleFitDispConfig
; sortingAlg <- getSortingAlg
+ ; dflags <- getDynFlags
+ ; hfPlugs <- tcg_hf_plugins <$> getGblEnv
; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs
- ; refLevel <- refLevelHoleFits <$> getDynFlags
- ; traceTc "findingValidHoleFitsFor { " $ ppr ct
+ refLevel = refLevelHoleFits dflags
+ hole = TyH (listToBag relevantCts) implics (Just ct)
+ (candidatePlugins, fitPlugins) =
+ unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs
+ ; traceTc "findingValidHoleFitsFor { " $ ppr hole
; traceTc "hole_lvl is:" $ ppr hole_lvl
- ; traceTc "implics are: " $ ppr implics
; traceTc "simples are: " $ ppr simples
; traceTc "locals are: " $ ppr lclBinds
; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env)
@@ -615,11 +566,14 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
globals = map GreHFCand gbl
syntax = map NameHFCand builtIns
to_check = locals ++ syntax ++ globals
+ ; cands <- foldM (flip ($)) to_check candidatePlugins
+ ; traceTc "numPlugins are:" $ ppr (length candidatePlugins)
; (searchDiscards, subs) <-
- tcFilterHoleFits findVLimit implics relevantCts (hole_ty, []) to_check
+ tcFilterHoleFits findVLimit hole (hole_ty, []) cands
; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs
; tidy_sorted_subs <- sortFits sortingAlg tidy_subs
- ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs tidy_sorted_subs
+ ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins
+ ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs
vDiscards = pVDisc || searchDiscards
; subs_with_docs <- addDocs limited_subs
; let vMsg = ppUnless (null subs_with_docs) $
@@ -638,8 +592,8 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
; traceTc "ref_tys are" $ ppr ref_tys
; let findRLimit = if sortingAlg > NoSorting then Nothing
else maxRSubs
- ; refDs <- mapM (flip (tcFilterHoleFits findRLimit implics
- relevantCts) to_check) ref_tys
+ ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole)
+ cands) ref_tys
; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs
; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs
-- For refinement substitutions we want matches
@@ -649,8 +603,10 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty
; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap
(exact, not_exact) = partition hasExactApp tidy_sorted_rsubs
- (pRDisc, exact_last_rfits) =
- possiblyDiscard maxRSubs $ not_exact ++ exact
+ ; plugin_handled_rsubs <- foldM (flip ($))
+ (not_exact ++ exact) fitPlugins
+ ; let (pRDisc, exact_last_rfits) =
+ possiblyDiscard maxRSubs $ plugin_handled_rsubs
rDiscards = pRDisc || any fst refDs
; rsubs_with_docs <- addDocs exact_last_rfits
; return (tidy_env,
@@ -732,6 +688,9 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
where zonkSubs' zs env [] = return (env, reverse zs)
zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf
; zonkSubs' (z:zs) env' hfs }
+
+ zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit)
+ zonkSub env hf@RawHoleFit{} = return (env, hf)
zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}
= do { (env, ty') <- zonkTidyTcType env ty
; (env, m') <- zonkTidyTcTypes env m
@@ -786,10 +745,7 @@ findValidHoleFits env _ _ _ = return (env, empty)
-- running the type checker. Stops after finding limit matches.
tcFilterHoleFits :: Maybe Int
-- ^ How many we should output, if limited
- -> [Implication]
- -- ^ Enclosing implications for givens
- -> [Ct]
- -- ^ Any relevant unsolved simple constraints
+ -> TypedHole -- ^ The hole to filter against
-> (TcType, [TcTyVar])
-- ^ The type to check for fits and a list of refinement
-- variables (free type variables in the type) for emulating
@@ -799,8 +755,8 @@ tcFilterHoleFits :: Maybe Int
-> TcM (Bool, [HoleFit])
-- ^ We return whether or not we stopped due to hitting the limit
-- and the fits we found.
-tcFilterHoleFits (Just 0) _ _ _ _ = return (False, []) -- Stop right away on 0
-tcFilterHoleFits limit implics relevantCts ht@(hole_ty, _) candidates =
+tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0
+tcFilterHoleFits limit (TyH {..}) ht@(hole_ty, _) candidates =
do { traceTc "checkingFitsFor {" $ ppr hole_ty
; (discards, subs) <- go [] emptyVarSet limit ht candidates
; traceTc "checkingFitsFor }" empty
@@ -901,7 +857,7 @@ tcFilterHoleFits limit implics relevantCts ht@(hole_ty, _) candidates =
-- refinement hole fits, so we can't wrap the side-effects deeper than this.
withoutUnification fvs $
do { traceTc "checkingFitOf {" $ ppr ty
- ; (fits, wrp) <- tcCheckHoleFit (listToBag relevantCts) implics h_ty ty
+ ; (fits, wrp) <- tcCheckHoleFit hole h_ty ty
; traceTc "Did it fit?" $ ppr fits
; traceTc "wrap is: " $ ppr wrp
; traceTc "checkingFitOf }" empty
@@ -934,6 +890,7 @@ tcFilterHoleFits limit implics relevantCts ht@(hole_ty, _) candidates =
else return Nothing }
else return Nothing }
where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty
+ hole = TyH tyHRelevantCts tyHImplics Nothing
subsDiscardMsg :: SDoc
@@ -970,8 +927,8 @@ withoutUnification free_vars action =
-- discarding any errors. Subsumption here means that the ty_b can fit into the
-- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a.
tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool
-tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit emptyBag [] ty_a ty_b
-
+tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b
+ where dummyHole = TyH emptyBag [] Nothing
-- | A tcSubsumes which takes into account relevant constraints, to fix trac
-- #14273. This makes sure that when checking whether a type fits the hole,
@@ -979,24 +936,22 @@ tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit emptyBag [] ty_a ty_b
-- constraints on the type of the hole.
-- Note: The simplifier may perform unification, so make sure to restore any
-- free type variables to avoid side-effects.
-tcCheckHoleFit :: Cts -- ^ Any relevant Cts to the hole.
- -> [Implication]
- -- ^ The nested implications of the hole with the innermost
- -- implication first.
- -> TcSigmaType -- ^ The type of the hole.
- -> TcSigmaType -- ^ The type to check whether fits.
+tcCheckHoleFit :: TypedHole -- ^ The hole to check against
+ -> TcSigmaType
+ -- ^ The type to check against (possibly modified, e.g. refined)
+ -> TcSigmaType -- ^ The type to check whether fits.
-> TcM (Bool, HsWrapper)
-- ^ Whether it was a match, and the wrapper from hole_ty to ty.
-tcCheckHoleFit _ _ hole_ty ty | hole_ty `eqType` ty
+tcCheckHoleFit _ hole_ty ty | hole_ty `eqType` ty
= return (True, idHsWrapper)
-tcCheckHoleFit relevantCts implics hole_ty ty = discardErrs $
+tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $
do { -- We wrap the subtype constraint in the implications to pass along the
-- givens, and so we must ensure that any nested implications and skolems
-- end up with the correct level. The implications are ordered so that
-- the innermost (the one with the highest level) is first, so it
-- suffices to get the level of the first one (or the current level, if
-- there are no implications involved).
- innermost_lvl <- case implics of
+ innermost_lvl <- case tyHImplics of
[] -> getTcLevel
-- imp is the innermost implication
(imp:_) -> return (ic_tclvl imp)
@@ -1004,15 +959,15 @@ tcCheckHoleFit relevantCts implics hole_ty ty = discardErrs $
tcSubType_NC ExprSigCtxt ty hole_ty
; traceTc "Checking hole fit {" empty
; traceTc "wanteds are: " $ ppr wanted
- ; if isEmptyWC wanted && isEmptyBag relevantCts
+ ; if isEmptyWC wanted && isEmptyBag tyHRelevantCts
then traceTc "}" empty >> return (True, wrp)
else do { fresh_binds <- newTcEvBinds
-- The relevant constraints may contain HoleDests, so we must
-- take care to clone them as well (to avoid #15370).
- ; cloned_relevants <- mapBagM cloneWanted relevantCts
+ ; cloned_relevants <- mapBagM cloneWanted tyHRelevantCts
-- We wrap the WC in the nested implications, see
-- Note [Nested Implications]
- ; let outermost_first = reverse implics
+ ; let outermost_first = reverse tyHImplics
setWC = setWCAndBinds fresh_binds
-- We add the cloned relevants to the wanteds generated by
-- the call to tcSubType_NC, see Note [Relevant Constraints]
@@ -1035,3 +990,10 @@ tcCheckHoleFit relevantCts implics hole_ty ty = discardErrs $
setWCAndBinds binds imp wc
= WC { wc_simple = emptyBag
, wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } }
+
+-- | Maps a plugin that needs no state to one with an empty one.
+fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR
+fromPureHFPlugin plug =
+ HoleFitPluginR { hfPluginInit = newTcRef ()
+ , hfPluginRun = const plug
+ , hfPluginStop = const $ return () }
diff --git a/compiler/typecheck/TcHoleFitTypes.hs b/compiler/typecheck/TcHoleFitTypes.hs
new file mode 100644
index 0000000000..8700cc1399
--- /dev/null
+++ b/compiler/typecheck/TcHoleFitTypes.hs
@@ -0,0 +1,144 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module TcHoleFitTypes (
+ TypedHole (..), HoleFit (..), HoleFitCandidate (..),
+ CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..),
+ hfIsLcl, pprHoleFitCand
+ ) where
+
+import GhcPrelude
+
+import TcRnTypes
+import TcType
+
+import RdrName
+
+import HsDoc
+import Id
+
+import Outputable
+import Name
+
+import Data.Function ( on )
+
+data TypedHole = TyH { tyHRelevantCts :: Cts
+ -- ^ Any relevant Cts to the hole
+ , tyHImplics :: [Implication]
+ -- ^ The nested implications of the hole with the
+ -- innermost implication first.
+ , tyHCt :: 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)
+
+
+-- | HoleFitCandidates are passed to hole fit plugins and then
+-- checked whether they fit a given typed-hole.
+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 cid) = text "Id HFC: " <> ppr cid
+pprHoleFitCand (NameHFCand cname) = text "Name HFC: " <> ppr cname
+pprHoleFitCand (GreHFCand cgre) = text "Gre HFC: " <> ppr cgre
+
+
+
+
+instance NamedThing HoleFitCandidate where
+ getName hfc = case hfc of
+ IdHFCand cid -> idName cid
+ NameHFCand cname -> cname
+ GreHFCand cgre -> gre_name cgre
+ getOccName hfc = case hfc of
+ IdHFCand cid -> occName cid
+ NameHFCand cname -> occName cname
+ GreHFCand cgre -> occName (gre_name cgre)
+
+instance HasOccName HoleFitCandidate where
+ occName = getOccName
+
+instance Ord HoleFitCandidate where
+ compare = compare `on` getName
+
+-- | 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.
+
+-- We define an Eq and Ord instance to be able to build a graph.
+instance Eq HoleFit where
+ (==) = (==) `on` hfId
+
+instance Outputable HoleFit where
+ ppr (RawHoleFit sd) = sd
+ ppr (HoleFit _ cand ty _ _ mtchs _) =
+ hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty))
+ where name = ppr $ getName cand
+ holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs
+
+-- We compare HoleFits by their name instead of their Id, since we don't
+-- want our tests to be affected by the non-determinism of `nonDetCmpVar`,
+-- which is used to compare Ids. When comparing, we want HoleFits with a lower
+-- refinement level to come first.
+instance Ord HoleFit where
+ compare (RawHoleFit _) (RawHoleFit _) = EQ
+ compare (RawHoleFit _) _ = LT
+ compare _ (RawHoleFit _) = GT
+ compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b
+ where cmp = if hfRefLvl a == hfRefLvl b
+ then compare `on` (getName . hfCand)
+ else compare `on` hfRefLvl
+
+hfIsLcl :: HoleFit -> Bool
+hfIsLcl hf@(HoleFit {}) = case hfCand hf of
+ IdHFCand _ -> True
+ NameHFCand _ -> False
+ GreHFCand gre -> gre_lcl gre
+hfIsLcl _ = False
+
+
+-- | 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]
+
+-- | A HoleFitPlugin is a pair of candidate and fit plugins.
+data HoleFitPlugin = HoleFitPlugin
+ { candPlugin :: CandPlugin
+ , fitPlugin :: FitPlugin }
+
+-- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can
+-- track internal state. Note the existential quantification, ensuring that
+-- the state cannot be modified from outside the plugin.
+data HoleFitPluginR = forall s. HoleFitPluginR
+ { hfPluginInit :: TcM (TcRef s)
+ -- ^ Initializes the TcRef to be passed to the plugin
+ , hfPluginRun :: TcRef s -> HoleFitPlugin
+ -- ^ The function defining the plugin itself
+ , hfPluginStop :: TcRef s -> TcM ()
+ -- ^ Cleanup of state, guaranteed to be called even on error
+ }
diff --git a/compiler/typecheck/TcHoleFitTypes.hs-boot b/compiler/typecheck/TcHoleFitTypes.hs-boot
new file mode 100644
index 0000000000..fde064e51a
--- /dev/null
+++ b/compiler/typecheck/TcHoleFitTypes.hs-boot
@@ -0,0 +1,10 @@
+-- This boot file is in place to break the loop where:
+-- + TcRnTypes needs 'HoleFitPlugin',
+-- + which needs 'TcHoleFitTypes'
+-- + which needs 'TcRnTypes'
+module TcHoleFitTypes where
+
+-- Build ordering
+import GHC.Base()
+
+data HoleFitPlugin
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 3ffc5df61e..55c229766f 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -140,6 +140,9 @@ import qualified Data.Set as S
import Control.DeepSeq
import Control.Monad
+import TcHoleFitTypes ( HoleFitPluginR (..) )
+
+
#include "HsVersions.h"
{-
@@ -164,7 +167,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 $ withHoleFitPlugins hsc_env $
tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
@@ -1840,7 +1843,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 $ withHoleFitPlugins 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)
@@ -2880,6 +2883,30 @@ withTcPlugins hsc_env m =
getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin]
getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args)
+
+withHoleFitPlugins :: HscEnv -> TcM a -> TcM a
+withHoleFitPlugins 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)
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 9a76e9ced8..e297301b6b 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/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 = [],
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 3bd26e9f76..c8d83215fd 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -208,6 +208,8 @@ import Data.Maybe ( mapMaybe )
import GHCi.Message
import GHCi.RemoteTypes
+import {-# SOURCE #-} TcHoleFitTypes ( HoleFitPlugin )
+
import qualified Language.Haskell.TH as TH
-- | A 'NameShape' is a substitution on 'Name's that can be used
@@ -685,6 +687,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
diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst
index ee816bf1b0..6b6a1ed3cb 100644
--- a/docs/users_guide/extending_ghc.rst
+++ b/docs/users_guide/extending_ghc.rst
@@ -834,6 +834,329 @@ output:
typeCheckPlugin (tc):
{$trModule = Module (TrNameS "main"#) (TrNameS "A"#), a = ()}
+.. _hole-fit-plugins
+
+Hole fit plugins
+~~~~~~~~~~~~~~~~
+
+Hole-fit plugins are plugins that are called when a typed-hole error message is
+being generated, and allows you to access information about the typed-hole at
+compile time, and allows you to customize valid hole fit suggestions.
+
+Using hole-fit plugins, you can extend the behavior of valid hole fit
+suggestions to use e.g. Hoogle or other external tools to find and/or synthesize
+valid hole fits, with the same information about the typed-hole that GHC uses.
+
+There are two access points are bundled together for defining hole fit plugins,
+namely a candidate plugin and a fit plugin, for modifying the candidates to be
+checked and fits respectively.
+
+
+::
+
+ type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]
+
+ type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit]
+
+ data HoleFitPlugin = HoleFitPlugin
+ { candPlugin :: CandPlugin
+ -- ^ A plugin for modifying hole fit candidates before they're checked
+ , fitPlugin :: FitPlugin
+ -- ^ A plugin for modifying valid hole fits after they've been found.
+ }
+
+Where ``TypedHole`` contains all the information about the hole available to GHC
+at error generation.
+
+::
+
+ data TypedHole = TyH { tyHRelevantCts :: Cts
+ -- ^ Any relevant Cts to the hole
+ , tyHImplics :: [Implication]
+ -- ^ The nested implications of the hole with the
+ -- innermost implication first.
+ , tyHCt :: Maybe Ct
+ -- ^ The hole constraint itself, if available.
+ }
+
+``HoleFitPlugins`` are then defined as follows
+
+::
+
+ plugin :: Plugin
+ plugin = defaultPlugin {
+ holeFitPlugin = (fmap . fmap) fromPureHFPlugin hfPlugin
+ }
+
+
+ hfPlugin :: [CommandLineOption] -> Maybe HoleFitPlugin
+
+
+Where ``fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR`` is a convencience
+function provided in the ``TcHoleErrors`` module, for defining plugins that do
+not require internal state.
+
+
+Stateful hole fit plugins
+^^^^^^^^^^^^^^^^^^^^^^^^^
+
+
+``HoleFitPlugins`` are wrapped in a ``HoleFitPluginR``, which provides a
+``TcRef`` for the plugin to use to track internal state, and to facilitate
+communication between the candidate and fit plugin.
+
+::
+
+ -- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can
+ -- track internal state. Note the existential quantification, ensuring that
+ -- the state cannot be modified from outside the plugin.
+ data HoleFitPluginR = forall s. HoleFitPluginR
+ { hfPluginInit :: TcM (TcRef s)
+ -- ^ Initializes the TcRef to be passed to the plugin
+ , hfPluginRun :: TcRef s -> HoleFitPlugin
+ -- ^ The function defining the plugin itself
+ , hfPluginStop :: TcRef s -> TcM ()
+ -- ^ Cleanup of state, guaranteed to be called even on error
+ }
+
+The plugin is then defined as by providing a value for the ``holeFitPlugin``
+field, a function that takes the ``CommandLineOption`` strings that are passed
+to the compiler using the :ghc-flag:`-fplugin-opt` flags and returns a
+``HoleFitPluginR``. This function can be used to pass the ``CommandLineOption``
+strings along to the candidate and fit plugins respectively.
+
+
+
+Hole fit plugin example
+^^^^^^^^^^^^^^^^^^^^^^^
+
+The following plugins allows users to limit the search for valid hole fits to
+certain modules, to sort the hole fits by where they originated (in ascending or
+descending order), as well as allowing users to put a limit on how much time is
+spent on searching for valid hole fits, after which new searches are aborted.
+
+::
+
+ {-# LANGUAGE TypeApplications, RecordWildCards #-}
+ module HolePlugin where
+
+ import GhcPlugins hiding ((<>))
+
+ import TcHoleErrors
+
+ import Data.List (stripPrefix, sortOn)
+
+ import TcRnTypes
+
+ import TcRnMonad
+
+ import Data.Time (UTCTime, NominalDiffTime)
+ import qualified Data.Time as Time
+
+ import Text.Read
+
+
+ data HolePluginState = HPS { timeAlloted :: Maybe NominalDiffTime
+ , elapsedTime :: NominalDiffTime
+ , timeCurStarted :: UTCTime }
+
+ bumpElapsed :: NominalDiffTime -> HolePluginState -> HolePluginState
+ bumpElapsed ad (HPS a e t) = HPS a (e + ad) t
+
+ setAlloted :: Maybe NominalDiffTime -> HolePluginState -> HolePluginState
+ setAlloted a (HPS _ e t) = HPS a e t
+
+ setCurStarted :: UTCTime -> HolePluginState -> HolePluginState
+ setCurStarted nt (HPS a e _) = HPS a e nt
+
+ hpStartState :: HolePluginState
+ hpStartState = HPS Nothing zero undefined
+ where zero = fromInteger @NominalDiffTime 0
+
+ initPlugin :: [CommandLineOption] -> TcM (TcRef HolePluginState)
+ initPlugin [msecs] = newTcRef $ hpStartState { timeAlloted = alloted }
+ where
+ errMsg = "Invalid amount of milliseconds given to plugin: " <> show msecs
+ alloted = case readMaybe @Integer msecs of
+ Just millisecs -> Just $ fromInteger @NominalDiffTime millisecs / 1000
+ _ -> error errMsg
+ initPlugin _ = newTcRef hpStartState
+
+ fromModule :: HoleFitCandidate -> [String]
+ fromModule (GreHFCand gre) =
+ map (moduleNameString . importSpecModule) $ gre_imp gre
+ fromModule _ = []
+
+ toHoleFitCommand :: TypedHole -> String -> Maybe String
+ toHoleFitCommand TyH{tyHCt = Just (CHoleCan _ h)} str
+ = stripPrefix ("_" <> str) $ occNameString $ holeOcc h
+ toHoleFitCommand _ _ = Nothing
+
+ -- | This candidate plugin filters the candidates by module,
+ -- using the name of the hole as module to search in
+ modFilterTimeoutP :: [CommandLineOption] -> TcRef HolePluginState -> CandPlugin
+ modFilterTimeoutP _ ref hole cands = do
+ curTime <- liftIO Time.getCurrentTime
+ HPS {..} <- readTcRef ref
+ updTcRef ref (setCurStarted curTime)
+ return $ case timeAlloted of
+ -- If we're out of time we remove all the candidates. Then nothing is checked.
+ Just sofar | elapsedTime > sofar -> []
+ _ -> case toHoleFitCommand hole "only_" of
+
+ Just modName -> filter (inScopeVia modName) cands
+ _ -> cands
+ where inScopeVia modNameStr cand@(GreHFCand _) =
+ elem (toModName modNameStr) $ fromModule cand
+ inScopeVia _ _ = False
+ toModName = replace '_' '.'
+ replace :: Eq a => a -> a -> [a] -> [a]
+ replace _ _ [] = []
+ replace a b (x:xs) = (if x == a then b else x):replace a b xs
+
+ modSortP :: [CommandLineOption] -> TcRef HolePluginState -> FitPlugin
+ modSortP _ ref hole hfs = do
+ curTime <- liftIO Time.getCurrentTime
+ HPS {..} <- readTcRef ref
+ updTcRef ref $ bumpElapsed (Time.diffUTCTime curTime timeCurStarted)
+ return $ case timeAlloted of
+ -- If we're out of time, remove any candidates, so nothing is checked.
+ Just sofar | elapsedTime > sofar -> [RawHoleFit $ text msg]
+ _ -> case toHoleFitCommand hole "sort_by_mod" of
+ -- If only_ is on, the fits will all be from the same module.
+ Just ('_':'d':'e':'s':'c':_) -> reverse hfs
+ Just _ -> orderByModule hfs
+ _ -> hfs
+ where orderByModule :: [HoleFit] -> [HoleFit]
+ orderByModule = sortOn (fmap fromModule . mbHFCand)
+ mbHFCand :: HoleFit -> Maybe HoleFitCandidate
+ mbHFCand HoleFit {hfCand = c} = Just c
+ mbHFCand _ = Nothing
+ msg = hang (text "Error: The time ran out, and the search was aborted for this hole.")
+ 7 $ text "Try again with a longer timeout."
+
+ plugin :: Plugin
+ plugin = defaultPlugin { holeFitPlugin = holeFitP, pluginRecompile = purePlugin}
+
+ holeFitP :: [CommandLineOption] -> Maybe HoleFitPluginR
+ holeFitP opts = Just (HoleFitPluginR initP pluginDef stopP)
+ where initP = initPlugin opts
+ stopP = const $ return ()
+ pluginDef ref = HoleFitPlugin { candPlugin = modFilterTimeoutP opts ref
+ , fitPlugin = modSortP opts ref }
+
+When you then compile a module containing the following
+
+::
+
+ {-# OPTIONS -fplugin=HolePlugin
+ -fplugin-opt=HolePlugin:600
+ -funclutter-valid-hole-fits #-}
+ module Main where
+
+ import Prelude hiding (head, last)
+
+ import Data.List (head, last)
+
+
+ f, g, h, i, j :: [Int] -> Int
+ f = _too_long
+ j = _
+ i = _sort_by_mod_desc
+ g = _only_Data_List
+ h = _only_Prelude
+
+ main :: IO ()
+ main = return ()
+
+
+The output is as follows:
+
+.. code-block:: none
+
+ Main.hs:12:5: error:
+ • Found hole: _too_long :: [Int] -> Int
+ Or perhaps ‘_too_long’ is mis-spelled, or not in scope
+ • In the expression: _too_long
+ In an equation for ‘f’: f = _too_long
+ • Relevant bindings include
+ f :: [Int] -> Int (bound at Main.hs:12:1)
+ Valid hole fits include
+ Error: The time ran out, and the search was aborted for this hole.
+ Try again with a longer timeout.
+ |
+ 12 | f = _too_long
+ | ^^^^^^^^^
+
+ Main.hs:13:5: error:
+ • Found hole: _ :: [Int] -> Int
+ • In the expression: _
+ In an equation for ‘j’: j = _
+ • Relevant bindings include
+ j :: [Int] -> Int (bound at Main.hs:13:1)
+ Valid hole fits include
+ j :: [Int] -> Int
+ f :: [Int] -> Int
+ g :: [Int] -> Int
+ h :: [Int] -> Int
+ i :: [Int] -> Int
+ head :: forall a. [a] -> a
+ (Some hole fits suppressed; use -fmax-valid-hole-fits=N or -fno-max-valid-hole-fits)
+ |
+ 13 | j = _
+ | ^
+
+ Main.hs:14:5: error:
+ • Found hole: _sort_by_mod_desc :: [Int] -> Int
+ Or perhaps ‘_sort_by_mod_desc’ is mis-spelled, or not in scope
+ • In the expression: _sort_by_mod_desc
+ In an equation for ‘i’: i = _sort_by_mod_desc
+ • Relevant bindings include
+ i :: [Int] -> Int (bound at Main.hs:14:1)
+ Valid hole fits include
+ sum :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
+ product :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
+ minimum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ maximum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ length :: forall (t :: * -> *) a. Foldable t => t a -> Int
+ last :: forall a. [a] -> a
+ (Some hole fits suppressed; use -fmax-valid-hole-fits=N or -fno-max-valid-hole-fits)
+ |
+ 14 | i = _sort_by_mod_desc
+ | ^^^^^^^^^^^^^^^^^
+
+ Main.hs:15:5: error:
+ • Found hole: _only_Data_List :: [Int] -> Int
+ Or perhaps ‘_only_Data_List’ is mis-spelled, or not in scope
+ • In the expression: _only_Data_List
+ In an equation for ‘g’: g = _only_Data_List
+ • Relevant bindings include
+ g :: [Int] -> Int (bound at Main.hs:15:1)
+ Valid hole fits include
+ head :: forall a. [a] -> a
+ last :: forall a. [a] -> a
+ |
+ 15 | g = _only_Data_List
+ | ^^^^^^^^^^^^^^^
+
+ Main.hs:16:5: error:
+ • Found hole: _only_Prelude :: [Int] -> Int
+ Or perhaps ‘_only_Prelude’ is mis-spelled, or not in scope
+ • In the expression: _only_Prelude
+ In an equation for ‘h’: h = _only_Prelude
+ • Relevant bindings include
+ h :: [Int] -> Int (bound at Main.hs:16:1)
+ Valid hole fits include
+ length :: forall (t :: * -> *) a. Foldable t => t a -> Int
+ maximum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ minimum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ product :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
+ sum :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
+ |
+ 16 | h = _only_Prelude
+ | ^^^^^^^^^^^^^
+
+
.. _plugin_recompilation:
diff --git a/testsuite/tests/plugins/Makefile b/testsuite/tests/plugins/Makefile
index f58a771ef9..46ef8cb3eb 100644
--- a/testsuite/tests/plugins/Makefile
+++ b/testsuite/tests/plugins/Makefile
@@ -130,3 +130,7 @@ T16104:
T16260:
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 T16260.hs -package-db simple-plugin/pkg.T16260/local.package.conf -fplugin Simple.TrustworthyPlugin
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 T16260.hs -package-db simple-plugin/pkg.T16260/local.package.conf -fplugin Simple.TrustworthyPlugin -fplugin-trustworthy
+
+.PHONY: HoleFitPlugin
+HoleFitPlugin:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 HoleFitPlugin.hs -package-db hole-fit-plugin/pkg.hole-fit-plugin/local.package.conf
diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T
index aea3748767..a4273f5ae8 100644
--- a/testsuite/tests/plugins/all.T
+++ b/testsuite/tests/plugins/all.T
@@ -200,8 +200,16 @@ test('T16104',
],
makefile_test, [])
+
test('T16260',
[extra_files(['simple-plugin/']),
pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.T16260 TOP={top}')
],
makefile_test, [])
+
+test('test-hole-plugin',
+ [extra_files(['hole-fit-plugin/']),
+ pre_cmd('$MAKE -s --no-print-directory -C hole-fit-plugin package.hole-fit-plugin TOP={top}'),
+ extra_hc_opts('-package-db hole-fit-plugin/pkg.hole-fit-plugin/local.package.conf '+ config.plugin_way_flags)
+ ],
+ compile, ['-fdefer-typed-holes'])
diff --git a/testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.cabal b/testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.cabal
new file mode 100644
index 0000000000..344fccf461
--- /dev/null
+++ b/testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.cabal
@@ -0,0 +1,11 @@
+name: HoleFitPlugin
+cabal-version: >= 1.24
+build-type: Simple
+version: 1.0.0
+
+
+library
+ default-language: Haskell2010
+ build-depends: base, ghc, time
+ exposed-modules: HoleFitPlugin
+ ghc-options: -Wall
diff --git a/testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs b/testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs
new file mode 100644
index 0000000000..dc6e9762f5
--- /dev/null
+++ b/testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE TypeApplications, RecordWildCards #-}
+module HoleFitPlugin where
+
+import GhcPlugins hiding ((<>))
+
+import TcHoleErrors
+
+import Data.List (stripPrefix, sortOn)
+
+import TcRnTypes
+
+import TcRnMonad
+
+import Text.Read
+
+
+
+data HolePluginState = HPS { holesChecked :: Int
+ , holesLimit :: Maybe Int}
+
+bumpHolesChecked :: HolePluginState -> HolePluginState
+bumpHolesChecked (HPS h l) = HPS (h + 1) l
+
+initPlugin :: [CommandLineOption] -> TcM (TcRef HolePluginState)
+initPlugin [limit] = newTcRef $ HPS 0 $
+ case readMaybe @Int limit of
+ Just number -> Just number
+ _ -> error $ "Invalid argument to plugin: " <> show limit
+initPlugin _ = newTcRef $ HPS 0 Nothing
+
+fromModule :: HoleFitCandidate -> [String]
+fromModule (GreHFCand gre) =
+ map (moduleNameString . importSpecModule) $ gre_imp gre
+fromModule _ = []
+
+toHoleFitCommand :: TypedHole -> String -> Maybe String
+toHoleFitCommand TyH{tyHCt = Just (CHoleCan _ h)} str
+ = stripPrefix ("_" <> str) $ occNameString $ holeOcc h
+toHoleFitCommand _ _ = Nothing
+
+
+-- | This candidate plugin filters the candidates by module,
+-- using the name of the hole as module to search in
+modFilterTimeoutP :: [CommandLineOption] -> TcRef HolePluginState -> CandPlugin
+modFilterTimeoutP _ ref hole cands = do
+ updTcRef ref bumpHolesChecked
+ HPS {..} <- readTcRef ref
+ return $ case holesLimit of
+ -- If we're out of checks, remove any candidates, so nothing is checked.
+ Just limit | holesChecked > limit -> []
+ _ -> case toHoleFitCommand hole "only_" of
+ Just modName -> filter (inScopeVia modName) cands
+ _ -> cands
+ where inScopeVia modNameStr cand@(GreHFCand _) =
+ elem (toModName modNameStr) $ fromModule cand
+ inScopeVia _ _ = False
+ toModName = replace '_' '.'
+ replace :: Eq a => a -> a -> [a] -> [a]
+ replace _ _ [] = []
+ replace a b (x:xs) = (if x == a then b else x):replace a b xs
+
+
+modSortP :: [CommandLineOption] -> TcRef HolePluginState -> FitPlugin
+modSortP _ ref hole hfs = do
+ HPS {..} <- readTcRef ref
+ return $ case holesLimit of
+ Just limit | holesChecked > limit -> [RawHoleFit $ text msg]
+ _ -> case toHoleFitCommand hole "sort_by_mod" of
+ -- If only_ is on, the fits will all be from the same module.
+ Just ('_':'d':'e':'s':'c':_) -> reverse hfs
+ Just _ -> orderByModule hfs
+ _ -> hfs
+ where orderByModule :: [HoleFit] -> [HoleFit]
+ orderByModule = sortOn (fmap fromModule . mbHFCand)
+ mbHFCand :: HoleFit -> Maybe HoleFitCandidate
+ mbHFCand HoleFit {hfCand = c} = Just c
+ mbHFCand _ = Nothing
+ msg = "Error: Too many holes were checked, and the search aborted for"
+ <> "this hole. Try again with a higher limit."
+
+plugin :: Plugin
+plugin = defaultPlugin { holeFitPlugin = holeFitP, pluginRecompile = purePlugin}
+
+holeFitP :: [CommandLineOption] -> Maybe HoleFitPluginR
+holeFitP opts = Just (HoleFitPluginR initP pluginDef stopP)
+ where initP = initPlugin opts
+ stopP = const $ return ()
+ pluginDef ref = HoleFitPlugin { candPlugin = modFilterTimeoutP opts ref
+ , fitPlugin = modSortP opts ref }
diff --git a/testsuite/tests/plugins/hole-fit-plugin/Makefile b/testsuite/tests/plugins/hole-fit-plugin/Makefile
new file mode 100644
index 0000000000..7ce5b78e75
--- /dev/null
+++ b/testsuite/tests/plugins/hole-fit-plugin/Makefile
@@ -0,0 +1,18 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean.%:
+ rm -rf pkg.$*
+
+HERE := $(abspath .)
+$(eval $(call canonicalise,HERE))
+
+package.%:
+ $(MAKE) -s --no-print-directory clean.$*
+ mkdir pkg.$*
+ "$(TEST_HC)" -outputdir pkg.$* --make -v0 -o pkg.$*/setup Setup.hs
+ "$(GHC_PKG)" init pkg.$*/local.package.conf
+ pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" $(if $(findstring YES,$(HAVE_PROFILING)), --enable-library-profiling) --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf
+ pkg.$*/setup build --distdir pkg.$*/dist -v0
+ pkg.$*/setup install --distdir pkg.$*/dist -v0
diff --git a/testsuite/tests/plugins/hole-fit-plugin/Setup.hs b/testsuite/tests/plugins/hole-fit-plugin/Setup.hs
new file mode 100644
index 0000000000..e8ef27dbba
--- /dev/null
+++ b/testsuite/tests/plugins/hole-fit-plugin/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
diff --git a/testsuite/tests/plugins/test-hole-plugin.hs b/testsuite/tests/plugins/test-hole-plugin.hs
new file mode 100644
index 0000000000..dc6b67e1d2
--- /dev/null
+++ b/testsuite/tests/plugins/test-hole-plugin.hs
@@ -0,0 +1,19 @@
+{-# OPTIONS -fplugin=HoleFitPlugin
+ -fplugin-opt=HoleFitPlugin:4
+ -funclutter-valid-hole-fits #-}
+module Main where
+
+import Prelude hiding (head, last)
+
+import Data.List (head, last)
+
+
+f, g, h, i, j :: [Int] -> Int
+f = _too_long
+j = _
+i = _sort_by_mod_desc
+g = _only_Data_List
+h = _only_Prelude
+
+main :: IO ()
+main = return ()
diff --git a/testsuite/tests/plugins/test-hole-plugin.stderr b/testsuite/tests/plugins/test-hole-plugin.stderr
new file mode 100644
index 0000000000..7ca539e8d7
--- /dev/null
+++ b/testsuite/tests/plugins/test-hole-plugin.stderr
@@ -0,0 +1,66 @@
+
+test-hole-plugin.hs:12:5: warning: [-Wtyped-holes (in -Wdefault)]
+ • Found hole: _too_long :: [Int] -> Int
+ Or perhaps ‘_too_long’ is mis-spelled, or not in scope
+ • In the expression: _too_long
+ In an equation for ‘f’: f = _too_long
+ • Relevant bindings include
+ f :: [Int] -> Int (bound at test-hole-plugin.hs:12:1)
+ Valid hole fits include
+ Error: Too many holes were checked, and the search aborted forthis hole. Try again with a higher limit.
+
+test-hole-plugin.hs:13:5: warning: [-Wtyped-holes (in -Wdefault)]
+ • Found hole: _ :: [Int] -> Int
+ • In the expression: _
+ In an equation for ‘j’: j = _
+ • Relevant bindings include
+ j :: [Int] -> Int (bound at test-hole-plugin.hs:13:1)
+ Valid hole fits include
+ j :: [Int] -> Int
+ f :: [Int] -> Int
+ i :: [Int] -> Int
+ g :: [Int] -> Int
+ h :: [Int] -> Int
+ head :: forall a. [a] -> a
+ (Some hole fits suppressed; use -fmax-valid-hole-fits=N or -fno-max-valid-hole-fits)
+
+test-hole-plugin.hs:14:5: warning: [-Wtyped-holes (in -Wdefault)]
+ • Found hole: _sort_by_mod_desc :: [Int] -> Int
+ Or perhaps ‘_sort_by_mod_desc’ is mis-spelled, or not in scope
+ • In the expression: _sort_by_mod_desc
+ In an equation for ‘i’: i = _sort_by_mod_desc
+ • Relevant bindings include
+ i :: [Int] -> Int (bound at test-hole-plugin.hs:14:1)
+ Valid hole fits include
+ sum :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
+ product :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
+ minimum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ maximum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ length :: forall (t :: * -> *) a. Foldable t => t a -> Int
+ last :: forall a. [a] -> a
+ (Some hole fits suppressed; use -fmax-valid-hole-fits=N or -fno-max-valid-hole-fits)
+
+test-hole-plugin.hs:15:5: warning: [-Wtyped-holes (in -Wdefault)]
+ • Found hole: _only_Data_List :: [Int] -> Int
+ Or perhaps ‘_only_Data_List’ is mis-spelled, or not in scope
+ • In the expression: _only_Data_List
+ In an equation for ‘g’: g = _only_Data_List
+ • Relevant bindings include
+ g :: [Int] -> Int (bound at test-hole-plugin.hs:15:1)
+ Valid hole fits include
+ head :: forall a. [a] -> a
+ last :: forall a. [a] -> a
+
+test-hole-plugin.hs:16:5: warning: [-Wtyped-holes (in -Wdefault)]
+ • Found hole: _only_Prelude :: [Int] -> Int
+ Or perhaps ‘_only_Prelude’ is mis-spelled, or not in scope
+ • In the expression: _only_Prelude
+ In an equation for ‘h’: h = _only_Prelude
+ • Relevant bindings include
+ h :: [Int] -> Int (bound at test-hole-plugin.hs:16:1)
+ Valid hole fits include
+ length :: forall (t :: * -> *) a. Foldable t => t a -> Int
+ maximum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ minimum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ product :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
+ sum :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
View Lorry Controller Status