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.

2 files changed, 40 insertions, 162 deletions

diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index ccf98857f4..c475357807 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -95,6 +95,7 @@ import GHC.Types.Name( Name, NamedThing(getName) )
 import GHC.Types.Name.Reader ( RdrName )
 import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..),
                          SrcStrictness(..), SrcUnpackedness(..) )
+import GHC.Core.TyCo.Rep ( Type(..) )
 import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )
 import GHC.Core.Type
 import GHC.Hs.Doc
@@ -866,6 +867,8 @@ data HsType pass
 data NewHsTypeX
   = NHsCoreTy Type -- An escape hatch for tunnelling a *closed*
                    -- Core Type through HsSyn.
+                   -- See also Note [Typechecking NHsCoreTys] in
+                   -- GHC.Tc.Gen.HsType.
     deriving Data
       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None
 
@@ -1870,32 +1873,43 @@ ppr_tylit (HsStrTy _ s) = text (show s)
 
 -- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses
 -- under precedence @p@.
-hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool
-hsTypeNeedsParens p = go
+hsTypeNeedsParens :: PprPrec -> HsType (GhcPass p) -> Bool
+hsTypeNeedsParens p = go_hs_ty
   where
-    go (HsForAllTy{})        = p >= funPrec
-    go (HsQualTy{})          = p >= funPrec
-    go (HsBangTy{})          = p > topPrec
-    go (HsRecTy{})           = False
-    go (HsTyVar{})           = False
-    go (HsFunTy{})           = p >= funPrec
-    go (HsTupleTy{})         = False
-    go (HsSumTy{})           = False
-    go (HsKindSig{})         = p >= sigPrec
-    go (HsListTy{})          = False
-    go (HsIParamTy{})        = p > topPrec
-    go (HsSpliceTy{})        = False
-    go (HsExplicitListTy{})  = False
-    go (HsExplicitTupleTy{}) = False
-    go (HsTyLit{})           = False
-    go (HsWildCardTy{})      = False
-    go (HsStarTy{})          = p >= starPrec
-    go (HsAppTy{})           = p >= appPrec
-    go (HsAppKindTy{})       = p >= appPrec
-    go (HsOpTy{})            = p >= opPrec
-    go (HsParTy{})           = False
-    go (HsDocTy _ (L _ t) _) = go t
-    go (XHsType{})           = False
+    go_hs_ty (HsForAllTy{})           = p >= funPrec
+    go_hs_ty (HsQualTy{})             = p >= funPrec
+    go_hs_ty (HsBangTy{})             = p > topPrec
+    go_hs_ty (HsRecTy{})              = False
+    go_hs_ty (HsTyVar{})              = False
+    go_hs_ty (HsFunTy{})              = p >= funPrec
+    go_hs_ty (HsTupleTy{})            = False
+    go_hs_ty (HsSumTy{})              = False
+    go_hs_ty (HsKindSig{})            = p >= sigPrec
+    go_hs_ty (HsListTy{})             = False
+    go_hs_ty (HsIParamTy{})           = p > topPrec
+    go_hs_ty (HsSpliceTy{})           = False
+    go_hs_ty (HsExplicitListTy{})     = False
+    go_hs_ty (HsExplicitTupleTy{})    = False
+    go_hs_ty (HsTyLit{})              = False
+    go_hs_ty (HsWildCardTy{})         = False
+    go_hs_ty (HsStarTy{})             = p >= starPrec
+    go_hs_ty (HsAppTy{})              = p >= appPrec
+    go_hs_ty (HsAppKindTy{})          = p >= appPrec
+    go_hs_ty (HsOpTy{})               = p >= opPrec
+    go_hs_ty (HsParTy{})              = False
+    go_hs_ty (HsDocTy _ (L _ t) _)    = go_hs_ty t
+    go_hs_ty (XHsType (NHsCoreTy ty)) = go_core_ty ty
+
+    go_core_ty (TyVarTy{})    = False
+    go_core_ty (AppTy{})      = p >= appPrec
+    go_core_ty (TyConApp _ args)
+      | null args             = False
+      | otherwise             = p >= appPrec
+    go_core_ty (ForAllTy{})   = p >= funPrec
+    go_core_ty (FunTy{})      = p >= funPrec
+    go_core_ty (LitTy{})      = False
+    go_core_ty (CastTy t _)   = go_core_ty t
+    go_core_ty (CoercionTy{}) = False
 
 maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc
 -- See Note [Printing promoted type constructors]
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 1c8023946c..626a771be7 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -47,7 +47,6 @@ module GHC.Hs.Utils(
   nlHsIntLit, nlHsVarApps,
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
-  typeToLHsType,
 
   -- * Constructing general big tuples
   -- $big_tuples
@@ -119,9 +118,7 @@ import GHC.Tc.Types.Evidence
 import GHC.Types.Name.Reader
 import GHC.Types.Var
 import GHC.Core.TyCo.Rep
-import GHC.Core.TyCon
-import GHC.Core.Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig )
-import GHC.Core.Multiplicity ( pattern One, pattern Many )
+import GHC.Core.Multiplicity ( pattern Many )
 import GHC.Builtin.Types ( unitTy )
 import GHC.Tc.Utils.TcType
 import GHC.Core.DataCon
@@ -680,139 +677,6 @@ mkClassOpSigs sigs
       = L loc (ClassOpSig noExtField False nms (dropWildCards ty))
     fiddle sig = sig
 
