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, 17 insertions, 1 deletions

diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index bd0bcb527d..3cac82ed2f 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -47,7 +47,8 @@ module HsDecls (
   -- ** Standalone deriving declarations
   DerivDecl(..), LDerivDecl,
   -- ** Deriving strategies
-  DerivStrategy(..), LDerivStrategy, derivStrategyName,
+  DerivStrategy(..), LDerivStrategy,
+  derivStrategyName, foldDerivStrategy, mapDerivStrategy,
   -- ** @RULE@ declarations
   LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),
   RuleBndr(..),LRuleBndr,
@@ -1936,6 +1937,21 @@ derivStrategyName = text . go
     go NewtypeStrategy  = "newtype"
     go (ViaStrategy {}) = "via"
 
+-- | Eliminate a 'DerivStrategy'.
+foldDerivStrategy :: (p ~ GhcPass pass)
+                  => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r
+foldDerivStrategy other _   StockStrategy    = other
+foldDerivStrategy other _   AnyclassStrategy = other
+foldDerivStrategy other _   NewtypeStrategy  = other
+foldDerivStrategy _     via (ViaStrategy t)  = via t
+
+-- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise,
+-- return the 'DerivStrategy' unchanged.
+mapDerivStrategy :: (p ~ GhcPass pass)
+                 => (XViaStrategy p -> XViaStrategy p)
+                 -> DerivStrategy p -> DerivStrategy p
+mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds
+
 {-
 ************************************************************************
 *                                                                      *