Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: b2adb180 by Simon Peyton Jones at 2025-07-22T11:46:58+01:00 Wibbles to deriving includign combining two DerivOrigin constructors - - - - - 5 changed files: - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/TcType.hs Changes: ===================================== compiler/GHC/Tc/Deriv/Utils.hs ===================================== @@ -107,12 +107,8 @@ askDerivUserTypeCtxt = asks (go . denv_ctxt) go (InferContext Just{}) = InstDeclCtxt True go (InferContext Nothing) = DerivClauseCtxt --- | @'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 +mkDerivOrigin standalone = DerivOrigin standalone -- | Contains all of the information known about a derived instance when -- determining what its @EarlyDerivSpec@ should be. @@ -562,8 +558,10 @@ data PredSpec { 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 + -- but can be a forall-constraint: + -- * in the case of GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased + -- * if a class has quantified-constraint superclasses, + -- via `mkDirectThetaSpec` in `inferConstraints` , sps_origin :: CtOrigin -- ^ The origin of the constraint @@ -716,13 +714,16 @@ emitPredSpecConstraints _ (SimplePredSpec { sps_pred = wanted_pred -- but here when we are trying to infer the context for an instance decl, we -- need that half-solved implication. See deriving/should_compile/T20815 -- and Note [Inferred contexts from method constraints] - = do { let skol_info_anon + = do { let (_,_,head_ty) = tcSplitQuantPredTy wanted_pred -- Yuk + skol_info_anon = case orig of DerivOriginCoerce meth _ _ _ -> MethSkol (idName meth) False + DerivOrigin _ -> InstSkol (IsQC orig) (pSizeHead head_ty) _ -> pprPanic "emitPredSpecConstraints" (ppr orig $$ ppr wanted_pred) - -- We only get a polymorphic wanted_pred from DerivOriginCoerce - -- This is a bit messy, but arises from the fact that SimplePredSpe - -- is not really simple! + -- We only get a polymorphic wanted_pred from limited places + -- This is a bit messy, but arises from the fact + -- that SimplePredSpec is not really simple! + ; 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 ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -4197,8 +4197,7 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) = empty drv_fixes = case orig of - DerivClauseOrigin -> [drv_fix False] - StandAloneDerivOrigin -> [drv_fix True] + DerivOrigin standalone -> [drv_fix standalone] DerivOriginDC _ _ standalone -> [drv_fix standalone] DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] _ -> [] ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -1374,7 +1374,7 @@ solveWantedForAll qci tvs theta body_pred ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs ; let inst_pred = substTy subst body_pred inst_theta = substTheta subst theta - skol_info_anon = InstSkol is_qc (get_size inst_pred) } + skol_info_anon = InstSkol is_qc (pSizeHead inst_pred) } ; given_ev_vars <- mapM newEvVar inst_theta ; (lvl, (w_id, wanteds)) @@ -1388,9 +1388,9 @@ solveWantedForAll qci tvs theta body_pred ; return ( wantedCtEvEvId wanted_ev , unitBag (mkNonCanonical $ CtWanted wanted_ev)) } - ; traceTcS "solveForAll {" (ppr skol_tvs $$ ppr given_ev_vars $$ ppr wanteds $$ ppr w_id) -- Try to solve the constraint completely + ; traceTcS "solveForAll {" (ppr skol_tvs $$ ppr given_ev_vars $$ ppr wanteds $$ ppr w_id) ; ev_binds_var <- TcS.newTcEvBinds ; solved <- trySolveImplication $ (implicationPrototype loc_env) @@ -1402,7 +1402,8 @@ solveWantedForAll qci tvs theta body_pred , ic_given = given_ev_vars , ic_wanted = emptyWC { wc_simple = wanteds } } ; traceTcS "solveForAll }" (ppr solved) - ; evbs <- TcS.getTcEvBindsMap ev_binds_var + + -- See if we succeeded in solving it completely ; if not solved then do { -- Not completely solved; abandon that attempt and add the -- original constraint to the inert set @@ -1410,7 +1411,8 @@ solveWantedForAll qci tvs theta body_pred ; stopWith (CtWanted wtd) "Wanted forall-constraint:unsolved" } else do { -- Completely solved; build an evidence term - setWantedEvTerm dest EvCanonical $ + evbs <- TcS.getTcEvBindsMap ev_binds_var + ; setWantedEvTerm dest EvCanonical $ EvFun { et_tvs = skol_tvs, et_given = given_ev_vars , et_binds = evBindMapBinds evbs, et_body = w_id } ; stopWith (CtWanted wtd) "Wanted forall-constraint:solved" } } @@ -1421,11 +1423,6 @@ solveWantedForAll qci tvs theta body_pred empty_subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfTypes (body_pred:theta) `delVarSetList` tvs - -- Getting the size of the head is a bit horrible - -- because of the special treament for class predicates - get_size pred = case classifyPredType pred of - ClassPred cls tys -> pSizeClassPred cls tys - _ -> pSizeType pred {- Note [Solving a Wanted forall-constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -24,6 +24,7 @@ module GHC.Tc.Types.Origin ( isWantedSuperclassOrigin, ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..), HsImplicitLiftSplice(..), + StandaloneDeriv, TypedThing(..), TyVarBndrs(..), @@ -568,9 +569,9 @@ data CtOrigin ClsInstOrQC -- Whether class instance or quantified constraint NakedScFlag - | DerivClauseOrigin -- Typechecking a deriving clause (as opposed to - -- standalone deriving). - | DerivOriginDC DataCon Int Bool + | DerivOrigin StandaloneDeriv + -- Typechecking a `deriving` clause, or a standalone `deriving` declaration + | DerivOriginDC DataCon Int StandaloneDeriv -- 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 @@ -578,14 +579,10 @@ data CtOrigin -- 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 GHC.Tc.Deriv.Infer - | DerivOriginCoerce Id Type Type Bool - -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from - -- `ty1` to `ty2`. - | 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 GHC.Tc.Deriv.Infer + | DerivOriginCoerce Id Type Type StandaloneDeriv + -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from + -- `ty1` to `ty2`. + | DefaultOrigin -- Typechecking a default decl | DoOrigin -- Arising from a do expression | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in @@ -659,6 +656,14 @@ data NonLinearPatternReason | ViewPatternReason | OtherPatternReason +type StandaloneDeriv = Bool + -- False <=> a `deriving` clause on a data/newtype declaration + -- e.g. data T a = MkT a deriving( Eq ) + -- True <=> a standalone `deriving` clause with a wildcard constraint + -- e.g deriving instance _ => Eq (T a) + -- See Note [Inferring the instance context] + -- in GHC.Tc.Deriv.Infer + -- | The number of superclass selections needed to get this Given. -- If @d :: C ty@ has @ScDepth=2@, then the evidence @d@ will look -- like @sc_sel (sc_sel dg)@, where @dg@ is a Given. @@ -929,8 +934,9 @@ pprCtO TupleOrigin = text "a tuple" pprCtO NegateOrigin = text "a use of syntactic negation" pprCtO (ScOrigin IsClsInst _) = text "the superclasses of an instance declaration" pprCtO (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint" -pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" -pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" +pprCtO (DerivOrigin standalone) + | standalone = text "a 'deriving' declaration" + | otherwise = text "the 'deriving' clause of a data type declaration" pprCtO DefaultOrigin = text "a 'default' declaration" pprCtO DoOrigin = text "a do statement" pprCtO MCompOrigin = text "a statement in a monad comprehension" ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -130,7 +130,7 @@ module GHC.Tc.Utils.TcType ( pSizeZero, pSizeOne, pSizeType, pSizeTypeX, pSizeTypes, pSizeClassPred, pSizeClassPredX, - pSizeTyConApp, + pSizeTyConApp, pSizeHead, noMoreTyVars, allDistinctTyVars, TypeSize, sizeType, sizeTypes, scopedSort, isTerminatingClass, isStuckTypeFamily, @@ -2364,6 +2364,13 @@ pSizeTyFamApp tc | isStuckTypeFamily tc = pSizeZero | otherwise = PS_TyFam tc +pSizeHead :: PredType -> PatersonSize +-- Getting the size of an instance head is a bit horrible +-- because of the special treament for class predicates +pSizeHead pred = case classifyPredType pred of + ClassPred cls tys -> pSizeClassPred cls tys + _ -> pSizeType pred + pSizeClassPred :: Class -> [Type] -> PatersonSize pSizeClassPred = pSizeClassPredX emptyVarSet View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b2adb18098229b56de3a1a6883ffac65... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b2adb18098229b56de3a1a6883ffac65... You're receiving this email because of your account on gitlab.haskell.org.