summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2018-03-23 12:06:04 -0400
committerRyan Scott <ryan.gl.scott@gmail.com>2018-03-23 12:06:05 -0400
commitaffdea82bb70e5a912b679a169c6e9a230e4c93e (patch)
tree1200f0f3cb2735a45017be61808b709f24c4db49 /compiler
parentd5577f44eaf3b9dfdfc77828038782bf818c176a (diff)
downloadhaskell-affdea82bb70e5a912b679a169c6e9a230e4c93e.tar.gz
Allow PartialTypeSignatures in standalone deriving contexts
Summary: At its core, this patch is a simple tweak that allows a user to write: ```lang=haskell deriving instance _ => Eq (Foo a) ``` Which is functionally equivalent to: ```lang=haskell data Foo a = ... deriving Eq ``` But with the added flexibility that `StandaloneDeriving` gives you (namely, the ability to use it anywhere, not just in the same module that `Foo` was declared in). This fixes #13324, and should hopefully address a use case brought up in #10607. Currently, only the use of a single, extra-constraints wildcard is permitted in a standalone deriving declaration. Any other wildcard is rejected, so things like `deriving instance (Eq a, _) => Eq (Foo a)` are currently forbidden. There are quite a few knock-on changes brought on by this change: * The `HsSyn` type used to represent standalone-derived instances was previously `LHsSigType`, which isn't sufficient to hold wildcard types. This needed to be changed to `LHsSigWcType` as a result. * Previously, `DerivContext` was a simple type synonym for `Maybe ThetaType`, under the assumption that you'd only ever be in the `Nothing` case if you were in a `deriving` clause. After this patch, that assumption no longer holds true, as you can also be in this situation with standalone deriving when an extra-constraints wildcard is used. As a result, I changed `DerivContext` to be a proper datatype that reflects the new wrinkle that this patch adds, and plumbed this through the relevant parts of `TcDeriv` and friends. * Relatedly, the error-reporting machinery in `TcErrors` also assumed that if you have any unsolved constraints in a derived instance, then you should be able to fix it by switching over to standalone deriving. This was always sound advice before, but with this new feature, it's possible to have unsolved constraints even when you're standalone-deriving something! To rectify this, I tweaked some constructors of `CtOrigin` a bit to reflect this new subtlety. This requires updating the Haddock submodule. See my fork at https://github.com/RyanGlScott/haddock/commit/067d52fd4be15a1842cbb05f42d9d482de0ad3a7 Test Plan: ./validate Reviewers: simonpj, goldfire, bgamari Reviewed By: simonpj Subscribers: goldfire, rwbarton, thomie, mpickering, carter GHC Trac Issues: #13324 Differential Revision: https://phabricator.haskell.org/D4383
Diffstat (limited to 'compiler')
-rw-r--r--compiler/deSugar/DsMeta.hs2
-rw-r--r--compiler/hsSyn/Convert.hs2
-rw-r--r--compiler/hsSyn/HsDecls.hs13
-rw-r--r--compiler/parser/Parser.y3
-rw-r--r--compiler/rename/RnSource.hs2
-rw-r--r--compiler/rename/RnTypes.hs34
-rw-r--r--compiler/typecheck/TcDeriv.hs151
-rw-r--r--compiler/typecheck/TcDerivInfer.hs43
-rw-r--r--compiler/typecheck/TcDerivUtils.hs144
-rw-r--r--compiler/typecheck/TcErrors.hs15
-rw-r--r--compiler/typecheck/TcRnTypes.hs27
11 files changed, 318 insertions, 118 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 5029f9df09..b74fa080af 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -488,7 +488,7 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
; repDeriv strat' cxt' inst_ty' }
; return (loc, dec) }
where
- (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+ (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 644075810c..3bb61e04f0 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -351,7 +351,7 @@ cvtDec (TH.StandaloneDerivD ds cxt ty)
; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
; returnJustL $ DerivD $
DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
- , deriv_type = mkLHsSigType inst_ty'
+ , deriv_type = mkLHsSigWcType inst_ty'
, deriv_overlap_mode = Nothing } }
cvtDec (TH.DefaultSigD nm typ)
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 475e31ea57..a3fe5a722e 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -1659,7 +1659,18 @@ type LDerivDecl pass = Located (DerivDecl pass)
-- | Deriving Declaration
data DerivDecl pass = DerivDecl
- { deriv_type :: LHsSigType pass
+ { deriv_type :: LHsSigWcType pass
+ -- ^ The instance type to derive.
+ --
+ -- It uses an 'LHsSigWcType' because the context is allowed to be a
+ -- single wildcard:
+ --
+ -- > deriving instance _ => Eq (Foo a)
+ --
+ -- Which signifies that the context should be inferred.
+
+ -- See Note [Inferring the instance context] in TcDerivInfer.
+
, deriv_strategy :: Maybe (Located DerivStrategy)
, deriv_overlap_mode :: Maybe (Located OverlapMode)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 898ed3c5ae..12413f2187 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1376,7 +1376,8 @@ stand_alone_deriving :: { LDerivDecl GhcPs }
: 'deriving' deriv_strategy 'instance' overlap_pragma inst_type
{% do { let { err = text "in the stand-alone deriving instance"
<> colon <+> quotes (ppr $5) }
- ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4))
+ ; ams (sLL $1 (hsSigType $>)
+ (DerivDecl (mkHsWildCardBndrs $5) $2 $4))
[mj AnnDeriving $1, mj AnnInstance $3] } }
-----------------------------------------------------------------------------
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 447871a7f2..d0ff52714d 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -945,7 +945,7 @@ rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)
; unless standalone_deriv_ok (addErr standaloneDerivErr)
; failIfTc (isJust deriv_strat && not deriv_strats_ok) $
illegalDerivStrategyErr $ fmap unLoc deriv_strat
- ; (ty', fvs) <- rnLHsInstType (text "a deriving declaration") ty
+ ; (ty', fvs) <- rnHsSigWcType DerivDeclCtx ty
; return (DerivDecl ty' deriv_strat overlap, fvs) }
standaloneDerivErr :: SDoc
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index b2dafb2bf7..55b9fd549f 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -170,7 +170,7 @@ rnWcBody ctxt nwc_rdrs hs_ty
, L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
= do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
; wc' <- setSrcSpan lx $
- do { checkExtraConstraintWildCard env wc
+ do { checkExtraConstraintWildCard env hs_ctxt1 wc
; rnAnonWildCard wc }
; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
@@ -188,26 +188,46 @@ rnWcBody ctxt nwc_rdrs hs_ty
rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
-checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs
- -> RnM ()
+checkExtraConstraintWildCard
+ :: RnTyKiEnv -> HsContext GhcPs -> HsWildCardInfo GhcPs -> RnM ()
-- Rename the extra-constraint spot in a type signature
-- (blah, _) => type
-- Check that extra-constraints are allowed at all, and
-- if so that it's an anonymous wildcard
-checkExtraConstraintWildCard env wc
+checkExtraConstraintWildCard env hs_ctxt wc
= checkWildCard env mb_bad
where
mb_bad | not (extraConstraintWildCardsAllowed env)
- = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc)
- <+> text "not allowed")
+ = Just base_msg
+ -- Currently, we do not allow wildcards in their full glory in
+ -- standalone deriving declarations. We only allow a single
+ -- extra-constraints wildcard à la:
+ --
+ -- deriving instance _ => Eq (Foo a)
+ --
+ -- i.e., we don't support things like
+ --
+ -- deriving instance (Eq a, _) => Eq (Foo a)
+ | DerivDeclCtx {} <- rtke_ctxt env
+ , not (null hs_ctxt)
+ = Just deriv_decl_msg
| otherwise
= Nothing
+ base_msg = text "Extra-constraint wildcard" <+> quotes (ppr wc)
+ <+> text "not allowed"
+
+ deriv_decl_msg
+ = hang base_msg
+ 2 (vcat [ text "except as the sole constraint"
+ , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])
+
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed env
= case rtke_ctxt env of
TypeSigCtx {} -> True
ExprWithTySigCtx {} -> True
+ DerivDeclCtx {} -> True
_ -> False
-- | Finds free type and kind variables in a type,
@@ -324,7 +344,7 @@ rnImplicitBndrs bind_free_tvs doc
thing_inside vars }
rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
--- Rename the type in an instance or standalone deriving decl
+-- Rename the type in an instance.
-- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma"
-- Do not try to decompose the inst_ty in case it is malformed
rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 294b42c530..152292d5b1 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -613,10 +613,11 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
; let deriv_strat = fmap unLoc deriv_strat'
; traceTc "Deriving strategy (standalone deriving)" $
vcat [ppr deriv_strat, ppr deriv_ty]
- ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
+ ; (tvs, deriv_ctxt, cls, inst_tys)
+ <- tcStandaloneDerivInstType deriv_ty
; traceTc "Standalone deriving;" $ vcat
[ text "tvs:" <+> ppr tvs
- , text "theta:" <+> ppr theta
+ , text "deriv_ctxt:" <+> ppr deriv_ctxt
, text "cls:" <+> ppr cls
, text "tys:" <+> ppr inst_tys ]
-- C.f. TcInstDcls.tcLocalInstDecl1
@@ -641,13 +642,58 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
| otherwise
-> Just <$> mkEqnHelp (fmap unLoc overlap_mode)
tvs cls cls_tys tc tc_args
- (Just theta) deriv_strat
+ deriv_ctxt deriv_strat
_ -> -- Complain about functions, primitive types, etc,
bale_out $
text "The last argument of the instance must be a data or newtype application"
}
+-- Typecheck the type in a standalone deriving declaration.
+--
+-- This may appear dense, but it's mostly huffing and puffing to recognize
+-- the special case of a type with an extra-constraints wildcard context, e.g.,
+--
+-- deriving instance _ => Eq (Foo a)
+--
+-- If there is such a wildcard, we typecheck this as if we had written
+-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,
+-- as the 'DerivContext', where loc is the location of the wildcard used for
+-- error reporting. This indicates that we should infer the context as if we
+-- were deriving Eq via a deriving clause
+-- (see Note [Inferring the instance context] in TcDerivInfer).
+--
+-- If there is no wildcard, then proceed as normal, and instead return
+-- @'SupplyContext' theta@, where theta is the typechecked context.
+--
+-- Note that this will never return @'InferContext' 'Nothing'@, as that can
+-- only happen with @deriving@ clauses.
+tcStandaloneDerivInstType
+ :: LHsSigWcType GhcRn
+ -> TcM ([TyVar], DerivContext, Class, [Type])
+tcStandaloneDerivInstType
+ (HsWC { hswc_body = deriv_ty@(HsIB { hsib_vars = vars
+ , hsib_closed = closed
+ , hsib_body = deriv_ty_body })})
+ | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body
+ , L _ [wc_pred] <- theta
+ , L _ (HsWildCardTy (AnonWildCard (L wc_span _))) <- ignoreParens wc_pred
+ = do (deriv_tvs, _deriv_theta, deriv_cls, deriv_inst_tys)
+ <- tc_hs_cls_inst_ty $
+ HsIB { hsib_vars = vars
+ , hsib_closed = closed
+ , hsib_body
+ = L (getLoc deriv_ty_body) $
+ HsForAllTy { hst_bndrs = tvs
+ , hst_body = rho }}
+ pure (deriv_tvs, InferContext (Just wc_span), deriv_cls, deriv_inst_tys)
+ | otherwise
+ = do (deriv_tvs, deriv_theta, deriv_cls, deriv_inst_tys)
+ <- tc_hs_cls_inst_ty deriv_ty
+ pure (deriv_tvs, SupplyContext deriv_theta, deriv_cls, deriv_inst_tys)
+ where
+ tc_hs_cls_inst_ty = tcHsClsInstType TcType.InstDeclCtxt
+
warnUselessTypeable :: TcM ()
warnUselessTypeable
= do { warn <- woptM Opt_WarnDerivingTypeable
@@ -659,7 +705,7 @@ warnUselessTypeable
deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance
-- Can be a data instance, hence [Type] args
-> Maybe DerivStrategy -- The optional deriving strategy
- -> LHsSigType GhcRn -- The deriving predicate
+ -> LHsSigType GhcRn -- The deriving predicate
-> TcM (Maybe EarlyDerivSpec)
-- The deriving clause of a data or newtype declaration
-- I.e. not standalone deriving
@@ -667,7 +713,8 @@ deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance
-- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays.
deriveTyData tvs tc tc_args deriv_strat deriv_pred
- = setSrcSpan (getLoc (hsSigType deriv_pred)) $ -- Use loc of the 'deriving' item
+ = setSrcSpan (getLoc (hsSigType deriv_pred)) $
+ -- Use loc of the 'deriving' item
do { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
<- tcExtendTyVarEnv tvs $
tcHsDeriv deriv_pred
@@ -754,7 +801,7 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
; spec <- mkEqnHelp Nothing tkvs
cls final_cls_tys tc final_tc_args
- Nothing deriv_strat
+ (InferContext Nothing) deriv_strat
; traceTc "derivTyData" (ppr spec)
; return $ Just spec } }
@@ -932,8 +979,10 @@ mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class -> [Type]
-> TyCon -> [Type]
- -> DerivContext -- Just => context supplied (standalone deriving)
- -- Nothing => context inferred (deriving on data decl)
+ -> DerivContext
+ -- SupplyContext => context supplied (standalone deriving)
+ -- InferContext => context inferred (deriving on data decl, or
+ -- standalone deriving decl with a wildcard)
-> Maybe DerivStrategy
-> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
@@ -941,7 +990,7 @@ mkEqnHelp :: Maybe OverlapMode
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded
-mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
+mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args deriv_ctxt deriv_strat
= do { -- Find the instance of a data family
-- Note [Looking up family instances for deriving]
fam_envs <- tcGetFamInstEnvs
@@ -963,7 +1012,7 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
, denv_tc_args = tc_args
, denv_rep_tc = rep_tc
, denv_rep_tc_args = rep_tc_args
- , denv_mtheta = mtheta
+ , denv_ctxt = deriv_ctxt
, denv_strat = deriv_strat }
; flip runReaderT deriv_env $
if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn }
@@ -1063,14 +1112,14 @@ mk_data_eqn mechanism
, denv_rep_tc = rep_tc
, denv_cls = cls
, denv_cls_tys = cls_tys
- , denv_mtheta = mtheta } <- ask
+ , denv_ctxt = deriv_ctxt } <- ask
let inst_ty = mkTyConApp tc tc_args
inst_tys = cls_tys ++ [inst_ty]
doDerivInstErrorChecks1 mechanism
loc <- lift getSrcSpanM
dfun_name <- lift $ newDFunName' cls tc
- case mtheta of
- Nothing -> -- Infer context
+ case deriv_ctxt of
+ InferContext wildcard ->
do { (inferred_constraints, tvs', inst_tys')
<- inferConstraints mechanism
; return $ InferTheta $ DS
@@ -1080,9 +1129,10 @@ mk_data_eqn mechanism
, ds_tc = rep_tc
, ds_theta = inferred_constraints
, ds_overlap = overlap_mode
+ , ds_standalone_wildcard = wildcard
, ds_mechanism = mechanism } }
- Just theta -> do -- Specified context
+ SupplyContext theta ->
return $ GivenTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs
@@ -1090,6 +1140,7 @@ mk_data_eqn mechanism
, ds_tc = rep_tc
, ds_theta = theta
, ds_overlap = overlap_mode
+ , ds_standalone_wildcard = Nothing
, ds_mechanism = mechanism }
mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
@@ -1100,9 +1151,9 @@ mk_eqn_stock go_for_it bale_out
, denv_rep_tc = rep_tc
, denv_cls = cls
, denv_cls_tys = cls_tys
- , denv_mtheta = mtheta } <- ask
+ , denv_ctxt = deriv_ctxt } <- ask
dflags <- getDynFlags
- case checkSideConditions dflags mtheta cls cls_tys tc rep_tc of
+ case checkSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc of
CanDerive gen_fn -> go_for_it $ DerivSpecStock gen_fn
DerivableClassError msg -> bale_out msg
_ -> bale_out (nonStdErr cls)
@@ -1124,7 +1175,7 @@ mk_eqn_no_mechanism go_for_it bale_out
, denv_rep_tc = rep_tc
, denv_cls = cls
, denv_cls_tys = cls_tys
- , denv_mtheta = mtheta } <- ask
+ , denv_ctxt = deriv_ctxt } <- ask
dflags <- getDynFlags
-- See Note [Deriving instances for classes themselves]
@@ -1136,7 +1187,7 @@ mk_eqn_no_mechanism go_for_it bale_out
| otherwise
= nonStdErr cls $$ msg
- case checkSideConditions dflags mtheta cls cls_tys tc rep_tc of
+ case checkSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc of
-- NB: pass the *representation* tycon to checkSideConditions
NonDerivableClass msg -> bale_out (dac_error msg)
DerivableClassError msg -> bale_out msg
@@ -1162,8 +1213,9 @@ mkNewTypeEqn
, denv_rep_tc_args = rep_tc_args
, denv_cls = cls
, denv_cls_tys = cls_tys
- , denv_mtheta = mtheta
+ , denv_ctxt = deriv_ctxt
, denv_strat = mb_strat } <- ask
+ sa_wildcard <- isStandaloneWildcardDeriv
dflags <- getDynFlags
let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags
@@ -1175,22 +1227,24 @@ mkNewTypeEqn
doDerivInstErrorChecks1 mechanism
dfun_name <- lift $ newDFunName' cls tycon
loc <- lift getSrcSpanM
- case mtheta of
- Just theta -> return $ GivenTheta $ DS
+ case deriv_ctxt of
+ SupplyContext theta -> return $ GivenTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tycon
, ds_theta = theta
, ds_overlap = overlap_mode
+ , ds_standalone_wildcard = Nothing
, ds_mechanism = mechanism }
- Nothing -> return $ InferTheta $ DS
+ InferContext wildcard -> return $ InferTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tycon
, ds_theta = all_thetas
, ds_overlap = overlap_mode
+ , ds_standalone_wildcard = wildcard
, ds_mechanism = mechanism }
bale_out = bale_out' newtype_deriving
bale_out' b msg = do err <- derivingThingErrM b msg
@@ -1250,7 +1304,7 @@ mkNewTypeEqn
rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
rep_tys = cls_tys ++ [rep_inst_ty]
rep_pred = mkClassPred cls rep_tys
- rep_pred_o = mkPredOrigin DerivOrigin TypeLevel rep_pred
+ rep_pred_o = mkPredOrigin deriv_origin TypeLevel rep_pred
-- rep_pred is the representation dictionary, from where
-- we are gong to get all the methods for the newtype
-- dictionary
@@ -1261,9 +1315,10 @@ mkNewTypeEqn
cls_tyvars = classTyVars cls
inst_ty = mkTyConApp tycon tc_args
inst_tys = cls_tys ++ [inst_ty]
- sc_preds = map (mkPredOrigin DerivOrigin TypeLevel) $
+ sc_preds = map (mkPredOrigin deriv_origin TypeLevel) $
substTheta (zipTvSubst cls_tyvars inst_tys) $
classSCTheta cls
+ deriv_origin = mkDerivOrigin sa_wildcard
-- Next we collect constraints for the class methods
-- If there are no methods, we don't need any constraints
@@ -1275,8 +1330,8 @@ mkNewTypeEqn
-- (Trac #12814)
| otherwise = rep_pred_o : coercible_constraints
coercible_constraints
- = [ mkPredOrigin (DerivOriginCoerce meth t1 t2) TypeLevel
- (mkReprPrimEqPred t1 t2)
+ = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)
+ TypeLevel (mkReprPrimEqPred t1 t2)
| meth <- meths
, let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs
inst_tys rep_inst_ty meth ]
@@ -1367,7 +1422,7 @@ mkNewTypeEqn
|| std_class_via_coercible cls)
-> go_for_it_gnd
| otherwise
- -> case checkSideConditions dflags mtheta cls cls_tys
+ -> case checkSideConditions dflags deriv_ctxt cls cls_tys
tycon rep_tycon of
DerivableClassError msg
-- There's a particular corner case where
@@ -1629,13 +1684,14 @@ genInst :: DerivSpec theta
-- See Note [Staging of tcDeriving]
genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
, ds_mechanism = mechanism, ds_tys = tys
- , ds_cls = clas, ds_loc = loc })
+ , ds_cls = clas, ds_loc = loc
+ , ds_standalone_wildcard = wildcard })
= do (meth_binds, deriv_stuff, unusedNames)
<- set_span_and_ctxt $
genDerivStuff mechanism loc clas rep_tycon tys tvs
let mk_inst_info theta = set_span_and_ctxt $ do
inst_spec <- newDerivClsInst theta spec
- doDerivInstErrorChecks2 clas inst_spec mechanism
+ doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism
traceTc "newder" (ppr inst_spec)
return $ InstInfo
{ iSpec = inst_spec
@@ -1662,14 +1718,14 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 mechanism = do
DerivEnv { denv_tc = tc
- , denv_rep_tc = rep_tc
- , denv_mtheta = mtheta } <- ask
+ , denv_rep_tc = rep_tc } <- ask
+ standalone <- isStandaloneDeriv
let anyclass_strategy = isDerivSpecAnyClass mechanism
bale_out msg = do err <- derivingThingErrMechanism mechanism msg
lift $ failWithTc err
- -- For standalone deriving (mtheta /= Nothing),
- -- check that all the data constructors are in scope...
+ -- For standalone deriving, check that all the data constructors are in
+ -- scope...
rdr_env <- lift getGlobalRdrEnv
let data_con_names = map dataConName (tyConDataCons rep_tc)
hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
@@ -1682,13 +1738,28 @@ doDerivInstErrorChecks1 mechanism = do
-- ...however, we don't perform this check if we're using DeriveAnyClass,
-- since it doesn't generate any code that requires use of a data
-- constructor.
- unless (anyclass_strategy || isNothing mtheta || not hidden_data_cons) $
+ unless (anyclass_strategy || not standalone || not hidden_data_cons) $
bale_out $ derivingHiddenErr tc
-doDerivInstErrorChecks2 :: Class -> ClsInst -> DerivSpecMechanism -> TcM ()
-doDerivInstErrorChecks2 clas clas_inst mechanism
+doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
+ -> DerivSpecMechanism -> TcM ()
+doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism
= do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)
; dflags <- getDynFlags
+ ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures
+ ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures
+
+ -- Error if PartialTypeSignatures isn't enabled when a user tries
+ -- to write @deriving instance _ => Eq (Foo a)@. Or, if that
+ -- extension is enabled, give a warning if -Wpartial-type-signatures
+ -- is enabled.
+ ; case wildcard of
+ Nothing -> pure ()
+ Just span -> setSrcSpan span $ do
+ checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion)
+ warnTc (Reason Opt_WarnPartialTypeSignatures)
+ wpartial_sigs partial_sig_msg
+
-- Check for Generic instances that are derived with an exotic
-- deriving strategy like DAC
-- See Note [Deriving strategies]
@@ -1700,6 +1771,12 @@ doDerivInstErrorChecks2 clas clas_inst mechanism
DerivSpecStock{} -> False
_ -> True
+ partial_sig_msg = text "Found type wildcard" <+> quotes (char '_')
+ <+> text "standing for" <+> quotes (pprTheta theta)
+
+ pts_suggestion
+ = text "To use the inferred type, enable PartialTypeSignatures"
+
gen_inst_err = text "Generic instances can only be derived in"
<+> text "Safe Haskell using the stock strategy."
@@ -1951,6 +2028,6 @@ derivingHiddenErr tc
= hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
2 (text "so you cannot derive an instance for it")
-standaloneCtxt :: LHsSigType GhcRn -> SDoc
+standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
2 (quotes (ppr ty))
diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs
index efad80f647..ebabc0f806 100644
--- a/compiler/typecheck/TcDerivInfer.hs
+++ b/compiler/typecheck/TcDerivInfer.hs
@@ -73,6 +73,7 @@ inferConstraints mechanism
, denv_tc_args = tc_args
, denv_cls = main_cls
, denv_cls_tys = cls_tys } <- ask
+ ; wildcard <- isStandaloneWildcardDeriv
; let is_anyclass = isDerivSpecAnyClass mechanism
infer_constraints
| is_anyclass = inferConstraintsDAC inst_tys
@@ -86,7 +87,8 @@ inferConstraints mechanism
cls_tvs = classTyVars main_cls
sc_constraints = ASSERT2( equalLength cls_tvs inst_tys
, ppr main_cls <+> ppr inst_tys )
- [ mkThetaOrigin DerivOrigin TypeLevel [] [] $
+ [ mkThetaOrigin (mkDerivOrigin wildcard)
+ TypeLevel [] [] $
substTheta cls_subst (classSCTheta main_cls) ]
cls_subst = ASSERT( equalLength cls_tvs inst_tys )
zipTvSubst cls_tvs inst_tys
@@ -110,6 +112,7 @@ inferConstraintsDataConArgs inst_ty inst_tys
, denv_rep_tc_args = rep_tc_args
, denv_cls = main_cls
, denv_cls_tys = cls_tys } <- ask
+ wildcard <- isStandaloneWildcardDeriv
let tc_binders = tyConBinders rep_tc
choose_level bndr
@@ -134,7 +137,7 @@ inferConstraintsDataConArgs inst_ty inst_tys
-- No constraints for unlifted types
-- See Note [Deriving and unboxed types]
, not (isUnliftedType arg_ty)
- , let orig = DerivOriginDC data_con arg_n
+ , let orig = DerivOriginDC data_con arg_n wildcard
, preds_and_mbSubst
<- get_arg_constraints orig arg_t_or_k arg_ty
]
@@ -213,7 +216,7 @@ inferConstraintsDataConArgs inst_ty inst_tys
-- Stupid constraints
stupid_constraints
- = [ mkThetaOrigin DerivOrigin TypeLevel [] [] $
+ = [ mkThetaOrigin deriv_origin TypeLevel [] [] $
substTheta tc_subst (tyConStupidTheta rep_tc) ]
tc_subst = -- See the comment with all_rep_tc_args for an
-- explanation of this assertion
@@ -233,7 +236,7 @@ inferConstraintsDataConArgs inst_ty inst_tys
constrs
| main_cls `hasKey` dataClassKey
, all (isLiftedTypeKind . typeKind) rep_tc_args
- = [ mk_cls_pred DerivOrigin t_or_k main_cls ty
+ = [ mk_cls_pred deriv_origin t_or_k main_cls ty
| (t_or_k, ty) <- zip t_or_ks rep_tc_args]
| otherwise
= []
@@ -247,6 +250,8 @@ inferConstraintsDataConArgs inst_ty inst_tys
| otherwise = cls_tys
+ deriv_origin = mkDerivOrigin wildcard
+
if -- Generic constraints are easy
| is_generic
-> return ([], tvs, inst_tys)
@@ -292,6 +297,7 @@ inferConstraintsDAC :: [TcType] -> DerivM ([ThetaOrigin], [TyVar], [TcType])
inferConstraintsDAC inst_tys
= do { DerivEnv { denv_tvs = tvs
, denv_cls = cls } <- ask
+ ; wildcard <- isStandaloneWildcardDeriv
; let gen_dms = [ (sel_id, dm_ty)
| (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
@@ -322,8 +328,9 @@ inferConstraintsDAC inst_tys
; let dm_theta' = substTheta subst dm_theta
tau_eq = mkPrimEqPred meth_tau (substTy subst dm_tau)
- ; return (mkThetaOrigin DerivOrigin TypeLevel
- meth_tvs meth_theta (tau_eq:dm_theta')) }
+ ; return (mkThetaOrigin (mkDerivOrigin wildcard)
+ TypeLevel meth_tvs meth_theta
+ (tau_eq:dm_theta')) }
; theta_origins <- lift $ pushTcLevelM_ (mapM do_one_meth gen_dms)
-- Yuk: the pushTcLevel is to match the one wrapping the call
@@ -334,20 +341,28 @@ inferConstraintsDAC inst_tys
{- Note [Inferring the instance context]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are two sorts of 'deriving':
+There are two sorts of 'deriving', as represented by the two constructors
+for DerivContext:
+
+ * InferContext mb_wildcard: This can either be:
+ - The deriving clause for a data type.
+ (e.g, data T a = T1 a deriving( Eq ))
+ In this case, mb_wildcard = Nothing.
+ - A standalone declaration with an extra-constraints wildcard
+ (e.g., deriving instance _ => Eq (Foo a))
+ In this case, mb_wildcard = Just loc, where loc is the location
+ of the extra-constraints wildcard.
- * InferTheta: the deriving clause for a data type
- data T a = T1 a deriving( Eq )
Here we must infer an instance context,
and generate instance declaration
instance Eq a => Eq (T a) where ...
- * CheckTheta: standalone deriving
+ * SupplyContext theta: standalone deriving
deriving instance Eq a => Eq (T a)
Here we only need to fill in the bindings;
- the instance context is user-supplied
+ the instance context (theta) is user-supplied
-For a deriving clause (InferTheta) we must figure out the
+For the InferContext case, we must figure out the
instance context (inferConstraintsDataConArgs). Suppose we are inferring
the instance context for
C t1 .. tn (T s1 .. sm)
@@ -539,8 +554,8 @@ See also Note [nonDetCmpType nondeterminism]
simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]]
-> TcM [DerivSpec ThetaType]
--- Used only for deriving clauses (InferTheta)
--- not for standalone deriving
+-- Used only for deriving clauses or standalone deriving with an
+-- extra-constraints wildcard (InferContext)
-- See Note [Simplifying the instance context]
simplifyInstanceContexts [] = return []
diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs
index c9804ba92c..ef9e83239d 100644
--- a/compiler/typecheck/TcDerivUtils.hs
+++ b/compiler/typecheck/TcDerivUtils.hs
@@ -12,7 +12,8 @@ module TcDerivUtils (
DerivM, DerivEnv(..),
DerivSpec(..), pprDerivSpec, DerivSpecMechanism(..),
isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass,
- DerivContext, DerivStatus(..),
+ DerivContext(..), DerivStatus(..),
+ isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,
PredOrigin(..), ThetaOrigin(..), mkPredOrigin,
mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,
checkSideConditions, hasStockDeriving,
@@ -51,6 +52,7 @@ import Util
import VarSet
import Control.Monad.Trans.Reader
+import Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import ListSetOps (assocMaybe)
@@ -59,6 +61,31 @@ import ListSetOps (assocMaybe)
-- is a simple reader around 'TcRn'.
type DerivM = ReaderT DerivEnv TcRn
+-- | Is GHC processing a stanalone deriving declaration?
+isStandaloneDeriv :: DerivM Bool
+isStandaloneDeriv = asks (go . denv_ctxt)
+ where
+ go :: DerivContext -> Bool
+ go (InferContext wildcard) = isJust wildcard
+ go (SupplyContext {}) = True
+
+-- | Is GHC processing a standalone deriving declaration with an
+-- extra-constraints wildcard as the context?
+-- (e.g., @deriving instance _ => Eq (Foo a)@)
+isStandaloneWildcardDeriv :: DerivM Bool
+isStandaloneWildcardDeriv = asks (go . denv_ctxt)
+ where
+ go :: DerivContext -> Bool
+ go (InferContext wildcard) = isJust wildcard
+ go (SupplyContext {}) = False
+
+-- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True',
+-- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting.
+mkDerivOrigin :: Bool -> CtOrigin
+mkDerivOrigin standalone_wildcard
+ | standalone_wildcard = StandAloneDerivOrigin
+ | otherwise = DerivClauseOrigin
+
-- | Contains all of the information known about a derived instance when
-- determining what its @EarlyDerivSpec@ should be.
data DerivEnv = DerivEnv
@@ -81,9 +108,12 @@ data DerivEnv = DerivEnv
, denv_rep_tc_args :: [Type]
-- ^ The representation types for 'denv_tc_args'
-- (for data family instances)
- , denv_mtheta :: DerivContext
- -- ^ 'Just' the context of the instance, for standalone deriving.
- -- 'Nothing' for @deriving@ clauses.
+ , denv_ctxt :: DerivContext
+ -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the
+ -- context of the instance).
+ -- 'InferContext' for @deriving@ clauses, or for standalone deriving that
+ -- uses a wildcard constraint.
+ -- See @Note [Inferring the instance context]@.
, denv_strat :: Maybe DerivStrategy
-- ^ 'Just' if user requests a particular deriving strategy.
-- Otherwise, 'Nothing'.
@@ -98,7 +128,7 @@ instance Outputable DerivEnv where
, denv_tc_args = tc_args
, denv_rep_tc = rep_tc
, denv_rep_tc_args = rep_tc_args
- , denv_mtheta = mtheta
+ , denv_ctxt = ctxt
, denv_strat = mb_strat })
= hang (text "DerivEnv")
2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode
@@ -109,18 +139,21 @@ instance Outputable DerivEnv where
, text "denv_tc_args" <+> ppr tc_args
, text "denv_rep_tc" <+> ppr rep_tc
, text "denv_rep_tc_args" <+> ppr rep_tc_args
- , text "denv_mtheta" <+> ppr mtheta
+ , text "denv_ctxt" <+> ppr ctxt
, text "denv_strat" <+> ppr mb_strat ])
-data DerivSpec theta = DS { ds_loc :: SrcSpan
- , ds_name :: Name -- DFun name
- , ds_tvs :: [TyVar]
- , ds_theta :: theta
- , ds_cls :: Class
- , ds_tys :: [Type]
- , ds_tc :: TyCon
- , ds_overlap :: Maybe OverlapMode
- , ds_mechanism :: DerivSpecMechanism }
+data DerivSpec theta = DS { ds_loc :: SrcSpan
+ , ds_name :: Name -- DFun name
+ , ds_tvs :: [TyVar]
+ , ds_theta :: theta
+ , ds_cls :: Class
+ , ds_tys :: [Type]
+ , ds_tc :: TyCon
+ , ds_overlap :: Maybe OverlapMode
+ , ds_standalone_wildcard :: Maybe SrcSpan
+ -- See Note [Inferring the instance context]
+ -- in TcDerivInfer
+ , ds_mechanism :: DerivSpecMechanism }
-- This spec implies a dfun declaration of the form
-- df :: forall tvs. theta => C tys
-- The Name is the name for the DFun we'll build
@@ -150,15 +183,17 @@ Example:
pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
- ds_tys = tys, ds_theta = rhs, ds_mechanism = mech })
+ ds_tys = tys, ds_theta = rhs,
+ ds_standalone_wildcard = wildcard, ds_mechanism = mech })
= hang (text "DerivSpec")
- 2 (vcat [ text "ds_loc =" <+> ppr l
- , text "ds_name =" <+> ppr n
- , text "ds_tvs =" <+> ppr tvs
- , text "ds_cls =" <+> ppr c
- , text "ds_tys =" <+> ppr tys
- , text "ds_theta =" <+> ppr rhs
- , text "ds_mechanism =" <+> ppr mech ])
+ 2 (vcat [ text "ds_loc =" <+> ppr l
+ , text "ds_name =" <+> ppr n
+ , text "ds_tvs =" <+> ppr tvs
+ , text "ds_cls =" <+> ppr c
+ , text "ds_tys =" <+> ppr tys
+ , text "ds_theta =" <+> ppr rhs
+ , text "ds_standalone_wildcard =" <+> ppr wildcard
+ , text "ds_mechanism =" <+> ppr mech ])
instance Outputable theta => Outputable (DerivSpec theta) where
ppr = pprDerivSpec
@@ -209,9 +244,29 @@ mechanismToStrategy (DerivSpecAnyClass{}) = AnyclassStrategy
instance Outputable DerivSpecMechanism where
ppr = ppr . mechanismToStrategy
-type DerivContext = Maybe ThetaType
- -- Nothing <=> Vanilla deriving; infer the context of the instance decl
- -- Just theta <=> Standalone deriving: context supplied by programmer
+-- | Whether GHC is processing a @deriving@ clause or a standalone deriving
+-- declaration.
+data DerivContext
+ = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either:
+ --
+ -- * A @deriving@ clause (in which case
+ -- @mb_wildcard@ is 'Nothing').
+ --
+ -- * A standalone deriving declaration with
+ -- an extra-constraints wildcard as the
+ -- context (in which case @mb_wildcard@ is
+ -- @'Just' loc@, where @loc@ is the location
+ -- of the wildcard.
+ --
+ -- GHC should infer the context.
+
+ | SupplyContext ThetaType -- ^ @'SupplyContext' theta@ is a standalone
+ -- deriving declaration, where @theta@ is the
+ -- context supplied by the user.
+
+instance Outputable DerivContext where
+ ppr (InferContext standalone) = text "InferContext" <+> ppr standalone
+ ppr (SupplyContext theta) = text "SupplyContext" <+> ppr theta
data DerivStatus = CanDerive -- Stock class, can derive
(SrcSpan -> TyCon -> [Type]
@@ -421,8 +476,8 @@ getDataConFixityFun tc
checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
-> TyCon -> TyCon
-> DerivStatus
-checkSideConditions dflags mtheta cls cls_tys tc rep_tc
- | Just cond <- sideConditions mtheta cls
+checkSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc
+ | Just cond <- sideConditions deriv_ctxt cls
= case (cond dflags tc rep_tc) of
NotValid err -> DerivableClassError err -- Class-specific error
IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
@@ -451,7 +506,7 @@ classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is n
-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
-- class for which stock deriving isn't possible.
sideConditions :: DerivContext -> Class -> Maybe Condition
-sideConditions mtheta cls
+sideConditions deriv_ctxt cls
| cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls)
| cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls)
| cls_key == showClassKey = Just (cond_std `andCond` cond_args cls)
@@ -485,10 +540,10 @@ sideConditions mtheta cls
| otherwise = Nothing
where
cls_key = getUnique cls
- cond_std = cond_stdOK mtheta False -- Vanilla data constructors, at least one,
- -- and monotype arguments
- cond_vanilla = cond_stdOK mtheta True -- Vanilla data constructors but
- -- allow no data cons or polytype arguments
+ cond_std = cond_stdOK deriv_ctxt False
+ -- Vanilla data constructors, at least one, and monotype arguments
+ cond_vanilla = cond_stdOK deriv_ctxt True
+ -- Vanilla data constructors but allow no data cons or polytype arguments
canDeriveAnyClass :: DynFlags -> Validity
-- IsValid: we can (try to) derive it via an empty instance declaration
@@ -542,8 +597,9 @@ andCond c1 c2 dflags tc rep_tc
--
-- 5. The data type cannot have fields with higher-rank types.
cond_stdOK
- :: DerivContext -- ^ 'Just' if this is standalone deriving, 'Nothing' if not.
- -- If it is standalone, we relax some of the validity checks
+ :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a
+ -- user-supplied context, 'InferContext' if not.
+ -- If it is the former, we relax some of the validity checks
-- we would otherwise perform (i.e., "just go for it").
-> Bool -- ^ 'True' <=> allow higher rank arguments and empty data
@@ -551,7 +607,7 @@ cond_stdOK
-- the -XEmptyDataDeriving extension.
-> Condition
-cond_stdOK mtheta permissive dflags tc rep_tc
+cond_stdOK deriv_ctxt permissive dflags tc rep_tc
= valid_ADT `andValid` valid_misc
where
valid_ADT, valid_misc :: Validity
@@ -565,25 +621,29 @@ cond_stdOK mtheta permissive dflags tc rep_tc
<+> text "data or newtype application"
valid_misc
- = case mtheta of
- Just _ -> IsValid
+ = case deriv_ctxt of
+ SupplyContext _ -> IsValid
-- Don't check these conservative conditions for
-- standalone deriving; just generate the code
-- and let the typechecker handle the result
- Nothing
+ InferContext wildcard
| null data_cons -- 1.
, not permissive
-> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`
NotValid (no_cons_why rep_tc $$ empty_data_suggestion)
| not (null con_whys)
- -> NotValid (vcat con_whys $$ standalone_suggestion)
+ -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard)
| otherwise
-> IsValid
empty_data_suggestion =
text "Use EmptyDataDeriving to enable deriving for empty data types"
- standalone_suggestion =
- text "Possible fix: use a standalone deriving declaration instead"
+ possible_fix_suggestion wildcard
+ = case wildcard of
+ Just _ ->
+ text "Possible fix: fill in the wildcard constraint yourself"
+ Nothing ->
+ text "Possible fix: use a standalone deriving declaration instead"
data_cons = tyConDataCons rep_tc
con_whys = getInvalids (map check_con data_cons)
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 1dba42d7b7..0700d02336 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -2779,13 +2779,18 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
= empty
drv_fixes = case orig of
- DerivOrigin -> [drv_fix]
- DerivOriginDC {} -> [drv_fix]
- DerivOriginCoerce {} -> [drv_fix]
+ DerivClauseOrigin -> [drv_fix False]
+ StandAloneDerivOrigin -> [drv_fix True]
+ DerivOriginDC _ _ standalone -> [drv_fix standalone]
+ DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]
_ -> []
- drv_fix = hang (text "use a standalone 'deriving instance' declaration,")
- 2 (text "so you can specify the instance context yourself")
+ drv_fix standalone_wildcard
+ | standalone_wildcard
+ = text "fill in the wildcard constraint yourself"
+ | otherwise
+ = hang (text "use a standalone 'deriving instance' declaration,")
+ 2 (text "so you can specify the instance context yourself")
-- Normal overlap error
overlap_msg
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 27482b1841..a2afe438dd 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -3359,13 +3359,24 @@ data CtOrigin
-- then TypeSize = sizeTypes [ty1, .., tyn]
-- See Note [Solving superclass constraints] in TcInstDcls
- | DerivOrigin -- Typechecking deriving
- | DerivOriginDC DataCon Int
- -- Checking constraints arising from this data con and field index
- | DerivOriginCoerce Id Type Type
+ | DerivClauseOrigin -- Typechecking a deriving clause (as opposed to
+ -- standalone deriving).
+ | DerivOriginDC DataCon Int Bool
+ -- Checking constraints arising from this data con and field index. The
+ -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if
+ -- standalong deriving (with a wildcard constraint) is being used. This
+ -- is used to inform error messages on how to recommended fixes (e.g., if
+ -- the argument is True, then don't recommend "use standalone deriving",
+ -- but rather "fill in the wildcard constraint yourself").
+ -- See Note [Inferring the instance context] in TcDerivInfer
+ | DerivOriginCoerce Id Type Type Bool
-- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from
-- `ty1` to `ty2`.
- | StandAloneDerivOrigin -- Typechecking stand-alone deriving
+ | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for
+ -- constraints coming from a wildcard constraint,
+ -- e.g., deriving instance _ => Eq (Foo a)
+ -- See Note [Inferring the instance context]
+ -- in TcDerivInfer
| DefaultOrigin -- Typechecking a default decl
| DoOrigin -- Arising from a do expression
| DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in
@@ -3558,14 +3569,14 @@ pprCtOrigin (KindEqOrigin t1 Nothing _ _)
pprCtOrigin (UnboundOccurrenceOf name)
= ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name)
-pprCtOrigin (DerivOriginDC dc n)
+pprCtOrigin (DerivOriginDC dc n _)
= hang (ctoHerald <+> text "the" <+> speakNth n
<+> text "field of" <+> quotes (ppr dc))
2 (parens (text "type" <+> quotes (ppr ty)))
where
ty = dataConOrigArgTys dc !! (n-1)
-pprCtOrigin (DerivOriginCoerce meth ty1 ty2)
+pprCtOrigin (DerivOriginCoerce meth ty1 ty2 _)
= hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth))
2 (sep [ text "from type" <+> quotes (ppr ty1)
, nest 2 $ text "to type" <+> quotes (ppr ty2) ])
@@ -3627,7 +3638,7 @@ pprCtO TupleOrigin = text "a tuple"
pprCtO NegateOrigin = text "a use of syntactic negation"
pprCtO (ScOrigin n) = text "the superclasses of an instance declaration"
<> whenPprDebug (parens (ppr n))
-pprCtO DerivOrigin = text "the 'deriving' clause of a data type declaration"
+pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration"
pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration"
pprCtO DefaultOrigin = text "a 'default' declaration"
pprCtO DoOrigin = text "a do statement"