Add defaulting plugins.

Like the built-in type defaulting rules these plugins can propose candidates
to resolve ambiguous type variables.

Machine learning and other large APIs like those for game engines introduce
new numeric types and other complex typed APIs. The built-in defaulting
mechanism isn't powerful enough to resolve ambiguous types in these cases forcing
users to specify minutia that they might not even know how to do. There is
an example defaulting plugin linked in the documentation. Applications include
defaulting the device a computation executes on, if a gradient should be
computed for a tensor, or the size of a tensor.

See https://github.com/ghc-proposals/ghc-proposals/pull/396 for details.

24 files changed, 453 insertions, 37 deletions

diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs
index 42cefd17fd..83d41a6695 100644
--- a/compiler/GHC/Driver/Plugins.hs
+++ b/compiler/GHC/Driver/Plugins.hs
@@ -35,6 +35,10 @@ module GHC.Driver.Plugins (
       -- - access to loaded interface files with 'interfaceLoadAction'
       --
     , keepRenamedSource
+      -- ** Defaulting plugins
+      -- | Defaulting plugins can add candidate types to the defaulting
+      -- mechanism.
+    , DefaultingPlugin
       -- ** Hole fit plugins
       -- | hole fit plugins allow plugins to change the behavior of valid hole
       -- fit suggestions
@@ -94,6 +98,9 @@ data Plugin = Plugin {
   , tcPlugin :: TcPlugin
     -- ^ An optional typechecker plugin, which may modify the
     -- behaviour of the constraint solver.
+  , defaultingPlugin :: DefaultingPlugin
+    -- ^ An optional defaulting plugin, which may specify the
+    -- additional type-defaulting rules.
   , 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.
@@ -195,6 +202,7 @@ instance Monoid PluginRecompile where
 
 type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
 type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin
+type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin
 type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR
 
 purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile
@@ -213,6 +221,7 @@ defaultPlugin :: Plugin
 defaultPlugin = Plugin {
         installCoreToDos      = const return
       , tcPlugin              = const Nothing
+      , defaultingPlugin      = const Nothing
       , holeFitPlugin         = const Nothing
       , driverPlugin          = const return
       , pluginRecompile       = impurePlugin
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index e420bd1c23..f474c3383d 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -3151,19 +3151,26 @@ discardMsg = text "(Some bindings suppressed;" <+>
              text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"
 
 -----------------------
-warnDefaulting :: [Ct] -> Type -> TcM ()
-warnDefaulting wanteds default_ty
+warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM ()
+warnDefaulting the_tv wanteds default_ty
   = do { warn_default <- woptM Opt_WarnTypeDefaults
        ; env0 <- tcInitTidyEnv
        ; let tidy_env = tidyFreeTyCoVars env0 $
                         tyCoVarsOfCtsList (listToBag wanteds)
              tidy_wanteds = map (tidyCt tidy_env) wanteds
+             tidy_tv = lookupVarEnv (snd tidy_env) the_tv
              (loc, ppr_wanteds) = pprWithArising tidy_wanteds
              warn_msg =
-                hang (hsep [ text "Defaulting the following"
-                           , text "constraint" <> plural tidy_wanteds
-                           , text "to type"
-                           , quotes (ppr default_ty) ])
+                hang (hsep $ [ text "Defaulting" ]
+                             ++
+                             (case tidy_tv of
+                                 Nothing -> []
+                                 Just tv -> [text "the type variable"
+                                            , quotes (ppr tv)])
+                             ++
+                             [ text "to type"
+                             , quotes (ppr default_ty)
+                             , text "in the following constraint" <> plural tidy_wanteds ])
                      2
                      ppr_wanteds
        ; let diag = TcRnUnknownMessage $
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 578adf730a..0cf68fcb35 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -204,7 +204,9 @@ 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 $ withHoleFitPlugins hsc_env $
+          withTcPlugins hsc_env $
+          withDefaultingPlugins hsc_env $
+          withHoleFitPlugins hsc_env $
 
           tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
 
@@ -2033,7 +2035,8 @@ runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, 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 $ withHoleFitPlugins hsc_env $
+  = initTcInteractive hsc_env $ withTcPlugins hsc_env $
+    withDefaultingPlugins 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)
@@ -3086,12 +3089,12 @@ Type Checker Plugins
 
 withTcPlugins :: HscEnv -> TcM a -> TcM a
 withTcPlugins hsc_env m =
-    case getTcPlugins hsc_env of
+    case catMaybes $ mapPlugins hsc_env tcPlugin of
        []      -> m  -- Common fast case
        plugins -> do
                 ev_binds_var <- newTcEvBinds
                 (solvers, rewriters, stops) <-
-                  unzip3 `fmap` mapM (startPlugin ev_binds_var) plugins
+                  unzip3 `fmap` mapM (start_plugin ev_binds_var) plugins
                 let
                   rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter]
                   !rewritersUniqFM = sequenceUFMList rewriters
@@ -3105,19 +3108,33 @@ withTcPlugins hsc_env m =
                   Left _ -> failM
                   Right res -> return res
   where
-  startPlugin ev_binds_var (TcPlugin start solve rewrite stop) =
+  start_plugin ev_binds_var (TcPlugin start solve rewrite stop) =
     do s <- runTcPluginM start
        return (solve s ev_binds_var, rewrite s, stop s)
 
-getTcPlugins :: HscEnv -> [GHC.Tc.Utils.Monad.TcPlugin]
-getTcPlugins hsc_env = catMaybes $ mapPlugins hsc_env (\p args -> tcPlugin p args)
-
+withDefaultingPlugins :: HscEnv -> TcM a -> TcM a
+withDefaultingPlugins hsc_env m =
+  do case catMaybes $ mapPlugins hsc_env defaultingPlugin of
+       [] -> m  -- Common fast case
+       plugins  -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins
+                      -- This ensures that dePluginStop is called even if a type
+                      -- error occurs during compilation
+                      eitherRes <- tryM $ do
+                        updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) m
+                      mapM_ runTcPluginM stops
+                      case eitherRes of
+                        Left _ -> failM
+                        Right res -> return res
+  where
+  start_plugin (DefaultingPlugin start fill stop) =
+    do s <- runTcPluginM start
+       return (fill s, stop s)
 
 withHoleFitPlugins :: HscEnv -> TcM a -> TcM a
 withHoleFitPlugins hsc_env m =
-  case getHfPlugins hsc_env of
+  case catMaybes $ mapPlugins hsc_env holeFitPlugin of
     [] -> m  -- Common fast case
-    plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins
+    plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins
                   -- This ensures that hfPluginStop is called even if a type
                   -- error occurs during compilation.
                   eitherRes <- tryM $
@@ -3127,14 +3144,10 @@ withHoleFitPlugins hsc_env m =
                     Left _ -> failM
                     Right res -> return res
   where
-    startPlugin (HoleFitPluginR init plugin stop) =
+    start_plugin (HoleFitPluginR init plugin stop) =
       do ref <- init
          return (plugin ref, stop ref)
 
-getHfPlugins :: HscEnv -> [HoleFitPluginR]
-getHfPlugins hsc_env =
-  catMaybes $ mapPlugins hsc_env (\p args -> holeFitPlugin p args)
-
 
 runRenamerPlugin :: TcGblEnv
                  -> HsGroup GhcRn
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index 276c0b284b..74a53ff348 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -2592,6 +2592,17 @@ applyDefaultingRules wanteds
   = do { info@(default_tys, _) <- getDefaultInfo
        ; wanteds               <- TcS.zonkWC wanteds
 
+       ; tcg_env <- TcS.getGblEnv
+       ; let plugins = tcg_defaulting_plugins tcg_env
+
+       ; plugin_defaulted <- if null plugins then return [] else
+           do {
+             ; traceTcS "defaultingPlugins {" (ppr wanteds)
+             ; defaultedGroups <- mapM (run_defaulting_plugin wanteds) plugins
+             ; traceTcS "defaultingPlugins }" (ppr defaultedGroups)
+             ; return defaultedGroups
+             }
+
        ; let groups = findDefaultableGroups info wanteds
 
        ; traceTcS "applyDefaultingRules {" $
@@ -2603,7 +2614,20 @@ applyDefaultingRules wanteds
 
        ; traceTcS "applyDefaultingRules }" (ppr something_happeneds)
 
-       ; return (or something_happeneds) }
+       ; return $ or something_happeneds || or plugin_defaulted }
+    where run_defaulting_plugin wanteds p =
+            do { groups <- runTcPluginTcS (p wanteds)
+               ; defaultedGroups <-
+                    filterM (\g -> disambigGroup
+                                   (deProposalCandidates g)
+                                   (deProposalTyVar g, deProposalCts g))
+                    groups
+               ; traceTcS "defaultingPlugin " $ ppr defaultedGroups
+               ; case defaultedGroups of
+                 [] -> return False
+                 _  -> return True
+               }
+
 
 findDefaultableGroups
     :: ( [Type]
@@ -2665,8 +2689,7 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
 
 ------------------------------
 disambigGroup :: [Type]            -- The default types
-              -> (TcTyVar, [Ct])   -- All classes of the form (C a)
-                                   --  sharing same type variable
+              -> (TcTyVar, [Ct])   -- All constraints sharing same type variable
               -> TcS Bool   -- True <=> something happened, reflected in ty_binds
 
 disambigGroup [] _
@@ -2680,7 +2703,7 @@ disambigGroup (default_ty:default_tys) group@(the_tv, wanteds)
        ; if success then
              -- Success: record the type variable binding, and return
              do { unifyTyVar the_tv default_ty
-                ; wrapWarnTcS $ warnDefaulting wanteds default_ty
+                ; wrapWarnTcS $ warnDefaulting the_tv wanteds default_ty
                 ; traceTcS "disambigGroup succeeded }" (ppr default_ty)
                 ; return True }
          else
@@ -2694,7 +2717,8 @@ disambigGroup (default_ty:default_tys) group@(the_tv, wanteds)
       = do { lcl_env <- TcS.getLclEnv
            ; tc_lvl <- TcS.getTcLevel
            ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env
-           ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred)
+           -- Equality constraints are possible due to type defaulting plugins
+           ; wanted_evs <- mapM (newWantedNC loc . substTy subst . ctPred)
                                 wanteds
            ; fmap isEmptyWC $
              solveSimpleWanteds $ listToBag $
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 39ff861153..d3c4b44211 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -82,6 +82,10 @@ module GHC.Tc.Types(
         TcPluginSolver, TcPluginRewriter,
         TcPluginM(runTcPluginM), unsafeTcPluginTcM,
 
+        -- Defaulting plugin
+        DefaultingPlugin(..), DefaultingProposal(..),
+        FillDefaulting, DefaultingPluginResult,
+
         -- Role annotations
         RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv,
         lookupRoleAnnot, getRoleAnnots,
@@ -621,6 +625,9 @@ data TcGblEnv
         -- ^ A collection of all the user-defined type-checking plugins for rewriting
         -- type family applications, collated by their type family 'TyCon's.
 
+        tcg_defaulting_plugins :: [FillDefaulting],
+        -- ^ A list of user-defined plugins for type defaulting plugins.
+
         tcg_hf_plugins :: [HoleFitPlugin],
         -- ^ A list of user-defined plugins for hole fit suggestions.
 
@@ -1767,6 +1774,36 @@ data TcPluginRewriteResult
     , tcRewriterNewWanteds :: [Ct]
     }
 
+-- | A collection of candidate default types for a type variable.
+data DefaultingProposal
+  = DefaultingProposal
+    { deProposalTyVar :: TcTyVar
+      -- ^ The type variable to default.
+    , deProposalCandidates :: [Type]
+      -- ^ Candidate types to default the type variable to.
+    , deProposalCts :: [Ct]
+      -- ^ The constraints against which defaults are checked.
+    }
+
+instance Outputable DefaultingProposal where
+  ppr p = text "DefaultingProposal"
+          <+> ppr (deProposalTyVar p)
+          <+> ppr (deProposalCandidates p)
+          <+> ppr (deProposalCts p)
+
+type DefaultingPluginResult = [DefaultingProposal]
+type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult
+
+-- | A plugin for controlling defaulting.
+data DefaultingPlugin = forall s. DefaultingPlugin
+  { dePluginInit :: TcPluginM s
+    -- ^ Initialize plugin, when entering type-checker.
+  , dePluginRun :: s -> FillDefaulting
+    -- ^ Default some types
+  , dePluginStop :: s -> TcPluginM ()
+   -- ^ Clean up after the plugin, when exiting the type-checker.
+  }
+
 {- *********************************************************************
 *                                                                      *
                         Role annotations
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 1c5e79013d..6b876d3121 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -351,6 +351,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_dependent_files = dependent_files_var,
                 tcg_tc_plugin_solvers   = [],
                 tcg_tc_plugin_rewriters = emptyUFM,
+                tcg_defaulting_plugins  = [],
                 tcg_hf_plugins     = [],
                 tcg_top_loc        = loc,
                 tcg_static_wc      = static_wc_var,
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index aae0c065d7..ce70b8e98d 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -9,6 +9,11 @@ Compiler
 - New :ghc-flag:`-Wredundant-strictness-flags` that checks for strictness flags
   (``!``) applied to unlifted types, which are always strict.
 
+- A new type of plugin: defaulting plugins. These plugins can propose
+  defaults for ambiguous variables that would otherwise cause errors
+  just like the built-in defaulting mechanism.
+
+
 ``base`` library
 ~~~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst
index 309fa6c912..ef9b584f04 100644
--- a/docs/users_guide/extending_ghc.rst
+++ b/docs/users_guide/extending_ghc.rst
@@ -1275,6 +1275,64 @@ The output is as follows:
       |     ^^^^^^^^^^^^^
 
 
+.. _defaulting-plugins:
+
+Defaulting plugins
+~~~~~~~~~~~~~~~~~~
+
+Defaulting plugins are called when ambiguous variables might otherwise cause
+errors, in the same way as the built-in defaulting mechanism.
+
+A defaulting plugin can propose potential ways to fill an ambiguous variable
+according to whatever criteria you would like. GHC will verify that those
+proposals will not lead to type errors in a context that you declare.
+
+Defaulting plugins have a single access point in the `GHC.Tc.Types` module
+
+::
+
+    -- | A collection of candidate default types for a type variable.
+    data DefaultingProposal
+      = DefaultingProposal
+        { deProposalTyVar :: TcTyVar
+          -- ^ The type variable to default.
+        , deProposalCandidates :: [Type]
+          -- ^ Candidate types to default the type variable to.
+        , deProposalCts :: [Ct]
+          -- ^ The constraints against which defaults are checked.
+        }
+    
+    type DefaultingPluginResult = [DefaultingProposal]
+    type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult
+    
+    -- | A plugin for controlling defaulting.
+    data DefaultingPlugin = forall s. DefaultingPlugin
+      { dePluginInit :: TcPluginM s
+        -- ^ Initialize plugin, when entering type-checker.
+      , dePluginRun :: s -> FillDefaulting
+        -- ^ Default some types
+      , dePluginStop :: s -> TcPluginM ()
+       -- ^ Clean up after the plugin, when exiting the type-checker.
+      }
+
+
+The plugin gets a combination of wanted constraints which can be most easily
+broken down into simple wanted constraints with ``approximateWC``. The result of
+running the plugin should be a ``DefaultingPluginResult``, a list of types that
+should be attempted for a given type variable that is ambiguous in a given
+context. GHC will check if one of the proposals is acceptable in the given
+context and then default to it. The most robust context to provide is the list
+of all wanted constraints that mention the variable you are defaulting. If you
+leave out a constraint, the default will be accepted, and then potentially
+result in a type checker error if it is incompatible with one of the constraints
+you left out. This can be a useful way of forcing a default and reporting errors
+to the user.
+
+There is an example of defaulting lifted types in the GHC test suite. In the
+`testsuite/tests/plugins/` directory see `defaulting-plugin/` for the
+implementation, `test-defaulting-plugin.hs` for an example of when defaulting
+happens, and `test-defaulting-plugin-fail.hs` for an example of when defaults
+don't fit and aren't applied.
 
 .. _plugin_recompilation:
 
diff --git a/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr b/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr
index 2487a3da5b..b8fcd66a02 100644
--- a/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr
+++ b/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr
@@ -4,7 +4,7 @@ B.hs:4:1: warning: [-Wmissing-signatures (in -Wall)]
       answer_to_live_the_universe_and_everything :: Int
 
 B.hs:5:13: warning: [-Wtype-defaults (in -Wall)]
-    • Defaulting the following constraints to type ‘Integer’
+    • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraints
         (Num a0) arising from the literal ‘1’ at B.hs:5:13
         (Enum a0)
           arising from the arithmetic sequence ‘1 .. 23 * 2’ at B.hs:5:12-20
@@ -20,7 +20,7 @@ B.hs:4:1: warning: [-Wmissing-signatures (in -Wall)]
       answer_to_live_the_universe_and_everything :: Int
 
 B.hs:5:13: warning: [-Wtype-defaults (in -Wall)]
-    • Defaulting the following constraints to type ‘Integer’
+    • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraints
         (Num a0) arising from the literal ‘1’ at B.hs:5:13
         (Enum a0)
           arising from the arithmetic sequence ‘1 .. 23 * 2’ at B.hs:5:12-20
diff --git a/testsuite/tests/parser/should_compile/T2245.stderr b/testsuite/tests/parser/should_compile/T2245.stderr
index ca38eec5ac..d5b8280494 100644
--- a/testsuite/tests/parser/should_compile/T2245.stderr
+++ b/testsuite/tests/parser/should_compile/T2245.stderr
@@ -12,7 +12,7 @@ T2245.hs:5:10: warning: [-Wmissing-methods (in -Wdefault)]
     • In the instance declaration for ‘Fractional T’
 
 T2245.hs:7:27: warning: [-Wtype-defaults (in -Wall)]
-    • Defaulting the following constraints to type ‘T’
+    • Defaulting the type variable ‘b0’ to type ‘T’ in the following constraints
         (Ord b0) arising from a use of ‘<’ at T2245.hs:7:27
         (Fractional b0)
           arising from the literal ‘1e400’ at T2245.hs:7:29-33
diff --git a/testsuite/tests/parser/should_compile/T515.stderr b/testsuite/tests/parser/should_compile/T515.stderr
index 580b8e722a..99ba2b24a5 100644
--- a/testsuite/tests/parser/should_compile/T515.stderr
+++ b/testsuite/tests/parser/should_compile/T515.stderr
@@ -3,7 +3,7 @@ T515.lhs:6:3: warning: [-Wmissing-signatures (in -Wall)]
     Top-level binding with no type signature: a :: Integer
 
 T515.lhs:6:7: warning: [-Wtype-defaults (in -Wall)]
-    • Defaulting the following constraint to type ‘Integer’
+    • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraint
         Num a0 arising from the literal ‘1’
     • In the expression: 1
       In an equation for ‘a’: a = 1
@@ -12,7 +12,7 @@ T515.lhs:7:3: warning: [-Wmissing-signatures (in -Wall)]
     Top-level binding with no type signature: b :: Integer
 
 T515.lhs:7:7: warning: [-Wtype-defaults (in -Wall)]
-    • Defaulting the following constraint to type ‘Integer’
+    • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraint
         Num a0 arising from the literal ‘2’
     • In the expression: 2
       In an equation for ‘b’: b = 2
diff --git a/testsuite/tests/plugins/Makefile b/testsuite/tests/plugins/Makefile
index c00b26684b..6716aecbfb 100644
--- a/testsuite/tests/plugins/Makefile
+++ b/testsuite/tests/plugins/Makefile
@@ -163,3 +163,12 @@ T20218:
 T20218b:
 	"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) T20218b.hs -package-db simple-plugin/pkg.T20218b/local.package.conf -fplugin Simple.ReplacePlugin -package simple-plugin -v0
 	./T20218b
+
+.PHONY: test-defaulting-plugin
+test-defaulting-plugin:
+	"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 test-defaulting-plugin.hs -package-db defaulting-plugin/pkg.test-defaulting-plugin/local.package.conf
+
+.PHONY: test-defaulting-plugin-fail
+test-defaulting-plugin-fail:
+	-"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 test-defaulting-plugin-fail.hs -package-db defaulting-plugin/pkg.test-defaulting-plugin-fail/local.package.conf
+
diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T
index 0fc41ec039..2146a2aa43 100644
--- a/testsuite/tests/plugins/all.T
+++ b/testsuite/tests/plugins/all.T
@@ -241,6 +241,7 @@ test('plugin-recomp-change-2',
       ],
      makefile_test, [])
 
+
 test('T20417',
      [extra_files(['plugin-recomp/', 'plugin-recomp-test.hs']),
       only_ways([config.ghc_plugin_way]),
@@ -248,6 +249,7 @@ test('T20417',
       ],
      makefile_test, [])
 
+
 test('T20218',
      [extra_files(['simple-plugin/']), only_ways([config.ghc_plugin_way]),
       pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.T20218 TOP={top}'),
@@ -261,3 +263,15 @@ test('T20218b',
       pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.T20218b TOP={top}')
       ],
      makefile_test, [])
+
+test('test-defaulting-plugin',
+     [extra_files(['defaulting-plugin/']),
+      only_ways([config.ghc_plugin_way]),
+      pre_cmd('$MAKE -s --no-print-directory -C defaulting-plugin package.test-defaulting-plugin TOP={top}')],
+     makefile_test, [])
+
+test('test-defaulting-plugin-fail',
+     [extra_files(['defaulting-plugin/']),
+      only_ways([config.ghc_plugin_way]),
+      pre_cmd('$MAKE -s --no-print-directory -C defaulting-plugin package.test-defaulting-plugin-fail TOP={top}')],
+     makefile_test, [])
diff --git a/testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs b/testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs
new file mode 100644
index 0000000000..62071b9cfb
--- /dev/null
+++ b/testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE MultiParamTypeClasses, KindSignatures, FlexibleInstances, DataKinds, PatternSynonyms, StandaloneDeriving, GeneralizedNewtypeDeriving, PolyKinds #-}
+{-# OPTIONS -Wno-orphans #-}
+module DefaultLifted(DefaultType,plugin) where
+import GHC.Plugins
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Plugin
+import GHC.Core.InstEnv
+import GHC.Tc.Solver (approximateWC)
+import GHC.Unit.Finder (findPluginModule)
+import GHC.Driver.Config.Finder (initFinderOpts)
+import Data.List
+import GHC.Tc.Types
+import qualified Data.Map as M
+import Control.Monad (liftM2)
+import GHC.Tc.Utils.TcType
+
+class DefaultType x (y :: x)
+
+instance Eq Type where
+  (==) = eqType
+instance Ord Type where
+  compare = nonDetCmpType
+instance Semigroup (TcPluginM [a]) where
+  (<>) = liftM2 (++)
+instance Monoid (TcPluginM [a]) where
+  mempty = pure mempty
+
+plugin :: Plugin
+plugin = defaultPlugin {
+  defaultingPlugin = install,
+  pluginRecompile = purePlugin
+  }
+
+install :: p -> Maybe GHC.Tc.Types.DefaultingPlugin
+install _ = Just $ DefaultingPlugin { dePluginInit = initialize
+                                    , dePluginRun  = run
+                                    , dePluginStop = stop
+                                    }
+
+pattern FoundModule :: Module -> FindResult
+pattern FoundModule a <- Found _ a
+fr_mod :: a -> a
+fr_mod = id
+
+lookupModule :: ModuleName -- ^ Name of the module
+             -> TcPluginM Module
+lookupModule mod_nm = do
+  hsc_env <- getTopEnv
+  let dflags    = hsc_dflags hsc_env
+  let fopts     = initFinderOpts dflags
+  let fc        = hsc_FC hsc_env
+  let units     = hsc_units hsc_env
+  let home_unit = hsc_home_unit hsc_env
+  -- found_module <- findPluginModule fc fopts units home_unit mod_name
+  found_module <- tcPluginIO $ findPluginModule fc fopts units home_unit mod_nm
+  case found_module of
+    FoundModule h -> return (fr_mod h)
+    _          -> do
+      found_module' <- findImportedModule mod_nm $ Just $ fsLit "this"
+      case found_module' of
+        FoundModule h -> return (fr_mod h)
+        _          -> panicDoc "Unable to resolve module looked up by plugin: "
+                               (ppr mod_nm)
+
+data PluginState = PluginState { defaultClassName :: Name }
+
+-- | Find a 'Name' in a 'Module' given an 'OccName'
+lookupName :: Module -> OccName -> TcPluginM Name
+lookupName md occ = lookupOrig md occ
+
+solveDefaultType :: PluginState -> [Ct] -> TcPluginM DefaultingPluginResult
+solveDefaultType _     []      = return []
+solveDefaultType state wanteds = do
+  envs <- getInstEnvs
+  insts <- classInstances envs <$> tcLookupClass (defaultClassName state)
+  let defaults =
+        foldl' (\m inst ->
+                 case is_tys inst of
+                   [matchty, replacety] -> M.insertWith (++) matchty [replacety] m
+                   _ -> error "Unsupported defaulting type")
+               M.empty insts
+  let groups =
+        foldl' (\m wanted ->
+                  foldl' (\m' var -> M.insertWith (++) var [wanted] m')
+                         m
+                         (filter (isVariableDefaultable defaults) $ tyCoVarsOfCtList wanted))
+               M.empty wanteds
+  M.foldMapWithKey (\var cts ->
+                    case M.lookup (tyVarKind var) defaults of
+                      Nothing -> error "Bug, we already checked that this variable has a default"
+                      Just deftys -> do
+                        pure [DefaultingProposal var deftys cts])
+    groups
+  where isVariableDefaultable defaults v = isAmbiguousTyVar v && M.member (tyVarKind v) defaults
+
+lookupDefaultTypes :: TcPluginM PluginState
+lookupDefaultTypes = do
+    md   <- lookupModule (mkModuleName "DefaultLifted")
+    name <- lookupName md (mkTcOcc "DefaultType")
+    pure $ PluginState { defaultClassName = name }
+
+initialize :: TcPluginM PluginState
+initialize = do
+  lookupDefaultTypes
+
+run :: PluginState -> WantedConstraints -> TcPluginM DefaultingPluginResult
+run s ws = do
+  solveDefaultType s (ctsElts $ approximateWC False ws)
+
+stop :: Monad m => p -> m ()
+stop _ = do
+  return ()
diff --git a/testsuite/tests/plugins/defaulting-plugin/Makefile b/testsuite/tests/plugins/defaulting-plugin/Makefile
new file mode 100644
index 0000000000..7ce5b78e75
--- /dev/null
+++ b/testsuite/tests/plugins/defaulting-plugin/Makefile
@@ -0,0 +1,18 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean.%:
+	rm -rf pkg.$*
+
+HERE := $(abspath .)
+$(eval $(call canonicalise,HERE))
+
+package.%:
+	$(MAKE) -s --no-print-directory clean.$*
+	mkdir pkg.$*
+	"$(TEST_HC)" -outputdir pkg.$* --make -v0 -o pkg.$*/setup Setup.hs
+	"$(GHC_PKG)" init pkg.$*/local.package.conf
+	pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" $(if $(findstring YES,$(HAVE_PROFILING)), --enable-library-profiling) --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf
+	pkg.$*/setup build     --distdir pkg.$*/dist -v0
+	pkg.$*/setup install   --distdir pkg.$*/dist -v0
diff --git a/testsuite/tests/plugins/defaulting-plugin/Setup.hs b/testsuite/tests/plugins/defaulting-plugin/Setup.hs
new file mode 100644
index 0000000000..e8ef27dbba
--- /dev/null
+++ b/testsuite/tests/plugins/defaulting-plugin/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
diff --git a/testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal b/testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal
new file mode 100644
index 0000000000..a8f69ab7a0
--- /dev/null
+++ b/testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal
@@ -0,0 +1,10 @@
+name: defaulting-plugin
+cabal-version: >=1.24
+build-type: Simple
+version: 0.1.0.0
+
+library
+  default-language: Haskell2010
+  build-depends: base, ghc, containers
+  exposed-modules: DefaultLifted
+  ghc-options: -Wall
diff --git a/testsuite/tests/plugins/test-defaulting-plugin-fail.hs b/testsuite/tests/plugins/test-defaulting-plugin-fail.hs
new file mode 100644
index 0000000000..c751f3f5c1
--- /dev/null
+++ b/testsuite/tests/plugins/test-defaulting-plugin-fail.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE MultiParamTypeClasses, KindSignatures, FlexibleInstances, DataKinds, PolyKinds, RankNTypes, AllowAmbiguousTypes, TypeOperators, TypeFamilies, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fplugin DefaultLifted -fwarn-type-defaults #-}
+
+-- Tests defaulting plugins
+module Main where
+import GHC.TypeLits
+import Data.Proxy
+import DefaultLifted
+
+instance DefaultType Nat 4
+instance DefaultType Nat 2
+instance DefaultType Nat 0
+
+q :: forall (a :: Nat). (KnownNat a) => Integer
+q = natVal (Proxy :: Proxy a)
+
+w :: forall (a :: Nat). (KnownNat a, 2 <= a) => Integer
+w = natVal (Proxy :: Proxy a)
+
+e :: forall (a :: Nat). (KnownNat a, 5 <= a) => Integer
+e = natVal (Proxy :: Proxy a)
+
+main :: IO ()
+main = do
+  print $ q + w + e
diff --git a/testsuite/tests/plugins/test-defaulting-plugin-fail.stderr b/testsuite/tests/plugins/test-defaulting-plugin-fail.stderr
new file mode 100644
index 0000000000..c9843437b4
--- /dev/null
+++ b/testsuite/tests/plugins/test-defaulting-plugin-fail.stderr
@@ -0,0 +1,5 @@
+test-defaulting-plugin-fail.hs:25:19:
+     Cannot satisfy: 5 <= a0
+     In the second argument of ‘(+)’, namely ‘e’
+      In the second argument of ‘($)’, namely ‘q + w + e’
+      In a stmt of a 'do' block: print $ q + w + e
diff --git a/testsuite/tests/plugins/test-defaulting-plugin.hs b/testsuite/tests/plugins/test-defaulting-plugin.hs
new file mode 100644
index 0000000000..fce4e96a8a
--- /dev/null
+++ b/testsuite/tests/plugins/test-defaulting-plugin.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE MultiParamTypeClasses, KindSignatures, FlexibleInstances, DataKinds, PolyKinds, RankNTypes, AllowAmbiguousTypes, TypeOperators, TypeFamilies, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fplugin DefaultLifted -fwarn-type-defaults #-}
+
+-- Tests defaulting plugins
+module Main where
+import GHC.TypeLits
+import Data.Proxy
+import DefaultLifted
+
+instance DefaultType Nat 4
+instance DefaultType Nat 2
+instance DefaultType Nat 0
+
+class MyClass (a :: Nat) (b :: Nat) where
+  mc :: (KnownNat a, KnownNat b) => Proxy a -> Proxy b -> Integer
+
+instance MyClass a b where
+  mc a b = natVal a + natVal b
+
+q :: forall (a :: Nat). (KnownNat a) => Integer
+q = natVal (Proxy :: Proxy a)
+
+w :: forall (a :: Nat). (KnownNat a, 2 <= a) => Integer
+w = natVal (Proxy :: Proxy a)
+
+main :: IO ()
+main = do
+  print $ q + w
+  print $ mc Proxy Proxy
diff --git a/testsuite/tests/plugins/test-defaulting-plugin.stderr b/testsuite/tests/plugins/test-defaulting-plugin.stderr
new file mode 100644
index 0000000000..5108d5c805
--- /dev/null
+++ b/testsuite/tests/plugins/test-defaulting-plugin.stderr
@@ -0,0 +1,37 @@
+
+test-defaulting-plugin.hs:28:11: warning: [-Wtype-defaults (in -Wall)]
+     Defaulting the type variable ‘a0’ to type ‘0’ in the following constraint
+        KnownNat a0 arising from a use of ‘q’
+     In the first argument of ‘(+)’, namely ‘q’
+      In the second argument of ‘($)’, namely ‘q + w’
+      In a stmt of a 'do' block: print $ q + w
+
+test-defaulting-plugin.hs:28:15: warning: [-Wtype-defaults (in -Wall)]
+     Defaulting the type variable ‘a0’ to type ‘2’ in the following constraints
+        (KnownNat a0)
+          arising from a use of ‘w’ at test-defaulting-plugin.hs:28:15
+        (GHC.TypeError.Assert
+           (Data.Type.Ord.OrdCond (CmpNat 2 a0) 'True 'True 'False)
+           (TypeError ...))
+          arising from a use of ‘w’ at test-defaulting-plugin.hs:28:15
+     In the second argument of ‘(+)’, namely ‘w’
+      In the second argument of ‘($)’, namely ‘q + w’
+      In a stmt of a 'do' block: print $ q + w
+
+test-defaulting-plugin.hs:29:11: warning: [-Wtype-defaults (in -Wall)]
+     Defaulting the type variable ‘b0’ to type ‘0’ in the following constraint
+        KnownNat b0 arising from a use of ‘mc’
+     In the second argument of ‘($)’, namely ‘mc Proxy Proxy’
+      In a stmt of a 'do' block: print $ mc Proxy Proxy
+      In the expression:
+        do print $ q + w
+           print $ mc Proxy Proxy
+
+test-defaulting-plugin.hs:29:11: warning: [-Wtype-defaults (in -Wall)]
+     Defaulting the type variable ‘a0’ to type ‘0’ in the following constraint
+        KnownNat a0 arising from a use of ‘mc’
+     In the second argument of ‘($)’, namely ‘mc Proxy Proxy’
+      In a stmt of a 'do' block: print $ mc Proxy Proxy
+      In the expression:
+        do print $ q + w
+           print $ mc Proxy Proxy
diff --git a/testsuite/tests/typecheck/should_compile/T10971a.stderr b/testsuite/tests/typecheck/should_compile/T10971a.stderr
index 800dc84efa..ff06f84bff 100644
--- a/testsuite/tests/typecheck/should_compile/T10971a.stderr
+++ b/testsuite/tests/typecheck/should_compile/T10971a.stderr
@@ -3,7 +3,7 @@ T10971a.hs:7:1: warning: [-Wmissing-signatures (in -Wall)]
     Top-level binding with no type signature: f :: [a] -> Int
 
 T10971a.hs:7:11: warning: [-Wtype-defaults (in -Wall)]
-    • Defaulting the following constraint to type ‘[]’
+    • Defaulting the type variable ‘t0’ to type ‘[]’ in the following constraint
         Foldable t0 arising from a use of ‘length’
     • In the expression: length x
       In the expression: \ x -> length x
@@ -18,7 +18,7 @@ T10971a.hs:8:6: warning: [-Wname-shadowing (in -Wall)]
       defined at T10971a.hs:7:1
 
 T10971a.hs:8:13: warning: [-Wtype-defaults (in -Wall)]
-    • Defaulting the following constraint to type ‘[]’
+    • Defaulting the type variable ‘t0’ to type ‘[]’ in the following constraint
         Traversable t0 arising from a use of ‘fmapDefault’
     • In the expression: fmapDefault f x
       In the expression: \ f x -> fmapDefault f x
@@ -33,7 +33,7 @@ T10971a.hs:9:6: warning: [-Wname-shadowing (in -Wall)]
       defined at T10971a.hs:7:1
 
 T10971a.hs:9:14: warning: [-Wtype-defaults (in -Wall)]
-    • Defaulting the following constraints to type ‘[]’
+    • Defaulting the type variable ‘t0’ to type ‘[]’ in the following constraints
         (Traversable t0)
           arising from a use of ‘fmapDefault’ at T10971a.hs:9:14-24
         (Foldable t0) arising from a use of ‘length’ at T10971a.hs:9:31-36
diff --git a/testsuite/tests/typecheck/should_fail/tcfail204.stderr b/testsuite/tests/typecheck/should_fail/tcfail204.stderr
index a1ab99c445..8fb0f1efc5 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail204.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail204.stderr
@@ -1,6 +1,6 @@
 
 tcfail204.hs:10:7: error: [-Wtype-defaults (in -Wall), -Werror=type-defaults]
-    • Defaulting the following constraints to type ‘Double’
+    • Defaulting the type variable ‘a0’ to type ‘Double’ in the following constraints
         (RealFrac a0)
           arising from a use of ‘ceiling’ at tcfail204.hs:10:7-13
         (Fractional a0)
diff --git a/testsuite/tests/warnings/should_compile/PluralS.stderr b/testsuite/tests/warnings/should_compile/PluralS.stderr
index 0276c3a59d..d8a6f76957 100644
--- a/testsuite/tests/warnings/should_compile/PluralS.stderr
+++ b/testsuite/tests/warnings/should_compile/PluralS.stderr
@@ -1,13 +1,13 @@
 
 PluralS.hs:15:17: warning: [-Wtype-defaults (in -Wall)]
-    • Defaulting the following constraint to type ‘Integer’
+    • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraint
         Num a0 arising from the literal ‘123’
     • In the first argument of ‘seq’, namely ‘123’
       In the expression: 123 `seq` ()
       In an equation for ‘defaultingNum’: defaultingNum = 123 `seq` ()
 
 PluralS.hs:17:24: warning: [-Wtype-defaults (in -Wall)]
-    • Defaulting the following constraints to type ‘Integer’
+    • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraints
         (Show a0) arising from a use of ‘show’ at PluralS.hs:17:24-27
         (Num a0) arising from the literal ‘123’ at PluralS.hs:17:29-31
     • In the expression: show 123