Commit affdea82 authored by Ryan Scott's avatar Ryan Scott

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 ...@@ -488,7 +488,7 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
; repDeriv strat' cxt' inst_ty' } ; repDeriv strat' cxt' inst_ty' }
; return (loc, dec) } ; return (loc, dec) }
where where
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ) repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
......
...@@ -351,7 +351,7 @@ cvtDec (TH.StandaloneDerivD ds cxt ty) ...@@ -351,7 +351,7 @@ cvtDec (TH.StandaloneDerivD ds cxt ty)
; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty' ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
; returnJustL $ DerivD $ ; returnJustL $ DerivD $
DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
, deriv_type = mkLHsSigType inst_ty' , deriv_type = mkLHsSigWcType inst_ty'
, deriv_overlap_mode = Nothing } } , deriv_overlap_mode = Nothing } }
cvtDec (TH.DefaultSigD nm typ) cvtDec (TH.DefaultSigD nm typ)
......
...@@ -1659,7 +1659,18 @@ type LDerivDecl pass = Located (DerivDecl pass) ...@@ -1659,7 +1659,18 @@ type LDerivDecl pass = Located (DerivDecl pass)
-- | Deriving Declaration -- | Deriving Declaration
data DerivDecl pass = DerivDecl 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_strategy :: Maybe (Located DerivStrategy)
, deriv_overlap_mode :: Maybe (Located OverlapMode) , deriv_overlap_mode :: Maybe (Located OverlapMode)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',
......
...@@ -1376,7 +1376,8 @@ stand_alone_deriving :: { LDerivDecl GhcPs } ...@@ -1376,7 +1376,8 @@ stand_alone_deriving :: { LDerivDecl GhcPs }
: 'deriving' deriv_strategy 'instance' overlap_pragma inst_type : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type
{% do { let { err = text "in the stand-alone deriving instance" {% do { let { err = text "in the stand-alone deriving instance"
<> colon <+> quotes (ppr $5) } <> 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] } } [mj AnnDeriving $1, mj AnnInstance $3] } }
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
......
...@@ -945,7 +945,7 @@ rnSrcDerivDecl (DerivDecl ty deriv_strat overlap) ...@@ -945,7 +945,7 @@ rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)
; unless standalone_deriv_ok (addErr standaloneDerivErr) ; unless standalone_deriv_ok (addErr standaloneDerivErr)
; failIfTc (isJust deriv_strat && not deriv_strats_ok) $ ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $
illegalDerivStrategyErr $ fmap unLoc deriv_strat 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) } ; return (DerivDecl ty' deriv_strat overlap, fvs) }
standaloneDerivErr :: SDoc standaloneDerivErr :: SDoc
......
...@@ -170,7 +170,7 @@ rnWcBody ctxt nwc_rdrs hs_ty ...@@ -170,7 +170,7 @@ rnWcBody ctxt nwc_rdrs hs_ty
, L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
= do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
; wc' <- setSrcSpan lx $ ; wc' <- setSrcSpan lx $
do { checkExtraConstraintWildCard env wc do { checkExtraConstraintWildCard env hs_ctxt1 wc
; rnAnonWildCard wc } ; rnAnonWildCard wc }
; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')] ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
...@@ -188,26 +188,46 @@ rnWcBody ctxt nwc_rdrs hs_ty ...@@ -188,26 +188,46 @@ rnWcBody ctxt nwc_rdrs hs_ty
rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs checkExtraConstraintWildCard
-> RnM () :: RnTyKiEnv -> HsContext GhcPs -> HsWildCardInfo GhcPs -> RnM ()
-- Rename the extra-constraint spot in a type signature -- Rename the extra-constraint spot in a type signature
-- (blah, _) => type -- (blah, _) => type
-- Check that extra-constraints are allowed at all, and -- Check that extra-constraints are allowed at all, and
-- if so that it's an anonymous wildcard -- if so that it's an anonymous wildcard
checkExtraConstraintWildCard env wc checkExtraConstraintWildCard env hs_ctxt wc
= checkWildCard env mb_bad = checkWildCard env mb_bad
where where
mb_bad | not (extraConstraintWildCardsAllowed env) mb_bad | not (extraConstraintWildCardsAllowed env)
= Just (text "Extra-constraint wildcard" <+> quotes (ppr wc) = Just base_msg
<+> text "not allowed") -- 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 | otherwise
= Nothing = 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 :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed env extraConstraintWildCardsAllowed env
= case rtke_ctxt env of = case rtke_ctxt env of
TypeSigCtx {} -> True TypeSigCtx {} -> True
ExprWithTySigCtx {} -> True ExprWithTySigCtx {} -> True
DerivDeclCtx {} -> True
_ -> False _ -> False
-- | Finds free type and kind variables in a type, -- | Finds free type and kind variables in a type,
...@@ -324,7 +344,7 @@ rnImplicitBndrs bind_free_tvs doc ...@@ -324,7 +344,7 @@ rnImplicitBndrs bind_free_tvs doc
thing_inside vars } thing_inside vars }
rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) 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" -- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma"
-- Do not try to decompose the inst_ty in case it is malformed -- Do not try to decompose the inst_ty in case it is malformed
rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
......
...@@ -613,10 +613,11 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode)) ...@@ -613,10 +613,11 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
; let deriv_strat = fmap unLoc deriv_strat' ; let deriv_strat = fmap unLoc deriv_strat'
; traceTc "Deriving strategy (standalone deriving)" $ ; traceTc "Deriving strategy (standalone deriving)" $
vcat [ppr deriv_strat, ppr deriv_ty] 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 ; traceTc "Standalone deriving;" $ vcat
[ text "tvs:" <+> ppr tvs [ text "tvs:" <+> ppr tvs
, text "theta:" <+> ppr theta , text "deriv_ctxt:" <+> ppr deriv_ctxt
, text "cls:" <+> ppr cls , text "cls:" <+> ppr cls
, text "tys:" <+> ppr inst_tys ] , text "tys:" <+> ppr inst_tys ]
-- C.f. TcInstDcls.tcLocalInstDecl1 -- C.f. TcInstDcls.tcLocalInstDecl1
...@@ -641,13 +642,58 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode)) ...@@ -641,13 +642,58 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
| otherwise | otherwise
-> Just <$> mkEqnHelp (fmap unLoc overlap_mode) -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)
tvs cls cls_tys tc tc_args tvs cls cls_tys tc tc_args
(Just theta) deriv_strat deriv_ctxt deriv_strat
_ -> -- Complain about functions, primitive types, etc, _ -> -- Complain about functions, primitive types, etc,
bale_out $ bale_out $
text "The last argument of the instance must be a data or newtype application" 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 :: TcM ()
warnUselessTypeable warnUselessTypeable
= do { warn <- woptM Opt_WarnDerivingTypeable = do { warn <- woptM Opt_WarnDerivingTypeable
...@@ -659,7 +705,7 @@ warnUselessTypeable ...@@ -659,7 +705,7 @@ warnUselessTypeable
deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance
-- Can be a data instance, hence [Type] args -- Can be a data instance, hence [Type] args
-> Maybe DerivStrategy -- The optional deriving strategy -> Maybe DerivStrategy -- The optional deriving strategy
-> LHsSigType GhcRn -- The deriving predicate -> LHsSigType GhcRn -- The deriving predicate
-> TcM (Maybe EarlyDerivSpec) -> TcM (Maybe EarlyDerivSpec)
-- The deriving clause of a data or newtype declaration -- The deriving clause of a data or newtype declaration
-- I.e. not standalone deriving -- I.e. not standalone deriving
...@@ -667,7 +713,8 @@ deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance ...@@ -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 -- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays. -- a no-op nowadays.
deriveTyData tvs tc tc_args deriv_strat deriv_pred 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) do { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
<- tcExtendTyVarEnv tvs $ <- tcExtendTyVarEnv tvs $
tcHsDeriv deriv_pred tcHsDeriv deriv_pred
...@@ -754,7 +801,7 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred ...@@ -754,7 +801,7 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
; spec <- mkEqnHelp Nothing tkvs ; spec <- mkEqnHelp Nothing tkvs
cls final_cls_tys tc final_tc_args cls final_cls_tys tc final_tc_args
Nothing deriv_strat (InferContext Nothing) deriv_strat
; traceTc "derivTyData" (ppr spec) ; traceTc "derivTyData" (ppr spec)
; return $ Just spec } } ; return $ Just spec } }
...@@ -932,8 +979,10 @@ mkEqnHelp :: Maybe OverlapMode ...@@ -932,8 +979,10 @@ mkEqnHelp :: Maybe OverlapMode
-> [TyVar] -> [TyVar]
-> Class -> [Type] -> Class -> [Type]
-> TyCon -> [Type] -> TyCon -> [Type]
-> DerivContext -- Just => context supplied (standalone deriving) -> DerivContext
-- Nothing => context inferred (deriving on data decl) -- SupplyContext => context supplied (standalone deriving)
-- InferContext => context inferred (deriving on data decl, or
-- standalone deriving decl with a wildcard)
-> Maybe DerivStrategy -> Maybe DerivStrategy
-> TcRn EarlyDerivSpec -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance -- Make the EarlyDerivSpec for an instance
...@@ -941,7 +990,7 @@ mkEqnHelp :: Maybe OverlapMode ...@@ -941,7 +990,7 @@ mkEqnHelp :: Maybe OverlapMode
-- where the 'theta' is optional (that's the Maybe part) -- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded -- 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 = do { -- Find the instance of a data family
-- Note [Looking up family instances for deriving] -- Note [Looking up family instances for deriving]
fam_envs <- tcGetFamInstEnvs fam_envs <- tcGetFamInstEnvs
...@@ -963,7 +1012,7 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat ...@@ -963,7 +1012,7 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
, denv_tc_args = tc_args , denv_tc_args = tc_args
, denv_rep_tc = rep_tc , denv_rep_tc = rep_tc
, denv_rep_tc_args = rep_tc_args , denv_rep_tc_args = rep_tc_args
, denv_mtheta = mtheta , denv_ctxt = deriv_ctxt
, denv_strat = deriv_strat } , denv_strat = deriv_strat }
; flip runReaderT deriv_env $ ; flip runReaderT deriv_env $
if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn } if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn }
...@@ -1063,14 +1112,14 @@ mk_data_eqn mechanism ...@@ -1063,14 +1112,14 @@ mk_data_eqn mechanism
, denv_rep_tc = rep_tc , denv_rep_tc = rep_tc
, denv_cls = cls , denv_cls = cls
, denv_cls_tys = cls_tys , denv_cls_tys = cls_tys
, denv_mtheta = mtheta } <- ask , denv_ctxt = deriv_ctxt } <- ask
let inst_ty = mkTyConApp tc tc_args let inst_ty = mkTyConApp tc tc_args
inst_tys = cls_tys ++ [inst_ty] inst_tys = cls_tys ++ [inst_ty]
doDerivInstErrorChecks1 mechanism doDerivInstErrorChecks1 mechanism
loc <- lift getSrcSpanM loc <- lift getSrcSpanM
dfun_name <- lift $ newDFunName' cls tc dfun_name <- lift $ newDFunName' cls tc
case mtheta of case deriv_ctxt of
Nothing -> -- Infer context InferContext wildcard ->
do { (inferred_constraints, tvs', inst_tys') do { (inferred_constraints, tvs', inst_tys')
<- inferConstraints mechanism <- inferConstraints mechanism
; return $ InferTheta $ DS ; return $ InferTheta $ DS
...@@ -1080,9 +1129,10 @@ mk_data_eqn mechanism ...@@ -1080,9 +1129,10 @@ mk_data_eqn mechanism
, ds_tc = rep_tc , ds_tc = rep_tc
, ds_theta = inferred_constraints , ds_theta = inferred_constraints
, ds_overlap = overlap_mode , ds_overlap = overlap_mode
, ds_standalone_wildcard = wildcard
, ds_mechanism = mechanism } } , ds_mechanism = mechanism } }
Just theta -> do -- Specified context SupplyContext theta ->
return $ GivenTheta $ DS return $ GivenTheta $ DS
{ ds_loc = loc { ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs , ds_name = dfun_name, ds_tvs = tvs
...@@ -1090,6 +1140,7 @@ mk_data_eqn mechanism ...@@ -1090,6 +1140,7 @@ mk_data_eqn mechanism
, ds_tc = rep_tc , ds_tc = rep_tc
, ds_theta = theta , ds_theta = theta
, ds_overlap = overlap_mode , ds_overlap = overlap_mode
, ds_standalone_wildcard = Nothing
, ds_mechanism = mechanism } , ds_mechanism = mechanism }
mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec) mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
...@@ -1100,9 +1151,9 @@ mk_eqn_stock go_for_it bale_out ...@@ -1100,9 +1151,9 @@ mk_eqn_stock go_for_it bale_out
, denv_rep_tc = rep_tc , denv_rep_tc = rep_tc
, denv_cls = cls , denv_cls = cls
, denv_cls_tys = cls_tys , denv_cls_tys = cls_tys
, denv_mtheta = mtheta } <- ask , denv_ctxt = deriv_ctxt } <- ask
dflags <- getDynFlags 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 CanDerive gen_fn -> go_for_it $ DerivSpecStock gen_fn
DerivableClassError msg -> bale_out msg DerivableClassError msg -> bale_out msg
_ -> bale_out (nonStdErr cls) _ -> bale_out (nonStdErr cls)
...@@ -1124,7 +1175,7 @@ mk_eqn_no_mechanism go_for_it bale_out ...@@ -1124,7 +1175,7 @@ mk_eqn_no_mechanism go_for_it bale_out
, denv_rep_tc = rep_tc , denv_rep_tc = rep_tc
, denv_cls = cls , denv_cls = cls
, denv_cls_tys = cls_tys , denv_cls_tys = cls_tys
, denv_mtheta = mtheta } <- ask , denv_ctxt = deriv_ctxt } <- ask
dflags <- getDynFlags dflags <- getDynFlags
-- See Note [Deriving instances for classes themselves] -- See Note [Deriving instances for classes themselves]
...@@ -1136,7 +1187,7 @@ mk_eqn_no_mechanism go_for_it bale_out ...@@ -1136,7 +1187,7 @@ mk_eqn_no_mechanism go_for_it bale_out
| otherwise | otherwise
= nonStdErr cls $$ msg = 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 -- NB: pass the *representation* tycon to checkSideConditions
NonDerivableClass msg -> bale_out (dac_error msg) NonDerivableClass msg -> bale_out (dac_error msg)
DerivableClassError msg -> bale_out msg DerivableClassError msg -> bale_out msg
...@@ -1162,8 +1213,9 @@ mkNewTypeEqn ...@@ -1162,8 +1213,9 @@ mkNewTypeEqn
, denv_rep_tc_args = rep_tc_args , denv_rep_tc_args = rep_tc_args
, denv_cls = cls , denv_cls = cls
, denv_cls_tys = cls_tys , denv_cls_tys = cls_tys
, denv_mtheta = mtheta , denv_ctxt = deriv_ctxt
, denv_strat = mb_strat } <- ask , denv_strat = mb_strat } <- ask
sa_wildcard <- isStandaloneWildcardDeriv
dflags <- getDynFlags dflags <- getDynFlags
let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags
...@@ -1175,22 +1227,24 @@ mkNewTypeEqn ...@@ -1175,22 +1227,24 @@ mkNewTypeEqn
doDerivInstErrorChecks1 mechanism doDerivInstErrorChecks1 mechanism
dfun_name <- lift $ newDFunName' cls tycon dfun_name <- lift $ newDFunName' cls tycon
loc <- lift getSrcSpanM loc <- lift getSrcSpanM
case mtheta of case deriv_ctxt of
Just theta -> return $ GivenTheta $ DS SupplyContext theta -> return $ GivenTheta $ DS
{ ds_loc = loc { ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs , ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys , ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tycon , ds_tc = rep_tycon
, ds_theta = theta , ds_theta = theta
, ds_overlap = overlap_mode , ds_overlap = overlap_mode
, ds_standalone_wildcard = Nothing
, ds_mechanism = mechanism } , ds_mechanism = mechanism }
Nothing -> return $ InferTheta $ DS InferContext wildcard -> return $ InferTheta $ DS
{ ds_loc = loc { ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs , ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys , ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tycon , ds_tc = rep_tycon
, ds_theta = all_thetas , ds_theta = all_thetas
, ds_overlap = overlap_mode , ds_overlap = overlap_mode
, ds_standalone_wildcard = wildcard
, ds_mechanism = mechanism } , ds_mechanism = mechanism }
bale_out = bale_out' newtype_deriving bale_out = bale_out' newtype_deriving
bale_out' b msg = do err <- derivingThingErrM b msg bale_out' b msg = do err <- derivingThingErrM b msg
...@@ -1250,7 +1304,7 @@ mkNewTypeEqn ...@@ -1250,7 +1304,7 @@ mkNewTypeEqn
rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
rep_tys = cls_tys ++ [rep_inst_ty] rep_tys = cls_tys ++ [rep_inst_ty]
rep_pred = mkClassPred cls rep_tys 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 -- rep_pred is the representation dictionary, from where
-- we are gong to get all the methods for the newtype -- we are gong to get all the methods for the newtype
-- dictionary -- dictionary
...@@ -1261,9 +1315,10 @@ mkNewTypeEqn ...@@ -1261,9 +1315,10 @@ mkNewTypeEqn
cls_tyvars = classTyVars cls cls_tyvars = classTyVars cls
inst_ty = mkTyConApp tycon tc_args inst_ty = mkTyConApp tycon tc_args
inst_tys = cls_tys ++ [inst_ty] 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) $ substTheta (zipTvSubst cls_tyvars inst_tys) $
classSCTheta cls classSCTheta cls
deriv_origin = mkDerivOrigin sa_wildcard
-- Next we collect constraints for the class methods -- Next we collect constraints for the class methods
-- If there are no methods, we don't need any constraints -- If there are no methods, we don't need any constraints
...@@ -1275,8 +1330,8 @@ mkNewTypeEqn ...@@ -1275,8 +1330,8 @@ mkNewTypeEqn
-- (Trac #12814) -- (Trac #12814)
| otherwise = rep_pred_o : coercible_constraints | otherwise = rep_pred_o : coercible_constraints
coercible_constraints coercible_constraints
= [ mkPredOrigin (DerivOriginCoerce meth t1 t2) TypeLevel = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)
(mkReprPrimEqPred t1 t2) TypeLevel (mkReprPrimEqPred t1 t2)
| meth <- meths | meth <- meths
, let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs
inst_tys rep_inst_ty meth ] inst_tys rep_inst_ty meth ]
...@@ -1367,7 +1422,7 @@ mkNewTypeEqn ...@@ -1367,7 +1422,7 @@ mkNewTypeEqn
|| std_class_via_coercible cls) || std_class_via_coercible cls)
-> go_for_it_gnd -> go_for_it_gnd
| otherwise | otherwise
-> case checkSideConditions dflags mtheta cls cls_tys -> case checkSideConditions dflags deriv_ctxt cls cls_tys
tycon rep_tycon of tycon rep_tycon of
DerivableClassError msg DerivableClassError msg
-- There's a particular corner case where -- There's a particular corner case where
...@@ -1629,13 +1684,14 @@ genInst :: DerivSpec theta ...@@ -1629,13 +1684,14 @@ genInst :: DerivSpec theta
-- See Note [Staging of tcDeriving] -- See Note [Staging of tcDeriving]
genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
, ds_mechanism = mechanism, ds_tys = tys , 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) = do (meth_binds, deriv_stuff, unusedNames)
<- set_span_and_ctxt $ <- set_span_and_ctxt $
genDerivStuff mechanism loc clas rep_tycon tys tvs genDerivStuff mechanism loc clas rep_tycon tys tvs
let mk_inst_info theta = set_span_and_ctxt $ do let mk_inst_info theta = set_span_and_ctxt $ do
inst_spec <- newDerivClsInst theta spec inst_spec <- newDerivClsInst theta spec
doDerivInstErrorChecks2 clas inst_spec mechanism doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism
traceTc "newder" (ppr inst_spec) traceTc "newder" (ppr inst_spec)
return $ InstInfo return $ InstInfo
{ iSpec = inst_spec { iSpec = inst_spec
...@@ -1662,14 +1718,14 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon ...@@ -1662,14 +1718,14 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon