From 46ff73df2bd12f270f447ab070d6a9b20cbab6fa Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Mon, 14 Jan 2019 21:45:17 -0500 Subject: 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) --- compiler/hsSyn/Convert.hs | 67 +++++++++++++++++++------------------ compiler/hsSyn/HsUtils.hs | 8 +---- testsuite/tests/th/T12045TH1.stderr | 4 +-- testsuite/tests/th/T16183.hs | 11 ++++++ testsuite/tests/th/T16183.stderr | 12 +++++++ testsuite/tests/th/all.T | 1 + 6 files changed, 62 insertions(+), 41 deletions(-) create mode 100644 testsuite/tests/th/T16183.hs create mode 100644 testsuite/tests/th/T16183.stderr 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) diff --git a/testsuite/tests/th/T12045TH1.stderr b/testsuite/tests/th/T12045TH1.stderr index fb4bf1a302..aede24c7a0 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 0000000000..6b1280f344 --- /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 0000000000..812fd58ac9 --- /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 4062cf2af0..b93673c138 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']) -- cgit v1.2.1