Commit e32f5827 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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)
parent 273131df
......@@ -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
......@@ -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
......
{-# 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
==================== 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])
......@@ -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'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment