diff options
| author | Richard Eisenberg <rae@richarde.dev> | 2022-02-18 23:29:52 +0100 |
|---|---|---|
| committer | Matthew Pickering <matthewtpickering@gmail.com> | 2022-02-22 18:17:00 +0000 |
| commit | e7ded241f5a59004e30cfa58da1bc84716b3a5e3 (patch) | |
| tree | 404c8bdd3171b159f9099381585e1252acd9145b /compiler/GHC | |
| parent | 6b468f7f6185e68ccdea547beb090092b77cf87e (diff) | |
| download | haskell-e7ded241f5a59004e30cfa58da1bc84716b3a5e3.tar.gz | |
Kill derived constraintswip/derived-refactor
Co-authored by: Sam Derbyshire
Previously, GHC had three flavours of constraint:
Wanted, Given, and Derived. This removes Derived constraints.
Though serving a number of purposes, the most important role
of Derived constraints was to enable better error messages.
This job has been taken over by the new RewriterSets, as explained
in Note [Wanteds rewrite wanteds] in GHC.Tc.Types.Constraint.
Other knock-on effects:
- Various new Notes as I learned about under-described bits of GHC
- A reshuffling around the AST for implicit-parameter bindings,
with better integration with TTG.
- Various improvements around fundeps. These were caused by the
fact that, previously, fundep constraints were all Derived,
and Derived constraints would get dropped. Thus, an unsolved
Derived didn't stop compilation. Without Derived, this is no
longer possible, and so we have to be considerably more careful
around fundeps.
- A nice little refactoring in GHC.Tc.Errors to center the work
on a new datatype called ErrorItem. Constraints are converted
into ErrorItems at the start of processing, and this allows for
a little preprocessing before the main classification.
- This commit also cleans up the behavior in generalisation around
functional dependencies. Now, if a variable is determined by
functional dependencies, it will not be quantified. This change
is user facing, but it should trim down GHC's strange behavior
around fundeps.
- Previously, reportWanteds did quite a bit of work, even on an empty
WantedConstraints. This commit adds a fast path.
- Now, GHC will unconditionally re-simplify constraints during
quantification. See Note [Unconditionally resimplify constraints when
quantifying], in GHC.Tc.Solver.
Close #18398.
Close #18406.
Solve the fundep-related non-confluence in #18851.
Close #19131.
Close #19137.
Close #20922.
Close #20668.
Close #19665.
-------------------------
Metric Decrease:
LargeRecord
T9872b
T9872b_defer
T9872d
TcPlugin_RewritePerf
-------------------------
Diffstat (limited to 'compiler/GHC')
53 files changed, 2998 insertions, 3074 deletions
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index ef6d4af5ec..22f3c32201 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -122,8 +122,7 @@ module GHC.Core.Coercion ( multToCo, - hasCoercionHoleTy, hasCoercionHoleCo, - HoleSet, coercionHolesOfType, coercionHolesOfCo, + hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy, setCoHoleType ) where @@ -156,7 +155,6 @@ import GHC.Builtin.Types.Prim import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Types.Unique.FM -import GHC.Types.Unique.Set import GHC.Utils.Misc import GHC.Utils.Outputable @@ -2725,16 +2723,13 @@ has_co_hole_co :: Coercion -> Monoid.Any (has_co_hole_ty, _, has_co_hole_co, _) = foldTyCo folder () where - folder = TyCoFolder { tcf_view = const Nothing + folder = TyCoFolder { tcf_view = noView , tcf_tyvar = const2 (Monoid.Any False) , tcf_covar = const2 (Monoid.Any False) , tcf_hole = const2 (Monoid.Any True) , tcf_tycobinder = const2 } - const2 :: a -> b -> c -> a - const2 x _ _ = x - -- | Is there a coercion hole in this type? hasCoercionHoleTy :: Type -> Bool hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty @@ -2743,19 +2738,16 @@ hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty hasCoercionHoleCo :: Coercion -> Bool hasCoercionHoleCo = Monoid.getAny . has_co_hole_co --- | A set of 'CoercionHole's -type HoleSet = UniqSet CoercionHole - --- | Extract out all the coercion holes from a given type -coercionHolesOfType :: Type -> UniqSet CoercionHole -coercionHolesOfCo :: Coercion -> UniqSet CoercionHole -(coercionHolesOfType, _, coercionHolesOfCo, _) = foldTyCo folder () +hasThisCoercionHoleTy :: Type -> CoercionHole -> Bool +hasThisCoercionHoleTy ty hole = Monoid.getAny (f ty) where - folder = TyCoFolder { tcf_view = const Nothing -- don't look through synonyms - , tcf_tyvar = \ _ _ -> mempty - , tcf_covar = \ _ _ -> mempty - , tcf_hole = const unitUniqSet - , tcf_tycobinder = \ _ _ _ -> () + (f, _, _, _) = foldTyCo folder () + + folder = TyCoFolder { tcf_view = noView + , tcf_tyvar = const2 (Monoid.Any False) + , tcf_covar = const2 (Monoid.Any False) + , tcf_hole = \ _ h -> Monoid.Any (getUnique h == getUnique hole) + , tcf_tycobinder = const2 } -- | Set the type of a 'CoercionHole' diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs index bf6d10f0f7..3de166364b 100644 --- a/compiler/GHC/Core/Predicate.hs +++ b/compiler/GHC/Core/Predicate.hs @@ -30,6 +30,7 @@ module GHC.Core.Predicate ( -- Implicit parameters isIPLikePred, hasIPSuperClasses, isIPTyCon, isIPClass, isCallStackTy, isCallStackPred, isCallStackPredTy, + isIPPred_maybe, -- Evidence variables DictId, isEvVar, isDictId @@ -51,7 +52,9 @@ import GHC.Builtin.Types.Prim ( concretePrimTyCon ) import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Data.FastString( FastString ) +import GHC.Data.FastString + +import Control.Monad ( guard ) -- | A predicate in the solver. The solver tries to prove Wanted predicates @@ -351,6 +354,15 @@ isCallStackTy ty = False +-- | Decomposes a predicate if it is an implicit parameter. Does not look in +-- superclasses. See also [Local implicit parameters]. +isIPPred_maybe :: Type -> Maybe (FastString, Type) +isIPPred_maybe ty = + do (tc,[t1,t2]) <- splitTyConApp_maybe ty + guard (isIPTyCon tc) + x <- isStrLitTy t1 + return (x,t2) + {- Note [Local implicit parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The function isIPLikePred tells if this predicate, or any of its @@ -380,7 +392,7 @@ Several wrinkles instantiate and check each superclass, one by one, in hasIPSuperClasses. -* With -XRecursiveSuperClasses, the superclass hunt can go on forever, +* With -XUndecidableSuperClasses, the superclass hunt can go on forever, so we need a RecTcChecker to cut it off. * Another apparent additional complexity involves type families. For diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs index 28929f37f9..e837132fc0 100644 --- a/compiler/GHC/Core/TyCo/FVs.hs +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -265,9 +265,6 @@ runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet {-# INLINE runTyCoVars #-} runTyCoVars f = appEndo f emptyVarSet -noView :: Type -> Maybe Type -noView _ = Nothing - {- ********************************************************************* * * Deep free variables @@ -382,8 +379,8 @@ shallowTcvFolder = TyCoFolder { tcf_view = noView ********************************************************************* -} -{- Note [Finding free coercion varibles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Finding free coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here we are only interested in the free /coercion/ variables. We can achieve this through a slightly different TyCo folder. @@ -392,6 +389,7 @@ Notice that we look deeply, into kinds. See #14880. -} +-- See Note [Finding free coercion variables] coVarsOfType :: Type -> CoVarSet coVarsOfTypes :: [Type] -> CoVarSet coVarsOfCo :: Coercion -> CoVarSet @@ -432,7 +430,6 @@ deepCoVarFolder = TyCoFolder { tcf_view = noView -- See Note [CoercionHoles and coercion free variables] -- in GHC.Core.TyCo.Rep - {- ********************************************************************* * * Closing over kinds diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index fae7c7de19..a08da28421 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -65,7 +65,7 @@ module GHC.Core.TyCo.Rep ( pickLR, -- ** Analyzing types - TyCoFolder(..), foldTyCo, + TyCoFolder(..), foldTyCo, noView, -- * Sizes typeSize, coercionSize, provSize, @@ -150,6 +150,7 @@ data Type | ForAllTy {-# UNPACK #-} !TyCoVarBinder Type -- ^ A Î type. + -- Note [When we quantify over a coercion variable] -- INVARIANT: If the binder is a coercion variable, it must -- be mentioned in the Type. See -- Note [Unused coercion variable in ForAllTy] @@ -624,6 +625,35 @@ In order to compare FunTys while respecting how they could expand into TyConApps, we must check the kinds of the arg and the res. +Note [When we quantify over a coercion variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TyCoVarBinder in a ForAllTy can be (most often) a TyVar or (rarely) +a CoVar. We support quantifying over a CoVar here in order to support +a homogeneous (~#) relation (someday -- not yet implemented). Here is +the example: + + type (:~~:) :: forall k1 k2. k1 -> k2 -> Type + data a :~~: b where + HRefl :: a :~~: a + +Assuming homogeneous equality (that is, with + (~#) :: forall k. k -> k -> TYPE (TupleRep '[]) +) after rejigging to make equalities explicit, we get a constructor that +looks like + + HRefl :: forall k1 k2 (a :: k1) (b :: k2). + forall (cv :: k1 ~# k2). (a |> cv) ~# b + => (:~~:) k1 k2 a b + +Note that we must cast `a` by a cv bound in the same type in order to +make this work out. + +See also https://gitlab.haskell.org/ghc/ghc/-/wikis/dependent-haskell/phase2 +which gives a general road map that covers this space. + +Having this feature in Core does *not* mean we have it in source Haskell. +See #15710 about that. + Note [Unused coercion variable in ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have @@ -1834,7 +1864,7 @@ We were also worried about `extendVarSet` tv Here deep_fvs and deep_tcf are mutually recursive, unlike fvs and tcf. -But, amazingly, we get good code here too. GHC is careful not to makr +But, amazingly, we get good code here too. GHC is careful not to mark TyCoFolder data constructor for deep_tcf as a loop breaker, so the record selections still cancel. And eta expansion still happens too. -} @@ -1843,8 +1873,8 @@ data TyCoFolder env a = TyCoFolder { tcf_view :: Type -> Maybe Type -- Optional "view" function -- E.g. expand synonyms - , tcf_tyvar :: env -> TyVar -> a - , tcf_covar :: env -> CoVar -> a + , tcf_tyvar :: env -> TyVar -> a -- Does not automatically recur + , tcf_covar :: env -> CoVar -> a -- into kinds of variables , tcf_hole :: env -> CoercionHole -> a -- ^ What to do with coercion holes. -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". @@ -1916,6 +1946,10 @@ foldTyCo (TyCoFolder { tcf_view = view go_prov _ (PluginProv _) = mempty go_prov _ (CorePrepProv _) = mempty +-- | A view function that looks through nothing. +noView :: Type -> Maybe Type +noView _ = Nothing + {- ********************************************************************* * * typeSize, coercionSize diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 1cacfca468..4fce8c8a09 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -86,7 +86,7 @@ module GHC.Core.Type ( -- ** Analyzing types TyCoMapper(..), mapTyCo, mapTyCoX, - TyCoFolder(..), foldTyCo, + TyCoFolder(..), foldTyCo, noView, -- (Newtypes) newTyConInstRhs, diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index f5f9b725f4..a1b72b914c 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -551,7 +551,10 @@ isEmptyIPBindsPR (IPBinds _ is) = null is isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds -type instance XCIPBind (GhcPass p) = EpAnn [AddEpAnn] +-- EPA annotations in GhcPs, dictionary Id in GhcTc +type instance XCIPBind GhcPs = EpAnn [AddEpAnn] +type instance XCIPBind GhcRn = NoExtField +type instance XCIPBind GhcTc = Id type instance XXIPBind (GhcPass p) = DataConCantHappen instance OutputableBndrId p @@ -560,10 +563,11 @@ instance OutputableBndrId p $$ whenPprDebug (pprIfTc @p $ ppr ds) instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where - ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) - where name = case lr of - Left (L _ ip) -> pprBndr LetBind ip - Right id -> pprBndr LetBind id + ppr (IPBind x (L _ ip) rhs) = name <+> equals <+> pprExpr (unLoc rhs) + where name = case ghcPass @p of + GhcPs -> pprBndr LetBind ip + GhcRn -> pprBndr LetBind ip + GhcTc -> pprBndr LetBind x {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 77c6ba651c..1c6ef3eafa 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -846,9 +846,8 @@ addTickHsIPBinds (IPBinds dictbinds ipbinds) = addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) addTickIPBind (IPBind x nm e) = - liftM2 (IPBind x) - (return nm) - (addTickLHsExpr e) + liftM (IPBind x nm) + (addTickLHsExpr e) -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 973d7f204f..c4dc64e58c 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -103,7 +103,7 @@ dsIPBinds (IPBinds ev_binds ip_binds) body ; foldrM ds_ip_bind inner ip_binds } where ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr - ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body + ds_ip_bind (L _ (IPBind n _ e)) body = do e' <- dsLExpr e return (Let (NonRec n e') body) diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index f6d718b222..5c95f14341 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1844,11 +1844,8 @@ repBinds (HsValBinds _ decs) ; return (ss, core_list) } rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) -rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs))) - = do { name <- case ename of - Left (L _ n) -> rep_implicit_param_name n - Right _ -> - panic "rep_implicit_param_bind: post typechecking" +rep_implicit_param_bind (L loc (IPBind _ (L _ n) (L _ rhs))) + = do { name <- rep_implicit_param_name n ; rhs' <- repE rhs ; ipb <- repImplicitParamBind name rhs' ; return (locA loc, ipb) } diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index cc694f249f..7b4e8bc20e 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -1278,7 +1278,6 @@ instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where valBinds ] - scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) = foldr combineScopes NoScope (bsScope ++ sigsScope) @@ -1299,15 +1298,13 @@ scopeHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) = foldr combineScopes NoScope (map (mkScopeA . getLoc) bs) scopeHsLocaLBinds (EmptyLocalBinds _) = NoScope - instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where - toHie (RS scope (L sp bind)) = concatM $ makeNodeA bind sp : case bind of - IPBind _ (Left _) expr -> [toHie expr] - IPBind _ (Right v) expr -> - [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp)) - $ L sp v - , toHie expr - ] + toHie (RS scope (L sp bind@(IPBind v _ expr))) = concatM $ makeNodeA bind sp : case hiePass @p of + HieRn -> [toHie expr] + HieTc -> [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp)) + $ L sp v + , toHie expr + ] instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where toHie (RS sc v) = concatM $ case v of diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 5d8a9c2c9d..4be8d39c5d 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -3452,7 +3452,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- reversed dbind :: { LIPBind GhcPs } dbind : ipvar '=' exp {% runPV (unECP $3) >>= \ $3 -> - acsA (\cs -> sLLlA $1 $> (IPBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (Left (reLocA $1)) $3)) } + acsA (\cs -> sLLlA $1 $> (IPBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (reLocA $1) $3)) } ipvar :: { Located HsIPName } : IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) } diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 08e8672d00..19d27a33cf 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -244,9 +244,9 @@ rnIPBinds (IPBinds _ ip_binds ) = do return (IPBinds noExtField ip_binds', plusFVs fvs_s) rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) -rnIPBind (IPBind _ ~(Left n) expr) = do +rnIPBind (IPBind _ n expr) = do (expr',fvExpr) <- rnLExpr expr - return (IPBind noAnn (Left n) expr', fvExpr) + return (IPBind noExtField n expr', fvExpr) {- ************************************************************************ diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index b4bf25b9b3..9f2c257435 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -1063,15 +1063,11 @@ getDictionaryBindings theta = do let dict_var = mkVanillaGlobal dictName theta loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing - -- Generate a wanted here because at the end of constraint - -- solving, most derived constraints get thrown away, which in certain - -- cases, notably with quantified constraints makes it impossible to rule - -- out instances as invalid. (See #18071) return CtWanted { ctev_pred = varType dict_var, ctev_dest = EvVarDest dict_var, - ctev_nosh = WDeriv, - ctev_loc = loc + ctev_loc = loc, + ctev_rewriters = emptyRewriterSet } -- Find instances where the head unifies with the provided type @@ -1132,13 +1128,19 @@ checkForExistence clsInst mb_inst_tys = do -- which otherwise appear as opaque type variables. (See #18262). WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds - if allBag allowedSimple simples && solvedImplics impls - then return . Just $ substInstArgs tys (bagToList (mapBag ctPred simples)) clsInst + -- The simples might contain superclasses. This clutters up the output + -- (we want e.g. instance Ord a => Ord (Maybe a), not + -- instance (Ord a, Eq a) => Ord (Maybe a)). So we use mkMinimalBySCs + let simple_preds = map ctPred (bagToList simples) + let minimal_simples = mkMinimalBySCs id simple_preds + + if all allowedSimple minimal_simples && solvedImplics impls + then return . Just $ substInstArgs tys minimal_simples clsInst else return Nothing where - allowedSimple :: Ct -> Bool - allowedSimple ct = isSatisfiablePred (ctPred ct) + allowedSimple :: PredType -> Bool + allowedSimple pred = isSatisfiablePred pred solvedImplics :: Bag Implication -> Bool solvedImplics impls = allBag (isSolvedStatus . ic_status) impls diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index db54c9bab4..ccc44df2b4 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -42,6 +42,7 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Ppr (pprTyVars) import GHC.Core.Type import GHC.Tc.Solver +import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Validity (validDerivPred) import GHC.Tc.Utils.Unify (buildImplicationFor, checkConstraints) import GHC.Builtin.Types (typeToTypeKind) @@ -788,10 +789,10 @@ simplifyDeriv pred tvs thetas -- Simplify the constraints, starting at the same level at which -- they are generated (c.f. the call to runTcSWithEvBinds in -- simplifyInfer) - ; solved_wanteds <- setTcLevel tc_lvl $ - runTcSDeriveds $ - solveWantedsAndDrop $ - unionsWC wanteds + ; (solved_wanteds, _) <- setTcLevel tc_lvl $ + runTcS $ + solveWanteds $ + unionsWC wanteds -- It's not yet zonked! Obviously zonk it before peering at it ; solved_wanteds <- zonkWC solved_wanteds @@ -809,16 +810,10 @@ simplifyDeriv pred tvs thetas -- constitutes an exotic constraint. get_good :: Ct -> Maybe PredType get_good ct | validDerivPred skol_set p - , isWantedCt ct = Just p - -- TODO: This is wrong - -- NB re 'isWantedCt': residual_wanted may contain - -- unsolved CtDerived and we stick them into the - -- bad set so that reportUnsolved may decide what - -- to do with them | otherwise = Nothing - where p = ctPred ct + where p = ctPred ct ; traceTc "simplifyDeriv outputs" $ vcat [ ppr tvs_skols, ppr residual_simple, ppr good ] diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index a833e76661..b71a6b1dd4 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -13,8 +14,6 @@ module GHC.Tc.Errors( reportUnsolved, reportAllUnsolved, warnAllUnsolved, warnDefaulting, - solverDepthErrorTcS, - -- * GHC API helper functions solverReportMsg_ExpectedActuals, solverReportInfo_ExpectedActuals @@ -92,7 +91,7 @@ import Data.List.NonEmpty ( NonEmpty(..), (<|) ) import qualified Data.List.NonEmpty as NE ( map, reverse ) import Data.List ( sortBy ) import Data.Ord ( comparing ) - +import qualified Data.Semigroup as S {- ************************************************************************ @@ -464,20 +463,73 @@ But without the context we won't find beta := Zero. This only matters in instance declarations.. -} +-- | Should we completely ignore this constraint in error reporting? +-- It *must* be the case that any constraint for which this returns True +-- somehow causes an error to be reported elsewhere. +-- See Note [Constraints to ignore]. +ignoreConstraint :: Ct -> Bool +ignoreConstraint ct + | AssocFamPatOrigin <- ctOrigin ct + = True + | otherwise + = False + +-- | Makes an error item from a constraint, calculating whether or not +-- the item should be suppressed. See Note [Wanteds rewrite Wanteds] +-- in GHC.Tc.Types.Constraint. Returns Nothing if we should just ignore +-- a constraint. See Note [Constraints to ignore]. +mkErrorItem :: Ct -> TcM (Maybe ErrorItem) +mkErrorItem ct + | ignoreConstraint ct + = do { traceTc "Ignoring constraint:" (ppr ct) + ; return Nothing } -- See Note [Constraints to ignore] + + | otherwise + = do { let loc = ctLoc ct + flav = ctFlavour ct + + ; (suppress, m_evdest) <- case ctEvidence ct of + CtGiven {} -> return (False, Nothing) + CtWanted { ctev_rewriters = rewriters, ctev_dest = dest } + -> do { supp <- anyUnfilledCoercionHoles rewriters + ; return (supp, Just dest) } + + ; let m_reason = case ct of CIrredCan { cc_reason = reason } -> Just reason + _ -> Nothing + + ; return $ Just $ EI { ei_pred = ctPred ct + , ei_evdest = m_evdest + , ei_flavour = flav + , ei_loc = loc + , ei_m_reason = m_reason + , ei_suppress = suppress }} + +---------------------------------------------------------------- reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () -reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics - , wc_holes = holes }) - = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples - , text "Suppress =" <+> ppr (cec_suppress ctxt) - , text "tidy_cts =" <+> ppr tidy_cts - , text "tidy_holes = " <+> ppr tidy_holes ]) +reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics + , wc_holes = holes }) + | isEmptyWC wc = traceTc "reportWanteds empty WC" empty + | otherwise + = do { tidy_items <- mapMaybeM mkErrorItem tidy_cts + ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples + , text "Suppress =" <+> ppr (cec_suppress ctxt) + , text "tidy_cts =" <+> ppr tidy_cts + , text "tidy_items =" <+> ppr tidy_items + , text "tidy_holes =" <+> ppr tidy_holes ]) + + -- This check makes sure that we aren't suppressing the only error that will + -- actually stop compilation + ; massert $ + null simples || -- no errors to report here + any ignoreConstraint simples || -- one error is ignorable (is reported elsewhere) + not (all ei_suppress tidy_items) -- not all error are suppressed -- First, deal with any out-of-scope errors: ; let (out_of_scope, other_holes) = partition isOutOfScopeHole tidy_holes -- don't suppress out-of-scope errors ctxt_for_scope_errs = ctxt { cec_suppress = False } ; (_, no_out_of_scope) <- askNoErrs $ - reportHoles tidy_cts ctxt_for_scope_errs out_of_scope + reportHoles tidy_items ctxt_for_scope_errs out_of_scope -- Next, deal with things that are utterly wrong -- Like Int ~ Bool (incl nullary TyCons) @@ -485,57 +537,71 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics -- These /ones/ are not suppressed by the incoming context -- (but will be by out-of-scope errors) ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope } - ; reportHoles tidy_cts ctxt_for_insols other_holes + ; reportHoles tidy_items ctxt_for_insols other_holes -- holes never suppress - ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts + -- See Note [Suppressing confusing errors] + ; let (suppressed_items, items0) = partition suppress tidy_items + ; traceTc "reportWanteds suppressed:" (ppr suppressed_items) + ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0 -- Now all the other constraints. We suppress errors here if -- any of the first batch failed, or if the enclosing context -- says to suppress - ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } - ; (_, leftovers) <- tryReporters ctxt2 report2 cts1 + ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } + ; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1 ; massertPpr (null leftovers) (text "The following unsolved Wanted constraints \ \have not been reported to the user:" $$ ppr leftovers) - -- All the Derived ones have been filtered out of simples - -- by the constraint solver. This is ok; we don't want - -- to report unsolved Derived goals as errors - -- See Note [Do not report derived but soluble errors] - - ; mapBagM_ (reportImplic ctxt2) implics } + ; mapBagM_ (reportImplic ctxt2) implics -- NB ctxt2: don't suppress inner insolubles if there's only a -- wanted insoluble here; but do suppress inner insolubles -- if there's a *given* insoluble here (= inaccessible code) + + -- Only now, if there are no errors, do we report suppressed ones + -- See Note [Suppressing confusing errors] + -- We don't need to update the context further because of the + -- whenNoErrs guard + ; whenNoErrs $ + do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items + ; massertPpr (null more_leftovers) (ppr more_leftovers) } } where - env = cec_tidy ctxt + env = cec_tidy ctxt tidy_cts = bagToList (mapBag (tidyCt env) simples) tidy_holes = bagToList (mapBag (tidyHole env) holes) + -- See Note [Suppressing confusing errors] + suppress :: ErrorItem -> Bool + suppress item + | Wanted <- ei_flavour item + = is_ww_fundep_item item + | otherwise + = False + -- report1: ones that should *not* be suppressed by -- an insoluble somewhere else in the tree -- It's crucial that anything that is considered insoluble -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise -- we might suppress its error message, and proceed on past -- type checking to get a Lint error later - report1 = [ ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter) + report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) , given_eq_spec - , ("insoluble2", unblocked utterly_wrong, True, mkGroupReporter mkEqErr) - , ("skolem eq1", unblocked very_wrong, True, mkSkolReporter) - , ("skolem eq2", unblocked skolem_eq, True, mkSkolReporter) - , ("non-tv eq", unblocked non_tv_eq, True, mkSkolReporter) + , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) + , ("skolem eq1", very_wrong, True, mkSkolReporter) + , ("skolem eq2", skolem_eq, True, mkSkolReporter) + , ("non-tv eq", non_tv_eq, True, mkSkolReporter) -- The only remaining equalities are alpha ~ ty, -- where alpha is untouchable; and representational equalities -- Prefer homogeneous equalities over hetero, because the -- former might be holding up the latter. -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical - , ("Homo eqs", unblocked is_homo_equality, True, mkGroupReporter mkEqErr) - , ("Other eqs", unblocked is_equality, True, mkGroupReporter mkEqErr) - , ("Blocked eqs", is_equality, False, mkSuppressReporter mkBlockedEqErr)] + , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr) + , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr) + ] -- report2: we suppress these if there are insolubles elsewhere in the tree report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) @@ -543,17 +609,17 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics , ("FixedRuntimeRep", is_FRR, False, mkGroupReporter mkFRRErr) , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] - -- also checks to make sure the constraint isn't HoleBlockerReason - -- See TcCanonical Note [Equalities with incompatible kinds], (4) - unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool - unblocked _ (CIrredCan { cc_reason = HoleBlockerReason {}}) _ = False - unblocked checker ct pred = checker ct pred + -- report3: suppressed errors should be reported as categorized by either report1 + -- or report2. Keep this in sync with the suppress function above + report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr) + ] -- rigid_nom_eq, rigid_nom_tv_eq, - is_dict, is_equality, is_ip, is_FRR, is_irred :: Ct -> Pred -> Bool + is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool - is_given_eq ct pred - | EqPred {} <- pred = arisesFromGivens ct + is_given_eq item pred + | Given <- ei_flavour item + , EqPred {} <- pred = True | otherwise = False -- I think all given residuals are equalities @@ -573,7 +639,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) non_tv_eq _ _ = False - is_user_type_error ct _ = isUserTypeErrorCt ct + is_user_type_error item _ = isUserTypeError (errorItemPred item) is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 is_homo_equality _ _ = False @@ -587,8 +653,8 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics is_ip _ (ClassPred cls _) = isIPClass cls is_ip _ _ = False - is_FRR ct (SpecialPred ConcretePrimPred _) - | FixedRuntimeRepOrigin {} <- ctOrigin ct + is_FRR item (SpecialPred ConcretePrimPred _) + | FixedRuntimeRepOrigin {} <- errorItemOrigin item = True is_FRR _ _ = False @@ -596,8 +662,12 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics is_irred _ (IrredPred {}) = True is_irred _ _ = False + -- See situation (1) of Note [Suppressing confusing errors] + is_ww_fundep item _ = is_ww_fundep_item item + is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin + given_eq_spec -- See Note [Given errors] - | has_gadt_match (cec_encl ctxt) + | has_gadt_match_here = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) | otherwise = ("insoluble1b", is_given_eq, False, ignoreErrorReporter) @@ -608,6 +678,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics -- #13446 is an example -- See Note [Given errors] + has_gadt_match_here = has_gadt_match (cec_encl ctxt) has_gadt_match [] = False has_gadt_match (implic : implics) | PatSkol {} <- ic_info implic @@ -637,36 +708,119 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of Just (tc,_) | isTypeFamilyTyCon tc -> Just tc _ -> Nothing +{- Note [Suppressing confusing errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Certain errors we might encounter are potentially confusing to users. +If there are any other errors to report, at all, we want to suppress these. + +Which errors (only 1 case right now): + +1) Errors which arise from the interaction of two Wanted fun-dep constraints. + Example: + + class C a b | a -> b where + op :: a -> b -> b + + foo _ = op True Nothing + + bar _ = op False [] + + Here, we could infer + foo :: C Bool (Maybe a) => p -> Maybe a + bar :: C Bool [a] => p -> [a] + + (The unused arguments suppress the monomorphism restriction.) The problem + is that these types can't both be correct, as they violate the functional + dependency. Yet reporting an error here is awkward: we must + non-deterministically choose either foo or bar to reject. We thus want + to report this problem only when there is nothing else to report. + See typecheck/should_fail/T13506 for an example of when to suppress + the error. The case above is actually accepted, because foo and bar + are checked separately, and thus the two fundep constraints never + encounter each other. It is test case typecheck/should_compile/FunDepOrigin1. + + This case applies only when both fundeps are *Wanted* fundeps; when + both are givens, the error represents unreachable code. For + a Given/Wanted case, see #9612. + +Mechanism: + +We use the `suppress` function within reportWanteds to filter out these two +cases, then report all other errors. Lastly, we return to these suppressed +ones and report them only if there have been no errors so far. + +Note [Constraints to ignore] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some constraints are meant only to aid the solver by unification; a failure +to solve them is not necessarily an error to report to the user. It is critical +that compilation is aborted elsewhere if there are any ignored constraints here; +they will remain unfilled, and might have been used to rewrite another constraint. + +Currently, the constraints to ignore are: + +1) Constraints generated in order to unify associated type instance parameters + with class parameters. Here are two illustrative examples: + + class C (a :: k) where + type F (b :: k) + + instance C True where + type F a = Int + + instance C Left where + type F (Left :: a -> Either a b) = Bool + + In the first instance, we want to infer that `a` has type Bool. So we emit + a constraint unifying kappa (the guessed type of `a`) with Bool. All is well. + + In the second instance, we process the associated type instance only + after fixing the quantified type variables of the class instance. We thus + have skolems a1 and b1 such that the class instance is for (Left :: a1 -> Either a1 b1). + Unifying a1 and b1 with a and b in the type instance will fail, but harmlessly so. + checkConsistentFamInst checks for this, and will fail if anything has gone + awry. Really the equality constraints emitted are just meant as an aid, not + a requirement. This is test case T13972. + + We detect this case by looking for an origin of AssocFamPatOrigin; constraints + with this origin are dropped entirely during error message reporting. + + If there is any trouble, checkValidFamInst bleats, aborting compilation. + +-} + + + -------------------------------------------- -- Reporters -------------------------------------------- type Reporter - = SolverReportErrCtxt -> [Ct] -> TcM () + = SolverReportErrCtxt -> [ErrorItem] -> TcM () type ReporterSpec - = ( String -- Name - , Ct -> Pred -> Bool -- Pick these ones - , Bool -- True <=> suppress subsequent reporters - , Reporter) -- The reporter itself + = ( String -- Name + , ErrorItem -> Pred -> Bool -- Pick these ones + , Bool -- True <=> suppress subsequent reporters + , Reporter) -- The reporter itself mkSkolReporter :: Reporter -- Suppress duplicates with either the same LHS, or same location -mkSkolReporter ctxt cts - = mapM_ (reportGroup mkEqErr ctxt) (group cts) +-- Pre-condition: all items are equalities +mkSkolReporter ctxt items + = mapM_ (reportGroup mkEqErr ctxt) (group items) where group [] = [] - group (ct:cts) = (ct : yeses) : group noes + group (item:items) = (item : yeses) : group noes where - (yeses, noes) = partition (group_with ct) cts + (yeses, noes) = partition (group_with item) items - group_with ct1 ct2 - | EQ <- cmp_loc ct1 ct2 = True - | eq_lhs_type ct1 ct2 = True - | otherwise = False + group_with item1 item2 + | EQ <- cmp_loc item1 item2 = True + | eq_lhs_type item1 item2 = True + | otherwise = False -reportHoles :: [Ct] -- other (tidied) constraints +reportHoles :: [ErrorItem] -- other (tidied) constraints -> SolverReportErrCtxt -> [Hole] -> TcM () -reportHoles tidy_cts ctxt holes +reportHoles tidy_items ctxt holes = do diag_opts <- initDiagOpts <$> getDynFlags let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt) @@ -675,7 +829,7 @@ reportHoles tidy_cts ctxt holes -- because otherwise types will be zonked and tidied many times over. (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes') let ctxt' = ctxt { cec_tidy = tidy_env' } - forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_cts ctxt' hole + forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_items ctxt' hole ; reportDiagnostic msg } keepThisHole :: Severity -> Hole -> Bool @@ -734,42 +888,43 @@ machinery, in cases where it is definitely going to be a no-op. mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt - = mapM_ $ \ct -> do { let err = important ctxt $ mkUserTypeError ct - ; maybeReportError ctxt ct err - ; addDeferredBinding ctxt err ct } + = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item + ; maybeReportError ctxt [item] err + ; addDeferredBinding ctxt err item } -mkUserTypeError :: Ct -> TcSolverReportMsg -mkUserTypeError ct = - case getUserTypeErrorMsg ct of +mkUserTypeError :: ErrorItem -> TcSolverReportMsg +mkUserTypeError item = + case getUserTypeErrorMsg (errorItemPred item) of Just msg -> UserTypeError msg - Nothing -> pprPanic "mkUserTypeError" (ppr ct) + Nothing -> pprPanic "mkUserTypeError" (ppr item) mkGivenErrorReporter :: Reporter -- See Note [Given errors] -mkGivenErrorReporter ctxt cts - = do { (ctxt, relevant_binds, ct) <- relevantBindings True ctxt ct +mkGivenErrorReporter ctxt items + = do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item ; let (implic:_) = cec_encl ctxt -- Always non-empty when mkGivenErrorReporter is called - ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) + loc' = setCtLocEnv (ei_loc item) (ic_env implic) + item' = item { ei_loc = loc' } -- For given constraints we overwrite the env (and hence src-loc) -- with one from the immediately-enclosing implication. -- See Note [Inaccessible code] - ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt ct' ty1 ty2 + ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt item' ty1 ty2 -- The hints wouldn't help in this situation, so we discard them. ; let supplementary = [ SupplementaryBindings relevant_binds ] msg = TcRnInaccessibleCode implic (NE.reverse . NE.map (SolverReportWithCtxt ctxt) $ eq_err_msgs) - ; msg <- mkErrorReport (ctLocEnv (ctLoc ct')) msg (Just ctxt) supplementary + ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary ; reportDiagnostic msg } where - (ct : _ ) = cts -- Never empty - (ty1, ty2) = getEqPredTys (ctPred ct) + (item : _ ) = items -- Never empty + (ty1, ty2) = getEqPredTys (errorItemPred item) ignoreErrorReporter :: Reporter -- Discard Given errors that don't come from -- a pattern match; maybe we should warn instead? -ignoreErrorReporter ctxt cts - = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt)) +ignoreErrorReporter ctxt items + = do { traceTc "mkGivenErrorReporter no" (ppr items $$ ppr (cec_encl ctxt)) ; return () } @@ -807,59 +962,43 @@ pattern match which binds some equality constraints. If we find one, we report the insoluble Given. -} -mkGroupReporter :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport) +mkGroupReporter :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, -- and report only the first (to avoid a cascade) -mkGroupReporter mk_err ctxt cts - = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) - --- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport) - -> Reporter -mkSuppressReporter mk_err ctxt cts - = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) - -eq_lhs_type :: Ct -> Ct -> Bool -eq_lhs_type ct1 ct2 - = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of +mkGroupReporter mk_err ctxt items + = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc items) + +eq_lhs_type :: ErrorItem -> ErrorItem -> Bool +eq_lhs_type item1 item2 + = case (classifyPredType (errorItemPred item1), classifyPredType (errorItemPred item2)) of (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2) - _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2) + _ -> pprPanic "mkSkolReporter" (ppr item1 $$ ppr item2) -cmp_loc :: Ct -> Ct -> Ordering -cmp_loc ct1 ct2 = get ct1 `compare` get ct2 +cmp_loc :: ErrorItem -> ErrorItem -> Ordering +cmp_loc item1 item2 = get item1 `compare` get item2 where - get ct = realSrcSpanStart (ctLocSpan (ctLoc ct)) + get ei = realSrcSpanStart (ctLocSpan (errorItemCtLoc ei)) -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter -reportGroup mk_err ctxt cts - | ct1 : _ <- cts = - do { err <- mk_err ctxt cts - ; traceTc "About to maybeReportErr" $ - vcat [ text "Constraint:" <+> ppr cts - , text "cec_suppress =" <+> ppr (cec_suppress ctxt) - , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] - ; maybeReportError ctxt ct1 err - -- But see Note [Always warn with -fdefer-type-errors] - ; traceTc "reportGroup" (ppr cts) - ; mapM_ (addDeferredBinding ctxt err) cts } - -- Add deferred bindings for all - -- Redundant if we are going to abort compilation, - -- but that's hard to know for sure, and if we don't - -- abort, we need bindings for all (e.g. #12156) - | otherwise = panic "empty reportGroup" - --- like reportGroup, but does not actually report messages. It still adds --- -fdefer-type-errors bindings, though. -suppressGroup :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter -suppressGroup mk_err ctxt cts - = do { err <- mk_err ctxt cts - ; traceTc "Suppressing errors for" (ppr cts) - ; mapM_ (addDeferredBinding ctxt err) cts } +reportGroup :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) -> Reporter +reportGroup mk_err ctxt items + = do { err <- mk_err ctxt items + ; traceTc "About to maybeReportErr" $ + vcat [ text "Constraint:" <+> ppr items + , text "cec_suppress =" <+> ppr (cec_suppress ctxt) + , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] + ; maybeReportError ctxt items err + -- But see Note [Always warn with -fdefer-type-errors] + ; traceTc "reportGroup" (ppr items) + ; mapM_ (addDeferredBinding ctxt err) items } + -- Add deferred bindings for all + -- Redundant if we are going to abort compilation, + -- but that's hard to know for sure, and if we don't + -- abort, we need bindings for all (e.g. #12156) -- See Note [No deferring for multiplicity errors] nonDeferrableOrigin :: CtOrigin -> Bool @@ -868,23 +1007,33 @@ nonDeferrableOrigin (UsageEnvironmentOf {}) = True nonDeferrableOrigin (FixedRuntimeRepOrigin {}) = True nonDeferrableOrigin _ = False -maybeReportError :: SolverReportErrCtxt -> Ct -> SolverReport -> TcM () -maybeReportError ctxt ct (SolverReport { sr_important_msgs = important, sr_supplementary = supp, sr_hints = hints }) - = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic - do let reason | nonDeferrableOrigin (ctOrigin ct) = ErrorWithoutFlag - | otherwise = cec_defer_type_errors ctxt +maybeReportError :: SolverReportErrCtxt + -> [ErrorItem] -- items covered by the Report + -> SolverReport -> TcM () +maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msgs = important + , sr_supplementary = supp + , sr_hints = hints }) + = unless (cec_suppress ctxt -- Some worse error has occurred, so suppress this diagnostic + || all ei_suppress items) $ + -- if they're all to be suppressed, report nothing + -- if at least one is not suppressed, do report: + -- the function that generates the error message + -- should look for an unsuppressed error item + do let reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag + | otherwise = cec_defer_type_errors ctxt -- See Note [No deferring for multiplicity errors] diag = TcRnSolverReport important reason hints - msg <- mkErrorReport (ctLocEnv (ctLoc ct)) diag (Just ctxt) supp + msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp reportDiagnostic msg +maybeReportError _ _ _ = panic "maybeReportError" -addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> Ct -> TcM () +addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> ErrorItem -> TcM () -- See Note [Deferring coercion errors to runtime] -addDeferredBinding ctxt err ct +addDeferredBinding ctxt err (EI { ei_evdest = Just dest, ei_pred = item_ty + , ei_loc = loc }) + -- if evdest is Just, then the constraint was from a wanted | deferringAnyBindings ctxt - , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct - -- Only add deferred bindings for Wanted constraints - = do { err_tm <- mkErrorTerm ctxt (ctLoc ct) pred err + = do { err_tm <- mkErrorTerm ctxt loc item_ty err ; let ev_binds_var = cec_binds ctxt ; case dest of @@ -895,9 +1044,7 @@ addDeferredBinding ctxt err ct let co_var = coHoleCoVar hole ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm ; fillCoercionHole hole (mkTcCoVarCo co_var) }} - - | otherwise -- Do not set any evidence for Given/Derived - = return () +addDeferredBinding _ _ _ = return () -- Do not set any evidence for Given mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type -- of the error term -> SolverReport -> TcM EvTerm @@ -913,42 +1060,44 @@ mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_sup ; return $ evDelayedError ty err_str } -tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (SolverReportErrCtxt, [Ct]) +tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) -- Use the first reporter in the list whose predicate says True -tryReporters ctxt reporters cts - = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts - ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts) - ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts - ; traceTc "tryReporters }" (ppr cts') - ; return (ctxt', cts') } +tryReporters ctxt reporters items + = do { let (vis_items, invis_items) + = partition (isVisibleOrigin . errorItemOrigin) items + ; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items) + ; (ctxt', items') <- go ctxt reporters vis_items invis_items + ; traceTc "tryReporters }" (ppr items') + ; return (ctxt', items') } where - go ctxt [] vis_cts invis_cts - = return (ctxt, vis_cts ++ invis_cts) + go ctxt [] vis_items invis_items + = return (ctxt, vis_items ++ invis_items) - go ctxt (r : rs) vis_cts invis_cts + go ctxt (r : rs) vis_items invis_items -- always look at *visible* Origins before invisible ones -- this is the whole point of isVisibleOrigin - = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts - ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts - ; go ctxt'' rs vis_cts' invis_cts' } + = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items + ; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items + ; go ctxt'' rs vis_items' invis_items' } -- Carry on with the rest, because we must make -- deferred bindings for them if we have -fdefer-type-errors -- But suppress their error messages -tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (SolverReportErrCtxt, [Ct]) -tryReporter ctxt (str, keep_me, suppress_after, reporter) cts +tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) +tryReporter ctxt (str, keep_me, suppress_after, reporter) items | null yeses - = return (ctxt, cts) + = return (ctxt, items) | otherwise = do { traceTc "tryReporter{ " (text str <+> ppr yeses) ; (_, no_errs) <- askNoErrs (reporter ctxt yeses) - ; let suppress_now = not no_errs && suppress_after + ; let suppress_now = not no_errs && suppress_after -- See Note [Suppressing error messages] ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) ; return (ctxt', nos) } where - (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts + (yeses, nos) = partition keep items + keep item = keep_me item (classifyPredType (errorItemPred item)) -- | Wrap an input 'TcRnMessage' with additional contextual information, -- such as relevant bindings or valid hole fits. @@ -1069,56 +1218,6 @@ from that EvVar, filling the hole with that coercion. Because coercions' types are unlifted, the error is guaranteed to be hit before we get to the coercion. -Note [Do not report derived but soluble errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wc_simples include Derived constraints that have not been solved, -but are not insoluble (in that case they'd be reported by 'report1'). -We do not want to report these as errors: - -* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have - an unsolved [D] Eq a, and we do not want to report that; it's just noise. - -* Functional dependencies. For givens, consider - class C a b | a -> b - data T a where - MkT :: C a d => [d] -> T a - f :: C a b => T a -> F Int - f (MkT xs) = length xs - Then we get a [D] b~d. But there *is* a legitimate call to - f, namely f (MkT [True]) :: T Bool, in which b=d. So we should - not reject the program. - - For wanteds, something similar - data T a where - MkT :: C Int b => a -> b -> T a - g :: C Int c => c -> () - f :: T a -> () - f (MkT x y) = g x - Here we get [G] C Int b, [W] C Int a, hence [D] a~b. - But again f (MkT True True) is a legitimate call. - -(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose -derived superclasses between iterations of the solver.) - -For functional dependencies, here is a real example, -stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs - - class C a b | a -> b - g :: C a b => a -> b -> () - f :: C a b => a -> b -> () - f xa xb = - let loop = g xa - in loop xb - -We will first try to infer a type for loop, and we will succeed: - C a b' => b' -> () -Subsequently, we will type check (loop xb) and all is good. But, -recall that we have to solve a final implication constraint: - C a b => (C a b' => .... cts from body of loop .... )) -And now we have a problem as we will generate an equality b ~ b' and fail to -solve it. - - ************************************************************************ * * Irreducible predicate errors @@ -1126,14 +1225,23 @@ solve it. ************************************************************************ -} -mkIrredErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport -mkIrredErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 +mkIrredErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport +mkIrredErr ctxt items + = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1 ; let msg = important ctxt $ - CouldNotDeduce (getUserGivens ctxt) (ct1 :| others) Nothing + CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing ; return $ msg `mappend` mk_relevant_bindings binds_msg } where - ct1:others = cts + (item1:others) = final_items + + filtered_items = filter (not . ei_suppress) items + final_items | null filtered_items = items + -- they're all suppressed; must report *something* + -- NB: even though reportWanteds asserts that not + -- all items are suppressed, it's possible all the + -- irreducibles are suppressed, and so this function + -- might get all suppressed items + | otherwise = filtered_items {- Note [Constructing Hole Errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1171,7 +1279,7 @@ See also 'reportUnsolved'. ---------------- -- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors]. -mkHoleError :: NameEnv Type -> [Ct] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) +mkHoleError :: NameEnv Type -> [ErrorItem] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc }) | isOutOfScopeHole hole = do { dflags <- getDynFlags @@ -1277,19 +1385,27 @@ maybeAddDeferredBindings ctxt hole report = do -- We unwrap the SolverReportErrCtxt here, to avoid introducing a loop in module -- imports -validHoleFits :: SolverReportErrCtxt -- ^ The context we're in, i.e. the - -- implications and the tidy environment - -> [Ct] -- ^ Unsolved simple constraints - -> Hole -- ^ The hole - -> TcM (SolverReportErrCtxt, ValidHoleFits) - -- ^ We return the new context - -- with a possibly updated - -- tidy environment, and - -- the valid hole fits. -validHoleFits ctxt@(CEC {cec_encl = implics - , cec_tidy = lcl_env}) simps hole - = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics simps hole +validHoleFits :: SolverReportErrCtxt -- ^ The context we're in, i.e. the + -- implications and the tidy environment + -> [ErrorItem] -- ^ Unsolved simple constraints + -> Hole -- ^ The hole + -> TcM (SolverReportErrCtxt, ValidHoleFits) + -- ^ We return the new context + -- with a possibly updated + -- tidy environment, and + -- the valid hole fits. +validHoleFits ctxt@(CEC { cec_encl = implics + , cec_tidy = lcl_env}) simps hole + = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (map mk_wanted simps) hole ; return (ctxt {cec_tidy = tidy_env}, fits) } + where + mk_wanted :: ErrorItem -> CtEvidence + mk_wanted (EI { ei_pred = pred, ei_evdest = Just dest, ei_loc = loc }) + = CtWanted { ctev_pred = pred + , ctev_dest = dest + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + mk_wanted item = pprPanic "validHoleFits no evdest" (ppr item) -- See Note [Constraints include ...] givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)] @@ -1300,13 +1416,16 @@ givenConstraints ctxt ---------------- -mkIPErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport -mkIPErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let msg = important ctxt $ UnboundImplicitParams (ct1 :| others) +mkIPErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport +-- What would happen if an item is suppressed because of +-- Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint? Very unclear +-- what's best. Let's not worry about this. +mkIPErr ctxt items + = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1 + ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others) ; return $ msg `mappend` mk_relevant_bindings binds_msg } where - ct1:others = cts + item1:others = items ---------------- @@ -1314,15 +1433,15 @@ mkIPErr ctxt cts -- Wanted constraints arising from representation-polymorphism checks. -- -- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin. -mkFRRErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport -mkFRRErr ctxt cts +mkFRRErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport +mkFRRErr ctxt items = do { -- Zonking/tidying. ; origs <- -- Zonk/tidy the 'CtOrigin's. - zonkTidyOrigins (cec_tidy ctxt) (map ctOrigin cts) + zonkTidyOrigins (cec_tidy ctxt) (map errorItemOrigin items) <&> -- Then remove duplicates: only retain one 'CtOrigin' per representation-polymorphic type. - (nubOrdBy (nonDetCmpType `on` (snd . frr_orig_and_type)) . snd) + (nubOrdBy (nonDetCmpType `on` (snd . frr_orig_and_type)) . snd) -- Obtain all the errors we want to report (constraints with FixedRuntimeRep origin), -- with the corresponding types: -- ty1 :: TYPE rep1, ty2 :: TYPE rep2, ... @@ -1396,21 +1515,29 @@ any more. So we don't assert that it is. -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport -mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct -mkEqErr _ [] = panic "mkEqErr" - -mkEqErr1 :: SolverReportErrCtxt -> Ct -> TcM SolverReport -mkEqErr1 ctxt ct -- Wanted or derived; - -- givens handled in mkGivenErrorReporter - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct +mkEqErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport +mkEqErr ctxt items + | item:_ <- filter (not . ei_suppress) items + = mkEqErr1 ctxt item + + | item:_ <- items -- they're all suppressed. still need an error message + -- for -fdefer-type-errors though + = mkEqErr1 ctxt item + + | otherwise + = panic "mkEqErr" -- guaranteed to have at least one item + +mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport +mkEqErr1 ctxt item -- Wanted only + -- givens handled in mkGivenErrorReporter + = do { (ctxt, binds_msg, item) <- relevantBindings True ctxt item ; rdr_env <- getGlobalRdrEnv ; fam_envs <- tcGetFamInstEnvs - ; let mb_coercible_msg = case ctEqRel ct of + ; let mb_coercible_msg = case errorItemEqRel item of NomEq -> Nothing ReprEq -> ReportCoercibleMsg <$> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) - ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt ct ty1 ty2 + ; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item)) + ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt item ty1 ty2 ; let report = foldMap (important ctxt) (reverse prev_msgs) `mappend` (important ctxt $ mkTcReportWithInfo last_msg $ maybeToList mb_coercible_msg) @@ -1418,7 +1545,7 @@ mkEqErr1 ctxt ct -- Wanted or derived; `mappend` (mk_report_hints hints) ; return report } where - (ty1, ty2) = getEqPredTys (ctPred ct) + (ty1, ty2) = getEqPredTys (errorItemPred item) -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint -- is left over. @@ -1465,41 +1592,40 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 type AccReportMsgs = NonEmpty TcSolverReportMsg mkEqErr_help :: SolverReportErrCtxt - -> Ct + -> ErrorItem -> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint]) -mkEqErr_help ctxt ct ty1 ty2 +mkEqErr_help ctxt item ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 - = mkTyVarEqErr ctxt ct tv1 ty2 + = mkTyVarEqErr ctxt item tv1 ty2 | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2 - = mkTyVarEqErr ctxt ct tv2 ty1 + = mkTyVarEqErr ctxt item tv2 ty1 | otherwise - = return (reportEqErr ctxt ct ty1 ty2 :| [], []) + = return (reportEqErr ctxt item ty1 ty2 :| [], []) reportEqErr :: SolverReportErrCtxt - -> Ct + -> ErrorItem -> TcType -> TcType -> TcSolverReportMsg -reportEqErr ctxt ct ty1 ty2 +reportEqErr ctxt item ty1 ty2 = mkTcReportWithInfo mismatch eqInfos where - mismatch = misMatchOrCND False ctxt ct ty1 ty2 - eqInfos = eqInfoMsgs ct ty1 ty2 + mismatch = misMatchOrCND False ctxt item ty1 ty2 + eqInfos = eqInfoMsgs ty1 ty2 -mkTyVarEqErr :: SolverReportErrCtxt -> Ct +mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint]) -- tv1 and ty2 are already tidied -mkTyVarEqErr ctxt ct tv1 ty2 - = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) - ; dflags <- getDynFlags - ; mkTyVarEqErr' dflags ctxt ct tv1 ty2 } +mkTyVarEqErr ctxt item tv1 ty2 + = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr tv1 $$ ppr ty2) + ; mkTyVarEqErr' ctxt item tv1 ty2 } -mkTyVarEqErr' :: DynFlags -> SolverReportErrCtxt -> Ct +mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint]) -mkTyVarEqErr' dflags ctxt ct tv1 ty2 +mkTyVarEqErr' ctxt item tv1 ty2 -- impredicativity is a simple error to understand; try it first | check_eq_result `cterHasProblem` cteImpredicative = do tyvar_eq_info <- extraTyVarEqInfo tv1 ty2 let - poly_msg = CannotUnifyWithPolytype ct tv1 ty2 + poly_msg = CannotUnifyWithPolytype item tv1 ty2 poly_msg_with_info | isSkolemTyVar tv1 = mkTcReportWithInfo poly_msg tyvar_eq_info @@ -1513,7 +1639,7 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2 | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) - || ctEqRel ct == ReprEq + || errorItemEqRel item == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) = do tv_extra <- extraTyVarEqInfo tv1 ty2 @@ -1523,7 +1649,7 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2 -- We report an "occurs check" even for a ~ F t a, where F is a type -- function; it's not insoluble (because in principle F could reduce) -- but we have certainly been unable to solve it - = let extras2 = eqInfoMsgs ct ty1 ty2 + = let extras2 = eqInfoMsgs ty1 ty2 interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ filter isTyVar $ @@ -1536,6 +1662,11 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2 in return (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], []) + -- This is wrinkle (4) in Note [Equalities with incompatible kinds] in + -- GHC.Tc.Solver.Canonical + | hasCoercionHoleTy ty2 + = return (mkBlockedEqErr item :| [], []) + -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably -- it started life as a TyVarTv, else it'd have been unified, given @@ -1552,7 +1683,7 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2 , Implic { ic_skols = skols } <- implic , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols , not (null esc_skols) - = return (SkolemEscape ct implic esc_skols :| [mismatch_msg], []) + = return (SkolemEscape item implic esc_skols :| [mismatch_msg], []) -- Nastiest case: attempt to unify an untouchable variable -- So tv is a meta tyvar (or started that way before we @@ -1568,43 +1699,48 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2 return (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig) | otherwise - = return (reportEqErr ctxt ct (mkTyVarTy tv1) ty2 :| [], []) + = return (reportEqErr ctxt item (mkTyVarTy tv1) ty2 :| [], []) -- This *can* happen (#6123) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function. where - headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 - mismatch_msg = mkMismatchMsg ct ty1 ty2 + headline_msg = misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2 + mismatch_msg = mkMismatchMsg item ty1 ty2 add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2 ty1 = mkTyVarTy tv1 - check_eq_result = case ct of - CIrredCan { cc_reason = NonCanonicalReason result } -> result - CIrredCan { cc_reason = HoleBlockerReason {} } -> cteProblem cteHoleBlocker - _ -> checkTyVarEq dflags tv1 ty2 + check_eq_result = case ei_m_reason item of + Just (NonCanonicalReason result) -> result + _ -> checkTyVarEq tv1 ty2 -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type -- variable is on the right, so we don't get useful info for the CIrredCan, -- and have to compute the result of checkTyVarEq here. insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs -eqInfoMsgs :: Ct -> TcType -> TcType -> [TcSolverReportInfo] +eqInfoMsgs :: TcType -> TcType -> [TcSolverReportInfo] -- Report (a) ambiguity if either side is a type function application -- e.g. F a0 ~ Int -- (b) warning about injectivity if both sides are the same -- type function application F a ~ F b -- See Note [Non-injective type functions] -eqInfoMsgs ct ty1 ty2 +eqInfoMsgs ty1 ty2 = catMaybes [tyfun_msg, ambig_msg] where mb_fun1 = isTyFun_maybe ty1 mb_fun2 = isTyFun_maybe ty2 - (ambig_kvs, ambig_tvs) = getAmbigTkvs ct + + -- if a type isn't headed by a type function, then any ambiguous + -- variables need not be reported as such. e.g.: F a ~ t0 -> t0, where a is a skolem + ambig_tkvs1 = maybe mempty (\_ -> ambigTkvsOfTy ty1) mb_fun1 + ambig_tkvs2 = maybe mempty (\_ -> ambigTkvsOfTy ty2) mb_fun2 + + ambig_tkvs@(ambig_kvs, ambig_tvs) = ambig_tkvs1 S.<> ambig_tkvs2 ambig_msg | isJust mb_fun1 || isJust mb_fun2 , not (null ambig_kvs && null ambig_tvs) - = Just $ Ambiguity False (ambig_kvs, ambig_tvs) + = Just $ Ambiguity False ambig_tkvs | otherwise = Nothing @@ -1616,24 +1752,23 @@ eqInfoMsgs ct ty1 ty2 | otherwise = Nothing -misMatchOrCND :: Bool -> SolverReportErrCtxt -> Ct +misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem -> TcType -> TcType -> TcSolverReportMsg -- If oriented then ty1 is actual, ty2 is expected -misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 +misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2 | insoluble_occurs_check -- See Note [Insoluble occurs check] || (isRigidTy ty1 && isRigidTy ty2) - || isGivenCt ct + || (ei_flavour item == Given) || null givens = -- If the equality is unconditionally insoluble -- or there is no context, don't report the context - mkMismatchMsg ct ty1 ty2 + mkMismatchMsg item ty1 ty2 | otherwise - = CouldNotDeduce givens (ct :| []) (Just $ CND_Extra level ty1 ty2) + = CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2) where - ev = ctEvidence ct - level = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel + level = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ] -- Keep only UserGivens that have some equalities. -- See Note [Suppress redundant givens during error reporting] @@ -1643,9 +1778,8 @@ misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message. -mkBlockedEqErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport -mkBlockedEqErr ctxt (ct:_) = return $ important ctxt (BlockedEquality ct) -mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" +mkBlockedEqErr :: ErrorItem -> TcSolverReportMsg +mkBlockedEqErr item = BlockedEquality item {- Note [Suppress redundant givens during error reporting] @@ -1732,53 +1866,49 @@ suggestAddSig ctxt ty1 _ty2 = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv -------------------- - -mkMismatchMsg :: Ct -> Type -> Type -> TcSolverReportMsg -mkMismatchMsg ct ty1 ty2 = - case ctOrigin ct of +mkMismatchMsg :: ErrorItem -> Type -> Type -> TcSolverReportMsg +mkMismatchMsg item ty1 ty2 = + case orig of TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> mkTcReportWithInfo (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds - , teq_mismatch_ct = ct - , teq_mismatch_ty1 = ty1 - , teq_mismatch_ty2 = ty2 + , teq_mismatch_item = item + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 , teq_mismatch_actual = uo_actual , teq_mismatch_expected = uo_expected , teq_mismatch_what = mb_thing}) extras KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k -> - mkTcReportWithInfo (Mismatch False ct ty1 ty2) + mkTcReportWithInfo (Mismatch False item ty1 ty2) (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k : extras) _ -> mkTcReportWithInfo - (Mismatch False ct ty1 ty2) + (Mismatch False item ty1 ty2) extras where - orig = ctOrigin ct + orig = errorItemOrigin item extras = sameOccExtras ty2 ty1 ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig --- | Whether to prints explicit kinds (with @-fprint-explicit-kinds@) +-- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) -- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments. -- -- This function first checks to see if the 'CtOrigin' argument is a --- 'TypeEqOrigin', and if so, uses the expected/actual types from that to --- check for a kind mismatch (as these types typically have more surrounding --- types and are likelier to be able to glean information about whether a --- mismatch occurred in an invisible argument position or not). If the --- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types --- themselves. +-- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible +-- equality; if it's not, definitely print the kinds. Even if the equality is +-- a visible equality, check the expected/actual types to see if the types +-- have equal visible components. If the 'CtOrigin' is +-- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves. shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool -shouldPprWithExplicitKinds ty1 ty2 ct - = tcEqTypeVis act_ty exp_ty - -- True when the visible bit of the types look the same, - -- so we want to show the kinds in the displayed type. - where - (act_ty, exp_ty) = case ct of - TypeEqOrigin { uo_actual = act - , uo_expected = exp } -> (act, exp) - _ -> (ty1, ty2) +shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act + , uo_expected = exp + , uo_visible = vis }) + | not vis = True -- See tests T15870, T16204c + | otherwise = tcEqTypeVis act exp -- See tests T9171, T9144. +shouldPprWithExplicitKinds ty1 ty2 _ct + = tcEqTypeVis ty1 ty2 {- Note [Insoluble occurs check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1880,39 +2010,44 @@ Warn of loopy local equalities that were dropped. ************************************************************************ -} -mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [Ct] -> TcM SolverReport -mkDictErr ctxt cts - = assert (not (null cts)) $ +mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport +mkDictErr ctxt orig_items + = assert (not (null items)) $ do { inst_envs <- tcGetInstEnvs - ; let min_cts = elim_superclasses cts - lookups = map (lookup_cls_inst inst_envs) min_cts - (no_inst_cts, overlap_cts) = partition is_no_inst lookups + ; let min_items = elim_superclasses items + lookups = map (lookup_cls_inst inst_envs) min_items + (no_inst_items, overlap_items) = partition is_no_inst lookups -- Report definite no-instance errors, -- or (iff there are none) overlap errors -- But we report only one of them (hence 'head') because they all -- have the same source-location origin, to try avoid a cascade -- of error from one location - ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) + ; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items)) ; return $ important ctxt err } where + filtered_items = filter (not . ei_suppress) orig_items + items | null filtered_items = orig_items -- all suppressed, but must report + -- something for -fdefer-type-errors + | otherwise = filtered_items -- common case + no_givens = null (getUserGivens ctxt) - is_no_inst (ct, (matches, unifiers, _)) + is_no_inst (item, (matches, unifiers, _)) = no_givens && null matches - && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) + && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfTypeList (errorItemPred item))) - lookup_cls_inst inst_envs ct - = (ct, lookupInstEnv True inst_envs clas tys) + lookup_cls_inst inst_envs item + = (item, lookupInstEnv True inst_envs clas tys) where - (clas, tys) = getClassPredTys (ctPred ct) + (clas, tys) = getClassPredTys (errorItemPred item) -- When simplifying [W] Ord (Set a), we need -- [W] Eq a, [W] Ord a -- but we really only want to report the latter - elim_superclasses cts = mkMinimalBySCs ctPred cts + elim_superclasses items = mkMinimalBySCs errorItemPred items -- Note [mk_dict_err] -- ~~~~~~~~~~~~~~~~~~~ @@ -1925,16 +2060,16 @@ mkDictErr ctxt cts -- - One match, one or more unifiers: report "Overlapping instances for", show the -- matching and unifying instances, and say "The choice depends on the instantion of ..., -- and the result of evaluating ...". -mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (Ct, ClsInstLookupResult) +mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult) -> TcM TcSolverReportMsg -- Report an overlap error if this class constraint results -- from an overlap (returning Left clas), otherwise return (Right pred) -mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) +mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) | null matches -- No matches but perhaps several unifiers - = do { (_, rel_binds, ct) <- relevantBindings True ctxt ct + = do { (_, rel_binds, item) <- relevantBindings True ctxt item ; candidate_insts <- get_candidate_instances ; (imp_errs, field_suggestions) <- record_field_suggestions - ; return (cannot_resolve_msg ct candidate_insts rel_binds imp_errs field_suggestions) } + ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) } | null unsafe_overlapped -- Some matches => overlap errors = return $ overlap_msg @@ -1942,8 +2077,8 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) | otherwise = return $ safe_haskell_msg where - orig = ctOrigin ct - pred = ctPred ct + orig = errorItemOrigin item + pred = errorItemPred item (clas, tys) = getClassPredTys pred ispecs = [ispec | (ispec, _) <- matches] unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] @@ -1990,21 +2125,22 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) HasFieldOrigin name -> Just (mkVarOccFS name) _ -> Nothing - cannot_resolve_msg :: Ct -> [ClsInst] -> RelevantBindings -> [ImportError] -> [GhcHint] -> TcSolverReportMsg - cannot_resolve_msg ct candidate_insts binds imp_errs field_suggestions - = CannotResolveInstance ct (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds + cannot_resolve_msg :: ErrorItem -> [ClsInst] -> RelevantBindings + -> [ImportError] -> [GhcHint] -> TcSolverReportMsg + cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions + = CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds -- Overlap errors. overlap_msg, safe_haskell_msg :: TcSolverReportMsg -- Normal overlap error overlap_msg - = assert (not (null matches)) $ OverlappingInstances ct ispecs (getPotentialUnifiers unifiers) + = assert (not (null matches)) $ OverlappingInstances item ispecs (getPotentialUnifiers unifiers) -- Overlap error because of Safe Haskell (first -- match should be the most specific match) safe_haskell_msg = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $ - UnsafeOverlap ct ispecs unsafe_ispecs + UnsafeOverlap item ispecs unsafe_ispecs {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2086,14 +2222,6 @@ the above error message would instead be displayed as: Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. -} -getAmbigTkvs :: Ct -> ([Var],[Var]) -getAmbigTkvs ct - = partition (`elemVarSet` dep_tkv_set) ambig_tkvs - where - tkvs = tyCoVarsOfCtList ct - ambig_tkvs = filter isAmbiguousTyVar tkvs - dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) - ----------------------- -- relevantBindings looks at the value environment and finds values whose -- types mention any of the offending type variables. It has to be @@ -2105,11 +2233,11 @@ getAmbigTkvs ct relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering -- See #8191 - -> SolverReportErrCtxt -> Ct - -> TcM (SolverReportErrCtxt, RelevantBindings, Ct) + -> SolverReportErrCtxt -> ErrorItem + -> TcM (SolverReportErrCtxt, RelevantBindings, ErrorItem) -- Also returns the zonked and tidied CtOrigin of the constraint -relevantBindings want_filtering ctxt ct - = do { traceTc "relevantBindings" (ppr ct) +relevantBindings want_filtering ctxt item + = do { traceTc "relevantBindings" (ppr item) ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) -- For *kind* errors, report the relevant bindings of the @@ -2117,19 +2245,19 @@ relevantBindings want_filtering ctxt ct ; let extra_tvs = case tidy_orig of KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2] _ -> emptyVarSet - ct_fvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs + ct_fvs = tyCoVarsOfType (errorItemPred item) `unionVarSet` extra_tvs - -- Put a zonked, tidied CtOrigin into the Ct + -- Put a zonked, tidied CtOrigin into the ErrorItem loc' = setCtLocOrigin loc tidy_orig - ct' = setCtLoc ct loc' + item' = item { ei_loc = loc' } ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env] ; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs ; let ctxt' = ctxt { cec_tidy = env2 } - ; return (ctxt', relev_bds, ct') } + ; return (ctxt', relev_bds, item') } where - loc = ctLoc ct + loc = errorItemCtLoc item lcl_env = ctLocEnv loc -- slightly more general version, to work also with holes @@ -2222,9 +2350,12 @@ warnDefaulting _ [] _ warnDefaulting the_tv wanteds@(ct:_) default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 $ - tyCoVarsOfCtsList (listToBag wanteds) - tidy_wanteds = map (tidyCt tidy_env) wanteds + -- don't want to report all the superclass constraints, which + -- add unhelpful clutter + ; let filtered = filter (not . isWantedSuperclassOrigin . ctOrigin) wanteds + tidy_env = tidyFreeTyCoVars env0 $ + tyCoVarsOfCtsList (listToBag filtered) + tidy_wanteds = map (tidyCt tidy_env) filtered tidy_tv = lookupVarEnv (snd tidy_env) the_tv diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty loc = ctLoc ct @@ -2236,36 +2367,8 @@ Note [Runtime skolems] We want to give a reasonably helpful error message for ambiguity arising from *runtime* skolems in the debugger. These are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType. - -************************************************************************ -* * - Error from the canonicaliser - These ones are called *during* constraint simplification -* * -************************************************************************ -} -solverDepthErrorTcS :: CtLoc -> TcType -> TcM a -solverDepthErrorTcS loc ty - = setCtLocM loc $ - do { ty <- zonkTcType ty - ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) - tidy_ty = tidyType tidy_env ty - msg = TcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Reduction stack overflow; size =" <+> ppr depth - , hang (text "When simplifying the following type:") - 2 (ppr tidy_ty) - , note ] - ; failWithTcM (tidy_env, msg) } - where - depth = ctLocDepth loc - note = vcat - [ text "Use -freduction-depth=0 to disable this check" - , text "(any upper bound you could choose might fail unpredictably with" - , text " minor updates to GHC, so disabling the check is recommended if" - , text " you're sure that type checking should terminate)" ] - {-********************************************************************** * * GHC API helper functions diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 4115d6b198..079bbd5df5 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -18,7 +18,7 @@ module GHC.Tc.Errors.Hole , getHoleFitDispConfig , HoleFitDispConfig (..) , HoleFitSortingAlg (..) - , relevantCts + , relevantCtEvidence , zonkSubs , sortHoleFitsByGraph @@ -68,7 +68,8 @@ import Data.List ( partition, sort, sortOn, nubBy ) import Data.Graph ( graphFromEdges, topSort ) -import GHC.Tc.Solver ( simplifyTopWanteds, runTcSDerivedsEarlyAbort ) +import GHC.Tc.Solver ( simplifyTopWanteds ) +import GHC.Tc.Solver.Monad ( runTcSEarlyAbort ) import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) import GHC.HsToCore.Docs ( extractDocs ) @@ -189,7 +190,7 @@ Here the nested implications are just one level deep, namely: Given = $dShow_a1pc :: Show a_a1pa[sk:2] Wanted = WC {wc_simple = - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))} + [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))} Binds = EvBindsVar<a1pi> Needed inner = [] Needed outer = [] @@ -218,7 +219,7 @@ needing to check whether the following constraints are soluble. Given = $dShow_a1pc :: Show a_a1pa[sk:2] Wanted = WC {wc_simple = - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)} + [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)} Binds = EvBindsVar<a1pl> Needed inner = [] Needed outer = [] @@ -361,7 +362,7 @@ as is the case in Here, the hole is given type a0_a1kv[tau:1]. Then, the emitted constraint is: - [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical) + [W] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical) However, when there are multiple holes, we need to be more careful. As an example, Let's take a look at the following code: @@ -373,8 +374,8 @@ Here there are two holes, `_a` and `_b`. Suppose _a :: a0_a1pd[tau:2] and _b :: a1_a1po[tau:2]. Then, the simple constraints passed to findValidHoleFits are: - [[WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical), - [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)] + [[W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical), + [W] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)] When we are looking for a match for the hole `_a`, we filter the simple constraints to the "Relevant constraints", by throwing out any constraints @@ -402,9 +403,9 @@ a constraint to show that `hole_ty ~ ty`, including any constraints in `ty`. For example, if `hole_ty = Int` and `ty = Foldable t => (a -> Bool) -> t a -> Bool`, we'd have `(a_a1pa[sk:1] -> Bool) -> t_t2jk[sk:1] a_a1pa[sk:1] -> Bool ~# Int` from the coercion, as well as `Foldable t_t2jk[sk:1]`. By adding a flag to -`TcSEnv` and adding a `runTcSDerivedsEarlyAbort`, we can fail as soon as we hit +`TcSEnv` and adding a `runTcSEarlyAbort`, we can fail as soon as we hit an insoluble constraint. Since we don't need the result in the case that it -fails, a boolean `False` (i.e. "it didn't work" from `runTcSDerivedsEarlyAbort`) +fails, a boolean `False` (i.e. "it didn't work" from `runTcSEarlyAbort`) is sufficient. We also check whether the type of the hole is an immutable type variable (i.e. @@ -552,7 +553,7 @@ getLocalBindings tidy_orig ct_loc -- See Note [Valid hole fits include ...] findValidHoleFits :: TidyEnv -- ^ The tidy_env for zonking -> [Implication] -- ^ Enclosing implications for givens - -> [Ct] + -> [CtEvidence] -- ^ The unsolved simple constraints in the implication for -- the hole. -> Hole @@ -569,7 +570,7 @@ findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ ; let findVLimit = if sortingAlg > HFSNoSorting then Nothing else maxVSubs refLevel = refLevelHoleFits dflags hole = TypedHole { th_relevant_cts = - listToBag (relevantCts hole_ty simples) + listToBag (relevantCtEvidence hole_ty simples) , th_implics = implics , th_hole = Just h } (candidatePlugins, fitPlugins) = @@ -690,21 +691,20 @@ findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ findValidHoleFits env _ _ _ = return (env, noValidHoleFits) -- See Note [Relevant constraints] -relevantCts :: Type -> [Ct] -> [Ct] -relevantCts hole_ty simples = if isEmptyVarSet (fvVarSet hole_fvs) then [] - else filter isRelevant simples - where ctFreeVarSet :: Ct -> VarSet - ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred - hole_fvs = tyCoFVsOfType hole_ty +relevantCtEvidence :: Type -> [CtEvidence] -> [CtEvidence] +relevantCtEvidence hole_ty simples + = if isEmptyVarSet (fvVarSet hole_fvs) + then [] + else filter isRelevant simples + where hole_fvs = tyCoFVsOfType hole_ty hole_fv_set = fvVarSet hole_fvs - anyFVMentioned :: Ct -> Bool - anyFVMentioned ct = ctFreeVarSet ct `intersectsVarSet` hole_fv_set -- We filter out those constraints that have no variables (since -- they won't be solved by finding a type for the type variable -- representing the hole) and also other holes, since we're not -- trying to find hole fits for many holes at once. - isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct)) - && anyFVMentioned ct + isRelevant ctev = not (isEmptyVarSet fvs) && + (fvs `intersectsVarSet` hole_fv_set) + where fvs = tyCoVarsOfCtEv ctev -- We zonk the hole fits so that the output aligns with the rest -- of the typed hole error message output. @@ -962,7 +962,7 @@ tcCheckHoleFit (TypedHole {..}) hole_ty ty = discardErrs $ -- imp is the innermost implication (imp:_) -> return (ic_tclvl imp) ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $ - tcSubTypeSigma (ExprSigCtxt NoRRC) ty hole_ty + tcSubTypeSigma orig (ExprSigCtxt NoRRC) ty hole_ty ; traceTc "Checking hole fit {" empty ; traceTc "wanteds are: " $ ppr wanted ; if isEmptyWC wanted && isEmptyBag th_relevant_cts @@ -971,11 +971,12 @@ tcCheckHoleFit (TypedHole {..}) hole_ty ty = discardErrs $ else do { fresh_binds <- newTcEvBinds -- The relevant constraints may contain HoleDests, so we must -- take care to clone them as well (to avoid #15370). - ; cloned_relevants <- mapBagM cloneWanted th_relevant_cts + ; cloned_relevants <- mapBagM cloneWantedCtEv th_relevant_cts -- We wrap the WC in the nested implications, for details, see -- Note [Checking hole fits] ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics - final_wc = wrapInImpls $ addSimples wanted cloned_relevants + final_wc = wrapInImpls $ addSimples wanted $ + mapBag mkNonCanonical cloned_relevants -- We add the cloned relevants to the wanteds generated -- by the call to tcSubType_NC, for details, see -- Note [Relevant constraints]. There's no need to clone @@ -983,14 +984,15 @@ tcCheckHoleFit (TypedHole {..}) hole_ty ty = discardErrs $ -- call to`tcSubtype_NC`. ; traceTc "final_wc is: " $ ppr final_wc -- See Note [Speeding up valid hole-fits] - ; (rem, _) <- tryTc $ runTcSDerivedsEarlyAbort $ simplifyTopWanteds final_wc + ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc ; traceTc "}" empty - ; return (any isSolvedWC rem, wrap) - } } - where - setWCAndBinds :: EvBindsVar -- Fresh ev binds var. - -> Implication -- The implication to put WC in. - -> WantedConstraints -- The WC constraints to put implic. - -> WantedConstraints -- The new constraints. - setWCAndBinds binds imp wc - = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds } + ; return (any isSolvedWC rem, wrap) } } + where + orig = ExprHoleOrigin (hole_occ <$> th_hole) + + setWCAndBinds :: EvBindsVar -- Fresh ev binds var. + -> Implication -- The implication to put WC in. + -> WantedConstraints -- The WC constraints to put implic. + -> WantedConstraints -- The new constraints. + setWCAndBinds binds imp wc + = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds } diff --git a/compiler/GHC/Tc/Errors/Hole.hs-boot b/compiler/GHC/Tc/Errors/Hole.hs-boot index 94d3f51c58..7bb50eb825 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs-boot +++ b/compiler/GHC/Tc/Errors/Hole.hs-boot @@ -7,18 +7,18 @@ module GHC.Tc.Errors.Hole where import GHC.Types.Var ( Id ) import GHC.Tc.Errors.Types ( HoleFitDispConfig, ValidHoleFits ) import GHC.Tc.Types ( TcM ) -import GHC.Tc.Types.Constraint ( Ct, CtLoc, Hole, Implication ) +import GHC.Tc.Types.Constraint ( CtEvidence, CtLoc, Hole, Implication ) import GHC.Utils.Outputable ( SDoc ) import GHC.Types.Var.Env ( TidyEnv ) import GHC.Tc.Errors.Hole.FitTypes ( HoleFit, TypedHole, HoleFitCandidate ) -import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, Type, TcTyVar ) +import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, TcTyVar ) import GHC.Tc.Types.Evidence ( HsWrapper ) import GHC.Utils.FV ( FV ) import Data.Bool ( Bool ) import Data.Maybe ( Maybe ) import Data.Int ( Int ) -findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Hole +findValidHoleFits :: TidyEnv -> [Implication] -> [CtEvidence] -> Hole -> TcM (TidyEnv, ValidHoleFits) tcCheckHoleFit :: TypedHole -> TcSigmaType -> TcSigmaType @@ -37,7 +37,6 @@ pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc getHoleFitSortingAlg :: TcM HoleFitSortingAlg getHoleFitDispConfig :: TcM HoleFitDispConfig -relevantCts :: Type -> [Ct] -> [Ct] zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit]) sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit] sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit] diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs index 70a655db45..077bdaab18 100644 --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs @@ -19,15 +19,17 @@ import GHC.Types.Id import GHC.Utils.Outputable import GHC.Types.Name +import GHC.Data.Bag + import Data.Function ( on ) -data TypedHole = TypedHole { th_relevant_cts :: Cts +data TypedHole = TypedHole { th_relevant_cts :: Bag CtEvidence -- ^ Any relevant Cts to the hole , th_implics :: [Implication] -- ^ The nested implications of the hole with the -- innermost implication first. , th_hole :: Maybe Hole - -- ^ The hole itself, if available. Only for debugging. + -- ^ The hole itself, if available. } instance Outputable TypedHole where diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index d1ea6d93e2..a736a40871 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -226,11 +226,17 @@ instance Diagnostic TcRnMessage where <+> text "with" <+> quotes (ppr n2)) 2 (hang (text "both bound by the partial type signature:") 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) - TcRnPartialTypeSigBadQuantifier n fn_name hs_ty + TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty -> mkSimpleDecorated $ hang (text "Can't quantify over" <+> quotes (ppr n)) - 2 (hang (text "bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) + 2 (vcat [ hang (text "bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty) + , extra ]) + where + extra | Just rhs_ty <- m_unif_ty + = sep [ quotes (ppr n), text "should really be", quotes (ppr rhs_ty) ] + | otherwise + = empty TcRnMissingSignature what _ _ -> mkSimpleDecorated $ case what of @@ -294,9 +300,6 @@ instance Diagnostic TcRnMessage where text "in the type of a term:") 2 (pprType ty) , text "(GHC does not yet support this)" ] - TcRnIllegalEqualConstraints ty - -> mkSimpleDecorated $ - text "Illegal equational constraint" <+> pprType ty TcRnBadQuantPredHead ty -> mkSimpleDecorated $ hang (text "Quantified predicate must have a class or type variable head:") @@ -744,8 +747,6 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnVDQInTermType{} -> ErrorWithoutFlag - TcRnIllegalEqualConstraints{} - -> ErrorWithoutFlag TcRnBadQuantPredHead{} -> ErrorWithoutFlag TcRnIllegalTupleConstraint{} @@ -982,8 +983,6 @@ instance Diagnostic TcRnMessage where -> noHints TcRnVDQInTermType{} -> noHints - TcRnIllegalEqualConstraints{} - -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]] TcRnBadQuantPredHead{} -> noHints TcRnIllegalTupleConstraint{} @@ -1531,7 +1530,7 @@ pprTcSolverReportMsg _ (UserTypeError ty) = pprUserTypeErrorTy ty pprTcSolverReportMsg ctxt (ReportHoleError hole err) = pprHoleError ctxt hole err -pprTcSolverReportMsg _ (CannotUnifyWithPolytype ct tv1 ty2) = +pprTcSolverReportMsg _ (CannotUnifyWithPolytype item tv1 ty2) = vcat [ (if isSkolemTyVar tv1 then text "Cannot equate type variable" else text "Cannot instantiate unification variable") @@ -1539,13 +1538,13 @@ pprTcSolverReportMsg _ (CannotUnifyWithPolytype ct tv1 ty2) = , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] where what = text $ levelString $ - ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel pprTcSolverReportMsg _ - (Mismatch { mismatch_ea = add_ea - , mismatch_ct = ct - , mismatch_ty1 = ty1 - , mismatch_ty2 = ty2 }) - = addArising (ctOrigin ct) msg + (Mismatch { mismatch_ea = add_ea + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 }) + = addArising (errorItemOrigin item) msg where msg | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || @@ -1576,9 +1575,9 @@ pprTcSolverReportMsg _ padding = length herald1 - length herald2 - is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } + is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False } - what = levelString (ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel) + what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel) conc :: [String] -> String conc = foldr1 add_space @@ -1605,9 +1604,9 @@ pprTcSolverReportMsg _ pprTcSolverReportMsg ctxt (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds - , teq_mismatch_ct = ct - , teq_mismatch_ty1 = ty1 - , teq_mismatch_ty2 = ty2 + , teq_mismatch_item = item + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 , teq_mismatch_expected = exp , teq_mismatch_actual = act , teq_mismatch_what = mb_thing }) @@ -1628,21 +1627,21 @@ pprTcSolverReportMsg ctxt Just thing -> quotes (ppr thing) <+> text "has kind" , quotes (pprWithTYPE act) ] | Just nargs_msg <- num_args_msg - , Right ea_msg <- mk_ea_msg ctxt (Just ct) level orig + , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig = nargs_msg $$ pprTcSolverReportMsg ctxt ea_msg | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $ ea_looks_same ty1 ty2 exp act - , Right ea_msg <- mk_ea_msg ctxt (Just ct) level orig + , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig = pprTcSolverReportMsg ctxt ea_msg -- The mismatched types are /inside/ exp and act - | let mismatch_err = Mismatch False ct ty1 ty2 + | let mismatch_err = Mismatch False item ty1 ty2 errs = case mk_ea_msg ctxt Nothing level orig of Left ea_info -> [ mkTcReportWithInfo mismatch_err ea_info ] Right ea_err -> [ mismatch_err, ea_err ] = vcat $ map (pprTcSolverReportMsg ctxt) errs - ct_loc = ctLoc ct - orig = ctOrigin ct + ct_loc = errorItemCtLoc item + orig = errorItemOrigin item level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel thing_msg (Just thing) _ levity = quotes (ppr thing) <+> text "is" <+> levity @@ -1683,7 +1682,7 @@ pprTcSolverReportMsg _ (FixedRuntimeRepError origs_and_tys) = ,nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty)] in vcat $ map (uncurry combine_origin_ty) origs_and_tys -pprTcSolverReportMsg _ (SkolemEscape ct implic esc_skols) = +pprTcSolverReportMsg _ (SkolemEscape item implic esc_skols) = let esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols <+> pprQuotedList esc_skols @@ -1703,7 +1702,7 @@ pprTcSolverReportMsg _ (SkolemEscape ct implic esc_skols) = ppr (getLclEnvLoc (ic_env implic)) ] ] where what = text $ levelString $ - ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel pprTcSolverReportMsg _ (UntouchableVariable tv implic) | Implic { ic_given = given, ic_info = skol_info } <- implic = sep [ quotes (ppr tv) <+> text "is untouchable" @@ -1711,9 +1710,9 @@ pprTcSolverReportMsg _ (UntouchableVariable tv implic) , nest 2 $ text "bound by" <+> ppr skol_info , nest 2 $ text "at" <+> ppr (getLclEnvLoc (ic_env implic)) ] -pprTcSolverReportMsg _ (BlockedEquality ct) = +pprTcSolverReportMsg _ (BlockedEquality item) = vcat [ hang (text "Cannot use equality for substitution:") - 2 (ppr (ctPred ct)) + 2 (ppr (errorItemPred item)) , text "Doing so would be ill-kinded." ] pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) = text "Expecting" <+> speakN (abs n) <+> @@ -1722,16 +1721,16 @@ pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) = more | n == 1 = text "more argument to" | otherwise = text "more arguments to" -- n > 1 -pprTcSolverReportMsg ctxt (UnboundImplicitParams (ct :| cts)) = +pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) = let givens = getUserGivens ctxt in if null givens - then addArising (ctOrigin ct) $ + then addArising (errorItemOrigin item) $ sep [ text "Unbound implicit parameter" <> plural preds , nest 2 (pprParendTheta preds) ] - else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (ct :| cts) Nothing) + else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (item :| items) Nothing) where - preds = map ctPred (ct : cts) -pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (ct :| others) mb_extra) + preds = map errorItemPred (item : items) +pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) = main_msg $$ case supplementary of Left infos @@ -1741,17 +1740,17 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (ct :| others) mb_extra) where main_msg | null useful_givens - = addArising (ctOrigin ct) no_instance_msg + = addArising orig no_instance_msg | otherwise - = vcat [ addArising (ctOrigin ct) no_deduce_msg + = vcat [ addArising orig no_deduce_msg , vcat (pp_givens useful_givens) ] supplementary = case mb_extra of Nothing -> Left [] Just (CND_Extra level ty1 ty2) -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig - (wanted, wanteds) = (ctPred ct, map ctPred others) - orig = ctOrigin ct + (wanted, wanteds) = (errorItemPred item, map errorItemPred others) + orig = errorItemOrigin item no_instance_msg | null others , Just (tc, _) <- splitTyConApp_maybe wanted @@ -1765,13 +1764,13 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (ct :| others) mb_extra) = text "Could not deduce" <+> pprParendType wanted | otherwise = text "Could not deduce:" <+> pprTheta wanteds -pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt ct ambigs) = +pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt item ambigs) = pprTcSolverReportInfo ctxt (Ambiguity True ambigs) <+> - pprArising (ctOrigin ct) $$ - text "prevents the constraint" <+> quotes (pprParendType $ ctPred ct) + pprArising (errorItemOrigin item) $$ + text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item) <+> text "from being solved." pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) - (CannotResolveInstance ct unifiers candidates imp_errs suggs binds) + (CannotResolveInstance item unifiers candidates imp_errs suggs binds) = vcat [ pprTcSolverReportMsg ctxt no_inst_msg @@ -1794,11 +1793,11 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) , vcat $ map ppr imp_errs , vcat $ map ppr suggs ] where - orig = ctOrigin ct - pred = ctPred ct + orig = errorItemOrigin item + pred = errorItemPred item (clas, tys) = getClassPredTys pred -- See Note [Highlighting ambiguous type variables] - (ambig_kvs, ambig_tvs) = ambigTkvsOfCt ct + (ambig_kvs, ambig_tvs) = ambigTkvsOfTy pred ambigs = ambig_kvs ++ ambig_tvs has_ambigs = not (null ambigs) useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) @@ -1812,9 +1811,9 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) no_inst_msg :: TcSolverReportMsg no_inst_msg | lead_with_ambig - = AmbiguityPreventsSolvingCt ct (ambig_kvs, ambig_tvs) + = AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs) | otherwise - = CouldNotDeduce useful_givens (ct :| []) Nothing + = CouldNotDeduce useful_givens (item :| []) Nothing -- Report "potential instances" only when the constraint arises -- directly from the user's use of an overloaded function @@ -1866,7 +1865,7 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) = hang (text "use a standalone 'deriving instance' declaration,") 2 (text "so you can specify the instance context yourself") -pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances ct matches unifiers) = +pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) = vcat [ addArising orig $ (text "Overlapping instances for" @@ -1903,8 +1902,8 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances ct matches , text "when compiling the other instance declarations"] ])] where - orig = ctOrigin ct - pred = ctPred ct + orig = errorItemOrigin item + pred = errorItemPred item (clas, tys) = getClassPredTys pred tyCoVars = tyCoVarsOfTypesList tys famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys @@ -1926,7 +1925,7 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances ct matches Just (clas', tys') -> clas' == clas && isJust (tcMatchTys tys tys') Nothing -> False -pprTcSolverReportMsg _ (UnsafeOverlap ct matches unsafe_overlapped) = +pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) = vcat [ addArising orig (text "Unsafe overlapping instances for" <+> pprType (mkClassPred clas tys)) , sep [text "The matching instance is:", @@ -1939,8 +1938,8 @@ pprTcSolverReportMsg _ (UnsafeOverlap ct matches unsafe_overlapped) = ] ] where - orig = ctOrigin ct - pred = ctPred ct + orig = errorItemOrigin item + pred = errorItemPred item (clas, tys) = getClassPredTys pred {- ********************************************************************* @@ -2475,6 +2474,9 @@ pprArising :: CtOrigin -> SDoc -- We've done special processing for TypeEq, KindEq, givens pprArising (TypeEqOrigin {}) = empty pprArising (KindEqOrigin {}) = empty +pprArising (AmbiguityCheckOrigin {}) = empty -- the "In the ambiguity check" context + -- is sufficient; this would just be + -- repetitive pprArising orig | isGivenOrigin orig = empty | otherwise = pprCtOrigin orig @@ -2614,9 +2616,10 @@ ea_looks_same ty1 ty2 exp act -- when the types really look the same. However, -- (TYPE 'LiftedRep) and Type both print the same way. -mk_ea_msg :: SolverReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg +mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind + -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg -- Constructs a "Couldn't match" message --- The (Maybe Ct) says whether this is the main top-level message (Just) +-- The (Maybe ErrorItem) says whether this is the main top-level message (Just) -- or a supplementary message (Nothing) mk_ea_msg ctxt at_top level (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) @@ -2625,13 +2628,13 @@ mk_ea_msg ctxt at_top level = Right $ KindMismatch { kmismatch_what = thing , kmismatch_expected = exp , kmismatch_actual = act } - | Just ct <- at_top + | Just item <- at_top , let mismatch = Mismatch - { mismatch_ea = True - , mismatch_ct = ct - , mismatch_ty1 = exp - , mismatch_ty2 = act } + { mismatch_ea = True + , mismatch_item = item + , mismatch_ty1 = exp + , mismatch_ty2 = act } = Right $ if expanded_syns then mkTcReportWithInfo mismatch [ea_expanded] diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index c244c4c2a4..bc9f9c3390 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -36,6 +36,8 @@ module GHC.Tc.Errors.Types ( , MissingSignature(..) , Exported(..) + , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc + , SolverReport(..), SolverReportSupplementary(..) , SolverReportWithCtxt(..) , SolverReportErrCtxt(..) @@ -82,6 +84,7 @@ import GHC.Core.DataCon (DataCon) import GHC.Core.FamInstEnv (FamInst) import GHC.Core.InstEnv (ClsInst) import GHC.Core.PatSyn (PatSyn) +import GHC.Core.Predicate (EqRel, predTypeEqRel) import GHC.Core.TyCon (TyCon, TyConFlavour) import GHC.Core.Type (Kind, Type, ThetaType, PredType) import GHC.Unit.State (UnitState) @@ -602,9 +605,11 @@ data TcRnMessage where Test cases: partial-sig/should_fail/T14479 -} TcRnPartialTypeSigBadQuantifier - :: Name -- ^ type variable being quantified - -> Name -- ^ function name - -> LHsSigWcType GhcRn -> TcRnMessage + :: Name -- ^ user-written name of type variable being quantified + -> Name -- ^ function name + -> Maybe Type -- ^ type the variable unified with, if known + -> LHsSigWcType GhcRn -- ^ partial type signature + -> TcRnMessage {-| TcRnMissingSignature is a warning that occurs when a top-level binding or a pattern synonym does not have a type signature. @@ -798,17 +803,6 @@ data TcRnMessage where -} TcRnVDQInTermType :: !Type -> TcRnMessage - {-| TcRnIllegalEqualConstraints is an error that occurs whenever an illegal equational - constraint is specified. - - Examples(s): - blah :: (forall a. a b ~ a c) => b -> c - blah = undefined - - Test cases: typecheck/should_fail/T17563 - -} - TcRnIllegalEqualConstraints :: !Type -> TcRnMessage - {-| TcRnBadQuantPredHead is an error that occurs whenever a quantified predicate lacks a class or type variable head. @@ -1875,7 +1869,10 @@ instance Outputable Exported where ppr IsExported = text "IsExported" -------------------------------------------------------------------------------- --- Errors used in GHC.Tc.Errors +-- +-- Errors used in GHC.Tc.Errors +-- +-------------------------------------------------------------------------------- {- Note [Error report] ~~~~~~~~~~~~~~~~~~~~~~ @@ -1971,6 +1968,56 @@ getUserGivens :: SolverReportErrCtxt -> [UserGiven] -- One item for each enclosing implication getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics +---------------------------------------------------------------------------- +-- +-- ErrorItem +-- +---------------------------------------------------------------------------- + +-- | A predicate with its arising location; used to encapsulate a constraint +-- that will give rise to a diagnostic. +data ErrorItem +-- We could perhaps use Ct here (and indeed used to do exactly that), but +-- having a separate type gives to denote errors-in-formation gives us +-- a nice place to do pre-processing, such as calculating ei_suppress. +-- Perhaps some day, an ErrorItem could eventually evolve to contain +-- the error text (or some representation of it), so we can then have all +-- the errors together when deciding which to report. + = EI { ei_pred :: PredType -- report about this + -- The ei_pred field will never be an unboxed equality with + -- a (casted) tyvar on the right; this is guaranteed by the solver + , ei_evdest :: Maybe TcEvDest -- for Wanteds, where to put evidence + , ei_flavour :: CtFlavour + , ei_loc :: CtLoc + , ei_m_reason :: Maybe CtIrredReason -- if this ErrorItem was made from a + -- CtIrred, this stores the reason + , ei_suppress :: Bool -- Suppress because of Note [Wanteds rewrite Wanteds] + -- in GHC.Tc.Constraint + } + +instance Outputable ErrorItem where + ppr (EI { ei_pred = pred + , ei_evdest = m_evdest + , ei_flavour = flav + , ei_suppress = supp }) + = pp_supp <+> ppr flav <+> pp_dest m_evdest <+> ppr pred + where + pp_dest Nothing = empty + pp_dest (Just ev) = ppr ev <+> dcolon + + pp_supp = if supp then text "suppress:" else empty + +errorItemOrigin :: ErrorItem -> CtOrigin +errorItemOrigin = ctLocOrigin . ei_loc + +errorItemEqRel :: ErrorItem -> EqRel +errorItemEqRel = predTypeEqRel . ei_pred + +errorItemCtLoc :: ErrorItem -> CtLoc +errorItemCtLoc = ei_loc + +errorItemPred :: ErrorItem -> PredType +errorItemPred = ei_pred {- Note [discardProvCtxtGivens] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2068,7 +2115,7 @@ data TcSolverReportMsg -- | A type equality between a type variable and a polytype. -- -- Test cases: T12427a, T2846b, T10194, ... - | CannotUnifyWithPolytype Ct TyVar Type + | CannotUnifyWithPolytype ErrorItem TyVar Type -- | Couldn't unify two types or kinds. -- @@ -2078,10 +2125,10 @@ data TcSolverReportMsg -- -- Test cases: T1396, T8263, ... | Mismatch - { mismatch_ea :: Bool -- ^ Should this be phrased in terms of expected vs actual? - , mismatch_ct :: Ct -- ^ The constraint in which the mismatch originated. - , mismatch_ty1 :: Type -- ^ First type (the expected type if if mismatch_ea is True) - , mismatch_ty2 :: Type -- ^ Second type (the actual type if mismatch_ea is True) + { mismatch_ea :: Bool -- ^ Should this be phrased in terms of expected vs actual? + , mismatch_item :: ErrorItem -- ^ The constraint in which the mismatch originated. + , mismatch_ty1 :: Type -- ^ First type (the expected type if if mismatch_ea is True) + , mismatch_ty2 :: Type -- ^ Second type (the actual type if mismatch_ea is True) } -- | A type has an unexpected kind. @@ -2099,9 +2146,9 @@ data TcSolverReportMsg -- Test cases: T1470, tcfail212. | TypeEqMismatch { teq_mismatch_ppr_explicit_kinds :: Bool - , teq_mismatch_ct :: Ct - , teq_mismatch_ty1 :: Type - , teq_mismatch_ty2 :: Type + , teq_mismatch_item :: ErrorItem + , teq_mismatch_ty1 :: Type + , teq_mismatch_ty2 :: Type , teq_mismatch_expected :: Type -- ^ The overall expected type , teq_mismatch_actual :: Type -- ^ The overall actual type , teq_mismatch_what :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of? @@ -2122,7 +2169,7 @@ data TcSolverReportMsg -- foo (MkEx x) = x -- -- Test cases: TypeSkolEscape, T11142. - | SkolemEscape Ct Implication [TyVar] + | SkolemEscape ErrorItem Implication [TyVar] -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope. -- @@ -2133,7 +2180,7 @@ data TcSolverReportMsg -- beteen their kinds. -- -- Test cases: none. - | BlockedEquality Ct + | BlockedEquality ErrorItem -- | Something was not applied to sufficiently many arguments. -- @@ -2153,7 +2200,7 @@ data TcSolverReportMsg -- -- Test case: tcfail130. | UnboundImplicitParams - (NE.NonEmpty Ct) + (NE.NonEmpty ErrorItem) -- | Couldn't solve some Wanted constraints using the Givens. -- This is the most commonly used constructor, used for generic @@ -2162,9 +2209,9 @@ data TcSolverReportMsg { cnd_user_givens :: [Implication] -- | The Wanted constraints we couldn't solve. -- - -- N.B.: the 'Ct' at the head of the list has been tidied, + -- N.B.: the 'ErrorItem' at the head of the list has been tidied, -- perhaps not the others. - , cnd_wanted :: NE.NonEmpty Ct + , cnd_wanted :: NE.NonEmpty ErrorItem -- | Some additional info consumed by 'mk_supplementary_ea_msg'. , cnd_extra :: Maybe CND_Extra @@ -2183,7 +2230,7 @@ data TcSolverReportMsg -- -- Test case: T4921. | AmbiguityPreventsSolvingCt - Ct -- ^ always a class constraint + ErrorItem -- ^ always a class constraint ([TyVar], [TyVar]) -- ^ ambiguous kind and type variables, respectively -- | Could not solve a constraint; there were several unifying candidate instances @@ -2191,7 +2238,7 @@ data TcSolverReportMsg -- as possible about why we couldn't choose any instance, e.g. because of -- ambiguous type variables. | CannotResolveInstance - { cannotResolve_ct :: Ct + { cannotResolve_item :: ErrorItem , cannotResolve_unifiers :: [ClsInst] , cannotResolve_candidates :: [ClsInst] , cannotResolve_importErrors :: [ImportError] @@ -2205,7 +2252,7 @@ data TcSolverReportMsg -- -- Test cases: tcfail118, tcfail121, tcfail218. | OverlappingInstances - { overlappingInstances_ct :: Ct + { overlappingInstances_item :: ErrorItem , overlappingInstances_matches :: [ClsInst] , overlappingInstances_unifiers :: [ClsInst] } @@ -2215,7 +2262,7 @@ data TcSolverReportMsg -- -- Test cases: SH_Overlap{1,2,5,6,7,11}. | UnsafeOverlap - { unsafeOverlap_ct :: Ct + { unsafeOverlap_item :: ErrorItem , unsafeOverlap_matches :: [ClsInst] , unsafeOverlapped :: [ClsInst] } diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 0d2ba18503..193292c797 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -41,6 +41,8 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.Unify import GHC.Tc.Solver import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType @@ -48,6 +50,7 @@ import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.Multiplicity import GHC.Core.FamInstEnv( normaliseType ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) +import GHC.Core.Class ( Class ) import GHC.Tc.Utils.TcType import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy) import GHC.Builtin.Types ( mkBoxedTupleTy ) @@ -250,48 +253,36 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside ; (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndMA (tc_ip_bind ipClass)) ip_binds - -- If the binding binds ?x = E, we must now - -- discharge any ?x constraints in expr_lie - -- See Note [Implicit parameter untouchables] + -- Add all the IP bindings as givens for the body of the 'let' ; (ev_binds, result) <- checkConstraints (IPSkol ips) [] given_ips thing_inside ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } where - ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds] + ips = [ip | (L _ (IPBind _ (L _ ip) _)) <- ip_binds] -- I wonder if we should do these one at a time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) + tc_ip_bind :: Class -> IPBind GhcRn -> TcM (DictId, IPBind GhcTc) + tc_ip_bind ipClass (IPBind _ l_name@(L _ ip) expr) = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] ; expr' <- tcCheckMonoExpr expr ty - ; let d = toDict ipClass p ty `fmap` expr' - ; return (ip_id, (IPBind noAnn (Right ip_id) d)) } - tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind" + ; let d = mapLoc (toDict ipClass p ty) expr' + ; return (ip_id, (IPBind ip_id l_name d)) } -- Coerces a `t` into a dictionary for `IP "x" t`. -- co : t -> IP "x" t + toDict :: Class -- IP class + -> Type -- type-level string for name of IP + -> Type -- type of IP + -> HsExpr GhcTc -- def'n of IP variable + -> HsExpr GhcTc -- dictionary for IP toDict ipClass x ty = mkHsWrap $ mkWpCastR $ wrapIP $ mkClassPred ipClass [x,ty] -{- Note [Implicit parameter untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We add the type variables in the types of the implicit parameters -as untouchables, not so much because we really must not unify them, -but rather because we otherwise end up with constraints like this - Num alpha, Implic { wanted = alpha ~ Int } -The constraint solver solves alpha~Int by unification, but then -doesn't float that solved constraint out (it's not an unsolved -wanted). Result disaster: the (Num alpha) is again solved, this -time by defaulting. No no no. - -However [Oct 10] this is all handled automatically by the -untouchable-range idea. --} - tcValBinds :: TopLevelFlag -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM thing @@ -726,12 +717,19 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list ; mapM_ (checkOverloadedSig mono) sigs ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) - ; (qtvs, givens, ev_binds, insoluble) - <- simplifyInfer tclvl infer_mode sigs name_taus wanted + ; ((qtvs, givens, ev_binds, insoluble), residual) + <- captureConstraints $ simplifyInfer tclvl infer_mode sigs name_taus wanted ; let inferred_theta = map evVarPred givens ; exports <- checkNoErrs $ - mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos + mapM (mkExport prag_fn residual insoluble qtvs inferred_theta) mono_infos + + -- NB: *after* the checkNoErrs call above. This ensures that we don't get an error + -- cascade in case mkExport runs into trouble. In particular, this avoids duplicate + -- errors when a partial type signature cannot be quantified in chooseInferredQuantifiers. + -- See Note [Quantification and partial signatures] in GHC.Tc.Solver, Wrinkle 4. + -- Tested in partial-sigs/should_fail/NamedWilcardExplicitForall. + ; emitConstraints residual ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports @@ -748,6 +746,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list -------------- mkExport :: TcPragEnv + -> WantedConstraints -- residual constraints, already emitted (for errors only) -> Bool -- True <=> there was an insoluble type error -- when typechecking the bindings -> [TyVar] -> TcThetaType -- Both already zonked @@ -766,12 +765,12 @@ mkExport :: TcPragEnv -- Pre-condition: the qtvs and theta are already zonked -mkExport prag_fn insoluble qtvs theta - mono_info@(MBI { mbi_poly_name = poly_name - , mbi_sig = mb_sig - , mbi_mono_id = mono_id }) +mkExport prag_fn residual insoluble qtvs theta + (MBI { mbi_poly_name = poly_name + , mbi_sig = mb_sig + , mbi_mono_id = mono_id }) = do { mono_ty <- zonkTcType (idType mono_id) - ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty + ; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty -- NB: poly_id has a zonked type ; poly_id <- addInlinePrags poly_id prag_sigs @@ -793,14 +792,21 @@ mkExport prag_fn insoluble qtvs theta then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguous type and have AllowAmbiguousType -- e..g infer x :: forall a. F a -> Int - else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $ - tcSubTypeSigma sig_ctxt sel_poly_ty poly_ty + else tcSubTypeSigma GhcBug20076 + sig_ctxt sel_poly_ty poly_ty + -- as Note [Impedance matching] explains, this should never fail, + -- and thus we'll never see an error message. It *may* do + -- instantiation, but no message will ever be printed to the + -- user, and so we use Shouldn'tHappenOrigin. + -- Actually, there is a bug here: #20076. So we tell the user + -- that they hit the bug. Once #20076 is fixed, change this + -- back to Shouldn'tHappenOrigin. ; localSigWarn poly_id mb_sig ; return (ABE { abe_ext = noExtField , abe_wrap = wrap - -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) + -- abe_wrap :: (forall qtvs. theta => mono_ty) ~ idType poly_id , abe_poly = poly_id , abe_mono = mono_id , abe_prags = SpecPrags spec_prags }) } @@ -808,12 +814,13 @@ mkExport prag_fn insoluble qtvs theta prag_sigs = lookupPragEnv prag_fn poly_name sig_ctxt = InfSigCtxt poly_name -mkInferredPolyId :: Bool -- True <=> there was an insoluble error when +mkInferredPolyId :: WantedConstraints -- the residual constraints, already emitted + -> Bool -- True <=> there was an insoluble error when -- checking the binding group for this Id -> [TyVar] -> TcThetaType -> Name -> Maybe TcIdSigInst -> TcType -> TcM TcId -mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty +mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst , CompleteSig { sig_bndr = poly_id } <- sig = return poly_id @@ -833,7 +840,7 @@ mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty -- We can discard the coercion _co, because we'll reconstruct -- it in the call to tcSubType below - ; (binders, theta') <- chooseInferredQuantifiers inferred_theta + ; (binders, theta') <- chooseInferredQuantifiers residual inferred_theta (tyCoVarsOfType mono_ty') qtvs mb_sig_inst ; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty') @@ -851,14 +858,16 @@ mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty ; return (mkLocalId poly_name Many inferred_poly_ty) } -chooseInferredQuantifiers :: TcThetaType -- inferred +chooseInferredQuantifiers :: WantedConstraints -- residual constraints + -> TcThetaType -- inferred -> TcTyVarSet -- tvs free in tau type -> [TcTyVar] -- inferred quantified tvs -> Maybe TcIdSigInst -> TcM ([InvisTVBinder], TcThetaType) -chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing +chooseInferredQuantifiers _residual inferred_theta tau_tvs qtvs Nothing = -- No type signature (partial or complete) for this binder, do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) + -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver -- Include kind variables! #7916 my_theta = pickCapturedPreds free_tvs inferred_theta binders = [ mkTyVarBinder InferredSpec tv @@ -866,11 +875,11 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing , tv `elemVarSet` free_tvs ] ; return (binders, my_theta) } -chooseInferredQuantifiers inferred_theta tau_tvs qtvs - (Just (TISI { sig_inst_sig = sig -- Always PartialSig - , sig_inst_wcx = wcx - , sig_inst_theta = annotated_theta - , sig_inst_skols = annotated_tvs })) +chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs + (Just (TISI { sig_inst_sig = sig@(PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty }) + , sig_inst_wcx = wcx + , sig_inst_theta = annotated_theta + , sig_inst_skols = annotated_tvs })) = -- Choose quantifiers for a partial type signature do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs ; psig_qtv_bndrs <- mapM zonkInvisTVBinder psig_qtv_bndrs @@ -888,8 +897,8 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs -- signature is not actually quantified. How can that happen? -- See Note [Quantification and partial signatures] Wrinkle 4 -- in GHC.Tc.Solver - ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs - , not (tv `elem` qtvs) ] + ; mapM_ report_mono_sig_tv_err [ pr | pr@(_,tv) <- psig_qtv_prs + , not (tv `elem` qtvs) ] ; annotated_theta <- zonkTcTypes annotated_theta ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx @@ -905,16 +914,20 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs ; return (final_qtvs, my_theta) } where report_dup_tyvar_tv_err (n1,n2) - | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty) - | otherwise -- Can't happen; by now we know it's a partial sig - = pprPanic "report_tyvar_tv_err" (ppr sig) - report_mono_sig_tv_err n - | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name hs_ty) - | otherwise -- Can't happen; by now we know it's a partial sig - = pprPanic "report_mono_sig_tv_err" (ppr sig) + report_mono_sig_tv_err (n,tv) + = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty) + where + m_unif_ty = listToMaybe + [ rhs + -- recall that residuals are always implications + | residual_implic <- bagToList $ wc_impl residual + , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic) + , let residual_pred = ctPred residual_ct + , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ] + , Just lhs_tv <- [ tcGetTyVar_maybe lhs ] + , lhs_tv == tv ] choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType -> TcM (VarSet, TcThetaType) @@ -925,7 +938,8 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty) = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs) - -- growThetaVars just like the no-type-sig case + -- growThetaTyVars just like the no-type-sig case + -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver -- Omitting this caused #12844 seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there `unionVarSet` tau_tvs -- by the user @@ -961,25 +975,8 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs -- Hack alert! See GHC.Tc.Gen.HsType: -- Note [Extra-constraint holes in partial type signatures] -mk_impedance_match_msg :: MonoBindInfo - -> TcType -> TcType - -> TidyEnv -> TcM (TidyEnv, SDoc) --- This is a rare but rather awkward error messages -mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig }) - inf_ty sig_ty tidy_env - = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty - ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty - ; let msg = vcat [ text "When checking that the inferred type" - , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty - , text "is as general as its" <+> what <+> text "signature" - , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ] - ; return (tidy_env2, msg) } - where - what = case mb_sig of - Nothing -> text "inferred" - Just sig | isPartialSig sig -> text "(partial)" - | otherwise -> empty - +chooseInferredQuantifiers _ _ _ _ (Just (TISI { sig_inst_sig = sig@(CompleteSig {}) })) + = pprPanic "chooseInferredQuantifiers" (ppr sig) mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_inf_msg poly_name poly_ty tidy_env @@ -988,7 +985,6 @@ mk_inf_msg poly_name poly_ty tidy_env , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] ; return (tidy_env1, msg) } - -- | Warn the user about polymorphic local binders that lack type signatures. localSigWarn :: Id -> Maybe TcIdSigInst -> TcM () localSigWarn id mb_sig @@ -1103,7 +1099,6 @@ Examples that might fail: or multi-parameter type classes - an inferred type that includes unboxed tuples - Note [Impedance matching] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1128,8 +1123,8 @@ We can get these by "impedance matching": tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool) tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) - f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f - g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g + f a d1 d2 = case tuple a Any d1 d2 of (f_mono, g_mono) -> f_mono + g b = case tuple Integer b dEqInteger dNumInteger of (f_mono,g_mono) -> g_mono Suppose the shared quantified tyvars are qtvs and constraints theta. Then we want to check that @@ -1138,13 +1133,10 @@ and the proof is the impedance matcher. Notice that the impedance matcher may do defaulting. See #7173. -It also cleverly does an ambiguity check; for example, rejecting - f :: F a -> F a -where F is a non-injective type function. --} +If we've gotten the constraints right during inference (and we assume we have), +this sub-type check should never fail. It's not really a check -- it's more of +a procedure to produce the right wrapper. - -{- Note [SPECIALISE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~ There is no point in a SPECIALISE pragma for a non-overloaded function: diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index c2a97a5c79..56a995b3ba 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -607,13 +607,14 @@ tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc }) = ApplyMR | otherwise = NoRestrictions - ; (qtvs, givens, ev_binds, _) - <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted + ; ((qtvs, givens, ev_binds, _), residual) + <- captureConstraints $ simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted + ; emitConstraints residual ; tau <- zonkTcType tau ; let inferred_theta = map evVarPred givens tau_tvs = tyCoVarsOfType tau - ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta + ; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs (Just sig_inst) ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau) @@ -621,7 +622,7 @@ tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc }) then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguous type and have AllowAmbiguousType -- e..g infer x :: forall a. F a -> Int - else tcSubTypeSigma (ExprSigCtxt NoRRC) inferred_sigma my_sigma + else tcSubTypeSigma ExprSigOrigin (ExprSigCtxt NoRRC) inferred_sigma my_sigma ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) ; let poly_wrap = wrap diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 204edcb0b0..4463d25590 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -109,7 +109,6 @@ import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Class import GHC.Types.Name --- import GHC.Types.Name.Set import GHC.Types.Var.Env import GHC.Builtin.Types import GHC.Types.Basic diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index ae9667804d..7f31b4edb3 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -1189,8 +1189,8 @@ Wrinkles: these unifications. The *only* thing the unification does is to side-effect those unification variables, so that we know what type x and y stand for; and cause an error if the equality - is not soluble. It's a bit like a Derived constraint arising - from a functional dependency. + is not soluble. It's a bit like a constraint arising + from a functional dependency, where we don't use the evidence. * Exactly the same works for existential arguments data T where diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs index 4aa3a764a8..0d2c5bcc8b 100644 --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -15,6 +15,7 @@ import GHC.Hs import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Solver +import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Types.Origin @@ -396,20 +397,24 @@ simplifyRule :: RuleName -- NB: This consumes all simple constraints on the LHS, but not -- any LHS implication constraints. simplifyRule name tc_lvl lhs_wanted rhs_wanted - = do { - -- Note [The SimplifyRule Plan] step 1 - -- First solve the LHS and *then* solve the RHS - -- Crucially, this performs unifications - -- Why clone? See Note [Simplify cloned constraints] - ; lhs_clone <- cloneWC lhs_wanted - ; rhs_clone <- cloneWC rhs_wanted - ; setTcLevel tc_lvl $ - runTcSDeriveds $ - do { _ <- solveWanteds lhs_clone - ; _ <- solveWanteds rhs_clone - -- Why do them separately? - -- See Note [Solve order for RULES] - ; return () } + = do { setTcLevel tc_lvl $ + do { -- Note [The SimplifyRule Plan] step 1 + -- First solve the LHS and *then* solve the RHS + -- Crucially, this performs unifications + -- Why clone? See Note [Simplify cloned constraints] + -- This must be in the bumped TcLevel because cloneWC creates + -- metavariables for Concrete# constraints. See Note [The Concrete mechanism] + -- in GHC.Tc.Utils.Concrete + ; lhs_clone <- cloneWC lhs_wanted + ; rhs_clone <- cloneWC rhs_wanted + ; discardResult $ + runTcS $ + do { + ; _ <- solveWanteds lhs_clone + ; _ <- solveWanteds rhs_clone + -- Why do them separately? + -- See Note [Solve order for RULES] + ; return () }} -- Note [The SimplifyRule Plan] step 2 ; lhs_wanted <- zonkWC lhs_wanted diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs index cfbebcd368..e3baf4c4f9 100644 --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -5,7 +5,7 @@ -} - +{-# LANGUAGE DeriveFunctor #-} -- | Functional dependencies -- @@ -18,6 +18,7 @@ module GHC.Tc.Instance.FunDeps , checkInstCoverage , checkFunDeps , pprFundeps + , instFD, closeWrtFunDeps ) where @@ -43,6 +44,7 @@ import GHC.Utils.FV import GHC.Utils.Error( Validity'(..), Validity, allValid ) import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Panic.Plain ( assert ) import GHC.Data.Pair ( Pair(..) ) import Data.List ( nubBy ) @@ -118,6 +120,7 @@ data FunDepEqn loc , fd_pred1 :: PredType -- The FunDepEqn arose from , fd_pred2 :: PredType -- combining these two constraints , fd_loc :: loc } + deriving Functor {- Given a bunch of predicates that must hold, such as @@ -350,7 +353,7 @@ Example For the coverage condition, we check (normal) fv(t2) `subset` fv(t1) - (liberal) fv(t2) `subset` oclose(fv(t1), theta) + (liberal) fv(t2) `subset` closeWrtFunDeps(fv(t1), theta) The liberal version ensures the self-consistency of the instance, but it does not guarantee termination. Example: @@ -363,7 +366,7 @@ it does not guarantee termination. Example: instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]). -But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) ) +But it is the case that fv([c]) `subset` closeWrtFunDeps( theta, fv(a,[b]) ) But it is a mistake to accept the instance because then this defn: f = \ b x y -> if b then x .*. [y] else y @@ -396,7 +399,7 @@ checkInstCoverage be_liberal clas theta inst_taus undetermined_tvs | be_liberal = liberal_undet_tvs | otherwise = conserv_undet_tvs - closed_ls_tvs = oclose theta ls_tvs + closed_ls_tvs = closeWrtFunDeps theta ls_tvs liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs @@ -407,7 +410,7 @@ checkInstCoverage be_liberal clas theta inst_taus vcat [ -- text "ls_tvs" <+> ppr ls_tvs -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs) -- , text "theta" <+> ppr theta - -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs)) + -- , text "closeWrtFunDeps" <+> ppr (closeWrtFunDeps theta (closeOverKinds ls_tvs)) -- , text "rs_tvs" <+> ppr rs_tvs sep [ text "The" <+> ppWhen be_liberal (text "liberal") @@ -466,17 +469,17 @@ Is the instance OK? Does {l,r,xs} determine v? Well: we get {l,k,xs} -> b * Note the 'k'!! We must call closeOverKinds on the seed set - ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b + ls_tvs = {l,r,xs}, BEFORE doing closeWrtFunDeps, else the {l,k,xs}->b fundep won't fire. This was the reason for #10564. - * So starting from seeds {l,r,xs,k} we do oclose to get + * So starting from seeds {l,r,xs,k} we do closeWrtFunDeps to get first {l,r,xs,k,b}, via the HMemberM constraint, and then {l,r,xs,k,b,v}, via the HasFieldM1 constraint. * And that fixes v. However, we must closeOverKinds whenever augmenting the seed set -in oclose! Consider #10109: +in closeWrtFunDeps! Consider #10109: data Succ a -- Succ :: forall k. k -> * class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab @@ -492,25 +495,27 @@ the variables free in (Succ {k3} ab). Bottom line: * closeOverKinds on initial seeds (done automatically by tyCoVarsOfTypes in checkInstCoverage) - * and closeOverKinds whenever extending those seeds (in oclose) + * and closeOverKinds whenever extending those seeds (in closeWrtFunDeps) Note [The liberal coverage condition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(oclose preds tvs) closes the set of type variables tvs, +(closeWrtFunDeps preds tvs) closes the set of type variables tvs, wrt functional dependencies in preds. The result is a superset of the argument set. For example, if we have class C a b | a->b where ... then - oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} + closeWrtFunDeps [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} because if we know x and y then that fixes z. We also use equality predicates in the predicates; if we have an assumption `t1 ~ t2`, then we use the fact that if we know `t1` we also know `t2` and the other way. - eg oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} + eg closeWrtFunDeps [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} -oclose is used (only) when checking the coverage condition for -an instance declaration +closeWrtFunDeps is used + - when checking the coverage condition for an instance declaration + - when determining which tyvars are unquantifiable during generalization, in + GHC.Tc.Solver.decideMonoTyVars. Note [Equality superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -521,10 +526,10 @@ Remember from Note [The equality types story] in GHC.Builtin.Types.Prim, that * (a ~~ b) is a superclass of (a ~ b) * (a ~# b) is a superclass of (a ~~ b) -So when oclose expands superclasses we'll get a (a ~# [b]) superclass. +So when closeWrtFunDeps expands superclasses we'll get a (a ~# [b]) superclass. But that's an EqPred not a ClassPred, and we jolly well do want to account for the mutual functional dependencies implied by (t1 ~# t2). -Hence the EqPred handling in oclose. See #10778. +Hence the EqPred handling in closeWrtFunDeps. See #10778. Note [Care with type functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -534,7 +539,7 @@ Consider (#12803) type family G c d = r | r -> d Now consider - oclose (C (F a b) (G c d)) {a,b} + closeWrtFunDeps (C (F a b) (G c d)) {a,b} Knowing {a,b} fixes (F a b) regardless of the injectivity of F. But knowing (G c d) fixes only {d}, because G is only injective @@ -543,12 +548,14 @@ in its second parameter. Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds. -} -oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet +closeWrtFunDeps :: [PredType] -> TyCoVarSet -> TyCoVarSet -- See Note [The liberal coverage condition] -oclose preds fixed_tvs +closeWrtFunDeps preds fixed_tvs | null tv_fds = fixed_tvs -- Fast escape hatch for common case. - | otherwise = fixVarSet extend fixed_tvs + | otherwise = assert (closeOverKinds fixed_tvs == fixed_tvs) + $ fixVarSet extend fixed_tvs where + extend fixed_tvs = foldl' add fixed_tvs tv_fds where add fixed_tvs (ls,rs) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index d9b59b4fd8..40bc5188f6 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -1809,9 +1809,14 @@ checkMainType tcg_env ctxt = FunSigCtxt main_name NoRRC ; main_id <- tcLookupId main_name ; (io_ty,_) <- getIOType + ; let main_ty = idType main_id + eq_orig = TypeEqOrigin { uo_actual = main_ty + , uo_expected = io_ty + , uo_thing = Nothing + , uo_visible = True } ; (_, lie) <- captureTopConstraints $ setMainCtxt main_name io_ty $ - tcSubTypeSigma ctxt (idType main_id) io_ty + tcSubTypeSigma eq_orig ctxt main_ty io_ty ; return lie } } } } checkMain :: Bool -- False => no 'module M(..) where' header at all diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs index 8984bffce9..30f5ef7520 100644 --- a/compiler/GHC/Tc/Plugin.hs +++ b/compiler/GHC/Tc/Plugin.hs @@ -41,7 +41,6 @@ module GHC.Tc.Plugin ( -- * Creating constraints newWanted, - newDerived, newGiven, newCoercionHole, @@ -167,10 +166,6 @@ newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence newWanted loc pty = unsafeTcPluginTcM (TcM.newWantedWithLoc loc pty) --- | Create a new derived constraint. -newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence -newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc } - -- | Create a new given constraint, with the supplied evidence. -- -- This should only be invoked within 'tcPluginSolve'. diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 8b6ac9928d..78f0f18fb7 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE MultiWayIf #-} module GHC.Tc.Solver( InferMode(..), simplifyInfer, findInferredDiff, @@ -22,18 +23,15 @@ module GHC.Tc.Solver( promoteTyVarSet, simplifyAndEmitFlatConstraints, -- For Rules we need these - solveWanteds, solveWantedsAndDrop, - approximateWC, runTcSDeriveds, - - -- We need this for valid hole-fits - runTcSDerivedsEarlyAbort + solveWanteds, + approximateWC ) where import GHC.Prelude import GHC.Data.Bag -import GHC.Core.Class ( Class, classKey, classTyCon ) +import GHC.Core.Class import GHC.Driver.Session import GHC.Tc.Utils.Instantiate import GHC.Data.List.SetOps @@ -54,12 +52,13 @@ import GHC.Tc.Utils.Monad as TcM import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad as TcS import GHC.Tc.Types.Constraint +import GHC.Tc.Instance.FunDeps import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Ppr -import GHC.Core.TyCon ( TyConBinder ) +import GHC.Core.TyCon ( TyConBinder, isTypeFamilyTyCon ) import GHC.Builtin.Types ( liftedRepTy, manyDataConTy, liftedDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc @@ -75,6 +74,7 @@ import Control.Monad import Data.Foldable ( toList ) import Data.List ( partition ) import Data.List.NonEmpty ( NonEmpty(..) ) +import GHC.Data.Maybe ( mapMaybe ) {- ********************************************************************************* @@ -484,7 +484,7 @@ report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints -- See Note [Top-level Defaulting Plan] simplifyTopWanteds wanteds - = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds) + = do { wc_first_go <- nestTcS (solveWanteds wanteds) -- This is where the main work happens ; dflags <- getDynFlags ; try_tyvar_defaulting dflags wc_first_go } @@ -519,7 +519,7 @@ simplifyTopWanteds wanteds = do { something_happened <- applyDefaultingRules wc -- See Note [Top-level Defaulting Plan] ; if something_happened - then do { wc_residual <- nestTcS (solveWantedsAndDrop wc) + then do { wc_residual <- nestTcS (solveWanteds wc) ; try_class_defaulting wc_residual } -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence else try_callstack_defaulting wc } @@ -751,7 +751,7 @@ How is this implemented? It's complicated! So we'll step through it all: Note [No defaulting in the ambiguity check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When simplifying constraints for the ambiguity check, we use -solveWantedsAndDrop, not simplifyTopWanteds, so that we do no defaulting. +solveWanteds, not simplifyTopWanteds, so that we do no defaulting. #11947 was an example: f :: Num a => Int -> Int This is ambiguous of course, but we don't want to default the @@ -807,7 +807,7 @@ is not set. simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () simplifyAmbiguityCheck ty wanteds = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) - ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds + ; (final_wc, _) <- runTcS $ solveWanteds wanteds -- NB: no defaulting! See Note [No defaulting in the ambiguity check] ; traceTc "End simplifyAmbiguityCheck }" empty @@ -835,7 +835,7 @@ simplifyDefault :: ThetaType -- Wanted; has no type variables in it simplifyDefault theta = do { traceTc "simplifyDefault" empty ; wanteds <- newWanteds DefaultOrigin theta - ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds)) + ; (unsolved, _) <- runTcS (solveWanteds (mkSimpleWC wanteds)) ; return (isEmptyWC unsolved) } ------------------ @@ -941,7 +941,7 @@ tcCheckWanteds inerts wanteds = do (sat, _new_inerts) <- runTcSInerts inerts $ do traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds) -- See Note [Superclasses and satisfiability] - wcs <- solveWantedsAndDrop (mkSimpleWC cts) + wcs <- solveWanteds (mkSimpleWC cts) traceTcS "checkWanteds }" (ppr wcs) return (isSolvedWC wcs) return sat @@ -1023,6 +1023,55 @@ This ensures that the implication constraint we generate, if any, has a strictly-increased level compared to the ambient level outside the let binding. +Note [Inferring principal types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't always infer principal types. For instance, the inferred type for + +> f x = show [x] + +is + +> f :: Show a => a -> String + +This is not the most general type if we allow flexible contexts. +Indeed, if we try to write the following + +> g :: Show [a] => a -> String +> g x = f x + +we get the error: + + * Could not deduce (Show a) arising from a use of `f' + from the context: Show [a] + +Though replacing f x in the right-hand side of g with the definition +of f x works, the call to f x does not. This is the hallmark of +unprincip{led,al} types. + +Another example: + +> class C a +> class D a where +> d :: a +> instance C a => D a where +> d = undefined +> h _ = d -- argument is to avoid the monomorphism restriction + +The inferred type for h is + +> h :: C a => t -> a + +even though + +> h :: D a => t -> a + +is more general. + +The fix is easy: don't simplify constraints before inferring a type. +That is, have the inferred type quantify over all constraints that arise +in a definition's right-hand side, even if they are simplifiable. +Unfortunately, this would yield all manner of unwieldy types, +and so we won't do so. -} -- | How should we choose which constraints to quantify over? @@ -1032,7 +1081,7 @@ data InferMode = ApplyMR -- ^ Apply the monomorphism restriction, -- the :type +d case; this mode refuses -- to quantify over any defaultable constraint | NoRestrictions -- ^ Quantify over any constraint that - -- satisfies 'GHC.Tc.Utils.TcType.pickQuantifiablePreds' + -- satisfies pickQuantifiablePreds instance Outputable InferMode where ppr ApplyMR = text "ApplyMR" @@ -1087,11 +1136,12 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds ; ev_binds_var <- TcM.newTcEvBinds ; psig_evs <- newWanteds AnnOrigin psig_theta - ; wanted_transformed_incl_derivs + ; wanted_transformed <- setTcLevel rhs_tclvl $ runTcSWithEvBinds ev_binds_var $ solveWanteds (mkSimpleWC psig_evs `andWC` wanteds) -- psig_evs : see Note [Add signature contexts as wanteds] + -- See Note [Inferring principal types] -- Find quant_pred_candidates, the predicates that -- we'll consider quantifying over @@ -1099,12 +1149,9 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds -- the psig_theta; it's just the extra bit -- NB2: We do not do any defaulting when inferring a type, this can lead -- to less polymorphic types, see Note [Default while Inferring] - ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs - ; let definite_error = insolubleWC wanted_transformed_incl_derivs + ; wanted_transformed <- TcM.zonkWC wanted_transformed + ; let definite_error = insolubleWC wanted_transformed -- See Note [Quantification with errors] - -- NB: must include derived errors in this test, - -- hence "incl_derivs" - wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs quant_pred_candidates | definite_error = [] | otherwise = ctsPreds (approximateWC False wanted_transformed) @@ -1208,9 +1255,9 @@ findInferredDiff annotated_theta inferred_theta ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env given_cts = mkGivens given_loc given_ids - ; residual <- runTcSDeriveds $ - do { _ <- solveSimpleGivens given_cts - ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) } + ; (residual, _) <- runTcS $ + do { _ <- solveSimpleGivens given_cts + ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) } -- NB: There are no meta tyvars fromn this level annotated_theta -- because we have either promoted them or unified them -- See `Note [Quantification and partial signatures]` Wrinkle 2 @@ -1306,19 +1353,21 @@ Note [Deciding quantification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the monomorphism restriction does not apply, then we quantify as follows: -* Step 1. Take the global tyvars, and "grow" them using the equality - constraints +* Step 1: decideMonoTyVars. + Take the global tyvars, and "grow" them using functional dependencies E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can happen because alpha is untouchable here) then do not quantify over beta, because alpha fixes beta, and beta is effectively free in - the environment too + the environment too; this logic extends to general fundeps, not + just equalities We also account for the monomorphism restriction; if it applies, add the free vars of all the constraints. Result is mono_tvs; we will not quantify over these. -* Step 2. Default any non-mono tyvars (i.e ones that are definitely +* Step 2: defaultTyVarsAndSimplify. + Default any non-mono tyvars (i.e ones that are definitely not going to become further constrained), and re-simplify the candidate constraints. @@ -1330,14 +1379,26 @@ If the monomorphism restriction does not apply, then we quantify as follows: This is all very tiresome. -* Step 3: decide which variables to quantify over, as follows: + This step also promotes the mono_tvs from Step 1. See + Note [Promote monomorphic tyvars]. In fact, the *only* + use of the mono_tvs from Step 1 is to promote them here. + This promotion effectively stops us from quantifying over them + later, in Step 3. Because the actual variables to quantify + over are determined in Step 3 (not in Step 1), it is OK for + the mono_tvs to be missing some variables free in the + environment. This is why removing the psig_qtvs is OK in + decideMonoTyVars. Test case for this scenario: T14479. + +* Step 3: decideQuantifiedTyVars. + Decide which variables to quantify over, as follows: - - Take the free vars of the tau-type (zonked_tau_tvs) and "grow" - them using all the constraints. These are tau_tvs_plus + - Take the free vars of the partial-type-signature types and constraints, + and the tau-type (zonked_tau_tvs), and then "grow" + them using all the constraints. These are grown_tcvs. + See Note [growThetaTyVars vs closeWrtFunDeps]. - - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being - careful to close over kinds, and to skolemise the quantified tyvars. - (This actually unifies each quantifies meta-tyvar with a fresh skolem.) + - Use quantifyTyVars to quantify over the free variables of all the types + involved, but only those in the grown_tcvs. Result is qtvs. @@ -1345,6 +1406,150 @@ If the monomorphism restriction does not apply, then we quantify as follows: qtvs. We have to zonk the constraints first, so they "see" the freshly created skolems. +Note [Lift equality constraints when quantifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can't quantify over a constraint (t1 ~# t2) because that isn't a +predicate type; see Note [Types for coercions, predicates, and evidence] +in GHC.Core.TyCo.Rep. + +So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted +to Coercible. + +This tiresome lifting is the reason that pick_me (in +pickQuantifiablePreds) returns a Maybe rather than a Bool. + +Note [Inheriting implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + f x = (x::Int) + ?y + +where f is *not* a top-level binding. +From the RHS of f we'll get the constraint (?y::Int). +There are two types we might infer for f: + + f :: Int -> Int + +(so we get ?y from the context of f's definition), or + + f :: (?y::Int) => Int -> Int + +At first you might think the first was better, because then +?y behaves like a free variable of the definition, rather than +having to be passed at each call site. But of course, the WHOLE +IDEA is that ?y should be passed at each call site (that's what +dynamic binding means) so we'd better infer the second. + +BOTTOM LINE: when *inferring types* you must quantify over implicit +parameters, *even if* they don't mention the bound type variables. +Reason: because implicit parameters, uniquely, have local instance +declarations. See pickQuantifiablePreds. + +Note [Quantifying over equality constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should we quantify over an equality constraint (s ~ t)? In general, we don't. +Doing so may simply postpone a type error from the function definition site to +its call site. (At worst, imagine (Int ~ Bool)). + +However, consider this + forall a. (F [a] ~ Int) => blah +Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call +site we will know 'a', and perhaps we have instance F [Bool] = Int. +So we *do* quantify over a type-family equality where the arguments mention +the quantified variables. + +Note [Unconditionally resimplify constraints when quantifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During quantification (in defaultTyVarsAndSimplify, specifically), we re-invoke +the solver to simplify the constraints before quantifying them. We do this for +two reasons, enumerated below. We could, in theory, detect when either of these +cases apply and simplify only then, but collecting this information is bothersome, +and simplifying redundantly causes no real harm. Note that this code path +happens only for definitions + * without a type signature + * when -XMonoLocalBinds does not apply + * with unsolved constraints +and so the performance cost will be small. + +1. Defaulting + +Defaulting the variables handled by defaultTyVar may unlock instance simplifications. +Example (typecheck/should_compile/T20584b): + + with (t :: Double) (u :: String) = printf "..." t u + +We know the types of t and u, but we do not know the return type of `with`. So, we +assume `with :: alpha`, where `alpha :: TYPE rho`. The type of printf is + printf :: PrintfType r => String -> r +The occurrence of printf is instantiated with a fresh var beta. We then get + beta := Double -> String -> alpha +and + [W] PrintfType (Double -> String -> alpha) + +Module Text.Printf exports + instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) +and it looks like that instance should apply. + +But I have elided some key details: (->) is polymorphic over multiplicity and +runtime representation. Here it is in full glory: + [W] PrintfType ((Double :: Type) %m1 -> (String :: Type) %m2 -> (alpha :: TYPE rho)) + instance (PrintfArg a, PrintfType r) => PrintfType ((a :: Type) %Many -> (r :: Type)) + +Because we do not know that m1 is Many, we cannot use the instance. (Perhaps a better instance +would have an explicit equality constraint to the left of =>, but that's not what we have.) +Then, in defaultTyVarsAndSimplify, we get m1 := Many, m2 := Many, and rho := LiftedRep. +Yet it's too late to simplify the quantified constraint, and thus GHC infers + wait :: PrintfType (Double -> String -> t) => Double -> String -> t +which is silly. Simplifying again after defaulting solves this problem. + +2. Interacting functional dependencies + +Suppose we have + + class C a b | a -> b + +and we are running simplifyInfer over + + forall[2] x. () => [W] C a beta1[1] + forall[2] y. () => [W] C a beta2[1] + +These are two implication constraints, both of which contain a +wanted for the class C. Neither constraint mentions the bound +skolem. We might imagine that these constraint could thus float +out of their implications and then interact, causing beta1 to unify +with beta2, but constraints do not currently float out of implications. + +Unifying the beta1 and beta2 is important. Without doing so, then we might +infer a type like (C a b1, C a b2) => a -> a, which will fail to pass the +ambiguity check, which will say (rightly) that it cannot unify b1 with b2, as +required by the fundep interactions. This happens in the parsec library, and +in test case typecheck/should_compile/FloatFDs. + +If we re-simplify, however, the two fundep constraints will interact, causing +a unification between beta1 and beta2, and all will be well. The key step +is that this simplification happens *after* the call to approximateWC in +simplifyInfer. + +Note [Do not quantify over constraints that determine a variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (typecheck/should_compile/tc231), where we're trying to infer +the type of a top-level declaration. We have + class Zork s a b | a -> b +and the candidate constraint at the end of simplifyInfer is + [W] Zork alpha (Z [Char]) beta +We definitely do want to quantify over alpha (which is mentioned in +the tau-type). But we do *not* want to quantify over beta: it is +determined by the functional dependency on Zork: note that the second +argument to Zork in the Wanted is a variable-free Z [Char]. + +The question here: do we want to quantify over the constraint? Definitely not. +Since we're not quantifying over beta, GHC has no choice but to zap beta +to Any, and then we infer a type involving (Zork a (Z [Char]) Any => ...). No no no. + +The no_fixed_dependencies check in pickQuantifiablePreds eliminates this +candidate from the pool. Because there are no Zork instances in scope, this +program is rejected. + -} decideQuantification @@ -1445,7 +1650,7 @@ decideMonoTyVars :: InferMode -- Decide which tyvars and covars cannot be generalised: -- (a) Free in the environment -- (b) Mentioned in a constraint we can't generalise --- (c) Connected by an equality to (a) or (b) +-- (c) Connected by an equality or fundep to (a) or (b) -- Also return CoVars that appear free in the final quantified types -- we can't quantify over these, and we must make sure they are in scope decideMonoTyVars infer_mode name_taus psigs candidates @@ -1475,7 +1680,7 @@ decideMonoTyVars infer_mode name_taus psigs candidates mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $ tyCoVarsOfTypes candidates -- We need to grab all the non-quantifiable tyvars in the - -- candidates so that we can grow this set to find other + -- types so that we can grow this set to find other -- non-quantifiable tyvars. This can happen with something -- like -- f x y = ... @@ -1487,30 +1692,47 @@ decideMonoTyVars infer_mode name_taus psigs candidates -- alpha. Actual test case: typecheck/should_compile/tc213 mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs - - eq_constraints = filter isEqPrimPred candidates - mono_tvs2 = growThetaTyVars eq_constraints mono_tvs1 + -- mono_tvs1 is now the set of variables from an outer scope + -- (that's mono_tvs0) and the set of covars, closed over kinds. + -- Given this set of variables we know we will not quantify, + -- we want to find any other variables that are determined by this + -- set, by functional dependencies or equalities. We thus use + -- closeWrtFunDeps to find all further variables determined by this root + -- set. See Note [growThetaTyVars vs closeWrtFunDeps] + + non_ip_candidates = filterOut isIPLikePred candidates + -- implicit params don't really determine a type variable + -- (that is, we might have IP "c" Bool and IP "c" Int in different + -- places within the same program), and + -- skipping this causes implicit params to monomorphise too many + -- variables; see Note [Inheriting implicit parameters] in + -- GHC.Tc.Solver. Skipping causes typecheck/should_compile/tc219 + -- to fail. + + mono_tvs2 = closeWrtFunDeps non_ip_candidates mono_tvs1 + -- mono_tvs2 now contains any variable determined by the "root + -- set" of monomorphic tyvars in mono_tvs1. constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $ - (growThetaTyVars eq_constraints - (tyCoVarsOfTypes no_quant) - `minusVarSet` mono_tvs2) - `delVarSetList` psig_qtvs + closeWrtFunDeps non_ip_candidates (tyCoVarsOfTypes no_quant) + `minusVarSet` mono_tvs2 -- constrained_tvs: the tyvars that we are not going to -- quantify solely because of the monomorphism restriction -- - -- (`minusVarSet` mono_tvs2`): a type variable is only + -- (`minusVarSet` mono_tvs2): a type variable is only -- "constrained" (so that the MR bites) if it is not - -- free in the environment (#13785) - -- + -- free in the environment (#13785) or is determined + -- by some variable that is free in the env't + + mono_tvs = (mono_tvs2 `unionVarSet` constrained_tvs) + `delVarSetList` psig_qtvs -- (`delVarSetList` psig_qtvs): if the user has explicitly -- asked for quantification, then that request "wins" - -- over the MR. Note: do /not/ delete psig_qtvs from - -- mono_tvs1, because mono_tvs1 cannot under any circumstances - -- be quantified (#14479); see - -- Note [Quantification and partial signatures], Wrinkle 3, 4 - - mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs + -- over the MR. + -- + -- What if a psig variable is also free in the environment + -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation + -- in Step 2 of Note [Deciding quantification]. -- Warn about the monomorphism restriction ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do @@ -1522,7 +1744,6 @@ decideMonoTyVars infer_mode name_taus psigs candidates , text "mono_tvs0 =" <+> ppr mono_tvs0 , text "no_quant =" <+> ppr no_quant , text "maybe_quant =" <+> ppr maybe_quant - , text "eq_constraints =" <+> ppr eq_constraints , text "mono_tvs =" <+> ppr mono_tvs , text "co_vars =" <+> ppr co_vars ] @@ -1546,16 +1767,17 @@ decideMonoTyVars infer_mode name_taus psigs candidates ------------------- defaultTyVarsAndSimplify :: TcLevel - -> TyCoVarSet + -> TyCoVarSet -- Promote these mono-tyvars -> [PredType] -- Assumed zonked -> TcM [PredType] -- Guaranteed zonked --- Default any tyvar free in the constraints, +-- Promote the known-monomorphic tyvars; +-- Default any tyvar free in the constraints; -- and re-simplify in case the defaulting allows further simplification defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates = do { -- Promote any tyvars that we cannot generalise -- See Note [Promote monomorphic tyvars] ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs) - ; any_promoted <- promoteTyVarSet mono_tvs + ; _ <- promoteTyVarSet mono_tvs -- Default any kind/levity vars ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} @@ -1565,35 +1787,34 @@ defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates -- the constraints generated ; poly_kinds <- xoptM LangExt.PolyKinds - ; default_kvs <- mapM (default_one poly_kinds True) - (dVarSetElems cand_kvs) - ; default_tvs <- mapM (default_one poly_kinds False) - (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) - ; let some_default = or default_kvs || or default_tvs - - ; case () of - _ | some_default -> simplify_cand candidates - | any_promoted -> mapM TcM.zonkTcType candidates - | otherwise -> return candidates + ; mapM_ (default_one poly_kinds True) (dVarSetElems cand_kvs) + ; mapM_ (default_one poly_kinds False) (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) + + ; simplify_cand candidates } where default_one poly_kinds is_kind_var tv | not (isMetaTyVar tv) - = return False + = return () | tv `elemVarSet` mono_tvs - = return False + = return () | otherwise - = defaultTyVar + = void $ defaultTyVar (if not poly_kinds && is_kind_var then DefaultKindVars else NonStandardDefaulting DefaultNonStandardTyVars) -- NB: only pass 'DefaultKindVars' when we know we're dealing with a kind variable. tv + -- this common case (no inferred contraints) should be fast + simplify_cand [] = return [] + -- see Note [Unconditionally resimplify constraints when quantifying] simplify_cand candidates - = do { clone_wanteds <- newWanteds DefaultOrigin candidates - ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $ - simplifyWantedsTcM clone_wanteds + = do { WC { wc_simple = simples } <- setTcLevel rhs_tclvl $ + do { wanteds <- newWanteds DefaultOrigin candidates + -- build wanteds at bumped level because newConcreteHole + -- whips up fresh metavariables + ; simplifyWantedsTcM wanteds } -- Discard evidence; simples is fully zonked ; let new_candidates = ctsPreds simples @@ -1625,6 +1846,7 @@ decideQuantifiedTyVars skol_info name_taus psigs candidates seed_tys = psig_tys ++ tau_tys -- Now "grow" those seeds to find ones reachable via 'candidates' + -- See Note [growThetaTyVars vs closeWrtFunDeps] grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys) -- Now we have to classify them into kind variables and type variables @@ -1652,15 +1874,90 @@ decideQuantifiedTyVars skol_info name_taus psigs candidates ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus } ------------------ +-- | When inferring types, should we quantify over a given predicate? +-- Generally true of classes; generally false of equality constraints. +-- Equality constraints that mention quantified type variables and +-- implicit variables complicate the story. See Notes +-- [Inheriting implicit parameters] and [Quantifying over equality constraints] +pickQuantifiablePreds + :: TyVarSet -- Quantifying over these + -> TcThetaType -- Proposed constraints to quantify + -> TcThetaType -- A subset that we can actually quantify +-- This function decides whether a particular constraint should be +-- quantified over, given the type variables that are being quantified +pickQuantifiablePreds qtvs theta + = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without + -- -XFlexibleContexts: see #10608, #10351 + -- flex_ctxt <- xoptM Opt_FlexibleContexts + mapMaybe (pick_me flex_ctxt) theta + where + pick_me flex_ctxt pred + = case classifyPredType pred of + + ClassPred cls tys + | Just {} <- isCallStackPred cls tys + -- NEVER infer a CallStack constraint. Otherwise we let + -- the constraints bubble up to be solved from the outer + -- context, or be defaulted when we reach the top-level. + -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence + -> Nothing + + | isIPClass cls + -> Just pred -- See Note [Inheriting implicit parameters] + + | pick_cls_pred flex_ctxt cls tys + -> Just pred + + EqPred eq_rel ty1 ty2 + | quantify_equality eq_rel ty1 ty2 + , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 + -- boxEqPred: See Note [Lift equality constraints when quantifying] + , pick_cls_pred flex_ctxt cls tys + -> Just (mkClassPred cls tys) + + IrredPred ty + | tyCoVarsOfType ty `intersectsVarSet` qtvs + -> Just pred + + _ -> Nothing + + + pick_cls_pred flex_ctxt cls tys + = tyCoVarsOfTypes tys `intersectsVarSet` qtvs + && (checkValidClsArgs flex_ctxt cls tys) + -- Only quantify over predicates that checkValidType + -- will pass! See #10351. + && (no_fixed_dependencies cls tys) + + -- See Note [Do not quantify over constraints that determine a variable] + no_fixed_dependencies cls tys + = and [ qtvs `intersectsVarSet` tyCoVarsOfTypes fd_lhs_tys + | fd <- cls_fds + , let (fd_lhs_tys, _) = instFD fd cls_tvs tys ] + where + (cls_tvs, cls_fds) = classTvsFds cls + + -- See Note [Quantifying over equality constraints] + quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 + quantify_equality ReprEq _ _ = True + + quant_fun ty + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) | isTypeFamilyTyCon tc + -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs + _ -> False + + +------------------ growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet --- See Note [Growing the tau-tvs using constraints] +-- See Note [growThetaTyVars vs closeWrtFunDeps] growThetaTyVars theta tcvs | null theta = tcvs | otherwise = transCloVarSet mk_next seed_tcvs where seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips (ips, non_ips) = partition isIPLikePred theta - -- See Note [Inheriting implicit parameters] in GHC.Tc.Utils.TcType + -- See Note [Inheriting implicit parameters] mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips @@ -1695,7 +1992,7 @@ quantify over all type variables that are * not forced to be monomorphic (mono_tvs), for example by being free in the environment. -However, in the case of a partial type signature, be doing inference +However, in the case of a partial type signature, we are doing inference *in the presence of a type signature*. For example: f :: _ -> a f x = ... @@ -1709,7 +2006,7 @@ sure to quantify over them. This leads to several wrinkles: f :: _ -> Maybe a f x = True && x The inferred type of 'f' is f :: Bool -> Bool, but there's a - left-over error of form (HoleCan (Maybe a ~ Bool)). The error-reporting + left-over error of form (Maybe a ~ Bool). The error-reporting machine expects to find a binding site for the skolem 'a', so we add it to the quantified tyvars. @@ -1750,17 +2047,55 @@ sure to quantify over them. This leads to several wrinkles: refrain from bogusly quantifying, in GHC.Tc.Solver.decideMonoTyVars. We report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. -Note [Growing the tau-tvs using constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(growThetaTyVars insts tvs) is the result of extending the set - of tyvars, tvs, using all conceivable links from pred +Note [growThetaTyVars vs closeWrtFunDeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with +the same type and similar behavior. This Note outlines the differences +and why we use one or the other. + +Both functions take a list of constraints. We will call these the +*candidates*. -E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e} -Then growThetaTyVars preds tvs = {a,b,c} +closeWrtFunDeps takes a set of "determined" type variables and finds the +closure of that set with respect to the functional dependencies +within the class constraints in the set of candidates. So, if we +have -Notice that - growThetaTyVars is conservative if v might be fixed by vs - => v `elem` grow(vs,C) + class C a b | a -> b + class D a b -- no fundep + candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)} + +then closeWrtFunDeps {a} will return the set {a,b,c}. +This is because, if `a` is determined, then `b` and `c` are, too, +by functional dependency. closeWrtFunDeps called with any seed set not including +`a` will just return its argument, as only `a` determines any other +type variable (in this example). + +growThetaTyVars operates similarly, but it behaves as if every +constraint has a functional dependency among all its arguments. +So, continuing our example, growThetaTyVars {a} will return +{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of +variables to include all variables that are mentioned in the same +constraint (transitively). + +We use closeWrtFunDeps in places where we need to know which variables are +*always* determined by some seed set. This includes + * when determining the mono-tyvars in decideMonoTyVars. If `a` + is going to be monomorphic, we need b and c to be also: they + are determined by the choice for `a`. + * when checking instance coverage, in + GHC.Tc.Instance.FunDeps.checkInstCoverage + +On the other hand, we use growThetaTyVars where we need to know +which variables *might* be determined by some seed set. This includes + * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers + and decideQuantifiedTyVars +How can `a` determine (say) `d` in the example above without a fundep? +Suppose we have + instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c) +Now, if `a` turns out to be a list, it really does determine b and c. +The danger in overdoing quantification is the creation of an ambiguous +type signature, but this is conveniently caught in the validity checker. Note [Quantification with errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1790,12 +2125,6 @@ GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type the recovery from failM emits no code at all, so there is no function to run! But -fdefer-type-errors aspires to produce a runnable program. -NB that we must include *derived* errors in the check for insolubles. -Example: - (a::*) ~ Int# -We get an insoluble derived error *~#, and we don't want to discard -it before doing the isInsolubleWC test! (#8262) - Note [Default while Inferring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Our current plan is that defaulting only happens at simplifyTop and @@ -1877,26 +2206,15 @@ This only half-works, but then let-generalisation only half-works. simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints -- Solve the specified Wanted constraints -- Discard the evidence binds --- Discards all Derived stuff in result -- Postcondition: fully zonked simplifyWantedsTcM wanted = do { traceTc "simplifyWantedsTcM {" (ppr wanted) - ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted)) + ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted)) ; result <- TcM.zonkWC result ; traceTc "simplifyWantedsTcM }" (ppr result) ; return result } -solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints --- Since solveWanteds returns the residual WantedConstraints, --- it should always be called within a runTcS or something similar, --- Result is not zonked -solveWantedsAndDrop wanted - = do { wc <- solveWanteds wanted - ; return (dropDerivedWC wc) } - solveWanteds :: WantedConstraints -> TcS WantedConstraints --- so that the inert set doesn't mindlessly propagate. --- NB: wc_simples may be wanted /or/ derived now solveWanteds wc@(WC { wc_holes = holes }) = do { cur_lvl <- TcS.getTcLevel ; traceTcS "solveWanteds {" $ @@ -1921,7 +2239,7 @@ simplify_loop :: Int -> IntWithInf -> Bool -> WantedConstraints -> TcS WantedConstraints -- Do a round of solving, and call maybe_simplify_again to iterate -- The 'definitely_redo_implications' flags is False if the only reason we --- are iterating is that we have added some new Derived superclasses (from Wanteds) +-- are iterating is that we have added some new Wanted superclasses -- hoping for fundeps to help us; see Note [Superclass iteration] -- -- Does not affect wc_holes at all; reason: wc_holes never affects anything @@ -1993,15 +2311,15 @@ Consider this implication constraint where class D a b | a -> b class D a b => C a b -We will expand d's superclasses, giving [D] D Int beta, in the hope of geting +We will expand d's superclasses, giving [W] D Int beta, in the hope of geting fundeps to unify beta. Doing so is usually fruitless (no useful fundeps), and if so it seems a pity to waste time iterating the implications (forall b. blah) (If we add new Given superclasses it's a different matter: it's really worth looking at the implications.) Hence the definitely_redo_implications flag to simplify_loop. It's usually -True, but False in the case where the only reason to iterate is new Derived -superclasses. In that case we check whether the new Deriveds actually led to +True, but False in the case where the only reason to iterate is new Wanted +superclasses. In that case we check whether the new Wanteds actually led to any new unifications, and iterate the implications only if so. -} @@ -2055,9 +2373,6 @@ solveImplication imp@(Implic { ic_tclvl = tclvl ; solveSimpleGivens givens ; residual_wanted <- solveWanteds wanteds - -- solveWanteds, *not* solveWantedsAndDrop, because - -- we want to retain derived equalities so we can float - -- them out in floatEqualities. ; (has_eqs, given_insols) <- getHasGivenEqs tclvl -- Call getHasGivenEqs /after/ solveWanteds, because @@ -2099,9 +2414,8 @@ solveImplication imp@(Implic { ic_tclvl = tclvl ---------------------- setImplicationStatus :: Implication -> TcS (Maybe Implication) --- Finalise the implication returned from solveImplication: --- * Set the ic_status field --- * Trim the ic_wanted field to remove Derived constraints +-- Finalise the implication returned from solveImplication, +-- setting the ic_status field -- Precondition: the ic_status field is not already IC_Solved -- Return Nothing if we can discard the implication altogether setImplicationStatus implic@(Implic { ic_status = status @@ -2170,9 +2484,8 @@ setImplicationStatus implic@(Implic { ic_status = status where WC { wc_simple = simples, wc_impl = implics, wc_holes = holes } = wc - pruned_simples = dropDerivedSimples simples pruned_implics = filterBag keep_me implics - pruned_wc = WC { wc_simple = pruned_simples + pruned_wc = WC { wc_simple = simples , wc_impl = pruned_implics , wc_holes = holes } -- do not prune holes; these should be reported @@ -2546,7 +2859,9 @@ defaultTyVarTcS the_tv = return False -- the common case approximateWC :: Bool -> WantedConstraints -> Cts --- Postcondition: Wanted or Derived Cts +-- Second return value is the depleted wc +-- Third return value is YesFDsCombined <=> multiple constraints for the same fundep floated +-- Postcondition: Wanted Cts -- See Note [ApproximateWC] -- See Note [floatKindEqualities vs approximateWC] approximateWC float_past_equalities wc @@ -2629,7 +2944,6 @@ you want. So I simply removed the extra code to implement the contamination stuff. There was zero effect on the testsuite (not even #8155). ------ End of historical note ----------- - Note [DefaultTyVar] ~~~~~~~~~~~~~~~~~~~ defaultTyVar is used on any un-instantiated meta type variables to @@ -2648,7 +2962,7 @@ are going to affect these type variables, so it's time to do it by hand. However we aren't ready to default them fully to () or whatever, because the type-class defaulting rules have yet to run. -An alternate implementation would be to emit a derived constraint setting +An alternate implementation would be to emit a Wanted constraint setting the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. Note [Promote _and_ default when inferring] @@ -2769,7 +3083,7 @@ applyDefaultingRules wanteds findDefaultableGroups :: ( [Type] , (Bool,Bool) ) -- (Overloaded strings, extended default rules) - -> WantedConstraints -- Unsolved (wanted or derived) + -> WantedConstraints -- Unsolved -> [(TyVar, [Ct])] findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds | null default_tys @@ -2855,8 +3169,12 @@ disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) ; tc_lvl <- TcS.getTcLevel ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) lcl_env -- Equality constraints are possible due to type defaulting plugins - ; wanted_evs <- mapM (newWantedNC loc . substTy subst . ctPred) - wanteds + ; wanted_evs <- sequence [ newWantedNC loc rewriters pred' + | wanted <- wanteds + , CtWanted { ctev_pred = pred + , ctev_rewriters = rewriters } + <- return (ctEvidence wanted) + , let pred' = substTy subst pred ] ; fmap isEmptyWC $ solveSimpleWanteds $ listToBag $ map mkNonCanonical wanted_evs } diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index 1643a0ef46..f38c5de866 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -4,7 +4,7 @@ module GHC.Tc.Solver.Canonical( canonicalize, - unifyDerived, + unifyWanted, makeSuperClasses, StopOrContinue(..), stopWith, continueWith, andWhenContinue, solveCallStack -- For GHC.Tc.Solver @@ -59,8 +59,10 @@ import Data.Maybe ( isJust, isNothing ) import Data.List ( zip4 ) import GHC.Types.Basic +import qualified Data.Semigroup as S import Data.Bifunctor ( bimap ) import Data.Foldable ( traverse_ ) +import GHC.Tc.Utils.Monad (setTcLevel) {- ************************************************************************ @@ -162,7 +164,7 @@ canClassNC ev cls tys ; emitWork sc_cts ; canClass ev cls tys False fds } - | isWanted ev + | CtWanted { ctev_rewriters = rewriters } <- ev , Just ip_name <- isCallStackPred cls tys , isPushCallStackOrigin orig -- If we're given a CallStack constraint that arose from a function @@ -176,8 +178,9 @@ canClassNC ev cls tys -- We change the origin to IPOccOrigin so -- this rule does not fire again. -- See Note [Overview of implicit CallStacks] + -- in GHC.Tc.Types.Evidence - ; new_ev <- newWantedEvVarNC new_loc pred + ; new_ev <- newWantedEvVarNC new_loc rewriters pred -- Then we solve the wanted by pushing the call-site -- onto the newly emitted CallStack @@ -220,15 +223,14 @@ canClass :: CtEvidence canClass ev cls tys pend_sc fds = -- all classes do *nominal* matching assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $ - do { redns@(Reductions _ xis) <- rewriteArgsNom ev cls_tc tys + do { (redns@(Reductions _ xis), rewriters) <- rewriteArgsNom ev cls_tc tys ; let redn@(Reduction _ xi) = mkClassPredRedn cls redns mk_ct new_ev = CDictCan { cc_ev = new_ev , cc_tyargs = xis , cc_class = cls , cc_pend_sc = pend_sc , cc_fundeps = fds } - ; mb <- rewriteEvidence ev redn - + ; mb <- rewriteEvidence rewriters ev redn ; traceTcS "canClass" (vcat [ ppr ev , ppr xi, ppr mb ]) ; return (fmap mk_ct mb) } @@ -245,15 +247,14 @@ We need to add superclass constraints for two reasons: We get a Wanted (Eq a), which can only be solved from the superclass of the Given (Ord a). -* For wanteds [W], and deriveds [WD], [D], they may give useful +* For wanteds [W], they may give useful functional dependencies. E.g. class C a b | a -> b where ... class C a b => D a b where ... Now a [W] constraint (D Int beta) has (C Int beta) as a superclass and that might tell us about beta, via C's fundeps. We can get this - by generating a [D] (C Int beta) constraint. It's derived because - we don't actually have to cough up any evidence for it; it's only there - to generate fundep equalities. + by generating a [W] (C Int beta) constraint. We won't use the evidence, + but it may lead to unification. See Note [Why adding superclasses can help]. @@ -303,7 +304,7 @@ So here's the plan: GHC.Tc.Solver.simpl_loop and solveWanteds. This may succeed in generating (a finite number of) extra Givens, - and extra Deriveds. Both may help the proof. + and extra Wanteds. Both may help the proof. 3a An important wrinkle: only expand Givens from the current level. Two reasons: @@ -397,7 +398,7 @@ Examples of how adding superclasses can help: Suppose we want to solve [G] C a b [W] C a beta - Then adding [D] beta~b will let us solve it. + Then adding [W] beta~b will let us solve it. -- Example 2 (similar but using a type-equality superclass) class (F a ~ b) => C a b @@ -406,8 +407,8 @@ Examples of how adding superclasses can help: [W] C a beta Follow the superclass rules to add [G] F a ~ b - [D] F a ~ beta - Now we get [D] beta ~ b, and can solve that. + [W] F a ~ beta + Now we get [W] beta ~ b, and can solve that. -- Example (tcfail138) class L a b | a -> b @@ -422,9 +423,9 @@ Examples of how adding superclasses can help: [W] G (Maybe a) Use the instance decl to get [W] C a beta - Generate its derived superclass - [D] L a beta. Now using fundeps, combine with [G] L a b to get - [D] beta ~ b + Generate its superclass + [W] L a beta. Now using fundeps, combine with [G] L a b to get + [W] beta ~ b which is what we want. Note [Danger of adding superclasses during solving] @@ -441,8 +442,8 @@ Assume the generated wanted constraint is: If we were to be adding the superclasses during simplification we'd get: [W] RealOf e ~ e [W] Normed e - [D] RealOf e ~ fuv - [D] Num fuv + [W] RealOf e ~ fuv + [W] Num fuv ==> e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv @@ -451,9 +452,6 @@ superclass of (Normed fuv) again we'd loop. By adding superclasses definitely only once, during canonicalisation, this situation can't happen. -Mind you, now that Wanteds cannot rewrite Derived, I think this particular -situation can't happen. - Note [Nested quantified constraint superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (typecheck/should_compile/T17202) @@ -616,18 +614,19 @@ mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc }) mk_strict_superclasses rec_clss ev tvs theta cls tys | all noFreeVarsOfType tys - = return [] -- Wanteds with no variables yield no deriveds. + = return [] -- Wanteds with no variables yield no superclass constraints. -- See Note [Improvement from Ground Wanteds] - | otherwise -- Wanted/Derived case, just add Derived superclasses + | otherwise -- Wanted case, just add Wanted superclasses -- that can lead to improvement. = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $ - concatMapM do_one_derived (immSuperClasses cls tys) + concatMapM do_one (immSuperClasses cls tys) where - loc = ctEvLoc ev + loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev) - do_one_derived sc_pred - = do { sc_ev <- newDerivedNC loc sc_pred + do_one sc_pred + = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred) + ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred ; mk_superclasses rec_clss sc_ev [] [] sc_pred } {- Note [Improvement from Ground Wanteds] @@ -635,8 +634,8 @@ mk_strict_superclasses rec_clss ev tvs theta cls tys Suppose class C b a => D a b and consider [W] D Int Bool -Is there any point in emitting [D] C Bool Int? No! The only point of -emitting superclass constraints for W/D constraints is to get +Is there any point in emitting [W] C Bool Int? No! The only point of +emitting superclass constraints for W constraints is to get improvement, extra unifications that result from functional dependencies. See Note [Why adding superclasses can help] above. @@ -734,8 +733,8 @@ canIrred :: CtEvidence -> TcS (StopOrContinue Ct) canIrred ev = do { let pred = ctEvPred ev ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred) - ; redn <- rewrite ev pred - ; rewriteEvidence ev redn `andWhenContinue` \ new_ev -> + ; (redn, rewriters) <- rewrite ev pred + ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev -> do { -- Re-classify, in case rewriting has improved its shape -- Code is like the canNC, except @@ -856,8 +855,8 @@ canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct) canForAll ev pend_sc = do { -- First rewrite it to apply the current substitution let pred = ctEvPred ev - ; redn <- rewrite ev pred - ; rewriteEvidence ev redn `andWhenContinue` \ new_ev -> + ; (redn, rewriters) <- rewrite ev pred + ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev -> do { -- Now decompose into its pieces and solve it -- (It takes a lot less code to rewrite before decomposing.) @@ -869,8 +868,8 @@ canForAll ev pend_sc solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool -> TcS (StopOrContinue Ct) -solveForAll ev tvs theta pred pend_sc - | CtWanted { ctev_dest = dest } <- ev +solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc }) + tvs theta pred _pend_sc = -- See Note [Solving a Wanted forall-constraint] setLclEnv (ctLocEnv loc) $ -- This setLclEnv is important: the emitImplicationTcS uses that @@ -884,7 +883,7 @@ solveForAll ev tvs theta pred pend_sc ; (lvl, (w_id, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ - do { wanted_ev <- newWantedEvVarNC loc $ + do { wanted_ev <- newWantedEvVarNC loc rewriters $ substTy subst pred ; return ( ctEvEvId wanted_ev , unitBag (mkNonCanonical wanted_ev)) } @@ -898,15 +897,11 @@ solveForAll ev tvs theta pred pend_sc ; stopWith ev "Wanted forall-constraint" } - | isGiven ev -- See Note [Solving a Given forall-constraint] + -- See Note [Solving a Given forall-constraint] +solveForAll ev@(CtGiven {}) tvs _theta pred pend_sc = do { addInertForAll qci ; stopWith ev "Given forall-constraint" } - - | otherwise - = do { traceTcS "discarding derived forall-constraint" (ppr ev) - ; stopWith ev "Derived forall-constraint" } where - loc = ctEvLoc ev qci = QCI { qci_ev = ev, qci_tvs = tvs , qci_pred = pred, qci_pend_sc = pend_sc } @@ -976,6 +971,44 @@ here are some examples: ==> the second constraint can be decomposed again; 'RuntimeRep' and '[]' are concrete, so we get C: Concrete# Rep, C: Concrete# rr +Note [Solving Concrete constraints requires simplifyArgsWorker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have + [W] co :: Concrete# [LiftedRep, IntRep] +and wish to canonicalise it so that we can solve it. Of course, that's really + [W] co :: Concrete# ((:) @RuntimeRep LiftedRep ((:) @RuntimeRep IntRep ('[] @RuntimeRep))) + +We can decompose to + [W] co1 :: Concrete# RuntimeRep + [W] co2 :: Concrete# LiftedRep + [W] co3 :: Concrete# ((:) @RuntimeRep IntRep ('[] @RuntimeRep)) + +Recall (Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete) that the evidence for +a Concrete# ty constraint is a coercion of type ty ~# alpha, where we require a concrete +type (one that responds True to GHC.Core.Type.isConcrete) to fill in alpha when solving +the constraint. Accordingly, when we create these new Concrete# constraints, we create +new metavariables alpha1 :: Type, alpha2 :: RuntimeRep, alpha3 :: [RuntimeRep], with: + + co1 :: RuntimeRep ~# alpha1 + co2 :: LiftedRep ~# alpha2 + co3 :: '[IntRep] ~# alpha3 + +and we already have + + co :: [LiftedRep, IntRep] ~# alpha0 + +We are now solving co. What do we fill in alpha0 with? The naive answer is to say + + alpha0 := (:) alpha1 alpha2 alpha3 + +but this would be ill-kinded! The first problem is that `(:) alpha1` expects its next +argument to have kind alpha1. (The next argument -- alpha3 -- is problematic, too.) The +second problem is that alpha0 :: [RuntimeRep], but the right-hand side above has kind +[alpha1]. Happily, we have a solution close to hand: simplifyArgsWorker, which deals +with precisely this scenario, of replacing all the arguments to a function (in this case, (:)), +with new arguments but making sure the kinds line up. All we have to do is bundle the information +we have in a form simplifyArgsWorker likes, and then do the reverse from its result. + -} -- | Canonicalise a 'Concrete#' constraint. @@ -1026,13 +1059,29 @@ canDecomposableConcretePrim :: CtEvidence canDecomposableConcretePrim ev f_tc args = do { traceTcS "canDecomposableConcretePrim" $ vcat [text "args =" <+> ppr args, text "ev =" <+> ppr ev] - ; arg_cos <- mapM (emit_new_concretePrim_wanted (ctEvLoc ev)) args - ; case ev of - CtWanted { ctev_dest = dest } - -> setWantedEvTerm dest (evCoercion $ mkTyConAppCo Nominal f_tc arg_cos) - _ -> pprPanic "canDecomposableConcretePrim: non-Wanted" $ - vcat [ text "ev =" <+> ppr ev - , text "args =" <+> ppr args ] + ; let ev_lvl + | CtWanted { ctev_dest = HoleDest hole } <- ev + , (_, _, _, conc_rhs_ty, Nominal) <- coVarKindsTypesRole (coHoleCoVar hole) + , Just conc_rhs_tv <- getTyVar_maybe conc_rhs_ty + , Just lvl <- metaTyVarTcLevel_maybe conc_rhs_tv + = lvl + + | otherwise + = pprPanic "canDecomposableConcretePrim" (ppr ev) + + ; (arg_cos, rhs_args) + <- mapAndUnzipM (emit_new_concretePrim_wanted ev_lvl (ctEvLoc ev)) args + + -- See Note [Solving Concrete constraints requires simplifyArgsWorker] + ; let (tc_binders, tc_res_kind) = splitPiTys (tyConKind f_tc) + fvs_args = tyCoVarsOfTypes rhs_args + ArgsReductions reductions final_co + = simplifyArgsWorker tc_binders tc_res_kind fvs_args + (repeat Nominal) (zipWith mkReduction arg_cos rhs_args) + Reduction concrete_co uncasted_concrete_rhs = mkTyConAppRedn Nominal f_tc reductions + concrete_rhs = uncasted_concrete_rhs `mkCastTyMCo` mkSymMCo final_co + + ; solveConcretePrimWanted ev concrete_co concrete_rhs ; stopWith ev "Decomposed Concrete#" } -- | Canonicalise a non-decomposable 'Concrete#' constraint. @@ -1050,12 +1099,44 @@ canNonDecomposableConcretePrim ev ty ; continueWith new_ct } -- | Create a new 'Concrete#' Wanted constraint and immediately add it --- to the work list. -emit_new_concretePrim_wanted :: CtLoc -> Type -> TcS Coercion -emit_new_concretePrim_wanted loc ty - = do { (hole, wanted) <- wrapTcS $ newConcretePrimWanted loc ty +-- to the work list. Returns the evidence (a coercion hole) used for the +-- constraint, and the right-hand type (a metavariable) of that coercion +emit_new_concretePrim_wanted :: TcLevel -> CtLoc -> Type -> TcS (Coercion, TcType) +emit_new_concretePrim_wanted ev_lvl loc ty + = do { (hole, rhs_ty, wanted) <- wrapTcS $ setTcLevel ev_lvl $ newConcretePrimWanted loc ty ; emitWorkNC [wanted] - ; return $ mkHoleCo hole } + ; return (mkHoleCo hole, rhs_ty) } + +-- | Solve a Wanted 'Concrete#' constraint. +-- +-- Recall that, when we create a Wanted constraint of the form @Concrete# ty@, +-- we create a metavariable @concrete_tau@ and a coercion hole of type +-- @ty ~# concrete_tau@. +-- +-- When we want to solve this constraint, because we have found that +-- @ty@ is indeed equal to a concrete type @rhs@, we thus need to do +-- two things: +-- +-- 1. fill the metavariable @concrete_tau := rhs@, +-- 2. fill the coercion hole with the evidence for the equality @ty ~# rhs@. +solveConcretePrimWanted :: HasDebugCallStack + => CtEvidence -- ^ always a [W] Concrete# ty + -> Coercion -- ^ @co :: ty ~ rhs@ + -> TcType -- ^ @rhs@, which must be concrete + -> TcS () +solveConcretePrimWanted (CtWanted { ctev_dest = dest@(HoleDest hole) }) co rhs + = do { let Pair _ty concrete_tau = coVarTypes $ coHoleCoVar hole + tau_tv = getTyVar "solveConcretePrimWanted" concrete_tau + ; unifyTyVar tau_tv rhs + ; setWantedEq dest co } + +solveConcretePrimWanted ev co rhs + = pprPanic "solveConcretePrimWanted: no coercion hole to fill" $ + vcat [ text "ev =" <+> ppr ev <> semi <+> text "dest =" <+> case ev of + CtWanted { ctev_dest = EvVarDest var } -> text "var" <+> ppr var + _ -> text "XXX NOT EVEN A WANTED XXX" + , text "co =" <+> ppr co + , text "rhs =" <+> ppr rhs ] {- ********************************************************************** * * @@ -1220,9 +1301,9 @@ can_eq_nc' True _rdr_env _envs ev NomEq ty1 _ ty2 _ -- No similarity in type structure detected. Rewrite and try again. can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 - = do { redn1@(Reduction _ xi1) <- rewrite ev ps_ty1 - ; redn2@(Reduction _ xi2) <- rewrite ev ps_ty2 - ; new_ev <- rewriteEqEvidence ev NotSwapped redn1 redn2 + = do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1 + ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2 + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } ---------------------------- @@ -1340,7 +1421,7 @@ can_eq_nc_forall :: CtEvidence -> EqRel -- so we must proceed one binder at a time (#13879) can_eq_nc_forall ev eq_rel s1 s2 - | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev + | CtWanted { ctev_loc = loc, ctev_dest = orig_dest, ctev_rewriters = rewriters } <- ev = do { let free_tvs = tyCoVarsOfTypes [s1,s2] (bndrs1, phi1) = tcSplitForAllTyVarBinders s1 (bndrs2, phi2) = tcSplitForAllTyVarBinders s2 @@ -1364,7 +1445,7 @@ can_eq_nc_forall ev eq_rel s1 s2 -> TcS (TcCoercion, Cts) go (skol_tv:skol_tvs) subst (bndr2:bndrs2) = do { let tv2 = binderVar bndr2 - ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv) + ; (kind_co, wanteds1) <- unify loc rewriters Nominal (tyVarKind skol_tv) (substTy subst (tyVarKind tv2)) ; let subst' = extendTvSubstAndInScope subst tv2 (mkCastTy (mkTyVarTy skol_tv) kind_co) @@ -1376,8 +1457,8 @@ can_eq_nc_forall ev eq_rel s1 s2 -- Done: unify phi1 ~ phi2 go [] subst bndrs2 - = assert (null bndrs2 ) - unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2) + = assert (null bndrs2) $ + unify loc rewriters (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2) go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] @@ -1396,14 +1477,14 @@ can_eq_nc_forall ev eq_rel s1 s2 ; stopWith ev "Discard given polytype equality" } where - unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts) + unify :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts) -- This version returns the wanted constraint rather -- than putting it in the work list - unify loc role ty1 ty2 + unify loc rewriters role ty1 ty2 | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1, emptyBag) | otherwise - = do { (wanted, co) <- newWantedEq loc role ty1 ty2 + = do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2 ; return (co, unitBag (mkNonCanonical wanted)) } --------------------------------- @@ -1641,7 +1722,7 @@ can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2 ; let redn1 = mkReduction co1 ty1' - ; new_ev <- rewriteEqEvidence ev swapped + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped redn1 (mkReflRedn Representational ps_ty2) ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 } @@ -1661,16 +1742,12 @@ can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2 -- to an irreducible constraint; see typecheck/should_compile/T10494 -- See Note [Decomposing AppTy at representational role] can_eq_app ev s1 t1 s2 t2 - | CtDerived {} <- ev - = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2] - ; stopWith ev "Decomposed [D] AppTy" } - - | CtWanted { ctev_dest = dest } <- ev - = do { co_s <- unifyWanted loc Nominal s1 s2 + | CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } <- ev + = do { co_s <- unifyWanted rewriters loc Nominal s1 s2 ; let arg_loc | isNextArgVisible s1 = loc | otherwise = updateCtLocOrigin loc toInvisibleOrigin - ; co_t <- unifyWanted arg_loc Nominal t1 t2 + ; co_t <- unifyWanted rewriters arg_loc Nominal t1 t2 ; let co = mkAppCo co_s co_t ; setWantedEq dest co ; stopWith ev "Decomposed [W] AppTy" } @@ -1718,7 +1795,7 @@ canEqCast rewritten ev eq_rel swapped ty1 co1 ty2 ps_ty2 = do { traceTcS "Decomposing cast" (vcat [ ppr ev , ppr ty1 <+> text "|>" <+> ppr co1 , ppr ps_ty2 ]) - ; new_ev <- rewriteEqEvidence ev swapped + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped (mkGReflLeftRedn role ty1 co1) (mkReflRedn role ps_ty2) ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 } @@ -1827,18 +1904,13 @@ So, in broad strokes, we want this rule: at role X. Pursuing the details requires exploring three axes: -* Flavour: Given vs. Derived vs. Wanted +* Flavour: Given vs. Wanted * Role: Nominal vs. Representational * TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable (A type variable isn't a TyCon, of course, but it's convenient to put the AppTy case in the same table.) -Right away, we can say that Derived behaves just as Wanted for the purposes -of decomposition. The difference between Derived and Wanted is the handling of -evidence. Since decomposition in these cases isn't a matter of soundness but of -guessing, we want the same behaviour regardless of evidence. - Here is a table (discussion following) detailing where decomposition of (T s1 ... sn) ~r (T t1 .. tn) is allowed. The first four lines (Data types ... type family) refer @@ -1865,7 +1937,7 @@ AppTy NO{4} NO{4} can_eq_nc' {1}: Type families can be injective in some, but not all, of their arguments, so we want to do partial decomposition. This is quite different than the way other decomposition is done, where the decomposed equalities replace the original -one. We thus proceed much like we do with superclasses, emitting new Deriveds +one. We thus proceed much like we do with superclasses, emitting new Wanteds when "decomposing" a partially-injective type family Wanted. Injective type families have no corresponding evidence of their injectivity, so we cannot decompose an injective-type-family Given. @@ -1879,6 +1951,27 @@ test case typecheck/should_fail/T10534. {4}: See Note [Decomposing AppTy at representational role] + Because type variables can stand in for newtypes, we conservatively do not + decompose AppTys over representational equality. Here are two examples that + demonstrate why we can't: + + 4a: newtype Phant a = MkPhant Int + [W] alpha Int ~R beta Bool + + If we eventually solve alpha := Phant and beta := Phant, then we can solve + this equality by unwrapping. But it would have been disastrous to decompose + the wanted to produce Int ~ Bool, which is definitely insoluble. + + 4b: newtype Age = MkAge Int + [W] alpha Age ~R Maybe Int + + First, a question: if we know that ty1 ~R ty2, can we conclude that + a ty1 ~R a ty2? Not for all a. This is precisely why we need role annotations + on type constructors. So, if we were to decompose, we would need to + decompose to [W] alpha ~R Maybe and [W] Age ~ Int. On the other hand, if we + later solve alpha := Maybe, then we would decompose to [W] Age ~R Int, and + that would be soluble. + In the implementation of can_eq_nc and friends, we don't directly pattern match using lines like in the tables above, as those tables don't cover all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity, @@ -2020,14 +2113,11 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 do { traceTcS "canDecomposableTyConAppOK" (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2) ; case ev of - CtDerived {} - -> unifyDeriveds loc tc_roles tys1 tys2 - - CtWanted { ctev_dest = dest } + CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } -- new_locs and tc_roles are both infinite, so -- we are guaranteed that cos has the same length -- as tys1 and tys2 - -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2 + -> do { cos <- zipWith4M (unifyWanted rewriters) new_locs tc_roles tys1 tys2 ; setWantedEq dest (mkTyConAppCo role tc cos) } CtGiven { ctev_evar = evar } @@ -2077,14 +2167,14 @@ canEqFailure :: CtEvidence -> EqRel canEqFailure ev NomEq ty1 ty2 = canEqHardFailure ev ty1 ty2 canEqFailure ev ReprEq ty1 ty2 - = do { redn1 <- rewrite ev ty1 - ; redn2 <- rewrite ev ty2 + = do { (redn1, rewriters1) <- rewrite ev ty1 + ; (redn2, rewriters2) <- rewrite ev ty2 -- We must rewrite the types before putting them in the -- inert set, so that we are sure to kick them out when -- new equalities become available ; traceTcS "canEqFailure with ReprEq" $ vcat [ ppr ev, ppr redn1, ppr redn2 ] - ; new_ev <- rewriteEqEvidence ev NotSwapped redn1 redn2 + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 ; continueWith (mkIrredCt ReprEqReason new_ev) } -- | Call when canonicalizing an equality fails with utterly no hope. @@ -2093,9 +2183,9 @@ canEqHardFailure :: CtEvidence -- See Note [Make sure that insolubles are fully rewritten] canEqHardFailure ev ty1 ty2 = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2) - ; redn1 <- rewrite ev ty1 - ; redn2 <- rewrite ev ty2 - ; new_ev <- rewriteEqEvidence ev NotSwapped redn1 redn2 + ; (redn1, rewriters1) <- rewrite ev ty1 + ; (redn2, rewriters2) <- rewrite ev ty2 + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 ; continueWith (mkIrredCt ShapeMismatchReason new_ev) } {- @@ -2150,21 +2240,6 @@ Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? No -- what would the evidence look like? So instead we simply discard this given evidence. - -Note [Combining insoluble constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As this point we have an insoluble constraint, like Int~Bool. - - * If it is Wanted, delete it from the cache, so that subsequent - Int~Bool constraints give rise to separate error messages - - * But if it is Derived, DO NOT delete from cache. A class constraint - may get kicked out of the inert set, and then have its functional - dependency Derived constraints generated a second time. In that - case we don't want to get two (or more) error messages by - generating two (or more) insoluble fundep constraints from the same - class constraint. - Note [No top-level newtypes on RHS of representational equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we're in this situation: @@ -2190,8 +2265,8 @@ Ticket #10009, a very nasty example: g _ = f (undefined :: F a) For g we get [G] g1 : UnF (F a) ~ a - [WD] w1 : UnF (F beta) ~ beta - [WD] w2 : F a ~ F beta + [W] w1 : UnF (F beta) ~ beta + [W] w2 : F a ~ F beta g1 is canonical (CEqCan). It is oriented as above because a is not touchable. See canEqTyVarFunEq. @@ -2206,17 +2281,16 @@ of w2. We'll thus lose. But if w2 is swapped around, to - [D] w3 : F beta ~ F a + [W] w3 : F beta ~ F a -then (after emitting shadow Deriveds, etc. See GHC.Tc.Solver.Monad -Note [The improvement story and derived shadows]) we'll kick w1 out of the inert +then we'll kick w1 out of the inert set (it mentions the LHS of w3). We then rewrite w1 to - [D] w4 : UnF (F a) ~ beta + [W] w4 : UnF (F a) ~ beta and then, using g1, to - [D] w5 : a ~ beta + [W] w5 : a ~ beta at which point we can unify and go on to glory. (This rewriting actually happens all at once, in the call to rewrite during canonicalisation.) @@ -2243,7 +2317,7 @@ canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 | otherwise - = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2 + = canEqCanLHSHetero ev eq_rel swapped lhs1 k1 xi2 k2 where k1 = canEqLHSKind lhs1 @@ -2251,40 +2325,42 @@ canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2) -> EqRel -> SwapFlag - -> CanEqLHS -> TcType -- xi1, pretty xi1 + -> CanEqLHS -- xi1 -> TcKind -- ki1 - -> TcType -> TcType -- xi2, pretty xi2 :: ki2 + -> TcType -- xi2 -> TcKind -- ki2 -> TcS (StopOrContinue Ct) -canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 +canEqCanLHSHetero ev eq_rel swapped lhs1 ki1 xi2 ki2 -- See Note [Equalities with incompatible kinds] - = do { kind_co <- emit_kind_co -- :: ki2 ~N ki1 + = do { (kind_ev, kind_co) <- mk_kind_eq -- :: ki2 ~N ki1 ; let -- kind_co :: (ki2 :: *) ~N (ki1 :: *) (whether swapped or not) - -- co1 :: kind(tv1) ~N ki1 - ps_rhs' = ps_xi2 `mkCastTy` kind_co -- :: ki1 - lhs_redn = mkReflRedn role xi1 - rhs_redn@(Reduction _ rhs') - = mkGReflRightRedn role xi2 kind_co + rhs_redn = mkGReflRightRedn role xi2 kind_co + + -- See Note [Equalities with incompatible kinds], Wrinkle (1) + -- This will be ignored in rewriteEqEvidence if the work item is a Given + rewriters = rewriterSetFromCo kind_co ; traceTcS "Hetero equality gives rise to kind equality" (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ]) - ; type_ev <- rewriteEqEvidence ev swapped lhs_redn rhs_redn + ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn - -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more - ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 rhs' ps_rhs' } + ; emitWorkNC [type_ev] -- delay the type equality until after we've finished + -- the kind equality, which may unlock things + -- See Note [Equalities with incompatible kinds] + + ; canEqNC kind_ev NomEq ki2 ki1 } where - emit_kind_co :: TcS CoercionN - emit_kind_co - | CtGiven { ctev_evar = evar } <- ev - = do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar) -- :: k2 ~ k1 - ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co) - ; emitWorkNC [kind_ev] - ; return (ctEvCoercion kind_ev) } + mk_kind_eq :: TcS (CtEvidence, CoercionN) + mk_kind_eq = case ev of + CtGiven { ctev_evar = evar } + -> do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar) -- :: k2 ~ k1 + ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co) + ; return (kind_ev, ctEvCoercion kind_ev) } - | otherwise - = unifyWanted kind_loc Nominal ki2 ki1 + CtWanted { ctev_rewriters = rewriters } + -> newWantedEq kind_loc rewriters Nominal ki2 ki1 xi1 = canEqLHSType lhs1 loc = ctev_loc ev @@ -2354,7 +2430,7 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco , TyFamLHS fun_tc2 fun_args2 <- lhs2 = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2) - -- emit derived equalities for injective type families + -- emit wanted equalities for injective type families ; let inj_eqns :: [TypeEqn] -- TypeEqn = Pair Type inj_eqns | ReprEq <- eq_rel = [] -- injectivity applies only for nom. eqs. @@ -2387,11 +2463,13 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco | otherwise -- ordinary, non-injective type family = [] - ; unless (isGiven ev) $ - mapM_ (unifyDerived (ctEvLoc ev) Nominal) inj_eqns + ; case ev of + CtWanted { ctev_rewriters = rewriters } -> + mapM_ (\ (Pair t1 t2) -> unifyWanted rewriters (ctEvLoc ev) Nominal t1 t2) inj_eqns + CtGiven {} -> return () + -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Interact ; tclvl <- getTcLevel - ; dflags <- getDynFlags ; let tvs1 = tyCoVarsOfTypes fun_args1 tvs2 = tyCoVarsOfTypes fun_args2 @@ -2402,9 +2480,9 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco -- If we have F a ~ F (F a), we want to swap. swap_for_occurs - | cterHasNoProblem $ checkTyFamEq dflags fun_tc2 fun_args2 + | cterHasNoProblem $ checkTyFamEq fun_tc2 fun_args2 (mkTyConApp fun_tc1 fun_args1) - , cterHasOccursCheck $ checkTyFamEq dflags fun_tc1 fun_args1 + , cterHasOccursCheck $ checkTyFamEq fun_tc1 fun_args1 (mkTyConApp fun_tc2 fun_args2) = True @@ -2448,10 +2526,9 @@ canEqTyVarFunEq :: CtEvidence -- :: lhs ~ (rhs |> mco) -> TcS (StopOrContinue Ct) canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs - ; dflags <- getDynFlags ; if | case is_touchable of { Untouchable -> False; _ -> True } , cterHasNoProblem $ - checkTyVarEq dflags tv1 rhs `cterRemoveProblem` cteTypeFamily + checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) rhs | otherwise @@ -2478,10 +2555,11 @@ canEqCanLHSFinish ev eq_rel swapped lhs rhs -- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) -- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqCanLHS2 - = do { dflags <- getDynFlags - ; new_ev <- rewriteEqEvidence ev swapped - (mkReflRedn role lhs_ty) - (mkReflRedn role rhs) + = do { + -- this performs the swap if necessary + new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn role lhs_ty) + (mkReflRedn role rhs) -- by now, (TyEq:K) is already satisfied ; massert (canEqLHSKind lhs `eqType` tcTypeKind rhs) @@ -2495,9 +2573,7 @@ canEqCanLHSFinish ev eq_rel swapped lhs rhs -- guarantees (TyEq:OC), (TyEq:F) -- Must do the occurs check even on tyvar/tyvar -- equalities, in case have x ~ (y :: ..x...); this is #12593. - -- This next line checks also for coercion holes (TyEq:H); see - -- Note [Equalities with incompatible kinds] - ; let result0 = checkTypeEq dflags lhs rhs `cterRemoveProblem` cteTypeFamily + ; let result0 = checkTypeEq lhs rhs `cterRemoveProblem` cteTypeFamily -- type families are OK here -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite @@ -2507,10 +2583,7 @@ canEqCanLHSFinish ev eq_rel swapped lhs rhs NomEq -> result0 ReprEq -> cterSetOccursCheckSoluble result0 - reason | result `cterHasOnlyProblem` cteHoleBlocker - = HoleBlockerReason (coercionHolesOfType rhs) - | otherwise - = NonCanonicalReason result + reason = NonCanonicalReason result ; if cterHasNoProblem result then do { traceTcS "CEqCan" (ppr lhs $$ ppr rhs) @@ -2531,14 +2604,15 @@ canEqCanLHSFinish ev eq_rel swapped lhs rhs ; traceTcS "new RHS:" (ppr new_rhs) -- This check is Detail (1) in the Note - ; if cterHasOccursCheck (checkTyVarEq dflags lhs_tv new_rhs) + ; if cterHasOccursCheck (checkTyVarEq lhs_tv new_rhs) then do { traceTcS "Note [Type variable cycles] Detail (1)" (ppr new_rhs) ; continueWith (mkIrredCt reason new_ev) } else do { -- See Detail (6) of Note [Type variable cycles] - new_new_ev <- rewriteEqEvidence new_ev NotSwapped + new_new_ev <- rewriteEqEvidence emptyRewriterSet + new_ev NotSwapped (mkReflRedn Nominal lhs_ty) rhs_redn @@ -2584,7 +2658,7 @@ rewriteCastedEquality :: CtEvidence -- :: lhs ~ (rhs |> mco), or (rhs |> mco -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs -- result is independent of SwapFlag rewriteCastedEquality ev eq_rel swapped lhs rhs mco - = rewriteEqEvidence ev swapped lhs_redn rhs_redn + = rewriteEqEvidence emptyRewriterSet ev swapped lhs_redn rhs_redn where lhs_redn = mkGReflRightMRedn role lhs sym_mco rhs_redn = mkGReflLeftMRedn role rhs mco @@ -2603,78 +2677,38 @@ k2 and use this to cast. To wit, from [X] (tv :: k1) ~ (rhs :: k2) -(where [X] is [G], [W], or [D]), we go to +(where [X] is [G] or [W]), we go to - [noDerived X] co :: k2 ~ k1 - [X] (tv :: k1) ~ ((rhs |> co) :: k1) + [X] co :: k2 ~ k1 + [X] (tv :: k1) ~ ((rhs |> co) :: k1) -where - - noDerived G = G - noDerived _ = W - -For reasons described in Wrinkle (2) below, we want the [X] constraint to be "blocked"; -that is, it should be put aside, and not used to rewrite any other constraint, -until the kind-equality on which it depends (namely 'co' above) is solved. -To achieve this -* The [X] constraint is a CIrredCan -* With a cc_reason of HoleBlockerReason bchs -* Where 'bchs' is the set of "blocking coercion holes". The blocking coercion - holes are the free coercion holes of [X]'s type -* When all the blocking coercion holes in the CIrredCan are filled (solved), - we convert [X] to a CNonCanonical and put it in the work list. -All this is described in more detail in Wrinkle (2). +We carry on with the *kind equality*, not the type equality, because +solving the former may unlock the latter. This choice is made in +canEqCanLHSHetero. It is important: otherwise, T13135 loops. Wrinkles: - (1) The noDerived step is because Derived equalities have no evidence. - And yet we absolutely need evidence to be able to proceed here. - Given evidence will use the KindCo coercion; Wanted evidence will - be a coercion hole. Even a Derived hetero equality begets a Wanted - kind equality. - - (2) Though it would be sound to do so, we must not mark the rewritten Wanted - [W] (tv :: k1) ~ ((rhs |> co) :: k1) - as canonical in the inert set. In particular, we must not unify tv. - If we did, the Wanted becomes a Given (effectively), and then can - rewrite other Wanteds. But that's bad: See Note [Wanteds do not rewrite Wanteds] - in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for - tales of destruction. - - So, we have an invariant on CEqCan (TyEq:H) that the RHS does not have - any coercion holes. This is checked in checkTypeEq. Any equalities that - have such an RHS are turned into CIrredCans with a HoleBlockerReason. We also - must be sure to kick out any such CIrredCan constraints that mention coercion holes - when those holes get filled in, so that the unification step can now proceed. - - The kicking out is done in kickOutAfterFillingCoercionHole, and the inerts - are stored in the inert_blocked field of InertCans. - - However, we must be careful: we kick out only when no coercion holes are - left. The holes in the type are stored in the HoleBlockerReason CtIrredReason. - The extra check that there are no more remaining holes avoids - needless work when rewriting evidence (which fills coercion holes) and - aids efficiency. - - Moreover, kicking out when there are remaining unfilled holes can - cause a loop in the solver in this case: - [W] w1 :: (ty1 :: F a) ~ (ty2 :: s) - After canonicalisation, we discover that this equality is heterogeneous. - So we emit - [W] co_abc :: F a ~ s - and preserve the original as - [W] w2 :: (ty1 |> co_abc) ~ ty2 (blocked on co_abc) - Then, co_abc comes becomes the work item. It gets swapped in - canEqCanLHS2 and then back again in canEqTyVarFunEq. We thus get - co_abc := sym co_abd, and then co_abd := sym co_abe, with - [W] co_abe :: F a ~ s - This process has filled in co_abc. Suppose w2 were kicked out. - When it gets processed, - would get this whole chain going again. The solution is to - kick out a blocked constraint only when the result of filling - in the blocking coercion involves no further blocking coercions. - Alternatively, we could be careful not to do unnecessary swaps during - canonicalisation, but that seems hard to do, in general. + (1) When X is W, the new type-level wanted is effectively rewritten by the + kind-level one. We thus include the kind-level wanted in the RewriterSet + for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. + This is done in canEqCanLHSHetero. + + (2) If we have [W] w :: alpha ~ (rhs |> co_hole), should we unify alpha? No. + The problem is that the wanted w is effectively rewritten by another wanted, + and unifying alpha effectively promotes this wanted to a given. Doing so + means we lose track of the rewriter set associated with the wanted. + + On the other hand, w is perfectly suitable for rewriting, because of the + way we carefully track rewriter sets. + + We thus allow w to be a CEqCan, but we prevent unification. See + Note [Unification preconditions] in GHC.Tc.Utils.Unify. + + The only tricky part is that we must later indeed unify if/when the kind-level + wanted gets solved. This is done in kickOutAfterFillingCoercionHole, + which kicks out all equalities whose RHS mentions the filled-in coercion hole. + Note that it looks for type family equalities, too, because of the use of + unifyTest in canEqTyVarFunEq. (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the algorithm detailed here, producing [W] co :: k2 ~ k1, and adding @@ -2694,25 +2728,6 @@ Wrinkles: cast appears opposite a tyvar. This is implemented in the cast case of can_eq_nc'. - (4) Reporting an error for a constraint that is blocked with HoleBlockerReason - is hard: what would we say to users? And we don't - really need to report, because if a constraint is blocked, then - there is unsolved wanted blocking it; that unsolved wanted will - be reported. We thus push such errors to the bottom of the queue - in the error-reporting code; they should never be printed. - - (4a) It would seem possible to do this filtering just based on the - presence of a blocking coercion hole. However, this is no good, - as it suppresses e.g. no-instance-found errors. We thus record - a CtIrredReason in CIrredCan and filter based on this status. - This happened in T14584. An alternative approach is to expressly - look for *equalities* with blocking coercion holes, but actually - recording the blockage in a status field seems nicer. - - (4b) The error message might be printed with -fdefer-type-errors, - so it still must exist. This is the only reason why there is - a message at all. Otherwise, we could simply do nothing. - Historical note: We used to do this via emitting a Derived kind equality and then parking @@ -2772,7 +2787,7 @@ Consider this situation (from indexed-types/should_compile/GivenLoop): or (typecheck/should_compile/T19682b): instance C (a -> b) - *[WD] alpha ~ (Arg alpha -> Res alpha) + *[W] alpha ~ (Arg alpha -> Res alpha) [W] C alpha In order to solve the final Wanted, we must use the starred constraint @@ -2795,17 +2810,15 @@ via new equality constraints. Our situations thus become: or instance C (a -> b) - [WD] alpha ~ (cbv1 -> cbv2) - [WD] Arg alpha ~ cbv1 - [WD] Res alpha ~ cbv2 + [W] alpha ~ (cbv1 -> cbv2) + [W] Arg alpha ~ cbv1 + [W] Res alpha ~ cbv2 [W] C alpha This transformation (creating the new types and emitting new equality constraints) is done in breakTyVarCycle_maybe. -The details depend on whether we're working with a Given or a Derived. -(Note that the Wanteds are really WDs, above. This is because Wanteds -are not used for rewriting.) +The details depend on whether we're working with a Given or a Wanted. Given ----- @@ -2849,19 +2862,19 @@ Note that * The evidence for the new `F a ~ cbv` constraint is Refl, because we know this fill-in is ultimately going to happen. -Wanted/Derived --------------- +Wanted +------ The fresh cycle-breaker variables here must actually be normal, touchable metavariables. That is, they are TauTvs. Nothing at all unusual. Repeating the example from above, we have - *[WD] alpha ~ (Arg alpha -> Res alpha) + *[W] alpha ~ (Arg alpha -> Res alpha) and we turn this into - *[WD] alpha ~ (cbv1 -> cbv2) - [WD] Arg alpha ~ cbv1 - [WD] Res alpha ~ cbv2 + *[W] alpha ~ (cbv1 -> cbv2) + [W] Arg alpha ~ cbv1 + [W] Res alpha ~ cbv2 where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below. @@ -2875,11 +2888,11 @@ here (including further context from our original example, from the top of the Note): instance C (a -> b) - [WD] Arg (cbv1 -> cbv2) ~ cbv1 - [WD] Res (cbv1 -> cbv2) ~ cbv2 + [W] Arg (cbv1 -> cbv2) ~ cbv1 + [W] Res (cbv1 -> cbv2) ~ cbv2 [W] C (cbv1 -> cbv2) -The first two WD constraints reduce to reflexivity and are discarded, +The first two W constraints reduce to reflexivity and are discarded, and the last is easily soluble. [Why TauTvs]: @@ -2897,43 +2910,43 @@ to unify the cbvs: AllEqF '[] '[] = () AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys) - [WD] alpha ~ (Head alpha : Tail alpha) - [WD] AllEqF '[Bool] alpha + [W] alpha ~ (Head alpha : Tail alpha) + [W] AllEqF '[Bool] alpha Without the logic detailed in this Note, we're stuck here, as AllEqF cannot reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach, just as described above. We thus invent cbv1 and cbv2 and unify alpha := cbv1 -> cbv2, yielding (after zonking) - [WD] Head (cbv1 : cbv2) ~ cbv1 - [WD] Tail (cbv1 : cbv2) ~ cbv2 - [WD] AllEqF '[Bool] (cbv1 : cbv2) + [W] Head (cbv1 : cbv2) ~ cbv1 + [W] Tail (cbv1 : cbv2) ~ cbv2 + [W] AllEqF '[Bool] (cbv1 : cbv2) -The first two WD constraints simplify to reflexivity and are discarded. +The first two W constraints simplify to reflexivity and are discarded. But the last reduces: - [WD] Bool ~ cbv1 - [WD] AllEq '[] cbv2 + [W] Bool ~ cbv1 + [W] AllEq '[] cbv2 The first of these is solved by unification: cbv1 := Bool. The second is solved by the instance for AllEq to become - [WD] AllEqF '[] cbv2 - [WD] SameShapeAs '[] cbv2 + [W] AllEqF '[] cbv2 + [W] SameShapeAs '[] cbv2 While the first of these is stuck, the second makes progress, to lead to - [WD] AllEqF '[] cbv2 - [WD] cbv2 ~ '[] + [W] AllEqF '[] cbv2 + [W] cbv2 ~ '[] This second constraint is solved by unification: cbv2 := '[]. We now have - [WD] AllEqF '[] '[] + [W] AllEqF '[] '[] which reduces to - [WD] () + [W] () which is trivially satisfiable. Hooray! @@ -2950,8 +2963,7 @@ We detect this scenario by the following characteristics: - and a nominal equality - and either - a Given flavour (but see also Detail (7) below) - - a Wanted/Derived or just plain Derived flavour, with a touchable metavariable - on the left + - a Wanted flavour, with a touchable metavariable on the left We don't use this trick for representational equalities, as there is no concrete use case where it is helpful (unlike for nominal equalities). @@ -3070,7 +3082,7 @@ Details: We track these equalities by giving them a special CtOrigin, CycleBreakerOrigin. This works for both Givens and WDs, as - we need the logic in the WD case for e.g. typecheck/should_fail/T17139. + we need the logic in the W case for e.g. typecheck/should_fail/T17139. (8) We really want to do this all only when there is a soluble occurs-check failure, not when other problems arise (such as an impredicative @@ -3116,7 +3128,9 @@ andWhenContinue tcs1 tcs2 ContinueWith ct -> tcs2 ct } infixr 0 `andWhenContinue` -- allow chaining with ($) -rewriteEvidence :: CtEvidence -- ^ old evidence +rewriteEvidence :: RewriterSet -- ^ See Note [Wanteds rewrite Wanteds] + -- in GHC.Tc.Types.Constraint + -> CtEvidence -- ^ old evidence -> Reduction -- ^ new predicate + coercion, of type <type of old evidence> ~ new predicate -> TcS (StopOrContinue CtEvidence) -- Returns Just new_ev iff either (i) 'co' is reflexivity @@ -3126,7 +3140,7 @@ rewriteEvidence :: CtEvidence -- ^ old evidence rewriteEvidence old_ev new_pred co Main purpose: create new evidence for new_pred; unless new_pred is cached already -* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev +* Returns a new_ev : new_pred, with same wanted/given flag as old_ev * If old_ev was wanted, create a binding for old_ev, in terms of new_ev * If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev * Returns Nothing if new_ev is already cached @@ -3135,7 +3149,7 @@ Main purpose: create new evidence for new_pred; flavour of same flavor ------------------------------------------------------------------- Wanted Already solved or in inert Nothing - or Derived Not Just new_evidence + Not Just new_evidence Given Already in inert Nothing Not Just new_evidence @@ -3150,37 +3164,33 @@ using new_pred. The rewriter preserves type synonyms, so they should appear in new_pred as well as in old_pred; that is important for good error messages. + +If we are rewriting with Refl, then there are no new rewriters to add to +the rewriter set. We check this with an assertion. -} -rewriteEvidence old_ev@(CtDerived {}) (Reduction _co new_pred) - = -- If derived, don't even look at the coercion. - -- This is very important, DO NOT re-order the equations for - -- rewriteEvidence to put the isTcReflCo test first! - -- Why? Because for *Derived* constraints, c, the coercion, which - -- was produced by rewriting, may contain suspended calls to - -- (ctEvExpr c), which fails for Derived constraints. - -- (Getting this wrong caused #7384.) - continueWith (setCtEvPredType old_ev new_pred) - -rewriteEvidence old_ev (Reduction co new_pred) +rewriteEvidence rewriters old_ev (Reduction co new_pred) | isTcReflCo co -- See Note [Rewriting with Refl] - = continueWith (setCtEvPredType old_ev new_pred) + = assert (isEmptyRewriterSet rewriters) $ + continueWith (setCtEvPredType old_ev new_pred) -rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) (Reduction co new_pred) - = do { new_ev <- newGivenEvVar loc (new_pred, new_tm) +rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) + (Reduction co new_pred) + = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted + do { new_ev <- newGivenEvVar loc (new_pred, new_tm) ; continueWith new_ev } where -- mkEvCast optimises ReflCo new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational (ctEvRole ev) co) -rewriteEvidence ev@(CtWanted { ctev_dest = dest - , ctev_nosh = si - , ctev_loc = loc }) (Reduction co new_pred) - = do { mb_new_ev <- newWanted_SI si loc new_pred - -- The "_SI" variant ensures that we make a new Wanted - -- with the same shadow-info as the existing one (#16735) +rewriteEvidence new_rewriters + ev@(CtWanted { ctev_dest = dest + , ctev_loc = loc + , ctev_rewriters = rewriters }) + (Reduction co new_pred) + = do { mb_new_ev <- newWanted loc rewriters' new_pred ; massert (tcCoercionRole co == ctEvRole ev) ; setWantedEvTerm dest (mkEvCast (getEvExpr mb_new_ev) @@ -3188,9 +3198,14 @@ rewriteEvidence ev@(CtWanted { ctev_dest = dest ; case mb_new_ev of Fresh new_ev -> continueWith new_ev Cached _ -> stopWith ev "Cached wanted" } + where + rewriters' = rewriters S.<> new_rewriters -rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) +rewriteEqEvidence :: RewriterSet -- New rewriters + -- See GHC.Tc.Types.Constraint + -- Note [Wanteds rewrite Wanteds] + -> CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) -- or orhs ~ olhs (swapped) -> SwapFlag -> Reduction -- lhs_co :: olhs ~ nlhs @@ -3211,10 +3226,7 @@ rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swap -- w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co -- -- It's all a form of rewriteEvidence, specialised for equalities -rewriteEqEvidence old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) - | CtDerived {} <- old_ev -- Don't force the evidence for a Derived - = return (setCtEvPredType old_ev new_pred) - +rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) | NotSwapped <- swapped , isTcReflCo lhs_co -- See Note [Rewriting with Refl] , isTcReflCo rhs_co @@ -3226,17 +3238,21 @@ rewriteEqEvidence old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) `mkTcTransCo` rhs_co) ; newGivenEvVar loc' (new_pred, new_tm) } - | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev - = do { (new_ev, hole_co) <- newWantedEq_SI si loc' - (ctEvRole old_ev) nlhs nrhs - -- The "_SI" variant ensures that we make a new Wanted - -- with the same shadow-info as the existing one (#16735) + | CtWanted { ctev_dest = dest + , ctev_rewriters = rewriters } <- old_ev + , let rewriters' = rewriters S.<> new_rewriters + = do { (new_ev, hole_co) <- newWantedEq loc' rewriters' + (ctEvRole old_ev) nlhs nrhs ; let co = maybeTcSymCo swapped $ lhs_co `mkTransCo` hole_co `mkTransCo` mkTcSymCo rhs_co ; setWantedEq dest co - ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) + ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev + , ppr nlhs + , ppr nrhs + , ppr co + , ppr new_rewriters ]) ; return new_ev } #if __GLASGOW_HASKELL__ <= 810 @@ -3259,11 +3275,10 @@ rewriteEqEvidence old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) * * ************************************************************************ -Note [unifyWanted and unifyDerived] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [unifyWanted] +~~~~~~~~~~~~~~~~~~ When decomposing equalities we often create new wanted constraints for (s ~ t). But what if s=t? Then it'd be faster to return Refl right away. -Similar remarks apply for Derived. Rather than making an equality test (which traverses the structure of the type, perhaps fruitlessly), unifyWanted traverses the common structure, and @@ -3272,32 +3287,32 @@ But where it succeeds in finding common structure, it just builds a coercion to reflect it. -} -unifyWanted :: CtLoc -> Role - -> TcType -> TcType -> TcS Coercion +unifyWanted :: RewriterSet -> CtLoc + -> Role -> TcType -> TcType -> TcS Coercion -- Return coercion witnessing the equality of the two types, -- emitting new work equalities where necessary to achieve that -- Very good short-cut when the two types are equal, or nearly so --- See Note [unifyWanted and unifyDerived] +-- See Note [unifyWanted] -- The returned coercion's role matches the input parameter -unifyWanted loc Phantom ty1 ty2 - = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2) +unifyWanted rewriters loc Phantom ty1 ty2 + = do { kind_co <- unifyWanted rewriters loc Nominal (tcTypeKind ty1) (tcTypeKind ty2) ; return (mkPhantomCo kind_co ty1 ty2) } -unifyWanted loc role orig_ty1 orig_ty2 +unifyWanted rewriters loc role orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 where go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) - = do { co_s <- unifyWanted loc role s1 s2 - ; co_t <- unifyWanted loc role t1 t2 - ; co_w <- unifyWanted loc Nominal w1 w2 + = do { co_s <- unifyWanted rewriters loc role s1 s2 + ; co_t <- unifyWanted rewriters loc role t1 t2 + ; co_w <- unifyWanted rewriters loc Nominal w1 w2 ; return (mkFunCo role co_w co_s co_t) } go (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2, tys1 `equalLength` tys2 , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality - = do { cos <- zipWith3M (unifyWanted loc) + = do { cos <- zipWith3M (unifyWanted rewriters loc) (tyConRolesX role tc1) tys1 tys2 ; return (mkTyConAppCo role tc1 cos) } @@ -3320,48 +3335,4 @@ unifyWanted loc role orig_ty1 orig_ty2 bale_out ty1 ty2 | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1) -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2 - -unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS () --- See Note [unifyWanted and unifyDerived] -unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2 - -unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS () --- See Note [unifyWanted and unifyDerived] -unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2 - -unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS () --- Create new Derived and put it in the work list --- Should do nothing if the two types are equal --- See Note [unifyWanted and unifyDerived] -unify_derived _ Phantom _ _ = return () -unify_derived loc role orig_ty1 orig_ty2 - = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - - go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) - = do { unify_derived loc role s1 s2 - ; unify_derived loc role t1 t2 - ; unify_derived loc Nominal w1 w2 } - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, tys1 `equalLength` tys2 - , isInjectiveTyCon tc1 role - = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2 - go ty1@(TyVarTy tv) ty2 - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty1' -> go ty1' ty2 - Nothing -> bale_out ty1 ty2 } - go ty1 ty2@(TyVarTy tv) - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty2' -> go ty1 ty2' - Nothing -> bale_out ty1 ty2 } - go ty1 ty2 = bale_out ty1 ty2 - - bale_out ty1 ty2 - | ty1 `tcEqType` ty2 = return () - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2 + | otherwise = emitNewWantedEq loc rewriters role orig_ty1 orig_ty2 diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs index 53b6097ec7..b5aad268b5 100644 --- a/compiler/GHC/Tc/Solver/InertSet.hs +++ b/compiler/GHC/Tc/Solver/InertSet.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -7,7 +8,7 @@ module GHC.Tc.Solver.InertSet ( -- * The work list WorkList(..), isEmptyWorkList, emptyWorkList, extendWorkListNonEq, extendWorkListCt, - extendWorkListCts, extendWorkListEq, extendWorkListDeriveds, + extendWorkListCts, extendWorkListEq, appendWorkList, extendWorkListImplic, workListSize, selectWorkItem, @@ -25,6 +26,7 @@ module GHC.Tc.Solver.InertSet ( -- * Inert equalities foldTyEqs, delEq, findEq, + partitionInertEqs, partitionFunEqs, -- * Kick-out kickOutRewritableLHS @@ -41,7 +43,6 @@ import GHC.Tc.Utils.TcType import GHC.Types.Var import GHC.Types.Var.Env -import GHC.Core.Class (Class(..)) import GHC.Core.Reduction import GHC.Core.Predicate import GHC.Core.TyCo.FVs @@ -50,12 +51,11 @@ import GHC.Core.TyCon import GHC.Core.Unify import GHC.Data.Bag -import GHC.Utils.Misc ( chkAppend, partitionWith ) +import GHC.Utils.Misc ( partitionWith ) import GHC.Utils.Outputable import GHC.Utils.Panic import Data.List ( partition ) -import Data.List.NonEmpty ( NonEmpty(..) ) {- ************************************************************************ @@ -89,13 +89,13 @@ It's very important to process equalities /first/: * (Avoiding fundep iteration) As #14723 showed, it's possible to get non-termination if we - - Emit the Derived fundep equalities for a class constraint, + - Emit the fundep equalities for a class constraint, generating some fresh unification variables. - That leads to some unification - Which kicks out the class constraint - - Which isn't solved (because there are still some more Derived + - Which isn't solved (because there are still some more equalities in the work-list), but generates yet more fundeps - Solution: prioritise derived equalities over class constraints + Solution: prioritise equalities over class constraints * (Class equalities) We need to prioritise equalities even if they are hidden inside a class constraint; @@ -106,12 +106,6 @@ It's very important to process equalities /first/: E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become homo-kinded when kicked out, and hence we want to prioritise it. -* (Derived equalities) Originally we tried to postpone processing - Derived equalities, in the hope that we might never need to deal - with them at all; but in fact we must process Derived equalities - eagerly, partly for the (Efficiency) reason, and more importantly - for (Avoiding fundep iteration). - Note [Prioritise class equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We prioritise equalities in the solver (see selectWorkItem). But class @@ -144,7 +138,7 @@ See GHC.Tc.Solver.Monad.deferTcSForAllEq -- See Note [WorkList priorities] data WorkList = WL { wl_eqs :: [Ct] -- CEqCan, CDictCan, CIrredCan - -- Given, Wanted, and Derived + -- Given and Wanted -- Contains both equality constraints and their -- class-level variants (a~b) and (a~~b); -- See Note [Prioritise equalities] @@ -176,10 +170,6 @@ extendWorkListNonEq :: Ct -> WorkList -> WorkList -- Extension by non equality extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } -extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList -extendWorkListDeriveds evs wl - = extendWorkListCts (map mkNonCanonical evs) wl - extendWorkListImplic :: Implication -> WorkList -> WorkList extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl } @@ -236,7 +226,7 @@ instance Outputable WorkList where data InertSet = IS { inert_cans :: InertCans - -- Canonical Given, Wanted, Derived + -- Canonical Given, Wanted -- Sometimes called "the inert set" , inert_cycle_breakers :: [(TcTyVar, TcType)] @@ -278,8 +268,7 @@ emptyInertCans , inert_safehask = emptyDictMap , inert_funeqs = emptyFunEqs , inert_insts = [] - , inert_irreds = emptyCts - , inert_blocked = emptyCts } + , inert_irreds = emptyCts } emptyInert :: InertSet emptyInert @@ -618,7 +607,7 @@ that the right variable is on the left of the equality when both are tyvars. You might wonder whether the skolem really needs to be bound "in the -very same implication" as the equuality constraint. +very same implication" as the equality constraint. Consider this (c.f. #15009): data S a where @@ -733,7 +722,7 @@ yet, we have a hard time noticing an occurs-check problem when building S, as the two equalities cannot rewrite one another. R2 actually restricts our ability to accept user-written programs. See -Note [Deriveds do rewrite Deriveds] in GHC.Tc.Types.Constraint for an example. +Note [Avoiding rewriting cycles] in GHC.Tc.Types.Constraint for an example. Note [Rewritable] ~~~~~~~~~~~~~~~~~ @@ -859,13 +848,6 @@ The idea is that us to kick out an inert wanted that mentions a, because of (K2a). This is a common case, hence good not to kick out. See also (K2a) below. -* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing - Proof: using Definition [Can-rewrite relation], fw can't rewrite anything - and so K0 holds. Intuitively, since fw can't rewrite anything (Lemma (L0)), - adding it cannot cause any loops - This is a common case, because Wanteds cannot rewrite Wanteds. - It's used to avoid even looking for constraint to kick out. - * Lemma (L1): The conditions of the Main Theorem imply that there is no (lhs -fs-> t) in S, s.t. (fs >= fw). Proof. Suppose the contrary (fs >= fw). Then because of (T1), @@ -937,10 +919,10 @@ Why we cannot drop the (fs >= fw) condition: can cause a loop. Example: Work: [G] b ~ a - Inert: [D] a ~ b + Inert: [W] a ~ b - (where G >= G, G >= D, and D >= D) - If we don't kick out the inert, then we get a loop on e.g. [D] a ~ Int. + (where G >= G, G >= W, and W >= W) + If we don't kick out the inert, then we get a loop on e.g. [W] a ~ Int. * Note that the above example is different if the inert is a Given G, because (T1) won't hold. @@ -1051,7 +1033,7 @@ Note [Flavours with roles] The system described in Note [inert_eqs: the inert equalities] discusses an abstract set of flavours. In GHC, flavours have two components: the flavour proper, -taken from {Wanted, Derived, Given} and the equality relation (often called +taken from {Wanted, Given} and the equality relation (often called role), taken from {NomEq, ReprEq}. When substituting w.r.t. the inert set, as described in Note [inert_eqs: the inert equalities], @@ -1080,7 +1062,7 @@ data InertCans -- See Note [Detailed InertCans Invariants] for more -- All CEqCans with a TyFamLHS; index is the whole family head type. -- LHS is fully rewritten (modulo eqCanRewrite constraints) -- wrt inert_eqs - -- Can include all flavours, [G], [W], [WD], [D] + -- Can include both [G] and [W] , inert_dicts :: DictMap Ct -- Dictionaries only @@ -1103,14 +1085,6 @@ data InertCans -- See Note [Detailed InertCans Invariants] for more -- and which don't interact with others (e.g. (c a)) -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) - , inert_blocked :: Cts - -- Equality predicates blocked on a coercion hole. - -- Each Ct is a CIrredCan with cc_reason = HoleBlockerReason - -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical - -- wrinkle (2) - -- These are stored separately from inert_irreds because - -- they get kicked out for different reasons - , inert_given_eq_lvl :: TcLevel -- The TcLevel of the innermost implication that has a Given -- equality of the sort that make a unification variable untouchable @@ -1133,7 +1107,6 @@ instance Outputable InertCans where , inert_dicts = dicts , inert_safehask = safehask , inert_irreds = irreds - , inert_blocked = blocked , inert_given_eq_lvl = ge_lvl , inert_given_eqs = given_eqs , inert_insts = insts }) @@ -1150,15 +1123,13 @@ instance Outputable InertCans where text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask) , ppUnless (isEmptyCts irreds) $ text "Irreds =" <+> pprCts irreds - , ppUnless (isEmptyCts blocked) $ - text "Blocked =" <+> pprCts blocked , ppUnless (null insts) $ text "Given instances =" <+> vcat (map ppr insts) , text "Innermost given equalities =" <+> ppr ge_lvl , text "Given eqs at this level =" <+> ppr given_eqs ] where - folder (EqualCtList eqs) rest = nonEmptyToBag eqs `andCts` rest + folder eqs rest = listToBag eqs `andCts` rest {- ********************************************************************* * * @@ -1168,7 +1139,7 @@ instance Outputable InertCans where addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs addTyEq old_eqs tv ct - = extendDVarEnv_C add_eq old_eqs tv (unitEqualCtList ct) + = extendDVarEnv_C add_eq old_eqs tv [ct] where add_eq old_eqs _ = addToEqualCtList ct old_eqs @@ -1178,15 +1149,14 @@ addCanFunEq old_eqs fun_tc fun_args ct = alterTcApp old_eqs fun_tc fun_args upd where upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list - upd Nothing = Just $ unitEqualCtList ct + upd Nothing = Just [ct] foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b foldTyEqs k eqs z - = foldDVarEnv (\(EqualCtList cts) z -> foldr k z cts) z eqs + = foldDVarEnv (\cts z -> foldr k z cts) z eqs findTyEqs :: InertCans -> TyVar -> [Ct] -findTyEqs icans tv = maybe [] id (fmap @Maybe equalCtListToList $ - lookupDVarEnv (inert_eqs icans) tv) +findTyEqs icans tv = concat @Maybe (lookupDVarEnv (inert_eqs icans) tv) delEq :: InertCans -> CanEqLHS -> TcType -> InertCans delEq ic lhs rhs = case lhs of @@ -1206,8 +1176,52 @@ delEq ic lhs rhs = case lhs of findEq :: InertCans -> CanEqLHS -> [Ct] findEq icans (TyVarLHS tv) = findTyEqs icans tv findEq icans (TyFamLHS fun_tc fun_args) - = maybe [] id (fmap @Maybe equalCtListToList $ - findFunEq (inert_funeqs icans) fun_tc fun_args) + = concat @Maybe (findFunEq (inert_funeqs icans) fun_tc fun_args) + +{-# INLINE partition_eqs_container #-} +partition_eqs_container + :: forall container + . container -- empty container + -> (forall b. (EqualCtList -> b -> b) -> b -> container -> b) -- folder + -> (container -> CanEqLHS -> EqualCtList -> container) -- extender + -> (Ct -> Bool) + -> container + -> ([Ct], container) +partition_eqs_container empty_container fold_container extend_container pred orig_inerts + = fold_container folder ([], empty_container) orig_inerts + where + folder :: EqualCtList -> ([Ct], container) -> ([Ct], container) + folder eqs (acc_true, acc_false) + = (eqs_true ++ acc_true, acc_false') + where + (eqs_true, eqs_false) = partition pred eqs + + acc_false' + | CEqCan { cc_lhs = lhs } : _ <- eqs_false + = extend_container acc_false lhs eqs_false + | otherwise + = acc_false + +partitionInertEqs :: (Ct -> Bool) -- Ct will always be a CEqCan with a TyVarLHS + -> InertEqs + -> ([Ct], InertEqs) +partitionInertEqs = partition_eqs_container emptyDVarEnv foldDVarEnv extendInertEqs + +-- precondition: CanEqLHS is a TyVarLHS +extendInertEqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs +extendInertEqs eqs (TyVarLHS tv) new_eqs = extendDVarEnv eqs tv new_eqs +extendInertEqs _ other _ = pprPanic "extendInertEqs" (ppr other) + +partitionFunEqs :: (Ct -> Bool) -- Ct will always be a CEqCan with a TyFamLHS + -> FunEqMap EqualCtList + -> ([Ct], FunEqMap EqualCtList) +partitionFunEqs + = partition_eqs_container emptyFunEqs (\ f z eqs -> foldFunEqs f eqs z) extendFunEqs + +-- precondition: CanEqLHS is a TyFamLHS +extendFunEqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList -> FunEqMap EqualCtList +extendFunEqs eqs (TyFamLHS tf args) new_eqs = insertTcApp eqs tf args new_eqs +extendFunEqs _ other _ = pprPanic "extendFunEqs" (ppr other) {- ********************************************************************* * * @@ -1225,18 +1239,13 @@ addInertItem tc_lvl TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys item } TyVarLHS tv -> ics { inert_eqs = addTyEq eqs tv item } -addInertItem tc_lvl ics@(IC { inert_blocked = blocked }) - item@(CIrredCan { cc_reason = HoleBlockerReason {}}) - = updateGivenEqs tc_lvl item $ -- this item is always an equality - ics { inert_blocked = blocked `snocBag` item } - addInertItem tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {}) = updateGivenEqs tc_lvl item $ -- An Irred might turn out to be an -- equality, so we play safe ics { inert_irreds = irreds `snocBag` item } addInertItem _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_dicts = addDictCt (inert_dicts ics) (classTyCon cls) tys item } + = ics { inert_dicts = addDict (inert_dicts ics) cls tys item } addInertItem _ ics@( IC { inert_irreds = irreds }) item@(CSpecialCan {}) = ics { inert_irreds = irreds `snocBag` item } @@ -1284,14 +1293,6 @@ kickOutRewritableLHS new_fr new_lhs , inert_funeqs = funeqmap , inert_irreds = irreds , inert_insts = old_insts }) - | not (new_fr `eqMayRewriteFR` new_fr) - = (emptyWorkList, ics) - -- If new_fr can't rewrite itself, it can't rewrite - -- anything else, so no need to kick out anything. - -- (This is a common case: wanteds can't rewrite wanteds) - -- Lemma (L2) in Note [Extending the inert equalities] - - | otherwise = (kicked_out, inert_cans_in) where -- inert_safehask stays unchanged; is that right? @@ -1313,12 +1314,10 @@ kickOutRewritableLHS new_fr new_lhs ((dicts_out `andCts` irs_out) `extendCtsList` insts_out) - (tv_eqs_out, tv_eqs_in) = foldDVarEnv (kick_out_eqs extend_tv_eqs) - ([], emptyDVarEnv) tv_eqs - (feqs_out, feqs_in) = foldFunEqs (kick_out_eqs extend_fun_eqs) - funeqmap ([], emptyFunEqs) - (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap - (irs_out, irs_in) = partitionBag kick_out_ct irreds + (tv_eqs_out, tv_eqs_in) = partitionInertEqs kick_out_eq tv_eqs + (feqs_out, feqs_in) = partitionFunEqs kick_out_eq funeqmap + (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap + (irs_out, irs_in) = partitionBag kick_out_ct irreds -- Kick out even insolubles: See Note [Rewrite insolubles] -- Of course we must kick out irreducibles like (c a), in case -- we can rewrite 'c' to something more useful @@ -1343,8 +1342,7 @@ kickOutRewritableLHS new_fr new_lhs fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool fr_tv_can_rewrite_ty new_tv role ty - = anyRewritableTyVar True role can_rewrite ty - -- True: ignore casts and coercions + = anyRewritableTyVar role can_rewrite ty where can_rewrite :: EqRel -> TyVar -> Bool can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv @@ -1367,7 +1365,7 @@ kickOutRewritableLHS new_fr new_lhs TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args fr_may_rewrite :: CtFlavourRole -> Bool - fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs + fr_may_rewrite fs = new_fr `eqCanRewriteFR` fs -- Can the new item rewrite the inert item? {-# INLINE kick_out_ct #-} -- perform case on new_lhs here only once @@ -1383,28 +1381,8 @@ kickOutRewritableLHS new_fr new_lhs fr_may_rewrite fs && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct) - extend_tv_eqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs - extend_tv_eqs eqs (TyVarLHS tv) cts = extendDVarEnv eqs tv cts - extend_tv_eqs eqs other _cts = pprPanic "extend_tv_eqs" (ppr eqs $$ ppr other) - - extend_fun_eqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList - -> FunEqMap EqualCtList - extend_fun_eqs eqs (TyFamLHS fam_tc fam_args) cts - = insertTcApp eqs fam_tc fam_args cts - extend_fun_eqs eqs other _cts = pprPanic "extend_fun_eqs" (ppr eqs $$ ppr other) - - kick_out_eqs :: (container -> CanEqLHS -> EqualCtList -> container) - -> EqualCtList -> ([Ct], container) - -> ([Ct], container) - kick_out_eqs extend eqs (acc_out, acc_in) - = (eqs_out `chkAppend` acc_out, case listToEqualCtList eqs_in of - Nothing -> acc_in - Just eqs_in_ecl@(EqualCtList (eq1 :| _)) - -> extend acc_in (cc_lhs eq1) eqs_in_ecl) - where - (eqs_out, eqs_in) = partition kick_out_eq (equalCtListToList eqs) - -- Implements criteria K1-K3 in Note [Extending the inert equalities] + kick_out_eq :: Ct -> Bool kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty , cc_ev = ev, cc_eq_rel = eq_rel }) | not (fr_may_rewrite fs) @@ -1413,7 +1391,7 @@ kickOutRewritableLHS new_fr new_lhs -- Below here (fr_may_rewrite fs) is True | TyVarLHS _ <- lhs - , fs `eqMayRewriteFR` new_fr + , fs `eqCanRewriteFR` new_fr = False -- (K4) Keep it in the inert set if the LHS is a tyvar and -- it can rewrite the work item. See Note [K4] @@ -1429,7 +1407,7 @@ kickOutRewritableLHS new_fr new_lhs where fs = (ctEvFlavour ev, eq_rel) kick_out_for_inertness - = (fs `eqMayRewriteFR` fs) -- (K2a) + = (fs `eqCanRewriteFR` fs) -- (K2a) && fr_can_rewrite_ty eq_rel rhs_ty -- (K2b) kick_out_for_completeness -- (K3) and Note [K3: completeness of solving] @@ -1437,7 +1415,7 @@ kickOutRewritableLHS new_fr new_lhs NomEq -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a) ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty -- (K3b) - kick_out_eq ct = pprPanic "keep_eq" (ppr ct) + kick_out_eq ct = pprPanic "kick_out_eq" (ppr ct) is_can_eq_lhs_head (TyVarLHS tv) = go where @@ -1480,9 +1458,6 @@ new equality, to maintain the inert-set invariants. kick out constraints that mention type variables whose kinds contain this LHS! - - A Derived equality can kick out [D] constraints in inert_eqs, - inert_dicts, inert_irreds etc. - - We don't kick out constraints from inert_solved_dicts, and inert_solved_funeqs optimistically. But when we lookup we have to take the substitution into account diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index 36e9afae98..b753a3c902 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -4,7 +4,7 @@ module GHC.Tc.Solver.Interact ( solveSimpleGivens, -- Solves [Ct] - solveSimpleWanteds, -- Solves Cts + solveSimpleWanteds -- Solves Cts ) where import GHC.Prelude @@ -31,7 +31,6 @@ import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) import GHC.Tc.Types.Evidence import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Tc.Types import GHC.Tc.Types.Constraint @@ -45,17 +44,18 @@ import GHC.Data.Bag import GHC.Utils.Monad ( concatMapM, foldlM ) import GHC.Core -import Data.List( partition, deleteFirstsBy ) +import Data.List( deleteFirstsBy ) +import Data.Function ( on ) import GHC.Types.SrcLoc import GHC.Types.Var.Env +import qualified Data.Semigroup as S import Control.Monad import GHC.Data.Pair (Pair(..)) import GHC.Types.Unique( hasKey ) import GHC.Driver.Session import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt -import Data.List.NonEmpty ( NonEmpty(..) ) import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe @@ -187,9 +187,9 @@ runTcPluginsGiven ; if null solvers then return [] else do { givens <- getInertGivens ; if null givens then return [] else - do { p <- runTcPluginSolvers solvers (givens,[],[]) - ; let (solved_givens, _, _) = pluginSolvedCts p - insols = pluginBadCts p + do { p <- runTcPluginSolvers solvers (givens,[]) + ; let (solved_givens, _) = pluginSolvedCts p + insols = pluginBadCts p ; updInertCans (removeInertCts solved_givens) ; updInertIrreds (\irreds -> extendCtsList irreds insols) ; return (pluginNewCts p) } } } @@ -208,22 +208,20 @@ runTcPluginsWanted wc@(WC { wc_simple = simples1 }) ; if null solvers then return (False, wc) else do { given <- getInertGivens - ; simples1 <- zonkSimples simples1 -- Plugin requires zonked inputs - ; let (wanted, derived) = partition isWantedCt (bagToList simples1) - ; p <- runTcPluginSolvers solvers (given, derived, wanted) - ; let (_, _, solved_wanted) = pluginSolvedCts p - (_, unsolved_derived, unsolved_wanted) = pluginInputCts p + ; wanted <- zonkSimples simples1 -- Plugin requires zonked inputs + ; p <- runTcPluginSolvers solvers (given, bagToList wanted) + ; let (_, solved_wanted) = pluginSolvedCts p + (_, unsolved_wanted) = pluginInputCts p new_wanted = pluginNewCts p insols = pluginBadCts p -- SLPJ: I'm deeply suspicious of this --- ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds) +-- ; updInertCans (removeInertCts $ solved_givens) ; mapM_ setEv solved_wanted ; return ( notNull (pluginNewCts p) , wc { wc_simple = listToBag new_wanted `andCts` listToBag unsolved_wanted `andCts` - listToBag unsolved_derived `andCts` listToBag insols } ) } } where setEv :: (EvTerm,Ct) -> TcS () @@ -231,11 +229,11 @@ runTcPluginsWanted wc@(WC { wc_simple = simples1 }) CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" --- | A triple of (given, derived, wanted) constraints to pass to plugins -type SplitCts = ([Ct], [Ct], [Ct]) +-- | A pair of (given, wanted) constraints to pass to plugins +type SplitCts = ([Ct], [Ct]) --- | A solved triple of constraints, with evidence for wanteds -type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)]) +-- | A solved pair of constraints, with evidence for wanteds +type SolvedCts = ([Ct], [(EvTerm,Ct)]) -- | Represents collections of constraints generated by typechecker -- plugins @@ -255,7 +253,7 @@ getTcPluginSolvers :: TcS [TcPluginSolver] getTcPluginSolvers = do { tcg_env <- getGblEnv; return (tcg_tc_plugin_solvers tcg_env) } --- | Starting from a triple of (given, derived, wanted) constraints, +-- | Starting from a pair of (given, wanted) constraints, -- invoke each of the typechecker constraint-solving plugins in turn and return -- -- * the remaining unmodified constraints, @@ -274,7 +272,7 @@ runTcPluginSolvers solvers all_cts where do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress do_plugin p solver = do - result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p)) + result <- runTcPluginTcS (uncurry solver (pluginInputCts p)) return $ progress p result progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress @@ -291,11 +289,11 @@ runTcPluginSolvers solvers all_cts , pluginBadCts = bad_cts ++ pluginBadCts p } - initialProgress = TcPluginProgress all_cts ([], [], []) [] [] + initialProgress = TcPluginProgress all_cts ([], []) [] [] discard :: [Ct] -> SplitCts -> SplitCts - discard cts (xs, ys, zs) = - (xs `without` cts, ys `without` cts, zs `without` cts) + discard cts (xs, ys) = + (xs `without` cts, ys `without` cts) without :: [Ct] -> [Ct] -> [Ct] without = deleteFirstsBy eqCt @@ -308,10 +306,9 @@ runTcPluginSolvers solvers all_cts add xs scs = foldl' addOne scs xs addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts - addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of - CtGiven {} -> (ct:givens, deriveds, wanteds) - CtDerived{} -> (givens, ct:deriveds, wanteds) - CtWanted {} -> (givens, deriveds, (ev,ct):wanteds) + addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of + CtGiven {} -> (ct:givens, wanteds) + CtWanted {} -> (givens, (ev,ct):wanteds) type WorkItem = Ct @@ -414,7 +411,7 @@ It *is* true that [Solver Invariant] then the inert item must Given or, equivalently, If the work-item is Given, - and the inert item is Wanted/Derived + and the inert item is Wanted then there is no reaction -} @@ -441,30 +438,10 @@ data InteractResult -- (if the latter is Wanted; just discard it if not) | KeepWork -- Keep the work item, and solve the inert item from it - | KeepBoth -- See Note [KeepBoth] - instance Outputable InteractResult where - ppr KeepBoth = text "keep both" ppr KeepInert = text "keep inert" ppr KeepWork = text "keep work-item" -{- Note [KeepBoth] -~~~~~~~~~~~~~~~~~~ -Consider - Inert: [WD] C ty1 ty2 - Work item: [D] C ty1 ty2 - -Here we can simply drop the work item. But what about - Inert: [W] C ty1 ty2 - Work item: [D] C ty1 ty2 - -Here we /cannot/ drop the work item, becuase we lose the [D] form, and -that is essential for e.g. fundeps, see isImprovable. We could zap -the inert item to [WD], but the simplest thing to do is simply to keep -both. (They probably started as [WD] and got split; this is relatively -rare and it doesn't seem worth trying to put them back together again.) --} - solveOneFromTheOther :: CtEvidence -- Inert (Dict or Irred) -> CtEvidence -- WorkItem (same predicate as inert) -> TcS InteractResult @@ -477,37 +454,22 @@ solveOneFromTheOther :: CtEvidence -- Inert (Dict or Irred) -- two wanteds into one by solving one from the other solveOneFromTheOther ev_i ev_w - | CtDerived {} <- ev_w -- Work item is Derived - = case ev_i of - CtWanted { ctev_nosh = WOnly } -> return KeepBoth - _ -> return KeepInert - - | CtDerived {} <- ev_i -- Inert item is Derived - = case ev_w of - CtWanted { ctev_nosh = WOnly } -> return KeepBoth - _ -> return KeepWork - -- The ev_w is inert wrt earlier inert-set items, - -- so it's safe to continue on from this point - - -- After this, neither ev_i or ev_w are Derived | CtWanted { ctev_loc = loc_w } <- ev_w , prohibitedSuperClassSolve loc_i loc_w = -- inert must be Given do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) ; return KeepWork } - | CtWanted { ctev_nosh = nosh_w } <- ev_w + | CtWanted {} <- ev_w -- Inert is Given or Wanted - = case ev_i of - CtWanted { ctev_nosh = WOnly } - | WDeriv <- nosh_w -> return KeepWork - _ -> return KeepInert - -- Consider work item [WD] C ty1 ty2 - -- inert item [W] C ty1 ty2 - -- Then we must keep the work item. But if the - -- work item was [W] C ty1 ty2 - -- then we are free to discard the work item in favour of inert - -- Remember, no Deriveds at this point + = return $ case ev_i of + CtWanted {} -> choose_better_loc + -- both are Wanted; choice of which to keep is + -- arbitrary. So we look at the context to choose + -- which would make a better error message + + _ -> KeepInert + -- work is Wanted; inert is Given: easy choice. -- From here on the work-item is Given @@ -536,6 +498,27 @@ solveOneFromTheOther ev_i ev_w lvl_i = ctLocLevel loc_i lvl_w = ctLocLevel loc_w + choose_better_loc + -- if only one is a WantedSuperclassOrigin (arising from expanding + -- a Wanted class constraint), keep the other: wanted superclasses + -- may be unexpected by users + | is_wanted_superclass_loc loc_i + , not (is_wanted_superclass_loc loc_w) = KeepWork + + | not (is_wanted_superclass_loc loc_i) + , is_wanted_superclass_loc loc_w = KeepInert + + -- otherwise, just choose the lower span + -- reason: if we have something like (abs 1) (where the + -- Num constraint cannot be satisfied), it's better to + -- get an error about abs than about 1. + -- This test might become more elaborate if we see an + -- opportunity to improve the error messages + | ((<) `on` ctLocSpan) loc_i loc_w = KeepInert + | otherwise = KeepWork + + is_wanted_superclass_loc = isWantedSuperclassOrigin . ctLocOrigin + different_level_strategy -- Both Given | isIPLikePred pred = if lvl_w > lvl_i then KeepWork else KeepInert | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork @@ -666,8 +649,6 @@ interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_reason = reason }) -- For insolubles, don't allow the constraint to be dropped -- which can happen with solveOneFromTheOther, so that -- we get distinct error messages with -fdefer-type-errors - -- See Note [Do not add duplicate derived insolubles] - , not (isDroppableCt workItem) = continueWith workItem | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w @@ -677,7 +658,6 @@ interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_reason = reason }) = do { what_next <- solveOneFromTheOther ev_i ev_w ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i) ; case what_next of - KeepBoth -> continueWith workItem KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i) ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) } KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w) @@ -736,56 +716,6 @@ irreducible constraints to look for an identical one. When doing this lookup, findMatchingIrreds spots the equality case, and matches either way around. It has to return a swap-flag so we can generate evidence that is the right way round too. - -Note [Do not add duplicate derived insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we *must* add an insoluble (Int ~ Bool) even if there is -one such there already, because they may come from distinct call -sites. Not only do we want an error message for each, but with --fdefer-type-errors we must generate evidence for each. But for -*derived* insolubles, we only want to report each one once. Why? - -(a) A constraint (C r s t) where r -> s, say, may generate the same fundep - equality many times, as the original constraint is successively rewritten. - -(b) Ditto the successive iterations of the main solver itself, as it traverses - the constraint tree. See example below. - -Also for *given* insolubles we may get repeated errors, as we -repeatedly traverse the constraint tree. These are relatively rare -anyway, so removing duplicates seems ok. (Alternatively we could take -the SrcLoc into account.) - -Note that the test does not need to be particularly efficient because -it is only used if the program has a type error anyway. - -Example of (b): assume a top-level class and instance declaration: - - class D a b | a -> b - instance D [a] [a] - -Assume we have started with an implication: - - forall c. Eq c => { wc_simple = [W] D [c] c } - -which we have simplified to, with a Derived constraing coming from -D's functional dependency: - - forall c. Eq c => { wc_simple = [W] D [c] c [W] - [D] (c ~ [c]) } - -When iterating the solver, we might try to re-solve this -implication. If we do not do a dropDerivedWC, then we will end up -trying to solve the following constraints the second time: - - [W] (D [c] c) - [D] (c ~ [c]) - -which will result in two Deriveds to end up in the insoluble set: - - wc_simple = [W] D [c] c - [D] (c ~ [c]) - [D] (c ~ [c]) -} {- @@ -1000,6 +930,68 @@ Passing along the solved_dicts important for two reasons: and to solve G2 we may need H. If we don't spot this sharing we may solve H twice; and if this pattern repeats we may get exponentially bad behaviour. + +Note [No Given/Given fundeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not create constraints from: +* Given/Given interactions via functional dependencies or type family + injectivity annotations. +* Given/instance fundep interactions via functional dependencies or + type family injectivity annotations. + +In this Note, all these interactions are called just "fundeps". + +We ingore such fundeps for several reasons: + +1. These fundeps will never serve a purpose in accepting more + programs: Given constraints do not contain metavariables that could + be unified via exploring fundeps. They *could* be useful in + discovering inaccessible code. However, the constraints will be + Wanteds, and as such will cause errors (not just warnings) if they + go unsolved. Maybe there is a clever way to get the right + inaccessible code warnings, but the path forward is far from + clear. #12466 has further commentary. + +2. Furthermore, here is a case where a Given/instance interaction is actively + harmful (from dependent/should_compile/RaeJobTalk): + + type family a == b :: Bool + type family Not a = r | r -> a where + Not False = True + Not True = False + + [G] Not (a == b) ~ True + + Reacting this Given with the equations for Not produces + + [W] a == b ~ False + + This is indeed a true consequence, and would make sense as a fresh Given. + But we don't have a way to produce evidence for fundeps, as a Wanted it + is /harmful/: we can't prove it, and so we'll report an error and reject + the program. (Previously fundeps gave rise to Deriveds, which + carried no evidence, so it didn't matter that they could not be proved.) + +3. #20922 showed a subtle different problem with Given/instance fundeps. + type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where + ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss + ... + + tclevel = 4 + [G] ZipCons is1 iss ~ (i : is2) : jss + + (The tclevel=4 means that this Given is at level 4.) The fundep tells us that + 'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification + variable; we don't know what type it stands for. So we would emit + [W] iss ~ is2 : beta + + Again we can't prove that equality; and worse we'll rewrite iss to + (is2:beta) in deeply nested contraints inside this implication, + where beta is untouchable (under other equality constraints), leading + to other insoluble constraints. + +The bottom line: since we have no evidence for them, we should ignore Given/Given +and Given/instance fundeps entirely. -} interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) @@ -1020,7 +1012,6 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs what_next <- solveOneFromTheOther ev_i ev_w ; traceTcS "lookupInertDict" (ppr what_next) ; case what_next of - KeepBoth -> continueWith workItem KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i) ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w) @@ -1109,7 +1100,7 @@ shortCutSolver dflags ev_w ev_i ; lift $ checkReductionDepth loc' pred - ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds + ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds -- Emit work for subgoals but use our local cache -- so we can solve recursive dictionaries. @@ -1128,50 +1119,45 @@ shortCutSolver dflags ev_w ev_i -- Use a local cache of solved dicts while emitting EvVars for new work -- We bail out of the entire computation if we need to emit an EvVar for -- a subgoal that isn't a ClassPred. - new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew - new_wanted_cached loc cache pty + new_wanted_cached :: CtEvidence -> CtLoc + -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew + new_wanted_cached ev_w loc cache pty | ClassPred cls tys <- classifyPredType pty = lift $ case findDict cache loc_w cls tys of Just ctev -> return $ Cached (ctEvExpr ctev) - Nothing -> Fresh <$> newWantedNC loc pty + Nothing -> Fresh <$> newWantedNC loc (ctEvRewriters ev_w) pty | otherwise = mzero addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS () --- Add derived constraints from type-class functional dependencies. +-- Add wanted constraints from type-class functional dependencies. addFunDepWork inerts work_ev cls - | isImprovable work_ev = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls) -- No need to check flavour; fundeps work between -- any pair of constraints, regardless of flavour -- Importantly we don't throw workitem back in the -- worklist because this can cause loops (see #5236) - | otherwise - = return () where work_pred = ctEvPred work_ev work_loc = ctEvLoc work_ev add_fds inert_ct - | isImprovable inert_ev = do { traceTcS "addFunDepWork" (vcat [ ppr work_ev , pprCtLoc work_loc, ppr (isGivenLoc work_loc) , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc) - , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ; + , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) - emitFunDepDeriveds $ - improveFromAnother derived_loc inert_pred work_pred + ; unless (isGiven work_ev && isGiven inert_ev) $ + emitFunDepWanteds (ctEvRewriters work_ev) $ + improveFromAnother (derived_loc, inert_rewriters) inert_pred work_pred -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok - -- NB: We do create FDs for given to report insoluble equations that arise - -- from pairs of Givens, and also because of floating when we approximate - -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs + -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps] } - | otherwise - = return () where inert_ev = ctEvidence inert_ct inert_pred = ctEvPred inert_ev inert_loc = ctEvLoc inert_ev + inert_rewriters = ctRewriters inert_ct derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` ctl_depth inert_loc , ctl_origin = FunDepOrigin1 work_pred @@ -1281,24 +1267,22 @@ I can think of two ways to fix this: improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType -> TcS () --- Generate derived improvement equalities, by comparing +-- Generate improvement equalities, by comparing -- the current work item with inert CFunEqs --- E.g. x + y ~ z, x + y' ~ z => [D] y ~ y' +-- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y' -- -- See Note [FunDep and implicit parameter reactions] --- Precondition: isImprovable work_ev improveLocalFunEqs work_ev inerts fam_tc args rhs - = assert (isImprovable work_ev) $ - unless (null improvement_eqns) $ + = unless (null improvement_eqns) $ do { traceTcS "interactFunEq improvements: " $ vcat [ text "Eqns:" <+> ppr improvement_eqns , text "Candidates:" <+> ppr funeqs_for_tc , text "Inert eqs:" <+> ppr (inert_eqs inerts) ] - ; emitFunDepDeriveds improvement_eqns } + ; emitFunDepWanteds (ctEvRewriters work_ev) improvement_eqns } where funeqs = inert_funeqs inerts - funeqs_for_tc = [ funeq_ct | EqualCtList (funeq_ct :| _) - <- findFunEqsByTyCon funeqs fam_tc + funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc + , funeq_ct <- equal_ct_list , NomEq == ctEqRel funeq_ct ] -- representational equalities don't interact -- with type family dependencies @@ -1307,7 +1291,7 @@ improveLocalFunEqs work_ev inerts fam_tc args rhs fam_inj_info = tyConInjectivityInfo fam_tc -------------------- - improvement_eqns :: [FunDepEqn CtLoc] + improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)] improvement_eqns | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc = -- Try built-in families, notably for arithmethic @@ -1322,15 +1306,19 @@ improveLocalFunEqs work_ev inerts fam_tc args rhs -------------------- do_one_built_in ops rhs (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_ev = inert_ev }) + | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps] = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs) + | otherwise + = [] + do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -------------------- -- See Note [Type inference for type families with injectivity] do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args , cc_rhs = irhs, cc_ev = inert_ev }) - | isImprovable inert_ev + | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps] , rhs `tcEqType` irhs = mk_fd_eqns inert_ev $ [ Pair arg iarg | (arg, iarg, True) <- zip3 args inert_args inj_args ] @@ -1340,17 +1328,25 @@ improveLocalFunEqs work_ev inerts fam_tc args rhs do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) -------------------- - mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc] + mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)] mk_fd_eqns inert_ev eqns | null eqns = [] | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns , fd_pred1 = work_pred - , fd_pred2 = ctEvPred inert_ev - , fd_loc = loc } ] + , fd_pred2 = inert_pred + , fd_loc = (loc, inert_rewriters) } ] where - inert_loc = ctEvLoc inert_ev - loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` - ctl_depth work_loc } + initial_loc -- start with the location of the Wanted involved + | isGiven work_ev = inert_loc + | otherwise = work_loc + eqn_orig = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc) + inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc) + eqn_loc = setCtLocOrigin initial_loc eqn_orig + inert_pred = ctEvPred inert_ev + inert_loc = ctEvLoc inert_ev + inert_rewriters = ctEvRewriters inert_ev + loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` + ctl_depth work_loc } {- Note [Type inference for type families with injectivity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1358,9 +1354,9 @@ Suppose we have a type family with an injectivity annotation: type family F a b = r | r -> b Then if we have an equality like F s1 t1 ~ F s2 t2, -we can use the injectivity to get a new Derived constraint on +we can use the injectivity to get a new Wanted constraint on the injective argument - [D] t1 ~ t2 + [W] t1 ~ t2 That in turn can help GHC solve constraints that would otherwise require guessing. For example, consider the ambiguity check for @@ -1380,15 +1376,15 @@ of the matching equation. For closed type families we have to perform additional apartness check for the selected equation to check that the selected is guaranteed to fire for given LHS arguments. -These new constraints are simply *Derived* constraints; they have no evidence. +These new constraints are Wanted constraints, but we will not use the evidence. We could go further and offer evidence from decomposing injective type-function applications, but that would require new evidence forms, and an extension to FC, so we don't do that right now (Dec 14). -We generate these Deriveds in three places, depending on how we notice the +We generate these Wanteds in three places, depending on how we notice the injectivity. -1. When we have a [W/D] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and +1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and described in Note [Decomposing equality] in GHC.Tc.Solver.Canonical. 2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these @@ -1455,10 +1451,7 @@ But it's not so simple: * We can only do g2 := g1 if g1 can discharge g2; that depends on (a) the role and (b) the flavour. E.g. a representational equality cannot discharge a nominal one; a Wanted cannot discharge a Given. - The predicate is eqCanDischargeFR. - -* If the inert is [W] and the work-item is [WD] we don't want to - forget the [D] part; hence the Bool result of inertsCanDischarge. + The predicate is eqCanRewriteFR. * Visibility. Suppose S :: forall k. k -> Type, and consider unifying S @Type (a::Type) ~ S @(Type->Type) (b::Type->Type) @@ -1479,9 +1472,7 @@ But it's not so simple: inertsCanDischarge :: InertCans -> Ct -> Maybe ( CtEvidence -- The evidence for the inert - , SwapFlag -- Whether we need mkSymCo - , Bool) -- True <=> keep a [D] version - -- of the [WD] constraint + , SwapFlag ) -- Whether we need mkSymCo inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w , cc_ev = ev_w, cc_eq_rel = eq_rel }) | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i @@ -1491,7 +1482,7 @@ inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w , inert_beats_wanted ev_i eq_rel ] = -- Inert: a ~ ty -- Work item: a ~ ty - Just (ev_i, NotSwapped, keep_deriv ev_i) + Just (ev_i, NotSwapped) | Just rhs_lhs <- canEqLHS_maybe rhs_w , (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i @@ -1501,7 +1492,7 @@ inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w , inert_beats_wanted ev_i eq_rel ] = -- Inert: a ~ b -- Work item: b ~ a - Just (ev_i, IsSwapped, keep_deriv ev_i) + Just (ev_i, IsSwapped) where loc_w = ctEvLoc ev_w @@ -1509,22 +1500,14 @@ inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w fr_w = (flav_w, eq_rel) inert_beats_wanted ev_i eq_rel - = -- eqCanDischargeFR: see second bullet of Note [Combining equalities] + = -- eqCanRewriteFR: see second bullet of Note [Combining equalities] -- strictly_more_visible: see last bullet of Note [Combining equalities] - fr_i`eqCanDischargeFR` fr_w + fr_i `eqCanRewriteFR` fr_w && not ((loc_w `strictly_more_visible` ctEvLoc ev_i) - && (fr_w `eqCanDischargeFR` fr_i)) + && (fr_w `eqCanRewriteFR` fr_i)) where fr_i = (ctEvFlavour ev_i, eq_rel) - -- See Note [Combining equalities], third bullet - keep_deriv ev_i - | Wanted WOnly <- ctEvFlavour ev_i -- inert is [W] - , Wanted WDeriv <- flav_w -- work item is [WD] - = True -- Keep a derived version of the work item - | otherwise - = False -- Work item is fully discharged - -- See Note [Combining equalities], final bullet strictly_more_visible loc1 loc2 = not (isVisibleOrigin (ctLocOrigin loc2)) && @@ -1538,20 +1521,13 @@ interactEq inerts workItem@(CEqCan { cc_lhs = lhs , cc_rhs = rhs , cc_ev = ev , cc_eq_rel = eq_rel }) - | Just (ev_i, swapped, keep_deriv) <- inertsCanDischarge inerts workItem + | Just (ev_i, swapped) <- inertsCanDischarge inerts workItem = do { setEvBindIfWanted ev $ evCoercion (maybeTcSymCo swapped $ tcDowngradeRole (eqRelRole eq_rel) (ctEvRole ev_i) (ctEvCoercion ev_i)) - ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev - , ctev_loc = ctEvLoc ev } - ; when keep_deriv $ - emitWork [workItem { cc_ev = deriv_ev }] - -- As a Derived it might not be fully rewritten, - -- so we emit it as new work - ; stopWith ev "Solved from inert" } | ReprEq <- eq_rel -- See Note [Do not unify representational equalities] @@ -1562,9 +1538,7 @@ interactEq inerts workItem@(CEqCan { cc_lhs = lhs = case lhs of TyVarLHS tv -> tryToSolveByUnification workItem ev tv rhs - TyFamLHS tc args -> do { when (isImprovable ev) $ - -- Try improvement, if possible - improveLocalFunEqs ev inerts tc args rhs + TyFamLHS tc args -> do { improveLocalFunEqs ev inerts tc args rhs ; continueWith workItem } interactEq _ wi = pprPanic "interactEq" (ppr wi) @@ -1597,7 +1571,7 @@ tryToSolveByUnification work_item ev tv rhs solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS (StopOrContinue Ct) -- Solve with the identity coercion -- Precondition: kind(xi) equals kind(tv) --- Precondition: CtEvidence is Wanted or Derived +-- Precondition: CtEvidence is Wanted -- Precondition: CtEvidence is nominal -- Returns: workItem where -- workItem = the new Given constraint @@ -1710,7 +1684,7 @@ Note [FunDep and implicit parameter reactions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Currently, our story of interacting two dictionaries (or a dictionary and top-level instances) for functional dependencies, and implicit -parameters, is that we simply produce new Derived equalities. So for example +parameters, is that we simply produce new Wanted equalities. So for example class D a b | a -> b where ... Inert: @@ -1719,7 +1693,7 @@ parameters, is that we simply produce new Derived equalities. So for example d2 :w D Int alpha We generate the extra work item - cv :d alpha ~ Bool + cv :w alpha ~ Bool where 'cv' is currently unused. However, this new item can perhaps be spontaneously solved to become given and react with d2, discharging it in favour of a new constraint d2' thus: @@ -1728,10 +1702,9 @@ parameters, is that we simply produce new Derived equalities. So for example Now d2' can be discharged from d1 We could be more aggressive and try to *immediately* solve the dictionary -using those extra equalities, but that requires those equalities to carry -evidence and derived do not carry evidence. +using those extra equalities. -If that were the case with the same inert set and work item we might dischard +If that were the case with the same inert set and work item we might discard d2 directly: cv :w alpha ~ Bool @@ -1756,10 +1729,10 @@ It's exactly the same with implicit parameters, except that the Note [Fundeps with instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ doTopFundepImprovement compares the constraint with all the instance -declarations, to see if we can produce any derived equalities. E.g +declarations, to see if we can produce any equalities. E.g class C2 a b | a -> b instance C Int Bool -Then the constraint (C Int ty) generates the Derived equality [D] ty ~ Bool. +Then the constraint (C Int ty) generates the equality [W] ty ~ Bool. There is a nasty corner in #19415 which led to the typechecker looping: class C s t b | s -> t @@ -1769,9 +1742,9 @@ There is a nasty corner in #19415 which led to the typechecker looping: work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char where kb0, b0 are unification vars ==> {fundeps against instance; k0, y0 fresh unification vars} - [D] T kb0 (b0::kb0) ~ T k0 (y0::k0) + [W] T kb0 (b0::kb0) ~ T k0 (y0::k0) Add dwrk to inert set - ==> {solve that Derived kb0 := k0, b0 := y0 + ==> {solve that equality kb0 := k0, b0 := y0 Now kick out dwrk, since it mentions kb0 But now we are back to the start! Loop! @@ -1791,7 +1764,7 @@ is very simple: a) The class has fundeps b) We have not had a successful hit against instances yet -* In doTopFundepImprovement, if we emit some Deriveds we flip the flag +* In doTopFundepImprovement, if we emit some constraints we flip the flag to False, so that we won't try again with the same CDictCan. In our example, dwrk will have its flag set to False. @@ -1828,8 +1801,8 @@ The two instances don't actually conflict on their fundeps, although it's pretty strange. So they are both accepted. Now try [W] GHet (K Int) (K Bool) This triggers fundeps from both instance decls; - [D] K Bool ~ K [a] - [D] K Bool ~ K beta + [W] K Bool ~ K [a] + [W] K Bool ~ K beta And there's a risk of complaining about Bool ~ [a]. But in fact the Wanted matches the second instance, so we never get as far as the fundeps. @@ -1837,7 +1810,7 @@ as the fundeps. #7875 is a case in point. -} -doTopFundepImprovement ::Ct -> TcS (StopOrContinue Ct) +doTopFundepImprovement :: Ct -> TcS (StopOrContinue Ct) -- Try to functional-dependency improvement betweeen the constraint -- and the top-level instance declarations -- See Note [Fundeps with instances] @@ -1845,13 +1818,13 @@ doTopFundepImprovement ::Ct -> TcS (StopOrContinue Ct) doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls , cc_tyargs = xis , cc_fundeps = has_fds }) - | has_fds, isImprovable ev + | has_fds = do { traceTcS "try_fundeps" (ppr work_item) ; instEnvs <- getInstEnvs ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis ; case fundep_eqns of [] -> continueWith work_item -- No improvement - _ -> do { emitFunDepDeriveds fundep_eqns + _ -> do { emitFunDepWanteds (ctEvRewriters ev) fundep_eqns ; continueWith (work_item { cc_fundeps = False }) } } | otherwise = continueWith work_item @@ -1863,30 +1836,38 @@ doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls mk_ct_loc :: PredType -- From instance decl -> SrcSpan -- also from instance deol - -> CtLoc + -> (CtLoc, RewriterSet) mk_ct_loc inst_pred inst_loc - = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin - inst_pred inst_loc } + = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin + inst_pred inst_loc } + , emptyRewriterSet ) doTopFundepImprovement work_item = pprPanic "doTopFundepImprovement" (ppr work_item) -emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS () +emitFunDepWanteds :: RewriterSet -- from the work item + -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS () -- See Note [FunDep and implicit parameter reactions] -emitFunDepDeriveds fd_eqns +emitFunDepWanteds work_rewriters fd_eqns = mapM_ do_one_FDEqn fd_eqns where - do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc }) + do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) }) | null tvs -- Common shortcut - = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc)) - ; mapM_ (unifyDerived loc Nominal) eqs } + = do { traceTcS "emitFunDepWanteds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc)) + ; mapM_ (\(Pair ty1 ty2) -> unifyWanted all_rewriters loc Nominal ty1 ty2) + (reverse eqs) } + -- See Note [Reverse order of fundep equations] + | otherwise - = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) + = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) ; subst <- instFlexi tvs -- Takes account of kind substitution - ; mapM_ (do_one_eq loc subst) eqs } + ; mapM_ (do_one_eq loc all_rewriters subst) (reverse eqs) } + -- See Note [Reverse order of fundep equations] + where + all_rewriters = work_rewriters S.<> rewriters - do_one_eq loc subst (Pair ty1 ty2) - = unifyDerived loc Nominal $ - Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2) + do_one_eq loc rewriters subst (Pair ty1 ty2) + = unifyWanted rewriters loc Nominal + (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2) {- ********************************************************************** @@ -1898,7 +1879,7 @@ emitFunDepDeriveds fd_eqns topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) -- The work item does not react with the inert set, --- so try interaction with top-level instances. Note: +-- so try interaction with top-level instances. topReactionsStage work_item = do { traceTcS "doTopReact" (ppr work_item) ; case work_item of @@ -1986,6 +1967,47 @@ See * Note [Evidence for quantified constraints] in GHC.Core.Predicate * Note [Equality superclasses in quantified constraints] in GHC.Tc.Solver.Canonical + +Note [Reverse order of fundep equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this scenario (from dependent/should_fail/T13135_simple): + + type Sig :: Type -> Type + data Sig a = SigFun a (Sig a) + + type SmartFun :: forall (t :: Type). Sig t -> Type + type family SmartFun sig = r | r -> sig where + SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig + + [W] SmartFun @kappa sigma ~ (Int -> Bool) + +The injectivity of SmartFun allows us to produce two new equalities: + + [W] w1 :: Type ~ kappa + [W] w2 :: SigFun @Type Int beta ~ sigma + +for some fresh (beta :: SigType). The second Wanted here is actually +heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa. +Of course, if we solve the first wanted first, the second becomes homogeneous. + +When looking for injectivity-inspired equalities, we work left-to-right, +producing the two equalities in the order written above. However, these +equalities are then passed into unifyWanted, which will fail, adding these +to the work list. However, crucially, the work list operates like a *stack*. +So, because we add w1 and then w2, we process w2 first. This is silly: solving +w1 would unlock w2. So we make sure to add equalities to the work +list in left-to-right order, which requires a few key calls to 'reverse'. + +This treatment is also used for class-based functional dependencies, although +we do not have a program yet known to exhibit a loop there. It just seems +like the right thing to do. + +When this was originally conceived, it was necessary to avoid a loop in T13135. +That loop is now avoided by continuing with the kind equality (not the type +equality) in canEqCanLHSHetero (see Note [Equalities with incompatible kinds] +in GHC.Tc.Solver.Canonical). However, the idea of working left-to-right still +seems worthwhile, and so the calls to 'reverse' remain. + -} -------------------- @@ -1999,7 +2021,7 @@ doTopReactEq work_item = doTopReactOther work_item improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS () -- See Note [FunDep and implicit parameter reactions] improveTopFunEqs ev fam_tc args rhs - | not (isImprovable ev) + | isGiven ev -- See Note [No Given/Given fundeps] = return () | otherwise @@ -2007,11 +2029,15 @@ improveTopFunEqs ev fam_tc args rhs ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs , ppr eqns ]) - ; mapM_ (unifyDerived loc Nominal) eqns } + ; mapM_ (\(Pair ty1 ty2) -> unifyWanted rewriters loc Nominal ty1 ty2) + (reverse eqns) } + -- Missing that `reverse` causes T13135 and T13135_simple to loop. + -- See Note [Reverse order of fundep equations] where loc = bumpCtLocDepth (ctEvLoc ev) -- ToDo: this location is wrong; it should be FunDepOrigin2 -- See #14778 + rewriters = ctEvRewriters ev improve_top_fun_eqs :: FamInstEnvs -> TyCon -> [TcType] -> TcType @@ -2094,7 +2120,7 @@ we do *not* need to expand type synonyms because the matcher will do that for us Note [Improvement orientation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A very delicate point is the orientation of derived equalities +A very delicate point is the orientation of equalities arising from injectivity improvement (#12522). Suppose we have type family F x = t | t -> x type instance F (a, Int) = (Int, G a) @@ -2103,10 +2129,10 @@ where G is injective; and wanted constraints [W] TF (alpha, beta) ~ fuv [W] fuv ~ (Int, <some type>) -The injectivity will give rise to derived constraints +The injectivity will give rise to constraints - [D] gamma1 ~ alpha - [D] Int ~ beta + [W] gamma1 ~ alpha + [W] Int ~ beta The fresh unification variable gamma1 comes from the fact that we can only do "partial improvement" here; see Section 5.2 of @@ -2115,7 +2141,7 @@ can only do "partial improvement" here; see Section 5.2 of Now, it's very important to orient the equations this way round, so that the fresh unification variable will be eliminated in favour of alpha. If we instead had - [D] alpha ~ gamma1 + [W] alpha ~ gamma1 then we would unify alpha := gamma1; and kick out the wanted constraint. But when we grough it back in, it'd look like [W] TF (gamma1, beta) ~ fuv @@ -2126,7 +2152,7 @@ introducing gamma1 in the first place, in the case where the actual argument (alpha, beta) partly matches the improvement template. But that's a bit tricky, esp when we remember that the kinds much match too; so it's easier to let the normal machinery -handle it. Instead we are careful to orient the new derived +handle it. Instead we are careful to orient the new equality with the template on the left. Delicate, but it works. -} @@ -2142,13 +2168,14 @@ doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct) doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls , cc_tyargs = xis }) | isGiven ev -- Never use instances for Given constraints - = doTopFundepImprovement work_item + = continueWith work_item + -- See Note [No Given/Given fundeps] | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached = do { setEvBindIfWanted ev (ctEvTerm solved_ev) ; stopWith ev "Dict/Top (cached)" } - | otherwise -- Wanted or Derived, but not cached + | otherwise -- Wanted, but not cached = do { dflags <- getDynFlags ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc ; case lkup_res of @@ -2174,32 +2201,16 @@ chooseInstance work_item , cir_mk_ev = mk_ev }) = do { traceTcS "doTopReact/found instance for" $ ppr ev ; deeper_loc <- checkInstanceOK loc what pred - ; if isDerived ev - then -- Use type-class instances for Deriveds, in the hope - -- of generating some improvements - -- C.f. Example 3 of Note [The improvement story and derived shadows] - -- It's easy because no evidence is involved - do { dflags <- getDynFlags - ; unless (subGoalDepthExceeded dflags (ctLocDepth deeper_loc)) $ - emitNewDeriveds deeper_loc theta - -- If we have a runaway Derived, let's not issue a - -- "reduction stack overflow" error, which is not particularly - -- friendly. Instead, just drop the Derived. - ; traceTcS "finish_derived" (ppr (ctl_depth deeper_loc)) - ; stopWith ev "Dict/Top (solved derived)" } - - else -- wanted - do { checkReductionDepth deeper_loc pred - ; evb <- getTcEvBindsVar - ; if isCoEvBindsVar evb - then continueWith work_item + ; checkReductionDepth deeper_loc pred + ; evb <- getTcEvBindsVar + ; if isCoEvBindsVar evb + then continueWith work_item -- See Note [Instances in no-evidence implications] - - else - do { evc_vars <- mapM (newWanted deeper_loc) theta + else + do { evc_vars <- mapM (newWanted deeper_loc (ctRewriters work_item)) theta ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars)) ; emitWorkNC (freshGoals evc_vars) - ; stopWith ev "Dict/Top (solved wanted)" }}} + ; stopWith ev "Dict/Top (solved wanted)" }} where ev = ctEvidence work_item pred = ctEvPred ev @@ -2212,8 +2223,7 @@ checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc -- Check that it's OK to use this insstance: -- (a) the use is well staged in the Template Haskell sense -- Returns the CtLoc to used for sub-goals --- Probably also want to call checkReductionDepth, but this function --- does not do so to enable special handling for Deriveds in chooseInstance +-- Probably also want to call checkReductionDepth checkInstanceOK loc what pred = do { checkWellStagedDFun loc what pred ; return deeper_loc } diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 2cd004053d..9f75491dd0 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -13,8 +14,9 @@ module GHC.Tc.Solver.Monad ( -- The TcS monad - TcS, runTcS, runTcSDeriveds, runTcSDerivedsEarlyAbort, runTcSWithEvBinds, - runTcSInerts, failTcS, warnTcS, addErrTcS, wrapTcS, runTcSEqualities, + TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts, + failTcS, warnTcS, addErrTcS, wrapTcS, + runTcSEqualities, nestTcS, nestImplicTcS, setEvBindsTcS, emitImplicationTcS, emitTvImplicationTcS, @@ -38,16 +40,14 @@ module GHC.Tc.Solver.Monad ( MaybeNew(..), freshGoals, isFresh, getEvExpr, newTcEvBinds, newNoTcEvBinds, - newWantedEq, newWantedEq_SI, emitNewWantedEq, - newWanted, newWanted_SI, newWantedEvVar, + newWantedEq, emitNewWantedEq, + newWanted, newWantedNC, newWantedEvVarNC, - newDerivedNC, newBoundEvVarId, unifyTyVar, reportUnifications, touchabilityTest, TouchabilityTestResult(..), setEvBind, setWantedEq, setWantedEvTerm, setEvBindIfWanted, newEvVar, newGivenEvVar, newGivenEvVars, - emitNewDeriveds, emitNewDerivedEq, checkReductionDepth, getSolvedDicts, setSolvedDicts, @@ -67,7 +67,6 @@ module GHC.Tc.Solver.Monad ( removeInertCts, getPendingGivenScs, addInertCan, insertFunEq, addInertForAll, emitWorkNC, emitWork, - isImprovable, lookupInertDict, -- The Model @@ -130,7 +129,8 @@ import qualified GHC.Tc.Utils.Monad as TcM import qualified GHC.Tc.Utils.TcMType as TcM import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) ) import qualified GHC.Tc.Utils.Env as TcM - ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl ) + ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl + , tcInitTidyEnv ) import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) import GHC.Tc.Utils.TcType import GHC.Driver.Session @@ -145,8 +145,8 @@ import GHC.Tc.Solver.InertSet import GHC.Tc.Types.Evidence import GHC.Core.Class import GHC.Core.TyCon -import GHC.Tc.Errors ( solverDepthErrorTcS ) import GHC.Tc.Errors.Types +import GHC.Types.Error ( mkPlainError, noHints ) import GHC.Types.Name import GHC.Types.TyThing @@ -167,15 +167,14 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Unify import GHC.Core.Predicate - -import GHC.Types.Unique.Set +import GHC.Types.Unique.Set (nonDetEltsUniqSet) +import GHC.Utils.Panic.Plain import Control.Monad import GHC.Utils.Monad import Data.IORef import GHC.Exts (oneShot) -import Data.List ( mapAccumL, partition ) -import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.List ( mapAccumL, partition, find ) #if defined(DEBUG) import GHC.Data.Graph.Directed @@ -183,358 +182,6 @@ import GHC.Data.Graph.Directed {- ********************************************************************* * * - Shadow constraints and improvement -* * -************************************************************************ - -Note [The improvement story and derived shadows] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not -rewrite Wanteds] in GHC.Tc.Types.Constraint), we may miss some opportunities for -solving. Here's a classic example (indexed-types/should_fail/T4093a) - - Ambiguity check for f: (Foo e ~ Maybe e) => Foo e - - We get [G] Foo e ~ Maybe e (CEqCan) - [W] Foo ee ~ Foo e (CEqCan) -- ee is a unification variable - [W] Foo ee ~ Maybe ee (CEqCan) - - The first Wanted gets rewritten to - - [W] Foo ee ~ Maybe e - - But now we appear to be stuck, since we don't rewrite Wanteds with - Wanteds. This is silly because we can see that ee := e is the - only solution. - -The basic plan is - * generate Derived constraints that shadow Wanted constraints - * allow Derived to rewrite Derived - * in order to cause some unifications to take place - * that in turn solve the original Wanteds - -The ONLY reason for all these Derived equalities is to tell us how to -unify a variable: that is, what Mark Jones calls "improvement". - -The same idea is sometimes also called "saturation"; find all the -equalities that must hold in any solution. - -Or, equivalently, you can think of the derived shadows as implementing -the "model": a non-idempotent but no-occurs-check substitution, -reflecting *all* *Nominal* equalities (a ~N ty) that are not -immediately soluble by unification. - -More specifically, here's how it works (Oct 16): - -* Wanted constraints are born as [WD]; this behaves like a - [W] and a [D] paired together. - -* When we are about to add a [WD] to the inert set, if it can - be rewritten by a [D] a ~ ty, then we split it into [W] and [D], - putting the latter into the work list (see maybeEmitShadow). - -In the example above, we get to the point where we are stuck: - [WD] Foo ee ~ Foo e - [WD] Foo ee ~ Maybe ee - -But now when [WD] Foo ee ~ Maybe ee is about to be added, we'll -split it into [W] and [D], since the inert [WD] Foo ee ~ Foo e -can rewrite it. Then: - work item: [D] Foo ee ~ Maybe ee - inert: [W] Foo ee ~ Maybe ee - [WD] Foo ee ~ Maybe e - -See Note [Splitting WD constraints]. Now the work item is rewritten -by the [WD] and we soon get ee := e. - -Additional notes: - - * The derived shadow equalities live in inert_eqs, along with - the Givens and Wanteds; see Note [EqualCtList invariants] - in GHC.Tc.Solver.Types. - - * We make Derived shadows only for Wanteds, not Givens. So we - have only [G], not [GD] and [G] plus splitting. See - Note [Add derived shadows only for Wanteds] - - * We also get Derived equalities from functional dependencies - and type-function injectivity; see calls to unifyDerived. - - * It's worth having [WD] rather than just [W] and [D] because - * efficiency: silly to process the same thing twice - * inert_dicts is a finite map keyed by - the type; it's inconvenient for it to map to TWO constraints - -Another example requiring Deriveds is in -Note [Put touchable variables on the left] in GHC.Tc.Solver.Canonical. - -Note [Splitting WD constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are about to add a [WD] constraint to the inert set; and we -know that the inert set has fully rewritten it. Should we split -it into [W] and [D], and put the [D] in the work list for further -work? - -* CDictCan (C tys): - Yes if the inert set could rewrite tys to make the class constraint, - or type family, fire. That is, yes if the inert_eqs intersects - with the free vars of tys. For this test we use - (anyRewritableTyVar True) which ignores casts and coercions in tys, - because rewriting the casts or coercions won't make the thing fire - more often. - -* CEqCan (lhs ~ ty): Yes if the inert set could rewrite 'lhs' or 'ty'. - We need to check both 'lhs' and 'ty' against the inert set: - - Inert set contains [D] a ~ ty2 - Then we want to put [D] a ~ ty in the worklist, so we'll - get [D] ty ~ ty2 with consequent good things - - - Inert set contains [D] b ~ a, where b is in ty. - We can't just add [WD] a ~ ty[b] to the inert set, because - that breaks the inert-set invariants. If we tried to - canonicalise another [D] constraint mentioning 'a', we'd - get an infinite loop - - Moreover we must use (anyRewritableTyVar False) for the RHS, - because even tyvars in the casts and coercions could give - an infinite loop if we don't expose it - -* CIrredCan: Yes if the inert set can rewrite the constraint. - We used to think splitting irreds was unnecessary, but - see Note [Splitting Irred WD constraints] - -* Others: nothing is gained by splitting. - -Note [Splitting Irred WD constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Splitting Irred constraints can make a difference. Here is the -scenario: - - a[sk] :: F v -- F is a type family - beta :: alpha - - work item: [WD] a ~ beta - -This is heterogeneous, so we emit a kind equality and make the work item an -inert Irred. - - work item: [D] F v ~ alpha - inert: [WD] (a |> co) ~ beta (CIrredCan) - -Can't make progress on the work item. Add to inert set. This kicks out the -old inert, because a [D] can rewrite a [WD]. - - work item: [WD] (a |> co) ~ beta - inert: [D] F v ~ alpha (CEqCan) - -Can't make progress on this work item either (although GHC tries by -decomposing the cast and rewriting... but that doesn't make a difference), -which is still hetero. Emit a new kind equality and add to inert set. But, -critically, we split the Irred. - - work list: - [D] F v ~ alpha (CEqCan) - [D] (a |> co) ~ beta (CIrred) -- this one was split off - inert: - [W] (a |> co) ~ beta - [D] F v ~ alpha - -We quickly solve the first work item, as it's the same as an inert. - - work item: [D] (a |> co) ~ beta - inert: - [W] (a |> co) ~ beta - [D] F v ~ alpha - -We decompose the cast, yielding - - [D] a ~ beta - -We then rewrite the kinds. The lhs kind is F v, which flattens to alpha. - - co' :: F v ~ alpha - [D] (a |> co') ~ beta - -Now this equality is homo-kinded. So we swizzle it around to - - [D] beta ~ (a |> co') - -and set beta := a |> co', and go home happy. - -If we don't split the Irreds, we loop. This is all dangerously subtle. - -This is triggered by test case typecheck/should_compile/SplitWD. - -Note [Add derived shadows only for Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only add shadows for Wanted constraints. That is, we have -[WD] but not [GD]; and maybeEmitShaodw looks only at [WD] -constraints. - -It does just possibly make sense ot add a derived shadow for a -Given. If we created a Derived shadow of a Given, it could be -rewritten by other Deriveds, and that could, conceivably, lead to a -useful unification. - -But (a) I have been unable to come up with an example of this - happening - (b) see #12660 for how adding the derived shadows - of a Given led to an infinite loop. - (c) It's unlikely that rewriting derived Givens will lead - to a unification because Givens don't mention touchable - unification variables - -For (b) there may be other ways to solve the loop, but simply -reraining from adding derived shadows of Givens is particularly -simple. And it's more efficient too! - -Still, here's one possible reason for adding derived shadows -for Givens. Consider - work-item [G] a ~ [b], inerts has [D] b ~ a. -If we added the derived shadow (into the work list) - [D] a ~ [b] -When we process it, we'll rewrite to a ~ [a] and get an -occurs check. Without it we'll miss the occurs check (reporting -inaccessible code); but that's probably OK. - -Note [Keep CDictCan shadows as CDictCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class C a => D a b -and [G] D a b, [G] C a in the inert set. Now we insert -[D] b ~ c. We want to kick out a derived shadow for [D] D a b, -so we can rewrite it with the new constraint, and perhaps get -instance reduction or other consequences. - -BUT we do not want to kick out a *non-canonical* (D a b). If we -did, we would do this: - - rewrite it to [D] D a c, with pend_sc = True - - use expandSuperClasses to add C a - - go round again, which solves C a from the givens -This loop goes on for ever and triggers the simpl_loop limit. - -Solution: kick out the CDictCan which will have pend_sc = False, -because we've already added its superclasses. So we won't re-add -them. If we forget the pend_sc flag, our cunning scheme for avoiding -generating superclasses repeatedly will fail. - -See #11379 for a case of this. - -Note [Do not do improvement for WOnly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do improvement between two constraints (e.g. for injectivity -or functional dependencies) only if both are "improvable". And -we improve a constraint wrt the top-level instances only if -it is improvable. - -Improvable: [G] [WD] [D} -Not improvable: [W] - -Reasons: - -* It's less work: fewer pairs to compare - -* Every [W] has a shadow [D] so nothing is lost - -* Consider [WD] C Int b, where 'b' is a skolem, and - class C a b | a -> b - instance C Int Bool - We'll do a fundep on it and emit [D] b ~ Bool - That will kick out constraint [WD] C Int b - Then we'll split it to [W] C Int b (keep in inert) - and [D] C Int b (in work list) - When processing the latter we'll rewrite it to - [D] C Int Bool - At that point it would be /stupid/ to interact it - with the inert [W] C Int b in the inert set; after all, - it's the very constraint from which the [D] C Int Bool - was split! We can avoid this by not doing improvement - on [W] constraints. This came up in #12860. --} - -maybeEmitShadow :: InertCans -> Ct -> TcS Ct --- See Note [The improvement story and derived shadows] -maybeEmitShadow ics ct - | let ev = ctEvidence ct - , CtWanted { ctev_pred = pred, ctev_loc = loc - , ctev_nosh = WDeriv } <- ev - , shouldSplitWD (inert_eqs ics) (inert_funeqs ics) ct - = do { traceTcS "Emit derived shadow" (ppr ct) - ; let derived_ev = CtDerived { ctev_pred = pred - , ctev_loc = loc } - shadow_ct = ct { cc_ev = derived_ev } - -- Te shadow constraint keeps the canonical shape. - -- This just saves work, but is sometimes important; - -- see Note [Keep CDictCan shadows as CDictCan] - ; emitWork [shadow_ct] - - ; let ev' = ev { ctev_nosh = WOnly } - ct' = ct { cc_ev = ev' } - -- Record that it now has a shadow - -- This is /the/ place we set the flag to WOnly - ; return ct' } - - | otherwise - = return ct - -shouldSplitWD :: InertEqs -> FunEqMap EqualCtList -> Ct -> Bool --- Precondition: 'ct' is [WD], and is inert --- True <=> we should split ct ito [W] and [D] because --- the inert_eqs can make progress on the [D] --- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs fun_eqs (CDictCan { cc_tyargs = tys }) - = should_split_match_args inert_eqs fun_eqs tys - -- NB True: ignore coercions - -- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_lhs = TyVarLHS tv, cc_rhs = ty - , cc_eq_rel = eq_rel }) - = tv `elemDVarEnv` inert_eqs - || anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs) ty - -- NB False: do not ignore casts and coercions - -- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel }) - = anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs) - (ctEvPred ev) - -shouldSplitWD inert_eqs fun_eqs (CIrredCan { cc_ev = ev }) - = anyRewritableCanEqLHS (ctEvEqRel ev) (canRewriteTv inert_eqs) - (canRewriteTyFam fun_eqs) (ctEvPred ev) - -shouldSplitWD _ _ _ = False -- No point in splitting otherwise - -should_split_match_args :: InertEqs -> FunEqMap EqualCtList -> [TcType] -> Bool --- True if the inert_eqs can rewrite anything in the argument types -should_split_match_args inert_eqs fun_eqs tys - = any (anyRewritableCanEqLHS NomEq (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)) tys - -- See Note [Splitting WD constraints] - -canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool -canRewriteTv inert_eqs eq_rel tv - | Just (EqualCtList (ct :| _)) <- lookupDVarEnv inert_eqs tv - , CEqCan { cc_eq_rel = eq_rel1 } <- ct - = eq_rel1 `eqCanRewrite` eq_rel - | otherwise - = False - -canRewriteTyFam :: FunEqMap EqualCtList -> EqRel -> TyCon -> [Type] -> Bool -canRewriteTyFam fun_eqs eq_rel tf args - | Just (EqualCtList (ct :| _)) <- findFunEq fun_eqs tf args - , CEqCan { cc_eq_rel = eq_rel1 } <- ct - = eq_rel1 `eqCanRewrite` eq_rel - | otherwise - = False - -isImprovable :: CtEvidence -> Bool --- See Note [Do not do improvement for WOnly] -isImprovable (CtWanted { ctev_nosh = WOnly }) = False -isImprovable _ = True - - -{- ********************************************************************* -* * Inert instances: inert_insts * * ********************************************************************* -} @@ -601,14 +248,28 @@ Note [Adding an equality to the InertCans] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When adding an equality to the inerts: -* Split [WD] into [W] and [D] if the inerts can rewrite the latter; - done by maybeEmitShadow. - * Kick out any constraints that can be rewritten by the thing we are adding. Done by kickOutRewritable. * Note that unifying a:=ty, is like adding [G] a~ty; just use kickOutRewritable with Nominal, Given. See kickOutAfterUnification. + +Note [Kick out existing binding for implicit parameter] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (typecheck/should_compile/ImplicitParamFDs) + flub :: (?x :: Int) => (Int, Integer) + flub = (?x, let ?x = 5 in ?x) +When we are checking the last ?x occurrence, we guess its type +to be a fresh unification variable alpha and emit an (IP "x" alpha) +constraint. But the given (?x :: Int) has been translated to an +IP "x" Int constraint, which has a functional dependency from the +name to the type. So fundep interaction tells us that alpha ~ Int, +and we get a type error. This is bad. + +Instead, we wish to excise any old given for an IP when adding a +new one. We also must make sure not to float out +any IP constraints outside an implication that binds an IP of +the same name; see GHC.Tc.Solver.floatConstraints. -} addInertCan :: Ct -> TcS () @@ -620,7 +281,6 @@ addInertCan ct = ; mkTcS (\TcSEnv{tcs_abort_on_insoluble=abort_flag} -> when (abort_flag && insolubleEqCt ct) TcM.failM) ; ics <- getInertCans - ; ct <- maybeEmitShadow ics ct ; ics <- maybeKickOut ics ct ; tclvl <- getTcLevel ; setInertCans (addInertItem tclvl ics ct) @@ -633,6 +293,27 @@ maybeKickOut ics ct | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics ; return ics' } + + -- See [Kick out existing binding for implicit parameter] + | isGivenCt ct + , CDictCan { cc_class = cls, cc_tyargs = [ip_name_strty, _ip_ty] } <- ct + , isIPClass cls + , Just ip_name <- isStrLitTy ip_name_strty + -- Would this be more efficient if we used findDictsByClass and then delDict? + = let dict_map = inert_dicts ics + dict_map' = filterDicts doesn't_match_ip_name dict_map + + doesn't_match_ip_name :: Ct -> Bool + doesn't_match_ip_name ct + | Just (inert_ip_name, _inert_ip_ty) <- isIPPred_maybe (ctPred ct) + = inert_ip_name /= ip_name + + | otherwise + = True + + in + return (ics { inert_dicts = dict_map' }) + | otherwise = return ics @@ -682,8 +363,10 @@ kickOutAfterUnification new_tv ; return n_kicked } -- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical -kickOutAfterFillingCoercionHole :: CoercionHole -> Coercion -> TcS () -kickOutAfterFillingCoercionHole hole filled_co +-- It's possible that this could just go ahead and unify, but could there be occurs-check +-- problems? Seems simpler just to kick out. +kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () +kickOutAfterFillingCoercionHole hole = do { ics <- getInertCans ; let (kicked_out, ics') = kick_out ics n_kicked = workListSize kicked_out @@ -698,39 +381,25 @@ kickOutAfterFillingCoercionHole hole filled_co ; setInertCans ics' } where - holes_of_co = coercionHolesOfCo filled_co - kick_out :: InertCans -> (WorkList, InertCans) - kick_out ics@(IC { inert_blocked = blocked }) - = let (to_kick, to_keep) = partitionBagWith kick_ct blocked - - kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList - ics' = ics { inert_blocked = to_keep } - in - (kicked_out, ics') - - kick_ct :: Ct -> Either Ct Ct - -- Left: kick out; Right: keep. But even if we keep, we may need - -- to update the set of blocking holes - kick_ct ct@(CIrredCan { cc_reason = HoleBlockerReason holes }) - | hole `elementOfUniqSet` holes - = let new_holes = holes `delOneFromUniqSet` hole - `unionUniqSets` holes_of_co - updated_ct = ct { cc_reason = HoleBlockerReason new_holes } - in - if isEmptyUniqSet new_holes - then Left updated_ct - else Right updated_ct - - | otherwise - = Right ct - - kick_ct other = pprPanic "kickOutAfterFillingCoercionHole" (ppr other) + kick_out ics@(IC { inert_eqs = eqs, inert_funeqs = funeqs }) + = (kicked_out, ics { inert_eqs = eqs_to_keep, inert_funeqs = funeqs_to_keep }) + where + (eqs_to_kick, eqs_to_keep) = partitionInertEqs kick_ct eqs + (funeqs_to_kick, funeqs_to_keep) = partitionFunEqs kick_ct funeqs + kicked_out = extendWorkListCts (eqs_to_kick ++ funeqs_to_kick) emptyWorkList + + kick_ct :: Ct -> Bool + -- True: kick out; False: keep. + kick_ct (CEqCan { cc_rhs = rhs, cc_ev = ctev }) + = isWanted ctev && -- optimisation: givens don't have coercion holes anyway + rhs `hasThisCoercionHoleTy` hole + kick_ct other = pprPanic "kick_ct (coercion hole)" (ppr other) -------------- addInertSafehask :: InertCans -> Ct -> InertCans addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_safehask = addDictCt (inert_dicts ics) (classTyCon cls) tys item } + = ics { inert_safehask = addDict (inert_dicts ics) cls tys item } addInertSafehask _ item = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item @@ -816,7 +485,7 @@ updInertIrreds :: (Cts -> Cts) -> TcS () updInertIrreds upd_fn = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) } -getInertEqs :: TcS (DTyVarEnv EqualCtList) +getInertEqs :: TcS InertEqs getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } getInnermostGivenEqLevel :: TcS TcLevel @@ -840,9 +509,8 @@ getInertGivens :: TcS [Ct] getInertGivens = do { inerts <- getInertCans ; let all_cts = foldDicts (:) (inert_dicts inerts) - $ foldFunEqs (\ecl out -> equalCtListToList ecl ++ out) - (inert_funeqs inerts) - $ concatMap equalCtListToList (dVarEnvElts (inert_eqs inerts)) + $ foldFunEqs (++) (inert_funeqs inerts) + $ foldDVarEnv (++) [] (inert_eqs inerts) ; return (filter isGivenCt all_cts) } getPendingGivenScs :: TcS [Ct] @@ -878,7 +546,7 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts }) add :: Ct -> DictMap Ct -> DictMap Ct add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts - = addDictCt dicts (classTyCon cls) tys ct + = addDict dicts cls tys ct add ct _ = pprPanic "getPendingScDicts" (ppr ct) get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) @@ -895,27 +563,24 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts }) getUnsolvedInerts :: TcS ( Bag Implication , Cts ) -- All simple constraints --- Return all the unsolved [Wanted] or [Derived] constraints +-- Return all the unsolved [Wanted] constraints -- -- Post-condition: the returned simple constraints are all fully zonked -- (because they come from the inert set) -- the unsolved implics may not be getUnsolvedInerts - = do { IC { inert_eqs = tv_eqs - , inert_funeqs = fun_eqs - , inert_irreds = irreds - , inert_blocked = blocked - , inert_dicts = idicts + = do { IC { inert_eqs = tv_eqs + , inert_funeqs = fun_eqs + , inert_irreds = irreds + , inert_dicts = idicts } <- getInertCans - ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts - unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts - unsolved_irreds = Bag.filterBag is_unsolved irreds - unsolved_blocked = blocked -- all blocked equalities are W/D - unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts - unsolved_others = unionManyBags [ unsolved_irreds - , unsolved_dicts - , unsolved_blocked ] + ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts + unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts + unsolved_irreds = Bag.filterBag isWantedCt irreds + unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts + unsolved_others = unionManyBags [ unsolved_irreds + , unsolved_dicts ] ; implics <- getWorkListImplics @@ -930,14 +595,11 @@ getUnsolvedInerts unsolved_others) } where add_if_unsolved :: Ct -> Cts -> Cts - add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts - | otherwise = cts + add_if_unsolved ct cts | isWantedCt ct = ct `consCts` cts + | otherwise = cts add_if_unsolveds :: EqualCtList -> Cts -> Cts - add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts - (equalCtListToList new_cts) - - is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived + add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts new_cts getHasGivenEqs :: TcLevel -- TcLevel of this implication -> TcS ( HasGivenEqs -- are there Given equalities? @@ -970,15 +632,8 @@ getHasGivenEqs tclvl insoluble_given_equality ct = insolubleEqCt ct && isGivenCt ct -{- Note [Unsolved Derived equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In getUnsolvedInerts, we return a derived equality from the inert_eqs -because it is a candidate for floating out of this implication. We -only float equalities with a meta-tyvar on the left, so we only pull -those out here. - -Note [What might equal later?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [What might equal later?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must determine whether a Given might later equal a Wanted. We definitely need to account for the possibility that any metavariable might be arbitrarily instantiated. Yet we do *not* want @@ -1084,16 +739,17 @@ removeInertCt is ct = pprPanic "removeInertCt" (ppr "CSpecialCan" <+> parens (ppr special_pred)) -- | Looks up a family application in the inerts. -lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole)) -lookupFamAppInert fam_tc tys +lookupFamAppInert :: (CtFlavourRole -> Bool) -- can it rewrite the target? + -> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole)) +lookupFamAppInert rewrite_pred fam_tc tys = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts ; return (lookup_inerts inert_funeqs) } where lookup_inerts inert_funeqs - | Just (EqualCtList (CEqCan { cc_ev = ctev, cc_rhs = rhs } :| _)) - <- findFunEq inert_funeqs fam_tc tys - = Just (mkReduction (ctEvCoercion ctev) rhs - ,ctEvFlavourRole ctev) + | Just ecl <- findFunEq inert_funeqs fam_tc tys + , Just (CEqCan { cc_ev = ctev, cc_rhs = rhs }) + <- find (rewrite_pred . ctFlavourRole) ecl + = Just (mkReduction (ctEvCoercion ctev) rhs, ctEvFlavourRole ctev) | otherwise = Nothing lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) @@ -1139,7 +795,6 @@ extendFamAppCache tc xi_args stuff@(Reduction _ ty) ; when (gopt Opt_FamAppCache dflags) $ do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args , ppr ty ]) - -- 'co' can be bottom, in the case of derived items ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) -> is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } } @@ -1330,19 +985,11 @@ runTcS tcs ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var ; return (res, ev_binds) } --- | This variant of 'runTcS' will keep solving, even when only Deriveds --- are left around. It also doesn't return any evidence, as callers won't --- need it. -runTcSDeriveds :: TcS a -> TcM a -runTcSDeriveds tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds ev_binds_var tcs } - - --- | This variant of 'runTcSDeriveds' will immediatley fail upon encountering an --- insoluble ct. See Note [Speeding up valid hole-fits] -runTcSDerivedsEarlyAbort :: TcS a -> TcM a -runTcSDerivedsEarlyAbort tcs +-- | This variant of 'runTcS' will immediatley fail upon encountering an +-- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage +-- site does not need the ev_binds, so we do not return them. +runTcSEarlyAbort :: TcS a -> TcM a +runTcSEarlyAbort tcs = do { ev_binds_var <- TcM.newTcEvBinds ; runTcSWithEvBinds' True True ev_binds_var tcs } @@ -1915,7 +1562,7 @@ an example: * There's a deeply-nested chain of implication constraints. ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int - * From the innermost one we get a [D] alpha[1] ~ Int, + * From the innermost one we get a [W] alpha[1] ~ Int, so we can unify. * It's better not to iterate the inner implications, but go all the @@ -2082,7 +1729,7 @@ Yuk! fillCoercionHole :: CoercionHole -> Coercion -> TcS () fillCoercionHole hole co = do { wrapTcS $ TcM.fillCoercionHole hole co - ; kickOutAfterFillingCoercionHole hole co } + ; kickOutAfterFillingCoercionHole hole } setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () setEvBindIfWanted ev tm @@ -2119,103 +1766,69 @@ newBoundEvVarId pred rhs newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts -emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion +emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion -- | Emit a new Wanted equality into the work-list -emitNewWantedEq loc role ty1 ty2 - = do { (ev, co) <- newWantedEq loc role ty1 ty2 +emitNewWantedEq loc rewriters role ty1 ty2 + = do { (ev, co) <- newWantedEq loc rewriters role ty1 ty2 ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) ; return co } -- | Make a new equality CtEvidence -newWantedEq :: CtLoc -> Role -> TcType -> TcType +newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion) -newWantedEq = newWantedEq_SI WDeriv - -newWantedEq_SI :: ShadowInfo -> CtLoc -> Role - -> TcType -> TcType - -> TcS (CtEvidence, Coercion) -newWantedEq_SI si loc role ty1 ty2 +newWantedEq loc rewriters role ty1 ty2 = do { hole <- wrapTcS $ TcM.newCoercionHole pty ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty) - ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole - , ctev_nosh = si - , ctev_loc = loc} + ; return ( CtWanted { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = rewriters } , mkHoleCo hole ) } where pty = mkPrimEqPredRole role ty1 ty2 -- no equalities here. Use newWantedEq instead -newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence -newWantedEvVarNC = newWantedEvVarNC_SI WDeriv - -newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence +newWantedEvVarNC :: CtLoc -> RewriterSet + -> TcPredType -> TcS CtEvidence -- Don't look up in the solved/inerts; we know it's not there -newWantedEvVarNC_SI si loc pty +newWantedEvVarNC loc rewriters pty = do { new_ev <- newEvVar pty ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ pprCtLoc loc) - ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev - , ctev_nosh = si - , ctev_loc = loc })} - -newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew -newWantedEvVar = newWantedEvVar_SI WDeriv + ; return (CtWanted { ctev_pred = pty + , ctev_dest = EvVarDest new_ev + , ctev_loc = loc + , ctev_rewriters = rewriters })} -newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew +newWantedEvVar :: CtLoc -> RewriterSet + -> TcPredType -> TcS MaybeNew -- For anything except ClassPred, this is the same as newWantedEvVarNC -newWantedEvVar_SI si loc pty - = do { mb_ct <- lookupInInerts loc pty +newWantedEvVar loc rewriters pty + = assert (not (isHoleDestPred pty)) $ + do { mb_ct <- lookupInInerts loc pty ; case mb_ct of Just ctev - | not (isDerived ctev) -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev ; return $ Cached (ctEvExpr ctev) } - _ -> do { ctev <- newWantedEvVarNC_SI si loc pty + _ -> do { ctev <- newWantedEvVarNC loc rewriters pty ; return (Fresh ctev) } } -newWanted :: CtLoc -> PredType -> TcS MaybeNew +newWanted :: CtLoc -> RewriterSet -> PredType -> TcS MaybeNew -- Deals with both equalities and non equalities. Tries to look -- up non-equalities in the cache -newWanted = newWanted_SI WDeriv - -newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew -newWanted_SI si loc pty +newWanted loc rewriters pty | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2 + = Fresh . fst <$> newWantedEq loc rewriters role ty1 ty2 | otherwise - = newWantedEvVar_SI si loc pty + = newWantedEvVar loc rewriters pty -- deals with both equalities and non equalities. Doesn't do any cache lookups. -newWantedNC :: CtLoc -> PredType -> TcS CtEvidence -newWantedNC loc pty +newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS CtEvidence +newWantedNC loc rewriters pty | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = fst <$> newWantedEq loc role ty1 ty2 + = fst <$> newWantedEq loc rewriters role ty1 ty2 | otherwise - = newWantedEvVarNC loc pty - -emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS () -emitNewDeriveds loc preds - | null preds - = return () - | otherwise - = do { evs <- mapM (newDerivedNC loc) preds - ; traceTcS "Emitting new deriveds" (ppr evs) - ; updWorkListTcS (extendWorkListDeriveds evs) } - -emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS () --- Create new equality Derived and put it in the work list --- There's no caching, no lookupInInerts -emitNewDerivedEq loc role ty1 ty2 - = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2) - ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc) - ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) } - -- Very important: put in the wl_eqs - -- See Note [Prioritise equalities] in GHC.Tc.Solver.InertSet - -- (Avoiding fundep iteration) - -newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence -newDerivedNC loc pred - = return $ CtDerived { ctev_pred = pred, ctev_loc = loc } + = newWantedEvVarNC loc rewriters pty -- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? --------- -- | Checks if the depth of the given location is too much. Fails if @@ -2225,8 +1838,7 @@ checkReductionDepth :: CtLoc -> TcType -- ^ type being reduced checkReductionDepth loc ty = do { dflags <- getDynFlags ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $ - wrapErrTcS $ - solverDepthErrorTcS loc ty } + wrapErrTcS $ solverDepthError loc ty } matchFam :: TyCon -> [Type] -> TcS (Maybe ReductionN) matchFam tycon args = wrapTcS $ matchFamTcM tycon args @@ -2248,6 +1860,28 @@ matchFamTcM tycon args 2 (vcat [ text "Rewrites to:" <+> ppr ty , text "Coercion:" <+> ppr co ]) +solverDepthError :: CtLoc -> TcType -> TcM a +solverDepthError loc ty + = TcM.setCtLocM loc $ + do { ty <- TcM.zonkTcType ty + ; env0 <- TcM.tcInitTidyEnv + ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) + tidy_ty = tidyType tidy_env ty + msg = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Reduction stack overflow; size =" <+> ppr depth + , hang (text "When simplifying the following type:") + 2 (ppr tidy_ty) + , note ] + ; TcM.failWithTcM (tidy_env, msg) } + where + depth = ctLocDepth loc + note = vcat + [ text "Use -freduction-depth=0 to disable this check" + , text "(any upper bound you could choose might fail unpredictably with" + , text " minor updates to GHC, so disabling the check is recommended if" + , text " you're sure that type checking should terminate)" ] + + {- ************************************************************************ * * @@ -2287,16 +1921,12 @@ breakTyVarCycle_maybe ev cte_result (TyVarLHS lhs_tv) rhs flavour = ctEvFlavour ev eq_rel = ctEvEqRel ev - final_check - | Given <- flavour - = return True - | ctFlavourContainsDerived flavour - = do { result <- touchabilityTest Derived lhs_tv rhs - ; return $ case result of - Untouchable -> False - _ -> True } - | otherwise - = return False + final_check = case flavour of + Given -> return True + Wanted -> do { result <- touchabilityTest Wanted lhs_tv rhs + ; return $ case result of + Untouchable -> False + _ -> True } -- This could be considerably more efficient. See Detail (5) of Note. go :: TcType -> TcS ReductionN @@ -2349,10 +1979,10 @@ breakTyVarCycle_maybe ev cte_result (TyVarLHS lhs_tv) rhs ; return $ mkReflRedn Nominal new_ty } -- Why reflexive? See Detail (4) of the Note - _derived_or_wd -> + Wanted -> do { new_tv <- wrapTcS (TcM.newFlexiTyVar fun_app_kind) ; let new_ty = mkTyVarTy new_tv - ; co <- emitNewWantedEq new_loc Nominal new_ty fun_app + ; co <- emitNewWantedEq new_loc (ctEvRewriters ev) Nominal new_ty fun_app ; return $ mkReduction (mkSymCo co) new_ty } -- See Detail (7) of the Note diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs index b7573e7f09..6e8baf15a6 100644 --- a/compiler/GHC/Tc/Solver/Rewrite.hs +++ b/compiler/GHC/Tc/Solver/Rewrite.hs @@ -5,7 +5,7 @@ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Tc.Solver.Rewrite( - rewrite, rewriteKind, rewriteArgsNom, + rewrite, rewriteArgsNom, rewriteType ) where @@ -34,15 +34,14 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Tc.Solver.Monad as TcS -import GHC.Tc.Solver.Types + import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Exts (oneShot) import Control.Monad -import GHC.Utils.Monad ( zipWith3M ) -import Data.List.NonEmpty ( NonEmpty(..) ) import Control.Applicative (liftA3) import GHC.Builtin.Types.Prim (tYPETyCon) +import Data.List ( find ) {- ************************************************************************ @@ -82,18 +81,23 @@ liftTcS thing_inside -- convenient wrapper when you have a CtEvidence describing -- the rewriting operation -runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS a +runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS (a, RewriterSet) runRewriteCtEv ev = runRewrite (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev) -- Run thing_inside (which does the rewriting) -runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS a +-- Also returns the set of Wanteds which rewrote a Wanted; +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint +runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS (a, RewriterSet) runRewrite loc flav eq_rel thing_inside - = runRewriteM thing_inside fmode - where - fmode = FE { fe_loc = loc - , fe_flavour = flav - , fe_eq_rel = eq_rel } + = do { rewriters_ref <- newTcRef emptyRewriterSet + ; let fmode = RE { re_loc = loc + , re_flavour = flav + , re_eq_rel = eq_rel + , re_rewriters = rewriters_ref } + ; res <- runRewriteM thing_inside fmode + ; rewriters <- readTcRef rewriters_ref + ; return (res, rewriters) } traceRewriteM :: String -> SDoc -> RewriteM () traceRewriteM herald doc = liftTcS $ traceTcS herald doc @@ -108,13 +112,13 @@ getRewriteEnvField accessor = mkRewriteM $ \env -> return (accessor env) getEqRel :: RewriteM EqRel -getEqRel = getRewriteEnvField fe_eq_rel +getEqRel = getRewriteEnvField re_eq_rel getRole :: RewriteM Role getRole = eqRelRole <$> getEqRel getFlavour :: RewriteM CtFlavour -getFlavour = getRewriteEnvField fe_flavour +getFlavour = getRewriteEnvField re_flavour getFlavourRole :: RewriteM CtFlavourRole getFlavourRole @@ -123,7 +127,7 @@ getFlavourRole ; return (flavour, eq_rel) } getLoc :: RewriteM CtLoc -getLoc = getRewriteEnvField fe_loc +getLoc = getRewriteEnvField re_loc checkStackDepth :: Type -> RewriteM () checkStackDepth ty @@ -134,38 +138,32 @@ checkStackDepth ty setEqRel :: EqRel -> RewriteM a -> RewriteM a setEqRel new_eq_rel thing_inside = mkRewriteM $ \env -> - if new_eq_rel == fe_eq_rel env + if new_eq_rel == re_eq_rel env then runRewriteM thing_inside env - else runRewriteM thing_inside (env { fe_eq_rel = new_eq_rel }) + else runRewriteM thing_inside (env { re_eq_rel = new_eq_rel }) {-# INLINE setEqRel #-} --- | Make sure that rewriting actually produces a coercion (in other --- words, make sure our flavour is not Derived) --- Note [No derived kind equalities] -noBogusCoercions :: RewriteM a -> RewriteM a -noBogusCoercions thing_inside - = mkRewriteM $ \env -> - -- No new thunk is made if the flavour hasn't changed (note the bang). - let !env' = case fe_flavour env of - Derived -> env { fe_flavour = Wanted WDeriv } - _ -> env - in - runRewriteM thing_inside env' - bumpDepth :: RewriteM a -> RewriteM a bumpDepth (RewriteM thing_inside) = mkRewriteM $ \env -> do -- bumpDepth can be called a lot during rewriting so we force the -- new env to avoid accumulating thunks. - { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) } + { let !env' = env { re_loc = bumpCtLocDepth (re_loc env) } ; thing_inside env' } +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint +-- Precondition: the CtEvidence is a CtWanted of an equality +recordRewriter :: CtEvidence -> RewriteM () +recordRewriter (CtWanted { ctev_dest = HoleDest hole }) + = RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriterSet` hole) +recordRewriter other = pprPanic "recordRewriter" (ppr other) + {- Note [Rewriter EqRels] ~~~~~~~~~~~~~~~~~~~~~~~ When rewriting, we need to know which equality relation -- nominal or representation -- we should be respecting. The only difference is -that we rewrite variables by representational equalities when fe_eq_rel +that we rewrite variables by representational equalities when re_eq_rel is ReprEq, and that we unwrap newtypes when rewriting w.r.t. representational equality. @@ -203,14 +201,6 @@ soon throw out the phantoms when decomposing a TyConApp. (Or, the canonicaliser will emit an insoluble, in which case we get a better error message anyway.) -Note [No derived kind equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A kind-level coercion can appear in types, via mkCastTy. So, whenever -we are generating a coercion in a dependent context (in other words, -in a kind) we need to make sure that our flavour is never Derived -(as Derived constraints have no evidence). The noBogusCoercions function -changes the flavour from Derived just for this purpose. - -} {- ********************************************************************* @@ -221,32 +211,21 @@ changes the flavour from Derived just for this purpose. -} -- | See Note [Rewriting]. --- If (xi, co) <- rewrite mode ev ty, then co :: xi ~r ty +-- If (xi, co, rewriters) <- rewrite mode ev ty, then co :: xi ~r ty -- where r is the role in @ev@. +-- rewriters is the set of coercion holes that have been used to rewrite +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewrite :: CtEvidence -> TcType - -> TcS Reduction + -> TcS (Reduction, RewriterSet) rewrite ev ty = do { traceTcS "rewrite {" (ppr ty) - ; redn <- runRewriteCtEv ev (rewrite_one ty) + ; result@(redn, _) <- runRewriteCtEv ev (rewrite_one ty) ; traceTcS "rewrite }" (ppr $ reductionReducedType redn) - ; return redn } - --- specialized to rewriting kinds: never Derived, always Nominal --- See Note [No derived kind equalities] --- See Note [Rewriting] -rewriteKind :: CtLoc -> CtFlavour -> TcType -> TcS ReductionN -rewriteKind loc flav ty - = do { traceTcS "rewriteKind {" (ppr flav <+> ppr ty) - ; let flav' = case flav of - Derived -> Wanted WDeriv -- the WDeriv/WOnly choice matters not - _ -> flav - ; redn <- runRewrite loc flav' NomEq (rewrite_one ty) - ; traceTcS "rewriteKind }" (ppr redn) -- the coercion inside the reduction is never a panic - ; return redn } + ; return result } -- See Note [Rewriting] rewriteArgsNom :: CtEvidence -> TyCon -> [TcType] - -> TcS Reductions + -> TcS (Reductions, RewriterSet) -- Externally-callable, hence runRewrite -- Rewrite a vector of types all at once; in fact they are -- always the arguments of type family or class, so @@ -255,15 +234,15 @@ rewriteArgsNom :: CtEvidence -> TyCon -> [TcType] -- The kind passed in is the kind of the type family or class, call it T -- The kind of T args must be constant (i.e. not depend on the args) -- --- For Derived constraints the returned coercion may be undefined --- because rewriting may use a Derived equality ([D] a ~ ty) +-- Final return value returned which Wanteds rewrote another Wanted +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewriteArgsNom ev tc tys = do { traceTcS "rewrite_args {" (vcat (map ppr tys)) - ; ArgsReductions redns@(Reductions _ tys') kind_co + ; (ArgsReductions redns@(Reductions _ tys') kind_co, rewriters) <- runRewriteCtEv ev (rewrite_args_tc tc Nothing tys) ; massert (isReflMCo kind_co) ; traceTcS "rewrite }" (vcat (map ppr tys')) - ; return redns } + ; return (redns, rewriters) } -- | Rewrite a type w.r.t. nominal equality. This is useful to rewrite -- a type w.r.t. any givens. It does not do type-family reduction. This @@ -271,10 +250,10 @@ rewriteArgsNom ev tc tys -- only givens. rewriteType :: CtLoc -> TcType -> TcS TcType rewriteType loc ty - = do { redn <- runRewrite loc Given NomEq $ - rewrite_one ty + = do { (redn, _) <- runRewrite loc Given NomEq $ + rewrite_one ty -- use Given flavor so that it is rewritten - -- only w.r.t. Givens, never Wanteds/Deriveds + -- only w.r.t. Givens, never Wanteds -- (Shouldn't matter, if only Givens are present -- anyway) ; return $ reductionReducedType redn } @@ -462,38 +441,20 @@ rewrite_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet -> [Role] -> [Type] -> RewriteM ArgsReductions rewrite_args_slow binders inner_ki fvs roles tys --- Arguments used dependently must be rewritten with proper coercions, but --- we're not guaranteed to get a proper coercion when rewriting with the --- "Derived" flavour. So we must call noBogusCoercions when rewriting arguments --- corresponding to binders that are dependent. However, we might legitimately --- have *more* arguments than binders, in the case that the inner_ki is a variable --- that gets instantiated with a Î -type. We conservatively choose not to produce --- bogus coercions for these, too. Note that this might miss an opportunity for --- a Derived rewriting a Derived. The solution would be to generate evidence for --- Deriveds, thus avoiding this whole noBogusCoercions idea. See also --- Note [No derived kind equalities] - = do { rewritten_args <- zipWith3M rw (map isNamedBinder binders ++ repeat True) - roles tys - ; return $ simplifyArgsWorker binders inner_ki fvs roles rewritten_args } + = do { rewritten_args <- zipWithM rw roles tys + ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) } where {-# INLINE rw #-} - rw :: Bool -- must we ensure to produce a real coercion here? - -- see comment at top of function - -> Role -> Type -> RewriteM Reduction - rw True r ty = noBogusCoercions $ rw1 r ty - rw False r ty = rw1 r ty - - {-# INLINE rw1 #-} - rw1 :: Role -> Type -> RewriteM Reduction - rw1 Nominal ty + rw :: Role -> Type -> RewriteM Reduction + rw Nominal ty = setEqRel NomEq $ rewrite_one ty - rw1 Representational ty + rw Representational ty = setEqRel ReprEq $ rewrite_one ty - rw1 Phantom ty + rw Phantom ty -- See Note [Phantoms in the rewriter] = do { ty <- liftTcS $ zonkTcType ty ; return $ mkReflRedn Phantom ty } @@ -859,17 +820,13 @@ rewrite_exact_fam_app tc tys where reduced = mkTyConApp tc xis -- STEP 3: try the inerts - ; result2 <- liftTcS $ lookupFamAppInert tc xis ; flavour <- getFlavour + ; result2 <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis ; case result2 of - { Just (redn, fr@(_, inert_eq_rel)) - - | fr `eqCanRewriteFR` (flavour, eq_rel) -> - do { traceRewriteM "rewrite family application with inert" $ - vcat [ ppr tc <+> ppr xis - , ppUnless (flavour == Derived) (ppr redn) ] - -- Deriveds have no evidence, so we can't print the reduction - ; finish True (homogenise downgraded_redn) } + { Just (redn, (inert_flavour, inert_eq_rel)) + -> do { traceRewriteM "rewrite family application with inert" + (ppr tc <+> ppr xis $$ ppr redn) + ; finish (inert_flavour == Given) (homogenise downgraded_redn) } -- this will sometimes duplicate an inert in the cache, -- but avoiding doing so had no impact on performance, and -- it seems easier not to weed out that special case @@ -890,18 +847,17 @@ rewrite_exact_fam_app tc tys -- call this if the above attempts made progress. -- This recursively rewrites the result and then adds to the cache finish :: Bool -- add to the cache? + -- Precondition: True ==> input coercion has + -- no coercion holes -> Reduction -> RewriteM Reduction finish use_cache redn = do { -- rewrite the result: FINISH 1 final_redn <- rewrite_reduction redn ; eq_rel <- getEqRel - ; flavour <- getFlavour -- extend the cache: FINISH 2 - ; when (use_cache && eq_rel == NomEq && flavour /= Derived) $ + ; when (use_cache && eq_rel == NomEq) $ -- the cache only wants Nominal eqs - -- and Wanteds can rewrite Deriveds; the cache - -- has only Givens liftTcS $ extendFamAppCache tc tys final_redn ; return final_redn } {-# INLINE finish #-} @@ -1034,32 +990,35 @@ rewrite_tyvar2 :: TcTyVar -> CtFlavourRole -> RewriteM RewriteTvResult rewrite_tyvar2 tv fr@(_, eq_rel) = do { ieqs <- liftTcS $ getInertEqs ; case lookupDVarEnv ieqs tv of - Just (EqualCtList (ct :| _)) -- If the first doesn't work, - -- the subsequent ones won't either - | CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv + Just equal_ct_list + | Just ct <- find can_rewrite equal_ct_list + , CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct - , let ct_fr = (ctEvFlavour ctev, ct_eq_rel) - , ct_fr `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR - -> do { traceRewriteM "Following inert tyvar" - (ppr tv <+> - equals <+> - ppr rhs_ty $$ ppr ctev) - ; let rewriting_co1 = ctEvCoercion ctev - rewriting_co = case (ct_eq_rel, eq_rel) of - (ReprEq, _rel) -> assert (_rel == ReprEq ) - -- if this ASSERT fails, then + -> do { let wrw = isWantedCt ct + ; traceRewriteM "Following inert tyvar" $ + vcat [ ppr tv <+> equals <+> ppr rhs_ty + , ppr ctev + , text "wanted_rewrite_wanted:" <+> ppr wrw ] + ; when wrw $ recordRewriter ctev + + ; let rewriting_co1 = ctEvCoercion ctev + rewriting_co = case (ct_eq_rel, eq_rel) of + (ReprEq, _rel) -> assert (_rel == ReprEq) + -- if this assert fails, then -- eqCanRewriteFR answered incorrectly rewriting_co1 (NomEq, NomEq) -> rewriting_co1 (NomEq, ReprEq) -> mkSubCo rewriting_co1 - ; return $ RTRFollowed $ mkReduction rewriting_co rhs_ty } - -- NB: ct is Derived then fmode must be also, hence - -- we are not going to touch the returned coercion - -- so ctEvCoercion is fine. + ; return $ RTRFollowed $ mkReduction rewriting_co rhs_ty } _other -> return RTRNotFollowed } + where + can_rewrite :: Ct -> Bool + can_rewrite ct = ctFlavourRole ct `eqCanRewriteFR` fr + -- This is THE key call of eqCanRewriteFR + {- Note [An alternative story for the inert substitution] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Solver/Types.hs b/compiler/GHC/Tc/Solver/Types.hs index 1b367e450e..d7a46a7c61 100644 --- a/compiler/GHC/Tc/Solver/Types.hs +++ b/compiler/GHC/Tc/Solver/Types.hs @@ -1,14 +1,12 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | Utility types used within the constraint solver module GHC.Tc.Solver.Types ( -- Inert CDictCans - DictMap, emptyDictMap, findDictsByClass, addDict, addDictCt, + DictMap, emptyDictMap, findDictsByClass, addDict, addDictsByClass, delDict, foldDicts, filterDicts, findDict, dictsToBag, partitionDicts, @@ -19,9 +17,7 @@ module GHC.Tc.Solver.Types ( insertTcApp, alterTcApp, filterTcAppMap, tcAppMapToBag, foldTcAppMap, - EqualCtList, pattern EqualCtList, - equalCtListToList, filterEqualCtList, unitEqualCtList, - listToEqualCtList, addToEqualCtList, + EqualCtList, filterEqualCtList, addToEqualCtList ) where import GHC.Prelude @@ -39,12 +35,10 @@ import GHC.Core.TyCon.Env import GHC.Data.Bag import GHC.Data.Maybe import GHC.Data.TrieMap +import GHC.Utils.Constants import GHC.Utils.Outputable import GHC.Utils.Panic - -import Data.Foldable -import Data.List.NonEmpty ( NonEmpty(..), nonEmpty, cons ) -import qualified Data.List.NonEmpty as NE +import GHC.Utils.Panic.Plain {- ********************************************************************* * * @@ -157,26 +151,6 @@ delDict m cls tys = delTcApp m (classTyCon cls) tys addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a addDict m cls tys item = insertTcApp m (classTyCon cls) tys item -addDictCt :: DictMap Ct -> TyCon -> [Type] -> Ct -> DictMap Ct --- Like addDict, but combines [W] and [D] to [WD] --- See Note [KeepBoth] in GHC.Tc.Solver.Interact -addDictCt m tc tys new_ct = alterTcApp m tc tys xt_ct - where - new_ct_ev = ctEvidence new_ct - - xt_ct :: Maybe Ct -> Maybe Ct - xt_ct (Just old_ct) - | CtWanted { ctev_nosh = WOnly } <- old_ct_ev - , CtDerived {} <- new_ct_ev - = Just (old_ct { cc_ev = old_ct_ev { ctev_nosh = WDeriv }}) - | CtDerived {} <- old_ct_ev - , CtWanted { ctev_nosh = WOnly } <- new_ct_ev - = Just (new_ct { cc_ev = new_ct_ev { ctev_nosh = WDeriv }}) - where - old_ct_ev = ctEvidence old_ct - - xt_ct _ = Just new_ct - addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct addDictsByClass m cls items = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items) @@ -213,7 +187,7 @@ We must /not/ solve this from the Given (?x::Int, C a), because of the intervening binding for (?x::Int). #14218. We deal with this by arranging that we always fail when looking up a -tuple constraint that hides an implicit parameter. Not that this applies +tuple constraint that hides an implicit parameter. Note that this applies * both to the inert_dicts (lookupInertDict) * and to the solved_dicts (looukpSolvedDict) An alternative would be not to extend these sets with such tuple @@ -263,7 +237,7 @@ findFunEq m tc tys = findTcApp m tc tys findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] -- Get inert function equation constraints that have the given tycon -- in their head. Not that the constraints remain in the inert set. --- We use this to check for derived interactions with built-in type-function +-- We use this to check for wanted interactions with built-in type-function -- constructors. findFunEqsByTyCon m tc | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm [] @@ -281,52 +255,48 @@ insertFunEq m tc tys val = insertTcApp m tc tys val * * ********************************************************************* -} -{- Note [EqualCtList invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- +Note [EqualCtList invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * All are equalities * All these equalities have the same LHS - * The list is never empty * No element of the list can rewrite any other - * Derived before Wanted - -From the fourth invariant it follows that the list is - - A single [G], or - - Zero or one [D] or [WD], followed by any number of [W] -The Wanteds can't rewrite anything which is why we put them last +Accordingly, this list is either empty, contains one element, or +contains a Given representational equality and a Wanted nominal one. -} -newtype EqualCtList = MkEqualCtList (NonEmpty Ct) - deriving newtype Outputable +type EqualCtList = [Ct] -- See Note [EqualCtList invariants] --- | Pattern synonym for easy unwrapping. NB: unidirectional to --- preserve invariants. -pattern EqualCtList :: NonEmpty Ct -> EqualCtList -pattern EqualCtList cts <- MkEqualCtList cts -{-# COMPLETE EqualCtList #-} - -unitEqualCtList :: Ct -> EqualCtList -unitEqualCtList ct = MkEqualCtList (ct :| []) - addToEqualCtList :: Ct -> EqualCtList -> EqualCtList --- NB: This function maintains the "derived-before-wanted" invariant of EqualCtList, --- but not the others. See Note [EqualCtList invariants] -addToEqualCtList ct (MkEqualCtList old_eqs) - | isWantedCt ct - , eq1 :| eqs <- old_eqs - = MkEqualCtList (eq1 :| ct : eqs) +-- See Note [EqualCtList invariants] +addToEqualCtList ct old_eqs + | debugIsOn + = case ct of + CEqCan { cc_lhs = TyVarLHS tv } -> + let shares_lhs (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv + shares_lhs _other = False + in + assert (all shares_lhs old_eqs) $ + assert (null ([ (ct1, ct2) | ct1 <- ct : old_eqs + , ct2 <- ct : old_eqs + , let { fr1 = ctFlavourRole ct1 + ; fr2 = ctFlavourRole ct2 } + , fr1 `eqCanRewriteFR` fr2 ])) $ + (ct : old_eqs) + + _ -> pprPanic "addToEqualCtList not CEqCan" (ppr ct) + | otherwise - = MkEqualCtList (ct `cons` old_eqs) + = ct : old_eqs +-- returns Nothing when the new list is empty, to keep the environments smaller filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList -filterEqualCtList pred (MkEqualCtList cts) - = fmap MkEqualCtList (nonEmpty $ NE.filter pred cts) - -equalCtListToList :: EqualCtList -> [Ct] -equalCtListToList (MkEqualCtList cts) = toList cts - -listToEqualCtList :: [Ct] -> Maybe EqualCtList --- NB: This does not maintain invariants other than having the EqualCtList be --- non-empty -listToEqualCtList cts = MkEqualCtList <$> nonEmpty cts +filterEqualCtList pred cts + | null new_list + = Nothing + | otherwise + = Just new_list + where + new_list = filter pred cts diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index e184bd178f..3c2ba8a9b3 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -3224,11 +3224,6 @@ addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () -- F c x y a :: Type -- Here the first arg of F should be the same as the third of C -- and the fourth arg of F should be the same as the first of C --- --- We emit /Derived/ constraints (a bit like fundeps) to encourage --- unification to happen, but without actually reporting errors. --- If, despite the efforts, corresponding positions do not match, --- checkConsistentFamInst will complain addConsistencyConstraints mb_clsinfo fam_app | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app @@ -3236,8 +3231,9 @@ addConsistencyConstraints mb_clsinfo fam_app | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ] ; traceTc "addConsistencyConstraints" (ppr eqs) - ; emitDerivedEqs AssocFamPatOrigin eqs } - -- Improve inference + ; emitWantedEqs AssocFamPatOrigin eqs } + -- Improve inference; these equalities will not produce errors. + -- See Note [Constraints to ignore] in GHC.Tc.Errors -- Any mis-match is reports by checkConsistentFamInst | otherwise = return () diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 65a2887049..699c50c54b 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -1951,8 +1951,9 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind -- checking instance-sig <= class-meth-sig -- The instance-sig is the focus here; the class-meth-sig -- is fixed (#18036) + ; let orig = InstanceSigOrigin sel_name sig_ty local_meth_ty ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $ - tcSubTypeSigma ctxt sig_ty local_meth_ty + tcSubTypeSigma orig ctxt sig_ty local_meth_ty ; return (sig_ty, hs_wrap) } ; inner_meth_name <- newName (nameOccName sel_name) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 26ffe9116e..8091869187 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -316,7 +316,7 @@ and is not implicitly instantiated. So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and marginally less efficient, if the builder/martcher are not inlined. -See also Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType +See also Note [Lift equality constraints when quantifying] in GHC.Tc.Solver Note [Coercions that escape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -474,7 +474,8 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details -- Else the error message location is wherever tcCheckPat finished, -- namely the right-hand corner of the pattern do { arg_id <- tcLookupId arg_name - ; wrap <- tcSubTypeSigma GenSigCtxt + ; wrap <- tcSubTypeSigma (OccurrenceOf (idName arg_id)) + GenSigCtxt (idType arg_id) (substTy subst arg_ty) -- Why do we need tcSubType here? diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index b49bc718cd..776d0f40fb 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -277,7 +277,7 @@ instance ContainsModule gbl => ContainsModule (Env gbl lcl) where -- (i.e. type family reductions and following filled-in metavariables) -- in the solver. data RewriteEnv - = FE { fe_loc :: !CtLoc + = RE { re_loc :: !CtLoc -- ^ In which context are we rewriting? -- -- Type-checking plugins might want to use this location information @@ -288,11 +288,12 @@ data RewriteEnv -- Within GHC, we use this field to keep track of reduction depth. -- See Note [Rewriter CtLoc] in GHC.Tc.Solver.Rewrite. - , fe_flavour :: !CtFlavour - , fe_eq_rel :: !EqRel + , re_flavour :: !CtFlavour + , re_eq_rel :: !EqRel -- ^ At what role are we rewriting? -- -- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite + , re_rewriters :: !(TcRef RewriterSet) -- ^ See Note [Wanteds rewrite Wanteds] } -- RewriteEnv is mostly used in @GHC.Tc.Solver.Rewrite@, but it is defined -- here so that it can also be passed to rewriting plugins. @@ -1667,12 +1668,11 @@ Constraint Solver Plugins ------------------------- -} --- | The @solve@ function of a type-checking plugin takes in Given, Derived +-- | The @solve@ function of a type-checking plugin takes in Given -- and Wanted constraints, and should return a 'TcPluginSolveResult' -- indicating which Wanted constraints it could solve, or whether any are -- insoluble. type TcPluginSolver = [Ct] -- ^ Givens - -> [Ct] -- ^ Deriveds -> [Ct] -- ^ Wanteds -> TcPluginM TcPluginSolveResult diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs index f1d59bf04b..8bd29b7bd5 100644 --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -15,22 +17,23 @@ module GHC.Tc.Types.Constraint ( singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, isEmptyCts, isPendingScDict, superClassesMightHelp, getPendingWantedScs, - isWantedCt, isDerivedCt, isGivenCt, - isUserTypeErrorCt, getUserTypeErrorMsg, - ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, + isWantedCt, isGivenCt, + isUserTypeError, getUserTypeErrorMsg, + ctEvidence, ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, + ctRewriters, ctEvId, mkTcEqPredLikeEv, mkNonCanonical, mkNonCanonicalCt, mkGivens, mkIrredCt, ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, + ctEvRewriters, tyCoVarsOfCt, tyCoVarsOfCts, tyCoVarsOfCtList, tyCoVarsOfCtsList, - ambigTkvsOfCt, - CtIrredReason(..), HoleSet, isInsolubleReason, + CtIrredReason(..), isInsolubleReason, CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck, - cteOK, cteImpredicative, cteTypeFamily, cteHoleBlocker, + cteOK, cteImpredicative, cteTypeFamily, cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble, cterHasNoProblem, cterHasProblem, cterHasOnlyProblem, cterRemoveProblem, cterHasOccursCheck, cterFromKind, @@ -43,10 +46,9 @@ module GHC.Tc.Types.Constraint ( WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC, addInsols, dropMisleading, addSimples, addImplics, addHoles, - tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, + tyCoVarsOfWC, tyCoVarsOfWCList, insolubleWantedCt, insolubleEqCt, insolubleCt, - isDroppableCt, insolubleImplic, - arisesFromGivens, + insolubleImplic, Implication(..), implicationPrototype, checkTelescopeSkol, ImplicStatus(..), isInsolubleStatus, isSolvedStatus, @@ -63,15 +65,22 @@ module GHC.Tc.Types.Constraint ( -- CtEvidence CtEvidence(..), TcEvDest(..), mkKindLoc, toKindLoc, mkGivenLoc, - isWanted, isGiven, isDerived, - ctEvRole, setCtEvPredType, + isWanted, isGiven, + ctEvRole, setCtEvPredType, setCtEvLoc, arisesFromGivens, + tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList, + ctEvUnique, tcEvDestUnique, + isHoleDestPred, + + RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet, + -- exported concretely only for anyUnfilledCoercionHoles + rewriterSetFromType, rewriterSetFromTypes, rewriterSetFromCo, + addRewriterSet, wrapType, - CtFlavour(..), ShadowInfo(..), ctFlavourContainsDerived, ctEvFlavour, + CtFlavour(..), ctEvFlavour, CtFlavourRole, ctEvFlavourRole, ctFlavourRole, - eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR, - eqCanDischargeFR, + eqCanRewrite, eqCanRewriteFR, -- Pretty printing pprEvVarTheta, @@ -104,6 +113,8 @@ import GHC.Utils.FV import GHC.Types.Var.Set import GHC.Driver.Session import GHC.Types.Basic +import GHC.Types.Unique +import GHC.Types.Unique.Set import GHC.Utils.Outputable import GHC.Types.SrcLoc @@ -113,13 +124,15 @@ import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Trace +import Data.Coerce +import Data.Monoid ( Endo(..) ) +import qualified Data.Semigroup as S import Control.Monad ( msum, when ) -import qualified Data.Semigroup ( (<>) ) -import Data.Maybe( mapMaybe ) +import Data.Maybe ( mapMaybe ) -- these are for CheckTyEqResult import Data.Word ( Word8 ) -import Data.List ( intersperse, partition ) +import Data.List ( intersperse ) @@ -226,8 +239,6 @@ data Ct -- to give best chance of -- unification happening; eg if rhs is touchable then lhs is too -- Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify - -- * (TyEq:H) The RHS has no blocking coercion holes. See GHC.Tc.Solver.Canonical - -- Note [Equalities with incompatible kinds], wrinkle (2) cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_lhs :: CanEqLHS, cc_rhs :: Xi, -- See invariants above @@ -337,18 +348,9 @@ data CtIrredReason = IrredShapeReason -- ^ this constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@) - | HoleBlockerReason HoleSet - -- ^ this constraint is blocked on the coercion hole(s) listed - -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical - -- Wrinkle (4a). Why store the HoleSet? See Wrinkle (2) of that - -- same Note. - -- INVARIANT: A HoleBlockerReason constraint is a homogeneous equality whose - -- left hand side can fit in a CanEqLHS. - | NonCanonicalReason CheckTyEqResult -- ^ an equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied; -- the 'CheckTyEqResult' states exactly why - -- INVARIANT: the 'CheckTyEqResult' has some bit set other than cteHoleBlocker | ReprEqReason -- ^ an equality that cannot be decomposed because it is representational. @@ -369,7 +371,6 @@ data CtIrredReason instance Outputable CtIrredReason where ppr IrredShapeReason = text "(irred)" - ppr (HoleBlockerReason holes) = parens (text "blocked on" <+> ppr holes) ppr (NonCanonicalReason cter) = ppr cter ppr ReprEqReason = text "(repr)" ppr ShapeMismatchReason = text "(shape)" @@ -378,7 +379,6 @@ instance Outputable CtIrredReason where -- | Are we sure that more solving will never solve this constraint? isInsolubleReason :: CtIrredReason -> Bool isInsolubleReason IrredShapeReason = False -isInsolubleReason (HoleBlockerReason {}) = False isInsolubleReason (NonCanonicalReason cter) = cterIsInsoluble cter isInsolubleReason ReprEqReason = False isInsolubleReason ShapeMismatchReason = True @@ -406,14 +406,11 @@ cterHasNoProblem _ = False -- | An individual problem that might be logged in a 'CheckTyEqResult' newtype CheckTyEqProblem = CTEP Word8 -cteImpredicative, cteTypeFamily, cteHoleBlocker, cteInsolubleOccurs, - cteSolubleOccurs :: CheckTyEqProblem +cteImpredicative, cteTypeFamily, cteInsolubleOccurs, cteSolubleOccurs :: CheckTyEqProblem cteImpredicative = CTEP (bit 0) -- forall or (=>) encountered cteTypeFamily = CTEP (bit 1) -- type family encountered -cteHoleBlocker = CTEP (bit 2) -- blocking coercion hole - -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical -cteInsolubleOccurs = CTEP (bit 3) -- occurs-check -cteSolubleOccurs = CTEP (bit 4) -- occurs-check under a type function or in a coercion +cteInsolubleOccurs = CTEP (bit 2) -- occurs-check +cteSolubleOccurs = CTEP (bit 3) -- occurs-check under a type function or in a coercion -- must be one bit to the left of cteInsolubleOccurs -- See also Note [Insoluble occurs check] in GHC.Tc.Errors @@ -477,7 +474,6 @@ instance Outputable CheckTyEqResult where where all_bits = [ (cteImpredicative, "cteImpredicative") , (cteTypeFamily, "cteTypeFamily") - , (cteHoleBlocker, "cteHoleBlocker") , (cteInsolubleOccurs, "cteInsolubleOccurs") , (cteSolubleOccurs, "cteSolubleOccurs") ] set_bits = [ text str @@ -579,9 +575,6 @@ ctEvidence ct = cc_ev ct ctLoc :: Ct -> CtLoc ctLoc = ctEvLoc . ctEvidence -setCtLoc :: Ct -> CtLoc -> Ct -setCtLoc ct loc = ct { cc_ev = (cc_ev ct) { ctev_loc = loc } } - ctOrigin :: Ct -> CtOrigin ctOrigin = ctLocOrigin . ctLoc @@ -589,6 +582,9 @@ ctPred :: Ct -> PredType -- See Note [Ct/evidence invariant] ctPred ct = ctEvPred (ctEvidence ct) +ctRewriters :: Ct -> RewriterSet +ctRewriters = ctEvRewriters . ctEvidence + ctEvId :: Ct -> EvVar -- The evidence Id for this Ct ctEvId ct = ctEvEvId (ctEvidence ct) @@ -677,11 +673,20 @@ eqCanEqLHS _ _ = False tyCoVarsOfCt :: Ct -> TcTyCoVarSet tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt --- | Returns free variables of constraints as a deterministically ordered. --- list. See Note [Deterministic FV] in "GHC.Utils.FV". +-- | Returns free variables of constraints as a non-deterministic set +tyCoVarsOfCtEv :: CtEvidence -> TcTyCoVarSet +tyCoVarsOfCtEv = fvVarSet . tyCoFVsOfCtEv + +-- | Returns free variables of constraints as a deterministically ordered +-- list. See Note [Deterministic FV] in GHC.Utils.FV. tyCoVarsOfCtList :: Ct -> [TcTyCoVar] tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt +-- | Returns free variables of constraints as a deterministically ordered +-- list. See Note [Deterministic FV] in GHC.Utils.FV. +tyCoVarsOfCtEvList :: CtEvidence -> [TcTyCoVar] +tyCoVarsOfCtEvList = fvVarList . tyCoFVsOfType . ctEvPred + -- | Returns free variables of constraints as a composable FV computation. -- See Note [Deterministic FV] in "GHC.Utils.FV". tyCoFVsOfCt :: Ct -> FV @@ -690,6 +695,11 @@ tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) -- constraint has been tidied. Tidying a constraint does not tidy the -- fields of the Ct, only the predicate in the CtEvidence. +-- | Returns free variables of constraints as a composable FV computation. +-- See Note [Deterministic FV] in GHC.Utils.FV. +tyCoFVsOfCtEv :: CtEvidence -> FV +tyCoFVsOfCtEv ct = tyCoFVsOfType (ctEvPred ct) + -- | Returns free variables of a bag of constraints as a non-deterministic -- set. See Note [Deterministic FV] in "GHC.Utils.FV". tyCoVarsOfCts :: Cts -> TcTyCoVarSet @@ -700,11 +710,21 @@ tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts +-- | Returns free variables of a bag of constraints as a deterministically +-- ordered list. See Note [Deterministic FV] in GHC.Utils.FV. +tyCoVarsOfCtEvsList :: [CtEvidence] -> [TcTyCoVar] +tyCoVarsOfCtEvsList = fvVarList . tyCoFVsOfCtEvs + -- | Returns free variables of a bag of constraints as a composable FV -- computation. See Note [Deterministic FV] in "GHC.Utils.FV". tyCoFVsOfCts :: Cts -> FV tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV +-- | Returns free variables of a bag of constraints as a composable FV +-- computation. See Note [Deterministic FV] in GHC.Utils.FV. +tyCoFVsOfCtEvs :: [CtEvidence] -> FV +tyCoFVsOfCtEvs = foldr (unionFV . tyCoFVsOfCtEv) emptyFV + -- | Returns free variables of WantedConstraints as a non-deterministic -- set. See Note [Deterministic FV] in "GHC.Utils.FV". tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet @@ -746,149 +766,10 @@ tyCoFVsOfHole (Hole { hole_ty = ty }) = tyCoFVsOfType ty tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV -ambigTkvsOfCt :: Ct -> ([Var],[Var]) -ambigTkvsOfCt ct - = partition (`elemVarSet` dep_tkv_set) ambig_tkvs - where - tkvs = tyCoVarsOfCtList ct - ambig_tkvs = filter isAmbiguousTyVar tkvs - dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) - ---------------------------- -dropDerivedWC :: WantedConstraints -> WantedConstraints --- See Note [Dropping derived constraints] -dropDerivedWC wc@(WC { wc_simple = simples }) - = wc { wc_simple = dropDerivedSimples simples } - -- The wc_impl implications are already (recursively) filtered - --------------------------- -dropDerivedSimples :: Cts -> Cts --- Drop all Derived constraints, but make [W] back into [WD], --- so that if we re-simplify these constraints we will get all --- the right derived constraints re-generated. Forgetting this --- step led to #12936 -dropDerivedSimples simples = mapMaybeBag dropDerivedCt simples - -dropDerivedCt :: Ct -> Maybe Ct -dropDerivedCt ct - = case ctEvFlavour ev of - Wanted WOnly -> Just (ct' { cc_ev = ev_wd }) - Wanted _ -> Just ct' - _ | isDroppableCt ct -> Nothing - | otherwise -> Just ct - where - ev = ctEvidence ct - ev_wd = ev { ctev_nosh = WDeriv } - ct' = setPendingScDict ct -- See Note [Resetting cc_pend_sc] - -{- Note [Resetting cc_pend_sc] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we discard Derived constraints, in dropDerivedSimples, we must -set the cc_pend_sc flag to True, so that if we re-process this -CDictCan we will re-generate its derived superclasses. Otherwise -we might miss some fundeps. #13662 showed this up. - -See Note [The superclass story] in GHC.Tc.Solver.Canonical. --} - -isDroppableCt :: Ct -> Bool -isDroppableCt ct - = isDerived ev && not keep_deriv - -- Drop only derived constraints, and then only if they - -- obey Note [Dropping derived constraints] - where - ev = ctEvidence ct - loc = ctEvLoc ev - orig = ctLocOrigin loc - - keep_deriv - = case ct of - CIrredCan { cc_reason = reason } | isInsolubleReason reason -> keep_eq True - _ -> keep_eq False - - keep_eq definitely_insoluble - | isGivenOrigin orig -- Arising only from givens - = definitely_insoluble -- Keep only definitely insoluble - | otherwise - = case orig of - -- See Note [Dropping derived constraints] - -- For fundeps, drop wanted/wanted interactions - FunDepOrigin2 {} -> True -- Top-level/Wanted - FunDepOrigin1 _ orig1 _ _ orig2 _ - | g1 || g2 -> True -- Given/Wanted errors: keep all - | otherwise -> False -- Wanted/Wanted errors: discard - where - g1 = isGivenOrigin orig1 - g2 = isGivenOrigin orig2 - - _ -> False - -arisesFromGivens :: Ct -> Bool -arisesFromGivens ct - = case ctEvidence ct of - CtGiven {} -> True - CtWanted {} -> False - CtDerived { ctev_loc = loc } -> isGivenLoc loc - isGivenLoc :: CtLoc -> Bool isGivenLoc loc = isGivenOrigin (ctLocOrigin loc) -{- Note [Dropping derived constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we discard derived constraints at the end of constraint solving; -see dropDerivedWC. For example - - * Superclasses: if we have an unsolved [W] (Ord a), we don't want to - complain about an unsolved [D] (Eq a) as well. - - * If we have [W] a ~ Int, [W] a ~ Bool, improvement will generate - [D] Int ~ Bool, and we don't want to report that because it's - incomprehensible. That is why we don't rewrite wanteds with wanteds! - - * We might float out some Wanteds from an implication, leaving behind - their insoluble Deriveds. For example: - - forall a[2]. [W] alpha[1] ~ Int - [W] alpha[1] ~ Bool - [D] Int ~ Bool - - The Derived is insoluble, but we very much want to drop it when floating - out. - -But (tiresomely) we do keep *some* Derived constraints: - - * Type holes are derived constraints, because they have no evidence - and we want to keep them, so we get the error report - - * We keep most derived equalities arising from functional dependencies - - Given/Given interactions (subset of FunDepOrigin1): - The definitely-insoluble ones reflect unreachable code. - - Others not-definitely-insoluble ones like [D] a ~ Int do not - reflect unreachable code; indeed if fundeps generated proofs, it'd - be a useful equality. See #14763. So we discard them. - - - Given/Wanted interacGiven or Wanted interacting with an - instance declaration (FunDepOrigin2) - - - Given/Wanted interactions (FunDepOrigin1); see #9612 - - - But for Wanted/Wanted interactions we do /not/ want to report an - error (#13506). Consider [W] C Int Int, [W] C Int Bool, with - a fundep on class C. We don't want to report an insoluble Int~Bool; - c.f. "wanteds do not rewrite wanteds". - -To distinguish these cases we use the CtOrigin. - -NB: we keep *all* derived insolubles under some circumstances: - - * They are looked at by simplifyInfer, to decide whether to - generalise. Example: [W] a ~ Int, [W] a ~ Bool - We get [D] Int ~ Bool, and indeed the constraints are insoluble, - and we want simplifyInfer to see that, even though we don't - ultimately want to generate an (inexplicable) error message from it - - +{- ************************************************************************ * * CtEvidence @@ -903,9 +784,6 @@ isWantedCt = isWanted . ctEvidence isGivenCt :: Ct -> Bool isGivenCt = isGiven . ctEvidence -isDerivedCt :: Ct -> Bool -isDerivedCt = isDerived . ctEvidence - {- Note [Custom type errors in constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -936,27 +814,24 @@ Eq (F (TypeError msg)) -- Here the type error is nested under a type-function -- | A constraint is considered to be a custom type error, if it contains -- custom type errors anywhere in it. -- See Note [Custom type errors in constraints] -getUserTypeErrorMsg :: Ct -> Maybe Type -getUserTypeErrorMsg ct = findUserTypeError (ctPred ct) +getUserTypeErrorMsg :: PredType -> Maybe Type +getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred + : map getUserTypeErrorMsg (subTys pred) where - findUserTypeError t = msum ( userTypeError_maybe t - : map findUserTypeError (subTys t) - ) - - subTys t = case splitAppTys t of - (t,[]) -> - case splitTyConApp_maybe t of + -- Richard thinks this function is very broken. What is subTys + -- supposed to be doing? Why are exactly-saturated tyconapps special? + -- What stops this from accidentally ripping apart a call to TypeError? + subTys t = case splitAppTys t of + (t,[]) -> + case splitTyConApp_maybe t of Nothing -> [] Just (_,ts) -> ts - (t,ts) -> t : ts + (t,ts) -> t : ts - - - -isUserTypeErrorCt :: Ct -> Bool -isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of - Just _ -> True - _ -> False +isUserTypeError :: PredType -> Bool +isUserTypeError pred = case getUserTypeErrorMsg pred of + Just _ -> True + _ -> False isPendingScDict :: Ct -> Maybe Ct -- Says whether this is a CDictCan with cc_pend_sc is True, @@ -971,12 +846,6 @@ isPendingScInst qci@(QCI { qci_pend_sc = True }) = Just (qci { qci_pend_sc = False }) isPendingScInst _ = Nothing -setPendingScDict :: Ct -> Ct --- Set the cc_pend_sc flag to True -setPendingScDict ct@(CDictCan { cc_pend_sc = False }) - = ct { cc_pend_sc = True } -setPendingScDict ct = ct - superClassesMightHelp :: WantedConstraints -> Bool -- ^ True if taking superclasses of givens, or of wanteds (to perhaps -- expose more equalities or functional dependencies) might help to @@ -988,7 +857,7 @@ superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics }) | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic) | otherwise = False - might_help_ct ct = isWantedCt ct && not (is_ip ct) + might_help_ct ct = not (is_ip ct) is_ip (CDictCan { cc_class = cls }) = isIPClass cls is_ip _ = False @@ -1017,16 +886,11 @@ Note that implication. E.g. forall a. Ord a => forall b. [W] Eq a - * Superclasses help only for Wanted constraints. Derived constraints - are not really "unsolved" and we certainly don't want them to - trigger superclass expansion. This was a good part of the loop - in #11523 - - * Even for Wanted constraints, we say "no" for implicit parameters. + * We say "no" for implicit parameters. we have [W] ?x::ty, expanding superclasses won't help: - Superclasses can't be implicit parameters - If we have a [G] ?x:ty2, then we'll have another unsolved - [D] ty ~ ty2 (from the functional dependency) + [W] ty ~ ty2 (from the functional dependency) which will trigger superclass expansion. It's a bit of a special case, but it's easy to do. The runtime cost @@ -1082,13 +946,8 @@ pprCts cts = vcat (map ppr (bagToList cts)) ************************************************************************ * * Wanted constraints - These are forced to be in GHC.Tc.Types because - TcLclEnv mentions WantedConstraints - WantedConstraint mentions CtLoc - CtLoc mentions ErrCtxt - ErrCtxt mentions TcM * * -v%************************************************************************ +************************************************************************ -} data WantedConstraints @@ -1192,10 +1051,12 @@ insolubleWantedCt :: Ct -> Bool -- a) an insoluble constraint as per 'insolubleCt', i.e. either -- - an insoluble equality constraint (e.g. Int ~ Bool), or -- - a custom type error constraint, TypeError msg :: Constraint --- b) that does not arise from a Given +-- b) that does not arise from a Given or a Wanted/Wanted fundep interaction -- -- See Note [Given insolubles]. -insolubleWantedCt ct = insolubleCt ct && not (arisesFromGivens ct) +insolubleWantedCt ct = insolubleCt ct && + not (arisesFromGivens ct) && + not (isWantedWantedFunDepOrigin (ctOrigin ct)) insolubleEqCt :: Ct -> Bool -- Returns True of /equality/ constraints @@ -1283,12 +1144,6 @@ because that'll suppress reports of [W] C b (f b). But we may not report the insoluble [G] f b ~# b either (see Note [Given errors] in GHC.Tc.Errors), so we may fail to report anything at all! Yikes. -The same applies to Derived constraints that /arise from/ Givens. -E.g. f :: (C Int [a]) => blah -where a fundep means we get - [D] Int ~ [a] -By the same reasoning we must not suppress other errors (#15767) - Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus) should ignore givens even if they are insoluble. @@ -1632,12 +1487,6 @@ At the end, we will hopefully have substituted uf1 := F alpha, and we will be able to report a more informative error: 'Can't construct the infinite type beta ~ F alpha beta' -Insoluble constraints *do* include Derived constraints. For example, -a functional dependency might give rise to [D] Int ~ Bool, and we must -report that. If insolubles did not contain Deriveds, reportErrors would -never see it. - - ************************************************************************ * * Invariant checking (debug only) @@ -1876,17 +1725,10 @@ data CtEvidence | CtWanted -- Wanted goal - { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] - , ctev_dest :: TcEvDest -- See Note [CtEvidence invariants] - , ctev_nosh :: ShadowInfo -- See Note [Constraint flavours] - , ctev_loc :: CtLoc } - - | CtDerived -- A goal that we don't really have to solve and can't - -- immediately rewrite anything other than a derived - -- (there's no evidence!) but if we do manage to solve - -- it may help in solving other goals. - { ctev_pred :: TcPredType - , ctev_loc :: CtLoc } + { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] + , ctev_dest :: TcEvDest -- See Note [CtEvidence invariants] + , ctev_loc :: CtLoc + , ctev_rewriters :: RewriterSet } -- See Note [Wanteds rewrite Wanteds] ctEvPred :: CtEvidence -> TcPredType -- The predicate of a flavor @@ -1909,6 +1751,14 @@ ctEvRole = eqRelRole . ctEvEqRel ctEvTerm :: CtEvidence -> EvTerm ctEvTerm ev = EvExpr (ctEvExpr ev) +-- | Extract the set of rewriters from a 'CtEvidence' +-- See Note [Wanteds rewrite Wanteds] +-- If the provided CtEvidence is not for a Wanted, just +-- return an empty set. +ctEvRewriters :: CtEvidence -> RewriterSet +ctEvRewriters (CtWanted { ctev_rewriters = rewriters }) = rewriters +ctEvRewriters _other = emptyRewriterSet + ctEvExpr :: CtEvidence -> EvExpr ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ }) = Coercion $ ctEvCoercion ev @@ -1929,34 +1779,64 @@ ctEvEvId :: CtEvidence -> EvVar ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev ctEvEvId (CtWanted { ctev_dest = HoleDest h }) = coHoleCoVar h ctEvEvId (CtGiven { ctev_evar = ev }) = ev -ctEvEvId ctev@(CtDerived {}) = pprPanic "ctEvId:" (ppr ctev) + +ctEvUnique :: CtEvidence -> Unique +ctEvUnique (CtGiven { ctev_evar = ev }) = varUnique ev +ctEvUnique (CtWanted { ctev_dest = dest }) = tcEvDestUnique dest + +tcEvDestUnique :: TcEvDest -> Unique +tcEvDestUnique (EvVarDest ev_var) = varUnique ev_var +tcEvDestUnique (HoleDest co_hole) = varUnique (coHoleCoVar co_hole) + +setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence +setCtEvLoc ctev loc = ctev { ctev_loc = loc } + +arisesFromGivens :: Ct -> Bool +arisesFromGivens ct = isGivenCt ct || isGivenLoc (ctLoc ct) -- | Set the type of CtEvidence. -- -- This function ensures that the invariants on 'CtEvidence' hold, by updating -- the evidence and the ctev_pred in sync with each other. -- See Note [CtEvidence invariants] -setCtEvPredType :: CtEvidence -> Type -> CtEvidence +setCtEvPredType :: CtEvidence -> PredType -> CtEvidence setCtEvPredType old_ctev new_pred = case old_ctev of CtGiven { ctev_evar = ev, ctev_loc = loc } -> CtGiven { ctev_pred = new_pred - , ctev_evar = setVarType ev new_pred + , ctev_evar = setVarType ev new_var_type , ctev_loc = loc } - CtWanted { ctev_dest = dest, ctev_nosh = nosh, ctev_loc = loc } -> - CtWanted { ctev_pred = new_pred - , ctev_dest = new_dest - , ctev_nosh = nosh - , ctev_loc = loc + CtWanted { ctev_dest = dest, ctev_loc = loc, ctev_rewriters = rewriters } -> + CtWanted { ctev_pred = new_pred + , ctev_dest = new_dest + , ctev_loc = loc + , ctev_rewriters = rewriters } where new_dest = case dest of - EvVarDest ev -> EvVarDest (setVarType ev new_pred) - HoleDest h -> HoleDest (setCoHoleType h new_pred) - CtDerived { ctev_loc = loc } -> - CtDerived { ctev_pred = new_pred - , ctev_loc = loc - } + EvVarDest ev -> EvVarDest (setVarType ev new_var_type) + HoleDest h -> HoleDest (setCoHoleType h new_var_type) + where + new_var_type + -- Gotcha: Concrete# constraints have evidence of a different type + -- than the predicate type + | SpecialPred ConcretePrimPred new_concrete_ty <- classifyPredType new_pred + = mkHeteroPrimEqPred (typeKind new_concrete_ty) k2 new_concrete_ty t2 + + | otherwise + = new_pred + + where + -- This is gross. But it will be short-lived, once we re-design + -- Concrete# constraints. + old_var = case old_ctev of + CtGiven { ctev_evar = evar } -> evar + CtWanted { ctev_dest = HoleDest h } -> coHoleCoVar h + CtWanted { ctev_dest = EvVarDest {} } -> + pprPanic "setCtEvPredType" (ppr old_ctev $$ ppr new_pred) + + (_k1, k2, _t1, t2, _role) = coVarKindsTypesRole old_var + instance Outputable TcEvDest where ppr (HoleDest h) = text "hole" <> ppr h @@ -1964,14 +1844,17 @@ instance Outputable TcEvDest where instance Outputable CtEvidence where ppr ev = ppr (ctEvFlavour ev) - <+> pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev))) + <+> pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)) <> pp_rewriters) -- Show the sub-goal depth too <> dcolon <+> ppr (ctEvPred ev) where pp_ev = case ev of CtGiven { ctev_evar = v } -> ppr v CtWanted {ctev_dest = d } -> ppr d - CtDerived {} -> text "_" + + rewriters = ctEvRewriters ev + pp_rewriters | isEmptyRewriterSet rewriters = empty + | otherwise = semi <> ppr rewriters isWanted :: CtEvidence -> Bool isWanted (CtWanted {}) = True @@ -1981,72 +1864,88 @@ isGiven :: CtEvidence -> Bool isGiven (CtGiven {}) = True isGiven _ = False -isDerived :: CtEvidence -> Bool -isDerived (CtDerived {}) = True -isDerived _ = False +-- | When creating a constraint for the given predicate, should +-- it get a 'HoleDest'? True for equalities and Concrete# constraints +-- only. See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete +isHoleDestPred :: PredType -> Bool +isHoleDestPred pty = case classifyPredType pty of + EqPred {} -> True + SpecialPred ConcretePrimPred _ -> True + _ -> False + {- -%************************************************************************ -%* * - CtFlavour -%* * -%************************************************************************ +************************************************************************ +* * + RewriterSet +* * +************************************************************************ +-} -Note [Constraint flavours] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Constraints come in four flavours: +-- | Stores a set of CoercionHoles that have been used to rewrite a constraint. +-- See Note [Wanteds rewrite Wanteds]. +newtype RewriterSet = RewriterSet (UniqSet CoercionHole) + deriving newtype (Outputable, Semigroup, Monoid) -* [G] Given: we have evidence +emptyRewriterSet :: RewriterSet +emptyRewriterSet = RewriterSet emptyUniqSet -* [W] Wanted WOnly: we want evidence +isEmptyRewriterSet :: RewriterSet -> Bool +isEmptyRewriterSet (RewriterSet set) = isEmptyUniqSet set -* [D] Derived: any solution must satisfy this constraint, but - we don't need evidence for it. Examples include: - - superclasses of [W] class constraints - - equalities arising from functional dependencies - or injectivity +addRewriterSet :: RewriterSet -> CoercionHole -> RewriterSet +addRewriterSet = coerce (addOneToUniqSet @CoercionHole) -* [WD] Wanted WDeriv: a single constraint that represents - both [W] and [D] - We keep them paired as one both for efficiency +-- | Makes a 'RewriterSet' from all the coercion holes that occur in the +-- given coercion. +rewriterSetFromCo :: Coercion -> RewriterSet +rewriterSetFromCo co = appEndo (rewriter_set_from_co co) emptyRewriterSet -The ctev_nosh field of a Wanted distinguishes between [W] and [WD] +-- | Makes a 'RewriterSet' from all the coercion holes that occur in the +-- given type. +rewriterSetFromType :: Type -> RewriterSet +rewriterSetFromType ty = appEndo (rewriter_set_from_ty ty) emptyRewriterSet -Wanted constraints are born as [WD], but are split into [W] and its -"shadow" [D] in GHC.Tc.Solver.Monad.maybeEmitShadow. +-- | Makes a 'RewriterSet' from all the coercion holes that occur in the +-- given types. +rewriterSetFromTypes :: [Type] -> RewriterSet +rewriterSetFromTypes tys = appEndo (rewriter_set_from_tys tys) emptyRewriterSet -See Note [The improvement story and derived shadows] in GHC.Tc.Solver.Monad +rewriter_set_from_ty :: Type -> Endo RewriterSet +rewriter_set_from_tys :: [Type] -> Endo RewriterSet +rewriter_set_from_co :: Coercion -> Endo RewriterSet +(rewriter_set_from_ty, rewriter_set_from_tys, rewriter_set_from_co, _) + = foldTyCo folder () + where + folder :: TyCoFolder () (Endo RewriterSet) + folder = TyCoFolder + { tcf_view = noView + , tcf_tyvar = \ _ tv -> rewriter_set_from_ty (tyVarKind tv) + , tcf_covar = \ _ cv -> rewriter_set_from_ty (varType cv) + , tcf_hole = \ _ hole -> coerce (`addOneToUniqSet` hole) S.<> + rewriter_set_from_ty (varType (coHoleCoVar hole)) + , tcf_tycobinder = \ _ _ _ -> () } + +{- +************************************************************************ +* * + CtFlavour +* * +************************************************************************ -} -data CtFlavour -- See Note [Constraint flavours] - = Given - | Wanted ShadowInfo - | Derived +data CtFlavour + = Given -- we have evidence + | Wanted -- we want evidence deriving Eq -data ShadowInfo - = WDeriv -- [WD] This Wanted constraint has no Derived shadow, - -- so it behaves like a pair of a Wanted and a Derived - | WOnly -- [W] It has a separate derived shadow - -- See Note [The improvement story and derived shadows] in GHC.Tc.Solver.Monad - deriving( Eq ) - instance Outputable CtFlavour where - ppr Given = text "[G]" - ppr (Wanted WDeriv) = text "[WD]" - ppr (Wanted WOnly) = text "[W]" - ppr Derived = text "[D]" - --- | Does this 'CtFlavour' subsumed 'Derived'? True of @[WD]@ and @[D]@. -ctFlavourContainsDerived :: CtFlavour -> Bool -ctFlavourContainsDerived (Wanted WDeriv) = True -ctFlavourContainsDerived Derived = True -ctFlavourContainsDerived _ = False + ppr Given = text "[G]" + ppr Wanted = text "[W]" ctEvFlavour :: CtEvidence -> CtFlavour -ctEvFlavour (CtWanted { ctev_nosh = nosh }) = Wanted nosh -ctEvFlavour (CtGiven {}) = Given -ctEvFlavour (CtDerived {}) = Derived +ctEvFlavour (CtWanted {}) = Wanted +ctEvFlavour (CtGiven {}) = Given -- | Whether or not one 'Ct' can rewrite another is determined by its -- flavour and its equality relation. See also @@ -2078,11 +1977,11 @@ With the solver handling Coercible constraints like equality constraints, the rewrite conditions must take role into account, never allowing a representational equality to rewrite a nominal one. -Note [Wanteds do not rewrite Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't allow Wanteds to rewrite Wanteds, because that can give rise -to very confusing type error messages. A good example is #8450. -Here's another +Note [Wanteds rewrite Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should one Wanted constraint be allowed to rewrite another? + +This example (along with #8450) suggests not: f :: a -> Bool f x = ( [x,'c'], [x,True] ) `seq` True Here we get @@ -2090,79 +1989,134 @@ Here we get [W] a ~ Bool but we do not want to complain about Bool ~ Char! -Note [Deriveds do rewrite Deriveds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -However we DO allow Deriveds to rewrite Deriveds, because that's how -improvement works; see Note [The improvement story and derived shadows] in -GHC.Tc.Solver.Interact. - -However, for now at least I'm only letting (Derived,NomEq) rewrite -(Derived,NomEq) and not doing anything for ReprEq. If we have - eqCanRewriteFR (Derived, NomEq) (Derived, _) = True -then we lose property R2 of Definition [Can-rewrite relation] -in GHC.Tc.Solver.Monad - R2. If f1 >= f, and f2 >= f, +This example suggests yes (indexed-types/should_fail/T4093a): + type family Foo a + f :: (Foo e ~ Maybe e) => Foo e +In the ambiguity check, we get + [G] g1 :: Foo e ~ Maybe e + [W] w1 :: Foo alpha ~ Foo e + [W] w2 :: Foo alpha ~ Maybe alpha +w1 gets rewritten by the Given to become + [W] w3 :: Foo alpha ~ Maybe e +Now, the only way to make progress is to allow Wanteds to rewrite Wanteds. +Rewriting w3 with w2 gives us + [W] w4 :: Maybe alpha ~ Maybe e +which will soon get us to alpha := e and thence to victory. + +TL;DR we want equality saturation. + +We thus want Wanteds to rewrite Wanteds in order to accept more programs, +but we don't want Wanteds to rewrite Wanteds because doing so can create +inscrutable error messages. We choose to allow the rewriting, but +every Wanted tracks the set of Wanteds it has been rewritten by. This is +called a RewriterSet, stored in the ctev_rewriters field of the CtWanted +constructor of CtEvidence. (Only Wanteds have RewriterSets.) + +Let's continue our first example above: + + inert: [W] w1 :: a ~ Char + work: [W] w2 :: a ~ Bool + +Because Wanteds can rewrite Wanteds, w1 will rewrite w2, yielding + + inert: [W] w1 :: a ~ Char + [W] w2 {w1}:: Char ~ Bool + +The {w1} in the second line of output is the RewriterSet of w1. + +A RewriterSet is just a set of unfilled CoercionHoles. This is +sufficient because only equalities (evidenced by coercion holes) are +used for rewriting; other (dictionary) constraints cannot ever +rewrite. The rewriter (in e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks +and returns a RewriterSet, consisting of the evidence (a CoercionHole) +for any Wanted equalities used in rewriting. Then rewriteEvidence and +rewriteEqEvidence (in GHC.Tc.Solver.Canonical) add this RewriterSet to +the rewritten constraint's rewriter set. + +In error reporting, we simply suppress any errors that have been rewritten by +/unsolved/ wanteds. This suppression happens in GHC.Tc.Errors.mkErrorItem, which +uses GHC.Tc.Utils.anyUnfilledCoercionHoles to look through any filled coercion +holes. The idea is that we wish to report the "root cause" -- the error that +rewrote all the others. + +Worry: It seems possible that *all* unsolved wanteds are rewritten by other +unsolved wanteds, so that e.g. w1 has w2 in its rewriter set, and w2 has +w1 in its rewiter set. We are unable to come up with an example of this in +practice, however, and so we believe this case cannot happen. + +Note [Avoiding rewriting cycles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet describes +the can-rewrite relation among CtFlavour/Role pairs, saying which constraints +can rewrite which other constraints. It puts forth (R2): + (R2) If f1 >= f, and f2 >= f, then either f1 >= f2 or f2 >= f1 -Consider f1 = (Given, ReprEq) - f2 = (Derived, NomEq) - f = (Derived, ReprEq) +The naive can-rewrite relation says that (Given, Representational) can rewrite +(Wanted, Representational) and that (Wanted, Nominal) can rewrite +(Wanted, Representational), but neither of (Given, Representational) and +(Wanted, Nominal) can rewrite the other. This would violate (R2). See also +Note [Why R2?] in GHC.Tc.Solver.InertSet. -I thought maybe we could never get Derived ReprEq constraints, but -we can; straight from the Wanteds during improvement. And from a Derived -ReprEq we could conceivably get a Derived NomEq improvement (by decomposing -a type constructor with Nomninal role), and hence unify. - -This restriction that (Derived, NomEq) cannot rewrite (Derived, ReprEq) bites, -in an obscure scenario: +To keep R2, we do not allow (Wanted, Nominal) to rewrite (Wanted, Representational). +This can, in theory, bite, in this scenario: + type family F a data T a type role T nominal - type family F a - - g :: forall b a. (F a ~ T a, Coercible (F a) (T b)) => () - g = () - - f :: forall a. (F a ~ T a) => () - f = g @a - -The problem is in the body of f. We have - - [G] F a ~N T a - [WD] F alpha ~N T alpha - [WD] F alpha ~R T a - -The Wanteds aren't of use, so let's just look at Deriveds: - [G] F a ~N T a - [D] F alpha ~N T alpha - [D] F alpha ~R T a + [W] F alpha ~N T alpha + [W] F alpha ~R T a As written, this makes no progress, and GHC errors. But, if we -allowed D/N to rewrite D/R, the first D could rewrite the second: +allowed W/N to rewrite W/R, the first W could rewrite the second: [G] F a ~N T a - [D] F alpha ~N T alpha - [D] T alpha ~R T a + [W] F alpha ~N T alpha + [W] T alpha ~R T a -Now we decompose the second D to get +Now we decompose the second W to get - [D] alpha ~N a + [W] alpha ~N a noting the role annotation on T. This causes (alpha := a), and then everything else unlocks. What to do? We could "decompose" nominal equalities into nominal-only ("NO") equalities and representational ones, where a NO equality rewrites -only nominals. That is, when considering whether [D] F alpha ~N T alpha -should rewrite [D] F alpha ~R T a, we could require splitting the first D -into [D] F alpha ~NO T alpha, [D] F alpha ~R T alpha. Then, we use the R -half of the split to rewrite the second D, and off we go. This splitting +only nominals. That is, when considering whether [W] F alpha ~N T alpha +should rewrite [W] F alpha ~R T a, we could require splitting the first W +into [W] F alpha ~NO T alpha, [W] F alpha ~R T alpha. Then, we use the R +half of the split to rewrite the second W, and off we go. This splitting would allow the split-off R equality to be rewritten by other equalities, thus avoiding the problem in Note [Why R2?] in GHC.Tc.Solver.InertSet. -This infelicity is #19665 and tested in typecheck/should_compile/T19665 -(marked as expect_broken). +However, note that I said that this bites in theory. That's because no +known program actually gives rise to this scenario. A direct encoding +ends up starting with + + [G] F a ~ T a + [W] F alpha ~ T alpha + [W] Coercible (F alpha) (T a) + +where ~ and Coercible denote lifted class constraints. The ~s quickly +reduce to ~N: good. But the Coercible constraint gets rewritten to + + [W] Coercible (T alpha) (T a) + +by the first Wanted. This is because Coercible is a class, and arguments +in class constraints use *nominal* rewriting, not the representational +rewriting that is restricted due to (R2). Note that reordering the code +doesn't help, because equalities (including lifted ones) are prioritized +over Coercible. Thus, I (Richard E.) see no way to write a program that +is rejected because of this infelicity. I have not proved it impossible, +exactly, but my usual tricks have not yielded results. + +In the olden days, when we had Derived constraints, this Note was all +about G/R and D/N both rewriting D/R. Back then, the code in +typecheck/should_compile/T19665 really did get rejected. But now, +according to the rewriting of the Coercible constraint, the program +is accepted. -} @@ -2175,54 +2129,12 @@ eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool -- Can fr1 actually rewrite fr2? -- Very important function! -- See Note [eqCanRewrite] --- See Note [Wanteds do not rewrite Wanteds] --- See Note [Deriveds do rewrite Deriveds] -eqCanRewriteFR (Given, r1) (_, r2) = eqCanRewrite r1 r2 -eqCanRewriteFR (Wanted WDeriv, NomEq) (Derived, NomEq) = True -eqCanRewriteFR (Derived, NomEq) (Derived, NomEq) = True -eqCanRewriteFR _ _ = False - -eqMayRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool --- Is it /possible/ that fr1 can rewrite fr2? --- This is used when deciding which inerts to kick out, --- at which time a [WD] inert may be split into [W] and [D] -eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True -eqMayRewriteFR (Derived, NomEq) (Wanted WDeriv, NomEq) = True -eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2 - -{- Note [eqCanDischarge] -~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have two identical CEqCan equality constraints -(i.e. both LHS and RHS are the same) - (x1:lhs~t) `eqCanDischarge` (xs:lhs~t) -Can we just drop x2 in favour of x1? - -Answer: yes if eqCanDischarge is true. - -Note that we do /not/ allow Wanted to discharge Derived. -We must keep both. Why? Because the Derived may rewrite -other Deriveds in the model whereas the Wanted cannot. - -However a Wanted can certainly discharge an identical Wanted. So -eqCanDischarge does /not/ define a can-rewrite relation in the -sense of Definition [Can-rewrite relation] in GHC.Tc.Solver.Monad. - -We /do/ say that a [W] can discharge a [WD]. In evidence terms it -certainly can, and the /caller/ arranges that the otherwise-lost [D] -is spat out as a new Derived. -} - -eqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool --- See Note [eqCanDischarge] -eqCanDischargeFR (f1,r1) (f2, r2) = eqCanRewrite r1 r2 - && eqCanDischargeF f1 f2 - -eqCanDischargeF :: CtFlavour -> CtFlavour -> Bool -eqCanDischargeF Given _ = True -eqCanDischargeF (Wanted _) (Wanted _) = True -eqCanDischargeF (Wanted WDeriv) Derived = True -eqCanDischargeF Derived Derived = True -eqCanDischargeF _ _ = False - +-- See Note [Wanteds rewrite Wanteds] +-- See Note [Avoiding rewriting cycles] +eqCanRewriteFR (Given, r1) (_, r2) = eqCanRewrite r1 r2 +eqCanRewriteFR (Wanted, NomEq) (Wanted, ReprEq) = False +eqCanRewriteFR (Wanted, r1) (Wanted, r2) = eqCanRewrite r1 r2 +eqCanRewriteFR (Wanted, _) (Given, _) = False {- ************************************************************************ @@ -2306,14 +2218,13 @@ subGoalDepthExceeded dflags (SubGoalDepth d) The 'CtLoc' gives information about where a constraint came from. This is important for decent error message reporting because dictionaries don't appear in the original source code. -type will evolve... -} -data CtLoc = CtLoc { ctl_origin :: CtOrigin - , ctl_env :: TcLclEnv - , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure - , ctl_depth :: !SubGoalDepth } +data CtLoc = CtLoc { ctl_origin :: CtOrigin + , ctl_env :: TcLclEnv + , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure + , ctl_depth :: !SubGoalDepth } -- The TcLclEnv includes particularly -- source location: tcl_loc :: RealSrcSpan @@ -2333,10 +2244,10 @@ toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } mkGivenLoc :: TcLevel -> SkolemInfoAnon -> TcLclEnv -> CtLoc mkGivenLoc tclvl skol_info env - = CtLoc { ctl_origin = GivenOrigin skol_info - , ctl_env = setLclEnvTcLevel env tclvl - , ctl_t_or_k = Nothing -- this only matters for error msgs - , ctl_depth = initialSubGoalDepth } + = CtLoc { ctl_origin = GivenOrigin skol_info + , ctl_env = setLclEnvTcLevel env tclvl + , ctl_t_or_k = Nothing -- this only matters for error msgs + , ctl_depth = initialSubGoalDepth } ctLocEnv :: CtLoc -> TcLclEnv ctLocEnv = ctl_env diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs index 8bbc1ac260..cf083b3c6f 100644 --- a/compiler/GHC/Tc/Types/Evidence.hs +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -790,7 +790,7 @@ Important Details: - GHC should NEVER report an insoluble CallStack constraint. - GHC should NEVER infer a CallStack constraint unless one was requested - with a partial type signature (See TcType.pickQuantifiablePreds). + with a partial type signature (See GHC.Tc.Solver..pickQuantifiablePreds). - A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)], where the String is the name of the binder that is used at the diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 7edd94439b..2733ddd5ba 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -21,7 +20,8 @@ module GHC.Tc.Types.Origin ( -- CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, isVisibleOrigin, toInvisibleOrigin, - pprCtOrigin, isGivenOrigin, + pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin, + isWantedSuperclassOrigin, TypedThing(..), TyVarBndrs(..), @@ -516,6 +516,8 @@ data CtOrigin | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc | AssocFamPatOrigin -- When matching the patterns of an associated -- family instance with that of its parent class + -- IMPORTANT: These constraints will never cause errors; + -- See Note [Constraints to ignore] in GHC.Tc.Errors | SectionOrigin | HasFieldOrigin FastString | TupleOrigin -- (..,..) @@ -574,7 +576,11 @@ data CtOrigin -- We only need a CtOrigin on the first, because the location -- is pinned on the entire error message - | ExprHoleOrigin OccName -- from an expression hole + | InjTFOrigin1 -- injective type family equation combining + PredType CtOrigin RealSrcSpan -- This constraint arising from ... + PredType CtOrigin RealSrcSpan -- and this constraint arising from ... + + | ExprHoleOrigin (Maybe OccName) -- from an expression hole | TypeHoleOrigin OccName -- from a type hole (partial type signature) | PatCheckOrigin -- normalisation of a type during pattern-match checking | ListOrigin -- An overloaded list @@ -582,9 +588,8 @@ data CtOrigin | BracketOrigin -- An overloaded quotation bracket | StaticOrigin -- A static form | Shouldn'tHappenOrigin String - -- the user should never see this one, - -- unless ImpredicativeTypes is on, where all - -- bets are off + -- the user should never see this one + | GhcBug20076 -- see #20076 -- | Testing whether the constraint associated with an instance declaration -- in a signature file is satisfied upon instantiation. @@ -605,6 +610,17 @@ data CtOrigin -- We record it here for access in 'GHC.Tc.Errors.mkFRRErr'. !FRROrigin + | WantedSuperclassOrigin PredType CtOrigin + -- From expanding out the superclasses of a Wanted; the PredType + -- is the subclass predicate, and the origin + -- of the original Wanted is the CtOrigin + + | InstanceSigOrigin -- from the sub-type check of an InstanceSig + Name -- the method name + Type -- the instance-sig type + Type -- the instantiated type of the method + | AmbiguityCheckOrigin UserTypeCtxt + -- | 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. @@ -629,11 +645,23 @@ isGivenOrigin :: CtOrigin -> Bool isGivenOrigin (GivenOrigin {}) = True isGivenOrigin (InstSCOrigin {}) = True isGivenOrigin (OtherSCOrigin {}) = True -isGivenOrigin (FunDepOrigin1 _ o1 _ _ o2 _) = isGivenOrigin o1 && isGivenOrigin o2 -isGivenOrigin (FunDepOrigin2 _ o1 _ _) = isGivenOrigin o1 isGivenOrigin (CycleBreakerOrigin o) = isGivenOrigin o isGivenOrigin _ = False +-- See Note [Suppressing confusing errors] in GHC.Tc.Errors +isWantedWantedFunDepOrigin :: CtOrigin -> Bool +isWantedWantedFunDepOrigin (FunDepOrigin1 _ orig1 _ _ orig2 _) + = not (isGivenOrigin orig1) && not (isGivenOrigin orig2) +isWantedWantedFunDepOrigin (InjTFOrigin1 _ orig1 _ _ orig2 _) + = not (isGivenOrigin orig1) && not (isGivenOrigin orig2) +isWantedWantedFunDepOrigin _ = False + +-- | Did a constraint arise from expanding a Wanted constraint +-- to look at superclasses? +isWantedSuperclassOrigin :: CtOrigin -> Bool +isWantedSuperclassOrigin (WantedSuperclassOrigin {}) = True +isWantedSuperclassOrigin _ = False + instance Outputable CtOrigin where ppr = pprCtOrigin @@ -705,7 +733,6 @@ lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" pprCtOrigin :: CtOrigin -> SDoc -- "arising from ..." --- Not an instance of Outputable because of the "arising from" prefix pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk pprCtOrigin (InstSCOrigin {}) = ctoHerald <+> pprSkolInfo InstSkol -- keep output in sync pprCtOrigin (OtherSCOrigin _ si) = ctoHerald <+> pprSkolInfo si @@ -728,11 +755,17 @@ pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) , hang (text "instance" <+> quotes (ppr pred2)) 2 (text "at" <+> ppr loc2) ]) +pprCtOrigin (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) + = hang (ctoHerald <+> text "reasoning about an injective type family using constraints:") + 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtOrigin orig1 <+> text "at" <+> ppr loc1) + , hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ]) + pprCtOrigin AssocFamPatOrigin = text "when matching a family LHS with its class instance head" pprCtOrigin (TypeEqOrigin { uo_actual = t1, uo_expected = t2, uo_visible = vis }) - = text "a type equality" <> brackets (ppr vis) <+> sep [ppr t1, char '~', ppr t2] + = hang (ctoHerald <+> text "a type equality" <> whenPprDebug (brackets (ppr vis))) + 2 (sep [ppr t1, char '~', ppr t2]) pprCtOrigin (KindEqOrigin t1 t2 _ _) = hang (ctoHerald <+> text "a kind equality arising from") @@ -761,13 +794,18 @@ pprCtOrigin (MCompPatOrigin pat) , text "in a statement in a monad comprehension" ] pprCtOrigin (Shouldn'tHappenOrigin note) - = sdocOption sdocImpredicativeTypes $ \case - True -> text "a situation created by impredicative types" - False -> vcat [ text "<< This should not appear in error messages. If you see this" - , text "in an error message, please report a bug mentioning" - <+> quotes (text note) <+> text "at" - , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>" - ] + = vcat [ text "<< This should not appear in error messages. If you see this" + , text "in an error message, please report a bug mentioning" + <+> quotes (text note) <+> text "at" + , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>" + ] + +pprCtOrigin GhcBug20076 + = vcat [ text "GHC Bug #20076 <https://gitlab.haskell.org/ghc/ghc/-/issues/20076>" + , text "Assuming you have a partial type signature, you can avoid this error" + , text "by either adding an extra-constraints wildcard (like `(..., _) => ...`," + , text "with the underscore at the end of the constraint), or by avoiding the" + , text "use of a simplifiable constraint in your partial type signature." ] pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") @@ -787,6 +825,22 @@ pprCtOrigin (FixedRuntimeRepOrigin _ frrOrig) -- in 'GHC.Tc.Errors.mkFRRErr'. = pprFRROrigin frrOrig +pprCtOrigin (WantedSuperclassOrigin subclass_pred subclass_orig) + = sep [ ctoHerald <+> text "a superclass required to satisfy" <+> quotes (ppr subclass_pred) <> comma + , pprCtOrigin subclass_orig ] + +pprCtOrigin (InstanceSigOrigin method_name sig_type orig_method_type) + = vcat [ ctoHerald <+> text "the check that an instance signature is more general" + , text "than the type of the method (instantiated for this instance)" + , hang (text "instance signature:") + 2 (ppr method_name <+> dcolon <+> ppr sig_type) + , hang (text "instantiated method type:") + 2 (ppr orig_method_type) ] + +pprCtOrigin (AmbiguityCheckOrigin ctxt) + = ctoHerald <+> text "a type ambiguity check for" $$ + pprUserTypeCtxt ctxt + pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin @@ -820,7 +874,8 @@ pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = text "a proc expression" pprCtO ArrowCmdOrigin = text "an arrow command" pprCtO AnnOrigin = text "an annotation" -pprCtO (ExprHoleOrigin occ) = text "a use of" <+> quotes (ppr occ) +pprCtO (ExprHoleOrigin Nothing) = text "an expression hole" +pprCtO (ExprHoleOrigin (Just occ)) = text "a use of" <+> quotes (ppr occ) pprCtO (TypeHoleOrigin occ) = text "a use of wildcard" <+> quotes (ppr occ) pprCtO PatCheckOrigin = text "a pattern-match completeness check" pprCtO ListOrigin = text "an overloaded list" @@ -839,6 +894,7 @@ pprCtO (OtherSCOrigin {}) = text "the superclass of a given constraint pprCtO (SpecPragOrigin {}) = text "a SPECIALISE pragma" pprCtO (FunDepOrigin1 {}) = text "a functional dependency" pprCtO (FunDepOrigin2 {}) = text "a functional dependency" +pprCtO (InjTFOrigin1 {}) = text "an injective type family" pprCtO (TypeEqOrigin {}) = text "a type equality" pprCtO (KindEqOrigin {}) = text "a kind equality" pprCtO (DerivOriginDC {}) = text "a deriving clause" @@ -850,6 +906,10 @@ pprCtO (ProvCtxtOrigin {}) = text "a provided constraint" pprCtO (InstProvidedOrigin {}) = text "a provided constraint" pprCtO (CycleBreakerOrigin orig) = pprCtO orig pprCtO (FixedRuntimeRepOrigin {}) = text "a representation polymorphism check" +pprCtO GhcBug20076 = text "GHC Bug #20076" +pprCtO (WantedSuperclassOrigin {}) = text "a superclass constraint" +pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance" +pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check" {- ********************************************************************* * * diff --git a/compiler/GHC/Tc/Utils/Concrete.hs b/compiler/GHC/Tc/Utils/Concrete.hs index 0b20a1af9d..bee886a58f 100644 --- a/compiler/GHC/Tc/Utils/Concrete.hs +++ b/compiler/GHC/Tc/Utils/Concrete.hs @@ -15,8 +15,8 @@ import GHC.Core.Coercion import GHC.Core.TyCo.Rep import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcType ( TcType, mkTyConApp ) -import GHC.Tc.Utils.TcMType ( newCoercionHole, newFlexiTyVarTy ) +import GHC.Tc.Utils.TcType ( mkTyConApp ) +import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin ( CtOrigin(..), FRROrigin(..), WpFunOrigin(..) ) @@ -402,11 +402,6 @@ There are, however, some interactions to take into account: Examples: backpack/should_run/T13955.bkp, rep-poly/RepPolyBackpack2. -} --- | A coercion hole used to store evidence for `Concrete#` constraints. --- --- See Note [The Concrete mechanism]. -type ConcreteHole = CoercionHole - -- | Evidence for a `Concrete#` constraint: -- essentially a 'ConcreteHole' (a coercion hole) that will be filled later, -- except: @@ -458,42 +453,32 @@ hasFixedRuntimeRep frrOrig ty -- Create a new Wanted 'Concrete#' constraint and emit it. | otherwise -> do { loc <- getCtLocM (FixedRuntimeRepOrigin ty frrOrig) (Just KindLevel) - ; (hole, ct_ev) <- newConcretePrimWanted loc ki + ; (hole, _, ct_ev) <- newConcretePrimWanted loc ki ; emitSimple $ mkNonCanonical ct_ev ; return $ ConcreteHoleEvidence hole } } where ki :: Kind ki = typeKind ty --- | Create a new (initially unfilled) coercion hole, --- to hold evidence for a @'Concrete#' (ty :: ki)@ constraint. -newConcreteHole :: Kind -- ^ Kind of the thing we want to ensure is concrete (e.g. 'runtimeRepTy') - -> Type -- ^ Thing we want to ensure is concrete (e.g. some 'RuntimeRep') - -> TcM ConcreteHole -newConcreteHole ki ty - = do { concrete_ty <- newFlexiTyVarTy ki - ; let co_ty = mkHeteroPrimEqPred ki ki ty concrete_ty - ; newCoercionHole co_ty } - -- | Create a new 'Concrete#' constraint. -newConcretePrimWanted :: CtLoc -> Type -> TcM (ConcreteHole, CtEvidence) +-- Returns the evidence, a metavariable which will be filled in with a +-- guaranteed-concrete type, and a Wanted CtEvidence +newConcretePrimWanted :: CtLoc -> Type -> TcM (ConcreteHole, TcType, CtEvidence) newConcretePrimWanted loc ty = do { let ki :: Kind ki = typeKind ty - ; hole <- newConcreteHole ki ty + ; (hole, concrete_ty) <- newConcreteHole ki ty ; let wantedCtEv :: CtEvidence wantedCtEv = CtWanted { ctev_dest = HoleDest hole , ctev_pred = mkTyConApp concretePrimTyCon [ki, ty] - , ctev_nosh = WOnly -- WOnly, because Derived Concrete# constraints - -- aren't useful: solving a Concrete# constraint - -- can't cause any unification to take place. + , ctev_rewriters = emptyRewriterSet , ctev_loc = loc } - ; return (hole, wantedCtEv) } + ; return (hole, concrete_ty, wantedCtEv) } {-*********************************************************************** * * diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 72670e6b06..a2720bc4e1 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -1261,10 +1261,10 @@ popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc getCtLocM origin t_or_k = do { env <- getLclEnv - ; return (CtLoc { ctl_origin = origin - , ctl_env = env - , ctl_t_or_k = t_or_k - , ctl_depth = initialSubGoalDepth }) } + ; return (CtLoc { ctl_origin = origin + , ctl_env = env + , ctl_t_or_k = t_or_k + , ctl_depth = initialSubGoalDepth }) } setCtLocM :: CtLoc -> TcM a -> TcM a -- Set the SrcSpan and error context from the CtLoc diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index 1ece974166..3c978b511c 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -37,9 +37,9 @@ module GHC.Tc.Utils.TcMType ( -------------------------------- -- Creating new evidence variables newEvVar, newEvVars, newDict, - newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, + newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv, emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, - emitDerivedEqs, + emitWantedEqs, newTcEvBinds, newNoTcEvBinds, addTcEvBind, emitNewExprHole, @@ -47,6 +47,8 @@ module GHC.Tc.Utils.TcMType ( unpackCoercionHole, unpackCoercionHole_maybe, checkCoercionHole, + ConcreteHole, newConcreteHole, + newImplication, -------------------------------- @@ -97,6 +99,10 @@ module GHC.Tc.Utils.TcMType ( ------------------------------ -- Representation polymorphism checkTypeHasFixedRuntimeRep, + + ------------------------------ + -- Other + anyUnfilledCoercionHoles ) where import GHC.Prelude @@ -192,12 +198,15 @@ newEvVar ty = do { name <- newSysName (predTypeOccName ty) -- | Create a new Wanted constraint with the given 'CtLoc'. newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence newWantedWithLoc loc pty - = do d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole pty - else EvVarDest <$> newEvVar pty - return $ CtWanted { ctev_dest = d - , ctev_pred = pty - , ctev_nosh = WDeriv - , ctev_loc = loc } + = do d <- case classifyPredType pty of + EqPred {} -> HoleDest <$> newCoercionHole pty + SpecialPred ConcretePrimPred ty -> + HoleDest <$> (fst <$> newConcreteHole (typeKind ty) ty) + _ -> EvVarDest <$> newEvVar pty + return $ CtWanted { ctev_dest = d + , ctev_pred = pty + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } -- | Create a new Wanted constraint with the given 'CtOrigin', and -- location information taken from the 'TcM' environment. @@ -216,13 +225,20 @@ newWanteds orig = mapM (newWanted orig Nothing) -- Cloning constraints ---------------------------------------------- -cloneWanted :: Ct -> TcM Ct -cloneWanted ct - | ev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ }) <- ctEvidence ct +cloneWantedCtEv :: CtEvidence -> TcM CtEvidence +cloneWantedCtEv ctev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ }) + | isEqPrimPred pty = do { co_hole <- newCoercionHole pty - ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) } + ; return (ctev { ctev_dest = HoleDest co_hole }) } + | SpecialPred ConcretePrimPred ty <- classifyPredType pty + = do { (co_hole, _) <- newConcreteHole (typeKind ty) ty + ; return (ctev { ctev_dest = HoleDest co_hole }) } | otherwise - = return ct + = pprPanic "cloneWantedCtEv" (ppr pty) +cloneWantedCtEv ctev = return ctev + +cloneWanted :: Ct -> TcM Ct +cloneWanted ct = mkNonCanonical <$> cloneWantedCtEv (ctEvidence ct) cloneWC :: WantedConstraints -> TcM WantedConstraints -- Clone all the evidence bindings in @@ -252,19 +268,13 @@ emitWanted origin pty ; emitSimple $ mkNonCanonical ev ; return $ ctEvTerm ev } -emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () --- Emit some new derived nominal equalities -emitDerivedEqs origin pairs +emitWantedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () +-- Emit some new wanted nominal equalities +emitWantedEqs origin pairs | null pairs = return () | otherwise - = do { loc <- getCtLocM origin Nothing - ; emitSimples (listToBag (map (mk_one loc) pairs)) } - where - mk_one loc (ty1, ty2) - = mkNonCanonical $ - CtDerived { ctev_pred = mkPrimEqPred ty1 ty2 - , ctev_loc = loc } + = mapM_ (uncurry (emitWantedEq origin TypeLevel Nominal)) pairs -- | Emits a new equality constraint emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion @@ -272,8 +282,10 @@ emitWantedEq origin t_or_k role ty1 ty2 = do { hole <- newCoercionHole pty ; loc <- getCtLocM origin (Just t_or_k) ; emitSimple $ mkNonCanonical $ - CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole - , ctev_nosh = WDeriv, ctev_loc = loc } + CtWanted { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = rewriterSetFromTypes [ty1, ty2] } ; return (HoleCo hole) } where pty = mkPrimEqPredRole role ty1 ty2 @@ -284,10 +296,10 @@ emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar emitWantedEvVar origin ty = do { new_cv <- newEvVar ty ; loc <- getCtLocM origin Nothing - ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv - , ctev_pred = ty - , ctev_nosh = WDeriv - , ctev_loc = loc } + ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv + , ctev_pred = ty + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } ; emitSimple $ mkNonCanonical ctev ; return new_cv } @@ -302,7 +314,7 @@ emitNewExprHole occ ty ; ref <- newTcRef (pprPanic "unfilled unbound-variable evidence" (ppr u)) ; let her = HER ref ty u - ; loc <- getCtLocM (ExprHoleOrigin occ) (Just TypeLevel) + ; loc <- getCtLocM (ExprHoleOrigin (Just occ)) (Just TypeLevel) ; let hole = Hole { hole_sort = ExprHole her , hole_occ = occ @@ -353,7 +365,7 @@ newImplication newCoercionHole :: TcPredType -> TcM CoercionHole newCoercionHole pred_ty = do { co_var <- newEvVar pred_ty - ; traceTc "New coercion hole:" (ppr co_var) + ; traceTc "New coercion hole:" (ppr co_var <+> dcolon <+> ppr pred_ty) ; ref <- newMutVar Nothing ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } } @@ -411,6 +423,24 @@ checkCoercionHole cv co | otherwise = False +-- | A coercion hole used to store evidence for `Concrete#` constraints. +-- +-- See Note [The Concrete mechanism]. +type ConcreteHole = CoercionHole + +-- | Create a new (initially unfilled) coercion hole, +-- to hold evidence for a @'Concrete#' (ty :: ki)@ constraint. +newConcreteHole :: Kind -- ^ Kind of the thing we want to ensure is concrete (e.g. 'runtimeRepTy') + -> Type -- ^ Thing we want to ensure is concrete (e.g. some 'RuntimeRep') + -> TcM (ConcreteHole, TcType) + -- ^ where to put the evidence, and a metavariable to store + -- the concrete type +newConcreteHole ki ty + = do { concrete_ty <- newFlexiTyVarTy ki + ; let co_ty = mkHeteroPrimEqPred ki ki ty concrete_ty + ; hole <- newCoercionHole co_ty + ; return (hole, concrete_ty) } + {- ********************************************************************** * ExpType functions @@ -2465,14 +2495,11 @@ zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys zonkSkolemInfoAnon skol_info = return skol_info {- -%************************************************************************ -%* * -\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} +************************************************************************ * * -* For internal use only! * + Zonking -- the main work-horses: zonkTcType, zonkTcTyVar * * ************************************************************************ - -} -- For unbound, mutable tyvars, zonkType uses the function given to it @@ -2620,13 +2647,21 @@ zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k) ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, p2') <- zonkTidyTcType env1 p2 - ; return (env2, FunDepOrigin1 p1' o1 l1 p2' o2 l2) } + ; (env2, o1') <- zonkTidyOrigin env1 o1 + ; (env3, p2') <- zonkTidyTcType env2 p2 + ; (env4, o2') <- zonkTidyOrigin env3 o2 + ; return (env4, FunDepOrigin1 p1' o1' l1 p2' o2' l2) } zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) = do { (env1, p1') <- zonkTidyTcType env p1 ; (env2, p2') <- zonkTidyTcType env1 p2 ; (env3, o1') <- zonkTidyOrigin env2 o1 ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } +zonkTidyOrigin env (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) + = do { (env1, pred1') <- zonkTidyTcType env pred1 + ; (env2, orig1') <- zonkTidyOrigin env1 orig1 + ; (env3, pred2') <- zonkTidyTcType env2 pred2 + ; (env4, orig2') <- zonkTidyOrigin env3 orig2 + ; return (env4, InjTFOrigin1 pred1' orig1' loc1 pred2' orig2' loc2) } zonkTidyOrigin env (CycleBreakerOrigin orig) = do { (env1, orig') <- zonkTidyOrigin env orig ; return (env1, CycleBreakerOrigin orig') } @@ -2636,6 +2671,10 @@ zonkTidyOrigin env (InstProvidedOrigin mod cls_inst) zonkTidyOrigin env (FixedRuntimeRepOrigin ty frr_orig) = do { (env1, ty') <- zonkTidyTcType env ty ; return (env1, FixedRuntimeRepOrigin ty' frr_orig)} +zonkTidyOrigin env (WantedSuperclassOrigin pty orig) + = do { (env1, pty') <- zonkTidyTcType env pty + ; (env2, orig') <- zonkTidyOrigin env1 orig + ; return (env2, WantedSuperclassOrigin pty' orig') } zonkTidyOrigin env orig = return (env, orig) zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> TcM (TidyEnv, [CtOrigin]) @@ -2644,13 +2683,14 @@ zonkTidyOrigins = mapAccumLM zonkTidyOrigin ---------------- tidyCt :: TidyEnv -> Ct -> Ct -- Used only in error reporting -tidyCt env ct - = ct { cc_ev = tidy_ev (ctEvidence ct) } - where - tidy_ev :: CtEvidence -> CtEvidence +tidyCt env ct = ct { cc_ev = tidyCtEvidence env (ctEvidence ct) } + +tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence -- NB: we do not tidy the ctev_evar field because we don't -- show it in error messages - tidy_ev ctev = ctev { ctev_pred = tidyType env (ctev_pred ctev) } +tidyCtEvidence env ctev = ctev { ctev_pred = tidyType env ty } + where + ty = ctev_pred ctev tidyHole :: TidyEnv -> Hole -> Hole tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty } @@ -2728,3 +2768,49 @@ naughtyQuantification orig_ty tv escapees ] ; failWithTcM (env, msg) } + +{- +************************************************************************ +* * + Checking for coercion holes +* * +************************************************************************ +-} + +-- | Check whether any coercion hole in a RewriterSet is still unsolved. +-- Does this by recursively looking through filled coercion holes until +-- one is found that is not yet filled in, at which point this aborts. +anyUnfilledCoercionHoles :: RewriterSet -> TcM Bool +anyUnfilledCoercionHoles (RewriterSet set) + = nonDetStrictFoldUniqSet go (return False) set + -- this does not introduce non-determinism, because the only + -- monadic action is to read, and the combining function is + -- commutative + where + go :: CoercionHole -> TcM Bool -> TcM Bool + go hole m_acc = m_acc <||> check_hole hole + + check_hole :: CoercionHole -> TcM Bool + check_hole hole = do { m_co <- unpackCoercionHole_maybe hole + ; case m_co of + Nothing -> return True -- unfilled hole + Just co -> unUCHM (check_co co) } + + check_ty :: Type -> UnfilledCoercionHoleMonoid + check_co :: Coercion -> UnfilledCoercionHoleMonoid + (check_ty, _, check_co, _) = foldTyCo folder () + + folder :: TyCoFolder () UnfilledCoercionHoleMonoid + folder = TyCoFolder { tcf_view = noView + , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv) + , tcf_covar = \ _ cv -> check_ty (varType cv) + , tcf_hole = \ _ -> UCHM . check_hole + , tcf_tycobinder = \ _ _ _ -> () } + +newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: TcM Bool } + +instance Semigroup UnfilledCoercionHoleMonoid where + UCHM l <> UCHM r = UCHM (l <||> r) + +instance Monoid UnfilledCoercionHoleMonoid where + mempty = UCHM (return False) diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index ae35cea3a2..807ad0ab56 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -92,11 +92,12 @@ module GHC.Tc.Utils.TcType ( orphNamesOfType, orphNamesOfCo, orphNamesOfTypes, orphNamesOfCoCon, getDFunTyKey, evVarPred, + ambigTkvsOfTy, --------------------------------- -- Predicate types mkMinimalBySCs, transSuperClasses, - pickQuantifiablePreds, pickCapturedPreds, + pickCapturedPreds, immSuperClasses, boxEqPred, isImprovementPred, @@ -105,7 +106,7 @@ module GHC.Tc.Utils.TcType ( -- * Finding "exact" (non-dead) type variables exactTyCoVarsOfType, exactTyCoVarsOfTypes, - anyRewritableTyVar, anyRewritableTyFamApp, anyRewritableCanEqLHS, + anyRewritableTyVar, anyRewritableTyFamApp, --------------------------------- -- Foreign import and export @@ -231,6 +232,7 @@ import qualified GHC.LanguageExtensions as LangExt import Data.IORef import Data.List.NonEmpty( NonEmpty(..) ) +import Data.List ( partition ) import {-# SOURCE #-} GHC.Tc.Types.Origin ( unkSkol, SkolemInfo ) @@ -847,15 +849,14 @@ isTyFamFree :: Type -> Bool -- ^ Check that a type does not contain any type family applications. isTyFamFree = null . tcTyFamInsts -any_rewritable :: Bool -- Ignore casts and coercions - -> EqRel -- Ambient role +any_rewritable :: EqRel -- Ambient role -> (EqRel -> TcTyVar -> Bool) -- check tyvar -> (EqRel -> TyCon -> [TcType] -> Bool) -- check type family -> (TyCon -> Bool) -- expand type synonym? -> TcType -> Bool -- Checks every tyvar and tyconapp (not including FunTys) within a type, -- ORing the results of the predicates above together --- Do not look inside casts and coercions if 'ignore_cos' is True +-- Do not look inside casts and coercions -- See Note [anyRewritableTyVar must be role-aware] -- -- This looks like it should use foldTyCo, but that function is @@ -864,7 +865,7 @@ any_rewritable :: Bool -- Ignore casts and coercions -- -- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. {-# INLINE any_rewritable #-} -- this allows specialization of predicates -any_rewritable ignore_cos role tv_pred tc_pred should_expand +any_rewritable role tv_pred tc_pred should_expand = go role emptyVarSet where go_tv rl bvs tv | tv `elemVarSet` bvs = False @@ -890,8 +891,8 @@ any_rewritable ignore_cos role tv_pred tc_pred should_expand where arg_rep = getRuntimeRep arg -- forgetting these causes #17024 res_rep = getRuntimeRep res go rl bvs (ForAllTy tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty - go rl bvs (CastTy ty co) = go rl bvs ty || go_co rl bvs co - go rl bvs (CoercionTy co) = go_co rl bvs co -- ToDo: check + go rl bvs (CastTy ty _) = go rl bvs ty + go _ _ (CoercionTy _) = False go_tc NomEq bvs _ tys = any (go NomEq bvs) tys go_tc ReprEq bvs tc tys = any (go_arg bvs) @@ -901,19 +902,12 @@ any_rewritable ignore_cos role tv_pred tc_pred should_expand go_arg bvs (Representational, ty) = go ReprEq bvs ty go_arg _ (Phantom, _) = False -- We never rewrite with phantoms - go_co rl bvs co - | ignore_cos = False - | otherwise = anyVarSet (go_tv rl bvs) (tyCoVarsOfCo co) - -- We don't have an equivalent of anyRewritableTyVar for coercions - -- (at least not yet) so take the free vars and test them - -anyRewritableTyVar :: Bool -- Ignore casts and coercions - -> EqRel -- Ambient role +anyRewritableTyVar :: EqRel -- Ambient role -> (EqRel -> TcTyVar -> Bool) -- check tyvar -> TcType -> Bool -- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. -anyRewritableTyVar ignore_cos role pred - = any_rewritable ignore_cos role pred +anyRewritableTyVar role pred + = any_rewritable role pred (\ _ _ _ -> False) -- no special check for tyconapps -- (this False is ORed with other results, so it -- really means "do nothing special"; the arguments @@ -930,18 +924,7 @@ anyRewritableTyFamApp :: EqRel -- Ambient role -- always ignores casts & coercions -- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. anyRewritableTyFamApp role check_tyconapp - = any_rewritable True role (\ _ _ -> False) check_tyconapp (not . isFamFreeTyCon) - --- This version is used by shouldSplitWD. It *does* look in casts --- and coercions, and it always expands type synonyms whose RHSs mention --- type families. --- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. -anyRewritableCanEqLHS :: EqRel -- Ambient role - -> (EqRel -> TcTyVar -> Bool) -- check tyvar - -> (EqRel -> TyCon -> [TcType] -> Bool) -- check type family - -> TcType -> Bool -anyRewritableCanEqLHS role check_tyvar check_tyconapp - = any_rewritable False role check_tyvar check_tyconapp (not . isFamFreeTyCon) + = any_rewritable role (\ _ _ -> False) check_tyconapp (not . isFamFreeTyCon) {- Note [anyRewritableTyVar must be role-aware] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1170,6 +1153,16 @@ findDupTyVarTvs prs eq_snd (_,tv1) (_,tv2) = tv1 == tv2 mk_result_prs ((n1,_) :| xs) = map (\(n2,_) -> (n1,n2)) xs +-- | Returns the (kind, type) variables in a type that are +-- as-yet-unknown: metavariables and RuntimeUnks +ambigTkvsOfTy :: TcType -> ([Var],[Var]) +ambigTkvsOfTy ty + = partition (`elemVarSet` dep_tkv_set) ambig_tkvs + where + tkvs = tyCoVarsOfTypeList ty + ambig_tkvs = filter isAmbiguousTyVar tkvs + dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) + {- ************************************************************************ * * @@ -1774,71 +1767,7 @@ evVarPred var = varType var -- partial signatures, (isEvVarType kappa) will return False. But -- nothing is wrong. So I just removed the ASSERT. ------------------- --- | When inferring types, should we quantify over a given predicate? --- Generally true of classes; generally false of equality constraints. --- Equality constraints that mention quantified type variables and --- implicit variables complicate the story. See Notes --- [Inheriting implicit parameters] and [Quantifying over equality constraints] -pickQuantifiablePreds - :: TyVarSet -- Quantifying over these - -> TcThetaType -- Proposed constraints to quantify - -> TcThetaType -- A subset that we can actually quantify --- This function decides whether a particular constraint should be --- quantified over, given the type variables that are being quantified -pickQuantifiablePreds qtvs theta - = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without - -- -XFlexibleContexts: see #10608, #10351 - -- flex_ctxt <- xoptM Opt_FlexibleContexts - mapMaybe (pick_me flex_ctxt) theta - where - pick_me flex_ctxt pred - = case classifyPredType pred of - - ClassPred cls tys - | Just {} <- isCallStackPred cls tys - -- NEVER infer a CallStack constraint. Otherwise we let - -- the constraints bubble up to be solved from the outer - -- context, or be defaulted when we reach the top-level. - -- See Note [Overview of implicit CallStacks] - -> Nothing - - | isIPClass cls - -> Just pred -- See Note [Inheriting implicit parameters] - - | pick_cls_pred flex_ctxt cls tys - -> Just pred - - EqPred eq_rel ty1 ty2 - | quantify_equality eq_rel ty1 ty2 - , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 - -- boxEqPred: See Note [Lift equality constraints when quantifying] - , pick_cls_pred flex_ctxt cls tys - -> Just (mkClassPred cls tys) - - IrredPred ty - | tyCoVarsOfType ty `intersectsVarSet` qtvs - -> Just pred - - _ -> Nothing - - - pick_cls_pred flex_ctxt cls tys - = tyCoVarsOfTypes tys `intersectsVarSet` qtvs - && (checkValidClsArgs flex_ctxt cls tys) - -- Only quantify over predicates that checkValidType - -- will pass! See #10351. - - -- See Note [Quantifying over equality constraints] - quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 - quantify_equality ReprEq _ _ = True - - quant_fun ty - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) | isTypeFamilyTyCon tc - -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs - _ -> False - +--------------------------- boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type]) -- Given (t1 ~# t2) or (t1 ~R# t2) return the boxed version -- (t1 ~ t2) or (t1 `Coercible` t2) @@ -2013,71 +1942,6 @@ Notice that See also GHC.Tc.TyCl.Utils.checkClassCycles. -Note [Lift equality constraints when quantifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can't quantify over a constraint (t1 ~# t2) because that isn't a -predicate type; see Note [Types for coercions, predicates, and evidence] -in GHC.Core.TyCo.Rep. - -So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted -to Coercible. - -This tiresome lifting is the reason that pick_me (in -pickQuantifiablePreds) returns a Maybe rather than a Bool. - -Note [Quantifying over equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should we quantify over an equality constraint (s ~ t)? In general, we don't. -Doing so may simply postpone a type error from the function definition site to -its call site. (At worst, imagine (Int ~ Bool)). - -However, consider this - forall a. (F [a] ~ Int) => blah -Should we quantify over the (F [a] ~ Int)? Perhaps yes, because at the call -site we will know 'a', and perhaps we have instance F [Bool] = Int. -So we *do* quantify over a type-family equality where the arguments mention -the quantified variables. - -Note [Inheriting implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f x = (x::Int) + ?y - -where f is *not* a top-level binding. -From the RHS of f we'll get the constraint (?y::Int). -There are two types we might infer for f: - - f :: Int -> Int - -(so we get ?y from the context of f's definition), or - - f :: (?y::Int) => Int -> Int - -At first you might think the first was better, because then -?y behaves like a free variable of the definition, rather than -having to be passed at each call site. But of course, the WHOLE -IDEA is that ?y should be passed at each call site (that's what -dynamic binding means) so we'd better infer the second. - -BOTTOM LINE: when *inferring types* you must quantify over implicit -parameters, *even if* they don't mention the bound type variables. -Reason: because implicit parameters, uniquely, have local instance -declarations. See pickQuantifiablePreds. - -Note [Quantifying over equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should we quantify over an equality constraint (s ~ t)? In general, we don't. -Doing so may simply postpone a type error from the function definition site to -its call site. (At worst, imagine (Int ~ Bool)). - -However, consider this - forall a. (F [a] ~ Int) => blah -Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call -site we will know 'a', and perhaps we have instance F [Bool] = Int. -So we *do* quantify over a type-family equality where the arguments mention -the quantified variables. - ************************************************************************ * * Classifying types diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index 1ff6c044dc..4a5ef151b7 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -556,8 +556,7 @@ tcSubTypePat :: CtOrigin -> UserTypeCtxt -- If wrap = tc_sub_type_et t1 t2 -- => wrap :: t1 ~> t2 tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected - = do { dflags <- getDynFlags - ; tc_sub_type dflags unifyTypeET inst_orig ctxt ty_actual ty_expected } + = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected tcSubTypePat _ _ (Infer inf_res) ty_expected = do { co <- fillInferResult ty_expected inf_res @@ -584,9 +583,8 @@ tcSubTypeNC :: CtOrigin -- ^ Used when instantiating -> TcM HsWrapper tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty = case res_ty of - Check ty_expected -> do { dflags <- getDynFlags - ; tc_sub_type dflags (unifyType m_thing) inst_orig ctxt - ty_actual ty_expected } + Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt + ty_actual ty_expected Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual -- See Note [Instantiation of InferResult] @@ -631,22 +629,18 @@ command. See Note [Implementing :type] in GHC.Tc.Module. -} --------------- -tcSubTypeSigma :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we + -- doing this subtype check? + -> UserTypeCtxt -- where did the expected type arise? + -> TcSigmaType -> TcSigmaType -> TcM HsWrapper -- External entry point, but no ExpTypes on either side -- Checks that actual <= expected -- Returns HsWrapper :: actual ~ expected -tcSubTypeSigma ctxt ty_actual ty_expected - = do { dflags <- getDynFlags - ; tc_sub_type dflags (unifyType Nothing) eq_orig ctxt ty_actual ty_expected } - where - eq_orig = TypeEqOrigin { uo_actual = ty_actual - , uo_expected = ty_expected - , uo_thing = Nothing - , uo_visible = True } +tcSubTypeSigma orig ctxt ty_actual ty_expected + = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected --------------- -tc_sub_type :: DynFlags - -> (TcType -> TcType -> TcM TcCoercionN) -- How to unify +tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify -> CtOrigin -- Used when instantiating -> UserTypeCtxt -- Used when skolemising -> TcSigmaType -- Actual; a sigma-type @@ -655,7 +649,7 @@ tc_sub_type :: DynFlags -- Checks that actual_ty is more polymorphic than expected_ty -- If wrap = tc_sub_type t1 t2 -- => wrap :: t1 ~> t2 -tc_sub_type dflags unify inst_orig ctxt ty_actual ty_expected +tc_sub_type unify inst_orig ctxt ty_actual ty_expected | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] , not (possibly_poly ty_actual) = do { traceTc "tc_sub_type (drop to equality)" $ @@ -683,7 +677,7 @@ tc_sub_type dflags unify inst_orig ctxt ty_actual ty_expected | (tvs, theta, tau) <- tcSplitSigmaTy ty , (tv:_) <- tvs , null theta - , checkTyVarEq dflags tv tau `cterHasProblem` cteInsolubleOccurs + , checkTyVarEq tv tau `cterHasProblem` cteInsolubleOccurs = True | otherwise = False @@ -1067,7 +1061,7 @@ take care: can yield /very/ confusing error messages, because we can get [W] C Int b1 -- from f_blah [W] C Int b2 -- from g_blan - and fundpes can yield [D] b1 ~ b2, even though the two functions have + and fundpes can yield [W] b1 ~ b2, even though the two functions have literally nothing to do with each other. #14185 is an example. Building an implication keeps them separate. -} @@ -1447,15 +1441,14 @@ uUnfilledVar2 :: CtOrigin -> TcTauType -- Type 2, zonked -> TcM Coercion uUnfilledVar2 origin t_or_k swapped tv1 ty2 - = do { dflags <- getDynFlags - ; cur_lvl <- getTcLevel - ; go dflags cur_lvl } + = do { cur_lvl <- getTcLevel + ; go cur_lvl } where - go dflags cur_lvl + go cur_lvl | isTouchableMetaTyVar cur_lvl tv1 -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles , canSolveByUnification (metaTyVarInfo tv1) ty2 - , cterHasNoProblem (checkTyVarEq dflags tv1 ty2) + , cterHasNoProblem (checkTyVarEq tv1 ty2) -- See Note [Prevent unification with type families] = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2) (tyVarKind tv1) ; traceTc "uUnfilledVar2 ok" $ @@ -1471,7 +1464,8 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2 ; return (mkTcNomReflCo ty2) } else defer } -- This cannot be solved now. See GHC.Tc.Solver.Canonical - -- Note [Equalities with incompatible kinds] + -- Note [Equalities with incompatible kinds] for how + -- this will be dealt with in the solver | otherwise = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2) @@ -1485,14 +1479,20 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2 defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 -canSolveByUnification :: MetaInfo -> TcType -> Bool --- See Note [Unification preconditions, (TYVAR-TV)] +-- | Checks (TYVAR-TV) and (COERCION-HOLE) of Note [Unification preconditions]; +-- returns True if these conditions are satisfied. But see the Note for other +-- preconditions, too. +canSolveByUnification :: MetaInfo -> TcType -- zonked + -> Bool +canSolveByUnification _ xi + | hasCoercionHoleTy xi -- (COERCION-HOLE) check + = False canSolveByUnification info xi = case info of CycleBreakerTv -> False TyVarTv -> case tcGetTyVar_maybe xi of Nothing -> False - Just tv -> case tcTyVarDetails tv of + Just tv -> case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle MetaTv { mtv_info = info } -> case info of TyVarTv -> True @@ -1552,7 +1552,7 @@ unify alpha := ty? This note only applied to /homogeneous/ equalities, in which both sides have the same kind. -There are three reasons not to unify: +There are four reasons not to unify: 1. (SKOL-ESC) Skolem-escape Consider the constraint @@ -1590,8 +1590,22 @@ There are three reasons not to unify: * CycleBreakerTv: never unified, except by restoreTyVarCycles. +4. (COERCION-HOLE) Confusing coercion holes + Suppose our equality is + (alpha :: k) ~ (Int |> {co}) + where co :: Type ~ k is an unsolved wanted. Note that this + equality is homogeneous; both sides have kind k. Unifying here + is sensible, but it can lead to very confusing error messages. + It's very much like a Wanted rewriting a Wanted. Even worse, + unifying a variable essentially turns an equality into a Given, + and so we could not use the tracking mechansim in + Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. + We thus simply do not unify in this case. + + This is expanded as Wrinkle (2) in Note [Equalities with incompatible kinds] + in GHC.Tc.Solver.Canonical. -Needless to say, all three have wrinkles: +Needless to say, all there are wrinkles: * (SKOL-ESC) Promotion. Given alpha[n] ~ ty, what if beta[k] is free in 'ty', where beta is a unification variable, and k>n? 'beta' @@ -1653,7 +1667,7 @@ So we look for a positive reason to swap, using a three-step test: Generally speaking we always try to put a MetaTv on the left in preference to SkolemTv or RuntimeUnkTv: a) Because the MetaTv may be touchable and can be unified - b) Even if it's not touchable, GHC.Tc.Solver.floatEqualities + b) Even if it's not touchable, GHC.Tc.Solver.floatConstraints looks for meta tyvars on the left Tie-breaking rules for MetaTvs: @@ -1909,23 +1923,22 @@ with (forall k. k->*) ---------------- {-# NOINLINE checkTyVarEq #-} -- checkTyVarEq becomes big after the `inline` fires -checkTyVarEq :: DynFlags -> TcTyVar -> TcType -> CheckTyEqResult -checkTyVarEq dflags tv ty - = inline checkTypeEq dflags (TyVarLHS tv) ty +checkTyVarEq :: TcTyVar -> TcType -> CheckTyEqResult +checkTyVarEq tv ty + = inline checkTypeEq (TyVarLHS tv) ty -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away {-# NOINLINE checkTyFamEq #-} -- checkTyFamEq becomes big after the `inline` fires -checkTyFamEq :: DynFlags - -> TyCon -- type function +checkTyFamEq :: TyCon -- type function -> [TcType] -- args, exactly saturated -> TcType -- RHS -> CheckTyEqResult -- always drops cteTypeFamily -checkTyFamEq dflags fun_tc fun_args ty - = inline checkTypeEq dflags (TyFamLHS fun_tc fun_args) ty +checkTyFamEq fun_tc fun_args ty + = inline checkTypeEq (TyFamLHS fun_tc fun_args) ty `cterRemoveProblem` cteTypeFamily -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away -checkTypeEq :: DynFlags -> CanEqLHS -> TcType -> CheckTyEqResult +checkTypeEq :: CanEqLHS -> TcType -> CheckTyEqResult -- If cteHasNoProblem (checkTypeEq dflags lhs rhs), then lhs ~ rhs -- is a canonical CEqCan. -- @@ -1933,8 +1946,7 @@ checkTypeEq :: DynFlags -> CanEqLHS -> TcType -> CheckTyEqResult -- (a) a forall type (forall a. blah) -- (b) a predicate type (c => ty) -- (c) a type family; see Note [Prevent unification with type families] --- (d) a blocking coercion hole --- (e) an occurrence of the LHS (occurs check) +-- (d) an occurrence of the LHS (occurs check) -- -- Note that an occurs-check does not mean "definite error". For example -- type family F a @@ -1945,20 +1957,18 @@ checkTypeEq :: DynFlags -> CanEqLHS -> TcType -> CheckTyEqResult -- certainly can't unify b0 := F b0 -- -- For (a), (b), and (c) we check only the top level of the type, NOT --- inside the kinds of variables it mentions. For (d) we look deeply --- in coercions when the LHS is a tyvar (but skip coercions for type family --- LHSs), and for (e) see Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. +-- inside the kinds of variables it mentions, and for (d) see +-- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. -- -- checkTypeEq is called from -- * checkTyFamEq, checkTyVarEq (which inline it to specialise away the -- case-analysis on 'lhs') -- * checkEqCanLHSFinish, which does not know the form of 'lhs' -checkTypeEq dflags lhs ty +checkTypeEq lhs ty = go ty where impredicative = cteProblem cteImpredicative type_family = cteProblem cteTypeFamily - hole_blocker = cteProblem cteHoleBlocker insoluble_occurs = cteProblem cteInsolubleOccurs soluble_occurs = cteProblem cteSolubleOccurs @@ -2029,21 +2039,11 @@ checkTypeEq dflags lhs ty -- inferred go_co co | TyVarLHS tv <- lhs , tv `elemVarSet` tyCoVarsOfCo co - = soluble_occurs S.<> maybe_hole_blocker + = soluble_occurs -- Don't check coercions for type families; see commentary at top of function | otherwise - = maybe_hole_blocker - where - -- See GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds] - -- Wrinkle (2) about this case in general, Wrinkle (4b) about the check for - -- deferred type errors - maybe_hole_blocker | not (gopt Opt_DeferTypeErrors dflags) - , hasCoercionHoleCo co - = hole_blocker - - | otherwise - = cteOK + = cteOK check_tc :: TyCon -> CheckTyEqResult check_tc diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 436543b095..ba6c98905f 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -68,7 +68,6 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Constants (debugIsOn) import GHC.Core.Multiplicity import GHC.Core @@ -511,14 +510,14 @@ zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do new_binds <- mapM (wrapLocMA zonk_ip_bind) binds let env1 = extendIdZonkEnvRec env - [ n | (L _ (IPBind _ (Right n) _)) <- new_binds] + [ n | (L _ (IPBind n _ _)) <- new_binds] (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) where - zonk_ip_bind (IPBind x n e) - = do n' <- mapIPNameTc (zonkIdBndr env) n + zonk_ip_bind (IPBind dict_id n e) + = do dict_id' <- zonkIdBndr env dict_id e' <- zonkLExpr env e - return (IPBind x n' e') + return (IPBind dict_id' n e') --------------------------------------------- zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc) @@ -1318,13 +1317,6 @@ zonkRecUpdFields env = mapM zonk_rbind ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id , hfbRHS = new_expr })) } -------------------------------------------------------------------------- -mapIPNameTc :: (a -> TcM b) -> Either (LocatedAn NoEpAnns HsIPName) a - -> TcM (Either (LocatedAn NoEpAnns HsIPName) b) -mapIPNameTc _ (Left x) = return (Left x) -mapIPNameTc f (Right x) = do r <- f x - return (Right r) - {- ************************************************************************ * * @@ -1833,6 +1825,13 @@ commitFlexi flexi tv zonked_kind SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) DefaultFlexi + -- Normally, RuntimeRep variables are defaulted in TcMType.defaultTyVar + -- But that sees only type variables that appear in, say, an inferred type + -- Defaulting here in the zonker is needed to catch e.g. + -- y :: Bool + -- y = (\x -> True) undefined + -- We need *some* known RuntimeRep for the x and undefined, but no one + -- will choose it until we get here, in the zonker. | isRuntimeRepTy zonked_kind -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) ; return liftedRepTy } @@ -1877,11 +1876,6 @@ zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) -- (undeferred) type errors. Originally, I put in a panic -- here, but that caused too many uses of `failIfErrsM`. Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole) - ; when debugIsOn $ - whenNoErrs $ - massertPpr False - (text "Type-correct unfilled coercion hole" - <+> ppr hole) ; cv' <- zonkCoVar cv ; return $ mkCoVarCo cv' } } -- This will be an out-of-scope variable, but keeping diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index cad2ea1796..f7851f21c4 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -45,6 +45,7 @@ import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Types.Rank import GHC.Tc.Errors.Types +import GHC.Types.Error -- others: import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp ) @@ -219,7 +220,7 @@ checkAmbiguity ctxt ty ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ captureConstraints $ - tcSubTypeSigma ctxt ty ty + tcSubTypeSigma (AmbiguityCheckOrigin ctxt) ctxt ty ty ; simplifyAmbiguityCheck ty wanted ; traceTc "Done ambiguity check for" (ppr ty) } @@ -687,7 +688,8 @@ check_type :: ValidityEnv -> Type -> TcM () -- Rank is allowed rank for function args -- Rank 0 means no for-alls anywhere -check_type _ (TyVarTy _) = return () +check_type _ (TyVarTy _) + = return () check_type ve (AppTy ty1 ty2) = do { check_type ve ty1 @@ -1079,19 +1081,11 @@ check_pred_help under_syn env dflags ctxt pred -- is wrong. For user written signatures, it'll be rejected by kind-checking -- well before we get to validity checking. For inferred types we are careful -- to box such constraints in GHC.Tc.Utils.TcType.pickQuantifiablePreds, as described - -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType + -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Solver ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head _ -> return () -check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM () -check_eq_pred env dflags pred - = -- Equational constraints are valid in all contexts if type - -- families are permitted - checkTcM (xopt LangExt.TypeFamilies dflags - || xopt LangExt.GADTs dflags) - (env, TcRnIllegalEqualConstraints (tidyType env pred)) - check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> ThetaType -> PredType -> TcM () check_quant_pred env dflags ctxt pred theta head_pred @@ -1141,7 +1135,9 @@ check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt check_class_pred env dflags ctxt pred cls tys | isEqPredClass cls -- (~) and (~~) are classified as classes, -- but here we want to treat them as equalities - = check_eq_pred env dflags pred + = -- Equational constraints are valid in all contexts, and + -- we do not need to check e.g. for FlexibleContexts here, so just do nothing + return () | isIPClass cls = do { check_arity diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 6703719797..d90ef38341 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -910,7 +910,7 @@ cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) cvtImplicitParamBind n e = do n' <- wrapL (ipName n) e' <- cvtl e - returnLA (IPBind noAnn (Left (reLocA n')) e') + returnLA (IPBind noAnn (reLocA n') e') ------------------------------------------------------------------- -- Expressions diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 67f7e405a3..0b3959e646 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -883,7 +883,6 @@ For further reading, see: Note [Bangs on imported data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs from imported modules. diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs index 55ea2a0dda..3ad0f10156 100644 --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -456,7 +456,7 @@ delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env') {- ************************************************************************ * * -\subsection{@VarEnv@s} + VarEnv * * ************************************************************************ -} @@ -565,7 +565,13 @@ modifyVarEnv_Directly mangle_fn env key Nothing -> env Just xx -> addToUFM_Directly env key (mangle_fn xx) --- Deterministic VarEnv +{- +************************************************************************ +* * + Deterministic VarEnv (DVarEnv) +* * +************************************************************************ +-} -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need -- DVarEnv. diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 3bc4e6adb8..f6a07ad0ae 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -14,7 +14,7 @@ -- module GHC.Utils.Misc ( -- * Miscellaneous higher-order functions - applyWhen, nTimes, + applyWhen, nTimes, const2, -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, @@ -180,6 +180,9 @@ nTimes 0 _ = id nTimes 1 f = f nTimes n f = f . nTimes (n-1) f +const2 :: a -> b -> c -> a +const2 x _ _ = x + fstOf3 :: (a,b,c) -> a sndOf3 :: (a,b,c) -> b thdOf3 :: (a,b,c) -> c |