[commit: ghc] master: Prevent users from defining instances for abstract classes. (bba004f)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/bba004f2a0642d3bb8c8876543aaa1a48a2f9a43/ghc

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

commit bba004f2a0642d3bb8c8876543aaa1a48a2f9a43
Author: Edward Z. Yang <ezyang at cs.stanford.edu>
Date:   Wed Mar 1 00:11:43 2017 -0800

    Prevent users from defining instances for abstract classes.
    
    Summary:
    Fixes #13068.
    
    Signed-off-by: Edward Z. Yang <ezyang at cs.stanford.edu>
    
    Test Plan: validate
    
    Reviewers: simonpj, austin, bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D3254


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

bba004f2a0642d3bb8c8876543aaa1a48a2f9a43
 compiler/typecheck/TcInstDcls.hs                     | 8 ++++++++
 compiler/types/Class.hs                              | 5 +++++
 testsuite/tests/typecheck/should_fail/T13068.hs      | 4 ++++
 testsuite/tests/typecheck/should_fail/T13068.hs-boot | 2 ++
 testsuite/tests/typecheck/should_fail/T13068.stderr  | 6 ++++++
 testsuite/tests/typecheck/should_fail/T13068a.hs     | 3 +++
 testsuite/tests/typecheck/should_fail/T13068m.hs     | 2 ++
 testsuite/tests/typecheck/should_fail/all.T          | 1 +
 8 files changed, 31 insertions(+)

diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 95d33dd..76d963d 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -520,6 +520,10 @@ doClsInstErrorChecks inst_info
          -- In hs-boot files there should be no bindings
       ; failIfTc (is_boot && not no_binds) badBootDeclErr
 
+         -- If not in an hs-boot file, abstract classes cannot have
+         -- instances declared
+      ; failIfTc (not is_boot && isAbstractClass clas) abstractClassInstErr
+
          -- Handwritten instances of any rejected
          -- class is always forbidden
          -- #12837
@@ -535,12 +539,16 @@ doClsInstErrorChecks inst_info
     binds    = iBinds inst_info
     no_binds = isEmptyLHsBinds (ib_binds binds) && null (ib_pragmas binds)
     clas_nm  = is_cls_nm ispec
+    clas     = is_cls ispec
 
     gen_inst_err = hang (text ("Generic instances can only be "
                             ++ "derived in Safe Haskell.") $+$
                          text "Replace the following instance:")
                       2 (pprInstanceHdr ispec)
 
+    abstractClassInstErr =
+        text "Cannot define instance for abstract class" <+> quotes (ppr clas_nm)
+
     -- Report an error or a warning for certain class instances.
     -- If we are working on an .hs-boot file, we just report a warning,
     -- and ignore the instance.  We do this, to give users a chance to fix
diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs
index cd9f8de..ecc7e2e 100644
--- a/compiler/types/Class.hs
+++ b/compiler/types/Class.hs
@@ -18,6 +18,7 @@ module Class (
         classKey, className, classATs, classATItems, classTyCon, classMethods,
         classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
         classAllSelIds, classSCSelId, classMinimalDef, classHasFds,
+        isAbstractClass,
         naturallyCoherentClass
     ) where
 
@@ -302,6 +303,10 @@ classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
                          }})
   = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
 
+isAbstractClass :: Class -> Bool
+isAbstractClass Class{ classBody = AbstractClass } = True
+isAbstractClass _ = False
+
 -- | If a class is "naturally coherent", then we needn't worry at all, in any
 -- way, about overlapping/incoherent instances. Just solve the thing!
 naturallyCoherentClass :: Class -> Bool
diff --git a/testsuite/tests/typecheck/should_fail/T13068.hs b/testsuite/tests/typecheck/should_fail/T13068.hs
new file mode 100644
index 0000000..e0b8f57
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13068.hs
@@ -0,0 +1,4 @@
+module T13068 where
+import T13068a
+class C a where
+    f :: a
diff --git a/testsuite/tests/typecheck/should_fail/T13068.hs-boot b/testsuite/tests/typecheck/should_fail/T13068.hs-boot
new file mode 100644
index 0000000..b23b752
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13068.hs-boot
@@ -0,0 +1,2 @@
+module T13068 where
+class C a
diff --git a/testsuite/tests/typecheck/should_fail/T13068.stderr b/testsuite/tests/typecheck/should_fail/T13068.stderr
new file mode 100644
index 0000000..c161209
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13068.stderr
@@ -0,0 +1,6 @@
+[1 of 4] Compiling T13068[boot]     ( T13068.hs-boot, T13068.o-boot )
+[2 of 4] Compiling T13068a          ( T13068a.hs, T13068a.o )
+
+T13068a.hs:3:1: error:
+    • Cannot define instance for abstract class ‘C’
+    • In the instance declaration for ‘C Int’
diff --git a/testsuite/tests/typecheck/should_fail/T13068a.hs b/testsuite/tests/typecheck/should_fail/T13068a.hs
new file mode 100644
index 0000000..fb7bda6
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13068a.hs
@@ -0,0 +1,3 @@
+module T13068a where
+import {-# SOURCE #-} T13068
+instance C Int where
diff --git a/testsuite/tests/typecheck/should_fail/T13068m.hs b/testsuite/tests/typecheck/should_fail/T13068m.hs
new file mode 100644
index 0000000..3effc0a
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13068m.hs
@@ -0,0 +1,2 @@
+import T13068
+main = print (f :: Int)
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 86334ba..2d1d12b 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -424,6 +424,7 @@ test('T12918b', normal, compile_fail, [''])
 test('T12921', normal, compile_fail, [''])
 test('T12973', normal, compile_fail, [''])
 test('StrictBinds', normal, compile_fail, [''])
+test('T13068', [extra_files(['T13068.hs', 'T13068a.hs', 'T13068.hs-boot', 'T13068m.hs'])], multimod_compile_fail, ['T13068m', ''])
 test('T13105', normal, compile_fail, [''])
 test('LevPolyBounded', normal, compile_fail, [''])
 test('T13292', normal, multimod_compile, ['T13292', '-v0 -fdefer-type-errors'])