[commit: ghc] ghc-7.10: Fix panics of PartialTypeSignatures combined with extensions (95368a7)

git at git.haskell.org git at git.haskell.org
Mon Jan 19 13:58:20 UTC 2015


Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/95368a70b16ee384ccb6cd6cf62d4efb3d9b9c8f/ghc

>---------------------------------------------------------------

commit 95368a70b16ee384ccb6cd6cf62d4efb3d9b9c8f
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
    
    (cherry picked from commit c9532f810a82c6395bc08fb77f2a895a50da86b5)


>---------------------------------------------------------------

95368a70b16ee384ccb6cd6cf62d4efb3d9b9c8f
 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 7739d97..817a96e 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