diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2018-03-23 12:06:04 -0400 |
---|---|---|
committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2018-03-23 12:06:05 -0400 |
commit | affdea82bb70e5a912b679a169c6e9a230e4c93e (patch) | |
tree | 1200f0f3cb2735a45017be61808b709f24c4db49 | |
parent | d5577f44eaf3b9dfdfc77828038782bf818c176a (diff) | |
download | haskell-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
21 files changed, 400 insertions, 120 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" diff --git a/docs/users_guide/8.6.1-notes.rst b/docs/users_guide/8.6.1-notes.rst index 1e3f509843..04ff09c888 100644 --- a/docs/users_guide/8.6.1-notes.rst +++ b/docs/users_guide/8.6.1-notes.rst @@ -21,6 +21,16 @@ Full details Language ~~~~~~~~ +- GHC now permits the use of a wildcard type as the context of a standalone + ``deriving`` declaration with the use of the + :extension:`PartialTypeSignatures` language extension. For instance, this + declaration: :: + + deriving instance _ => Eq (Foo a) + + Denotes a derived ``Eq (Foo a)`` instance, where the context is inferred in + much the same way as ordinary ``deriving`` clauses do. + See :ref:`partial-type-signatures`. - Data declarations with empty ``where`` clauses are no longer valid without the extension :extension:`GADTSyntax` enabled. For instance, consider the diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 1717cbb0b2..0cb8a6ae50 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -3908,11 +3908,21 @@ number of important ways: module as the data type declaration. (But be aware of the dangers of orphan instances (:ref:`orphan-modules`). -- You must supply an explicit context (in the example the context is - ``(Eq a)``), exactly as you would in an ordinary instance +- In most cases, you must supply an explicit context (in the example the + context is ``(Eq a)``), exactly as you would in an ordinary instance declaration. (In contrast, in a ``deriving`` clause attached to a data type declaration, the context is inferred.) + The exception to this rule is that the context of a standalone deriving + declaration can infer its context when a single, extra-wildcards constraint + is used as the context, such as in: :: + + deriving instance _ => Eq (Foo a) + + This is essentially the same as if you had written ``deriving Foo`` after + the declaration for ``data Foo a``. Using this feature requires the use of + :extension:`PartialTypeSignatures` (:ref:`partial-type-signatures`). + - Unlike a ``deriving`` declaration attached to a ``data`` declaration, the instance can be more specific than the data type (assuming you also use :extension:`FlexibleInstances`, :ref:`instance-rules`). Consider @@ -11568,6 +11578,15 @@ Anonymous wildcards are also allowed in visible type applications argument to ``wurble``, then you can say ``wurble @_ @Int`` where the first argument is a wildcard. +Standalone ``deriving`` declarations permit the use of a single, +extra-constraints wildcard, like so: :: + + deriving instance _ => Eq (Foo a) + +This denotes a derived ``Eq (Foo a)`` instance where the context is inferred, +in much the same way that ordinary ``deriving`` clauses do. Any other use of +wildcards in a standalone ``deriving`` declaration is prohibited. + In all other contexts, type wildcards are disallowed, and a named wildcard is treated as an ordinary type variable. For example: :: diff --git a/testsuite/tests/partial-sigs/should_compile/T13324_compile.hs b/testsuite/tests/partial-sigs/should_compile/T13324_compile.hs new file mode 100644 index 0000000000..670744e668 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/T13324_compile.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +module T13324_compile where + +data Option a = None | Some a + +deriving instance _ => Show (Option a) diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T index ebf6338c86..0a0483b139 100644 --- a/testsuite/tests/partial-sigs/should_compile/all.T +++ b/testsuite/tests/partial-sigs/should_compile/all.T @@ -69,6 +69,7 @@ test('T12156', normal, compile_fail, ['-fdefer-typed-holes']) test('T12531', normal, compile, ['-fdefer-typed-holes']) test('T12845', normal, compile, ['']) test('T12844', normal, compile, ['']) +test('T13324_compile', normal, compile, ['-Wno-partial-type-signatures']) test('T13482', normal, compile, ['']) test('T14217', normal, compile_fail, ['']) test('T14643', normal, compile, ['']) diff --git a/testsuite/tests/partial-sigs/should_fail/T13324_fail1.hs b/testsuite/tests/partial-sigs/should_fail/T13324_fail1.hs new file mode 100644 index 0000000000..a177cbdbd9 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/T13324_fail1.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +module T13324_fail1 where + +data Option a = None | Some a + +deriving instance (Eq a, _) => Eq (Option a) +deriving instance (Show _) => Show (Option a) diff --git a/testsuite/tests/partial-sigs/should_fail/T13324_fail1.stderr b/testsuite/tests/partial-sigs/should_fail/T13324_fail1.stderr new file mode 100644 index 0000000000..dd3a9948f9 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/T13324_fail1.stderr @@ -0,0 +1,10 @@ + +T13324_fail1.hs:7:26: error: + Extra-constraint wildcard ‘_’ not allowed + except as the sole constraint + e.g., deriving instance _ => Eq (Foo a) + in a deriving declaration + +T13324_fail1.hs:8:25: error: + Wildcard ‘_’ not allowed + in a deriving declaration diff --git a/testsuite/tests/partial-sigs/should_fail/T13324_fail2.hs b/testsuite/tests/partial-sigs/should_fail/T13324_fail2.hs new file mode 100644 index 0000000000..41f36c7b20 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/T13324_fail2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +module T13324_fail2 where + +newtype Foo f a = Foo (f (f a)) +deriving instance _ => Eq (Foo f a) + +data T a where + MkT :: T Int +deriving instance _ => Eq (T a) diff --git a/testsuite/tests/partial-sigs/should_fail/T13324_fail2.stderr b/testsuite/tests/partial-sigs/should_fail/T13324_fail2.stderr new file mode 100644 index 0000000000..75e4829cdb --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/T13324_fail2.stderr @@ -0,0 +1,12 @@ + +T13324_fail2.hs:7:1: error: + • No instance for (Eq (f (f a))) + arising from a 'deriving' declaration + Possible fix: fill in the wildcard constraint yourself + • When deriving the instance for (Eq (Foo f a)) + +T13324_fail2.hs:11:1: error: + • Can't make a derived instance of ‘Eq (T a)’: + Constructor ‘MkT’ is a GADT + Possible fix: fill in the wildcard constraint yourself + • In the stand-alone deriving instance for ‘_ => Eq (T a)’ diff --git a/testsuite/tests/partial-sigs/should_fail/all.T b/testsuite/tests/partial-sigs/should_fail/all.T index 0f7496d1f5..2439f64e14 100644 --- a/testsuite/tests/partial-sigs/should_fail/all.T +++ b/testsuite/tests/partial-sigs/should_fail/all.T @@ -64,6 +64,8 @@ test('PatBind3', normal, compile_fail, ['']) test('T12039', normal, compile_fail, ['']) test('T12634', normal, compile_fail, ['']) test('T12732', normal, compile_fail, ['-fobject-code -fdefer-typed-holes']) +test('T13324_fail1', normal, compile_fail, ['']) +test('T13324_fail2', normal, compile_fail, ['']) test('T14040a', normal, compile_fail, ['']) test('T14449', normal, compile_fail, ['']) test('T14479', normal, compile_fail, ['']) diff --git a/utils/haddock b/utils/haddock -Subproject 4804e39144dc0ded9b38dbb3442b6016ac719a1 +Subproject 067d52fd4be15a1842cbb05f42d9d482de0ad3a |