Fix #14916 with an additional validity check in deriveTyData
authorRyan Scott <ryan.gl.scott@gmail.com>
Sun, 25 Mar 2018 19:34:05 +0000 (15:34 -0400)
committerBen Gamari <ben@smart-cactus.org>
Sun, 25 Mar 2018 19:34:21 +0000 (15:34 -0400)
Manually-written instances and standalone-derived instances
have the benefit of having the `checkValidInstHead` function run over
them, which catches manual instances of built-in types like `(~)` and
`Coercible`. However, instances generated from `deriving` clauses
weren't being passed through `checkValidInstHead`, leading to
confusing results as in #14916.

`checkValidInstHead` also has additional validity checks for language
extensions like `FlexibleInstances` and `MultiParamTypeClasses`. Up
until now, GHC has never required these language extensions for
`deriving` clause, so to avoid unnecessary breakage, I opted to
suppress these language extension checks for `deriving` clauses, just
like we currently suppress them for `SPECIALIZE instance` pragmas.

Test Plan: make test TEST=T14916

Reviewers: goldfire, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14916

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

compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcType.hs
compiler/typecheck/TcValidity.hs
testsuite/tests/deriving/should_fail/T14916.hs [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T14916.stderr [new file with mode: 0644]
testsuite/tests/deriving/should_fail/all.T

index 152292d..0e7268b 100644 (file)
@@ -26,6 +26,7 @@ import TcValidity( allDistinctTyVars )
 import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )
 import TcEnv
 import TcGenDeriv                       -- Deriv stuff
+import TcValidity
 import InstEnv
 import Inst
 import FamInstEnv
@@ -782,8 +783,9 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
 
         ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
 
+        ; let final_tc_app = mkTyConApp tc final_tc_args
         ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop)     -- (a, b, c)
-                  (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
+                  (derivingEtaErr cls final_cls_tys final_tc_app)
                 -- Check that
                 --  (a) The args to drop are all type variables; eg reject:
                 --              data instance T a Int = .... deriving( Monad )
@@ -799,6 +801,11 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
                 -- expand any type synonyms.
                 -- See Note [Eta-reducing type synonyms]
 
+        ; checkValidInstHead DerivClauseCtxt cls $
+                             final_cls_tys ++ [final_tc_app]
+                -- Check that we aren't deriving an instance of a magical
+                -- type like (~) or Coercible (#14916).
+
         ; spec <- mkEqnHelp Nothing tkvs
                             cls final_cls_tys tc final_tc_args
                             (InferContext Nothing) deriv_strat
index de37aa8..d378fcb 100644 (file)
@@ -617,6 +617,7 @@ data UserTypeCtxt
                         --      f :: <S> => a -> a
   | DataTyCtxt Name     -- The "stupid theta" part of a data decl
                         --      data <S> => T a = MkT a
+  | DerivClauseCtxt     -- A 'deriving' clause
 
 {-
 -- Notes re TySynCtxt
@@ -652,6 +653,7 @@ pprUserTypeCtxt (ClassSCCtxt c)   = text "the super-classes of class" <+> quotes
 pprUserTypeCtxt SigmaCtxt         = text "the context of a polymorphic type"
 pprUserTypeCtxt (DataTyCtxt tc)   = text "the context of the data type declaration for" <+> quotes (ppr tc)
 pprUserTypeCtxt (PatSynCtxt n)    = text "the signature for pattern synonym" <+> quotes (ppr n)
+pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause"
 
 isSigMaybe :: UserTypeCtxt -> Maybe Name
 isSigMaybe (FunSigCtxt n _) = Just n
index 3bf9f52..d2d32c6 100644 (file)
@@ -9,7 +9,7 @@ module TcValidity (
   Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
   ContextKind(..), expectedKindInCtxt,
   checkValidTheta, checkValidFamPats,
-  checkValidInstance, validDerivPred,
+  checkValidInstance, checkValidInstHead, validDerivPred,
   checkInstTermination, checkTySynRhs,
   ClsInstInfo, checkValidCoAxiom, checkValidCoAxBranch,
   checkValidTyFamEqn,
@@ -921,6 +921,7 @@ okIPCtxt (InstDeclCtxt {}) = False
 okIPCtxt (SpecInstCtxt {}) = False
 okIPCtxt (RuleSigCtxt {})  = False
 okIPCtxt DefaultDeclCtxt   = False
+okIPCtxt DerivClauseCtxt   = False
 
 {-
 Note [Kind polymorphic type classes]
@@ -1050,9 +1051,9 @@ checkValidInstHead ctxt clas cls_args
              checkHasFieldInst clas cls_args
 
            -- Check language restrictions;
-           -- but not for SPECIALISE instance pragmas
+           -- but not for SPECIALISE instance pragmas or deriving clauses
        ; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
-       ; unless spec_inst_prag $
+       ; unless (spec_inst_prag || deriv_clause) $
          do { checkTc (xopt LangExt.TypeSynonymInstances dflags ||
                        all tcInstHeadTyNotSynonym ty_args)
                  (instTypeErr clas cls_args head_type_synonym_msg)
@@ -1068,6 +1069,7 @@ checkValidInstHead ctxt clas cls_args
        ; mapM_ checkValidTypePat ty_args }
   where
     spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False }
+    deriv_clause   = case ctxt of { DerivClauseCtxt -> True; _ -> False }
 
     head_type_synonym_msg = parens (
                 text "All instance types must be of the form (T t1 ... tn)" $$
diff --git a/testsuite/tests/deriving/should_fail/T14916.hs b/testsuite/tests/deriving/should_fail/T14916.hs
new file mode 100644 (file)
index 0000000..19b323f
--- /dev/null
@@ -0,0 +1,8 @@
+{-# LANGUAGE DeriveAnyClass #-}
+module T14916 where
+
+import Data.Coerce
+import Data.Typeable
+
+data A = MkA deriving ((~) A)
+data B = MkB deriving (Coercible B)
diff --git a/testsuite/tests/deriving/should_fail/T14916.stderr b/testsuite/tests/deriving/should_fail/T14916.stderr
new file mode 100644 (file)
index 0000000..2a6cca1
--- /dev/null
@@ -0,0 +1,10 @@
+
+T14916.hs:7:24: error:
+    • Illegal instance declaration for ‘A ~ A’
+        Manual instances of this class are not permitted.
+    • In the data declaration for ‘A’
+
+T14916.hs:8:24: error:
+    • Illegal instance declaration for ‘Coercible B B’
+        Manual instances of this class are not permitted.
+    • In the data declaration for ‘B’
index acd3486..8dc5b78 100644 (file)
@@ -71,3 +71,4 @@ test('T14365', [extra_files(['T14365B.hs','T14365B.hs-boot'])],
                multimod_compile_fail, ['T14365A',''])
 test('T14728a', normal, compile_fail, [''])
 test('T14728b', normal, compile_fail, [''])
+test('T14916', normal, compile_fail, [''])