diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
| -rw-r--r-- | compiler/main/Plugins.hs | 14 | ||||
| -rw-r--r-- | compiler/typecheck/TcHoleErrors.hs | 282 | ||||
| -rw-r--r-- | compiler/typecheck/TcHoleFitTypes.hs | 144 | ||||
| -rw-r--r-- | compiler/typecheck/TcHoleFitTypes.hs-boot | 10 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.hs | 31 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.hs | 1 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 4 |
8 files changed, 323 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 |