diff options
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 |