Fix #10684 by processing deriving clauses with finer grain
authorRyan Scott <ryan.gl.scott@gmail.com>
Tue, 25 Jul 2017 20:14:27 +0000 (16:14 -0400)
committerRyan Scott <ryan.gl.scott@gmail.com>
Tue, 25 Jul 2017 20:14:27 +0000 (16:14 -0400)
Summary:
Previously, one could experience error cascades with deriving clauses
when one class in a set of many failed to derive, causing the other derived
classes to be skipped entirely and resulting in other errors down the line.
The solution is to process each class in a data type's set of deriving clauses
individually, and engineer it so that failure to derive an individual class
within that set doesn't cancel out the others.

Test Plan: make test TEST="T10684 T12801"

Reviewers: austin, bgamari, simonpj

Reviewed By: simonpj

Subscribers: simonpj, rwbarton, thomie

GHC Trac Issues: #10684, #12801

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

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

index 9e92f18..056bc9b 100644 (file)
@@ -496,9 +496,21 @@ makeDerivSpecs :: Bool
                -> [LDerivDecl GhcRn]
                -> TcM [EarlyDerivSpec]
 makeDerivSpecs is_boot deriv_infos deriv_decls
-  = do  { eqns1 <- concatMapM (recoverM (return []) . deriveDerivInfo)  deriv_infos
-        ; eqns2 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls
-        ; let eqns = eqns1 ++ eqns2
+  = do  { -- We carefully set up uses of recoverM to minimize error message
+          -- cascades. See Note [Flattening deriving clauses].
+        ; eqns1 <- sequenceA
+                     [ recoverM (pure Nothing)
+                                (deriveClause rep_tc (fmap unLoc dcs)
+                                                      pred err_ctxt)
+                     | DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses
+                                 , di_ctxt = err_ctxt } <- deriv_infos
+                     , L _ (HsDerivingClause { deriv_clause_strategy = dcs
+                                             , deriv_clause_tys = L _ preds })
+                         <- clauses
+                     , pred <- preds
+                     ]
+        ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
+        ; let eqns = catMaybes (eqns1 ++ eqns2)
 
         ; if is_boot then   -- No 'deriving' at all in hs-boot files
               do { unless (null eqns) (add_deriv_err (head eqns))
@@ -510,13 +522,69 @@ makeDerivSpecs is_boot deriv_infos deriv_decls
          addErr (hang (text "Deriving not permitted in hs-boot file")
                     2 (text "Use an instance declaration instead"))
 
+{-
+Note [Flattening deriving clauses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider what happens if you run this program (from Trac #10684) without
+DeriveGeneric enabled:
+
+    data A = A deriving (Show, Generic)
+    data B = B A deriving (Show)
+
+Naturally, you'd expect GHC to give an error to the effect of:
+
+    Can't make a derived instance of `Generic A':
+      You need -XDeriveGeneric to derive an instance for this class
+
+And *only* that error, since the other two derived Show instances appear to be
+independent of this derived Generic instance. Yet GHC also used to give this
+additional error on the program above:
+
+    No instance for (Show A)
+      arising from the 'deriving' clause of a data type declaration
+    When deriving the instance for (Show B)
+
+This was happening because when GHC encountered any error within a single
+data type's set of deriving clauses, it would call recoverM and move on
+to the next data type's deriving clauses. One unfortunate consequence of
+this design is that if A's derived Generic instance failed, so its derived
+Show instance would be skipped entirely, leading to the "No instance for
+(Show A)" error cascade.
+
+The solution to this problem is to "flatten" the set of classes that are
+derived for a particular data type via deriving clauses. That is, if
+you have:
+
+    newtype C = C D
+      deriving (E, F, G)
+      deriving anyclass (H, I, J)
+      deriving newtype  (K, L, M)
+
+Then instead of processing instances E through M under the scope of a single
+recoverM, we flatten these deriving clauses into the list:
+
+    [ E (Nothing)
+    , F (Nothing)
+    , G (Nothing)
+    , H (Just anyclass)
+    , I (Just anyclass)
+    , J (Just anyclass)
+    , K (Just newtype)
+    , L (Just newtype)
+    , M (Just newtype) ]
+
+And then process each class individually, under its own recoverM scope. That
+way, failure to derive one class doesn't cancel out other classes in the
+same set of clause-derived classes.
+-}
+
 ------------------------------------------------------------------
--- | Process a `deriving` clause
-deriveDerivInfo :: DerivInfo -> TcM [EarlyDerivSpec]
-deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses
-                           , di_ctxt = err_ctxt })
+-- | Process a single class in a `deriving` clause.
+deriveClause :: TyCon -> Maybe DerivStrategy -> LHsSigType GhcRn -> SDoc
+             -> TcM (Maybe EarlyDerivSpec)
+deriveClause rep_tc mb_strat pred err_ctxt
   = addErrCtxt err_ctxt $
-    concatMapM (deriveForClause . unLoc) clauses
+    deriveTyData tvs tc tys mb_strat pred
   where
     tvs = tyConTyVars rep_tc
     (tc, tys) = case tyConFamInstSig_maybe rep_tc of
@@ -527,16 +595,14 @@ deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses
 
                   _ -> (rep_tc, mkTyVarTys tvs)     -- datatype
 
-    deriveForClause :: HsDerivingClause GhcRn -> TcM [EarlyDerivSpec]
-    deriveForClause (HsDerivingClause { deriv_clause_strategy = dcs
-                                      , deriv_clause_tys      = L _ preds })
-      = concatMapM (deriveTyData tvs tc tys (fmap unLoc dcs)) preds
-
 ------------------------------------------------------------------
-deriveStandalone :: LDerivDecl GhcRn -> TcM [EarlyDerivSpec]
--- Standalone deriving declarations
+deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
+-- Process a single standalone deriving declaration
 --  e.g.   deriving instance Show a => Show (T a)
 -- Rather like tcLocalInstDecl
+--
+-- This returns a Maybe because the user might try to derive Typeable, which is
+-- a no-op nowadays.
 deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
   = setSrcSpan loc                   $
     addErrCtxt (standaloneCtxt deriv_ty)  $
@@ -567,7 +633,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
            Just (tc, tc_args)
               | className cls == typeableClassName
               -> do warnUselessTypeable
-                    return []
+                    return Nothing
 
               | isUnboxedTupleTyCon tc
               -> bale_out $ unboxedTyConErr "tuple"
@@ -579,7 +645,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
               -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
                                         tvs cls cls_tys tc tc_args
                                         (Just theta) deriv_strat
-                    ; return [spec] }
+                    ; return $ Just spec }
 
            _  -> -- Complain about functions, primitive types, etc,
                  bale_out $
