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.

2 files changed, 36 insertions, 39 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 59b42bda0f..8672a662cc 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 8cc3fb2cea..c5cac539ab 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)