Add HoleFitPlugins and RawHoleFits
authorMatthías Páll Gissurarson <pallm@chalmers.se>
Mon, 21 Jan 2019 00:44:15 +0000 (19:44 -0500)
committerMatthías Páll Gissurarson <pallm@chalmers.se>
Fri, 31 May 2019 17:15:26 +0000 (19:15 +0200)
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 { relevantCts :: Cts -- ^ Any relevant Cts to the
hole , implics :: [Implication] -- ^ The nested implications of the hole
with the --   innermost implication first.  , holeCt :: Maybe Ct -- ^
The hole constraint itself, if available.  } ```

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 HoleFitPlugin
hfp opts = Just (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 holeCt 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 <$> holeCt 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.

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

compiler/main/Plugins.hs
compiler/typecheck/TcHoleErrors.hs
compiler/typecheck/TcHoleErrors.hs-boot

index 9329752..4901d7a 100644 (file)
@@ -53,6 +53,8 @@ import Fingerprint
 import Data.List
 import Outputable (Outputable(..), text, (<+>))
 
+import {-# SOURCE #-} qualified TcHoleErrors (HoleFitPlugin)
+
 --Qualified import so we can define a Semigroup instance
 -- but it doesn't clash with Outputable.<>
 import qualified Data.Semigroup
@@ -79,6 +81,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 +174,7 @@ instance Monoid PluginRecompile where
 
 type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
 type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin
+type HoleFitPlugin = [CommandLineOption] -> Maybe TcHoleErrors.HoleFitPlugin
 
 purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile
 purePlugin _args = return NoForceRecompile
@@ -186,7 +192,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
index db47450..164ee89 100644 (file)
@@ -1,6 +1,9 @@
+{-# LANGUAGE RecordWildCards #-}
 module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits, HoleFit (..)
                     , HoleFitCandidate (..), tcCheckHoleFit, tcSubsumes
-                    , withoutUnification ) where
+                    , withoutUnification
+                    , HoleFitPlugin (..), TypedHole (..), CandPlugin, FitPlugin
+                    ) where
 
 import GhcPrelude
 
@@ -28,7 +31,7 @@ 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 )
@@ -45,6 +48,8 @@ import LoadIface       ( loadInterfaceForNameMaybe )
 
 import PrelInfo (knownKeyNames)
 
+import Plugins (holeFitPlugin, plugins, paPlugin, paArguments)
+
 
 {-
 Note [Valid hole fits include ...]
@@ -455,19 +460,24 @@ data HoleFit =
                                    -- with, if anything
           , hfDoc :: Maybe HsDocString } -- Documentation of this HoleFit, if
                                          -- available.
+ | RawHoleFit SDoc
+ -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins
+ --   can inject any fit they want.
 
-
-hfName :: HoleFit -> Name
-hfName hf = case hfCand hf of
-              IdHFCand id -> idName id
-              NameHFCand name -> name
-              GreHFCand gre -> gre_name gre
+hfName :: HoleFit -> Maybe Name
+hfName hf@(HoleFit {}) = Just $ case hfCand hf of
+                                  IdHFCand id -> idName id
+                                  NameHFCand name -> name
+                                  GreHFCand gre -> gre_name gre
+hfName _ = Nothing
 
 hfIsLcl :: HoleFit -> Bool
-hfIsLcl hf = case hfCand hf of
-               IdHFCand _    -> True
-               NameHFCand _  -> False
-               GreHFCand gre -> gre_lcl gre
+hfIsLcl hf@(HoleFit {}) = case hfCand hf of
+                            IdHFCand _    -> True
+                            NameHFCand _  -> False
+                            GreHFCand gre -> gre_lcl gre
+hfIsLcl _ = False
+
 
 -- We define an Eq and Ord instance to be able to build a graph.
 instance Eq HoleFit where
@@ -478,7 +488,10 @@ instance Eq HoleFit where
 -- 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
+  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` hfName
                  else compare `on` hfRefLvl
