[commit: ghc] master: Slight refactor of stock deriving internals (f433659)

[git at git.haskell.org]

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

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

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

commit f4336593a390e6317ac2852d8defb54bfa633d3e
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Tue Feb 20 12:50:34 2018 -0500

    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


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

f4336593a390e6317ac2852d8defb54bfa633d3e
 compiler/typecheck/TcDeriv.hs      | 16 +++-------------
 compiler/typecheck/TcDerivUtils.hs | 10 ++++++----
 2 files changed, 9 insertions(+), 17 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index b78cba7..294b42c 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 eae2fa5..c9804ba 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 )