@@ -598,9 +664,12 @@ deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
                                              --   Can be a data instance, hence [Type] args
              -> Maybe DerivStrategy          -- The optional deriving strategy
              -> LHsSigType GhcRn             -- The deriving predicate
-             -> TcM [EarlyDerivSpec]
+             -> TcM (Maybe EarlyDerivSpec)
 -- The deriving clause of a data or newtype declaration
 -- I.e. not standalone deriving
+--
+-- This returns a Maybe because the user might try to derive Typeable, which is
+-- a no-op nowadays.
 deriveTyData tvs tc tc_args deriv_strat deriv_pred
   = setSrcSpan (getLoc (hsSigType deriv_pred)) $  -- Use loc of the 'deriving' item
     do  { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
@@ -619,7 +688,7 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
         ; let [cls_arg_kind] = cls_arg_kinds
         ; if className cls == typeableClassName
           then do warnUselessTypeable
-                  return []
+                  return Nothing
           else
 
      do {  -- Given data T a b c = ... deriving( C d ),
@@ -691,7 +760,7 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
                             cls final_cls_tys tc final_tc_args
                             Nothing deriv_strat
         ; traceTc "derivTyData" (ppr spec)
-        ; return [spec] } }
+        ; return $ Just spec } }
 
 
 {-
diff --git a/testsuite/tests/deriving/should_fail/T10684.hs b/testsuite/tests/deriving/should_fail/T10684.hs
new file mode 100644 (file)
index 0000000..fdda0c7
--- /dev/null
@@ -0,0 +1,4 @@
+module A where
+import GHC.Generics
+data A = A deriving (Show, Generic)
+data B = B A deriving (Show)
diff --git a/testsuite/tests/deriving/should_fail/T10684.stderr b/testsuite/tests/deriving/should_fail/T10684.stderr
new file mode 100644 (file)
index 0000000..6cdbac2
--- /dev/null
@@ -0,0 +1,5 @@
+
+T10684.hs:3:28: error:
+    • Can't make a derived instance of ‘Generic A’:
+        You need DeriveGeneric to derive an instance for this class
+    • In the data declaration for ‘A’
diff --git a/testsuite/tests/deriving/should_fail/T12801.hs b/testsuite/tests/deriving/should_fail/T12801.hs
new file mode 100644 (file)
index 0000000..22bbdf0
--- /dev/null
@@ -0,0 +1,8 @@
+data Container
+  = Container [Wibble Int]
+  deriving (Eq, Show)
+
+data Wibble a
+  = Wibble a
+  | Wobble
+  deriving (Eq, Functor, Show)
diff --git a/testsuite/tests/deriving/should_fail/T12801.stderr b/testsuite/tests/deriving/should_fail/T12801.stderr
new file mode 100644 (file)
index 0000000..7bc63df
--- /dev/null
@@ -0,0 +1,5 @@
+
+T12801.hs:8:17: error:
+    • Can't make a derived instance of ‘Functor Wibble’:
+        You need DeriveFunctor to derive an instance for this class
+    • In the data declaration for ‘Wibble’
index 9f3781c..5fa589f 100644 (file)
@@ -60,7 +60,9 @@ test('T10598_fail3', normal, compile_fail, [''])
 test('T10598_fail4', normal, compile_fail, [''])
 test('T10598_fail5', normal, compile_fail, [''])
 test('T10598_fail6', normal, compile_fail, [''])
+test('T10684', normal, compile_fail, [''])
 test('T11509_1', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
      compile_fail, [''])
 test('T12163', normal, compile_fail, [''])
 test('T12512', omit_ways(['ghci']), compile_fail, [''])
+test('T12801', normal, compile_fail, [''])