[commit: ghc] master: Only pretty-print binders in closed type families with -fprint-explicit-foralls (da792e4)
git at git.haskell.org
git at git.haskell.org
Wed Apr 26 01:11:56 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/da792e47981f65b2dba4fc76ce51dc3fb9c4c02d/ghc
>---------------------------------------------------------------
commit da792e47981f65b2dba4fc76ce51dc3fb9c4c02d
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date: Tue Apr 25 18:38:34 2017 -0400
Only pretty-print binders in closed type families with -fprint-explicit-foralls
Previously, we were unconditionally pretty-printing all type variable
binders when pretty-printing closed type families (e.g., in the output
of `:info` in GHCi). This threw me for a loop, so let's guard this behind
the `-fprint-explicit-foralls` flag.
Test Plan: make test TEST=T13420
Reviewers: goldfire, austin, bgamari
Reviewed By: bgamari
Subscribers: rwbarton, thomie
GHC Trac Issues: #13420
Differential Revision: https://phabricator.haskell.org/D3497
>---------------------------------------------------------------
da792e47981f65b2dba4fc76ce51dc3fb9c4c02d
compiler/iface/IfaceSyn.hs | 6 +++++-
testsuite/tests/backpack/should_fail/bkpfail42.stderr | 4 ++--
testsuite/tests/ghci/scripts/T13420.hs | 7 +++++++
testsuite/tests/ghci/scripts/T13420.script | 2 ++
testsuite/tests/ghci/scripts/T13420.stdout | 6 ++++++
testsuite/tests/ghci/scripts/T7939.stdout | 8 ++++----
testsuite/tests/ghci/scripts/all.T | 1 +
.../should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr | 2 +-
8 files changed, 28 insertions(+), 8 deletions(-)
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 5db8c99..047ed25 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -67,6 +67,7 @@ import TyCon ( Role (..), Injectivity(..) )
import Util( filterOut, filterByList )
import DataCon (SrcStrictness(..), SrcUnpackedness(..))
import Lexeme (isLexSym)
+import DynFlags
import Control.Monad
import System.IO.Unsafe
@@ -554,7 +555,10 @@ pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs
$+$
nest 2 maybe_incomps
where
- ppr_binders
+ ppr_binders = sdocWithDynFlags $ \dflags ->
+ ppWhen (gopt Opt_PrintExplicitForalls dflags) ppr_binders'
+
+ ppr_binders'
| null tvs && null cvs = empty
| null cvs
= brackets (pprWithCommas (pprIfaceTvBndr True) tvs)
diff --git a/testsuite/tests/backpack/should_fail/bkpfail42.stderr b/testsuite/tests/backpack/should_fail/bkpfail42.stderr
index 5a9e1aa..467ab71 100644
--- a/testsuite/tests/backpack/should_fail/bkpfail42.stderr
+++ b/testsuite/tests/backpack/should_fail/bkpfail42.stderr
@@ -7,9 +7,9 @@ bkpfail42.bkp:9:9: error:
• Type constructor ‘F’ has conflicting definitions in the module
and its hsig file
Main module: type family F a :: *
- where [a] F a = Int
+ where F a = Int
Hsig file: type family F a :: *
- where [a] F a = Bool
+ where F a = Bool
• while merging the signatures from:
• p[A=<A>]:A
• ...and the local signature for A
diff --git a/testsuite/tests/ghci/scripts/T13420.hs b/testsuite/tests/ghci/scripts/T13420.hs
new file mode 100644
index 0000000..6b84e65
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T13420.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies #-}
+module T13420 where
+
+type family F a where
+ F [Int] = Bool
+ F [a] = Double
+ F (a b) = Char
diff --git a/testsuite/tests/ghci/scripts/T13420.script b/testsuite/tests/ghci/scripts/T13420.script
new file mode 100644
index 0000000..aba31bf
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T13420.script
@@ -0,0 +1,2 @@
+:load T13420
+:i F
diff --git a/testsuite/tests/ghci/scripts/T13420.stdout b/testsuite/tests/ghci/scripts/T13420.stdout
new file mode 100644
index 0000000..e6b81ad
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T13420.stdout
@@ -0,0 +1,6 @@
+type family F a :: *
+ where
+ F [Int] = Bool
+ F [a] = Double
+ F (a b) = Char
+ -- Defined at T13420.hs:4:1
diff --git a/testsuite/tests/ghci/scripts/T7939.stdout b/testsuite/tests/ghci/scripts/T7939.stdout
index 2b2c8b7..db2590c 100644
--- a/testsuite/tests/ghci/scripts/T7939.stdout
+++ b/testsuite/tests/ghci/scripts/T7939.stdout
@@ -15,13 +15,13 @@ type family H (a :: Bool) :: Bool
H :: Bool -> Bool
type family J (a :: [k]) :: Bool
where
- [k] J k '[] = 'False
- [k, (h :: k), (t :: [k])] J k (h : t) = 'True
+ J k '[] = 'False
+ J k (h : t) = 'True
-- Defined at T7939.hs:17:1
J :: [k] -> Bool
type family K (a1 :: [a]) :: Maybe a
where
- [a] K a '[] = 'Nothing
- [a, (h :: a), (t :: [a])] K a (h : t) = 'Just h
+ K a '[] = 'Nothing
+ K a (h : t) = 'Just h
-- Defined at T7939.hs:21:1
K :: [a] -> Maybe a
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 917537b..ae0a528 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -251,6 +251,7 @@ test('T12550', normal, ghci_script, ['T12550.script'])
test('StaticPtr', normal, ghci_script, ['StaticPtr.script'])
test('T13202', normal, ghci_script, ['T13202.script'])
test('T13202a', normal, ghci_script, ['T13202a.script'])
+test('T13420', normal, ghci_script, ['T13420.script'])
test('T13466', normal, ghci_script, ['T13466.script'])
test('GhciCurDir', normal, ghci_script, ['GhciCurDir.script'])
test('T13591', expect_broken(13591), ghci_script, ['T13591.script'])
diff --git a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr
index 4fb8877..9d7618d 100644
--- a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr
@@ -2,7 +2,7 @@ TYPE SIGNATURES
TYPE CONSTRUCTORS
type family F a :: *
where
- [_t] F _t = Int
+ F _t = Int
axiom NamedWildcardInTypeFamilyInstanceLHS.D:R:F
COERCION AXIOMS
axiom NamedWildcardInTypeFamilyInstanceLHS.D:R:F ::
More information about the ghc-commits
mailing list