Fix panics of PartialTypeSignatures combined with extensions
authorThomas Winant <thomas.winant@cs.kuleuven.be>
Mon, 12 Jan 2015 11:29:50 +0000 (05:29 -0600)
committerAustin Seipp <austin@well-typed.com>
Tue, 13 Jan 2015 16:10:38 +0000 (10:10 -0600)
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

compiler/parser/Parser.y
testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/all.T

index 4958e0c..36b27cf 100644 (file)
@@ -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 (file)
index 0000000..5e85e59
--- /dev/null
@@ -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 (file)
index 0000000..38cb4ce
--- /dev/null
@@ -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 (file)
index 0000000..cd36449
--- /dev/null
@@ -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 (file)
index 0000000..e8148f1
--- /dev/null
@@ -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 (file)
index 0000000..6348921
--- /dev/null
@@ -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 (file)
index 0000000..921d7a0
--- /dev/null
@@ -0,0 +1,4 @@
+
+WildcardInStandaloneDeriving.hs:4:19:
+    Wildcard not allowed
+    in the stand-alone deriving instance: ‘_’
index c275e93..7e56d15 100644 (file)
@@ -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, [''])