Use NHsCoreTy to embed types into GND-generated code

`GeneralizedNewtypeDeriving` is in the unique situation where it must
produce an `LHsType GhcPs` from a Core `Type`. Historically, this was
done with the `typeToLHsType` function, which walked over the entire
`Type` and attempted to construct an `LHsType` with the same overall
structure. `typeToLHsType` is quite complicated, however, and has
been the subject of numerous bugs over the years (e.g., #14579).

Luckily, there is an easier way to accomplish the same thing: the
`XHsType` constructor of `HsType`. `XHsType` bundles an `NHsCoreTy`,
which allows embedding a Core `Type` directly into an `HsType`,
avoiding the need to laboriously convert from one to another (as
`typeToLHsType` did). Moreover, renaming and typechecking an
`XHsType` is simple, since one doesn't need to do anything to a
Core `Type`...

...well, almost. For the reasons described in
`Note [Typechecking NHsCoreTys]` in `GHC.Tc.Gen.HsType`, we must
apply a substitution that we build from the local `tcl_env` type
environment. But that's a relatively modest price to pay.

Now that `GeneralizedNewtypeDeriving` uses `NHsCoreTy`, the
`typeToLHsType` function no longer has any uses in GHC, so this patch
rips it out. Some additional tweaks to `hsTypeNeedsParens` were
necessary to make the new `-ddump-deriv` output correctly
parenthesized, but other than that, this patch is quite
straightforward.

This is a mostly internal refactoring, although it is likely that
`GeneralizedNewtypeDeriving`-generated code will now need fewer
language extensions in certain situations than it did before.

3 files changed, 67 insertions, 10 deletions

diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 01b7896853..f0655f5b4e 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -591,7 +591,7 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
                         -- mean more tests (dynamically)
         nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
   where
-    ascribeBool e = nlExprWithTySig e boolTy
+    ascribeBool e = nlExprWithTySig e $ nlHsTyVar boolTyCon_RDR
 
 nlConWildPat :: DataCon -> LPat GhcPs
 -- The pattern (K {})
@@ -1890,7 +1890,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
           --
           --   op :: forall c. a -> [T x] -> c -> Int
           L loc $ ClassOpSig noExtField False [loc_meth_RDR]
-                $ mkLHsSigType $ typeToLHsType to_ty
+                $ mkLHsSigType $ nlHsCoreTy to_ty
         )
       where
         Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
@@ -1946,12 +1946,15 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
 nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
 nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty)
   where
-    hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)
+    hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s
 
-nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
+nlExprWithTySig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
 nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty
   where
-    hs_ty = mkLHsSigWcType (typeToLHsType s)
+    hs_ty = mkLHsSigWcType s
+
+nlHsCoreTy :: Type -> LHsType GhcPs
+nlHsCoreTy = noLoc . XHsType . NHsCoreTy
 
 mkCoerceClassMethEqn :: Class   -- the class being derived
                      -> [TyVar] -- the tvs in the instance head (this includes
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 68d29f565e..22edf3c0b4 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -90,6 +90,7 @@ import GHC.Tc.Utils.TcType
 import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder )
 import GHC.Core.Type
 import GHC.Builtin.Types.Prim
+import GHC.Types.Name.Env
 import GHC.Types.Name.Reader( lookupLocalRdrOcc )
 import GHC.Types.Var
 import GHC.Types.Var.Set
@@ -106,6 +107,7 @@ import GHC.Types.SrcLoc
 import GHC.Settings.Constants ( mAX_CTUPLE_SIZE )
 import GHC.Utils.Error( MsgDoc )
 import GHC.Types.Unique
+import GHC.Types.Unique.FM
 import GHC.Types.Unique.Set
 import GHC.Utils.Misc
 import GHC.Types.Unique.Supply
@@ -833,8 +835,17 @@ tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))
   = tc_infer_hs_type mode ty
 
 tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty
