Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 13986e8d by Simon Peyton Jones at 2025-07-21T00:18:42+01:00 Use an implication constraint in Deriv - - - - - 4 changed files: - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - testsuite/tests/deriving/should_compile/T20815.hs Changes: ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -1432,13 +1432,13 @@ See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom -- EarlyDerivSpec from it. mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec mk_eqn_from_mechanism mechanism - = do DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys - , denv_ctxt = deriv_ctxt - , denv_skol_info = skol_info - , denv_warn = warn } <- ask + = do env@(DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys + , denv_ctxt = deriv_ctxt + , denv_skol_info = skol_info + , denv_warn = warn }) <- ask user_ctxt <- askDerivUserTypeCtxt doDerivInstErrorChecks1 mechanism loc <- lift getSrcSpanM @@ -1446,7 +1446,7 @@ mk_eqn_from_mechanism mechanism case deriv_ctxt of InferContext wildcard -> do { (inferred_constraints, tvs', inst_tys', mechanism') - <- inferConstraints mechanism + <- inferConstraints mechanism env ; return $ InferTheta $ DS { ds_loc = loc , ds_name = dfun_name, ds_tvs = tvs' ===================================== compiler/GHC/Tc/Deriv/Infer.hs ===================================== @@ -66,7 +66,7 @@ import Data.Maybe ---------------------- -inferConstraints :: DerivSpecMechanism +inferConstraints :: DerivSpecMechanism -> DerivEnv -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) -- inferConstraints figures out the constraints needed for the -- instance declaration generated by a 'deriving' clause on a @@ -83,12 +83,12 @@ inferConstraints :: DerivSpecMechanism -- Generate a sufficiently large set of constraints that typechecking the -- generated method definitions should succeed. This set will be simplified -- before being used in the instance declaration -inferConstraints mechanism - = do { DerivEnv { denv_tvs = tvs - , denv_cls = main_cls - , denv_inst_tys = inst_tys } <- ask - ; wildcard <- isStandaloneWildcardDeriv - ; let infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) +inferConstraints mechanism (DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs + , denv_cls = main_cls + , denv_inst_tys = inst_tys }) + = do { let wildcard = isStandaloneWildcardDeriv ctxt + infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) infer_constraints = case mechanism of DerivSpecStock{dsm_stock_dit = dit} @@ -169,12 +169,12 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys , dit_tc_args = tc_args , dit_rep_tc = rep_tc , dit_rep_tc_args = rep_tc_args }) - = do DerivEnv { denv_tvs = tvs + = do DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs , denv_cls = main_cls , denv_inst_tys = inst_tys } <- ask - wildcard <- isStandaloneWildcardDeriv - - let inst_ty = mkTyConApp tc tc_args + let wildcard = isStandaloneWildcardDeriv ctxt + inst_ty = mkTyConApp tc tc_args tc_binders = tyConBinders rep_tc choose_level bndr | isNamedTyConBinder bndr = KindLevel @@ -370,13 +370,14 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys -- derived instance context. inferConstraintsAnyclass :: DerivM ThetaSpec inferConstraintsAnyclass - = do { DerivEnv { denv_cls = cls + = do { DerivEnv { denv_ctxt = ctxt + , denv_cls = cls , denv_inst_tys = inst_tys } <- ask ; let gen_dms = [ (sel_id, dm_ty) | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] - ; wildcard <- isStandaloneWildcardDeriv - ; let meth_pred :: (Id, Type) -> PredSpec + ; let wildcard = isStandaloneWildcardDeriv ctxt + meth_pred :: (Id, Type) -> PredSpec -- (Id,Type) are the selector Id and the generic default method type -- NB: the latter is /not/ quantified over the class variables -- See Note [Gathering and simplifying constraints for DeriveAnyClass] @@ -408,10 +409,10 @@ inferConstraintsAnyclass inferConstraintsCoerceBased :: [Type] -> Type -> DerivM ThetaSpec inferConstraintsCoerceBased cls_tys rep_ty = do - DerivEnv { denv_tvs = tvs + DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs , denv_cls = cls , denv_inst_tys = inst_tys } <- ask - sa_wildcard <- isStandaloneWildcardDeriv let -- rep_ty might come from: -- GeneralizedNewtypeDeriving / DerivSpecNewtype: -- the underlying type of the newtype () @@ -426,6 +427,7 @@ inferConstraintsCoerceBased cls_tys rep_ty = do -- we are going to get all the methods for the final -- dictionary deriv_origin = mkDerivOrigin sa_wildcard + sa_wildcard = isStandaloneWildcardDeriv ctxt -- Next we collect constraints for the class methods -- If there are no methods, we don't need any constraints @@ -574,7 +576,7 @@ Consider the `deriving Alt` part of this example (from the passing part of T20815a): class Alt f where - some :: Applicative f => f a -> f [a] + some :: forall a. Applicative f => f a -> f [a] newtype T f a = T (f a) deriving Alt ===================================== compiler/GHC/Tc/Deriv/Utils.hs ===================================== @@ -35,11 +35,11 @@ import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Deriv.Generics import GHC.Tc.Errors.Types -import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical) +import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical, mkSimpleWC) import GHC.Tc.Types.Origin import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Unify (tcSubTypeSigma) +import GHC.Tc.Utils.Unify (tcSubTypeSigma, buildImplicationFor) import GHC.Tc.Zonk.Type import GHC.Core.Class @@ -71,7 +71,6 @@ import GHC.Utils.Error import GHC.Utils.Unique (sameUnique) import Control.Monad.Trans.Reader -import Data.Foldable (traverse_) import Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Data.List.SetOps (assocMaybe) @@ -92,12 +91,9 @@ isStandaloneDeriv = asks (go . denv_ctxt) -- | 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 +isStandaloneWildcardDeriv :: DerivContext -> Bool +isStandaloneWildcardDeriv (InferContext wildcard) = isJust wildcard +isStandaloneWildcardDeriv (SupplyContext {}) = False -- | Return 'InstDeclCtxt' if processing with a standalone @deriving@ -- declaration or 'DerivClauseCtxt' if processing a @deriving@ clause. @@ -563,11 +559,17 @@ data PredSpec SimplePredSpec { sps_pred :: TcPredType -- ^ The constraint to emit as a wanted + -- Usually just a simple predicate like (Eq a) or (ki ~# Type), + -- but (hack) in the case of GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased, + -- it can be a forall-constraint + , sps_origin :: CtOrigin -- ^ The origin of the constraint + , sps_type_or_kind :: TypeOrKind -- ^ Whether the constraint is a type or kind } + | -- | A special 'PredSpec' that is only used by @DeriveAnyClass@. This -- will check if @stps_ty_actual@ is a subtype of (i.e., more polymorphic -- than) @stps_ty_expected@ in the constraint solving machinery, emitting an @@ -677,8 +679,8 @@ captureThetaSpecConstraints :: -- @deriving@ declaration -> ThetaSpec -- ^ The specs from which constraints will be created -> TcM (TcLevel, WantedConstraints) -captureThetaSpecConstraints user_ctxt theta = - pushTcLevelM $ mk_wanteds theta +captureThetaSpecConstraints user_ctxt theta + = pushTcLevelM $ mk_wanteds theta where -- Create the constraints we need to solve. For stock and newtype -- deriving, these constraints will be simple wanted constraints @@ -689,34 +691,48 @@ captureThetaSpecConstraints user_ctxt theta = mk_wanteds :: ThetaSpec -> TcM WantedConstraints mk_wanteds preds = do { (_, wanteds) <- captureConstraints $ - traverse_ emit_constraints preds + mapM_ (emitPredSpecConstraints user_ctxt) preds ; pure wanteds } - -- Emit the appropriate constraints depending on what sort of - -- PredSpec we are dealing with. - emit_constraints :: PredSpec -> TcM () - emit_constraints ps = - case ps of - -- For constraints like (C a, Ord b), emit the - -- constraints directly as simple wanted constraints. - SimplePredSpec { sps_pred = wanted - , sps_origin = orig - , sps_type_or_kind = t_or_k - } -> do - ev <- newWanted orig (Just t_or_k) wanted - emitSimple (mkNonCanonical ev) - - -- For DeriveAnyClass, check if ty_actual is a subtype of - -- ty_expected, which emits an implication constraint as a - -- side effect. See - -- Note [Gathering and simplifying constraints for DeriveAnyClass]. - -- in GHC.Tc.Deriv.Infer. - SubTypePredSpec { stps_ty_actual = ty_actual - , stps_ty_expected = ty_expected - , stps_origin = orig - } -> do - _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected - return () +emitPredSpecConstraints :: UserTypeCtxt -> PredSpec -> TcM () +--- Emit the appropriate constraints depending on what sort of +-- PredSpec we are dealing with. +emitPredSpecConstraints _ (SimplePredSpec { sps_pred = wanted_pred + , sps_origin = orig + , sps_type_or_kind = t_or_k }) + -- For constraints like (C a) or (Ord b), emit the + -- constraints directly as simple wanted constraints. + | isRhoTy wanted_pred + = do { ev <- newWanted orig (Just t_or_k) wanted_pred + ; emitSimple (mkNonCanonical ev) } + + | otherwise + -- Forall-constraints, which come exclusively from + -- GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased. + -- For these we want to emit an implication constraint, and NOT a forall-constraint + -- Why? Because forall-constraints are solved all-or-nothing, but here when we + -- are trying to infer the context for an instance decl, we need that half-solved + -- implicatation (see deriving/should_compile/T20815). + = do { let skol_info_anon = DerivSkol wanted_pred + ; skol_info <- mkSkolemInfo skol_info_anon + ; (_wrapper, tv_prs, givens, wanted_rho) <- topSkolemise skol_info wanted_pred + -- _wrapper: we ignore the evidence from all these constraints + ; (tc_lvl, ev) <- pushTcLevelM $ newWanted orig (Just t_or_k) wanted_rho + ; let skol_tvs = map (binderVar . snd) tv_prs + ; (implic, _) <- buildImplicationFor tc_lvl skol_info_anon skol_tvs + givens (mkSimpleWC [ev]) + ; emitImplications implic } + +emitPredSpecConstraints user_ctxt + (SubTypePredSpec { stps_ty_actual = ty_actual + , stps_ty_expected = ty_expected + , stps_origin = orig }) +-- For DeriveAnyClass, check if ty_actual is a subtype of ty_expected, +-- which emits an implication constraint as a side effect. See +-- Note [Gathering and simplifying constraints for DeriveAnyClass] +-- in GHC.Tc.Deriv.Infer. + = do { _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected + ; return () } {- ************************************************************************ ===================================== testsuite/tests/deriving/should_compile/T20815.hs ===================================== @@ -12,3 +12,5 @@ instance Alt [] where () = (++) newtype L a = L [a] deriving (Functor, Alt) + +newtype T f a = T (f a) deriving (Functor, Alt) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13986e8d787ab795c621c4b37734a9e0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13986e8d787ab795c621c4b37734a9e0... You're receiving this email because of your account on gitlab.haskell.org.