@@ -500,60 +513,61 @@ addDocs fits =
    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 }
+    case hfName fit of
+     Just name ->
+        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} }
+     Nothing -> 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 $ map ((text "@" <>) . pprParendType) wrap
-          tyAppVars = sep $ punctuate comma $
-              map (\(v,t) -> ppr v <+> text "~" <+> pprParendType t) $
-                zip vars wrap
-            where
-              vars = unwrapTypeVars ty
-              -- 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 -> [TyVar]
-              unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of
-                                  Just (_, unfunned) -> unwrapTypeVars unfunned
-                                  _ -> []
-                where (vars, unforalled) = splitForAllTys 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)
+pprHoleFit _ (RawHoleFit sd) = sd
+pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) hf@(HoleFit {..}) =
+ hang display 2 provenance
+ where name = fromJust (hfName hf)
+       tyApp = sep $ map ((text "@" <>) . pprParendType) hfWrap
+       tyAppVars = sep $ punctuate comma $
+           map (\(v,t) -> ppr v <+> text "~" <+> pprParendType t) $
+             zip vars hfWrap
+         where
+           vars = unwrapTypeVars hfType
+           -- 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 -> [TyVar]
+           unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of
+                               Just (_, unfunned) -> unwrapTypeVars unfunned
+                               _ -> []
+             where (vars, unforalled) = splitForAllTys 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
@@ -589,12 +603,15 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
      ; maxVSubs <- maxValidHoleFits <$> getDynFlags
      ; hfdc <- getHoleFitDispConfig
      ; sortingAlg <- getSortingAlg
+     ; dflags <- getDynFlags
      ; 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) =
+              mapAndUnzip (\p -> ((candPlugin p) hole, (fitPlugin p) hole)) $
+                getHoleFitPlugins dflags
+     ; 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)
            -- We remove binding shadowings here, but only for the local level.
@@ -606,11 +623,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) $
@@ -629,8 +649,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
@@ -640,8 +660,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,
@@ -723,6 +745,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
@@ -777,10 +802,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
@@ -790,8 +812,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
@@ -892,7 +914,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
@@ -925,6 +947,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 relevantCts implics Nothing
 
 
 subsDiscardMsg :: SDoc
@@ -940,6 +963,10 @@ refSubsDiscardMsg =
     text "or -fno-max-refinement-hole-fits)"
 
 
+getHoleFitPlugins :: DynFlags -> [HoleFitPlugin]
+getHoleFitPlugins dflags = catMaybes $ map get_plugin (plugins dflags)
+  where get_plugin p = holeFitPlugin (paPlugin p) (paArguments p)
+
 -- | Checks whether a MetaTyVar is flexible or not.
 isFlexiTyVar :: TcTyVar -> TcM Bool
 isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv
@@ -961,7 +988,29 @@ 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
+
+
+type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit]
+type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]
+data HoleFitPlugin = HoleFitPlugin { candPlugin :: CandPlugin
+                                   , fitPlugin :: FitPlugin }
+
+
+data TypedHole = TyH { relevantCts :: Cts
+                       -- ^ Any relevant Cts to the hole
+                     , implics :: [Implication]
+                       -- ^ The nested implications of the hole with the
+                       --   innermost implication first.
+                     , holeCt :: Maybe Ct
+                       -- ^ The hole constraint itself, if available.
+                     }
+
+instance Outputable TypedHole where
+  ppr (TyH rels implics ct)
+    = hang (text "TypedHole") 2
+        (ppr rels $+$ ppr implics $+$ ppr ct)
 
 
 -- | A tcSubsumes which takes into account relevant constraints, to fix trac
@@ -970,17 +1019,15 @@ 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
index 16e0c95..d727d6b 100644 (file)
@@ -10,3 +10,5 @@ import VarEnv     ( TidyEnv )
 
 findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct
                   -> TcM (TidyEnv, SDoc)
+
+data HoleFitPlugin