[commit: ghc] ghc-8.2: Parenthesize type/data families correctly for -ddump-splices (a2de03a)
git at git.haskell.org
git at git.haskell.org
Tue Apr 11 02:21:50 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.2
Link : http://ghc.haskell.org/trac/ghc/changeset/a2de03a8d5448f085074af4d78db998386bd8a5a/ghc
>---------------------------------------------------------------
commit a2de03a8d5448f085074af4d78db998386bd8a5a
Author: Alan Zimmerman <alan.zimm at gmail.com>
Date: Sun Apr 9 21:06:06 2017 +0200
Parenthesize type/data families correctly for -ddump-splices
Fix a regression in the pretty-printed code for -ddump-splices, which regressed
since 8.0.
Closes trac issue #13550
(cherry picked from commit 5282bb1772ba3f1dc999a177965e543822f342a0)
>---------------------------------------------------------------
a2de03a8d5448f085074af4d78db998386bd8a5a
compiler/hsSyn/Convert.hs | 9 +++--
testsuite/tests/printer/Makefile | 4 ++
testsuite/tests/printer/T13550.hs | 69 +++++++++++++++++++++++++++++++++++
testsuite/tests/printer/T13550.stdout | 22 +++++++++++
testsuite/tests/printer/all.T | 1 +
5 files changed, 101 insertions(+), 4 deletions(-)
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 921448e..8d90344 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -37,7 +37,7 @@ import Outputable
import MonadUtils ( foldrM )
import qualified Data.ByteString as BS
-import Control.Monad( unless, liftM, ap )
+import Control.Monad( unless, liftM, ap, (<=<) )
import Data.Maybe( catMaybes, fromMaybe, isNothing )
import Language.Haskell.TH as TH hiding (sigP)
@@ -386,7 +386,7 @@ cvtDec (TH.PatSynSigD nm ty)
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
- = do { lhs' <- mapM cvtType lhs
+ = do { lhs' <- mapM (wrap_apps <=< cvtType) lhs
; rhs' <- cvtType rhs
; returnL $ TyFamEqn { tfe_tycon = tc
, tfe_pats = mkHsImplicitBndrs lhs'
@@ -433,7 +433,7 @@ cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
cvt_tyinst_hdr cxt tc tys
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
- ; tys' <- mapM cvtType tys
+ ; tys' <- mapM (wrap_apps <=< cvtType) tys
; return (cxt', tc', mkHsImplicitBndrs tys') }
----------------
@@ -552,7 +552,8 @@ cvtSrcStrictness SourceStrict = SrcStrict
cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType RdrName)
cvt_arg (Bang su ss, ty)
- = do { ty' <- cvtType ty
+ = do { ty'' <- cvtType ty
+ ; ty' <- wrap_apps ty''
; let su' = cvtSrcUnpackedness su
; let ss' = cvtSrcStrictness ss
; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' }
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 9f0eb23..9cb968f 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -205,3 +205,7 @@ T13199:
.PHONY: T13050p
T13050p:
$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13050p.hs
+
+.PHONY: T13550
+T13550:
+ $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13550.hs
diff --git a/testsuite/tests/printer/T13550.hs b/testsuite/tests/printer/T13550.hs
new file mode 100644
index 0000000..90a70aa
--- /dev/null
+++ b/testsuite/tests/printer/T13550.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
+module Bug where
+
+$([d| type family Foo a b
+ type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
+
+ data family Bar a b
+ data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b)
+ |])
+
+{-
+ type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
+
+becomes
+
+[TySynInstD Bug.Foo
+ (TySynEqn
+ [AppT
+ (ConT GHC.Base.Maybe)
+ (VarT a_6989586621679027317)
+ ,VarT b_6989586621679027318]
+ (AppT
+ (AppT
+ (ConT Data.Either.Either)
+ (AppT
+ (ConT GHC.Base.Maybe)
+ (VarT a_6989586621679027317)
+ )
+ )
+ (AppT (ConT GHC.Base.Maybe) (VarT b_6989586621679027318))
+ )
+ )
+]
+
+ data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b)
+
+becomes
+
+[DataInstD [] Bug.Bar
+ [AppT
+ (ConT GHC.Base.Maybe)
+ (VarT a_6989586621679027707)
+ ,VarT b_6989586621679027708
+ ]
+ Nothing
+ [NormalC
+ BarMaybe_6989586621679027706
+ [(Bang
+ NoSourceUnpackedness
+ NoSourceStrictness
+ ,AppT
+ (ConT GHC.Base.Maybe)
+ (VarT a_6989586621679027707)
+ )
+ ,(Bang
+ NoSourceUnpackedness
+ NoSourceStrictness
+ ,AppT
+ (ConT GHC.Base.Maybe)
+ (VarT b_6989586621679027708)
+ )
+ ]
+ ]
+ []]
+
+
+-}
diff --git a/testsuite/tests/printer/T13550.stdout b/testsuite/tests/printer/T13550.stdout
new file mode 100644
index 0000000..ff02835
--- /dev/null
+++ b/testsuite/tests/printer/T13550.stdout
@@ -0,0 +1,22 @@
+T13550.hs:(6,3)-(11,6): Splicing declarations
+ [d| type family Foo a b
+ data family Bar a b
+
+ type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
+ data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) |]
+ ======>
+ type family Foo a b
+ type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
+ data family Bar a b
+ data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b)
+T13550.ppr.hs:(5,3)-(8,69): Splicing declarations
+ [d| type family Foo a b
+ data family Bar a b
+
+ type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
+ data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) |]
+ ======>
+ type family Foo a b
+ type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
+ data family Bar a b
+ data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b)
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index e5fd00f..c939e49 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -48,3 +48,4 @@ test('Ppr047', expect_fail, run_command, ['$MAKE -s --no-print-directory ppr047'
test('Ppr048', ignore_stderr, run_command, ['$MAKE -s --no-print-directory ppr048'])
test('T13199', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13199'])
test('T13050p', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13050p'])
+test('T13550', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13550'])
More information about the ghc-commits
mailing list