Fix #15331 with careful blasts of parenthesizeHsType
authorRyan Scott <ryan.gl.scott@gmail.com>
Thu, 5 Jul 2018 12:51:43 +0000 (08:51 -0400)
committerRyan Scott <ryan.gl.scott@gmail.com>
Thu, 5 Jul 2018 13:51:15 +0000 (09:51 -0400)
Summary:
Another `-ddump-splices` bug that can be solved with more
judicious use of parentheses.

Test Plan: make test TEST=T15331

Reviewers: goldfire, bgamari, alanz, tdammers

Reviewed By: tdammers

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #15331

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

compiler/hsSyn/Convert.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/typecheck/TcGenDeriv.hs
testsuite/tests/th/T15331.hs [new file with mode: 0644]
testsuite/tests/th/T15331.stderr [new file with mode: 0644]
testsuite/tests/th/all.T

index aa651da..c64cb7c 100644 (file)
@@ -818,7 +818,8 @@ cvtl e = wrapL (cvt e)
     cvt (AppTypeE e t) = do { e' <- cvtl e
                             ; t' <- cvtType t
                             ; tp <- wrap_apps t'
-                            ; return $ HsAppType (mkHsWildCardBndrs tp) e' }
+                            ; let tp' = parenthesizeHsType appPrec tp
+                            ; return $ HsAppType (mkHsWildCardBndrs tp') e' }
     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
index 6d14d7d..cbaa9fb 100644 (file)
@@ -1425,8 +1425,8 @@ ppr_tylit (HsStrTy _ s) = text (show s)
 hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool
 hsTypeNeedsParens p = go
   where
-    go (HsForAllTy{})        = False
-    go (HsQualTy{})          = False
+    go (HsForAllTy{})        = p >= funPrec
+    go (HsQualTy{})          = p >= funPrec
     go (HsBangTy{})          = p > topPrec
     go (HsRecTy{})           = False
     go (HsTyVar{})           = False
index ca0cb92..a759f1a 100644 (file)
@@ -178,7 +178,10 @@ mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2)
 
 mkHsAppType :: (XAppTypeE (GhcPass id) ~ LHsWcType GhcRn)
             => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id)
-mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType t e)
+mkHsAppType e t = addCLoc e t_body (HsAppType paren_wct e)
+  where
+    t_body    = hswc_body t
+    paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
 
 mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
 mkHsAppTypes = foldl mkHsAppType
index e1665e2..beaad98 100644 (file)
@@ -1810,7 +1810,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
 nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
 nlHsAppType e s = noLoc (HsAppType hs_ty e)
   where
-    hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s)
+    hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)
 
 nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
 nlExprWithTySig e s = noLoc $ ExprWithTySig hs_ty
diff --git a/testsuite/tests/th/T15331.hs b/testsuite/tests/th/T15331.hs
new file mode 100644 (file)
index 0000000..0b0a076
--- /dev/null
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+module T15331 where
+
+import Data.Proxy
+
+$([d| f :: Proxy (Int -> Int)
+      f = Proxy @(Int -> Int)
+    |])
diff --git a/testsuite/tests/th/T15331.stderr b/testsuite/tests/th/T15331.stderr
new file mode 100644 (file)
index 0000000..99bfdfd
--- /dev/null
@@ -0,0 +1,6 @@
+T15331.hs:(7,3)-(9,6): Splicing declarations
+    [d| f :: Proxy (Int -> Int)
+        f = Proxy @(Int -> Int) |]
+  ======>
+    f :: Proxy (Int -> Int)
+    f = Proxy @(Int -> Int)
index d8b8c94..84aa84b 100644 (file)
@@ -417,3 +417,4 @@ test('T14885c', normal, compile, [''])
 test('T15243', normal, compile, ['-dsuppress-uniques'])
 test('T15321', normal, compile_fail, [''])
 test('T15324', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T15331', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])