Fix #14578 by checking isCompoundHsType in more places

Summary:
The `HsType` pretty-printer does not automatically insert
parentheses where necessary for type applications, so a function
`isCompoundHsType` was created in D4056 towards this purpose.
However, it was not used in as many places as it ought to be,
resulting in #14578.

Test Plan: make test TEST=T14578

Reviewers: alanz, bgamari, simonpj

Reviewed By: alanz, simonpj

Subscribers: simonpj, rwbarton, thomie, carter

GHC Trac Issues: #14578

Differential Revision: https://phabricator.haskell.org/D4266

(cherry picked from commit 1bd91a7a)

compiler/hsSyn/HsTypes.hs

@@ -66,7 +66,7 @@ module HsTypes (
         -- Printing
         pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
         pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
-        isCompoundHsType
+        isCompoundHsType, parenthesizeCompoundHsType
     ) where
 
 import GhcPrelude
@@ -936,7 +936,7 @@ mkHsOpTy :: LHsType pass -> Located (IdP pass) -> LHsType pass -> HsType pass
 mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2
 
 mkHsAppTy :: LHsType pass -> LHsType pass -> LHsType pass
-mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
+mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 (parenthesizeCompoundHsType t2))
 
 mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass
 mkHsAppTys = foldl mkHsAppTy
@@ -1376,3 +1376,11 @@ isCompoundHsType (L _ HsEqTy{}  ) = True
 isCompoundHsType (L _ HsFunTy{} ) = True
 isCompoundHsType (L _ HsOpTy{}  ) = True
 isCompoundHsType _                = False
+
+-- | @'parenthesizeCompoundHsType' ty@ checks if @'isCompoundHsType' ty@ is
+-- true, and if so, surrounds it with an 'HsParTy'. Otherwise, it simply
+-- returns @ty@.
+parenthesizeCompoundHsType :: LHsType pass -> LHsType pass
+parenthesizeCompoundHsType ty@(L loc _)
+  | isCompoundHsType ty = L loc (HsParTy ty)
+  | otherwise           = ty

compiler/hsSyn/HsUtils.hs

@@ -482,10 +482,10 @@ nlHsTyVar :: IdP name                     -> LHsType name
 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
 nlHsParTy :: LHsType name                 -> LHsType name
 
-nlHsAppTy f t           = noLoc (HsAppTy f t)
-nlHsTyVar x             = noLoc (HsTyVar NotPromoted (noLoc x))
-nlHsFunTy a b           = noLoc (HsFunTy a b)
-nlHsParTy t             = noLoc (HsParTy t)
+nlHsAppTy f t = noLoc (HsAppTy f (parenthesizeCompoundHsType t))
+nlHsTyVar x   = noLoc (HsTyVar NotPromoted (noLoc x))
+nlHsFunTy a b = noLoc (HsFunTy a b)
+nlHsParTy t   = noLoc (HsParTy t)
 
 nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name
 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys

testsuite/tests/deriving/should_compile/T14578.hs

+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module T14578 where
+
+import Control.Applicative
+import Data.Functor.Compose
+import Data.Semigroup
+
+newtype App f a = MkApp (f a)
+  deriving (Functor, Applicative)
+
+instance (Applicative f, Semigroup a) => Semigroup (App f a) where
+  (<>) = liftA2 (<>)
+
+newtype Wat f g a = MkWat (App (Compose f g) a)
+  deriving Semigroup

testsuite/tests/deriving/should_compile/T14578.stderr

+
+==================== Derived instances ====================
+Derived class instances:
+  instance GHC.Base.Functor f =>
+           GHC.Base.Functor (T14578.App f) where
+    GHC.Base.fmap
+      = GHC.Prim.coerce
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep).
+            a -> b -> f a -> f b)
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep).
+            a -> b -> T14578.App f a -> T14578.App f b)
+          GHC.Base.fmap
+    (GHC.Base.<$)
+      = GHC.Prim.coerce
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep).
+            a -> f b -> f a)
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep).
+            a -> T14578.App f b -> T14578.App f a)
+          (GHC.Base.<$)
+  
+  instance GHC.Base.Applicative f =>
+           GHC.Base.Applicative (T14578.App f) where
+    GHC.Base.pure
+      = GHC.Prim.coerce
+          @(forall (a :: TYPE GHC.Types.LiftedRep). a -> f a)
+          @(forall (a :: TYPE GHC.Types.LiftedRep). a -> T14578.App f a)
+          GHC.Base.pure
+    (GHC.Base.<*>)
+      = GHC.Prim.coerce
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep).
+            f (a -> b) -> f a -> f b)
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep).
+            T14578.App f (a -> b) -> T14578.App f a -> T14578.App f b)
+          (GHC.Base.<*>)
+    GHC.Base.liftA2
+      = GHC.Prim.coerce
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep)
+                   (c :: TYPE GHC.Types.LiftedRep).
+            a -> b -> c -> f a -> f b -> f c)
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep)
+                   (c :: TYPE GHC.Types.LiftedRep).
+            a -> b -> c -> T14578.App f a -> T14578.App f b -> T14578.App f c)
+          GHC.Base.liftA2
+    (GHC.Base.*>)
+      = GHC.Prim.coerce
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep).
+            f a -> f b -> f b)
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep).
+            T14578.App f a -> T14578.App f b -> T14578.App f b)
+          (GHC.Base.*>)
+    (GHC.Base.<*)
+      = GHC.Prim.coerce
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep).
+            f a -> f b -> f a)
+          @(forall (a :: TYPE GHC.Types.LiftedRep)
+                   (b :: TYPE GHC.Types.LiftedRep).
+            T14578.App f a -> T14578.App f b -> T14578.App f a)
+          (GHC.Base.<*)
+  
+  instance (GHC.Base.Applicative f, GHC.Base.Applicative g,
+            GHC.Base.Semigroup a) =>
+           GHC.Base.Semigroup (T14578.Wat f g a) where
+    (GHC.Base.<>)
+      = GHC.Prim.coerce
+          @(T14578.App (Data.Functor.Compose.Compose f g) a
+            -> T14578.App (Data.Functor.Compose.Compose f g) a
+               -> T14578.App (Data.Functor.Compose.Compose f g) a)
+          @(T14578.Wat f g a -> T14578.Wat f g a -> T14578.Wat f g a)
+          (GHC.Base.<>)
+    GHC.Base.sconcat
+      = GHC.Prim.coerce
+          @(GHC.Base.NonEmpty (T14578.App (Data.Functor.Compose.Compose f g) a)
+            -> T14578.App (Data.Functor.Compose.Compose f g) a)
+          @(GHC.Base.NonEmpty (T14578.Wat f g a) -> T14578.Wat f g a)
+          GHC.Base.sconcat
+    GHC.Base.stimes
+      = GHC.Prim.coerce
+          @(forall (b :: TYPE GHC.Types.LiftedRep).
+            GHC.Real.Integral b =>
+            b
+            -> T14578.App (Data.Functor.Compose.Compose f g) a
+               -> T14578.App (Data.Functor.Compose.Compose f g) a)
+          @(forall (b :: TYPE GHC.Types.LiftedRep).
+            GHC.Real.Integral b => b -> T14578.Wat f g a -> T14578.Wat f g a)
+          GHC.Base.stimes
+  
+
+Derived type family instances:
+
+
+
+==================== Filling in method body ====================
+GHC.Base.Semigroup [T14578.App f[ssk:2] a[ssk:2]]
+  GHC.Base.sconcat = GHC.Base.$dmsconcat
+                       @(T14578.App f[ssk:2] a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Base.Semigroup [T14578.App f[ssk:2] a[ssk:2]]
+  GHC.Base.stimes = GHC.Base.$dmstimes
+                      @(T14578.App f[ssk:2] a[ssk:2])
+
+

testsuite/tests/deriving/should_compile/all.T

@@ -98,3 +98,4 @@ test('T14045b', normal, compile, [''])
 test('T14094', normal, compile, [''])
 test('T14339', normal, compile, [''])
 test('T14331', normal, compile, [''])
+test('T14578', normal, compile, ['-ddump-deriv -dsuppress-uniques'])