Slight refactor of stock deriving internals

Summary:
Before, the `hasStockDeriving` function, which determines
how derived bindings should be generated for stock classes, was
awkwardly separated from the `checkSideConditions` function, which
checks invariants of the same classes that `hasStockDeriving` does.
As a result, there was a fair deal of hoopla needed to actually use
`hasStockDeriving`.

But this hoopla really isn't required—we should be using
`hasStockDeriving` from within `checkSideConditions`, since they're
looking up information about the same classes! By doing this, we can
eliminate some kludgy code in the form of `mk_eqn_stock'`, which had
an unreachable `pprPanic` that was stinking up the place.

Reviewers: bgamari, dfeuer

Reviewed By: bgamari

Subscribers: dfeuer, rwbarton, thomie, carter

GHC Trac Issues: #13154

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

2 files changed, 9 insertions, 17 deletions

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index b78cba7faa..294b42c530 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -1103,20 +1103,10 @@ mk_eqn_stock go_for_it bale_out
                 , denv_mtheta  = mtheta } <- ask
        dflags <- getDynFlags
        case checkSideConditions dflags mtheta cls cls_tys tc rep_tc of
-         CanDerive               -> mk_eqn_stock' go_for_it
+         CanDerive gen_fn        -> go_for_it $ DerivSpecStock gen_fn
          DerivableClassError msg -> bale_out msg
          _                       -> bale_out (nonStdErr cls)
 
-mk_eqn_stock' :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
-              -> DerivM EarlyDerivSpec
-mk_eqn_stock' go_for_it
-  = do cls <- asks denv_cls
-       go_for_it $
-         case hasStockDeriving cls of
-           Just gen_fn -> DerivSpecStock gen_fn
-           Nothing ->
-             pprPanic "mk_eqn_stock': Not a stock class!" (ppr cls)
-
 mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
                 -> (SDoc -> DerivM EarlyDerivSpec)
                 -> DerivM EarlyDerivSpec
@@ -1150,7 +1140,7 @@ mk_eqn_no_mechanism go_for_it bale_out
            -- NB: pass the *representation* tycon to checkSideConditions
            NonDerivableClass   msg -> bale_out (dac_error msg)
            DerivableClassError msg -> bale_out msg
-           CanDerive               -> mk_eqn_stock' go_for_it
+           CanDerive gen_fn        -> go_for_it $ DerivSpecStock gen_fn
            DerivableViaInstance    -> go_for_it DerivSpecAnyClass
 
 {-
@@ -1420,7 +1410,7 @@ mkNewTypeEqn
                        <+> text "for instantiating" <+> ppr cls ]
                  mk_data_eqn DerivSpecAnyClass
                -- CanDerive
-               CanDerive -> mk_eqn_stock' mk_data_eqn
+               CanDerive gen_fn -> mk_data_eqn $ DerivSpecStock gen_fn
 
 {-
 Note [Recursive newtypes]
diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs
index eae2fa557b..c9804ba92c 100644
--- a/compiler/typecheck/TcDerivUtils.hs
+++ b/compiler/typecheck/TcDerivUtils.hs
@@ -10,9 +10,8 @@ Error-checking and other utilities for @deriving@ clauses or declarations.
 
 module TcDerivUtils (
         DerivM, DerivEnv(..),
-        DerivSpec(..), pprDerivSpec,
-        DerivSpecMechanism(..), isDerivSpecStock,
-        isDerivSpecNewtype, isDerivSpecAnyClass,
+        DerivSpec(..), pprDerivSpec, DerivSpecMechanism(..),
+        isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass,
         DerivContext, DerivStatus(..),
         PredOrigin(..), ThetaOrigin(..), mkPredOrigin,
         mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,
@@ -215,6 +214,8 @@ type DerivContext = Maybe ThetaType
    -- Just theta <=> Standalone deriving: context supplied by programmer
 
 data DerivStatus = CanDerive                 -- Stock class, can derive
+                     (SrcSpan -> TyCon -> [Type]
+                              -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
                  | DerivableClassError SDoc  -- Stock class, but can't do it
                  | DerivableViaInstance      -- See Note [Deriving any class]
                  | NonDerivableClass SDoc    -- Non-stock class
@@ -425,12 +426,13 @@ checkSideConditions dflags mtheta cls cls_tys tc rep_tc
   = case (cond dflags tc rep_tc) of
         NotValid err -> DerivableClassError err  -- Class-specific error
         IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
-                   -> CanDerive
                    -- All stock derivable classes are unary in the sense that
                    -- there should be not types in cls_tys (i.e., no type args
                    -- other than last). Note that cls_types can contain
                    -- invisible types as well (e.g., for Generic1, which is
                    -- poly-kinded), so make sure those are not counted.
+                 , Just gen_fn <- hasStockDeriving cls
+                   -> CanDerive gen_fn
                  | otherwise -> DerivableClassError (classArgsErr cls cls_tys)
                    -- e.g. deriving( Eq s )