[commit: ghc] master: Fix #14916 with an additional validity check in deriveTyData (20f14b4)

git at git.haskell.org git at git.haskell.org
Mon Mar 26 00:12:33 UTC 2018


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

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

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

commit 20f14b4fd4eaf2c3ab375b8fc6d40ee9e6db94fd
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Sun Mar 25 15:34:05 2018 -0400

    Fix #14916 with an additional validity check in deriveTyData
    
    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


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

20f14b4fd4eaf2c3ab375b8fc6d40ee9e6db94fd
 compiler/typecheck/TcDeriv.hs                      |  9 ++++++++-
 compiler/typecheck/TcType.hs                       |  2 ++
 compiler/typecheck/TcValidity.hs                   |  8 +++++---
 testsuite/tests/deriving/should_fail/T14916.hs     |  8 ++++++++
 testsuite/tests/deriving/should_fail/T14916.stderr | 10 ++++++++++
 testsuite/tests/deriving/should_fail/all.T         |  1 +
 6 files changed, 34 insertions(+), 4 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 152292d..0e7268b 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -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
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index de37aa8..d378fcb 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -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
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 3bf9f52..d2d32c6 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -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
index 0000000..19b323f
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T14916.hs
@@ -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
index 0000000..2a6cca1
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T14916.stderr
@@ -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’
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index acd3486..8dc5b78 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -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, [''])



More information about the ghc-commits mailing list