Commit affdea82 authored by Ryan Scott's avatar Ryan Scott
Browse files

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
parent d5577f44
......@@ -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 })
......
......@@ -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)
......
......@@ -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',
......
......@@ -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] } }
-----------------------------------------------------------------------------
......
......@@ -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
......
......@@ -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
......
......@@ -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))
......@@ -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)