-typeToLHsType :: Type -> LHsType GhcPs
--- ^ Converting a Type to an HsType RdrName
--- This is needed to implement GeneralizedNewtypeDeriving.
---
--- Note that we use 'getRdrName' extensively, which
--- generates Exact RdrNames rather than strings.
-typeToLHsType ty
-  = go ty
-  where
-    go :: Type -> LHsType GhcPs
-    go ty@(FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res })
-      = case af of
-          VisArg   -> nlHsFunTy (multToHsArrow mult) (go arg) (go res)
-          InvisArg | (theta, tau) <- tcSplitPhiTy ty
-                   -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
-                                      , hst_xqual = noExtField
-                                      , hst_body = go tau })
-
-    go ty@(ForAllTy (Bndr _ argf) _)
-      = noLoc (HsForAllTy { hst_tele = tele
-                          , hst_xforall = noExtField
-                          , hst_body = go tau })
-      where
-        (tele, tau)
-          | isVisibleArgFlag argf
-          = let (req_tvbs, tau') = tcSplitForAllTysReq ty in
-            (mkHsForAllVisTele (map go_tv req_tvbs), tau')
-          | otherwise
-          = let (inv_tvbs, tau') = tcSplitForAllTysInvis ty in
-            (mkHsForAllInvisTele (map go_tv inv_tvbs), tau')
-    go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)
-    go (LitTy (NumTyLit n))
-      = noLoc $ HsTyLit noExtField (HsNumTy NoSourceText n)
-    go (LitTy (StrTyLit s))
-      = noLoc $ HsTyLit noExtField (HsStrTy NoSourceText s)
-    go ty@(TyConApp tc args)
-      | tyConAppNeedsKindSig True tc (length args)
-        -- We must produce an explicit kind signature here to make certain
-        -- programs kind-check. See Note [Kind signatures in typeToLHsType].
-      = nlHsParTy $ noLoc $ HsKindSig noExtField ty' (go (tcTypeKind ty))
-      | otherwise = ty'
-       where
-        ty' :: LHsType GhcPs
-        ty' = go_app (noLoc $ HsTyVar noExtField prom $ noLoc $ getRdrName tc)
-                     args (tyConArgFlags tc args)
-
-        prom :: PromotionFlag
-        prom = if isPromotedDataCon tc then IsPromoted else NotPromoted
-    go ty@(AppTy {})        = go_app (go head) args (appTyArgFlags head args)
-      where
-        head :: Type
-        args :: [Type]
-        (head, args) = splitAppTys ty
-    go (CastTy ty _)        = go ty
-    go (CoercionTy co)      = pprPanic "typeToLHsType" (ppr co)
-
-         -- Source-language types have _invisible_ kind arguments,
-         -- so we must remove them here (#8563)
-
-    go_app :: LHsType GhcPs -- The type being applied
-           -> [Type]        -- The argument types
-           -> [ArgFlag]     -- The argument types' visibilities
-           -> LHsType GhcPs
-    go_app head args arg_flags =
-      foldl' (\f (arg, flag) ->
-               let arg' = go arg in
-               case flag of
-                 -- See Note [Explicit Case Statement for Specificity]
-                 Invisible spec -> case spec of
-                   InferredSpec  -> f
-                   SpecifiedSpec -> f `nlHsAppKindTy` arg'
-                 Required  -> f `nlHsAppTy`     arg')
-             head (zip args arg_flags)
-
-    go_tv :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
-    go_tv (Bndr tv flag) = noLoc $ KindedTyVar noExtField
-                                               flag
-                                               (noLoc (getRdrName tv))
-                                               (go (tyVarKind tv))
-
--- | This is used to transform an arrow from Core's Type to surface
--- syntax. There is a choice between being very explicit here, or trying to
--- refold arrows into shorthands as much as possible. We choose to do the
--- latter, for it should be more readable. It also helps printing Haskell'98
--- code into Haskell'98 syntax.
-multToHsArrow :: Mult -> HsArrow GhcPs
-multToHsArrow One = HsLinearArrow
-multToHsArrow Many = HsUnrestrictedArrow
-multToHsArrow ty = HsExplicitMult (typeToLHsType ty)
-
-{-
-Note [Kind signatures in typeToLHsType]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are types that typeToLHsType can produce which require explicit kind
-signatures in order to kind-check. Here is an example from #14579:
-
-  -- type P :: forall {k} {t :: k}. Proxy t
-  type P = 'Proxy
-
-  -- type Wat :: forall a. Proxy a -> *
-  newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a)
-    deriving Eq
-
-  -- type Wat2 :: forall {a}. Proxy a -> *
-  type Wat2 = Wat
-
-  -- type Glurp :: * -> *
-  newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a))
-    deriving Eq
-
-The derived Eq instance for Glurp (without any kind signatures) would be:
-
-  instance Eq a => Eq (Glurp a) where
-    (==) :: Glurp a -> Glurp a -> Bool
-    (==) = coerce @(Wat2 P  -> Wat2 P  -> Bool)
-                  @(Glurp a -> Glurp a -> Bool)
-                  (==)
-
-(Where the visible type applications use types produced by typeToLHsType.)
-
-The type P (in Wat2 P) has an underspecified kind, so we must ensure that
-typeToLHsType ascribes it with its kind: Wat2 (P :: Proxy a). To accomplish
-this, whenever we see an application of a tycon to some arguments, we use
-the tyConAppNeedsKindSig function to determine if it requires an explicit kind
-signature to resolve some ambiguity. (See Note
-Note [When does a tycon application need an explicit kind signature?] for a
-more detailed explanation of how this works.)
-
-Note that we pass True to tyConAppNeedsKindSig since we are generated code with
-visible kind applications, so even specified arguments count towards injective
-positions in the kind of the tycon.
--}
-
 {- *********************************************************************
 *                                                                      *
     --------- HsWrappers: type args, dict args, casts ---------