Commit 9c002177 authored by Ryan Scott's avatar Ryan Scott Committed by Marge Bot

Refactor some cruft in TcDeriv

* `mk_eqn_stock`, `mk_eqn_anyclass`, and `mk_eqn_no_mechanism` all
  took a continuation of type
  `DerivSpecMechanism -> DerivM EarlyDerivSpec` to represent its
  primary control flow. However, in practice this continuation was
  always instantiated with the `mk_originative_eqn` function, so
  there's not much point in making this be a continuation in the
  first place.

  This patch removes these continuations in favor of invoking
  `mk_originative_eqn` directly, which is simpler.
* There were several parts of `TcDeriv` that took different code
  paths if compiling an `.hs-boot` file. But this is silly, because
  ever since 101a8c77 we simply error
  eagerly whenever attempting to derive any instances in an
  `.hs-boot` file.

  This patch removes all of the unnecessary `.hs-boot` code paths,
  leaving only one (which errors out).
* Remove various error continuation arguments from `mk_eqn_stock`
  and related functions.
parent 58013220
Pipeline #10789 failed with stages
in 404 minutes and 42 seconds
......@@ -99,10 +99,6 @@ data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])
-- by the programmer; it is ds_theta
-- See Note [Inferring the instance context] in TcDerivInfer
earlyDSLoc :: EarlyDerivSpec -> SrcSpan
earlyDSLoc (InferTheta spec) = ds_loc spec
earlyDSLoc (GivenTheta spec) = ds_loc spec
splitEarlyDerivSpec :: [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
splitEarlyDerivSpec [] = ([],[])
......@@ -216,13 +212,10 @@ tcDeriving :: [DerivInfo] -- All `deriving` clauses
tcDeriving deriv_infos deriv_decls
= recoverM (do { g <- getGblEnv
; return (g, emptyBag, emptyValBindsOut)}) $
do { -- Fish the "deriving"-related information out of the TcEnv
-- And make the necessary "equations".
is_boot <- tcIsHsBootOrSig
; traceTc "tcDeriving" (ppr is_boot)
; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
; traceTc "tcDeriving 1" (ppr early_specs)
do { -- Fish the "deriving"-related information out of the TcEnv
-- And make the necessary "equations".
early_specs <- makeDerivSpecs deriv_infos deriv_decls
; traceTc "tcDeriving" (ppr early_specs)
; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
; insts1 <- mapM genInst given_specs
......@@ -260,8 +253,7 @@ tcDeriving deriv_infos deriv_decls
; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs
; let inst_infos = inst_infos1 ++ inst_infos2
; (inst_info, rn_binds, rn_dus) <-
renameDeriv is_boot inst_infos binds
; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds
; unless (isEmptyBag inst_info) $
liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
......@@ -297,19 +289,10 @@ pprRepTy fi@(FamInst { fi_tys = lhs })
equals <+> ppr rhs
where rhs = famInstRHS fi
renameDeriv :: Bool
-> [InstInfo GhcPs]
renameDeriv :: [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv is_boot inst_infos bagBinds
| is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings
-- The inst-info bindings will all be empty, but it's easier to
-- just use rn_inst_info to change the type appropriately
= do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
; return ( listToBag rn_inst_infos
, emptyValBindsOut, usesOnly (plusFVs fvs)) }
| otherwise
renameDeriv inst_infos bagBinds
= discardWarnings $
-- Discard warnings about unused bindings etc
setXOptM LangExt.EmptyCase $
......@@ -489,11 +472,10 @@ in derived code.
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
-}
makeDerivSpecs :: Bool
-> [DerivInfo]
makeDerivSpecs :: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM [EarlyDerivSpec]
makeDerivSpecs is_boot deriv_infos deriv_decls
makeDerivSpecs deriv_infos deriv_decls
= do { eqns1 <- sequenceA
[ deriveClause rep_tc scoped_tvs dcs preds err_ctxt
| DerivInfo { di_rep_tc = rep_tc
......@@ -505,17 +487,7 @@ makeDerivSpecs is_boot deriv_infos deriv_decls
<- clauses
]
; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
; let eqns = concat eqns1 ++ catMaybes eqns2
; if is_boot then -- No 'deriving' at all in hs-boot files
do { unless (null eqns) (add_deriv_err (head eqns))
; return [] }
else return eqns }
where
add_deriv_err eqn
= setSrcSpan (earlyDSLoc eqn) $
addErr (hang (text "Deriving not permitted in hs-boot file")
2 (text "Use an instance declaration instead"))
; return $ concat eqns1 ++ catMaybes eqns2 }
------------------------------------------------------------------
-- | Process the derived classes in a single @deriving@ clause.
......@@ -1336,17 +1308,15 @@ See Note [Eta reduction for data families] in FamInstEnv
mkDataTypeEqn :: DerivM EarlyDerivSpec
mkDataTypeEqn
= do mb_strat <- asks denv_strat
let bale_out msg = do err <- derivingThingErrM False msg
lift $ failWithTc err
case mb_strat of
Just StockStrategy -> mk_eqn_stock mk_originative_eqn bale_out
Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out
Just StockStrategy -> mk_eqn_stock
Just AnyclassStrategy -> mk_eqn_anyclass
Just (ViaStrategy ty) -> mk_eqn_via ty
-- GeneralizedNewtypeDeriving makes no sense for non-newtypes
Just NewtypeStrategy -> bale_out gndNonNewtypeErr
Just NewtypeStrategy -> derivingThingFailWith False gndNonNewtypeErr
-- Lacking a user-requested deriving strategy, we will try to pick
-- between the stock or anyclass strategies
Nothing -> mk_eqn_no_mechanism mk_originative_eqn bale_out
Nothing -> mk_eqn_no_mechanism
-- Derive an instance by way of an originative deriving strategy
-- (stock or anyclass).
......@@ -1460,9 +1430,7 @@ mk_coerce_based_eqn mk_mechanism coerced_ty
lift $ traceTc "newtype deriving:" $
ppr tycon <+> ppr (rep_tys coerced_ty) <+> ppr inferred_thetas
let mechanism = mk_mechanism coerced_ty
bale_out msg = do err <- derivingThingErrMechanism mechanism msg
lift $ failWithTc err
atf_coerce_based_error_checks cls bale_out
atf_coerce_based_error_checks mechanism cls
doDerivInstErrorChecks1 mechanism
dfun_name <- lift $ newDFunName' cls tycon
loc <- lift getSrcSpanM
......@@ -1491,11 +1459,13 @@ mk_coerce_based_eqn mk_mechanism coerced_ty
--
-- See Note [GND and associated type families]
atf_coerce_based_error_checks
:: Class
-> (SDoc -> DerivM ())
-> DerivM ()
atf_coerce_based_error_checks cls bale_out
= let cls_tyvars = classTyVars cls
:: DerivSpecMechanism
-> Class -> DerivM ()
atf_coerce_based_error_checks mechanism cls
= let bale_out msg = do err <- derivingThingErrMechanism mechanism msg
lift $ failWithTc err
cls_tyvars = classTyVars cls
ats_look_sensible
= -- Check (a) from Note [GND and associated type families]
......@@ -1540,10 +1510,8 @@ atf_coerce_based_error_checks cls bale_out
<+> text "in a kind, which is not (yet) allowed")
in unless ats_look_sensible $ bale_out cant_derive_err
mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
-> (SDoc -> DerivM EarlyDerivSpec)
-> DerivM EarlyDerivSpec
mk_eqn_stock go_for_it bale_out
mk_eqn_stock :: DerivM EarlyDerivSpec
mk_eqn_stock
= do DerivEnv { denv_tc = tc
, denv_rep_tc = rep_tc
, denv_cls = cls
......@@ -1552,18 +1520,16 @@ mk_eqn_stock go_for_it bale_out
dflags <- getDynFlags
case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
tc rep_tc of
CanDeriveStock gen_fn -> go_for_it $ DerivSpecStock gen_fn
StockClassError msg -> bale_out msg
_ -> bale_out (nonStdErr cls)
mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
-> (SDoc -> DerivM EarlyDerivSpec)
-> DerivM EarlyDerivSpec
mk_eqn_anyclass go_for_it bale_out
CanDeriveStock gen_fn -> mk_originative_eqn $ DerivSpecStock gen_fn
StockClassError msg -> derivingThingFailWith False msg
_ -> derivingThingFailWith False (nonStdErr cls)
mk_eqn_anyclass :: DerivM EarlyDerivSpec
mk_eqn_anyclass
= do dflags <- getDynFlags
case canDeriveAnyClass dflags of
IsValid -> go_for_it DerivSpecAnyClass
NotValid msg -> bale_out msg
IsValid -> mk_originative_eqn DerivSpecAnyClass
NotValid msg -> derivingThingFailWith False msg
mk_eqn_newtype :: Type -- The newtype's representation type
-> DerivM EarlyDerivSpec
......@@ -1573,10 +1539,8 @@ mk_eqn_via :: Type -- The @via@ type
-> DerivM EarlyDerivSpec
mk_eqn_via = mk_coerce_based_eqn DerivSpecVia
mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
-> (SDoc -> DerivM EarlyDerivSpec)
-> DerivM EarlyDerivSpec
mk_eqn_no_mechanism go_for_it bale_out
mk_eqn_no_mechanism :: DerivM EarlyDerivSpec
mk_eqn_no_mechanism
= do DerivEnv { denv_tc = tc
, denv_rep_tc = rep_tc
, denv_cls = cls
......@@ -1597,10 +1561,10 @@ mk_eqn_no_mechanism go_for_it bale_out
tc rep_tc of
-- NB: pass the *representation* tycon to
-- checkOriginativeSideConditions
NonDerivableClass msg -> bale_out (dac_error msg)
StockClassError msg -> bale_out msg
CanDeriveStock gen_fn -> go_for_it $ DerivSpecStock gen_fn
CanDeriveAnyClass -> go_for_it DerivSpecAnyClass
NonDerivableClass msg -> derivingThingFailWith False (dac_error msg)
StockClassError msg -> derivingThingFailWith False msg
CanDeriveStock gen_fn -> mk_originative_eqn $ DerivSpecStock gen_fn
CanDeriveAnyClass -> mk_originative_eqn DerivSpecAnyClass
{-
************************************************************************
......@@ -1625,9 +1589,8 @@ mkNewTypeEqn
let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags
deriveAnyClass = xopt LangExt.DeriveAnyClass dflags
bale_out = bale_out' newtype_deriving
bale_out' b msg = do err <- derivingThingErrM b msg
lift $ failWithTc err
bale_out = derivingThingFailWith newtype_deriving
non_std = nonStdErr cls
suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"
......@@ -1705,8 +1668,8 @@ mkNewTypeEqn
MASSERT( cls_tys `lengthIs` (classArity cls - 1) )
case mb_strat of
Just StockStrategy -> mk_eqn_stock mk_originative_eqn bale_out
Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out
Just StockStrategy -> mk_eqn_stock
Just AnyclassStrategy -> mk_eqn_anyclass
Just NewtypeStrategy ->
-- Since the user explicitly asked for GeneralizedNewtypeDeriving,
-- we don't need to perform all of the checks we normally would,
......@@ -2094,6 +2057,16 @@ doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism
gen_inst_err = text "Generic instances can only be derived in"
<+> text "Safe Haskell using the stock strategy."
derivingThingFailWith :: Bool -- If True, add a snippet about how not even
-- GeneralizedNewtypeDeriving would make this
-- declaration work. This only kicks in when
-- an explicit deriving strategy is not given.
-> SDoc -- The error message
-> DerivM a
derivingThingFailWith newtype_deriving msg = do
err <- derivingThingErrM newtype_deriving msg
lift $ failWithTc err
genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
-> TyCon -> [Type] -> [TyVar]
-> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
......
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