Banish reportFloatingViaTvs to the shadow realm (#15831, #16181)

GHC used to reject programs of this form:

```
newtype Age = MkAge Int
  deriving Eq via Const Int a
```

That's because an earlier implementation of `DerivingVia` would
generate the following instance:

```
instance Eq Age where
  (==) = coerce @(Const Int a -> Const Int a -> Bool)
                @(Age         -> Age         -> Bool)
                (==)
```

Note that the `a` in `Const Int a` is not bound anywhere, which
causes all sorts of issues. I figured that no one would ever want to
write code like this anyway, so I simply banned "floating" `via` type
variables like `a`, checking for their presence in the aptly named
`reportFloatingViaTvs` function.

`reportFloatingViaTvs` ended up being implemented in a subtly
incorrect way, as #15831 demonstrates. Following counsel with the
sage of gold fire, I decided to abandon `reportFloatingViaTvs`
entirely and opt for a different approach that would _accept_
the instance above. This is because GHC now generates this instance
instead:

```
instance forall a. Eq Age where
  (==) = coerce @(Const Int a -> Const Int a -> Bool)
                @(Age         -> Age         -> Bool)
                (==)
```

Notice that we now explicitly quantify the `a` in
`instance forall a. Eq Age`, so everything is peachy scoping-wise.
See `Note [Floating `via` type variables]` in `TcDeriv` for the full
scoop.

A pleasant benefit of this refactoring is that it made it much easier
to catch the problem observed in #16181, so this patch fixes that
issue too.

Fixes #15831. Fixes #16181.

1 files changed, 19 insertions, 81 deletions

diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index aea4b0d5eb..8f85fac28b 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -971,8 +971,7 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap)
   = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
        ; (mds', ty', fvs)
-           <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty ->
-              rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $
+           <- rnLDerivStrategy DerivDeclCtx mds $
               rnHsSigWcType BindUnlessForall DerivDeclCtx ty
        ; warnNoDerivStrat mds' loc
        ; return (DerivDecl noExtField ty' mds' overlap, fvs) }
@@ -1725,20 +1724,12 @@ rnLHsDerivingClause doc
                               , deriv_clause_strategy = dcs
                               , deriv_clause_tys = (dL->L loc' dct) }))
   = do { (dcs', dct', fvs)
-           <- rnLDerivStrategy doc dcs $ \strat_tvs ppr_via_ty ->
-              mapFvRn (rn_deriv_ty strat_tvs ppr_via_ty) dct
+           <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc) dct
        ; warnNoDerivStrat dcs' loc
        ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExtField
                                          , deriv_clause_strategy = dcs'
                                          , deriv_clause_tys = cL loc' dct' })
               , fvs ) }
-  where
-    rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs
-                -> RnM (LHsSigType GhcRn, FreeVars)
-    rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = dL->L loc _}) =
-      rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $
-      rnHsSigType doc deriv_ty
-    rn_deriv_ty _ _ (XHsImplicitBndrs nec) = noExtCon nec
 rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause nec))
   = noExtCon nec
 rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match"
@@ -1747,20 +1738,19 @@ rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match"
 rnLDerivStrategy :: forall a.
                     HsDocContext
                  -> Maybe (LDerivStrategy GhcPs)
-                 -> ([Name]   -- The tyvars bound by the via type
-                      -> SDoc -- The pretty-printed via type (used for
-                              -- error message reporting)
-                      -> RnM (a, FreeVars))
+                 -> RnM (a, FreeVars)
                  -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
 rnLDerivStrategy doc mds thing_inside
   = case mds of
       Nothing -> boring_case Nothing
-      Just ds -> do (ds', thing, fvs) <- rn_deriv_strat ds
-                    pure (Just ds', thing, fvs)
+      Just (dL->L loc ds) ->
+        setSrcSpan loc $ do
+          (ds', thing, fvs) <- rn_deriv_strat ds
+          pure (Just (cL loc ds'), thing, fvs)
   where
-    rn_deriv_strat :: LDerivStrategy GhcPs
-                   -> RnM (LDerivStrategy GhcRn, a, FreeVars)
-    rn_deriv_strat (dL->L loc ds) = do
+    rn_deriv_strat :: DerivStrategy GhcPs
+                   -> RnM (DerivStrategy GhcRn, a, FreeVars)
+    rn_deriv_strat ds = do
       let extNeeded :: LangExt.Extension
           extNeeded
             | ViaStrategy{} <- ds
@@ -1772,9 +1762,9 @@ rnLDerivStrategy doc mds thing_inside
         failWith $ illegalDerivStrategyErr ds
 
       case ds of
-        StockStrategy    -> boring_case (cL loc StockStrategy)
-        AnyclassStrategy -> boring_case (cL loc AnyclassStrategy)
-        NewtypeStrategy  -> boring_case (cL loc NewtypeStrategy)
+        StockStrategy    -> boring_case StockStrategy
+        AnyclassStrategy -> boring_case AnyclassStrategy
+        NewtypeStrategy  -> boring_case NewtypeStrategy
         ViaStrategy via_ty ->
           do (via_ty', fvs1) <- rnHsSigType doc via_ty
              let HsIB { hsib_ext  = via_imp_tvs
@@ -1782,65 +1772,13 @@ rnLDerivStrategy doc mds thing_inside
                  (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body
                  via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs
                  via_tvs = via_imp_tvs ++ via_exp_tvs
-             (thing, fvs2) <- extendTyVarEnvFVRn via_tvs $
-                              thing_inside via_tvs (ppr via_ty')
-             pure (cL loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2)
-
-    boring_case :: mds
-                -> RnM (mds, a, FreeVars)
-    boring_case mds = do
-      (thing, fvs) <- thing_inside [] empty
-      pure (mds, thing, fvs)
-
--- | Errors if a @via@ type binds any floating type variables.
--- See @Note [Floating `via` type variables]@
-rnAndReportFloatingViaTvs
-  :: forall a. Outputable a
-  => [Name]  -- ^ The bound type variables from a @via@ type.
-  -> SrcSpan -- ^ The source span (for error reporting only).
-  -> SDoc    -- ^ The pretty-printed @via@ type (for error reporting only).
-  -> String  -- ^ A description of what the @via@ type scopes over
-             --   (for error reporting only).
-  -> RnM (a, FreeVars) -- ^ The thing the @via@ type scopes over.
-  -> RnM (a, FreeVars)
-rnAndReportFloatingViaTvs tv_names loc ppr_via_ty via_scope_desc thing_inside
-  = do (thing, thing_fvs) <- thing_inside
-       setSrcSpan loc $ mapM_ (report_floating_via_tv thing thing_fvs) tv_names
-       pure (thing, thing_fvs)
-  where
-    report_floating_via_tv :: a -> FreeVars -> Name -> RnM ()
-    report_floating_via_tv thing used_names tv_name
-      = unless (tv_name `elemNameSet` used_names) $ addErr $ vcat
-          [ text "Type variable" <+> quotes (ppr tv_name) <+>
-            text "is bound in the" <+> quotes (text "via") <+>
-            text "type" <+> quotes ppr_via_ty
-          , text "but is not mentioned in the derived" <+>
-            text via_scope_desc <+> quotes (ppr thing) <>
-            text ", which is illegal" ]
-
-{-
-Note [Floating `via` type variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Imagine the following `deriving via` clause:
-
-    data Quux
-      deriving Eq via (Const a Quux)
+             (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside
+             pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2)
 
-This should be rejected. Why? Because it would generate the following instance:
-
-    instance Eq Quux where
-      (==) = coerce @(Quux         -> Quux         -> Bool)
-                    @(Const a Quux -> Const a Quux -> Bool)
-                    (==) :: Const a Quux -> Const a Quux -> Bool
-
-This instance is ill-formed, as the `a` in `Const a Quux` is unbound. The
-problem is that `a` is never used anywhere in the derived class `Eq`. Since
-`a` is bound but has no use sites, we refer to it as "floating".
-
-We use the rnAndReportFloatingViaTvs function to check that any type renamed
-within the context of the `via` deriving strategy actually uses all bound
-`via` type variables, and if it doesn't, it throws an error.
--}
+    boring_case :: ds -> RnM (ds, a, FreeVars)
+    boring_case ds = do
+      (thing, fvs) <- thing_inside
+      pure (ds, thing, fvs)
 
 badGadtStupidTheta :: HsDocContext -> SDoc
 badGadtStupidTheta _