Use sigPrec in more places in Convert and HsUtils

Trac #16183 was caused by TH conversion (in `Convert`) not properly
inserting parentheses around occurrences of explicit signatures where
appropriate, such as in applications, function types, and type family
equations. Solution: use `parenthesizeHsType sigPrec` in these
places. While I was in town, I also updated `nlHsFunTy` to do the
same thing.

(cherry picked from commit b1e569a54085bf1093b4f858f8c7c739e3be769b)

6 files changed, 62 insertions, 41 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 59b42bd..8672a66 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -418,7 +418,7 @@ cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
        ; case head_ty of
            ConT nm -> do { nm' <- tconNameL nm
                          ; rhs' <- cvtType rhs
-                         ; args' <- mapM wrap_tyargs args
+                         ; let args' = map wrap_tyarg args
                          ; returnL $ mkHsImplicitBndrs
                             $ FamEqn { feqn_ext    = noExt
                                      , feqn_tycon  = nm'
@@ -485,7 +485,7 @@ cvt_datainst_hdr cxt bndrs tys
        ; (head_ty, args) <- split_ty_app tys
        ; case head_ty of
           ConT nm -> do { nm' <- tconNameL nm
-                        ; args' <- mapM wrap_tyargs args
+                        ; let args' = map wrap_tyarg args
                         ; return (cxt', nm', bndrs', args') }
           InfixT t1 nm t2 -> do { nm' <- tconNameL nm
                                 ; args' <- mapM cvtType [t1,t2]
@@ -622,9 +622,9 @@ cvtSrcStrictness SourceStrict       = SrcStrict
 cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
 cvt_arg (Bang su ss, ty)
   = do { ty'' <- cvtType ty
-       ; ty' <- wrap_apps ty''
-       ; let su' = cvtSrcUnpackedness su
-       ; let ss' = cvtSrcStrictness ss
+       ; let ty' = parenthesizeHsType appPrec ty''
+             su' = cvtSrcUnpackedness su
+             ss' = cvtSrcStrictness ss
        ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }
 
 cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
@@ -880,9 +880,9 @@ cvtl e = wrapL (cvt e)
                                                           (mkLHsPar y')}
     cvt (AppTypeE e t) = do { e' <- cvtl e
                             ; t' <- cvtType t
-                            ; tp <- wrap_apps t'
-                            ; let tp' = parenthesizeHsType appPrec tp
-                            ; return $ HsAppType noExt e' (mkHsWildCardBndrs tp') }
+                            ; let tp = parenthesizeHsType appPrec t'
+                            ; return $ HsAppType noExt e'
+                                     $ mkHsWildCardBndrs tp }
     cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its
                                -- own expression to avoid pretty-printing
                                -- oddities that can result from zero-argument
@@ -1369,8 +1369,10 @@ cvtTypeKind ty_str ty
                           HsFunTy{}    -> returnL (HsParTy noExt x')
                           HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646
                           HsQualTy{}   -> returnL (HsParTy noExt x') -- #15324
-                          _            -> return x'
-                 returnL (HsFunTy noExt x'' y')
+                          _            -> return $
+                                          parenthesizeHsType sigPrec x'
+                 let y'' = parenthesizeHsType sigPrec y'
+                 returnL (HsFunTy noExt x'' y'')
              | otherwise
              -> mk_apps
                 (HsTyVar noExt NotPromoted (noLoc (getRdrName funTyCon)))
@@ -1504,34 +1506,35 @@ cvtTypeKind ty_str ty
 
 -- | Constructs an application of a type to arguments passed in a list.
 mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
-mk_apps head_ty []       = returnL head_ty
-mk_apps head_ty (arg:args) =
-  do { head_ty' <- returnL head_ty
-     ; case arg of
-       HsValArg ty  -> do { p_ty      <- add_parens ty
-                          ; mk_apps (HsAppTy noExt head_ty' p_ty) args }
-       HsTypeArg ki -> do { p_ki      <- add_parens ki
-                          ; mk_apps (HsAppKindTy noExt head_ty' p_ki) args }
-       HsArgPar _   -> mk_apps (HsParTy noExt head_ty') args
-     }
+mk_apps head_ty type_args = do
+  head_ty' <- returnL head_ty
+  -- We must parenthesize the function type in case of an explicit
+  -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there
+  -- _must_ be parentheses around `Maybe :: Type -> Type`.
+  let phead_ty :: LHsType GhcPs
+      phead_ty = parenthesizeHsType sigPrec head_ty'
+
+      go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
+      go [] = pure head_ty'
+      go (arg:args) =
+        case arg of
+          HsValArg ty  -> do p_ty <- add_parens ty
+                             mk_apps (HsAppTy noExt phead_ty p_ty) args
+          HsTypeArg ki -> do p_ki <- add_parens ki
+                             mk_apps (HsAppKindTy noExt phead_ty p_ki) args
+          HsArgPar _   -> mk_apps (HsParTy noExt phead_ty) args
+
+  go type_args
    where
     -- See Note [Adding parens for splices]
     add_parens lt@(dL->L _ t)
       | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)
       | otherwise                   = return lt
 
--- See Note [Adding parens for splices]
-wrap_apps  :: LHsType GhcPs -> CvtM (LHsType GhcPs)
-wrap_apps t@(dL->L _ HsAppTy {})     = returnL (HsParTy noExt t)
-wrap_apps t@(dL->L _ HsAppKindTy {}) = returnL (HsParTy noExt t)
-wrap_apps t                          = return t
-
-wrap_tyargs :: LHsTypeArg GhcPs -> CvtM (LHsTypeArg GhcPs)
-wrap_tyargs (HsValArg ty) = do { ty' <- wrap_apps ty
-                                  ; return $ HsValArg ty'}
-wrap_tyargs (HsTypeArg ki) = do { ki' <- wrap_apps ki
-                               ; return $ HsTypeArg ki'}
-wrap_tyargs argPar = return argPar
+wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
+wrap_tyarg (HsValArg ty)    = HsValArg  $ parenthesizeHsType appPrec ty
+wrap_tyarg (HsTypeArg ki)   = HsTypeArg $ parenthesizeHsType appPrec ki
+wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized
 
 -- ---------------------------------------------------------------------
 -- Note [Adding parens for splices]
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 8cc3fb2..c5cac53 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -504,13 +504,7 @@ nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)
 
 nlHsAppTy f t = noLoc (HsAppTy noExt f (parenthesizeHsType appPrec t))
 nlHsTyVar x   = noLoc (HsTyVar noExt NotPromoted (noLoc x))
-nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a)
-                                     (parenthesize_fun_tail b))
-  where
-    parenthesize_fun_tail (dL->L loc (HsFunTy ext ty1 ty2))
-      = cL loc (HsFunTy ext (parenthesizeHsType funPrec ty1)
-                           (parenthesize_fun_tail ty2))
-    parenthesize_fun_tail lty = lty
+nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a) b)
 nlHsParTy t   = noLoc (HsParTy noExt t)
 
 nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
diff --git a/testsuite/tests/th/T12045TH1.stderr b/testsuite/tests/th/T12045TH1.stderr
index fb4bf1a..aede24c 100644
--- a/testsuite/tests/th/T12045TH1.stderr
+++ b/testsuite/tests/th/T12045TH1.stderr
@@ -5,7 +5,7 @@ T12045TH1.hs:(8,3)-(10,52): Splicing declarations
   ======>
     type family F (a :: k) :: Type where
       F @Type Int = Bool
-      F @Type -> Type Maybe = Char
+      F @(Type -> Type) Maybe = Char
 T12045TH1.hs:13:3-31: Splicing declarations
     [d| data family D (a :: k) |] ======> data family D (a :: k)
 T12045TH1.hs:15:3-40: Splicing declarations
@@ -15,4 +15,4 @@ T12045TH1.hs:15:3-40: Splicing declarations
 T12045TH1.hs:17:3-50: Splicing declarations
     [d| data instance D @(Type -> Type) b = DChar |]
   ======>
-    data instance D @Type -> Type b = DChar
+    data instance D @(Type -> Type) b = DChar
diff --git a/testsuite/tests/th/T16183.hs b/testsuite/tests/th/T16183.hs
new file mode 100644
index 0000000..6b1280f
--- /dev/null
+++ b/testsuite/tests/th/T16183.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+module T16183 where
+
+import Data.Kind
+
+$([d| type F1 = (Maybe :: Type -> Type) Int
+      type F2 = (Int :: Type) -> (Int :: Type)
+      type family F3 a where
+        F3 (a :: Type) = Int
+      newtype F4 = MkF4 (Int :: Type) |])
diff --git a/testsuite/tests/th/T16183.stderr b/testsuite/tests/th/T16183.stderr
new file mode 100644
index 0000000..812fd58
--- /dev/null
+++ b/testsuite/tests/th/T16183.stderr
@@ -0,0 +1,12 @@
+T16183.hs:(7,3)-(11,40): Splicing declarations
+    [d| type F1 = (Maybe :: Type -> Type) Int
+        type F2 = (Int :: Type) -> (Int :: Type)
+        type family F3 a where
+          F3 (a :: Type) = Int
+        newtype F4 = MkF4 (Int :: Type) |]
+  ======>
+    type F1 = (Maybe :: Type -> Type) Int
+    type F2 = (Int :: Type) -> (Int :: Type)
+    type family F3 a where
+      F3 (a :: Type) = Int
+    newtype F4 = MkF4 (Int :: Type)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 4062cf2..b93673c 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -468,3 +468,4 @@ test('T15985', normal, compile, [''])
 test('T16133', normal, compile_fail, [''])
 test('T15471', normal, multimod_compile, ['T15471.hs', '-v0'])
 test('T16180', when(opsys('darwin'), expect_broken(16218)), compile_and_run, [''])
+test('T16183', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])