[commit: ghc] master: Fix panics of PartialTypeSignatures combined with extensions (c9532f8)
git at git.haskell.org
git at git.haskell.org
Tue Jan 13 16:09:59 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/c9532f810a82c6395bc08fb77f2a895a50da86b5/ghc
>---------------------------------------------------------------
commit c9532f810a82c6395bc08fb77f2a895a50da86b5
Author: Thomas Winant <thomas.winant at cs.kuleuven.be>
Date: Mon Jan 12 05:29:50 2015 -0600
Fix panics of PartialTypeSignatures combined with extensions
Summary:
Disallow wildcards in stand-alone deriving instances
(StandaloneDeriving), default signatures (DefaultSignatures) and
instances signatures (InstanceSigs).
Test Plan: validate
Reviewers: austin
Reviewed By: austin
Subscribers: carter, thomie, monoidal
Differential Revision: https://phabricator.haskell.org/D595
GHC Trac Issues: #9922
>---------------------------------------------------------------
c9532f810a82c6395bc08fb77f2a895a50da86b5
compiler/parser/Parser.y | 15 +++++++++++++--
.../should_fail/WildcardInDefaultSignature.hs | 4 ++++
.../should_fail/WildcardInDefaultSignature.stderr | 4 ++++
.../partial-sigs/should_fail/WildcardInInstanceSig.hs | 4 ++++
.../partial-sigs/should_fail/WildcardInInstanceSig.stderr | 4 ++++
.../should_fail/WildcardInStandaloneDeriving.hs | 4 ++++
.../should_fail/WildcardInStandaloneDeriving.stderr | 4 ++++
testsuite/tests/partial-sigs/should_fail/all.T | 3 +++
8 files changed, 40 insertions(+), 2 deletions(-)
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 4958e0c..36b27cf 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -798,6 +798,10 @@ inst_decl :: { LInstDecl RdrName }
, cid_datafam_insts = adts }
; let err = text "In instance head:" <+> ppr $3
; checkNoPartialType err $3
+ ; sequence_ [ checkNoPartialType err ty
+ | sig@(L _ (TypeSig _ ty _ )) <- sigs
+ , let err = text "in instance signature" <> colon
+ <+> quotes (ppr sig) ]
; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }))
(mj AnnInstance $1 : (fst $ unLoc $4)) } }
@@ -972,8 +976,12 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
: 'deriving' 'instance' overlap_pragma inst_type
- {% ams (sLL $1 $> (DerivDecl $4 $3))
- [mj AnnDeriving $1,mj AnnInstance $2] }
+ {% do {
+ let err = text "in the stand-alone deriving instance"
+ <> colon <+> quotes (ppr $4)
+ ; checkNoPartialType err $4
+ ; ams (sLL $1 $> (DerivDecl $4 $3))
+ [mj AnnDeriving $1,mj AnnInstance $2] }}
-----------------------------------------------------------------------------
-- Role annotations
@@ -1070,6 +1078,9 @@ decl_cls : at_decl_cls { sLL $1 $> (unitOL $1) }
-- A 'default' signature used with the generic-programming extension
| 'default' infixexp '::' sigtypedoc
{% do { (TypeSig l ty _) <- checkValSig $2 $4
+ ; let err = text "in default signature" <> colon <+>
+ quotes (ppr ty)
+ ; checkNoPartialType err ty
; ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (GenericSig l ty)))
[mj AnnDefault $1,mj AnnDcolon $3] } }
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.hs
new file mode 100644
index 0000000..5e85e59
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE DefaultSignatures #-}
+module WildcardInDefaultSignature where
+
+class C a where default f :: _
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.stderr
new file mode 100644
index 0000000..38cb4ce
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.stderr
@@ -0,0 +1,4 @@
+
+WildcardInDefaultSignature.hs:4:30:
+ Wildcard not allowed
+ in default signature: ‘_’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.hs
new file mode 100644
index 0000000..cd36449
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE InstanceSigs #-}
+module WildcardInInstanceSig where
+
+instance Num Bool where negate :: _
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.stderr
new file mode 100644
index 0000000..e8148f1
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.stderr
@@ -0,0 +1,4 @@
+
+WildcardInInstanceSig.hs:4:35:
+ Wildcard not allowed
+ in instance signature: ‘negate :: _’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.hs
new file mode 100644
index 0000000..6348921
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE StandaloneDeriving #-}
+module WildcardInStandaloneDeriving where
+
+deriving instance _
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.stderr
new file mode 100644
index 0000000..921d7a0
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.stderr
@@ -0,0 +1,4 @@
+
+WildcardInStandaloneDeriving.hs:4:19:
+ Wildcard not allowed
+ in the stand-alone deriving instance: ‘_’
diff --git a/testsuite/tests/partial-sigs/should_fail/all.T b/testsuite/tests/partial-sigs/should_fail/all.T
index c275e93..7e56d15 100644
--- a/testsuite/tests/partial-sigs/should_fail/all.T
+++ b/testsuite/tests/partial-sigs/should_fail/all.T
@@ -26,15 +26,18 @@ test('WildcardInADT3', normal, compile_fail, [''])
test('WildcardInADTContext1', normal, compile_fail, [''])
test('WildcardInADTContext2', normal, compile_fail, [''])
test('WildcardInDefault', normal, compile_fail, [''])
+test('WildcardInDefaultSignature', normal, compile_fail, [''])
test('WildcardInDeriving', normal, compile_fail, [''])
test('WildcardInForeignExport', normal, compile_fail, [''])
test('WildcardInForeignImport', normal, compile_fail, [''])
test('WildcardInGADT1', normal, compile_fail, [''])
test('WildcardInGADT2', normal, compile_fail, [''])
test('WildcardInInstanceHead', normal, compile_fail, [''])
+test('WildcardInInstanceSig', normal, compile_fail, [''])
test('WildcardsInPatternAndExprSig', normal, compile_fail, [''])
test('WildcardInPatSynSig', normal, compile_fail, [''])
test('WildcardInNewtype', normal, compile_fail, [''])
+test('WildcardInStandaloneDeriving', normal, compile_fail, [''])
test('WildcardInstantiations', normal, compile_fail, [''])
test('WildcardInTypeBrackets', [req_interp, only_compiler_types(['ghc'])], compile_fail, [''])
test('WildcardInTypeFamilyInstanceLHS', normal, compile_fail, [''])
More information about the ghc-commits
mailing list