diff options
| -rw-r--r-- | compiler/typecheck/TcDeriv.hs | 16 | ||||
| -rw-r--r-- | 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 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 ) |