Commit b1e569a5 authored by Ryan Scott's avatar Ryan Scott Committed by Marge Bot

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.
parent 77974922
......@@ -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]
......
......@@ -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)
......
......@@ -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
{-# 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) |])
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)
......@@ -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'])
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