Commit f4336593 authored by Ryan Scott's avatar Ryan Scott

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
parent f511bb58
......@@ -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]
......
......@@ -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 )
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment