[Git][ghc/ghc][master] Add HoleFitPlugins and RawHoleFits
Marge Bot
gitlab at gitlab.haskell.org
Fri Jun 21 17:32:08 UTC 2019
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c311277b by Matthías Páll Gissurarson at 2019-06-21T01:21:21Z
Add HoleFitPlugins and RawHoleFits
This patch adds a new kind of plugin, Hole fit plugins. These plugins
can change what candidates are considered when looking for valid hole
fits, and add hole fits of their own. The type of a plugin is relatively
simple,
```
type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit]
type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]
data HoleFitPlugin = HoleFitPlugin { candPlugin :: CandPlugin
, fitPlugin :: FitPlugin }
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.
}
This allows users and plugin writers to interact with the candidates and
fits as they wish, even going as far as to allow them to reimplement the
current functionality (since `TypedHole` contains all the relevant
information).
As an example, consider the following plugin:
```
module HolePlugin where
import GhcPlugins
import TcHoleErrors
import Data.List (intersect, stripPrefix)
import RdrName (importSpecModule)
import TcRnTypes
import System.Process
plugin :: Plugin
plugin = defaultPlugin { holeFitPlugin = hfp, pluginRecompile = purePlugin }
hfp :: [CommandLineOption] -> Maybe HoleFitPluginR
hfp opts = Just (fromPureHFPlugin $ HoleFitPlugin (candP opts) (fp opts))
toFilter :: Maybe String -> Maybe String
toFilter = flip (>>=) (stripPrefix "_module_")
replace :: Eq a => a -> a -> [a] -> [a]
replace match repl str = replace' [] str
where
replace' sofar (x:xs) | x == match = replace' (repl:sofar) xs
replace' sofar (x:xs) = replace' (x:sofar) xs
replace' sofar [] = reverse sofar
-- | This candidate plugin filters the candidates by module,
-- using the name of the hole as module to search in
candP :: [CommandLineOption] -> CandPlugin
candP _ hole cands =
do let he = case tyHCt hole of
Just (CHoleCan _ h) -> Just (occNameString $ holeOcc h)
_ -> Nothing
case toFilter he of
Just undscModName -> do let replaced = replace '_' '.' undscModName
let res = filter (greNotInOpts [replaced]) cands
return $ res
_ -> return cands
where greNotInOpts opts (GreHFCand gre) = not $ null $ intersect (inScopeVia gre) opts
greNotInOpts _ _ = True
inScopeVia = map (moduleNameString . importSpecModule) . gre_imp
-- Yes, it's pretty hacky, but it is just an example :)
searchHoogle :: String -> IO [String]
searchHoogle ty = lines <$> (readProcess "hoogle" [(show ty)] [])
fp :: [CommandLineOption] -> FitPlugin
fp ("hoogle":[]) hole hfs =
do dflags <- getDynFlags
let tyString = showSDoc dflags . ppr . ctPred <$> tyHCt hole
res <- case tyString of
Just ty -> liftIO $ searchHoogle ty
_ -> return []
return $ (take 2 $ map (RawHoleFit . text . ("Hoogle says: " ++)) res) ++ hfs
fp _ _ hfs = return hfs
```
with this plugin available, you can compile the following file
```
{-# OPTIONS -fplugin=HolePlugin -fplugin-opt=HolePlugin:hoogle #-}
module Main where
import Prelude hiding (head, last)
import Data.List (head, last)
t :: [Int] -> Int
t = _module_Prelude
g :: [Int] -> Int
g = _module_Data_List
main :: IO ()
main = print $ t [1,2,3]
```
and get the following output:
```
Main.hs:14:5: error:
• Found hole: _module_Prelude :: [Int] -> Int
Or perhaps ‘_module_Prelude’ is mis-spelled, or not in scope
• In the expression: _module_Prelude
In an equation for ‘t’: t = _module_Prelude
• Relevant bindings include
t :: [Int] -> Int (bound at Main.hs:14:1)
Valid hole fits include
Hoogle says: GHC.List length :: [a] -> Int
Hoogle says: GHC.OldList length :: [a] -> Int
t :: [Int] -> Int (bound at Main.hs:14:1)
g :: [Int] -> Int (bound at Main.hs:17:1)
length :: forall (t :: * -> *) a. Foldable t => t a -> Int
with length @[] @Int
(imported from ‘Prelude’ at Main.hs:5:1-34
(and originally defined in ‘Data.Foldable’))
maximum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
with maximum @[] @Int
(imported from ‘Prelude’ at Main.hs:5:1-34
(and originally defined in ‘Data.Foldable’))
(Some hole fits suppressed; use -fmax-valid-hole-fits=N or -fno-max-valid-hole-fits)
|
14 | t = _module_Prelude
| ^^^^^^^^^^^^^^^
Main.hs:17:5: error:
• Found hole: _module_Data_List :: [Int] -> Int
Or perhaps ‘_module_Data_List’ is mis-spelled, or not in scope
• In the expression: _module_Data_List
In an equation for ‘g’: g = _module_Data_List
• Relevant bindings include
g :: [Int] -> Int (bound at Main.hs:17:1)
Valid hole fits include
Hoogle says: GHC.List length :: [a] -> Int
Hoogle says: GHC.OldList length :: [a] -> Int
g :: [Int] -> Int (bound at Main.hs:17:1)
head :: forall a. [a] -> a
with head @Int
(imported from ‘Data.List’ at Main.hs:7:19-22
(and originally defined in ‘GHC.List’))
last :: forall a. [a] -> a
with last @Int
(imported from ‘Data.List’ at Main.hs:7:25-28
(and originally defined in ‘GHC.List’))
|
17 | g = _module_Data_List
```
This relatively simple plugin has two functions, as an example of what
is possible to do with hole fit plugins. The candidate plugin starts by
filtering the candidates considered by module, indicated by the name of
the hole (`_module_Data_List`). The second function is in the fit
plugin, where the plugin invokes a local hoogle instance to search by
the type of the hole.
By adding the `RawHoleFit` type, we can also allow these completely free
suggestions, used in the plugin above to display fits found by Hoogle.
Additionally, the `HoleFitPluginR` wrapper can be used for plugins to
maintain state between invocations, which can be used to speed up
invocation of plugins that have expensive initialization.
```
-- | 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
}
```
Of course, the syntax here is up for debate, but hole fit plugins allow
us to experiment relatively easily with ways to interact with
typed-holes without having to dig deep into GHC.
Reviewers: bgamari
Subscribers: rwbarton, carter
Differential Revision: https://phabricator.haskell.org/D5373
- - - - -
17 changed files:
- compiler/ghc.cabal.in
- compiler/main/Plugins.hs
- compiler/typecheck/TcHoleErrors.hs
- + compiler/typecheck/TcHoleFitTypes.hs
- + compiler/typecheck/TcHoleFitTypes.hs-boot
- compiler/typecheck/TcRnDriver.hs
- compiler/typecheck/TcRnMonad.hs
- compiler/typecheck/TcRnTypes.hs
- docs/users_guide/extending_ghc.rst
- testsuite/tests/plugins/Makefile
- testsuite/tests/plugins/all.T
- + testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.cabal
- + testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs
- + testsuite/tests/plugins/hole-fit-plugin/Makefile
- + testsuite/tests/plugins/hole-fit-plugin/Setup.hs
- + testsuite/tests/plugins/test-hole-plugin.hs
- + testsuite/tests/plugins/test-hole-plugin.stderr
Changes:
=====================================
compiler/ghc.cabal.in
=====================================
@@ -521,6 +521,7 @@ Library
TcRules
TcSimplify
TcHoleErrors
+ TcHoleFitTypes
TcErrors
TcTyClsDecls
TcTyDecls
=====================================
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
=====================================
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 at RawHoleFit{} = return (env, hf)
zonkSub env hf at 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 () }
=====================================
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
+ }
=====================================
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
=====================================
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)
=====================================
compiler/typecheck/TcRnMonad.hs
=====================================
@@ -312,6 +312,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
tcg_safeInfer = infer_var,
tcg_dependent_files = dependent_files_var,
tcg_tc_plugins = [],
+ tcg_hf_plugins = [],
tcg_top_loc = loc,
tcg_static_wc = static_wc_var,
tcg_complete_matches = [],
=====================================
compiler/typecheck/TcRnTypes.hs
=====================================
@@ -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
=====================================
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:
=====================================
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
=====================================
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'])
=====================================
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
=====================================
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 }
=====================================
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
=====================================
testsuite/tests/plugins/hole-fit-plugin/Setup.hs
=====================================
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
=====================================
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 ()
=====================================
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 it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/c311277bf640a4aeb929f3080eaaf656c0e0611c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/c311277bf640a4aeb929f3080eaaf656c0e0611c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190621/c8329a97/attachment-0001.html>
More information about the ghc-commits
mailing list