Prevent users from defining instances for abstract classes.
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Wed, 1 Mar 2017 08:11:43 +0000 (00:11 -0800)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Thu, 2 Mar 2017 23:59:02 +0000 (15:59 -0800)
Summary:
Fixes #13068.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
Test Plan: validate

Reviewers: simonpj, austin, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D3254

compiler/typecheck/TcInstDcls.hs
compiler/types/Class.hs
testsuite/tests/typecheck/should_fail/T13068.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T13068.hs-boot [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T13068.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T13068a.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T13068m.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/all.T

index 95d33dd..76d963d 100644 (file)
@@ -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
index cd9f8de..ecc7e2e 100644 (file)
@@ -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 (file)
index 0000000..e0b8f57
--- /dev/null
@@ -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 (file)
index 0000000..b23b752
--- /dev/null
@@ -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 (file)
index 0000000..c161209
--- /dev/null
@@ -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 (file)
index 0000000..fb7bda6
--- /dev/null
@@ -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 (file)
index 0000000..3effc0a
--- /dev/null
@@ -0,0 +1,2 @@
+import T13068
+main = print (f :: Int)
index 86334ba..2d1d12b 100644 (file)
@@ -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'])