-tc_infer_hs_type _    (XHsType (NHsCoreTy ty))
-  = return (ty, tcTypeKind ty)
+
+-- See Note [Typechecking NHsCoreTys]
+tc_infer_hs_type _ (XHsType (NHsCoreTy ty))
+  = do env <- getLclEnv
+       let subst_prs = [ (nm, tv)
+                       | ATyVar nm tv <- nameEnvElts (tcl_env env) ]
+           subst = mkTvSubst
+                     (mkInScopeSet $ mkVarSet $ map snd subst_prs)
+                     (listToUFM $ map (liftSnd mkTyVarTy) subst_prs)
+           ty' = substTy subst ty
+       return (ty', tcTypeKind ty')
 
 tc_infer_hs_type _ (HsExplicitListTy _ _ tys)
   | null tys  -- this is so that we can use visible kind application with '[]
@@ -847,6 +858,47 @@ tc_infer_hs_type mode other_ty
        ; ty' <- tc_hs_type mode other_ty kv
        ; return (ty', kv) }
 
+{-
+Note [Typechecking NHsCoreTys]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NHsCoreTy is an escape hatch that allows embedding Core Types in HsTypes.
+As such, there's not much to be done in order to typecheck an NHsCoreTy,
+since it's already been typechecked to some extent. There is one thing that
+we must do, however: we must substitute the type variables from the tcl_env.
+To see why, consider GeneralizedNewtypeDeriving, which is one of the main
+clients of NHsCoreTy (example adapted from #14579):
+
+  newtype T a = MkT a deriving newtype Eq
+
+This will produce an InstInfo GhcPs that looks roughly like this:
+
+  instance forall a_1. Eq a_1 => Eq (T a_1) where
+    (==) = coerce @(  a_1 ->   a_1 -> Bool) -- The type within @(...) is an NHsCoreTy
+                  @(T a_1 -> T a_1 -> Bool) -- So is this
+                  (==)
+
+This is then fed into the renamer. Since all of the type variables in this
+InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically
+identical. Things get more interesting when the InstInfo is fed into the
+typechecker, however. GHC will first generate fresh skolems to instantiate
+the instance-bound type variables with. In the example above, we might generate
+the skolem a_2 and use that to instantiate a_1, which extends the local type
+environment (tcl_env) with [a_1 :-> a_2]. This gives us:
+
+  instance forall a_2. Eq a_2 => Eq (T a_2) where ...
+
+To ensure that the body of this instance is well scoped, every occurrence of
+the `a` type variable should refer to a_2, the new skolem. However, the
+NHsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the
+substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this
+substitution to each NHsCoreTy and all is well:
+
+  instance forall a_2. Eq a_2 => Eq (T a_2) where
+    (==) = coerce @(  a_2 ->   a_2 -> Bool)
+                  @(T a_2 -> T a_2 -> Bool)
+                  (==)
+-}
+
 ------------------------------------------
 tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType
 tcLHsType hs_ty exp_kind
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index dd828bc277..dc8aeb1962 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -1604,7 +1604,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
 
     tc_default sel_id (Just (dm_name, _))
-      = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name
+      = do { (meth_bind, inline_prags) <- mkDefMethBind dfun_id clas sel_id dm_name
            ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
                           dfun_ev_binds is_derived hs_sig_fn
                           spec_inst_prags inline_prags
@@ -1947,7 +1947,7 @@ mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
          | L inst_loc (SpecPrag _       wrap inl) <- spec_inst_prags]
 
 
-mkDefMethBind :: Class -> [Type] -> Id -> Name
+mkDefMethBind :: DFunId -> Class -> Id -> Name
               -> TcM (LHsBind GhcRn, [LSig GhcRn])
 -- The is a default method (vanailla or generic) defined in the class
 -- So make a binding   op = $dmop @t1 @t2
@@ -1955,7 +1955,7 @@ mkDefMethBind :: Class -> [Type] -> Id -> Name
 -- and t1,t2 are the instance types.
 -- See Note [Default methods in instances] for why we use
 -- visible type application here
-mkDefMethBind clas inst_tys sel_id dm_name
+mkDefMethBind dfun_id clas sel_id dm_name
   = do  { dflags <- getDynFlags
         ; dm_id <- tcLookupId dm_name
         ; let inline_prag = idInlinePragma dm_id
@@ -1980,6 +1980,8 @@ mkDefMethBind clas inst_tys sel_id dm_name
 
        ; return (bind, inline_prags) }
   where
+    (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id)
+
     mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
     mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy
                                                 $ noLoc $ XHsType $ NHsCoreTy ty))