diff options
| author | Richard Eisenberg <rae@richarde.dev> | 2020-11-25 15:22:16 -0500 |
|---|---|---|
| committer | Richard Eisenberg <rae@richarde.dev> | 2020-11-30 11:42:41 -0500 |
| commit | 50b22545b7ae4cbb718fdf452e9fc71dbe04cd91 (patch) | |
| tree | 99dfc962fb7b5118cf387722cc4e0a05f3a3a74e | |
| parent | da912d0a21d0256b5f0c1f4e099d4fccc806a696 (diff) | |
| download | haskell-50b22545b7ae4cbb718fdf452e9fc71dbe04cd91.tar.gz | |
Remove flattening variables
This patch redesigns the flattener to simplify type family applications
directly instead of using flattening meta-variables and skolems. The key new
innovation is the CanEqLHS type and the new CEqCan constraint (Ct). A CanEqLHS
is either a type variable or exactly-saturated type family application; either
can now be rewritten using a CEqCan constraint in the inert set.
Because the flattener no longer reduces all type family applications to
variables, there was some performance degradation if a lengthy type family
application is now flattened over and over (not making progress). To
compensate, this patch contains some extra optimizations in the flattener,
leading to a number of performance improvements.
Close #18875.
Close #18910.
There are many extra parts of the compiler that had to be affected in writing
this patch:
* The family-application cache (formerly the flat-cache) sometimes stores
coercions built from Given inerts. When these inerts get kicked out, we must
kick out from the cache as well. (This was, I believe, true previously, but
somehow never caused trouble.) Kicking out from the cache requires adding a
filterTM function to TrieMap.
* This patch obviates the need to distinguish "blocking" coercion holes from
non-blocking ones (which, previously, arose from CFunEqCans). There is thus
some simplification around coercion holes.
* Extra commentary throughout parts of the code I read through, to preserve
the knowledge I gained while working.
* A change in the pure unifier around unifying skolems with other types.
Unifying a skolem now leads to SurelyApart, not MaybeApart, as documented
in Note [Binding when looking up instances] in GHC.Core.InstEnv.
* Some more use of MCoercion where appropriate.
* Previously, class-instance lookup automatically noticed that e.g. C Int was
a "unifier" to a target [W] C (F Bool), because the F Bool was flattened to
a variable. Now, a little more care must be taken around checking for
unifying instances.
* Previously, tcSplitTyConApp_maybe would split (Eq a => a). This is silly,
because (=>) is not a tycon in Haskell. Fixed now, but there are some
knock-on changes in e.g. TrieMap code and in the canonicaliser.
* New function anyFreeVarsOf{Type,Co} to check whether a free variable
satisfies a certain predicate.
* Type synonyms now remember whether or not they are "forgetful"; a forgetful
synonym drops at least one argument. This is useful when flattening; see
flattenView.
* The pattern-match completeness checker invokes the solver. This invocation
might need to look through newtypes when checking representational equality.
Thus, the desugarer needs to keep track of the in-scope variables to know
what newtype constructors are in scope. I bet this bug was around before but
never noticed.
* Extra-constraints wildcards are no longer simplified before printing.
See Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver.
* Whether or not there are Given equalities has become slightly subtler.
See the new HasGivenEqs datatype.
* Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical
explains a significant new wrinkle in the new approach.
* See Note [What might match later?] in GHC.Tc.Solver.Interact, which
explains the fix to #18910.
* The inert_count field of InertCans wasn't actually used, so I removed
it.
Though I (Richard) did the implementation, Simon PJ was very involved
in design and review.
This updates the Haddock submodule to avoid #18932 by adding
a type signature.
-------------------------
Metric Decrease:
T12227
T5030
T9872a
T9872b
T9872c
Metric Increase:
T9872d
-------------------------
119 files changed, 3693 insertions, 3752 deletions
diff --git a/compiler/GHC/Cmm/Dataflow/Label.hs b/compiler/GHC/Cmm/Dataflow/Label.hs index 161125daff..a9a74fd50e 100644 --- a/compiler/GHC/Cmm/Dataflow/Label.hs +++ b/compiler/GHC/Cmm/Dataflow/Label.hs @@ -141,6 +141,7 @@ instance TrieMap LabelMap where alterTM k f m = mapAlter f k m foldTM k m z = mapFoldr k z m mapTM f m = mapMap f m + filterTM f m = mapFilter f m ----------------------------------------------------------------------------- -- FactBase diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 4413c7355b..051f415572 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -13,8 +13,8 @@ -- module GHC.Core.Coercion ( -- * Main data type - Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR, - UnivCoProvenance, CoercionHole(..), BlockSubstFlag(..), + Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionN, MCoercionR, + UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar, LeftOrRight(..), Var, CoVar, TyCoVar, @@ -69,8 +69,10 @@ module GHC.Core.Coercion ( pickLR, isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, - isReflCoVar_maybe, isGReflMCo, - coToMCo, mkTransMCo, mkTransMCoL, + isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo, + mkCoherenceRightMCo, + + coToMCo, mkTransMCo, mkTransMCoL, mkCastTyMCo, mkSymMCo, isReflMCo, -- ** Coercion variables mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, @@ -79,7 +81,7 @@ module GHC.Core.Coercion ( -- ** Free variables tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, - coercionSize, + coercionSize, anyFreeVarsOfCo, -- ** Substitution CvSubstEnv, emptyCvSubstEnv, @@ -121,7 +123,8 @@ module GHC.Core.Coercion ( simplifyArgsWorker, - badCoercionHole, badCoercionHoleCo + hasCoercionHoleTy, hasCoercionHoleCo, + HoleSet, coercionHolesOfType, coercionHolesOfCo ) where #include "HsVersions.h" @@ -154,6 +157,7 @@ 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 @@ -331,6 +335,32 @@ mkTransMCoL :: MCoercion -> Coercion -> MCoercion mkTransMCoL MRefl co2 = MCo co2 mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2) +-- | Get the reverse of an 'MCoercion' +mkSymMCo :: MCoercion -> MCoercion +mkSymMCo MRefl = MRefl +mkSymMCo (MCo co) = MCo (mkSymCo co) + +-- | Cast a type by an 'MCoercion' +mkCastTyMCo :: Type -> MCoercion -> Type +mkCastTyMCo ty MRefl = ty +mkCastTyMCo ty (MCo co) = ty `mkCastTy` co + +mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflLeftMCo r ty MRefl = mkReflCo r ty +mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co + +mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflRightMCo r ty MRefl = mkReflCo r ty +mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co + +-- | Like 'mkCoherenceRightCo', but with an 'MCoercion' +mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion +mkCoherenceRightMCo _ _ MRefl co2 = co2 +mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2 + +isReflMCo :: MCoercion -> Bool +isReflMCo MRefl = True +isReflMCo _ = False {- %************************************************************************ @@ -1219,7 +1249,7 @@ mkKindCo co | otherwise = KindCo co -mkSubCo :: Coercion -> Coercion +mkSubCo :: HasDebugCallStack => Coercion -> Coercion -- Input coercion is Nominal, result is Representational -- see also Note [Role twiddling functions] mkSubCo (Refl ty) = GRefl Representational ty MRefl @@ -1675,6 +1705,11 @@ data NormaliseStepResult ev -- ^ ev is evidence; -- Usually a co :: old type ~ new type +instance Outputable ev => Outputable (NormaliseStepResult ev) where + ppr NS_Done = text "NS_Done" + ppr NS_Abort = text "NS_Abort" + ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev] + mapStepResult :: (ev1 -> ev2) -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) @@ -2634,7 +2669,8 @@ FamInstEnv, and so lives here. Note [simplifyArgsWorker] ~~~~~~~~~~~~~~~~~~~~~~~~~ -Invariant (F2) of Note [Flattening] says that flattening is homogeneous. +Invariant (F2) of Note [Flattening] in GHC.Tc.Solver.Flatten says that +flattening is homogeneous. This causes some trouble when flattening a function applied to a telescope of arguments, perhaps with dependency. For example, suppose @@ -2913,7 +2949,7 @@ simplifyArgsWorker :: [TyCoBinder] -> Kind -> [(Type, Coercion)] -- flattened type arguments, arg -- each comes with the coercion used to flatten it, -- with co :: flattened_type ~ original_type - -> ([Type], [Coercion], CoercionN) + -> ([Type], [Coercion], MCoercionN) -- Returns (xis, cos, res_co), where each co :: xi ~ arg, -- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args -- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in), @@ -2935,14 +2971,15 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs -> Kind -- Unsubsted result kind of function (not a Pi-type) -> [Role] -- Roles at which to flatten these ... -> [(Type, Coercion)] -- flattened arguments, with their flattening coercions - -> ([Type], [Coercion], CoercionN) + -> ([Type], [Coercion], MCoercionN) go acc_xis acc_cos !lc binders inner_ki _ [] -- The !lc makes the function strict in the lifting context -- which means GHC can unbox that pair. A modest win. = (reverse acc_xis, reverse acc_cos, kind_co) where final_kind = mkPiTys binders inner_ki - kind_co = liftCoSubst Nominal lc final_kind + kind_co | noFreeVarsOfType final_kind = MRefl + | otherwise = MCo $ liftCoSubst Nominal lc final_kind go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args) = -- By Note [Flattening] in GHC.Tc.Solver.Flatten invariant (F2), @@ -2998,7 +3035,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs (xis_out, cos_out, res_co_out) = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args in - (xis_out, cos_out, res_co_out `mkTransCo` res_co) + (xis_out, cos_out, res_co_out `mkTransMCoL` res_co) go _ _ _ _ _ _ _ = panic "simplifyArgsWorker wandered into deeper water than usual" @@ -3024,31 +3061,40 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs %************************************************************************ -} -bad_co_hole_ty :: Type -> Monoid.Any -bad_co_hole_co :: Coercion -> Monoid.Any -(bad_co_hole_ty, _, bad_co_hole_co, _) +has_co_hole_ty :: Type -> Monoid.Any +has_co_hole_co :: Coercion -> Monoid.Any +(has_co_hole_ty, _, has_co_hole_co, _) = foldTyCo folder () where folder = TyCoFolder { tcf_view = const Nothing , tcf_tyvar = const2 (Monoid.Any False) , tcf_covar = const2 (Monoid.Any False) - , tcf_hole = const hole + , tcf_hole = const2 (Monoid.Any True) , tcf_tycobinder = const2 } const2 :: a -> b -> c -> a const2 x _ _ = x - hole :: CoercionHole -> Monoid.Any - hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True - hole _ = Monoid.Any False +-- | Is there a coercion hole in this type? +hasCoercionHoleTy :: Type -> Bool +hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty + +-- | Is there a coercion hole in this coercion? +hasCoercionHoleCo :: Coercion -> Bool +hasCoercionHoleCo = Monoid.getAny . has_co_hole_co --- | Is there a blocking coercion hole in this type? See --- "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds] -badCoercionHole :: Type -> Bool -badCoercionHole = Monoid.getAny . bad_co_hole_ty +-- | A set of 'CoercionHole's +type HoleSet = UniqSet CoercionHole --- | Is there a blocking coercion hole in this coercion? See --- GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds] -badCoercionHoleCo :: Coercion -> Bool -badCoercionHoleCo = Monoid.getAny . bad_co_hole_co +-- | Extract out all the coercion holes from a given type +coercionHolesOfType :: Type -> UniqSet CoercionHole +coercionHolesOfCo :: Coercion -> UniqSet CoercionHole +(coercionHolesOfType, _, coercionHolesOfCo, _) = foldTyCo folder () + where + folder = TyCoFolder { tcf_view = const Nothing -- don't look through synonyms + , tcf_tyvar = \ _ _ -> mempty + , tcf_covar = \ _ _ -> mempty + , tcf_hole = const unitUniqSet + , tcf_tycobinder = \ _ _ _ -> () + } diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot index 7a92a84eb6..0c18e5e68f 100644 --- a/compiler/GHC/Core/Coercion.hs-boot +++ b/compiler/GHC/Core/Coercion.hs-boot @@ -30,7 +30,7 @@ mkInstCo :: Coercion -> Coercion -> Coercion mkGReflCo :: Role -> Type -> MCoercionN -> Coercion mkNomReflCo :: Type -> Coercion mkKindCo :: Coercion -> Coercion -mkSubCo :: Coercion -> Coercion +mkSubCo :: HasDebugCallStack => Coercion -> Coercion mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs index ae7ae8971f..46b238e678 100644 --- a/compiler/GHC/Core/Coercion/Axiom.hs +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -584,9 +584,21 @@ instance Outputable CoAxiomRule where -- Type checking of built-in families data BuiltInSynFamily = BuiltInSynFamily { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) + -- Does this reduce on the given arguments? + -- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type) + -- That is: mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) + -- :: F tys ~r rhs, + -- where the r in the output is coaxrRole of the rule. It is up to the + -- caller to ensure that this role is appropriate. + , sfInteractTop :: [Type] -> Type -> [TypeEqn] + -- If given these type arguments and RHS, returns the equalities that + -- are guaranteed to hold. + , sfInteractInert :: [Type] -> Type -> [Type] -> Type -> [TypeEqn] + -- If given one set of arguments and result, and another set of arguments + -- and result, returns the equalities that are guaranteed to hold. } -- Provides default implementations that do nothing. diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs index 3769fb23be..108154e1c6 100644 --- a/compiler/GHC/Core/Coercion/Opt.hs +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -27,7 +27,6 @@ import GHC.Types.Var.Env import GHC.Data.Pair import GHC.Data.List.SetOps ( getNth ) import GHC.Core.Unify -import GHC.Core.InstEnv import Control.Monad ( zipWithM ) import GHC.Utils.Outputable @@ -1006,7 +1005,7 @@ checkAxInstCo (AxiomInstCo ax ind cos) check_no_conflict _ [] = Nothing check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) -- See Note [Apartness] in GHC.Core.FamInstEnv - | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp + | SurelyApart <- tcUnifyTysFG (const BindMe) flat lhs_incomp = check_no_conflict flat rest | otherwise = Just b diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index c5445fceae..a6c7604008 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -428,7 +428,8 @@ Here is how we do it: apart(target, pattern) = not (unify(flatten(target), pattern)) where flatten (implemented in flattenTys, below) converts all type-family -applications into fresh variables. (See Note [Flattening] in GHC.Core.Unify.) +applications into fresh variables. (See +Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.) Note [Compatibility] ~~~~~~~~~~~~~~~~~~~~ @@ -1141,6 +1142,7 @@ reduceTyFamApp_maybe envs role tc tys | Just ax <- isBuiltInSynFamTyCon_maybe tc , Just (coax,ts,ty) <- sfMatchFam ax tys + , role == coaxrRole coax = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) in Just (co, ty) @@ -1175,7 +1177,8 @@ findBranch branches target_tys , cab_incomps = incomps }) = branch in_scope = mkInScopeSet (unionVarSets $ map (tyCoVarsOfTypes . coAxBranchLHS) incomps) - -- See Note [Flattening] in GHC.Core.Unify + -- See Note [Flattening type-family applications when matching instances] + -- in GHC.Core.Unify flattened_target = flattenTys in_scope target_tys in case tcMatchTys tpl_lhs target_tys of Just subst -- matching worked. now, check for apartness. @@ -1192,11 +1195,11 @@ findBranch branches target_tys -- (POPL '14). This should be used when determining if an equation -- ('CoAxBranch') of a closed type family can be used to reduce a certain target -- type family application. -apartnessCheck :: [Type] -- ^ /flattened/ target arguments. Make sure - -- they're flattened! See Note [Flattening] - -- in GHC.Core.Unify - -- (NB: This "flat" is a different - -- "flat" than is used in GHC.Tc.Solver.Flatten.) +apartnessCheck :: [Type] + -- ^ /flattened/ target arguments. Make sure they're flattened! See + -- Note [Flattening type-family applications when matching instances] + -- in GHC.Core.Unify. (NB: This "flat" is a different + -- "flat" than is used in GHC.Tc.Solver.Flatten.) -> CoAxBranch -- ^ the candidate equation we wish to use -- Precondition: this matches the target -> Bool -- ^ True <=> equation can fire @@ -1316,7 +1319,7 @@ topNormaliseType_maybe env ty tyFamStepper :: NormaliseStepper (Coercion, MCoercionN) tyFamStepper rec_nts tc tys -- Try to step a type/data family = case topReduceTyFamApp_maybe env tc tys of - Just (co, rhs, res_co) -> NS_Step rec_nts rhs (co, MCo res_co) + Just (co, rhs, res_co) -> NS_Step rec_nts rhs (co, res_co) _ -> NS_Done --------------- @@ -1362,14 +1365,14 @@ normalise_tc_app tc tys assemble_result :: Role -- r, ambient role in NormM monad -> Type -- nty, result type, possibly of changed kind -> Coercion -- orig_ty ~r nty, possibly heterogeneous - -> CoercionN -- typeKind(orig_ty) ~N typeKind(nty) + -> MCoercionN -- typeKind(orig_ty) ~N typeKind(nty) -> (Coercion, Type) -- (co :: orig_ty ~r nty_casted, nty_casted) -- where nty_casted has same kind as orig_ty assemble_result r nty orig_to_nty kind_co = ( final_co, nty_old_kind ) where - nty_old_kind = nty `mkCastTy` mkSymCo kind_co - final_co = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty + nty_old_kind = nty `mkCastTyMCo` mkSymMCo kind_co + final_co = mkCoherenceRightMCo r nty (mkSymMCo kind_co) orig_to_nty --------------- -- | Try to simplify a type-family application, by *one* step @@ -1378,7 +1381,7 @@ normalise_tc_app tc tys -- res_co :: typeKind(F tys) ~ typeKind(rhs) -- Type families and data families; always Representational role topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type] - -> Maybe (Coercion, Type, Coercion) + -> Maybe (Coercion, Type, MCoercion) topReduceTyFamApp_maybe envs fam_tc arg_tys | isFamilyTyCon fam_tc -- type families and data families , Just (co, rhs) <- reduceTyFamApp_maybe envs role fam_tc ntys @@ -1391,7 +1394,7 @@ topReduceTyFamApp_maybe envs fam_tc arg_tys normalise_tc_args fam_tc arg_tys normalise_tc_args :: TyCon -> [Type] -- tc tys - -> NormM (Coercion, [Type], CoercionN) + -> NormM (Coercion, [Type], MCoercionN) -- (co, new_tys), where -- co :: tc tys ~ tc new_tys; might not be homogeneous -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys) @@ -1474,14 +1477,14 @@ normalise_type ty ; role <- getRole ; let nty = mkAppTys nfun nargs nco = mkAppCos fun_co args_cos - nty_casted = nty `mkCastTy` mkSymCo res_co - final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco + nty_casted = nty `mkCastTyMCo` mkSymMCo res_co + final_co = mkCoherenceRightMCo role nty (mkSymMCo res_co) nco ; return (final_co, nty_casted) } } normalise_args :: Kind -- of the function -> [Role] -- roles at which to normalise args -> [Type] -- args - -> NormM ([Coercion], [Type], Coercion) + -> NormM ([Coercion], [Type], MCoercion) -- returns (cos, xis, res_co), where each xi is the normalised -- version of the corresponding type, each co is orig_arg ~ xi, -- and the res_co :: kind(f orig_args) ~ kind(f xis) @@ -1491,7 +1494,7 @@ normalise_args :: Kind -- of the function normalise_args fun_ki roles args = do { normed_args <- zipWithM normalise1 roles args ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args - ; return (map mkSymCo cos, xis, mkSymCo res_co) } + ; return (map mkSymCo cos, xis, mkSymMCo res_co) } where (ki_binders, inner_ki) = splitPiTys fun_ki fvs = tyCoVarsOfTypes args diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index e8603a4cae..6eae14090f 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -828,18 +828,22 @@ lookupInstEnv' ie vis_mods cls tys = find ms us rest | otherwise - = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, + = ASSERT2( tys_tv_set `disjointVarSet` tpl_tv_set, (ppr cls <+> ppr tys <+> ppr all_tvs) $$ (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them -- See Note [Template tyvars are fresh] - case tcUnifyTys instanceBindFun tpl_tys tys of - Just _ -> find ms (item:us) rest - Nothing -> find ms us rest + case tcUnifyTysFG instanceBindFun tpl_tys tys of + -- We consider MaybeApart to be a case where the instance might + -- apply in the future. This covers an instance like C Int and + -- a target like [W] C (F a), where F is a type family. + SurelyApart -> find ms us rest + _ -> find ms (item:us) rest where tpl_tv_set = mkVarSet tpl_tvs + tys_tv_set = tyCoVarsOfTypes tys --------------- -- This is the common way to call this function. @@ -1023,20 +1027,28 @@ When looking up in the instance environment, or family-instance environment, we are careful about multiple matches, as described above in Note [Overlapping instances] -The key_tys can contain skolem constants, and we can guarantee that those +The target tys can contain skolem constants. For existentials and instance variables, +we can guarantee that those are never going to be instantiated to anything, so we should not involve -them in the unification test. Example: +them in the unification test. These are called "super skolems". Example: class Foo a where { op :: a -> Int } instance Foo a => Foo [a] -- NB overlap instance Foo [Int] -- NB overlap data T = forall a. Foo a => MkT a f :: T -> Int f (MkT x) = op [x,x] -The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd -complain, saying that the choice of instance depended on the instantiation -of 'a'; but of course it isn't *going* to be instantiated. - -We do this only for isOverlappableTyVar skolems. For example we reject +The op [x,x] means we need (Foo [a]). This `a` will never be instantiated, and +so it is a super skolem. (See the use of tcInstSuperSkolTyVarsX in +GHC.Tc.Gen.Pat.tcDataConPat.) Super skolems respond True to +isOverlappableTyVar, and the use of Skolem in instanceBindFun, above, means +that these will be treated as fresh constants in the unification algorithm +during instance lookup. Without this treatment, GHC would complain, saying +that the choice of instance depended on the instantiation of 'a'; but of +course it isn't *going* to be instantiated. Note that it is necessary that +the unification algorithm returns SurelyApart for these super-skolems +for GHC to be able to commit to another instance. + +We do this only for super skolems. For example we reject g :: forall a => [a] -> Int g x = op x on the grounds that the correct instance depends on the instantiation of 'a' diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs index b3273a1a2e..2181abb304 100644 --- a/compiler/GHC/Core/Map/Expr.hs +++ b/compiler/GHC/Core/Map/Expr.hs @@ -116,6 +116,7 @@ instance TrieMap CoreMap where alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) foldTM k (CoreMap m) = foldTM k m mapTM f (CoreMap m) = CoreMap (mapTM f m) + filterTM f (CoreMap m) = CoreMap (filterTM f m) -- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended -- key makes it suitable for recursive traversal, since it can track binders, @@ -197,6 +198,7 @@ instance TrieMap CoreMapX where alterTM = xtE foldTM = fdE mapTM = mapE + filterTM = ftE -------------------------- mapE :: (a->b) -> CoreMapX a -> CoreMapX b @@ -213,6 +215,20 @@ mapE f (CM { cm_var = cvar, cm_lit = clit , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick } +ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a +ftE f (CM { cm_var = cvar, cm_lit = clit + , cm_co = cco, cm_type = ctype + , cm_cast = ccast , cm_app = capp + , cm_lam = clam, cm_letn = cletn + , cm_letr = cletr, cm_case = ccase + , cm_ecase = cecase, cm_tick = ctick }) + = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit + , cm_co = filterTM f cco, cm_type = filterTM f ctype + , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp + , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn + , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase + , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick } + -------------------------- lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a lookupCoreMap cm e = lookupTM e cm @@ -330,6 +346,7 @@ instance TrieMap AltMap where alterTM = xtA emptyCME foldTM = fdA mapTM = mapA + filterTM = ftA instance Eq (DeBruijn CoreAlt) where D env1 a1 == D env2 a2 = go a1 a2 where @@ -348,6 +365,12 @@ mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) , am_data = mapTM (mapTM f) adata , am_lit = mapTM (mapTM f) alit } +ftA :: (a->Bool) -> AltMap a -> AltMap a +ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) + = AM { am_deflt = filterTM f adeflt + , am_data = mapTM (filterTM f) adata + , am_lit = mapTM (filterTM f) alit } + lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a lkA env (DEFAULT, _, rhs) = am_deflt >.> lkG (D env rhs) lkA env (LitAlt lit, _, rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) diff --git a/compiler/GHC/Core/Map/Type.hs b/compiler/GHC/Core/Map/Type.hs index 36583dc670..8056211314 100644 --- a/compiler/GHC/Core/Map/Type.hs +++ b/compiler/GHC/Core/Map/Type.hs @@ -8,6 +8,9 @@ {-# LANGUAGE TypeFamilies #-} module GHC.Core.Map.Type ( + -- * Re-export generic interface + TrieMap(..), + -- * Maps over 'Type's TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, LooseTypeMap, @@ -45,6 +48,7 @@ import GHC.Types.Var.Env import GHC.Types.Unique.FM import GHC.Utils.Outputable +import GHC.Data.Maybe import GHC.Utils.Panic import qualified Data.Map as Map @@ -86,6 +90,7 @@ instance TrieMap CoercionMap where alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) foldTM k (CoercionMap m) = foldTM k m mapTM f (CoercionMap m) = CoercionMap (mapTM f m) + filterTM f (CoercionMap m) = CoercionMap (filterTM f m) type CoercionMapG = GenMap CoercionMapX newtype CoercionMapX a = CoercionMapX (TypeMapX a) @@ -97,6 +102,7 @@ instance TrieMap CoercionMapX where alterTM = xtC foldTM f (CoercionMapX core_tm) = foldTM f core_tm mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm) + filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm) instance Eq (DeBruijn Coercion) where D env1 co1 == D env2 co2 @@ -135,6 +141,12 @@ data TypeMapX a = TM { tm_var :: VarMap a , tm_app :: TypeMapG (TypeMapG a) , tm_tycon :: DNameEnv a + + -- only InvisArg arrows here + , tm_funty :: TypeMapG (TypeMapG (TypeMapG a)) + -- keyed on the argument, result rep, and result + -- constraints are never linear-restricted and are always lifted + , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr , tm_tylit :: TyLitMap a , tm_coerce :: Maybe a @@ -142,10 +154,12 @@ data TypeMapX a -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type -- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the --- last one? See Note [Equality on AppTys] in "GHC.Core.Type" +-- last one? See Note [Equality on AppTys] in GHC.Core.Type -- -- Note, however, that we keep Constraint and Type apart here, despite the fact -- that they are both synonyms of TYPE 'LiftedRep (see #11715). +-- +-- We also keep (Eq a => a) as a FunTy, distinct from ((->) (Eq a) a). trieMapView :: Type -> Maybe Type trieMapView ty -- First check for TyConApps that need to be expanded to @@ -164,6 +178,7 @@ instance TrieMap TypeMapX where alterTM = xtT foldTM = fdT mapTM = mapT + filterTM = filterT instance Eq (DeBruijn Type) where env_t@(D env t) == env_t'@(D env' t') @@ -184,8 +199,11 @@ instance Eq (DeBruijn Type) where -> D env t1 == D env' t1' && D env t2 == D env' t2' (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s -> D env t1 == D env' t1' && D env t2 == D env' t2' - (FunTy _ w1 t1 t2, FunTy _ w1' t1' t2') - -> D env w1 == D env w1' && D env t1 == D env' t1' && D env t2 == D env' t2' + (FunTy v1 w1 t1 t2, FunTy v1' w1' t1' t2') + -> v1 == v1' && + D env w1 == D env w1' && + D env t1 == D env' t1' && + D env t2 == D env' t2' (TyConApp tc tys, TyConApp tc' tys') -> tc == tc' && D env tys == D env' tys' (LitTy l, LitTy l') @@ -205,17 +223,19 @@ emptyT :: TypeMapX a emptyT = TM { tm_var = emptyTM , tm_app = emptyTM , tm_tycon = emptyDNameEnv + , tm_funty = emptyTM , tm_forall = emptyTM , tm_tylit = emptyTyLitMap , tm_coerce = Nothing } mapT :: (a->b) -> TypeMapX a -> TypeMapX b mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon - , tm_forall = tforall, tm_tylit = tlit + , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit , tm_coerce = tcoerce }) = TM { tm_var = mapTM f tvar , tm_app = mapTM (mapTM f) tapp , tm_tycon = mapTM f ttycon + , tm_funty = mapTM (mapTM (mapTM f)) tfunty , tm_forall = mapTM (mapTM f) tforall , tm_tylit = mapTM f tlit , tm_coerce = fmap f tcoerce } @@ -233,6 +253,11 @@ lkT (D env ty) m = go ty m go (LitTy l) = tm_tylit >.> lkTyLit l go (ForAllTy (Bndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) >=> lkBndr env tv + go (FunTy InvisArg _ arg res) + | Just res_rep <- getRuntimeRep_maybe res + = tm_funty >.> lkG (D env arg) + >=> lkG (D env res_rep) + >=> lkG (D env res) go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) go (CastTy t _) = go t go (CoercionTy {}) = tm_coerce @@ -245,6 +270,10 @@ xtT (D env (TyVarTy v)) f m = m { tm_var = tm_var m |> xtVar env v f } xtT (D env (AppTy t1 t2)) f m = m { tm_app = tm_app m |> xtG (D env t1) |>> xtG (D env t2) f } xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f } +xtT (D env (FunTy InvisArg _ t1 t2)) f m = m { tm_funty = tm_funty m |> xtG (D env t1) + |>> xtG (D env t2_rep) + |>> xtG (D env t2) f } + where t2_rep = expectJust "xtT FunTy InvisArg" (getRuntimeRep_maybe t2) xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } xtT (D env (CastTy t _)) f m = xtT (D env t) f m xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } @@ -258,10 +287,23 @@ fdT :: (a -> b -> b) -> TypeMapX a -> b -> b fdT k m = foldTM k (tm_var m) . foldTM (foldTM k) (tm_app m) . foldTM k (tm_tycon m) + . foldTM (foldTM (foldTM k)) (tm_funty m) . foldTM (foldTM k) (tm_forall m) . foldTyLit k (tm_tylit m) . foldMaybe k (tm_coerce m) +filterT :: (a -> Bool) -> TypeMapX a -> TypeMapX a +filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon + , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit + , tm_coerce = tcoerce }) + = TM { tm_var = filterTM f tvar + , tm_app = mapTM (filterTM f) tapp + , tm_tycon = filterTM f ttycon + , tm_funty = mapTM (mapTM (filterTM f)) tfunty + , tm_forall = mapTM (filterTM f) tforall + , tm_tylit = filterTM f tlit + , tm_coerce = filterMaybe f tcoerce } + ------------------------ data TyLitMap a = TLM { tlm_number :: Map.Map Integer a , tlm_string :: UniqFM FastString a @@ -274,6 +316,7 @@ instance TrieMap TyLitMap where alterTM = xtTyLit foldTM = foldTyLit mapTM = mapTyLit + filterTM = filterTyLit emptyTyLitMap :: TyLitMap a emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM } @@ -298,6 +341,10 @@ foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b foldTyLit l m = flip (foldUFM l) (tlm_string m) . flip (Map.foldr l) (tlm_number m) +filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a +filterTyLit f (TLM { tlm_number = tn, tlm_string = ts }) + = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts } + ------------------------------------------------- -- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this -- is the type you want. The keys in this map may have different kinds. @@ -321,6 +368,7 @@ instance TrieMap TypeMap where alterTM k f m = xtTT (deBruijnize k) f m foldTM k (TypeMap m) = foldTM (foldTM k) m mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m) + filterTM f (TypeMap m) = TypeMap (mapTM (filterTM f) m) foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b foldTypeMap k z m = foldTM k m z @@ -361,6 +409,7 @@ instance TrieMap LooseTypeMap where alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) foldTM f (LooseTypeMap m) = foldTM f m mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m) + filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m) {- ************************************************************************ @@ -435,6 +484,7 @@ instance TrieMap BndrMap where alterTM = xtBndr emptyCME foldTM = fdBndrMap mapTM = mapBndrMap + filterTM = ftBndrMap mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm) @@ -456,6 +506,8 @@ xtBndr :: forall a . CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a xtBndr env v xt (BndrMap tymap) = BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt)) +ftBndrMap :: (a -> Bool) -> BndrMap a -> BndrMap a +ftBndrMap f (BndrMap tm) = BndrMap (mapTM (filterTM f) tm) --------- Variable occurrence ------------- data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable @@ -468,6 +520,7 @@ instance TrieMap VarMap where alterTM = xtVar emptyCME foldTM = fdVar mapTM = mapVar + filterTM = ftVar mapVar :: (a->b) -> VarMap a -> VarMap b mapVar f (VM { vm_bvar = bv, vm_fvar = fv }) @@ -493,6 +546,10 @@ lkDFreeVar var env = lookupDVarEnv env var xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a xtDFreeVar v f m = alterDVarEnv f m v +ftVar :: (a -> Bool) -> VarMap a -> VarMap a +ftVar f (VM { vm_bvar = bv, vm_fvar = fv }) + = VM { vm_bvar = filterTM f bv, vm_fvar = filterTM f fv } + ------------------------------------------------- lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a lkDNamed n env = lookupDNameEnv env (getName n) diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs index dadb82c5f5..8277b06378 100644 --- a/compiler/GHC/Core/TyCo/FVs.hs +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -26,7 +26,8 @@ module GHC.Core.TyCo.FVs injectiveVarsOfType, injectiveVarsOfTypes, invisibleVarsOfType, invisibleVarsOfTypes, - -- No Free vars + -- Any and No Free vars + anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo, noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, -- * Well-scoped free variables @@ -47,7 +48,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes) -import Data.Monoid as DM ( Endo(..), All(..) ) +import Data.Monoid as DM ( Endo(..), Any(..) ) import GHC.Core.TyCo.Rep import GHC.Core.TyCon import GHC.Types.Var @@ -855,32 +856,43 @@ invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType {- ********************************************************************* * * - No free vars + Any free vars * * ********************************************************************* -} -nfvFolder :: TyCoFolder TyCoVarSet DM.All -nfvFolder = TyCoFolder { tcf_view = noView - , tcf_tyvar = do_tcv, tcf_covar = do_tcv - , tcf_hole = do_hole, tcf_tycobinder = do_bndr } +{-# INLINE afvFolder #-} -- so that specialization to (const True) works +afvFolder :: (TyCoVar -> Bool) -> TyCoFolder TyCoVarSet DM.Any +afvFolder check_fv = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } where - do_tcv is tv = All (tv `elemVarSet` is) - do_hole _ _ = All True -- I'm unsure; probably never happens + do_tcv is tv = Any (not (tv `elemVarSet` is) && check_fv tv) + do_hole _ _ = Any False -- I'm unsure; probably never happens do_bndr is tv _ = is `extendVarSet` tv -nfv_ty :: Type -> DM.All -nfv_tys :: [Type] -> DM.All -nfv_co :: Coercion -> DM.All -(nfv_ty, nfv_tys, nfv_co, _) = foldTyCo nfvFolder emptyVarSet +anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool +anyFreeVarsOfType check_fv ty = DM.getAny (f ty) + where (f, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet + +anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool +anyFreeVarsOfTypes check_fv tys = DM.getAny (f tys) + where (_, f, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet + +anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool +anyFreeVarsOfCo check_fv co = DM.getAny (f co) + where (_, _, f, _) = foldTyCo (afvFolder check_fv) emptyVarSet noFreeVarsOfType :: Type -> Bool -noFreeVarsOfType ty = DM.getAll (nfv_ty ty) +noFreeVarsOfType ty = not $ DM.getAny (f ty) + where (f, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet noFreeVarsOfTypes :: [Type] -> Bool -noFreeVarsOfTypes tys = DM.getAll (nfv_tys tys) +noFreeVarsOfTypes tys = not $ DM.getAny (f tys) + where (_, f, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet noFreeVarsOfCo :: Coercion -> Bool -noFreeVarsOfCo co = getAll (nfv_co co) +noFreeVarsOfCo co = not $ DM.getAny (f co) + where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet {- ********************************************************************* @@ -983,4 +995,3 @@ tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList -- | Get the free vars of types in scoped order tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList - diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index 1e8fcda0ca..0be6824b9d 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -37,7 +37,7 @@ module GHC.Core.TyCo.Rep ( -- * Coercions Coercion(..), UnivCoProvenance(..), - CoercionHole(..), BlockSubstFlag(..), coHoleCoVar, setCoHoleCoVar, + CoercionHole(..), coHoleCoVar, setCoHoleCoVar, CoercionN, CoercionR, CoercionP, KindCoercion, MCoercion(..), MCoercionR, MCoercionN, @@ -93,7 +93,7 @@ import GHC.Core.Coercion.Axiom import GHC.Builtin.Names ( liftedTypeKindTyConKey, manyDataConKey ) import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, manyDataConTy ) import GHC.Types.Basic ( LeftOrRight(..), pickLR ) -import GHC.Types.Unique ( hasKey ) +import GHC.Types.Unique ( hasKey, Uniquable(..) ) import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Misc @@ -1588,15 +1588,9 @@ data CoercionHole = CoercionHole { ch_co_var :: CoVar -- See Note [CoercionHoles and coercion free variables] - , ch_blocker :: BlockSubstFlag -- should this hole block substitution? - -- See (2a) in TcCanonical - -- Note [Equalities with incompatible kinds] , ch_ref :: IORef (Maybe Coercion) } -data BlockSubstFlag = YesBlockSubst - | NoBlockSubst - coHoleCoVar :: CoercionHole -> CoVar coHoleCoVar = ch_co_var @@ -1612,9 +1606,8 @@ instance Data.Data CoercionHole where instance Outputable CoercionHole where ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) -instance Outputable BlockSubstFlag where - ppr YesBlockSubst = text "YesBlockSubst" - ppr NoBlockSubst = text "NoBlockSubst" +instance Uniquable CoercionHole where + getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv {- Note [Phantom coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index b82dd5cb26..198b66959b 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -56,7 +56,7 @@ module GHC.Core.TyCon( mustBeSaturated, isPromotedDataCon, isPromotedDataCon_maybe, isKindTyCon, isLiftedTypeKindTyConName, - isTauTyCon, isFamFreeTyCon, + isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, isDataSumTyCon_maybe, @@ -817,10 +817,15 @@ data TyCon synIsTau :: Bool, -- True <=> the RHS of this synonym does not -- have any foralls, after expanding any -- nested synonyms - synIsFamFree :: Bool -- True <=> the RHS of this synonym does not mention + synIsFamFree :: Bool, -- True <=> the RHS of this synonym does not mention -- any type synonym families (data families -- are fine), again after expanding any -- nested synonyms + synIsForgetful :: Bool -- True <= at least one argument is not mentioned + -- in the RHS (or is mentioned only under + -- forgetful synonyms) + -- Test is conservative, so True does not guarantee + -- forgetfulness. } -- | Represents families (both type and data) @@ -1779,20 +1784,21 @@ mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm -- | Create a type synonym 'TyCon' mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> [Role] -> Type -> Bool -> Bool -> TyCon -mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free + -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon +mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful = SynonymTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConTyVars = binderVars binders, - tcRoles = roles, - synTcRhs = rhs, - synIsTau = is_tau, - synIsFamFree = is_fam_free + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConTyVars = binderVars binders, + tcRoles = roles, + synTcRhs = rhs, + synIsTau = is_tau, + synIsFamFree = is_fam_free, + synIsForgetful = is_forgetful } -- | Create a type family 'TyCon' @@ -2046,11 +2052,22 @@ isTauTyCon :: TyCon -> Bool isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau isTauTyCon _ = True +-- | Is this tycon neither a type family nor a synonym that expands +-- to a type family? isFamFreeTyCon :: TyCon -> Bool isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav isFamFreeTyCon _ = True +-- | Is this a forgetful type synonym? If this is a type synonym whose +-- RHS does not mention one (or more) of its bound variables, returns +-- True. Thus, False means that all bound variables appear on the RHS; +-- True may not mean anything, as the test to set this flag is +-- conservative. +isForgetfulSynTyCon :: TyCon -> Bool +isForgetfulSynTyCon (SynonymTyCon { synIsForgetful = forget }) = forget +isForgetfulSynTyCon _ = False + -- As for newtypes, it is in some contexts important to distinguish between -- closed synonyms and synonym families, as synonym families have no unique -- right hand side to which a synonym family application can expand. @@ -2118,7 +2135,7 @@ isClosedSynFamilyTyConWithAxiom_maybe (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing --- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an +-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an -- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is -- injective), or 'NotInjective' otherwise. tyConInjectivityInfo :: TyCon -> Injectivity diff --git a/compiler/GHC/Core/TyCon/Env.hs b/compiler/GHC/Core/TyCon/Env.hs index 76edb829fd..d5947a2fda 100644 --- a/compiler/GHC/Core/TyCon/Env.hs +++ b/compiler/GHC/Core/TyCon/Env.hs @@ -26,11 +26,11 @@ module GHC.Core.TyCon.Env ( DTyConEnv, - emptyDTyConEnv, + emptyDTyConEnv, isEmptyDTyConEnv, lookupDTyConEnv, delFromDTyConEnv, filterDTyConEnv, - mapDTyConEnv, - adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv, + mapDTyConEnv, mapMaybeDTyConEnv, + adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv, foldDTyConEnv ) where #include "HsVersions.h" @@ -116,6 +116,9 @@ type DTyConEnv a = UniqDFM TyCon a emptyDTyConEnv :: DTyConEnv a emptyDTyConEnv = emptyUDFM +isEmptyDTyConEnv :: DTyConEnv a -> Bool +isEmptyDTyConEnv = isNullUDFM + lookupDTyConEnv :: DTyConEnv a -> TyCon -> Maybe a lookupDTyConEnv = lookupUDFM @@ -128,6 +131,9 @@ filterDTyConEnv = filterUDFM mapDTyConEnv :: (a -> b) -> DTyConEnv a -> DTyConEnv b mapDTyConEnv = mapUDFM +mapMaybeDTyConEnv :: (a -> Maybe b) -> DTyConEnv a -> DTyConEnv b +mapMaybeDTyConEnv = mapMaybeUDFM + adjustDTyConEnv :: (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a adjustDTyConEnv = adjustUDFM @@ -136,3 +142,6 @@ alterDTyConEnv = alterUDFM extendDTyConEnv :: DTyConEnv a -> TyCon -> a -> DTyConEnv a extendDTyConEnv = addToUDFM + +foldDTyConEnv :: (elt -> a -> a) -> a -> DTyConEnv elt -> a +foldDTyConEnv = foldUDFM diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index b983671d11..3164e2626b 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -29,7 +29,7 @@ module GHC.Core.Type ( mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, - mkVisFunTy, mkInvisFunTy, + mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkVisFunTyMany, mkInvisFunTyMany, mkVisFunTysMany, mkInvisFunTysMany, @@ -155,6 +155,7 @@ module GHC.Core.Type ( coVarsOfType, coVarsOfTypes, + anyFreeVarsOfType, anyFreeVarsOfTypes, noFreeVarsOfType, splitVisVarsOfType, splitVisVarsOfTypes, expandTypeSynonyms, @@ -1343,11 +1344,19 @@ splitTyConApp_maybe = repSplitTyConApp_maybe . coreFullView -- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your -- type before using this function. -- +-- This does *not* split types headed with (=>), as that's not a TyCon in the +-- type-checker. +-- -- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' -tcSplitTyConApp_maybe ty = repSplitTyConApp_maybe ty +tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +tcSplitTyConApp_maybe (FunTy VisArg w arg res) + | Just arg_rep <- getRuntimeRep_maybe arg + , Just res_rep <- getRuntimeRep_maybe res + = Just (funTyCon, [w, arg_rep, res_rep, arg, res]) +tcSplitTyConApp_maybe _ = Nothing ------------------- repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) @@ -1358,7 +1367,7 @@ repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- have enough info to extract the runtime-rep arguments that -- the funTyCon requires. This will usually be true; -- but may be temporarily false during canonicalization: --- see Note [FunTy and decomposing tycon applications] in "GHC.Tc.Solver.Canonical" +-- see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical -- repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) repSplitTyConApp_maybe (FunTy _ w arg res) @@ -1966,13 +1975,17 @@ isCoVarType ty buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> KnotTied Type -> TyCon --- This function is here beucase here is where we have +-- This function is here because here is where we have -- isFamFree and isTauTy buildSynTyCon name binders res_kind roles rhs - = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free + = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful where - is_tau = isTauTy rhs - is_fam_free = isFamFreeTy rhs + is_tau = isTauTy rhs + is_fam_free = isFamFreeTy rhs + is_forgetful = any (not . (`elemVarSet` tyCoVarsOfType rhs) . binderVar) binders || + uniqSetAny isForgetfulSynTyCon (tyConsOfType rhs) + -- NB: This is allowed to be conservative, returning True more often + -- than it should. See comments on GHC.Core.TyCon.isForgetfulSynTyCon {- ************************************************************************ diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs index c99913d3be..a8f75535ab 100644 --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -24,7 +24,7 @@ module GHC.Core.Unify ( liftCoMatch, -- The core flattening algorithm - flattenTys + flattenTys, flattenTysX ) where #include "HsVersions.h" @@ -363,12 +363,6 @@ types are apart. This has practical consequences for the ability for closed type family applications to reduce. See test case indexed-types/should_compile/Overlap14. -Note [Unification with skolems] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we discover that two types unify if and only if a skolem variable is -substituted, we can't properly unify the types. But, that skolem variable -may later be instantiated with a unifyable type. So, we return maybeApart -in these cases. -} -- | Simple unification of two types; all type variables are bindable @@ -699,8 +693,9 @@ unifier It does /not/ work up to ~. The algorithm implemented here is rather delicate, and we depend on it to uphold certain properties. This is a summary of these required properties. Any reference to "flattening" refers to the flattening -algorithm in GHC.Core.FamInstEnv (See Note [Flattening] in GHC.Core.Unify), not -the flattening algorithm in the solver. +algorithm in GHC.Core.Unify (See +Note [Flattening type-family applications when matching instances] in GHC.Core.Unify), +not the flattening algorithm in the solver. Notation: θ,φ substitutions @@ -983,9 +978,11 @@ unify_ty env ty1 (TyVarTy tv2) kco = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) unify_ty env ty1 ty2 _kco + -- NB: This keeps Constraint and Type distinct, as it should for use in the + -- type-checker. | Just (tc1, tys1) <- mb_tc_app1 , Just (tc2, tys2) <- mb_tc_app2 - , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2) + , tc1 == tc2 = if isInjectiveTyCon tc1 Nominal then unify_tys env tys1 tys2 else do { let inj | isTypeFamilyTyCon tc1 @@ -1034,6 +1031,16 @@ unify_ty env ty1 (AppTy ty2a ty2b) _kco | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + -- tcSplitTyConApp won't split a (=>), so we handle this separately. +unify_ty env (FunTy InvisArg _w1 arg1 res1) (FunTy InvisArg _w2 arg2 res2) _kco + -- Look at result representations, but arg representations would be redundant + -- as anything that can appear to the left of => is lifted. + -- And anything that can appear to the left of => is unrestricted, so skip the + -- multiplicities. + | Just res_rep1 <- getRuntimeRep_maybe res1 + , Just res_rep2 <- getRuntimeRep_maybe res2 + = unify_tys env [res_rep1, arg1, res1] [res_rep2, arg2, res2] + unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco @@ -1163,12 +1170,12 @@ uUnrefined env tv1' ty2 ty2' kco -- How could this happen? If we're only matching and if -- we're comparing forall-bound variables. - _ -> maybeApart -- See Note [Unification with skolems] + _ -> surelyApart }}}} uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable = case tvBindFlag env tv1' of - Skolem -> maybeApart -- See Note [Unification with skolems] + Skolem -> surelyApart BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) bindTv :: UMEnv -> OutTyVar -> Type -> UM () @@ -1211,6 +1218,9 @@ data BindFlag | Skolem -- This type variable is a skolem constant -- Don't bind it; it only matches itself + -- These variables are SurelyApart from other types + -- See Note [Binding when looking up instances] in GHC.Core.InstEnv + -- for why it must be SurelyApart. deriving Eq {- @@ -1616,8 +1626,8 @@ pushRefl co = * * ************************************************************************ -Note [Flattening] -~~~~~~~~~~~~~~~~~ +Note [Flattening type-family applications when matching instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As described in "Closed type families with overlapping equations" http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf we need to flatten core types before unifying them, when checking for "surely-apart" @@ -1646,6 +1656,15 @@ can see that (F x x) can reduce to Double. So, it had better be the case that (F blah blah) can reduce to Double, no matter what (blah) is! Flattening as done below ensures this. +We also use this flattening operation to check for class instances. +If we have + instance C (Maybe b) + instance {-# OVERLAPPING #-} C (Maybe Bool) + [W] C (Maybe (F a)) +we want to know that the second instance might match later. So we +flatten the (F a) in the target before trying to unify with instances. +(This is done in GHC.Core.InstEnv.lookupInstEnv'.) + The algorithm works by building up a TypeMap TyVar, mapping type family applications to fresh variables. This mapping must be threaded through all the function calls, as any entry in @@ -1758,11 +1777,11 @@ flattenTys is defined here because of module dependencies. -} data FlattenEnv - = FlattenEnv { fe_type_map :: TypeMap TyVar + = FlattenEnv { fe_type_map :: TypeMap (TyVar, TyCon, [Type]) -- domain: exactly-saturated type family applications - -- range: fresh variables + -- range: (fresh variable, type family tycon, args) , fe_in_scope :: InScopeSet } - -- See Note [Flattening] + -- See Note [Flattening type-family applications when matching instances] emptyFlattenEnv :: InScopeSet -> FlattenEnv emptyFlattenEnv in_scope @@ -1773,13 +1792,29 @@ updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) } flattenTys :: InScopeSet -> [Type] -> [Type] --- See Note [Flattening] --- NB: the returned types may mention fresh type variables, --- arising from the flattening. We don't return the --- mapping from those fresh vars to the ty-fam --- applications they stand for (we could, but no need) -flattenTys in_scope tys - = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys +-- See Note [Flattening type-family applications when matching instances] +flattenTys in_scope tys = fst (flattenTysX in_scope tys) + +flattenTysX :: InScopeSet -> [Type] -> ([Type], TyVarEnv (TyCon, [Type])) +-- See Note [Flattening type-family applications when matching instances] +-- NB: the returned types mention the fresh type variables +-- in the domain of the returned env, whose range includes +-- the original type family applications. Building a substitution +-- from this information and applying it would yield the original +-- types -- almost. The problem is that the original type might +-- have something like (forall b. F a b); the returned environment +-- can't really sensibly refer to that b. So it may include a locally- +-- bound tyvar in its range. Currently, the only usage of this env't +-- checks whether there are any meta-variables in it +-- (in GHC.Tc.Solver.Monad.mightMatchLater), so this is all OK. +flattenTysX in_scope tys + = let (env, result) = coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys in + (result, build_env (fe_type_map env)) + where + build_env :: TypeMap (TyVar, TyCon, [Type]) -> TyVarEnv (TyCon, [Type]) + build_env env_in + = foldTM (\(tv, tc, tys) env_out -> extendVarEnv env_out tv (tc, tys)) + env_in emptyVarEnv coreFlattenTys :: TvSubstEnv -> FlattenEnv -> [Type] -> (FlattenEnv, [Type]) @@ -1841,7 +1876,7 @@ coreFlattenCo subst env co (env1, kind') = coreFlattenTy subst env (coercionType co) covar = mkFlattenFreshCoVar (fe_in_scope env1) kind' -- Add the covar to the FlattenEnv's in-scope set. - -- See Note [Flattening], wrinkle 2A. + -- See Note [Flattening type-family applications when matching instances], wrinkle 2A. env2 = updateInScopeSet env1 (flip extendInScopeSet covar) coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv @@ -1849,7 +1884,7 @@ coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv coreFlattenVarBndr subst env tv = (env2, subst', tv') where - -- See Note [Flattening], wrinkle 2B. + -- See Note [Flattening type-family applications when matching instances], wrinkle 2B. kind = varType tv (env1, kind') = coreFlattenTy subst env kind tv' = uniqAway (fe_in_scope env1) (setVarType tv kind') @@ -1862,26 +1897,30 @@ coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv -> (FlattenEnv, Type) coreFlattenTyFamApp tv_subst env fam_tc fam_args = case lookupTypeMap type_map fam_ty of - Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args') - Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc - tv = uniqAway in_scope $ - mkTyVar tyvar_name (typeKind fam_ty) - - ty' = mkAppTys (mkTyVarTy tv) leftover_args' - env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv - , fe_in_scope = extendInScopeSet in_scope tv } - in (env'', ty') + Just (tv, _, _) -> (env', mkAppTys (mkTyVarTy tv) leftover_args') + Nothing -> + let tyvar_name = mkFlattenFreshTyName fam_tc + tv = uniqAway in_scope $ + mkTyVar tyvar_name (typeKind fam_ty) + + ty' = mkAppTys (mkTyVarTy tv) leftover_args' + env'' = env' { fe_type_map = extendTypeMap type_map fam_ty + (tv, fam_tc, sat_fam_args) + , fe_in_scope = extendInScopeSet in_scope tv } + in (env'', ty') where arity = tyConArity fam_tc tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args ) splitAt arity fam_args -- Apply the substitution before looking up an application in the - -- environment. See Note [Flattening], wrinkle 1. + -- environment. See Note [Flattening type-family applications when matching instances], + -- wrinkle 1. -- NB: substTys short-cuts the common case when the substitution is empty. sat_fam_args' = substTys tcv_subst sat_fam_args (env', leftover_args') = coreFlattenTys tv_subst env leftover_args - -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening], + -- `fam_tc` may be over-applied to `fam_args` (see + -- Note [Flattening type-family applications when matching instances] -- wrinkle 3), so we split it into the arguments needed to saturate it -- (sat_fam_args') and the rest (leftover_args') fam_ty = mkTyConApp fam_tc sat_fam_args' diff --git a/compiler/GHC/Data/Bag.hs b/compiler/GHC/Data/Bag.hs index 75e7927a6b..e314309efc 100644 --- a/compiler/GHC/Data/Bag.hs +++ b/compiler/GHC/Data/Bag.hs @@ -17,7 +17,7 @@ module GHC.Data.Bag ( filterBag, partitionBag, partitionBagWith, concatBag, catBagMaybes, foldBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, - listToBag, bagToList, mapAccumBagL, + listToBag, nonEmptyToBag, bagToList, mapAccumBagL, concatMapBag, concatMapBagPair, mapMaybeBag, mapBagM, mapBagM_, flatMapBagM, flatMapBagPairM, @@ -35,6 +35,7 @@ import Control.Monad import Data.Data import Data.Maybe( mapMaybe ) import Data.List ( partition, mapAccumL ) +import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Foldable as Foldable infixr 3 `consBag` @@ -299,6 +300,10 @@ listToBag [] = EmptyBag listToBag [x] = UnitBag x listToBag vs = ListBag vs +nonEmptyToBag :: NonEmpty a -> Bag a +nonEmptyToBag (x :| []) = UnitBag x +nonEmptyToBag (x :| xs) = ListBag (x : xs) + bagToList :: Bag a -> [a] bagToList b = foldr (:) [] b diff --git a/compiler/GHC/Data/Maybe.hs b/compiler/GHC/Data/Maybe.hs index 230468a20e..ac9c687b62 100644 --- a/compiler/GHC/Data/Maybe.hs +++ b/compiler/GHC/Data/Maybe.hs @@ -16,7 +16,7 @@ module GHC.Data.Maybe ( failME, isSuccess, orElse, - firstJust, firstJusts, + firstJust, firstJusts, firstJustsM, whenIsJust, expectJust, rightToMaybe, @@ -31,6 +31,7 @@ import Control.Monad import Control.Monad.Trans.Maybe import Control.Exception (catch, SomeException(..)) import Data.Maybe +import Data.Foldable ( foldlM ) import GHC.Utils.Misc (HasCallStack) infixr 4 `orElse` @@ -51,6 +52,15 @@ firstJust a b = firstJusts [a, b] firstJusts :: [Maybe a] -> Maybe a firstJusts = msum +-- | Takes computations returnings @Maybes@; tries each one in order. +-- The first one to return a @Just@ wins. Returns @Nothing@ if all computations +-- return @Nothing@. +firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) +firstJustsM = foldlM go Nothing where + go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) + go Nothing action = action + go result@(Just _) _action = return result + expectJust :: HasCallStack => String -> Maybe a -> a {-# INLINE expectJust #-} expectJust _ (Just x) = x diff --git a/compiler/GHC/Data/TrieMap.hs b/compiler/GHC/Data/TrieMap.hs index 52a5b4ac78..54128d28f8 100644 --- a/compiler/GHC/Data/TrieMap.hs +++ b/compiler/GHC/Data/TrieMap.hs @@ -16,11 +16,11 @@ module GHC.Data.TrieMap( -- * Maps over 'Literal's LiteralMap, -- * 'TrieMap' class - TrieMap(..), insertTM, deleteTM, + TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM, -- * Things helpful for adding additional Instances. (>.>), (|>), (|>>), XT, - foldMaybe, + foldMaybe, filterMaybe, -- * Map for leaf compression GenMap, lkG, xtG, mapG, fdG, @@ -40,6 +40,8 @@ import GHC.Utils.Outputable import Control.Monad( (>=>) ) import Data.Kind( Type ) +import qualified Data.Semigroup as S + {- This module implements TrieMaps, which are finite mappings whose key is a structured value like a CoreExpr or Type. @@ -70,6 +72,7 @@ class TrieMap m where lookupTM :: forall b. Key m -> m b -> Maybe b alterTM :: forall b. Key m -> XT b -> m b -> m b mapTM :: (a->b) -> m a -> m b + filterTM :: (a -> Bool) -> m a -> m a foldTM :: (a -> b -> b) -> m a -> b -> b -- The unusual argument order here makes @@ -82,6 +85,13 @@ insertTM k v m = alterTM k (\_ -> Just v) m deleteTM :: TrieMap m => Key m -> m a -> m a deleteTM k m = alterTM k (\_ -> Nothing) m +foldMapTM :: (TrieMap m, Monoid r) => (a -> r) -> m a -> r +foldMapTM f m = foldTM (\ x r -> f x S.<> r) m mempty + +-- This looks inefficient. +isEmptyTM :: TrieMap m => m a -> Bool +isEmptyTM m = foldTM (\ _ _ -> False) m True + ---------------------- -- Recall that -- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c @@ -121,6 +131,7 @@ instance TrieMap IntMap.IntMap where alterTM = xtInt foldTM k m z = IntMap.foldr k z m mapTM f m = IntMap.map f m + filterTM f m = IntMap.filter f m xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a xtInt k f m = IntMap.alter f k m @@ -132,6 +143,7 @@ instance Ord k => TrieMap (Map.Map k) where alterTM k f m = Map.alter f k m foldTM k m z = Map.foldr k z m mapTM f m = Map.map f m + filterTM f m = Map.filter f m {- @@ -208,6 +220,7 @@ instance forall key. Uniquable key => TrieMap (UniqDFM key) where alterTM k f m = alterUDFM f m k foldTM k m z = foldUDFM k z m mapTM f m = mapUDFM f m + filterTM f m = filterUDFM f m {- ************************************************************************ @@ -229,6 +242,10 @@ instance TrieMap m => TrieMap (MaybeMap m) where alterTM = xtMaybe alterTM foldTM = fdMaybe mapTM = mapMb + filterTM = ftMaybe + +instance TrieMap m => Foldable (MaybeMap m) where + foldMap = foldMapTM mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b mapMb f (MM { mm_nothing = mn, mm_just = mj }) @@ -248,6 +265,19 @@ fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b fdMaybe k m = foldMaybe k (mm_nothing m) . foldTM k (mm_just m) +ftMaybe :: TrieMap m => (a -> Bool) -> MaybeMap m a -> MaybeMap m a +ftMaybe f (MM { mm_nothing = mn, mm_just = mj }) + = MM { mm_nothing = filterMaybe f mn, mm_just = filterTM f mj } + +foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b +foldMaybe _ Nothing b = b +foldMaybe k (Just a) b = k a b + +filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a +filterMaybe _ Nothing = Nothing +filterMaybe f input@(Just x) | f x = input + | otherwise = Nothing + {- ************************************************************************ * * @@ -267,6 +297,10 @@ instance TrieMap m => TrieMap (ListMap m) where alterTM = xtList alterTM foldTM = fdList mapTM = mapList + filterTM = ftList + +instance TrieMap m => Foldable (ListMap m) where + foldMap = foldMapTM instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where ppr m = text "List elts" <+> ppr (foldTM (:) m []) @@ -290,9 +324,9 @@ fdList :: forall m a b. TrieMap m fdList k m = foldMaybe k (lm_nil m) . foldTM (fdList k) (lm_cons m) -foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b -foldMaybe _ Nothing b = b -foldMaybe k (Just a) b = k a b +ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a +ftList f (LM { lm_nil = mnil, lm_cons = mcons }) + = LM { lm_nil = filterMaybe f mnil, lm_cons = mapTM (filterTM f) mcons } {- ************************************************************************ @@ -354,6 +388,10 @@ instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where alterTM = xtG foldTM = fdG mapTM = mapG + filterTM = ftG + +instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where + foldMap = foldMapTM --We want to be able to specialize these functions when defining eg --tries over (GenMap CoreExpr) which requires INLINEABLE @@ -403,3 +441,13 @@ fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b fdG _ EmptyMap = \z -> z fdG k (SingletonMap _ v) = \z -> k v z fdG k (MultiMap m) = foldTM k m + +{-# INLINEABLE ftG #-} +ftG :: TrieMap m => (a -> Bool) -> GenMap m a -> GenMap m a +ftG _ EmptyMap = EmptyMap +ftG f input@(SingletonMap _ v) + | f v = input + | otherwise = EmptyMap +ftG f (MultiMap m) = MultiMap (filterTM f m) + -- we don't have enough information to reconstruct the key to make + -- a SingletonMap diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 25acaab359..3d0908caa0 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -263,7 +263,7 @@ data GeneralFlag | Opt_RPath | Opt_RelativeDynlibPaths | Opt_Hpc - | Opt_FlatCache + | Opt_FamAppCache | Opt_ExternalInterpreter | Opt_OptimalApplicativeDo | Opt_VersionMacros diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 7be2da383c..024ac97c05 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3413,7 +3413,7 @@ fFlagsDeps = [ flagSpec "expose-internal-symbols" Opt_ExposeInternalSymbols, flagSpec "external-dynamic-refs" Opt_ExternalDynamicRefs, flagSpec "external-interpreter" Opt_ExternalInterpreter, - flagSpec "flat-cache" Opt_FlatCache, + flagSpec "family-application-cache" Opt_FamAppCache, flagSpec "float-in" Opt_FloatIn, flagSpec "force-recomp" Opt_ForceRecomp, flagSpec "ignore-optim-changes" Opt_IgnoreOptimChanges, @@ -3771,7 +3771,7 @@ defaultFlags settings = [ Opt_AutoLinkPackages, Opt_DiagnosticsShowCaret, Opt_EmbedManifest, - Opt_FlatCache, + Opt_FamAppCache, Opt_GenManifest, Opt_GhciHistory, Opt_GhciSandbox, diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index c8f45a307b..f17018492c 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -298,12 +298,19 @@ initTcDsForSolver thing_inside ; hsc_env <- getTopEnv ; let DsGblEnv { ds_mod = mod - , ds_fam_inst_env = fam_inst_env } = gbl + , ds_fam_inst_env = fam_inst_env + , ds_gbl_rdr_env = rdr_env } = gbl + -- This is *the* use of ds_gbl_rdr_env: + -- Make sure the solver (used by the pattern-match overlap checker) has + -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it + -- knows how to reduce type families, and which newtypes it can unwrap. + DsLclEnv { dsl_loc = loc } = lcl ; liftIO $ initTc hsc_env HsSrcFile False mod loc $ - updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $ + updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env + , tcg_rdr_env = rdr_env }) $ thing_inside } mkDsEnvs :: UnitState -> HomeUnit -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv @@ -318,6 +325,7 @@ mkDsEnvs unit_state home_unit mod rdr_env type_env fam_inst_env msg_var cc_st_va real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) gbl_env = DsGblEnv { ds_mod = mod , ds_fam_inst_env = fam_inst_env + , ds_gbl_rdr_env = rdr_env , ds_if_env = (if_genv, if_lenv) , ds_unqual = mkPrintUnqualified unit_state home_unit rdr_env , ds_msgs = msg_var diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs index 68da67d21e..aeeeb0c530 100644 --- a/compiler/GHC/HsToCore/Types.hs +++ b/compiler/GHC/HsToCore/Types.hs @@ -12,6 +12,7 @@ import GHC.Types.CostCentre.State import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Var +import GHC.Types.Name.Reader (GlobalRdrEnv) import GHC.Hs (LForeignDecl, HsExpr, GhcTc) import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches) import GHC.HsToCore.Pmc.Types (Nablas) @@ -42,6 +43,9 @@ data DsGblEnv = DsGblEnv { ds_mod :: Module -- For SCC profiling , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env + , ds_gbl_rdr_env :: GlobalRdrEnv -- needed *only* to know what newtype + -- constructors are in scope during + -- pattern-match satisfiability checking , ds_unqual :: PrintUnqualified , ds_msgs :: IORef Messages -- Warning messages , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs index 5a2b9b16fa..61a7824188 100644 --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -130,6 +130,8 @@ instance TrieMap StgArgMap where foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m) mapTM f (SAM {sam_var = varm, sam_lit = litm}) = SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm } + filterTM f (SAM {sam_var = varm, sam_lit = litm}) = + SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm } newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) } @@ -141,6 +143,7 @@ instance TrieMap ConAppMap where m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f } foldTM k = un_cam >.> foldTM (foldTM k) mapTM f = un_cam >.> mapTM (mapTM f) >.> CAM + filterTM f = un_cam >.> mapTM (filterTM f) >.> CAM ----------------- -- The CSE Env -- diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 028d9b16a6..c2c4c2c53b 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -210,8 +210,6 @@ report_unsolved type_errors expr_holes ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) ; wanted <- zonkWC wanted -- Zonk to reveal all information - -- If we are deferring we are going to need /all/ evidence around, - -- including the evidence produced by unflattening (zonkWC) ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs free_tvs = filterOut isCoVar $ tyCoVarsOfWCList wanted @@ -619,7 +617,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics -- also checks to make sure the constraint isn't BlockedCIS -- See TcCanonical Note [Equalities with incompatible kinds], (4) unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool - unblocked _ (CIrredCan { cc_status = BlockedCIS }) _ = False + unblocked _ (CIrredCan { cc_status = BlockedCIS {}}) _ = False unblocked checker ct pred = checker ct pred -- rigid_nom_eq, rigid_nom_tv_eq, @@ -678,7 +676,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics has_gadt_match [] = False has_gadt_match (implic : implics) | PatSkol {} <- ic_info implic - , not (ic_no_eqs implic) + , ic_given_eqs implic /= NoGivenEqs , ic_warn_inaccessible implic -- Don't bother doing this if -Winaccessible-code isn't enabled. -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance. @@ -888,7 +886,10 @@ maybeReportHoleError ctxt hole err -- Unlike maybeReportError, these "hole" errors are -- /not/ suppressed by cec_suppress. We want to see them! -maybeReportHoleError ctxt (Hole { hole_sort = TypeHole }) err +maybeReportHoleError ctxt (Hole { hole_sort = hole_sort }) err + | case hole_sort of TypeHole -> True + ConstraintHole -> True + _ -> False -- When -XPartialTypeSignatures is on, warnings (instead of errors) are -- generated for holes in partial type signatures. -- Unless -fwarn-partial-type-signatures is not on, @@ -900,7 +901,7 @@ maybeReportHoleError ctxt (Hole { hole_sort = TypeHole }) err HoleWarn -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err HoleDefer -> return () -maybeReportHoleError ctxt hole@(Hole { hole_sort = ExprHole _ }) err +maybeReportHoleError ctxt hole err -- Otherwise this is a typed hole in an expression, -- but not for an out-of-scope variable (because that goes through a -- different function) @@ -967,6 +968,8 @@ maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole ev_id }) = return () maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = TypeHole }) = return () +maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = ConstraintHole }) + = return () tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -- Use the first reporter in the list whose predicate says True @@ -1215,6 +1218,9 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ)) 2 (text "standing for" <+> quotes pp_hole_type_with_kind) , tyvars_msg, type_hole_hint ] + ConstraintHole -> vcat [ hang (text "Found extra-constraints wildcard standing for") + 2 (quotes $ pprType hole_ty) -- always kind constraint + , tyvars_msg, type_hole_hint ] pp_hole_type_with_kind | isLiftedTypeKind hole_kind @@ -1628,7 +1634,7 @@ misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 eq_pred = ctEvPred ev orig = ctEvOrigin ev level = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel - givens = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)] + 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] @@ -1686,7 +1692,10 @@ When reporting that GHC can't solve (a ~ c), there are two givens in scope: redundant), so it's not terribly useful to report it in an error message. To accomplish this, we discard any Implications that do not bind any equalities by filtering the `givens` selected in `misMatchOrCND` (based on -the `ic_no_eqs` field of the Implication). +the `ic_given_eqs` field of the Implication). Note that we discard givens +that have no equalities whatsoever, but we want to keep ones with only *local* +equalities, as these may be helpful to the user in understanding what went +wrong. But this is not enough to avoid all redundant givens! Consider this example, from #15361: @@ -1699,7 +1708,7 @@ Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope. The (* ~ *) part arises due the kinds of (:~~:) being unified. More importantly, (* ~ *) is redundant, so we'd like not to report it. However, the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its -ic_no_eqs field), so the test above will keep it wholesale. +ic_given_eqs field), so the test above will keep it wholesale. To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) part. This works because mkMinimalBySCs eliminates reflexive equalities in @@ -1741,7 +1750,7 @@ suggestAddSig ctxt ty1 _ty2 -- 'find' returns the binders of an InferSkol for 'tv', -- provided there is an intervening implication with - -- ic_no_eqs = False (i.e. a GADT match) + -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match) find [] _ _ = [] find (implic:implics) seen_eqs tv | tv `elem` ic_skols implic @@ -1749,7 +1758,7 @@ suggestAddSig ctxt ty1 _ty2 , seen_eqs = map fst prs | otherwise - = find implics (seen_eqs || not (ic_no_eqs implic)) tv + = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv -------------------- misMatchMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> Report diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index e1077b883a..896ded667b 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -829,8 +829,7 @@ mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty do { fam_envs <- tcGetFamInstEnvs ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty -- Unification may not have normalised the type, - -- (see Note [Lazy flattening] in GHC.Tc.Solver.Flatten) so do it - -- here to make it as uncomplicated as possible. + -- so do it here to make it as uncomplicated as possible. -- Example: f :: [F Int] -> Bool -- should be rewritten to f :: [Char] -> Bool, if possible -- diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 6e42b9e21e..0246426222 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -1189,6 +1189,11 @@ tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind = do { checkWiredInTyCon typeSymbolKindCon ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } +--------- Wildcards + +tc_hs_type mode ty@(HsWildCardTy _) ek + = tcAnonWildCardOcc NoExtraConstraint mode ty ek + --------- Potentially kind-polymorphic types: call the "up" checker -- See Note [Future-proofing the type checker] tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek @@ -1197,7 +1202,6 @@ tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsWildCardTy _) ek = tcAnonWildCardOcc mode ty ek {- Note [Variable Specificity and Forall Visibility] @@ -2071,8 +2075,9 @@ newNamedWildTyVar _name -- Currently ignoring the "_x" wildcard name used in t ; return tyvar } --------------------------- -tcAnonWildCardOcc :: TcTyMode -> HsType GhcRn -> Kind -> TcM TcType -tcAnonWildCardOcc (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }) +tcAnonWildCardOcc :: IsExtraConstraint + -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType +tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }) ty exp_kind -- hole_lvl: see Note [Checking partial type signatures] -- esp the bullet on nested forall types @@ -2086,7 +2091,7 @@ tcAnonWildCardOcc (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }) ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes) ; when emit_holes $ - emitAnonTypeHole wc_tv + emitAnonTypeHole is_extra wc_tv -- Why the 'when' guard? -- See Note [Wildcards in visible kind application] @@ -2107,7 +2112,7 @@ tcAnonWildCardOcc (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }) HM_FamPat -> False HM_VTA -> False -tcAnonWildCardOcc mode ty _ +tcAnonWildCardOcc _ mode ty _ -- mode_holes is Nothing. Should not happen, because renamer -- should already have rejected holes in unexpected places = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty) @@ -3805,7 +3810,7 @@ tcPartialContext mode hs_theta | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last = do { wc_tv_ty <- setSrcSpan wc_loc $ - tcAnonWildCardOcc mode ty constraintKind + tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind ; theta <- mapM (tc_lhs_pred mode) hs_theta1 ; return (theta, Just wc_tv_ty) } | otherwise diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index a1004e07c6..5500c7692c 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -898,6 +898,8 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs -- Get location from monad, not from ex_tvs -- This freshens: See Note [Freshen existentials] + -- Why "super"? See Note [Binding when lookup up instances] + -- in GHC.Core.InstEnv. ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys -- pat_ty' is type of the actual constructor application diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs index 620e585f8f..65e91608b9 100644 --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -523,7 +523,7 @@ tcLookupDataFamInst_maybe fam_inst_envs tc tc_args -- It is only used by the type inference engine (specifically, when -- solving representational equality), and hence it is careful to unwrap -- only if the relevant data constructor is in scope. That's why --- it get a GlobalRdrEnv argument. +-- it gets a GlobalRdrEnv argument. -- -- It is careful not to unwrap data/newtype instances if it can't -- continue unwrapping. Such care is necessary for proper error diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs index b27168a1fc..fc1b607dbe 100644 --- a/compiler/GHC/Tc/Plugin.hs +++ b/compiler/GHC/Tc/Plugin.hs @@ -80,7 +80,6 @@ import GHC.Core.Class import GHC.Driver.Env import GHC.Utils.Outputable import GHC.Core.Type -import GHC.Core.Coercion ( BlockSubstFlag(..) ) import GHC.Types.Id import GHC.Core.InstEnv import GHC.Data.FastString @@ -181,7 +180,7 @@ newEvVar = unsafeTcPluginTcM . TcM.newEvVar -- | Create a fresh coercion hole. newCoercionHole :: PredType -> TcPluginM CoercionHole -newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole YesBlockSubst +newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole -- | Bind an evidence variable. This must not be invoked from -- 'tcPluginInit' or 'tcPluginStop', or it will panic. diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index dc23ca54e6..8a2ff39116 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -258,13 +258,13 @@ floatKindEqualities wc = float_wc emptyVarSet wc | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag Hole) - float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_no_eqs = no_eqs + float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs , ic_skols = skols, ic_status = status }) | isInsolubleStatus status = Nothing -- A short cut /plus/ we must keep track of IC_BadTelescope | otherwise = do { (simples, holes) <- float_wc new_trapping_tvs wanted - ; when (not (isEmptyBag simples) && not no_eqs) $ + ; when (not (isEmptyBag simples) && given_eqs /= NoGivenEqs) $ Nothing -- If there are some constraints to float out, but we can't -- because we don't float out past local equalities @@ -938,7 +938,7 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds ; psig_theta_vars <- mapM TcM.newEvVar psig_theta ; wanted_transformed_incl_derivs <- setTcLevel rhs_tclvl $ - runTcSWithEvBinds ev_binds_var True $ + runTcSWithEvBinds ev_binds_var $ do { let loc = mkGivenLoc rhs_tclvl UnkSkol $ env_lcl tc_env psig_givens = mkGivens loc psig_theta_vars @@ -1025,13 +1025,13 @@ mkResidualConstraints rhs_tclvl ev_binds_var then return emptyBag else do implic1 <- newImplication return $ unitBag $ - implic1 { ic_tclvl = rhs_tclvl - , ic_skols = qtvs - , ic_given = full_theta_vars - , ic_wanted = inner_wanted - , ic_binds = ev_binds_var - , ic_no_eqs = False - , ic_info = skol_info } + implic1 { ic_tclvl = rhs_tclvl + , ic_skols = qtvs + , ic_given = full_theta_vars + , ic_wanted = inner_wanted + , ic_binds = ev_binds_var + , ic_given_eqs = MaybeGivenEqs + , ic_info = skol_info } ; return (emptyWC { wc_simple = outer_simple , wc_impl = implics })} @@ -1641,7 +1641,7 @@ simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints -- Solve the specified Wanted constraints -- Discard the evidence binds -- Discards all Derived stuff in result --- Postcondition: fully zonked and unflattened constraints +-- Postcondition: fully zonked simplifyWantedsTcM wanted = do { traceTc "simplifyWantedsTcM {" (ppr wanted) ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted)) @@ -1810,7 +1810,7 @@ solveImplication imp@(Implic { ic_tclvl = tclvl -- ; when debugIsOn check_tc_level -- Solve the nested constraints - ; (no_given_eqs, given_insols, residual_wanted) + ; (has_given_eqs, given_insols, residual_wanted) <- nestImplicTcS ev_binds_var tclvl $ do { let loc = mkGivenLoc tclvl info (ic_env imp) givens = mkGivens loc given_ids @@ -1821,16 +1821,16 @@ solveImplication imp@(Implic { ic_tclvl = tclvl -- we want to retain derived equalities so we can float -- them out in floatEqualities - ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols - -- Call getNoGivenEqs /after/ solveWanteds, because + ; (has_eqs, given_insols) <- getHasGivenEqs tclvl + -- Call getHasGivenEqs /after/ solveWanteds, because -- solveWanteds can augment the givens, via expandSuperClasses, -- to reveal given superclass equalities - ; return (no_eqs, given_insols, residual_wanted) } + ; return (has_eqs, given_insols, residual_wanted) } ; (floated_eqs, residual_wanted) <- floatEqualities skols given_ids ev_binds_var - no_given_eqs residual_wanted + has_given_eqs residual_wanted ; traceTcS "solveImplication 2" (ppr given_insols $$ ppr residual_wanted) @@ -1838,13 +1838,13 @@ solveImplication imp@(Implic { ic_tclvl = tclvl -- Don't lose track of the insoluble givens, -- which signal unreachable code; put them in ic_wanted - ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs + ; res_implic <- setImplicationStatus (imp { ic_given_eqs = has_given_eqs , ic_wanted = final_wanted }) ; evbinds <- TcS.getTcEvBindsMap ev_binds_var ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var ; traceTcS "solveImplication end }" $ vcat - [ text "no_given_eqs =" <+> ppr no_given_eqs + [ text "has_given_eqs =" <+> ppr has_given_eqs , text "floated_eqs =" <+> ppr floated_eqs , text "res_implic =" <+> ppr res_implic , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) @@ -2049,6 +2049,13 @@ simplifyHoles :: Bag Hole -> TcS (Bag Hole) simplifyHoles = mapBagM simpl_hole where simpl_hole :: Hole -> TcS Hole + + -- See Note [Do not simplify ConstraintHoles] + simpl_hole h@(Hole { hole_sort = ConstraintHole }) = return h + + -- other wildcards should be simplified for printing + -- we must do so here, and not in the error-message generation + -- code, because we have all the givens already set up simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc }) = do { ty' <- flattenType loc ty ; return (h { hole_ty = ty' }) } @@ -2093,6 +2100,41 @@ test T12227. But we don't get to discard all redundant equality superclasses, alas; see #15205. +Note [Do not simplify ConstraintHoles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before printing the inferred value for a type hole (a _ wildcard in +a partial type signature), we simplify it w.r.t. any Givens. This +makes for an easier-to-understand diagnostic for the user. + +However, we do not wish to do this for extra-constraint holes. Here is +the example for why (partial-sigs/should_compile/T12844): + + bar :: _ => FooData rngs + bar = foo + + data FooData rngs + + class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs + + type family Head (xs :: [k]) where Head (x ': xs) = x + +GHC correctly infers that the extra-constraints wildcard on `bar` +should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this constraint +as a Given on the implication constraint for `bar`. The Hole for +the _ is stored within the implication's WantedConstraints. +When simplifyHoles is called, that constraint is already assumed as +a Given. Simplifying with respect to it turns it into +('(r, r') ~ '(r, r'), Foo rngs), which is disastrous. + +Furthermore, there is no need to simplify here: extra-constraints wildcards +are filled in with the output of the solver, in chooseInferredQuantifiers +(choose_psig_context), so they are already simplified. (Contrast to normal +type holes, which are just bound to a meta-variable.) Avoiding the poor output +is simple: just don't simplify extra-constraints wildcards. + +This is the only reason we need to track ConstraintHole separately +from TypeHole in HoleSort. + Note [Tracking redundant constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With Opt_WarnRedundantConstraints, GHC can report which @@ -2268,7 +2310,7 @@ approximateWC float_past_equalities wc concatMapBag (float_implic trapping_tvs) implics float_implic :: TcTyCoVarSet -> Implication -> Cts float_implic trapping_tvs imp - | float_past_equalities || ic_no_eqs imp + | float_past_equalities || ic_given_eqs imp == NoGivenEqs = float_wc new_trapping_tvs (ic_wanted imp) | otherwise -- Take care with equalities = emptyCts -- See (1) under Note [ApproximateWC] @@ -2475,7 +2517,7 @@ no evidence for a fundep equality), but equality superclasses do matter (since they carry evidence). -} -floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool +floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> HasGivenEqs -> WantedConstraints -> TcS (Cts, WantedConstraints) -- Main idea: see Note [Float Equalities out of Implications] @@ -2493,16 +2535,17 @@ floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool -- Subtleties: Note [Float equalities from under a skolem binding] -- Note [Skolem escape] -- Note [What prevents a constraint from floating] -floatEqualities skols given_ids ev_binds_var no_given_eqs +floatEqualities skols given_ids ev_binds_var has_given_eqs wanteds@(WC { wc_simple = simples }) - | not no_given_eqs -- There are some given equalities, so don't float + | MaybeGivenEqs <- has_given_eqs -- There are some given equalities, so don't float = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] | otherwise - = do { -- First zonk: the inert set (from whence they came) is fully - -- zonked, but unflattening may have filled in unification - -- variables, and we /must/ see them. Otherwise we may float - -- constraints that mention the skolems! + = do { -- First zonk: the inert set (from whence they came) is not + -- necessarily fully zonked; equalities are not kicked out + -- if a unification cannot make progress. See Note + -- [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad, which + -- describes how the inert set might not actually be inert. simples <- TcS.zonkSimples simples ; binds <- TcS.getTcEvBindsMap ev_binds_var @@ -2629,10 +2672,9 @@ happen. In particular, float out equalities that are: of error messages. NB: generally we won't see (ty ~ alpha), with alpha on the right because - of Note [Unification variables on the left] in GHC.Tc.Utils.Unify. - But if we start with (F tys ~ alpha), it will orient as (fmv ~ alpha), - and unflatten back to (F tys ~ alpha). So we must look for alpha on - the right too. Example T4494. + of Note [Unification variables on the left] in GHC.Tc.Utils.Unify, + but if we have (F tys ~ alpha) and alpha is untouchable, then it will + appear on the right. Example T4494. * Nominal. No point in floating (alpha ~R# ty), because we do not unify representational equalities even if alpha is touchable. diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index 7068d3176d..60300b70f4 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} module GHC.Tc.Solver.Canonical( canonicalize, unifyDerived, - makeSuperClasses, maybeSym, + makeSuperClasses, StopOrContinue(..), stopWith, continueWith, solveCallStack -- For GHC.Tc.Solver ) where @@ -16,7 +17,7 @@ import GHC.Prelude import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Types.Origin -import GHC.Tc.Utils.Unify( swapOverTyVars, metaTyVarUpdateOK, MetaTyVarUpdateResult(..) ) +import GHC.Tc.Utils.Unify import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Tc.Solver.Flatten @@ -28,15 +29,17 @@ import GHC.Core.TyCon import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom import GHC.Core import GHC.Types.Id( mkTemplateLocals ) import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe ) import GHC.Types.Var import GHC.Types.Var.Env( mkInScopeSet ) -import GHC.Types.Var.Set( delVarSetList ) +import GHC.Types.Var.Set( delVarSetList, anyVarSet ) import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Builtin.Types ( anyTypeOfKind ) import GHC.Driver.Session( DynFlags ) import GHC.Types.Name.Set import GHC.Types.Name.Reader @@ -47,7 +50,7 @@ import GHC.Utils.Misc import GHC.Data.Bag import GHC.Utils.Monad import Control.Monad -import Data.Maybe ( isJust ) +import Data.Maybe ( isJust, isNothing ) import Data.List ( zip4 ) import GHC.Types.Basic @@ -89,53 +92,46 @@ last time through, so we can skip the classification step. canonicalize :: Ct -> TcS (StopOrContinue Ct) canonicalize (CNonCanonical { cc_ev = ev }) = {-# SCC "canNC" #-} - case classifyPredType pred of - ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys) - canClassNC ev cls tys - EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2) - canEqNC ev eq_rel ty1 ty2 - IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred) - canIrred OtherCIS ev - ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred) - canForAllNC ev tvs th p - where - pred = ctEvPred ev + canNC ev canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) = canForAll ev pend_sc -canonicalize (CIrredCan { cc_ev = ev, cc_status = status }) - | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev) - = -- For insolubles (all of which are equalities, do /not/ flatten the arguments +canonicalize (CIrredCan { cc_ev = ev }) + = canNC ev + -- Instead of flattening the evidence before classifying, it's possible we + -- can make progress without the flatten. Try this first. + -- For insolubles (all of which are equalities), do /not/ flatten the arguments -- In #14350 doing so led entire-unnecessary and ridiculously large -- type function expansion. Instead, canEqNC just applies -- the substitution to the predicate, and may do decomposition; -- e.g. a ~ [a], where [G] a ~ [Int], can decompose - canEqNC ev eq_rel ty1 ty2 - - | otherwise - = canIrred status ev canonicalize (CDictCan { cc_ev = ev, cc_class = cls , cc_tyargs = xis, cc_pend_sc = pend_sc }) = {-# SCC "canClass" #-} canClass ev cls xis pend_sc -canonicalize (CTyEqCan { cc_ev = ev - , cc_tyvar = tv - , cc_rhs = xi - , cc_eq_rel = eq_rel }) +canonicalize (CEqCan { cc_ev = ev + , cc_lhs = lhs + , cc_rhs = rhs + , cc_eq_rel = eq_rel }) = {-# SCC "canEqLeafTyVarEq" #-} - canEqNC ev eq_rel (mkTyVarTy tv) xi - -- NB: Don't use canEqTyVar because that expects flattened types, - -- and tv and xi may not be flat w.r.t. an updated inert set + canEqNC ev eq_rel (canEqLHSType lhs) rhs -canonicalize (CFunEqCan { cc_ev = ev - , cc_fun = fn - , cc_tyargs = xis1 - , cc_fsk = fsk }) - = {-# SCC "canEqLeafFunEq" #-} - canCFunEqCan ev fn xis1 fsk +canNC :: CtEvidence -> TcS (StopOrContinue Ct) +canNC ev = + case classifyPredType pred of + ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys) + canClassNC ev cls tys + EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2) + canEqNC ev eq_rel ty1 ty2 + IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred) + canIrred ev + ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred) + canForAllNC ev tvs th p + where + pred = ctEvPred ev {- ************************************************************************ @@ -206,8 +202,7 @@ canClass :: CtEvidence canClass ev cls tys pend_sc = -- all classes do *nominal* matching ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys ) - do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys - ; MASSERT( isTcReflCo _kind_co ) + do { (xis, cos) <- flattenArgsNom ev cls_tc tys ; let co = mkTcTyConAppCo Nominal cls_tc cos xi = mkClassPred cls xis mk_ct new_ev = CDictCan { cc_ev = new_ev @@ -701,24 +696,27 @@ See also Note [Evidence for quantified constraints] in GHC.Core.Predicate. ************************************************************************ -} -canIrred :: CtIrredStatus -> CtEvidence -> TcS (StopOrContinue Ct) +canIrred :: CtEvidence -> TcS (StopOrContinue Ct) -- Precondition: ty not a tuple and no other evidence form -canIrred status ev +canIrred ev = do { let pred = ctEvPred ev ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred) - ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred + ; (xi,co) <- flatten ev pred -- co :: xi ~ pred ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> do { -- Re-classify, in case flattening has improved its shape - -- Code is like the CNonCanonical case of canonicalize, except + -- Code is like the canNC, except -- that the IrredPred branch stops work ; case classifyPredType (ctEvPred new_ev) of ClassPred cls tys -> canClassNC new_ev cls tys EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2 - ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred) + ForAllPred tvs th p -> -- this is highly suspect; Quick Look + -- should never leave a meta-var filled + -- in with a polytype. This is #18987. + do traceTcS "canEvNC:forall" (ppr pred) canForAllNC ev tvs th p IrredPred {} -> continueWith $ - mkIrredCt status new_ev } } + mkIrredCt OtherCIS new_ev } } {- ********************************************************************* * * @@ -817,11 +815,8 @@ canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct) -- We have a constraint (forall as. blah => C tys) canForAll ev pend_sc = do { -- First rewrite it to apply the current substitution - -- Do not bother with type-family reductions; we can't - -- do them under a forall anyway (c.f. Flatten.flatten_one - -- on a forall type) let pred = ctEvPred ev - ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred + ; (xi,co) <- flatten ev pred -- co :: xi ~ pred ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> do { -- Now decompose into its pieces and solve it @@ -988,19 +983,12 @@ can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 -- Then, get rid of casts can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 - | not (isTyVarTy ty2) -- See (3) in Note [Equalities with incompatible kinds] + | isNothing (canEqLHS_maybe ty2) -- See (3) in Note [Equalities with incompatible kinds] = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ - | not (isTyVarTy ty1) -- See (3) in Note [Equalities with incompatible kinds] + | isNothing (canEqLHS_maybe ty1) -- See (3) in Note [Equalities with incompatible kinds] = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 --- NB: pattern match on True: we want only flat types sent to canEqTyVar. --- See also Note [No top-level newtypes on RHS of representational equalities] -can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2 - = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2 -can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2 - = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1 - ---------------------- -- Otherwise try to decompose ---------------------- @@ -1014,8 +1002,8 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ -- Decompose FunTy: (s -> t) and (c => t) -- NB: don't decompose (Int -> blah) ~ (Show a => blah) can_eq_nc' _flat _rdr_env _envs ev eq_rel - (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ - (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ + (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1 + (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2 | af1 == af2 -- Don't decompose (Int -> blah) ~ (Show a => blah) , Just ty1a_rep <- getRuntimeRep_maybe ty1a -- getRutimeRep_maybe: , Just ty1b_rep <- getRuntimeRep_maybe ty1b -- see Note [Decomposing FunTy] @@ -1026,11 +1014,14 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel [am2, ty2a_rep, ty2b_rep, ty2a, ty2b] -- Decompose type constructor applications --- NB: e have expanded type synonyms already -can_eq_nc' _flat _rdr_env _envs ev eq_rel - (TyConApp tc1 tys1) _ - (TyConApp tc2 tys2) _ - | not (isTypeFamilyTyCon tc1) +-- NB: we have expanded type synonyms already +can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _ + | Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1 + , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2 + -- we want to catch e.g. Maybe Int ~ (Int -> Int) here for better + -- error messages rather than decomposing into AppTys; + -- hence no direct match on TyConApp + , not (isTypeFamilyTyCon tc1) , not (isTypeFamilyTyCon tc2) = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 @@ -1041,22 +1032,51 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel = can_eq_nc_forall ev eq_rel s1 s2 -- See Note [Canonicalising type applications] about why we require flat types -can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _ - | NomEq <- eq_rel +-- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families +-- NB: Only decompose AppTy for nominal equality. See Note [Decomposing equality] +can_eq_nc' True _rdr_env _envs ev NomEq ty1 _ ty2 _ + | Just (t1, s1) <- tcSplitAppTy_maybe ty1 , Just (t2, s2) <- tcSplitAppTy_maybe ty2 = can_eq_app ev t1 s1 t2 s2 -can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _ - | NomEq <- eq_rel - , Just (t1, s1) <- tcSplitAppTy_maybe ty1 - = can_eq_app ev t1 s1 t2 s2 + +------------------- +-- Can't decompose. +------------------- -- No similarity in type structure detected. Flatten and try again. can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 - = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1 - ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2 + = do { (xi1, co1) <- flatten ev ps_ty1 + ; (xi2, co2) <- flatten ev ps_ty2 ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } +---------------------------- +-- Look for a canonical LHS. See Note [Canonical LHS]. +-- Only flat types end up below here. +---------------------------- + +-- NB: pattern match on True: we want only flat types sent to canEqLHS +-- This means we've rewritten any variables and reduced any type family redexes +-- See also Note [No top-level newtypes on RHS of representational equalities] +can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | Just can_eq_lhs1 <- canEqLHS_maybe ty1 + = canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2 + + | Just can_eq_lhs2 <- canEqLHS_maybe ty2 + = canEqCanLHS ev eq_rel IsSwapped can_eq_lhs2 ps_ty2 ty1 ps_ty1 + + -- If the type is TyConApp tc1 args1, then args1 really can't be less + -- than tyConArity tc1. It could be *more* than tyConArity, but then we + -- should have handled the case as an AppTy. That case only fires if + -- *both* sides of the equality are AppTy-like... but if one side is + -- AppTy-like and the other isn't (and it also isn't a variable or + -- saturated type family application, both of which are handled by + -- can_eq_nc'), we're in a failure mode and can just fall through. + +---------------------------- +-- Fall-through. Give up. +---------------------------- + -- We've flattened and the types don't match. Give up. can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) @@ -1461,7 +1481,7 @@ can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2 -- AppTys only decompose for nominal equality, so this case just leads -- to an irreducible constraint; see typecheck/should_compile/T10494 --- See Note [Decomposing equality], note {4} +-- 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] @@ -1615,7 +1635,7 @@ In this Note, "decomposition" refers to taking the constraint where that notation indicates a list of new constraints, where the new constraints may have different flavours and different roles. -The key property to consider is injectivity. When decomposing a Given the +The key property to consider is injectivity. When decomposing a Given, the decomposition is sound if and only if T is injective in all of its type arguments. When decomposing a Wanted, the decomposition is sound (assuming the correct roles in the produced equality constraints), but it may be a guess -- @@ -1633,56 +1653,53 @@ Pursuing the details requires exploring three axes: * Role: Nominal vs. Representational * TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable -(So a type variable isn't a TyCon, but it's convenient to put the AppTy case +(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 behavior regardless of evidence. +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 -to TyConApps with various TyCons T; the last line is for AppTy, where -there is presumably a type variable at the head, so it's actually - (s s1 ... sn) ~r (t t1 .. tn) +to TyConApps with various TyCons T; the last line is for AppTy, covering +both where there is a type variable at the head and the case for an over- +saturated type family. -NOMINAL GIVEN WANTED +NOMINAL GIVEN WANTED WHERE -Datatype YES YES -Newtype YES YES -Data family YES YES -Type family YES, in injective args{1} YES, in injective args{1} -Type variable YES YES +Datatype YES YES canTyConApp +Newtype YES YES canTyConApp +Data family YES YES canTyConApp +Type family NO{1} YES, in injective args{1} canEqCanLHS2 +AppTy YES YES can_eq_app -REPRESENTATIONAL GIVEN WANTED +REPRESENTATIONAL GIVEN WANTED -Datatype YES YES -Newtype NO{2} MAYBE{2} -Data family NO{3} MAYBE{3} -Type family NO NO -Type variable NO{4} NO{4} +Datatype YES YES canTyConApp +Newtype NO{2} MAYBE{2} canTyConApp(can_decompose) +Data family NO{3} MAYBE{3} canTyConApp(can_decompose) +Type family NO NO canEqCanLHS2 +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 Givens -when "decomposing" a partially-injective type family Given and new Deriveds -when "decomposing" a partially-injective type family Wanted. (As of the time of -writing, 13 June 2015, the implementation of injective type families has not -been merged, but it should be soon. Please delete this parenthetical if the -implementation is indeed merged.) +one. We thus proceed much like we do with superclasses, emitting new Deriveds +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. {2}: See Note [Decomposing newtypes at representational role] {3}: Because of the possibility of newtype instances, we must treat -data families like newtypes. See also Note [Decomposing newtypes at -representational role]. See #10534 and test case -typecheck/should_fail/T10534. +data families like newtypes. See also +Note [Decomposing newtypes at representational role]. See #10534 and +test case typecheck/should_fail/T10534. -{4}: Because type variables can stand in for newtypes, we conservatively do not -decompose AppTys over representational equality. +{4}: See Note [Decomposing AppTy at representational role] 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 @@ -1752,6 +1769,68 @@ Conclusion: * Decompose [W] N s ~R N t iff there no given constraint that could later solve it. +Note [Decomposing AppTy at representational role] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never decompose AppTy at a representational role. For Givens, doing +so is simply unsound: the LRCo coercion former requires a nominal-roled +arguments. (See (1) for an example of why.) For Wanteds, decomposing +would be sound, but it would be a guess, and a non-confluent one at that. + +Here is an example: + + [G] g1 :: a ~R b + [W] w1 :: Maybe b ~R alpha a + [W] w2 :: alpha ~ Maybe + +Suppose we see w1 before w2. If we were to decompose, we would decompose +this to become + + [W] w3 :: Maybe ~R alpha + [W] w4 :: b ~ a + +Note that w4 is *nominal*. A nominal role here is necessary because AppCo +requires a nominal role on its second argument. (See (2) for an example of +why.) If we decomposed w1 to w3,w4, we would then get stuck, because w4 +is insoluble. On the other hand, if we see w2 first, setting alpha := Maybe, +all is well, as we can decompose Maybe b ~R Maybe a into b ~R a. + +Another example: + + newtype Phant x = MkPhant Int + + [W] w1 :: Phant Int ~R alpha Bool + [W] w2 :: alpha ~ Phant + +If we see w1 first, decomposing would be disastrous, as we would then try +to solve Int ~ Bool. Instead, spotting w2 allows us to simplify w1 to become + + [W] w1' :: Phant Int ~R Phant Bool + +which can then (assuming MkPhant is in scope) be simplified to Int ~R Int, +and all will be well. See also Note [Unwrap newtypes first]. + +Bottom line: never decompose AppTy with representational roles. + +(1) Decomposing a Given AppTy over a representational role is simply +unsound. For example, if we have co1 :: Phant Int ~R a Bool (for +the newtype Phant, above), then we surely don't want any relationship +between Int and Bool, lest we also have co2 :: Phant ~ a around. + +(2) The role on the AppCo coercion is a conservative choice, because we don't +know the role signature of the function. For example, let's assume we could +have a representational role on the second argument of AppCo. Then, consider + + data G a where -- G will have a nominal role, as G is a GADT + MkG :: G Int + newtype Age = MkAge Int + + co1 :: G ~R a -- by assumption + co2 :: Age ~R Int -- by newtype axiom + co3 = AppCo co1 co2 :: G Age ~R a Int -- by our broken AppCo + +and now co3 can be used to cast MkG to have type G Age, in violation of +the way GADTs are supposed to work (which is to use nominal equality). + -} canDecomposableTyConAppOK :: CtEvidence -> EqRel @@ -1820,8 +1899,8 @@ canEqFailure :: CtEvidence -> EqRel canEqFailure ev NomEq ty1 ty2 = canEqHardFailure ev ty1 ty2 canEqFailure ev ReprEq ty1 ty2 - = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1 - ; (xi2, co2) <- flatten FM_FlattenAll ev ty2 + = do { (xi1, co1) <- flatten ev ty1 + ; (xi2, co2) <- flatten ev ty2 -- We must flatten the types before putting them in the -- inert set, so that we are sure to kick them out when -- new equalities become available @@ -1836,8 +1915,8 @@ canEqHardFailure :: CtEvidence -- See Note [Make sure that insolubles are fully rewritten] canEqHardFailure ev ty1 ty2 = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2) - ; (s1, co1) <- flatten FM_SubstOnly ev ty1 - ; (s2, co2) <- flatten FM_SubstOnly ev ty2 + ; (s1, co1) <- flatten ev ty1 + ; (s2, co2) <- flatten ev ty2 ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2 ; continueWith (mkIrredCt InsolubleCIS new_ev) } @@ -1858,10 +1937,7 @@ unifyWanted etc to short-cut that work. Note [Canonicalising type applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given (s1 t1) ~ ty2, how should we proceed? -The simple things is to see if ty2 is of form (s2 t2), and -decompose. By this time s1 and s2 can't be saturated type -function applications, because those have been dealt with -by an earlier equation in can_eq_nc, so it is always sound to +The simple thing is to see if ty2 is of form (s2 t2), and decompose. However, over-eager decomposition gives bad error messages @@ -1921,9 +1997,9 @@ Suppose we're in this situation: where newtype Id a = Id a -We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened +We want to make sure canEqCanLHS sees [W] a ~R a, after b is flattened and the Id newtype is unwrapped. This is assured by requiring only flat -types in canEqTyVar *and* having the newtype-unwrapping check above +types in canEqCanLHS *and* having the newtype-unwrapping check above the tyvar check in can_eq_nc. Note [Occurs check error] @@ -1942,104 +2018,83 @@ isInsolubleOccursCheck does. See also #10715, which induced this addition. -Note [canCFunEqCan] -~~~~~~~~~~~~~~~~~~~ -Flattening the arguments to a type family can change the kind of the type -family application. As an easy example, consider (Any k) where (k ~ Type) -is in the inert set. The original (Any k :: k) becomes (Any Type :: Type). -The problem here is that the fsk in the CFunEqCan will have the old kind. - -The solution is to come up with a new fsk/fmv of the right kind. For -givens, this is easy: just introduce a new fsk and update the flat-cache -with the new one. For wanteds, we want to solve the old one if favor of -the new one, so we use dischargeFmv. This also kicks out constraints -from the inert set; this behavior is correct, as the kind-change may -allow more constraints to be solved. - -We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case -if we really need to. Of course `flattenArgsNom` should return `Refl` -whenever possible, but #15577 was an infinite loop because even -though the coercion was homo-kinded, `kind_co` was not `Refl`, so we -made a new (identical) CFunEqCan, and then the entire process repeated. --} +Note [Put touchable variables on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticket #10009, a very nasty example: -canCFunEqCan :: CtEvidence - -> TyCon -> [TcType] -- LHS - -> TcTyVar -- RHS - -> TcS (StopOrContinue Ct) --- ^ Canonicalise a CFunEqCan. We know that --- the arg types are already flat, --- and the RHS is a fsk, which we must *not* substitute. --- So just substitute in the LHS -canCFunEqCan ev fn tys fsk - = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys - -- cos :: tys' ~ tys - - ; let lhs_co = mkTcTyConAppCo Nominal fn cos - -- :: F tys' ~ F tys - new_lhs = mkTyConApp fn tys' - - flav = ctEvFlavour ev - ; (ev', fsk') - <- if isTcReflexiveCo kind_co -- See Note [canCFunEqCan] - then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs) - ; let fsk_ty = mkTyVarTy fsk - ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty - lhs_co (mkTcNomReflCo fsk_ty) - ; return (ev', fsk) } - else do { traceTcS "canCFunEqCan: non-refl" $ - vcat [ text "Kind co:" <+> ppr kind_co - , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk) - , text "LHS:" <+> hang (ppr (mkTyConApp fn tys)) - 2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys))) - , text "New LHS" <+> hang (ppr new_lhs) - 2 (dcolon <+> ppr (tcTypeKind new_lhs)) ] - ; (ev', new_co, new_fsk) - <- newFlattenSkolem flav (ctEvLoc ev) fn tys' - ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co - -- sym lhs_co :: F tys ~ F tys' - -- new_co :: F tys' ~ new_fsk - -- co :: F tys ~ (new_fsk |> kind_co) - co = mkTcSymCo lhs_co `mkTcTransCo` - mkTcCoherenceRightCo Nominal - (mkTyVarTy new_fsk) - kind_co - new_co - - ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev) - ; dischargeFunEq ev fsk co xi - ; return (ev', new_fsk) } - - ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev') - ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn - , cc_tyargs = tys', cc_fsk = fsk' }) } + f :: (UnF (F b) ~ b) => F b -> () + + g :: forall a. (UnF (F a) ~ a) => a -> () + 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 + +g1 is canonical (CEqCan). It is oriented as above because a is not touchable. +See canEqTyVarFunEq. + +w1 is similarly canonical, though the occurs-check in canEqTyVarFunEq is key +here. + +w2 is canonical. But which way should it be oriented? As written, we'll be +stuck. When w2 is added to the inert set, nothing gets kicked out: g1 is +a Given (and Wanteds don't rewrite Givens), and w2 doesn't mention the LHS +of w2. We'll thus lose. + +But if w2 is swapped around, to + + [D] 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 +set (it mentions the LHS of w3). We then rewrite w1 to + + [D] w4 : UnF (F a) ~ beta + +and then, using g1, to + + [D] 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 flatten during canonicalisation.) + +But what about the new LHS makes it better? It mentions a variable (beta) +that can appear in a Wanted -- a touchable metavariable never appears +in a Given. On the other hand, the original LHS mentioned only variables +that appear in Givens. We thus choose to put variables that can appear +in Wanteds on the left. + +Ticket #12526 is another good example of this in action. + +-} --------------------- -canEqTyVar :: CtEvidence -- ev :: lhs ~ rhs - -> EqRel -> SwapFlag - -> TcTyVar -- tv1 - -> TcType -- lhs: pretty lhs, already flat - -> TcType -> TcType -- rhs: already flat - -> TcS (StopOrContinue Ct) -canEqTyVar ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 +canEqCanLHS :: CtEvidence -- ev :: lhs ~ rhs + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs (or, if swapped, rhs) + -> TcType -- lhs: pretty lhs, already flat + -> TcType -> TcType -- rhs: already flat + -> TcS (StopOrContinue Ct) +canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 | k1 `tcEqType` k2 - = canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 + = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 | otherwise - = canEqTyVarHetero ev eq_rel swapped tv1 ps_xi1 k1 xi2 ps_xi2 k2 + = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2 where - k1 = tyVarKind tv1 + k1 = canEqLHSKind lhs1 k2 = tcTypeKind xi2 -canEqTyVarHetero :: CtEvidence -- :: (tv1 :: ki1) ~ (xi2 :: ki2) - -> EqRel -> SwapFlag - -> TcTyVar -> TcType -- tv1, pretty tv1 - -> TcKind -- ki1 - -> TcType -> TcType -- xi2, pretty xi2 :: ki2 - -> TcKind -- ki2 - -> TcS (StopOrContinue Ct) -canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2 +canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2) + -> EqRel -> SwapFlag + -> CanEqLHS -> TcType -- xi1, pretty xi1 + -> TcKind -- ki1 + -> TcType -> TcType -- xi2, pretty xi2 :: ki2 + -> TcKind -- ki2 + -> TcS (StopOrContinue Ct) +canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 -- See Note [Equalities with incompatible kinds] = do { kind_co <- emit_kind_co -- :: ki2 ~N ki1 @@ -2050,15 +2105,14 @@ canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2 rhs_co = mkTcGReflLeftCo role xi2 kind_co -- rhs_co :: (xi2 |> kind_co) ~ xi2 - lhs' = mkTyVarTy tv1 -- same as old lhs - lhs_co = mkTcReflCo role lhs' + lhs_co = mkTcReflCo role xi1 ; traceTcS "Hetero equality gives rise to kind equality" (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ]) - ; type_ev <- rewriteEqEvidence ev swapped lhs' rhs' lhs_co rhs_co + ; type_ev <- rewriteEqEvidence ev swapped xi1 rhs' lhs_co rhs_co -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more - ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' } + ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 rhs' ps_rhs' } where emit_kind_co :: TcS CoercionN emit_kind_co @@ -2071,9 +2125,10 @@ canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2 | otherwise = unifyWanted kind_loc Nominal ki2 ki1 + xi1 = canEqLHSType lhs1 loc = ctev_loc ev role = eqRelRole eq_rel - kind_loc = mkKindLoc (mkTyVarTy tv1) xi2 loc + kind_loc = mkKindLoc xi1 xi2 loc kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki2 ki1 maybe_sym = case swapped of @@ -2082,104 +2137,236 @@ canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2 NotSwapped -> mkTcSymCo -- guaranteed that tcTypeKind lhs == tcTypeKind rhs -canEqTyVarHomo :: CtEvidence - -> EqRel -> SwapFlag - -> TcTyVar -- lhs: tv1 - -> TcType -- pretty lhs, flat - -> TcType -> TcType -- rhs, flat - -> TcS (StopOrContinue Ct) -canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _ - | Just (tv2, _) <- tcGetCastedTyVar_maybe xi2 - , tv1 == tv2 - = canEqReflexive ev eq_rel (mkTyVarTy tv1) - -- we don't need to check co because it must be reflexive - - -- this guarantees (TyEq:TV) - | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2 - , swapOverTyVars (isGiven ev) tv1 tv2 - = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) - ; let role = eqRelRole eq_rel - sym_co2 = mkTcSymCo co2 - ty1 = mkTyVarTy tv1 - new_lhs = ty1 `mkCastTy` sym_co2 - lhs_co = mkTcGReflLeftCo role ty1 sym_co2 +canEqCanLHSHomo :: CtEvidence + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs (or, if swapped, rhs) + -> TcType -- pretty lhs + -> TcType -> TcType -- rhs, pretty rhs + -> TcS (StopOrContinue Ct) +canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 + | (xi2', mco) <- split_cast_ty xi2 + , Just lhs2 <- canEqLHS_maybe xi2' + = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkTcSymMCo mco) mco - new_rhs = mkTyVarTy tv2 - rhs_co = mkTcGReflRightCo role new_rhs co2 + | otherwise + = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2 - ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co + where + split_cast_ty (CastTy ty co) = (ty, MCo co) + split_cast_ty other = (other, MRefl) + +-- This function deals with the case that both LHS and RHS are potential +-- CanEqLHSs. +canEqCanLHS2 :: CtEvidence -- lhs ~ (rhs |> mco) + -- or, if swapped: (rhs |> mco) ~ lhs + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs (or, if swapped, rhs) + -> TcType -- pretty lhs + -> CanEqLHS -- rhs + -> TcType -- pretty rhs + -> MCoercion -- :: kind(rhs) ~N kind(lhs) + -> TcS (StopOrContinue Ct) +canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco + | lhs1 `eqCanEqLHS` lhs2 + -- It must be the case that mco is reflexive + = canEqReflexive ev eq_rel (canEqLHSType lhs1) + | TyVarLHS tv1 <- lhs1 + , TyVarLHS tv2 <- lhs2 + , swapOverTyVars (isGiven ev) tv1 tv2 + = do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) + ; new_ev <- do_swap + ; canEqCanLHSFinish new_ev eq_rel IsSwapped (TyVarLHS tv2) + (ps_xi1 `mkCastTyMCo` sym_mco) } + + | TyVarLHS tv1 <- lhs1 + , TyFamLHS fun_tc2 fun_args2 <- lhs2 + = canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco + + | TyFamLHS fun_tc1 fun_args1 <- lhs1 + , TyVarLHS tv2 <- lhs2 + = do { new_ev <- do_swap + ; canEqTyVarFunEq new_ev eq_rel IsSwapped tv2 ps_xi2 + fun_tc1 fun_args1 ps_xi1 sym_mco } + + | TyFamLHS fun_tc1 fun_args1 <- lhs1 + , TyFamLHS fun_tc2 fun_args2 <- lhs2 + = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2) + + -- emit derived equalities for injective type families + ; let inj_eqns :: [TypeEqn] -- TypeEqn = Pair Type + inj_eqns + | ReprEq <- eq_rel = [] -- injectivity applies only for nom. eqs. + | fun_tc1 /= fun_tc2 = [] -- if the families don't match, stop. + + | Injective inj <- tyConInjectivityInfo fun_tc1 + = [ Pair arg1 arg2 + | (arg1, arg2, True) <- zip3 fun_args1 fun_args2 inj ] + + -- built-in synonym families don't have an entry point + -- for this use case. So, we just use sfInteractInert + -- and pass two equal RHSs. We *could* add another entry + -- point, but then there would be a burden to make + -- sure the new entry point and existing ones were + -- internally consistent. This is slightly distasteful, + -- but it works well in practice and localises the + -- problem. + | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc1 + = let ki1 = canEqLHSKind lhs1 + ki2 | MRefl <- mco + = ki1 -- just a small optimisation + | otherwise + = canEqLHSKind lhs2 + + fake_rhs1 = anyTypeOfKind ki1 + fake_rhs2 = anyTypeOfKind ki2 + in + sfInteractInert ops fun_args1 fake_rhs1 fun_args2 fake_rhs2 + + | otherwise -- ordinary, non-injective type family + = [] + + ; unless (isGiven ev) $ + mapM_ (unifyDerived (ctEvLoc ev) Nominal) inj_eqns + + ; tclvl <- getTcLevel ; dflags <- getDynFlags - ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) } + ; let tvs1 = tyCoVarsOfTypes fun_args1 + tvs2 = tyCoVarsOfTypes fun_args2 + + swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 && + -- swap 'em: Note [Put touchable variables on the left] + not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1) + -- this check is just to avoid unfruitful swapping + + -- If we have F a ~ F (F a), we want to swap. + swap_for_occurs + | MTVU_OK () <- checkTyFamEq dflags fun_tc2 fun_args2 + (mkTyConApp fun_tc1 fun_args1) + , MTVU_Occurs <- checkTyFamEq dflags fun_tc1 fun_args1 + (mkTyConApp fun_tc2 fun_args2) + = True + + | otherwise + = False + + ; if swap_for_rewriting || swap_for_occurs + then do { new_ev <- do_swap + ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) } + else finish_without_swapping } + + -- that's all the special cases. Now we just figure out which non-special case + -- to continue to. + | otherwise + = finish_without_swapping -canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_xi2 - = do { dflags <- getDynFlags - ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_xi2 } - --- The RHS here is either not a casted tyvar, or it's a tyvar but we want --- to rewrite the LHS to the RHS (as per swapOverTyVars) -canEqTyVar2 :: DynFlags - -> CtEvidence -- lhs ~ rhs (or, if swapped, orhs ~ olhs) - -> EqRel - -> SwapFlag - -> TcTyVar -- lhs = tv, flat - -> TcType -- rhs, flat - -> TcS (StopOrContinue Ct) --- LHS is an inert type variable, --- and RHS is fully rewritten, but with type synonyms + where + sym_mco = mkTcSymMCo mco + + do_swap = rewriteCastedEquality ev eq_rel swapped (canEqLHSType lhs1) (canEqLHSType lhs2) mco + finish_without_swapping = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco) + + +-- This function handles the case where one side is a tyvar and the other is +-- a type family application. Which to put on the left? +-- If we can unify the variable, put it on the left, as this may be our only +-- shot to unify. +-- Otherwise, put the function on the left, because it's generally better to +-- rewrite away function calls. This makes types smaller. And it seems necessary: +-- [W] F alpha ~ alpha +-- [W] F alpha ~ beta +-- [W] G alpha beta ~ Int ( where we have type instance G a a = a ) +-- If we end up with a stuck alpha ~ F alpha, we won't be able to solve this. +-- Test case: indexed-types/should_compile/CEqCanOccursCheck +-- It would probably work to always put the variable on the left, but we think +-- it would be less efficient. +canEqTyVarFunEq :: CtEvidence -- :: lhs ~ (rhs |> mco) + -- or (rhs |> mco) ~ lhs if swapped + -> EqRel -> SwapFlag + -> TyVar -> TcType -- lhs, pretty lhs + -> TyCon -> [Xi] -> TcType -- rhs fun, rhs args, pretty rhs + -> MCoercion -- :: kind(rhs) ~N kind(lhs) + -> TcS (StopOrContinue Ct) +canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco + = do { tclvl <- getTcLevel + ; dflags <- getDynFlags + ; if | isTouchableMetaTyVar tclvl tv1 + , MTVU_OK _ <- checkTyVarEq dflags YesTypeFamilies tv1 (ps_xi2 `mkCastTyMCo` mco) + -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) + (ps_xi2 `mkCastTyMCo` mco) + | otherwise + -> do { new_ev <- rewriteCastedEquality ev eq_rel swapped + (mkTyVarTy tv1) (mkTyConApp fun_tc2 fun_args2) + mco + ; canEqCanLHSFinish new_ev eq_rel IsSwapped + (TyFamLHS fun_tc2 fun_args2) + (ps_xi1 `mkCastTyMCo` sym_mco) } } + where + sym_mco = mkTcSymMCo mco + +-- The RHS here is either not CanEqLHS, or it's one that we +-- want to rewrite the LHS to (as per e.g. swapOverTyVars) +canEqCanLHSFinish :: CtEvidence + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs (or, if swapped, rhs) + -> TcType -- rhs, pretty rhs + -> TcS (StopOrContinue Ct) +canEqCanLHSFinish ev eq_rel swapped lhs rhs +-- RHS is fully rewritten, but with type synonyms -- preserved as much as possible -- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) --- the "flat" requirement guarantees (TyEq:AFF) -- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqTyVarHomo -canEqTyVar2 dflags ev eq_rel swapped tv1 rhs - -- this next line checks also for coercion holes; see - -- Note [Equalities with incompatible kinds] - | MTVU_OK rhs' <- mtvu -- No occurs check + + = do { dflags <- getDynFlags + ; new_ev <- rewriteEqEvidence ev swapped lhs_ty rhs rewrite_co1 rewrite_co2 + -- Must do the occurs check even on tyvar/tyvar -- equalities, in case have x ~ (y :: ..x...) -- #12593 -- guarantees (TyEq:OC), (TyEq:F), and (TyEq:H) - = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2 - ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1 - , cc_rhs = rhs', cc_eq_rel = eq_rel }) } + -- this next line checks also for coercion holes (TyEq:H); see + -- Note [Equalities with incompatible kinds] + ; case canEqOK dflags eq_rel lhs rhs of + CanEqOK -> + do { traceTcS "canEqOK" (ppr lhs $$ ppr rhs) + ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs + , cc_rhs = rhs, cc_eq_rel = eq_rel }) } + -- it is possible that cc_rhs mentions the LHS if the LHS is a type + -- family. This will cause later flattening to potentially loop, but + -- that will be caught by the depth counter. The other option is an + -- occurs-check for a function application, which seems awkward. + + CanEqNotOK status + -- See Note [Type variable cycles in Givens] + | OtherCIS <- status + , Given <- ctEvFlavour ev + , TyVarLHS lhs_tv <- lhs + , not (isCycleBreakerTyVar lhs_tv) -- See Detail (7) of Note + , NomEq <- eq_rel + -> do { traceTcS "canEqCanLHSFinish breaking a cycle" (ppr lhs $$ ppr rhs) + ; new_rhs <- breakTyVarCycle (ctEvLoc ev) rhs + ; traceTcS "new RHS:" (ppr new_rhs) + ; let new_pred = mkPrimEqPred (mkTyVarTy lhs_tv) new_rhs + new_new_ev = new_ev { ctev_pred = new_pred } + -- See Detail (6) of Note [Type variable cycles in Givens] + + ; if anyRewritableTyVar True NomEq (\ _ tv -> tv == lhs_tv) new_rhs + then do { traceTcS "Note [Type variable cycles in Givens] Detail (1)" + (ppr new_new_ev) + ; continueWith (mkIrredCt status new_ev) } + else continueWith (CEqCan { cc_ev = new_new_ev, cc_lhs = lhs + , cc_rhs = new_rhs, cc_eq_rel = eq_rel }) } - | otherwise -- For some reason (occurs check, or forall) we can't unify -- We must not use it for further rewriting! - = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs $$ ppr mtvu) - ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2 - ; let status | isInsolubleOccursCheck eq_rel tv1 rhs - = InsolubleCIS - -- If we have a ~ [a], it is not canonical, and in particular - -- we don't want to rewrite existing inerts with it, otherwise - -- we'd risk divergence in the constraint solver - - | MTVU_HoleBlocker <- mtvu - = BlockedCIS - -- This is the case detailed in - -- Note [Equalities with incompatible kinds] - - | otherwise - = OtherCIS - -- A representational equality with an occurs-check problem isn't - -- insoluble! For example: - -- a ~R b a - -- We might learn that b is the newtype Id. - -- But, the occurs-check certainly prevents the equality from being - -- canonical, and we might loop if we were to use it in rewriting. - - ; continueWith (mkIrredCt status new_ev) } + | otherwise + -> do { traceTcS "canEqCanLHSFinish can't make a canonical" (ppr lhs $$ ppr rhs) + ; continueWith (mkIrredCt status new_ev) } } where - mtvu = metaTyVarUpdateOK dflags tv1 rhs - -- Despite the name of the function, tv1 may not be a - -- unification variable; we are really checking that this - -- equality is ok to be used to rewrite others, i.e. that - -- it satisfies the conditions for CTyEqCan - role = eqRelRole eq_rel - lhs = mkTyVarTy tv1 + lhs_ty = canEqLHSType lhs - rewrite_co1 = mkTcReflCo role lhs + rewrite_co1 = mkTcReflCo role lhs_ty rewrite_co2 = mkTcReflCo role rhs -- | Solve a reflexive equality constraint @@ -2192,6 +2379,96 @@ canEqReflexive ev eq_rel ty mkTcReflCo (eqRelRole eq_rel) ty) ; stopWith ev "Solved by reflexivity" } +rewriteCastedEquality :: CtEvidence -- :: lhs ~ (rhs |> mco), or (rhs |> mco) ~ lhs + -> EqRel -> SwapFlag + -> TcType -- lhs + -> TcType -- rhs + -> MCoercion -- mco + -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs + -- result is independent of SwapFlag +rewriteCastedEquality ev eq_rel swapped lhs rhs mco + = rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co + where + new_lhs = lhs `mkCastTyMCo` sym_mco + lhs_co = mkTcGReflLeftMCo role lhs sym_mco + + new_rhs = rhs + rhs_co = mkTcGReflRightMCo role rhs mco + + sym_mco = mkTcSymMCo mco + role = eqRelRole eq_rel + +--------------------------------------------- +-- | Result of checking whether a RHS is suitable for pairing +-- with a CanEqLHS in a CEqCan. +data CanEqOK + = CanEqOK -- RHS is good + | CanEqNotOK CtIrredStatus -- don't proceed; explains why + +instance Outputable CanEqOK where + ppr CanEqOK = text "CanEqOK" + ppr (CanEqNotOK status) = text "CanEqNotOK" <+> ppr status + +-- | This function establishes most of the invariants needed to make +-- a CEqCan. +-- +-- TyEq:OC: Checked here. +-- TyEq:F: Checked here. +-- TyEq:K: assumed; ASSERTed here (that is, kind(lhs) = kind(rhs)) +-- TyEq:N: assumed; ASSERTed here (if eq_rel is R, rhs is not a newtype) +-- TyEq:TV: not checked (this is hard to check) +-- TyEq:H: Checked here. +canEqOK :: DynFlags -> EqRel -> CanEqLHS -> Xi -> CanEqOK +canEqOK dflags eq_rel lhs rhs + = ASSERT( good_rhs ) + case checkTypeEq dflags YesTypeFamilies lhs rhs of + MTVU_OK () -> CanEqOK + MTVU_Bad -> CanEqNotOK OtherCIS + -- Violation of TyEq:F + + MTVU_HoleBlocker -> CanEqNotOK (BlockedCIS holes) + where holes = coercionHolesOfType rhs + -- This is the case detailed in + -- Note [Equalities with incompatible kinds] + -- Violation of TyEq:H + + -- These are both a violation of TyEq:OC, but we + -- want to differentiate for better production of + -- error messages + MTVU_Occurs | TyVarLHS tv <- lhs + , isInsolubleOccursCheck eq_rel tv rhs -> CanEqNotOK InsolubleCIS + -- If we have a ~ [a], it is not canonical, and in particular + -- we don't want to rewrite existing inerts with it, otherwise + -- we'd risk divergence in the constraint solver + + -- NB: no occCheckExpand here; see Note [Flattening synonyms] + -- in GHC.Tc.Solver.Flatten + + | otherwise -> CanEqNotOK OtherCIS + -- A representational equality with an occurs-check problem isn't + -- insoluble! For example: + -- a ~R b a + -- We might learn that b is the newtype Id. + -- But, the occurs-check certainly prevents the equality from being + -- canonical, and we might loop if we were to use it in rewriting. + + -- This case also include type family occurs-check errors, which + -- are not generally insoluble + + where + good_rhs = kinds_match && not bad_newtype + + lhs_kind = canEqLHSKind lhs + rhs_kind = tcTypeKind rhs + + kinds_match = lhs_kind `tcEqType` rhs_kind + + bad_newtype | ReprEq <- eq_rel + , Just tc <- tyConAppTyCon_maybe rhs + = isNewTyCon tc + | otherwise + = False + {- Note [Equalities with incompatible kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What do we do when we have an equality @@ -2213,8 +2490,17 @@ where noDerived G = G noDerived _ = W -For Wanted/Derived, the [X] constraint is "blocked" (not CTyEqCan, is CIrred) -until the k1~k2 constraint solved: Wrinkle (2). +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_status of BlockedCIS 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). Wrinkles: @@ -2232,39 +2518,59 @@ Wrinkles: in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for tales of destruction. - So, we have an invariant on CTyEqCan (TyEq:H) that the RHS does not have - any coercion holes. This is checked in metaTyVarUpdateOK. We also - must be sure to kick out any constraints that mention coercion holes - when those holes get filled in. - - (2a) We don't want to do this for CoercionHoles that witness - CFunEqCans (that are produced by the flattener), as these will disappear - once we unflatten. So we remember in the CoercionHole structure - whether the presence of the hole should block substitution or not. - A bit gross, this. - - (2b) We must now absolutely make sure to kick out any constraints that - mention a newly-filled-in coercion hole. This is done in - kickOutAfterFillingCoercionHole. + 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 BlockedCIS status. 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. + + (2a) We must now kick out any constraints that mention a newly-filled-in + coercion hole, but only if there are no more remaining coercion + holes. This is done in kickOutAfterFillingCoercionHole. 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. (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the algorithm detailed here, producing [W] co :: k2 ~ k1, and adding [W] (a :: k1) ~ ((rhs |> co) :: k1) to the irreducibles. Some time later, we solve co, and fill in co's coercion hole. This kicks out - the irreducible as described in (2b). + the irreducible as described in (2a). But now, during canonicalization, we see the cast - and remove it, in canEqCast. By the time we get into canEqTyVar, the equality + and remove it, in canEqCast. By the time we get into canEqCanLHS, the equality is heterogeneous again, and the process repeats. To avoid this, we don't strip casts off a type if the other type - in the equality is a tyvar. And this is an improvement regardless: + in the equality is a CanEqLHS (the scenario above can happen with a + type family, too. testcase: typecheck/should_compile/T13822). + And this is an improvement regardless: because tyvars can, generally, unify with casted types, there's no reason to go through the work of stripping off the cast when the 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 only because - of wrinkle (2) is hard: what would we say to users? And we don't + (4) Reporting an error for a constraint that is blocked with status BlockedCIS + 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 @@ -2328,7 +2634,211 @@ However, if we encounter an equality constraint with a type synonym application on one side and a variable on the other side, we should NOT (necessarily) expand the type synonym, since for the purpose of good error messages we want to leave type synonyms unexpanded as much -as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqTyVar. +as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS. + +Note [Type variable cycles in Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this situation (from indexed-types/should_compile/GivenLoop): + + instance C (Maybe b) + [G] a ~ Maybe (F a) + [W] C a + +In order to solve the Wanted, we must use the Given to rewrite `a` to +Maybe (F a). But note that the Given has an occurs-check failure, and +so we can't straightforwardly add the Given to the inert set. + +The key idea is to replace the (F a) in the RHS of the Given with a +fresh variable, which we'll call a CycleBreakerTv, or cbv. Then, emit +a new Given to connect cbv with F a. So our situation becomes + + instance C (Maybe b) + [G] a ~ Maybe cbv + [G] F a ~ cbv + [W] C a + +Note the orientation of the second Given. The type family ends up +on the left; see commentary on canEqTyVarFunEq, which decides how to +orient such cases. No special treatment for CycleBreakerTvs is +necessary. This scenario is now easily soluble, by using the first +Given to rewrite the Wanted, which can now be solved. + +(The first Given actually also rewrites the second one. This causes +no trouble.) + +More generally, we detect this scenario by the following characteristics: + - a Given CEqCan constraint + - with a tyvar on its LHS + - with a soluble occurs-check failure + - and a nominal equality + +Having identified the scenario, we wish to replace all type family +applications on the RHS with fresh metavariables (with MetaInfo +CycleBreakerTv). This is done in breakTyVarCycle. These metavariables are +untouchable, but we also emit Givens relating the fresh variables to the type +family applications they replace. + +Of course, we don't want our fresh variables leaking into e.g. error messages. +So we fill in the metavariables with their original type family applications +after we're done running the solver (in nestImplicTcS and runTcSWithEvBinds). +This is done by restoreTyVarCycles, which uses the inert_cycle_breakers field in +InertSet, which contains the pairings invented in breakTyVarCycle. + +That is: + +We transform + [G] g : a ~ ...(F a)... +to + [G] (Refl a) : F a ~ cbv -- CEqCan + [G] g : a ~ ...cbv... -- CEqCan + +Note that +* `cbv` is a fresh cycle breaker variable. +* `cbv` is a is a meta-tyvar, but it is completely untouchable. +* We track the cycle-breaker variables in inert_cycle_breakers in InertSet +* We eventually fill in the cycle-breakers, with `cbv := F a`. + No one else fills in cycle-breakers! +* In inert_cycle_breakers, we remember the (cbv, F a) pair; that is, we + remember the /original/ type. The [G] F a ~ cbv constraint may be rewritten + by other givens (eg if we have another [G] a ~ (b,c), but at the end we + still fill in with cbv := F a +* This fill-in is done when solving is complete, by restoreTyVarCycles + in nestImplicTcS and runTcSWithEvBinds. +* The evidence for the new `F a ~ cbv` constraint is Refl, because we know this fill-in is + ultimately going to happen. + +There are drawbacks of this approach: + + 1. We apply this trick only for Givens, never for Wanted or Derived. + It wouldn't make sense for Wanted, because Wanted never rewrite. + But it's conceivable that a Derived would benefit from this all. + I doubt it would ever happen, though, so I'm holding off. + + 2. We don't use this trick for representational equalities, as there + is no concrete use case where it is helpful (unlike for nominal + equalities). Furthermore, because function applications can be + CanEqLHSs, but newtype applications cannot, the disparities between + the cases are enough that it would be effortful to expand the idea + to representational equalities. A quick attempt, with + + data family N a b + + f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b + f = coerce + + failed with "Could not match 'b' with 'b'." Further work is held off + until when we have a concrete incentive to explore this dark corner. + +Details: + + (1) We don't look under foralls, at all, when substituting away type family + applications, because doing so can never be fruitful. Recall that we + are in a case like [G] a ~ forall b. ... a .... Until we have a type + family that can pull the body out from a forall, this will always be + insoluble. Note also that the forall cannot be in an argument to a + type family, or that outer type family application would already have + been substituted away. + + However, we still must check to make sure that breakTyVarCycle actually + succeeds in getting rid of all occurrences of the offending variable. + If one is hidden under a forall, this won't be true. So we perform + an additional check after performing the substitution. + + Skipping this check causes typecheck/should_fail/GivenForallLoop to loop. + + (2) Our goal here is to avoid loops in rewriting. We can thus skip looking + in coercions, as we don't rewrite in coercions. + (There is no worry about unifying a meta-variable here: this Note is + only about Givens.) + + (3) As we're substituting, we can build ill-kinded + types. For example, if we have Proxy (F a) b, where (b :: F a), then + replacing this with Proxy cbv b is ill-kinded. However, we will later + set cbv := F a, and so the zonked type will be well-kinded again. + The temporary ill-kinded type hurts no one, and avoiding this would + be quite painfully difficult. + + Specifically, this detail does not contravene the Purely Kinded Type Invariant + (Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType). + The PKTI says that we can call typeKind on any type, without failure. + It would be violated if we, say, replaced a kind (a -> b) with a kind c, + because an arrow kind might be consulted in piResultTys. Here, we are + replacing one opaque type like (F a b c) with another, cbv (opaque in + that we never assume anything about its structure, like that it has a + result type or a RuntimeRep argument). + + (4) The evidence for the produced Givens is all just reflexive, because + we will eventually set the cycle-breaker variable to be the type family, + and then, after the zonk, all will be well. + + (5) The approach here is inefficient. For instance, we could choose to + affect only type family applications that mention the offending variable: + in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore, + we could try to detect cases like a ~ (F a, F a) and use the same + tyvar to replace F a. (Cf. + Note [Flattening type-family applications when matching instances] + in GHC.Core.Unify, which + goes to this extra effort.) There may be other opportunities for + improvement. However, this is really a very small corner case, always + tickled by a user-written Given. The investment to craft a clever, + performant solution seems unworthwhile. + + (6) We often get the predicate associated with a constraint from its + evidence. We thus must not only make sure the generated CEqCan's + fields have the updated RHS type, but we must also update the + evidence itself. As in Detail (4), we don't need to change the + evidence term (as in e.g. rewriteEqEvidence) because the cycle + breaker variables are all zonked away by the time we examine the + evidence. That is, we must set the ctev_pred of the ctEvidence. + This is implemented in canEqCanLHSFinish, with a reference to + this detail. + + (7) We don't wish to apply this magic to CycleBreakerTvs themselves. + Consider this, from typecheck/should_compile/ContextStack2: + + type instance TF (a, b) = (TF a, TF b) + t :: (a ~ TF (a, Int)) => ... + + [G] a ~ TF (a, Int) + + The RHS reduces, so we get + + [G] a ~ (TF a, TF Int) + + We then break cycles, to get + + [G] g1 :: a ~ (cbv1, cbv2) + [G] g2 :: TF a ~ cbv1 + [G] g3 :: TF Int ~ cbv2 + + g1 gets added to the inert set, as written. But then g2 becomes + the work item. g1 rewrites g2 to become + + [G] TF (cbv1, cbv2) ~ cbv1 + + which then uses the type instance to become + + [G] (TF cbv1, TF cbv2) ~ cbv1 + + which looks remarkably like the Given we started with. If left + unchecked, this will end up breaking cycles again, looping ad + infinitum (and resulting in a context-stack reduction error, + not an outright loop). The solution is easy: don't break cycles + if the var is already a CycleBreakerTv. Instead, we mark this + final Given as a CIrredCan with an OtherCIS status (it's not + insoluble). + + NB: When filling in CycleBreakerTvs, we fill them in with what + they originally stood for (e.g. cbv1 := TF a, cbv2 := TF Int), + not what may be in a rewritten constraint. + + Not breaking cycles fursther makes sense, because + we only want to break cycles for user-written loopy Givens, and + a CycleBreakerTv certainly isn't user-written. + +NB: This same situation (an equality like b ~ Maybe (F b)) can arise with +Wanteds, but we have no concrete case incentivising special treatment. It +would just be a CIrredCan. -} @@ -2479,26 +2989,22 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co | CtGiven { ctev_evar = old_evar } <- old_ev = do { let new_tm = evCoercion (lhs_co - `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar) + `mkTcTransCo` maybeTcSymCo swapped (mkTcCoVarCo old_evar) `mkTcTransCo` mkTcSymCo rhs_co) ; newGivenEvVar loc' (new_pred, new_tm) } | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev - = case dest of - HoleDest hole -> - do { (new_ev, hole_co) <- newWantedEq_SI (ch_blocker hole) 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) - ; let co = maybeSym swapped $ - mkSymCo lhs_co - `mkTransCo` hole_co - `mkTransCo` rhs_co - ; setWantedEq dest co - ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) - ; return new_ev } - - _ -> panic "rewriteEqEvidence" + = 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) + ; let co = maybeTcSymCo swapped $ + mkSymCo lhs_co + `mkTransCo` hole_co + `mkTransCo` rhs_co + ; setWantedEq dest co + ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) + ; return new_ev } #if __GLASGOW_HASKELL__ <= 810 | otherwise @@ -2513,7 +3019,14 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co loc = ctEvLoc old_ev loc' = bumpCtLocDepth loc -{- Note [unifyWanted and unifyDerived] +{- +************************************************************************ +* * + Unification +* * +************************************************************************ + +Note [unifyWanted and unifyDerived] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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. @@ -2619,7 +3132,3 @@ unify_derived loc role orig_ty1 orig_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 - -maybeSym :: SwapFlag -> TcCoercion -> TcCoercion -maybeSym IsSwapped co = mkTcSymCo co -maybeSym NotSwapped co = co diff --git a/compiler/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs index 22c92cff80..c94dc21f2a 100644 --- a/compiler/GHC/Tc/Solver/Flatten.hs +++ b/compiler/GHC/Tc/Solver/Flatten.hs @@ -5,18 +5,14 @@ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Tc.Solver.Flatten( - FlattenMode(..), flatten, flattenKind, flattenArgsNom, - rewriteTyVar, flattenType, - - unflattenWanteds + flattenType ) where #include "HsVersions.h" import GHC.Prelude -import GHC.Tc.Types import GHC.Core.TyCo.Ppr ( pprTyVar ) import GHC.Tc.Types.Constraint import GHC.Core.Predicate @@ -29,468 +25,35 @@ import GHC.Core.Coercion import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env +import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Tc.Solver.Monad as TcS -import GHC.Types.Basic( SwapFlag(..) ) import GHC.Utils.Misc -import GHC.Data.Bag +import GHC.Data.Maybe import Control.Monad import GHC.Utils.Monad ( zipWith3M ) -import Data.Foldable ( foldrM ) +import Data.List.NonEmpty ( NonEmpty(..) ) import Control.Arrow ( first ) {- -Note [The flattening story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* A CFunEqCan is either of form - [G] <F xis> : F xis ~ fsk -- fsk is a FlatSkolTv - [W] x : F xis ~ fmv -- fmv is a FlatMetaTv - where - x is the witness variable - xis are function-free - fsk/fmv is a flatten skolem; - it is always untouchable (level 0) - -* CFunEqCans can have any flavour: [G], [W], [WD] or [D] - -* KEY INSIGHTS: - - - A given flatten-skolem, fsk, is known a-priori to be equal to - F xis (the LHS), with <F xis> evidence. The fsk is still a - unification variable, but it is "owned" by its CFunEqCan, and - is filled in (unflattened) only by unflattenGivens. - - - A unification flatten-skolem, fmv, stands for the as-yet-unknown - type to which (F xis) will eventually reduce. It is filled in - - - - All fsk/fmv variables are "untouchable". To make it simple to test, - we simply give them TcLevel=0. This means that in a CTyVarEq, say, - fmv ~ Int - we NEVER unify fmv. - - - A unification flatten-skolem, fmv, ONLY gets unified when either - a) The CFunEqCan takes a step, using an axiom - b) By unflattenWanteds - They are never unified in any other form of equality. - For example [W] ffmv ~ Int is stuck; it does not unify with fmv. - -* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan. - That would destroy the invariant about the shape of a CFunEqCan, - and it would risk wanted/wanted interactions. The only way we - learn information about fsk is when the CFunEqCan takes a step. - - However we *do* substitute in the LHS of a CFunEqCan (else it - would never get to fire!) - -* Unflattening: - - We unflatten Givens when leaving their scope (see unflattenGivens) - - We unflatten Wanteds at the end of each attempt to simplify the - wanteds; see unflattenWanteds, called from solveSimpleWanteds. - -* Ownership of fsk/fmv. Each canonical [G], [W], or [WD] - CFunEqCan x : F xis ~ fsk/fmv - "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv. - Why? We make a fresh fsk/fmv when the constraint is born; - and we never rewrite the RHS of a CFunEqCan. - - In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W], - but does not "own" it. If we reduce a [D] F Int ~ fmv, where - say type instance F Int = ty, then we don't discharge fmv := ty. - Rather we simply generate [D] fmv ~ ty (in GHC.Tc.Solver.Interact.reduce_top_fun_eq, - and dischargeFmv) - -* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2 - then xis1 /= xis2 - i.e. at most one CFunEqCan with a particular LHS - -* Flattening a type (F xis): - - If we are flattening in a Wanted/Derived constraint - then create new [W] x : F xis ~ fmv - else create new [G] x : F xis ~ fsk - with fresh evidence variable x and flatten-skolem fsk/fmv - - - Add it to the work list - - - Replace (F xis) with fsk/fmv in the type you are flattening - - - You can also add the CFunEqCan to the "flat cache", which - simply keeps track of all the function applications you - have flattened. - - - If (F xis) is in the cache already, just - use its fsk/fmv and evidence x, and emit nothing. - - - No need to substitute in the flat-cache. It's not the end - of the world if we start with, say (F alpha ~ fmv1) and - (F Int ~ fmv2) and then find alpha := Int. Athat will - simply give rise to fmv1 := fmv2 via [Interacting rule] below - -* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv - - Flatten xis (to substitute any tyvars; there are already no functions) - cos :: xis ~ flat_xis - - New wanted x2 :: F flat_xis ~ fsk/fmv - - Add new wanted to flat cache - - Discharge x = F cos ; x2 - -* [Interacting rule] - (inert) [W] x1 : F tys ~ fmv1 - (work item) [W] x2 : F tys ~ fmv2 - Just solve one from the other: - x2 := x1 - fmv2 := fmv1 - This just unites the two fsks into one. - Always solve given from wanted if poss. - -* For top-level reductions, see Note [Top-level reductions for type functions] - in GHC.Tc.Solver.Interact - - -Why given-fsks, alone, doesn't work -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Could we get away with only flatten meta-tyvars, with no flatten-skolems? No. - - [W] w : alpha ~ [F alpha Int] - ----> flatten - w = ...w'... - [W] w' : alpha ~ [fsk] - [G] <F alpha Int> : F alpha Int ~ fsk - ---> unify (no occurs check) - alpha := [fsk] - -But since fsk = F alpha Int, this is really an occurs check error. If -that is all we know about alpha, we will succeed in constraint -solving, producing a program with an infinite type. - -Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk) -using axiom, zonking would not see it, so (x::alpha) sitting in the -tree will get zonked to an infinite type. (Zonking always only does -refl stuff.) - -Why flatten-meta-vars, alone doesn't work -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at Simple13, with unification-fmvs only - - [G] g : a ~ [F a] - ----> Flatten given - g' = g;[x] - [G] g' : a ~ [fmv] - [W] x : F a ~ fmv - ---> subst a in x - g' = g;[x] - x = F g' ; x2 - [W] x2 : F [fmv] ~ fmv - -And now we have an evidence cycle between g' and x! - -If we used a given instead (ie current story) - - [G] g : a ~ [F a] - ----> Flatten given - g' = g;[x] - [G] g' : a ~ [fsk] - [G] <F a> : F a ~ fsk - ----> Substitute for a - [G] g' : a ~ [fsk] - [G] F (sym g'); <F a> : F [fsk] ~ fsk - - -Why is it right to treat fmv's differently to ordinary unification vars? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - f :: forall a. a -> a -> Bool - g :: F Int -> F Int -> Bool - -Consider - f (x:Int) (y:Bool) -This gives alpha~Int, alpha~Bool. There is an inconsistency, -but really only one error. SherLoc may tell you which location -is most likely, based on other occurrences of alpha. - -Consider - g (x:Int) (y:Bool) -Here we get (F Int ~ Int, F Int ~ Bool), which flattens to - (fmv ~ Int, fmv ~ Bool) -But there are really TWO separate errors. - - ** We must not complain about Int~Bool. ** - -Moreover these two errors could arise in entirely unrelated parts of -the code. (In the alpha case, there must be *some* connection (eg -v:alpha in common envt).) - -Note [Unflattening can force the solver to iterate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at #10340: - type family Any :: * -- No instances - get :: MonadState s m => m s - instance MonadState s (State s) where ... - - foo :: State Any Any - foo = get - -For 'foo' we instantiate 'get' at types mm ss - [WD] MonadState ss mm, [WD] mm ss ~ State Any Any -Flatten, and decompose - [WD] MonadState ss mm, [WD] Any ~ fmv - [WD] mm ~ State fmv, [WD] fmv ~ ss -Unify mm := State fmv: - [WD] MonadState ss (State fmv) - [WD] Any ~ fmv, [WD] fmv ~ ss -Now we are stuck; the instance does not match!! So unflatten: - fmv := Any - ss := Any (*) - [WD] MonadState Any (State Any) - -The unification (*) represents progress, so we must do a second -round of solving; this time it succeeds. This is done by the 'go' -loop in solveSimpleWanteds. - -This story does not feel right but it's the best I can do; and the -iteration only happens in pretty obscure circumstances. - - -************************************************************************ -* * -* Examples - Here is a long series of examples I had to work through -* * -************************************************************************ - -Simple20 -~~~~~~~~ -axiom F [a] = [F a] - - [G] F [a] ~ a ---> - [G] fsk ~ a - [G] [F a] ~ fsk (nc) ---> - [G] F a ~ fsk2 - [G] fsk ~ [fsk2] - [G] fsk ~ a ---> - [G] F a ~ fsk2 - [G] a ~ [fsk2] - [G] fsk ~ a - ----------------------------------------- -indexed-types/should_compile/T44984 - - [W] H (F Bool) ~ H alpha - [W] alpha ~ F Bool ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 - - fmv1 ~ fmv2 - fmv0 ~ alpha - -flatten -~~~~~~~ - fmv0 := F Bool - fmv1 := H (F Bool) - fmv2 := H alpha - alpha := F Bool -plus - fmv1 ~ fmv2 - -But these two are equal under the above assumptions. -Solve by Refl. - - ---- under plan B, namely solve fmv1:=fmv2 eagerly --- - [W] H (F Bool) ~ H alpha - [W] alpha ~ F Bool ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 - - fmv1 ~ fmv2 - fmv0 ~ alpha ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 fmv2 := fmv1 - - fmv0 ~ alpha - -flatten - fmv0 := F Bool - fmv1 := H fmv0 = H (F Bool) - retain H alpha ~ fmv2 - because fmv2 has been filled - alpha := F Bool - - ----------------------------- -indexed-types/should_failt/T4179 - -after solving - [W] fmv_1 ~ fmv_2 - [W] A3 (FCon x) ~ fmv_1 (CFunEqCan) - [W] A3 (x (aoa -> fmv_2)) ~ fmv_2 (CFunEqCan) - ----------------------------------------- -indexed-types/should_fail/T7729a - -a) [W] BasePrimMonad (Rand m) ~ m1 -b) [W] tt m1 ~ BasePrimMonad (Rand m) - ----> process (b) first - BasePrimMonad (Ramd m) ~ fmv_atH - fmv_atH ~ tt m1 - ----> now process (a) - m1 ~ s_atH ~ tt m1 -- An obscure occurs check - - ----------------------------------------- -typecheck/TcTypeNatSimple - -Original constraint - [W] x + y ~ x + alpha (non-canonical) -==> - [W] x + y ~ fmv1 (CFunEqCan) - [W] x + alpha ~ fmv2 (CFuneqCan) - [W] fmv1 ~ fmv2 (CTyEqCan) - -(sigh) - ----------------------------------------- -indexed-types/should_fail/GADTwrong1 - - [G] Const a ~ () -==> flatten - [G] fsk ~ () - work item: Const a ~ fsk -==> fire top rule - [G] fsk ~ () - work item fsk ~ () - -Surely the work item should rewrite to () ~ ()? Well, maybe not; -it'a very special case. More generally, our givens look like -F a ~ Int, where (F a) is not reducible. - - ----------------------------------------- -indexed_types/should_fail/T8227: - -Why using a different can-rewrite rule in CFunEqCan heads -does not work. - -Assuming NOT rewriting wanteds with wanteds - - Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk - [W] fmv_aBk ~ fsk_aBh - - [G] Scalar fsk_aBg ~ fsk_aBh - [G] V a ~ f_aBg - - Worklist includes [W] Scalar fmv_aBi ~ fmv_aBk - fmv_aBi, fmv_aBk are flatten unification variables - - Work item: [W] V fsk_aBh ~ fmv_aBi - -Note that the inert wanteds are cyclic, because we do not rewrite -wanteds with wanteds. - - -Then we go into a loop when normalise the work-item, because we -use rewriteOrSame on the argument of V. - -Conclusion: Don't make canRewrite context specific; instead use -[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable. - - ----------------------------------------- - -Here is a somewhat similar case: - - type family G a :: * - - blah :: (G a ~ Bool, Eq (G a)) => a -> a - blah = error "urk" - - foo x = blah x - -For foo we get - [W] Eq (G a), G a ~ Bool -Flattening - [W] G a ~ fmv, Eq fmv, fmv ~ Bool -We can't simplify away the Eq Bool unless we substitute for fmv. -Maybe that doesn't matter: we would still be left with unsolved -G a ~ Bool. - --------------------------- -#9318 has a very simple program leading to - - [W] F Int ~ Int - [W] F Int ~ Bool - -We don't want to get "Error Int~Bool". But if fmv's can rewrite -wanteds, we will - - [W] fmv ~ Int - [W] fmv ~ Bool ----> - [W] Int ~ Bool - - ************************************************************************ * * * FlattenEnv & FlatM * The flattening environment & monad * * ************************************************************************ - -} -type FlatWorkListRef = TcRef [Ct] -- See Note [The flattening work list] - data FlattenEnv - = FE { fe_mode :: !FlattenMode - , fe_loc :: CtLoc -- See Note [Flattener CtLoc] - -- unbanged because it's bogus in rewriteTyVar + = FE { fe_loc :: !CtLoc -- See Note [Flattener CtLoc] , fe_flavour :: !CtFlavour , fe_eq_rel :: !EqRel -- See Note [Flattener EqRels] - , fe_work :: !FlatWorkListRef } -- See Note [The flattening work list] - -data FlattenMode -- Postcondition for all three: inert wrt the type substitution - = FM_FlattenAll -- Postcondition: function-free - | FM_SubstOnly -- See Note [Flattening under a forall] - --- | FM_Avoid TcTyVar Bool -- See Note [Lazy flattening] --- -- Postcondition: --- -- * tyvar is only mentioned in result under a rigid path --- -- e.g. [a] is ok, but F a won't happen --- -- * If flat_top is True, top level is not a function application --- -- (but under type constructors is ok e.g. [F a]) - -instance Outputable FlattenMode where - ppr FM_FlattenAll = text "FM_FlattenAll" - ppr FM_SubstOnly = text "FM_SubstOnly" - -eqFlattenMode :: FlattenMode -> FlattenMode -> Bool -eqFlattenMode FM_FlattenAll FM_FlattenAll = True -eqFlattenMode FM_SubstOnly FM_SubstOnly = True --- FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2 -eqFlattenMode _ _ = False - --- | The 'FlatM' monad is a wrapper around 'TcS' with the following --- extra capabilities: (1) it offers access to a 'FlattenEnv'; --- and (2) it maintains the flattening worklist. --- See Note [The flattening work list]. + } + +-- | The 'FlatM' monad is a wrapper around 'TcS' with a 'FlattenEnv' newtype FlatM a = FlatM { runFlatM :: FlattenEnv -> TcS a } deriving (Functor) @@ -504,45 +67,27 @@ instance Applicative FlatM where pure x = FlatM $ const (pure x) (<*>) = ap +instance HasDynFlags FlatM where + getDynFlags = liftTcS getDynFlags + liftTcS :: TcS a -> FlatM a liftTcS thing_inside = FlatM $ const thing_inside -emitFlatWork :: Ct -> FlatM () --- See Note [The flattening work list] -emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :) - -- convenient wrapper when you have a CtEvidence describing -- the flattening operation -runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a -runFlattenCtEv mode ev - = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev) - --- Run thing_inside (which does flattening), and put all --- the work it generates onto the main work list --- See Note [The flattening work list] -runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a -runFlatten mode loc flav eq_rel thing_inside - = do { flat_ref <- newTcRef [] - ; let fmode = FE { fe_mode = mode - , fe_loc = bumpCtLocDepth loc - -- See Note [Flatten when discharging CFunEqCan] - , fe_flavour = flav - , fe_eq_rel = eq_rel - , fe_work = flat_ref } - ; res <- runFlatM thing_inside fmode - ; new_flats <- readTcRef flat_ref - ; updWorkListTcS (add_flats new_flats) - ; return res } +runFlattenCtEv :: CtEvidence -> FlatM a -> TcS a +runFlattenCtEv ev + = runFlatten (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev) + +-- Run thing_inside (which does the flattening) +runFlatten :: CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a +runFlatten loc flav eq_rel thing_inside + = runFlatM thing_inside fmode where - add_flats new_flats wl - = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) } - - add_funeqs [] wl = wl - add_funeqs (f:fs) wl = add_funeqs fs (f:wl) - -- add_funeqs fs ws = reverse fs ++ ws - -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4] - -- = [f3,f2,f1,w1,w2,w3,w4] + fmode = FE { fe_loc = loc + , fe_flavour = flav + , fe_eq_rel = eq_rel } traceFlat :: String -> SDoc -> FlatM () traceFlat herald doc = liftTcS $ traceTcS herald doc @@ -567,9 +112,6 @@ getFlavourRole ; eq_rel <- getEqRel ; return (flavour, eq_rel) } -getMode :: FlatM FlattenMode -getMode = getFlatEnvField fe_mode - getLoc :: FlatM CtLoc getLoc = getFlatEnvField fe_loc @@ -585,14 +127,7 @@ setEqRel new_eq_rel thing_inside if new_eq_rel == fe_eq_rel env then runFlatM thing_inside env else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel }) - --- | Change the 'FlattenMode' in a 'FlattenEnv'. -setMode :: FlattenMode -> FlatM a -> FlatM a -setMode new_mode thing_inside - = FlatM $ \env -> - if new_mode `eqFlattenMode` fe_mode env - then runFlatM thing_inside env - else runFlatM thing_inside (env { fe_mode = new_mode }) +{-# INLINE setEqRel #-} -- | Make sure that flattening actually produces a coercion (in other -- words, make sure our flavour is not Derived) @@ -616,55 +151,6 @@ bumpDepth (FlatM thing_inside) ; thing_inside env' } {- -Note [The flattening work list] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The "flattening work list", held in the fe_work field of FlattenEnv, -is a list of CFunEqCans generated during flattening. The key idea -is this. Consider flattening (Eq (F (G Int) (H Bool)): - * The flattener recursively calls itself on sub-terms before building - the main term, so it will encounter the terms in order - G Int - H Bool - F (G Int) (H Bool) - flattening to sub-goals - w1: G Int ~ fuv0 - w2: H Bool ~ fuv1 - w3: F fuv0 fuv1 ~ fuv2 - - * Processing w3 first is BAD, because we can't reduce i t,so it'll - get put into the inert set, and later kicked out when w1, w2 are - solved. In #9872 this led to inert sets containing hundreds - of suspended calls. - - * So we want to process w1, w2 first. - - * So you might think that we should just use a FIFO deque for the work-list, - so that putting adding goals in order w1,w2,w3 would mean we processed - w1 first. - - * BUT suppose we have 'type instance G Int = H Char'. Then processing - w1 leads to a new goal - w4: H Char ~ fuv0 - We do NOT want to put that on the far end of a deque! Instead we want - to put it at the *front* of the work-list so that we continue to work - on it. - -So the work-list structure is this: - - * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on - top (extendWorkListFunEq), and take new work from the top - (selectWorkItem). - - * When flattening, emitFlatWork pushes new flattening goals (like - w1,w2,w3) onto the flattening work list, fe_work, another - push-down stack. - - * When we finish flattening, we *reverse* the fe_work stack - onto the wl_funeqs stack (which brings w1 to the top). - -The function runFlatten initialises the fe_work stack, and reverses -it onto wl_fun_eqs at the end. - Note [Flattener EqRels] ~~~~~~~~~~~~~~~~~~~~~~~ When flattening, we need to know which equality relation -- nominal @@ -693,32 +179,6 @@ will be essentially impossible. So, the official recommendation if a stack limit is hit is to disable the check entirely. Otherwise, there will be baffling, unpredictable errors. -Note [Lazy flattening] -~~~~~~~~~~~~~~~~~~~~~~ -The idea of FM_Avoid mode is to flatten less aggressively. If we have - a ~ [F Int] -there seems to be no great merit in lifting out (F Int). But if it was - a ~ [G a Int] -then we *do* want to lift it out, in case (G a Int) reduces to Bool, say, -which gets rid of the occurs-check problem. (For the flat_top Bool, see -comments above and at call sites.) - -HOWEVER, the lazy flattening actually seems to make type inference go -*slower*, not faster. perf/compiler/T3064 is a case in point; it gets -*dramatically* worse with FM_Avoid. I think it may be because -floating the types out means we normalise them, and that often makes -them smaller and perhaps allows more re-use of previously solved -goals. But to be honest I'm not absolutely certain, so I am leaving -FM_Avoid in the code base. What I'm removing is the unique place -where it is *used*, namely in GHC.Tc.Solver.Canonical.canEqTyVar. - -See also Note [Conservative unification check] in GHC.Tc.Utils.Unify, which gives -other examples where lazy flattening caused problems. - -Bottom line: FM_Avoid is unused for now (Nov 14). -Note: T5321Fun got faster when I disabled FM_Avoid - T5837 did too, but it's pathological anyway - Note [Phantoms in the flattener] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have @@ -730,8 +190,8 @@ is really irrelevant -- it will be ignored when solving for representational equality later on. So, we omit flattening `ty` entirely. This may violate the expectation of "xi"s for a bit, but the canonicaliser will soon throw out the phantoms when decomposing a TyConApp. (Or, the -canonicaliser will emit an insoluble, in which case the unflattened version -yields a better error message anyway.) +canonicaliser will emit an insoluble, in which case we get +a better error message anyway.) Note [No derived kind equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -751,52 +211,19 @@ changes the flavour from Derived just for this purpose. * flattening work gets put into the work list * * * ********************************************************************* - -Note [rewriteTyVar] -~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an injective function F and - inert_funeqs: F t1 ~ fsk1 - F t2 ~ fsk2 - inert_eqs: fsk1 ~ [a] - a ~ Int - fsk2 ~ [Int] - -We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to get the -[D] t1 ~ t2 from the injectiveness of F. So we flatten cc_fsk of CFunEqCans -when trying to find derived equalities arising from injectivity. -} -- | See Note [Flattening]. -- If (xi, co) <- flatten mode ev ty, then co :: xi ~r ty --- where r is the role in @ev@. If @mode@ is 'FM_FlattenAll', --- then 'xi' is almost function-free (Note [Almost function-free] --- in "GHC.Tc.Types"). -flatten :: FlattenMode -> CtEvidence -> TcType +-- where r is the role in @ev@. +flatten :: CtEvidence -> TcType -> TcS (Xi, TcCoercion) -flatten mode ev ty - = do { traceTcS "flatten {" (ppr mode <+> ppr ty) - ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty) +flatten ev ty + = do { traceTcS "flatten {" (ppr ty) + ; (ty', co) <- runFlattenCtEv ev (flatten_one ty) ; traceTcS "flatten }" (ppr ty') ; return (ty', co) } --- Apply the inert set as an *inert generalised substitution* to --- a variable, zonking along the way. --- See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad. --- Equivalently, this flattens the variable with respect to NomEq --- in a Derived constraint. (Why Derived? Because Derived allows the --- most about of rewriting.) Returns no coercion, because we're --- using Derived constraints. --- See Note [rewriteTyVar] -rewriteTyVar :: TcTyVar -> TcS TcType -rewriteTyVar tv - = do { traceTcS "rewriteTyVar {" (ppr tv) - ; (ty, _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $ - flattenTyVar tv - ; traceTcS "rewriteTyVar }" (ppr ty) - ; return ty } - where - fake_loc = pprPanic "rewriteTyVar used a CtLoc" (ppr tv) - -- specialized to flattening kinds: never Derived, always Nominal -- See Note [No derived kind equalities] -- See Note [Flattening] @@ -806,28 +233,29 @@ flattenKind loc flav ty ; let flav' = case flav of Derived -> Wanted WDeriv -- the WDeriv/WOnly choice matters not _ -> flav - ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty) + ; (ty', co) <- runFlatten loc flav' NomEq (flatten_one ty) ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic ; return (ty', co) } -- See Note [Flattening] -flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN) +flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion]) -- Externally-callable, hence runFlatten -- Flatten a vector of types all at once; in fact they are -- always the arguments of type family or class, so -- ctEvFlavour ev = Nominal -- and we want to flatten all at nominal role -- The kind passed in is the kind of the type family or class, call it T --- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys)) +-- 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 flattening may use a Derived equality ([D] a ~ ty) flattenArgsNom ev tc tys = do { traceTcS "flatten_args {" (vcat (map ppr tys)) ; (tys', cos, kind_co) - <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys) + <- runFlattenCtEv ev (flatten_args_tc tc Nothing tys) + ; MASSERT( isReflMCo kind_co ) ; traceTcS "flatten }" (vcat (map ppr tys')) - ; return (tys', cos, kind_co) } + ; return (tys', cos) } -- | Flatten 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 @@ -835,8 +263,7 @@ flattenArgsNom ev tc tys -- only givens. flattenType :: CtLoc -> TcType -> TcS TcType flattenType loc ty - -- More info about FM_SubstOnly in Note [Holes] in GHC.Tc.Types.Constraint - = do { (xi, _) <- runFlatten FM_SubstOnly loc Given NomEq $ + = do { (xi, _) <- runFlatten loc Given NomEq $ flatten_one ty -- use Given flavor so that it is rewritten -- only w.r.t. Givens, never Wanteds/Deriveds @@ -854,35 +281,31 @@ flattenType loc ty ~~~~~~~~~~~~~~~~~~~~ flatten ty ==> (xi, co) where - xi has no type functions, unless they appear under ForAlls + xi has no reducible type functions has no skolems that are mapped in the inert set has no filled-in metavariables co :: xi ~ ty Key invariants: - (F0) co :: xi ~ zonk(ty) + (F0) co :: xi ~ zonk(ty') where zonk(ty') ~ zonk(ty) (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) -Note that it is flatten's job to flatten *every type function it sees*. -flatten is only called on *arguments* to type functions, by canEqGiven. +Note that it is flatten's job to try to reduce *every type function it sees*. Flattening also: * zonks, removing any metavariables, and * applies the substitution embodied in the inert set -The result of flattening is *almost function-free*. See -Note [Almost function-free] in GHC.Tc.Utils. - Because flattening zonks and the returned coercion ("co" above) is also zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead, we can rely on this fact: - (F0) co :: xi ~ zonk(ty) + (F0) co :: xi ~ zonk(ty'), where zonk(ty') ~ zonk(ty) Note that the left-hand type of co is *always* precisely xi. The right-hand type may or may not be ty, however: if ty has unzonked filled-in metavariables, -then the right-hand type of co will be the zonked version of ty. +then the right-hand type of co will be the zonk-equal to ty. It is for this reason that we occasionally have to explicitly zonk, when (co :: xi ~ ty) is important even before we zonk the whole program. For example, see the FTRNotFollowed @@ -890,7 +313,7 @@ case in flattenTyVar. Why have these invariants on flattening? Because we sometimes use tcTypeKind during canonicalisation, and we want this kind to be zonked (e.g., see -GHC.Tc.Solver.Canonical.canEqTyVar). +GHC.Tc.Solver.Canonical.canEqCanLHS). Flattening is always homogeneous. That is, the kind of the result of flattening is always the same as the kind of the input, modulo zonking. More formally: @@ -903,26 +326,12 @@ Recall that in comments we use alpha[flat = ty] to represent a flattening skolem variable alpha which has been generated to stand in for ty. ------ Example of flattening a constraint: ------ - flatten (List (F (G Int))) ==> (xi, cc) - where - xi = List alpha - cc = { G Int ~ beta[flat = G Int], - F beta ~ alpha[flat = F beta] } -Here - * alpha and beta are 'flattening skolem variables'. - * All the constraints in cc are 'given', and all their coercion terms - are the identity. - -NB: Flattening Skolems only occur in canonical constraints, which -are never zonked, so we don't need to worry about zonking doing -accidental unflattening. - Note that we prefer to leave type synonyms unexpanded when possible, so when the flattener encounters one, it first asks whether its -transitive expansion contains any type function applications. If so, +transitive expansion contains any type function applications or is +forgetful -- that is, omits one or more type variables in its RHS. If so, it expands the synonym and proceeds; if not, it simply returns the -unexpanded synonym. +unexpanded synonym. See also Note [Flattening synonyms]. Note [flatten_args performance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -955,33 +364,34 @@ If we need to make this yet more performant, a possible way forward is to duplicate the flattener code for the nominal case, and make that case faster. This doesn't seem quite worth it, yet. -Note [flatten_exact_fam_app_fully performance] +Note [flatten_exact_fam_app performance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The refactor of GRefl seems to cause performance trouble for T9872x: -the allocation of flatten_exact_fam_app_fully_performance -increased. See note [Generalized reflexive coercion] in -GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the -current state. - -The explicit pattern match in homogenise_result helps with T9872a, b, c. - -Still, it increases the expected allocation of T9872d by ~2%. - -TODO: a step-by-step replay of the refactor to analyze the performance. - +Once we've got a flat rhs, we extend the famapp-cache to record +the result. Doing so can save lots of work when the same redex shows up more +than once. Note that we record the link from the redex all the way to its +*final* value, not just the single step reduction. + +If we can reduce the family application right away (the first call +to try_to_reduce), we do *not* add to the cache. There are two possibilities +here: 1) we just read the result from the cache, or 2) we used one type +family instance. In either case, recording the result in the cache doesn't +save much effort the next time around. And adding to the cache here is +actually disastrous: it more than doubles the allocations for T9872a. So +we skip adding to the cache here. -} {-# INLINE flatten_args_tc #-} flatten_args_tc :: TyCon -- T - -> [Role] -- Role r + -> Maybe [Role] -- Nothing: ambient role is Nominal; all args are Nominal + -- Otherwise: no assumptions; use roles provided -> [Type] -- Arg types [t1,..,tn] -> FlatM ( [Xi] -- List of flattened args [x1,..,xn] -- 1-1 corresp with [t1,..,tn] , [Coercion] -- List of arg coercions [co1,..,con] -- 1-1 corresp with [t1,..,tn] -- coi :: xi ~r ti - , CoercionN) -- Result coercion, rco + , MCoercionN) -- Result coercion, rco -- rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con)) flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet -- NB: TyCon kinds are always closed @@ -999,8 +409,9 @@ flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are -- named. -> Kind -> TcTyCoVarSet -- function kind; kind's free vars - -> [Role] -> [Type] -- these are in 1-to-1 correspondence - -> FlatM ([Xi], [Coercion], CoercionN) + -> Maybe [Role] -> [Type] -- these are in 1-to-1 correspondence + -- Nothing: use all Nominal + -> FlatM ([Xi], [Coercion], MCoercionN) -- Coercions :: Xi ~ Type, at roles given -- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys) -- That is, the third coercion relates the kind of some function (whose kind is @@ -1012,15 +423,12 @@ flatten_args orig_binders any_named_bndrs orig_inner_ki orig_fvs - orig_roles + orig_m_roles orig_tys - = if any_named_bndrs - then flatten_args_slow orig_binders - orig_inner_ki - orig_fvs - orig_roles - orig_tys - else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys + = case (orig_m_roles, any_named_bndrs) of + (Nothing, False) -> flatten_args_fast orig_tys + _ -> flatten_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys + where orig_roles = fromMaybe (repeat Nominal) orig_m_roles {-# INLINE flatten_args_fast #-} -- | fast path flatten_args, in which none of the binders are named and @@ -1028,75 +436,30 @@ flatten_args orig_binders -- There are many bang patterns in here. It's been observed that they -- greatly improve performance of an optimized build. -- The T9872 test cases are good witnesses of this fact. -flatten_args_fast :: [TyCoBinder] - -> Kind - -> [Role] - -> [Type] - -> FlatM ([Xi], [Coercion], CoercionN) -flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys - = fmap finish (iterate orig_tys orig_roles orig_binders) +flatten_args_fast :: [Type] + -> FlatM ([Xi], [Coercion], MCoercionN) +flatten_args_fast orig_tys + = fmap finish (iterate orig_tys) where iterate :: [Type] - -> [Role] - -> [TyCoBinder] - -> FlatM ([Xi], [Coercion], [TyCoBinder]) - iterate (ty:tys) (role:roles) (_:binders) = do - (xi, co) <- go role ty - (xis, cos, binders) <- iterate tys roles binders - pure (xi : xis, co : cos, binders) - iterate [] _ binders = pure ([], [], binders) - iterate _ _ _ = pprPanic - "flatten_args wandered into deeper water than usual" (vcat []) - -- This debug information is commented out because leaving it in - -- causes a ~2% increase in allocations in T9872{a,c,d}. - {- - (vcat [ppr orig_binders, - ppr orig_inner_ki, - ppr (take 10 orig_roles), -- often infinite! - ppr orig_tys]) - -} - - {-# INLINE go #-} - go :: Role - -> Type - -> FlatM (Xi, Coercion) - go role ty - = case role of - -- In the slow path we bind the Xi and Coercion from the recursive - -- call and then use it such - -- - -- let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder) - -- casted_xi = xi `mkCastTy` kind_co - -- casted_co = xi |> kind_co ~r xi ; co - -- - -- but this isn't necessary: - -- mkTcSymCo (Refl a b) = Refl a b, - -- mkCastTy x (Refl _ _) = x - -- mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co - -- - -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since - -- we've already established that they're all anonymous. - Nominal -> setEqRel NomEq $ flatten_one ty - Representational -> setEqRel ReprEq $ flatten_one ty - Phantom -> -- See Note [Phantoms in the flattener] - do { ty <- liftTcS $ zonkTcType ty - ; return (ty, mkReflCo Phantom ty) } - + -> FlatM ([Xi], [Coercion]) + iterate (ty:tys) = do + (xi, co) <- flatten_one ty + (xis, cos) <- iterate tys + pure (xi : xis, co : cos) + iterate [] = pure ([], []) {-# INLINE finish #-} - finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN) - finish (xis, cos, binders) = (xis, cos, kind_co) - where - final_kind = mkPiTys binders orig_inner_ki - kind_co = mkNomReflCo final_kind + finish :: ([Xi], [Coercion]) -> ([Xi], [Coercion], MCoercionN) + finish (xis, cos) = (xis, cos, MRefl) {-# INLINE flatten_args_slow #-} -- | Slow path, compared to flatten_args_fast, because this one must track -- a lifting context. flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet -> [Role] -> [Type] - -> FlatM ([Xi], [Coercion], CoercionN) + -> FlatM ([Xi], [Coercion], MCoercionN) flatten_args_slow binders inner_ki fvs roles tys -- Arguments used dependently must be flattened with proper coercions, but -- we're not guaranteed to get a proper coercion when flattening with the @@ -1143,6 +506,10 @@ flatten_one :: TcType -> FlatM (Xi, Coercion) -- Postcondition: Coercion :: Xi ~ TcType -- The role on the result coercion matches the EqRel in the FlattenEnv +flatten_one ty + | Just ty' <- flattenView ty -- See Note [Flattening synonyms] + = flatten_one ty' + flatten_one xi@(LitTy {}) = do { role <- getRole ; return (xi, mkReflCo role xi) } @@ -1154,19 +521,7 @@ flatten_one (AppTy ty1 ty2) = flatten_app_tys ty1 [ty2] flatten_one (TyConApp tc tys) - -- Expand type synonyms that mention type families - -- on the RHS; see Note [Flattening synonyms] - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' - = do { mode <- getMode - ; case mode of - FM_FlattenAll | not (isFamFreeTyCon tc) - -> flatten_one expanded_ty - _ -> flatten_ty_con_app tc tys } - - -- Otherwise, it's a type function application, and we have to - -- flatten it away as well, and generate a new given equality constraint - -- between the application and a newly generated flattening skolem variable. + -- If it's a type family application, try to reduce it | isTypeFamilyTyCon tc = flatten_fam_app tc tys @@ -1174,11 +529,6 @@ flatten_one (TyConApp tc tys) -- * data family application -- we just recursively flatten the arguments. | otherwise --- FM_Avoid stuff commented out; see Note [Lazy flattening] --- , let fmode' = case fmode of -- Switch off the flat_top bit in FM_Avoid --- FE { fe_mode = FM_Avoid tv _ } --- -> fmode { fe_mode = FM_Avoid tv False } --- _ -> fmode = flatten_ty_con_app tc tys flatten_one ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 }) @@ -1198,14 +548,12 @@ flatten_one ty@(ForAllTy {}) -- applications inside the forall involve the bound type variables. = do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty tvs = binderVars bndrs - ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho - -- Substitute only under a forall - -- See Note [Flattening under a forall] + ; (rho', co) <- flatten_one rho ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) } flatten_one (CastTy ty g) = do { (xi, co) <- flatten_one ty - ; (g', _) <- flatten_co g + ; (g', _) <- flatten_co g ; role <- getRole ; return (mkCastTy xi g', castCoercionKind1 co role xi ty g') } -- It makes a /big/ difference to call castCoercionKind1 not @@ -1279,7 +627,9 @@ flatten_app_ty_args fun_xi fun_co arg_tys flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) flatten_ty_con_app tc tys = do { role <- getRole - ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys + ; let m_roles | Nominal <- role = Nothing + | otherwise = Just $ tyConRolesX role tc + ; (xis, cos, kind_co) <- flatten_args_tc tc m_roles tys ; let tyconapp_xi = mkTyConApp tc xis tyconapp_co = mkTyConAppCo role tc cos ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) } @@ -1288,15 +638,12 @@ flatten_ty_con_app tc tys homogenise_result :: Xi -- a flattened type -> Coercion -- :: xi ~r original ty -> Role -- r - -> CoercionN -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty) + -> MCoercionN -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty) -> (Xi, Coercion) -- (xi |> kind_co, (xi |> kind_co) -- ~r original ty) -homogenise_result xi co r kind_co - -- the explicit pattern match here improves the performance of T9872a, b, c by - -- ~2% - | isGReflCo kind_co = (xi `mkCastTy` kind_co, co) - | otherwise = (xi `mkCastTy` kind_co - , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co) +homogenise_result xi co _ MRefl = (xi, co) +homogenise_result xi co r mco@(MCo kind_co) + = (xi `mkCastTy` kind_co, (mkSymCo $ GRefl r xi mco) `mkTransCo` co) {-# INLINE homogenise_result #-} -- Flatten a vector (list of arguments). @@ -1304,7 +651,7 @@ flatten_vector :: Kind -- of the function being applied to these arguments -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the -- args have? -> [Type] -- the args to flatten - -> FlatM ([Xi], [Coercion], CoercionN) + -> FlatM ([Xi], [Coercion], MCoercionN) flatten_vector ki roles tys = do { eq_rel <- getEqRel ; case eq_rel of @@ -1312,17 +659,17 @@ flatten_vector ki roles tys any_named_bndrs inner_ki fvs - (repeat Nominal) + Nothing tys ReprEq -> flatten_args bndrs any_named_bndrs inner_ki fvs - roles + (Just roles) tys } where - (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki + (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki -- "RAE" fix fvs = tyCoVarsOfType ki {-# INLINE flatten_vector #-} @@ -1333,251 +680,215 @@ Not expanding synonyms aggressively improves error messages, and keeps types smaller. But we need to take care. Suppose - type T a = a -> a -and we want to flatten the type (T (F a)). Then we can safely flatten -the (F a) to a skolem, and return (T fsk). We don't need to expand the -synonym. This works because TcTyConAppCo can deal with synonyms -(unlike TyConAppCo), see Note [TcCoercions] in GHC.Tc.Types.Evidence. + type Syn a = Int + type instance F Bool = Syn (F Bool) + [G] F Bool ~ Syn (F Bool) -But (#8979) for - type T a = (F a, a) where F is a type function -we must expand the synonym in (say) T Int, to expose the type function -to the flattener. +If we don't expand the synonym, we'll get a spurious occurs-check +failure. This is normally what occCheckExpand takes care of, but +the LHS is a type family application, and occCheckExpand (already +complex enough as it is) does not know how to expand to avoid +a type family application. +In addition, expanding the forgetful synonym like this +will generally yield a *smaller* type. To wit, if we spot +S ( ... F tys ... ), where S is forgetful, we don't want to bother +doing hard work simplifying (F tys). We thus expand forgetful +synonyms, but not others. -Note [Flattening under a forall] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Under a forall, we - (a) MUST apply the inert substitution - (b) MUST NOT flatten type family applications -Hence FMSubstOnly. +isForgetfulSynTyCon returns True more often than it needs to, so +we err on the side of more expansion. -For (a) consider c ~ a, a ~ T (forall b. (b, [c])) -If we don't apply the c~a substitution to the second constraint -we won't see the occurs-check error. - -For (b) consider (a ~ forall b. F a b), we don't want to flatten -to (a ~ forall b.fsk, F a b ~ fsk) -because now the 'b' has escaped its scope. We'd have to flatten to - (a ~ forall b. fsk b, forall b. F a b ~ fsk b) -and we have not begun to think about how to make that work! +We also, of course, must expand type synonyms that mention type families, +so those families can get reduced. ************************************************************************ * * Flattening a type-family application * * ************************************************************************ + +Note [How to normalise a family application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given an exactly saturated family application, how should we normalise it? +This Note spells out the algorithm and its reasoning. + +STEP 1. Try the famapp-cache. If we get a cache hit, jump to FINISH. + +STEP 2. Try top-level instances. Note that we haven't simplified the arguments + yet. Example: + type instance F (Maybe a) = Int + target: F (Maybe (G Bool)) + Instead of first trying to simplify (G Bool), we use the instance first. This + avoids the work of simplifying G Bool. + + If an instance is found, jump to FINISH. + +STEP 3. Flatten all arguments. This might expose more information so that we + can use a top-level instance. + + Continue to the next step. + +STEP 4. Try the inerts. Note that we try the inerts *after* flattening the + arguments, because the inerts will have flattened LHSs. + + If an inert is found, jump to FINISH. + +STEP 5. Try the famapp-cache again. Now that we've revealed more information + in the arguments, the cache might be helpful. + + If we get a cache hit, jump to FINISH. + +STEP 6. Try top-level instances, which might trigger now that we know more + about the argumnents. + + If an instance is found, jump to FINISH. + +STEP 7. No progress to be made. Return what we have. (Do not do FINISH.) + +FINISH 1. We've made a reduction, but the new type may still have more + work to do. So flatten the new type. + +FINISH 2. Add the result to the famapp-cache, connecting the type we started + with to the one we ended with. + +Because STEP 1/2 and STEP 5/6 happen the same way, they are abstracted into +try_to_reduce. + +FINISH is naturally implemented in `finish`. But, Note [flatten_exact_fam_app performance] +tells us that we should not add to the famapp-cache after STEP 1/2. So `finish` +is inlined in that case, and only FINISH 1 is performed. + -} flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) -- flatten_fam_app can be over-saturated - -- flatten_exact_fam_app is exactly saturated - -- flatten_exact_fam_app_fully lifts out the application to top level + -- flatten_exact_fam_app lifts out the application to top level -- Postcondition: Coercion :: Xi ~ F tys flatten_fam_app tc tys -- Can be over-saturated = ASSERT2( tys `lengthAtLeast` tyConArity tc , ppr tc $$ ppr (tyConArity tc) $$ ppr tys) - do { mode <- getMode - ; case mode of - { FM_SubstOnly -> flatten_ty_con_app tc tys - ; FM_FlattenAll -> - -- Type functions are saturated -- The type function might be *over* saturated -- in which case the remaining arguments should -- be dealt with by AppTys do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys - ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1 + ; (xi1, co1) <- flatten_exact_fam_app tc tys1 -- co1 :: xi1 ~ F tys1 - ; flatten_app_ty_args xi1 co1 tys_rest } } } + ; flatten_app_ty_args xi1 co1 tys_rest } -- the [TcType] exactly saturate the TyCon --- See note [flatten_exact_fam_app_fully performance] -flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion) -flatten_exact_fam_app_fully tc tys - -- See Note [Reduce type family applications eagerly] - -- the following tcTypeKind should never be evaluated, as it's just used in - -- casting, and casts by refl are dropped - = do { mOut <- try_to_reduce_nocache tc tys - ; case mOut of - Just out -> pure out - Nothing -> do - { -- First, flatten the arguments - ; (xis, cos, kind_co) - <- setEqRel NomEq $ -- just do this once, instead of for - -- each arg - flatten_args_tc tc (repeat Nominal) tys - -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys) - ; eq_rel <- getEqRel - ; cur_flav <- getFlavour - ; let role = eqRelRole eq_rel - ret_co = mkTyConAppCo role tc cos - -- ret_co :: F xis ~ F tys; might be heterogeneous - - -- Now, look in the cache - ; mb_ct <- liftTcS $ lookupFlatCache tc xis - ; case mb_ct of - Just (co, rhs_ty, flav) -- co :: F xis ~ fsk - -- flav is [G] or [WD] - -- See Note [Type family equations] in GHC.Tc.Solver.Monad - | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav - -> -- Usable hit in the flat-cache - do { traceFlat "flatten/flat-cache hit" $ - (ppr tc <+> ppr xis $$ ppr rhs_ty) - ; (fsk_xi, fsk_co) <- flatten_one rhs_ty - -- The fsk may already have been unified, so - -- flatten it - -- fsk_co :: fsk_xi ~ fsk - ; let xi = fsk_xi `mkCastTy` kind_co - co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co - `mkTransCo` - maybeTcSubCo eq_rel (mkSymCo co) - `mkTransCo` ret_co - ; return (xi, co') - } - -- :: fsk_xi ~ F xis - - -- Try to reduce the family application right now - -- See Note [Reduce type family applications eagerly] - _ -> do { mOut <- try_to_reduce tc - xis - kind_co - (`mkTransCo` ret_co) - ; case mOut of - Just out -> pure out - Nothing -> do - { loc <- getLoc - ; (ev, co, fsk) <- liftTcS $ - newFlattenSkolem cur_flav loc tc xis - - -- The new constraint (F xis ~ fsk) is not - -- necessarily inert (e.g. the LHS may be a - -- redex) so we must put it in the work list - ; let ct = CFunEqCan { cc_ev = ev - , cc_fun = tc - , cc_tyargs = xis - , cc_fsk = fsk } - ; emitFlatWork ct - - ; traceFlat "flatten/flat-cache miss" $ - (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev) - - -- NB: fsk's kind is already flattened because - -- the xis are flattened - ; let fsk_ty = mkTyVarTy fsk - xi = fsk_ty `mkCastTy` kind_co - co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeTcSubCo eq_rel (mkSymCo co)) - `mkTransCo` ret_co - ; return (xi, co') - } - } - } - } - +-- See Note [How to normalise a family application] +flatten_exact_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) +flatten_exact_fam_app tc tys + = do { checkStackDepth (mkTyConApp tc tys) + + -- STEP 1/2. Try to reduce without reducing arguments first. + ; result1 <- try_to_reduce tc tys + ; case result1 of + -- Don't use the cache; + -- See Note [flatten_exact_fam_app performance] + { Just (co, xi) -> finish False (xi, co) + ; Nothing -> + + -- That didn't work. So reduce the arguments, in STEP 3. + do { eq_rel <- getEqRel + -- checking eq_rel == NomEq saves ~0.5% in T9872a + ; (xis, cos, kind_co) <- if eq_rel == NomEq + then flatten_args_tc tc Nothing tys + else setEqRel NomEq $ + flatten_args_tc tc Nothing tys + -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys) + + ; let role = eqRelRole eq_rel + args_co = mkTyConAppCo role tc cos + -- args_co :: F xis ~r F tys + + homogenise :: TcType -> TcCoercion -> (TcType, TcCoercion) + -- in (xi', co') = homogenise xi co + -- assume co :: xi ~r F xis, co is homogeneous + -- then xi' :: tcTypeKind(F tys) + -- and co' :: xi' ~r F tys, which is homogeneous + homogenise xi co = homogenise_result xi (co `mkTcTransCo` args_co) role kind_co + + -- STEP 4: try the inerts + ; result2 <- liftTcS $ lookupFamAppInert tc xis + ; flavour <- getFlavour + ; case result2 of + { Just (co, xi, fr@(_, inert_eq_rel)) + -- co :: F xis ~ir xi + + | fr `eqCanRewriteFR` (flavour, eq_rel) -> + do { traceFlat "rewrite family application with inert" + (ppr tc <+> ppr xis $$ ppr xi) + ; finish True (homogenise xi downgraded_co) } + -- 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 + where + inert_role = eqRelRole inert_eq_rel + role = eqRelRole eq_rel + downgraded_co = tcDowngradeRole role inert_role (mkTcSymCo co) + -- downgraded_co :: xi ~r F xis + + ; _ -> + + -- inert didn't work. Try to reduce again, in STEP 5/6. + do { result3 <- try_to_reduce tc xis + ; case result3 of + Just (co, xi) -> finish True (homogenise xi co) + Nothing -> -- we have made no progress at all: STEP 7. + return (homogenise reduced (mkTcReflCo role reduced)) + where + reduced = mkTyConApp tc xis }}}}} where + -- call this if the above attempts made progress. + -- This recursively flattens the result and then adds to the cache + finish :: Bool -- add to the cache? + -> (Xi, Coercion) -> FlatM (Xi, Coercion) + finish use_cache (xi, co) + = do { -- flatten the result: FINISH 1 + (fully, fully_co) <- bumpDepth $ flatten_one xi + ; let final_co = fully_co `mkTcTransCo` co + ; eq_rel <- getEqRel + ; flavour <- getFlavour + + -- extend the cache: FINISH 2 + ; when (use_cache && eq_rel == NomEq && flavour /= Derived) $ + -- the cache only wants Nominal eqs + -- and Wanteds can rewrite Deriveds; the cache + -- has only Givens + liftTcS $ extendFamAppCache tc tys (final_co, fully) + ; return (fully, final_co) } + {-# INLINE finish #-} - -- try_to_reduce and try_to_reduce_nocache (below) could be unified into - -- a more general definition, but it was observed that separating them - -- gives better performance (lower allocation numbers in T9872x). - - try_to_reduce :: TyCon -- F, family tycon - -> [Type] -- args, not necessarily flattened - -> CoercionN -- kind_co :: tcTypeKind(F args) ~N - -- tcTypeKind(F orig_args) - -- where - -- orig_args is what was passed to the outer - -- function - -> ( Coercion -- :: (xi |> kind_co) ~ F args - -> Coercion ) -- what to return from outer function - -> FlatM (Maybe (Xi, Coercion)) - try_to_reduce tc tys kind_co update_co - = do { checkStackDepth (mkTyConApp tc tys) - ; mb_match <- liftTcS $ matchFam tc tys - ; case mb_match of - -- NB: norm_co will always be homogeneous. All type families - -- are homogeneous. - Just (norm_co, norm_ty) - -> do { traceFlat "Eager T.F. reduction success" $ - vcat [ ppr tc, ppr tys, ppr norm_ty - , ppr norm_co <+> dcolon - <+> ppr (coercionKind norm_co) - ] - ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty - ; eq_rel <- getEqRel - ; let co = maybeTcSubCo eq_rel norm_co - `mkTransCo` mkSymCo final_co - ; flavour <- getFlavour - -- NB: only extend cache with nominal equalities - ; when (eq_rel == NomEq) $ - liftTcS $ - extendFlatCache tc tys ( co, xi, flavour ) - ; let role = eqRelRole eq_rel - xi' = xi `mkCastTy` kind_co - co' = update_co $ - mkTcCoherenceLeftCo role xi kind_co (mkSymCo co) - ; return $ Just (xi', co') } - Nothing -> pure Nothing } - - try_to_reduce_nocache :: TyCon -- F, family tycon - -> [Type] -- args, not necessarily flattened - -> FlatM (Maybe (Xi, Coercion)) - try_to_reduce_nocache tc tys - = do { checkStackDepth (mkTyConApp tc tys) - ; mb_match <- liftTcS $ matchFam tc tys - ; case mb_match of - -- NB: norm_co will always be homogeneous. All type families - -- are homogeneous. - Just (norm_co, norm_ty) - -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty - ; eq_rel <- getEqRel - ; let co = mkSymCo (maybeTcSubCo eq_rel norm_co - `mkTransCo` mkSymCo final_co) - ; return $ Just (xi, co) } - Nothing -> pure Nothing } - -{- Note [Reduce type family applications eagerly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we come across a type-family application like (Append (Cons x Nil) t), -then, rather than flattening to a skolem etc, we may as well just reduce -it on the spot to (Cons x t). This saves a lot of intermediate steps. -Examples that are helped are tests T9872, and T5321Fun. - -Performance testing indicates that it's best to try this *twice*, once -before flattening arguments and once after flattening arguments. -Adding the extra reduction attempt before flattening arguments cut -the allocation amounts for the T9872{a,b,c} tests by half. - -An example of where the early reduction appears helpful: - - type family Last x where - Last '[x] = x - Last (h ': t) = Last t - - workitem: (x ~ Last '[1,2,3,4,5,6]) - -Flattening the argument never gets us anywhere, but trying to flatten -it at every step is quadratic in the length of the list. Reducing more -eagerly makes simplifying the right-hand type linear in its length. - -Testing also indicated that the early reduction should *not* use the -flat-cache, but that the later reduction *should*. (Although the -effect was not large.) Hence the Bool argument to try_to_reduce. To -me (SLPJ) this seems odd; I get that eager reduction usually succeeds; -and if don't use the cache for eager reduction, we will miss most of -the opportunities for using it at all. More exploration would be good -here. - -At the end, once we've got a flat rhs, we extend the flatten-cache to record -the result. Doing so can save lots of work when the same redex shows up more -than once. Note that we record the link from the redex all the way to its -*final* value, not just the single step reduction. Interestingly, using the -flat-cache for the first reduction resulted in an increase in allocations -of about 3% for the four T9872x tests. However, using the flat-cache in -the later reduction is a similar gain. I (Richard E) don't currently (Dec '14) -have any knowledge as to *why* these facts are true. +-- Returned coercion is output ~r input, where r is the role in the FlatM monad +-- See Note [How to normalise a family application] +try_to_reduce :: TyCon -> [TcType] -> FlatM (Maybe (TcCoercion, TcType)) +try_to_reduce tc tys + = do { result <- liftTcS $ firstJustsM [ lookupFamAppCache tc tys -- STEP 5 + , matchFam tc tys ] -- STEP 6 + ; downgrade result } + where + -- The result above is always Nominal. We might want a Representational + -- coercion; this downgrades (and prints, out of convenience). + downgrade :: Maybe (TcCoercionN, TcType) -> FlatM (Maybe (TcCoercion, TcType)) + downgrade Nothing = return Nothing + downgrade result@(Just (co, xi)) + = do { traceFlat "Eager T.F. reduction success" $ + vcat [ ppr tc, ppr tys, ppr xi + , ppr co <+> dcolon <+> ppr (coercionKind co) + ] + ; eq_rel <- getEqRel + -- manually doing it this way avoids allocation in the vastly + -- common NomEq case + ; case eq_rel of + NomEq -> return result + ReprEq -> return (Just (mkSubCo co, xi)) } +{- ************************************************************************ * * Flattening a type variable @@ -1636,17 +947,15 @@ flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult flatten_tyvar2 tv fr@(_, eq_rel) = do { ieqs <- liftTcS $ getInertEqs - ; mode <- getMode ; case lookupDVarEnv ieqs tv of - Just (ct:_) -- If the first doesn't work, - -- the subsequent ones won't either - | CTyEqCan { cc_ev = ctev, cc_tyvar = tv - , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct + Just (EqualCtList (ct :| _)) -- If the first doesn't work, + -- the subsequent ones won't either + | 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 { traceFlat "Following inert tyvar" - (ppr mode <+> - ppr tv <+> + (ppr tv <+> equals <+> ppr rhs_ty $$ ppr ctev) ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev) @@ -1688,239 +997,14 @@ only if (a) the work item can rewrite the inert AND This is significantly harder to think about. It can save a LOT of work in occurs-check cases, but we don't care about them much. #5837 -is an example; all the constraints here are Givens - - [G] a ~ TF (a,Int) - --> - work TF (a,Int) ~ fsk - inert fsk ~ a - - ---> - work fsk ~ (TF a, TF Int) - inert fsk ~ a - - ---> - work a ~ (TF a, TF Int) - inert fsk ~ a - - ---> (attempting to flatten (TF a) so that it does not mention a - work TF a ~ fsk2 - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (substitute for a) - work TF (fsk2, TF Int) ~ fsk2 - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (top-level reduction, re-orient) - work fsk2 ~ (TF fsk2, TF Int) - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (attempt to flatten (TF fsk2) to get rid of fsk2 - work TF fsk2 ~ fsk3 - work fsk2 ~ (fsk3, TF Int) - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) +is an example, but it causes trouble only with the old (pre-Fall 2020) +flattening story. It is unclear if there is any gain w.r.t. to +the new story. - ---> - work TF fsk2 ~ fsk3 - inert fsk2 ~ (fsk3, TF Int) - inert a ~ ((fsk3, TF Int), TF Int) - inert fsk ~ ((fsk3, TF Int), TF Int) - -Because the incoming given rewrites all the inert givens, we get more and -more duplication in the inert set. But this really only happens in pathological -casee, so we don't care. - - -************************************************************************ -* * - Unflattening -* * -************************************************************************ - -An unflattening example: - [W] F a ~ alpha -flattens to - [W] F a ~ fmv (CFunEqCan) - [W] fmv ~ alpha (CTyEqCan) -We must solve both! -} -unflattenWanteds :: Cts -> Cts -> TcS Cts -unflattenWanteds tv_eqs funeqs - = do { tclvl <- getTcLevel - - ; traceTcS "Unflattening" $ braces $ - vcat [ text "Funeqs =" <+> pprCts funeqs - , text "Tv eqs =" <+> pprCts tv_eqs ] - - -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check - -- Occurs check: consider [W] alpha ~ [F alpha] - -- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv] - -- ==> (unify) [W] F [fmv] ~ fmv - -- See Note [Unflatten using funeqs first] - ; funeqs <- foldrM unflatten_funeq emptyCts funeqs - ; traceTcS "Unflattening 1" $ braces (pprCts funeqs) - - -- Step 2: unify the tv_eqs, if possible - ; tv_eqs <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs - ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs) - - -- Step 3: fill any remaining fmvs with fresh unification variables - ; funeqs <- mapBagM finalise_funeq funeqs - ; traceTcS "Unflattening 3" $ braces (pprCts funeqs) - - -- Step 4: remove any tv_eqs that look like ty ~ ty - ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs - - ; let all_flat = tv_eqs `andCts` funeqs - ; traceTcS "Unflattening done" $ braces (pprCts all_flat) - - ; return all_flat } - where - ---------------- - unflatten_funeq :: Ct -> Cts -> TcS Cts - unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis - , cc_fsk = fmv, cc_ev = ev }) rest - = do { -- fmv should be an un-filled flatten meta-tv; - -- we now fix its final value by filling it, being careful - -- to observe the occurs check. Zonking will eliminate it - -- altogether in due course - rhs' <- zonkTcType (mkTyConApp tc xis) - ; case occCheckExpand [fmv] rhs' of - Just rhs'' -- Normal case: fill the tyvar - -> do { setReflEvidence ev NomEq rhs'' - ; unflattenFmv fmv rhs'' - ; return rest } - - Nothing -> -- Occurs check - return (ct `consCts` rest) } - - unflatten_funeq other_ct _ - = pprPanic "unflatten_funeq" (ppr other_ct) - - ---------------- - finalise_funeq :: Ct -> TcS Ct - finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev }) - = do { demoteUnfilledFmv fmv - ; return (mkNonCanonical ev) } - finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct) - - ---------------- - unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts - unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv - , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest - - | NomEq <- eq_rel -- See Note [Do not unify representational equalities] - -- in GHC.Tc.Solver.Interact - , isFmvTyVar tv -- Previously these fmvs were untouchable, - -- but now they are touchable - -- NB: unlike unflattenFmv, filling a fmv here /does/ - -- bump the unification count; it is "improvement" - -- Note [Unflattening can force the solver to iterate] - = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct ) - -- CTyEqCan invariant (TyEq:K) should ensure this is true - do { is_filled <- isFilledMetaTyVar tv - ; elim <- case is_filled of - False -> do { traceTcS "unflatten_eq 2" (ppr ct) - ; tryFill ev tv rhs } - True -> do { traceTcS "unflatten_eq 3" (ppr ct) - ; try_fill_rhs ev tclvl tv rhs } - ; if elim - then do { setReflEvidence ev eq_rel (mkTyVarTy tv) - ; return rest } - else return (ct `consCts` rest) } - - | otherwise - = return (ct `consCts` rest) - - unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct) - - ---------------- - try_fill_rhs ev tclvl lhs_tv rhs - -- Constraint is lhs_tv ~ rhs_tv, - -- and lhs_tv is filled, so try RHS - | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs - -- co :: kind(rhs_tv) ~ kind(lhs_tv) - , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv - && not (isTyVarTyVar rhs_tv)) - -- LHS is a filled fmv, and so is a type - -- family application, which a TyVarTv should - -- not unify with - = do { is_filled <- isFilledMetaTyVar rhs_tv - ; if is_filled then return False - else tryFill ev rhs_tv - (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) } - - | otherwise - = return False - - ---------------- - finalise_eq :: Ct -> Cts -> TcS Cts - finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv - , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest - | isFmvTyVar tv - = do { ty1 <- zonkTcTyVar tv - ; rhs' <- zonkTcType rhs - ; if ty1 `tcEqType` rhs' - then do { setReflEvidence ev eq_rel rhs' - ; return rest } - else return (mkNonCanonical ev `consCts` rest) } - - | otherwise - = return (mkNonCanonical ev `consCts` rest) - - finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct) - -tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool --- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv --- If tv does not appear in 'rhs', it set tv := rhs, --- binds the evidence (which should be a CtWanted) to Refl<rhs> --- and return True. Otherwise returns False -tryFill ev tv rhs - = ASSERT2( not (isGiven ev), ppr ev ) - do { rhs' <- zonkTcType rhs - ; case () of - _ | Just tv' <- tcGetTyVar_maybe rhs' - , tv == tv' -- tv == rhs - -> return True - - _ | Just rhs'' <- occCheckExpand [tv] rhs' - -> do { -- Fill the tyvar - unifyTyVar tv rhs'' - ; return True } - - _ | otherwise -- Occurs check - -> return False - } - -setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS () -setReflEvidence ev eq_rel rhs - = setEvBindIfWanted ev (evCoercion refl_co) - where - refl_co = mkTcReflCo (eqRelRole eq_rel) rhs - -{- -Note [Unflatten using funeqs first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - [W] G a ~ Int - [W] F (G a) ~ G a - -do not want to end up with - [W] F Int ~ Int -because that might actually hold! Better to end up with the two above -unsolved constraints. The flat form will be - - G a ~ fmv1 (CFunEqCan) - F fmv1 ~ fmv2 (CFunEqCan) - fmv1 ~ Int (CTyEqCan) - fmv1 ~ fmv2 (CTyEqCan) - -Flatten using the fun-eqs first. --} +-------------------------------------- +-- Utilities -- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at -- least one named binder. @@ -1946,6 +1030,6 @@ ty_con_binders_ty_binders' = foldr go ([], False) go (Bndr tv (NamedTCB vis)) (bndrs, _) = (Named (Bndr tv vis) : bndrs, True) go (Bndr tv (AnonTCB af)) (bndrs, n) - = (Anon af (unrestricted (tyVarKind tv)) : bndrs, n) + = (Anon af (tymult (tyVarKind tv)) : bndrs, n) {-# INLINE go #-} {-# INLINE ty_con_binders_ty_binders' #-} diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index baa132c2b6..49d4ad20ab 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -11,14 +11,12 @@ module GHC.Tc.Solver.Interact ( #include "HsVersions.h" import GHC.Prelude -import GHC.Types.Basic ( SwapFlag(..), isSwapped, +import GHC.Types.Basic ( SwapFlag(..), infinity, IntWithInf, intGtLimit ) import GHC.Tc.Solver.Canonical -import GHC.Tc.Solver.Flatten -import GHC.Tc.Utils.Unify ( canSolveByUnification ) +import GHC.Tc.Utils.Unify( canSolveByUnification ) import GHC.Types.Var.Set import GHC.Core.Type as Type -import GHC.Core.Coercion ( BlockSubstFlag(..) ) import GHC.Core.InstEnv ( DFunInstType ) import GHC.Types.Var @@ -57,6 +55,7 @@ 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 @@ -90,50 +89,6 @@ Note [Basic Simplifier Plan] If in Step 1 no such element exists, we have exceeded our context-stack depth and will simply fail. - -Note [Unflatten after solving the simple wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We unflatten after solving the wc_simples of an implication, and before attempting -to float. This means that - - * The fsk/fmv flatten-skolems only survive during solveSimples. We don't - need to worry about them across successive passes over the constraint tree. - (E.g. we don't need the old ic_fsk field of an implication. - - * When floating an equality outwards, we don't need to worry about floating its - associated flattening constraints. - - * Another tricky case becomes easy: #4935 - type instance F True a b = a - type instance F False a b = b - - [w] F c a b ~ gamma - (c ~ True) => a ~ gamma - (c ~ False) => b ~ gamma - - Obviously this is soluble with gamma := F c a b, and unflattening - will do exactly that after solving the simple constraints and before - attempting the implications. Before, when we were not unflattening, - we had to push Wanted funeqs in as new givens. Yuk! - - Another example that becomes easy: indexed_types/should_fail/T7786 - [W] BuriedUnder sub k Empty ~ fsk - [W] Intersect fsk inv ~ s - [w] xxx[1] ~ s - [W] forall[2] . (xxx[1] ~ Empty) - => Intersect (BuriedUnder sub k Empty) inv ~ Empty - -Note [Running plugins on unflattened wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is an annoying mismatch between solveSimpleGivens and -solveSimpleWanteds, because the latter needs to fiddle with the inert -set, unflatten and zonk the wanteds. It passes the zonked wanteds -to runTcPluginsWanteds, which produces a replacement set of wanteds, -some additional insolubles and a flag indicating whether to go round -the loop again. If so, prepareInertsForImplications is used to remove -the previous wanteds (which will still be in the inert set). Note -that prepareInertsForImplications will discard the insolubles, so we -must keep track of them separately. -} solveSimpleGivens :: [Ct] -> TcS () @@ -177,48 +132,36 @@ solveSimpleWanteds simples | otherwise = do { -- Solve - (unif_count, wc1) <- solve_simple_wanteds wc + wc1 <- solve_simple_wanteds wc -- Run plugins ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 - -- See Note [Running plugins on unflattened wanteds] - ; if unif_count == 0 && not rerun_plugin - then return (n, wc2) -- Done - else do { traceTcS "solveSimple going round again:" $ - ppr unif_count $$ ppr rerun_plugin - ; go (n+1) limit wc2 } } -- Loop + ; if rerun_plugin + then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin) + ; go (n+1) limit wc2 } -- Loop + else return (n, wc2) } -- Done -solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints) +solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints -- Try solving these constraints -- Affects the unification state (of course) but not the inert set -- The result is not necessarily zonked solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_holes = holes }) = nestTcS $ do { solveSimples simples1 - ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts - ; (unif_count, unflattened_eqs) <- reportUnifications $ - unflattenWanteds tv_eqs fun_eqs - -- See Note [Unflatten after solving the simple wanteds] - ; return ( unif_count - , WC { wc_simple = others `andCts` unflattened_eqs - , wc_impl = implics1 `unionBags` implics2 - , wc_holes = holes }) } + ; (implics2, unsolved) <- getUnsolvedInerts + ; return (WC { wc_simple = unsolved + , wc_impl = implics1 `unionBags` implics2 + , wc_holes = holes }) } {- Note [The solveSimpleWanteds loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Solving a bunch of simple constraints is done in a loop, (the 'go' loop of 'solveSimpleWanteds'): - 1. Try to solve them; unflattening may lead to improvement that - was not exploitable during solving + 1. Try to solve them 2. Try the plugin - 3. If step 1 did improvement during unflattening; or if the plugin - wants to run again, go back to step 1 - -Non-obviously, improvement can also take place during -the unflattening that takes place in step (1). See GHC.Tc.Solver.Flatten, -See Note [Unflattening can force the solver to iterate] + 3. If the plugin wants to run again, go back to step 1 -} -- The main solver loop implements Note [Basic Simplifier Plan] @@ -481,15 +424,16 @@ or, equivalently, -- Interaction result of WorkItem <~> Ct interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct) --- Precondition: if the workitem is a CTyEqCan then it will not be able to --- react with anything at this stage. +-- Precondition: if the workitem is a CEqCan then it will not be able to +-- react with anything at this stage (except, maybe, via a type family +-- dependency) interactWithInertsStage wi = do { inerts <- getTcSInerts + ; lvl <- getTcLevel ; let ics = inert_cans inerts ; case wi of - CTyEqCan {} -> interactTyVarEq ics wi - CFunEqCan {} -> interactFunEq ics wi + CEqCan {} -> interactEq lvl ics wi CIrredCan {} -> interactIrred ics wi CDictCan {} -> interactDict ics wi _ -> pprPanic "interactWithInerts" (ppr wi) } @@ -1127,6 +1071,8 @@ shortCutSolver dflags ev_w ev_i ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds) ; loc' <- lift $ checkInstanceOK loc what pred + ; lift $ checkReductionDepth loc' pred + ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds -- Emit work for subgoals but use our local cache @@ -1298,113 +1244,63 @@ I can think of two ways to fix this: ********************************************************************** -} -interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- Try interacting the work item with the inert set -interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc - , cc_tyargs = args, cc_fsk = fsk }) - | Just inert_ct@(CFunEqCan { cc_ev = ev_i - , cc_fsk = fsk_i }) - <- findFunEq (inert_funeqs inerts) tc args - , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev - = do { traceTcS "reactFunEq (rewrite inert item):" $ - vcat [ text "work_item =" <+> ppr work_item - , text "inertItem=" <+> ppr ev_i - , text "(swap_flag, upgrade)" <+> ppr pr ] - ; if isSwapped swap_flag - then do { -- Rewrite inert using work-item - let work_item' | upgrade_flag = upgradeWanted work_item - | otherwise = work_item - ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item' - -- Do the updInertFunEqs before the reactFunEq, so that - -- we don't kick out the inertItem as well as consuming it! - ; reactFunEq ev fsk ev_i fsk_i - ; stopWith ev "Work item rewrites inert" } - else do { -- Rewrite work-item using inert - ; when upgrade_flag $ - updInertFunEqs $ \ feqs -> insertFunEq feqs tc args - (upgradeWanted inert_ct) - ; reactFunEq ev_i fsk_i ev fsk - ; stopWith ev "Inert rewrites work item" } } - - | otherwise -- Try improvement - = do { improveLocalFunEqs ev inerts tc args fsk - ; continueWith work_item } - -interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item) - -upgradeWanted :: Ct -> Ct --- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2 --- so upgrade the [W] to [WD] before putting it in the inert set -upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) } - where - upgrade_ev ev = ASSERT2( isWanted ev, ppr ct ) - ev { ctev_nosh = WDeriv } - -improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar +improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType -> TcS () -- Generate derived improvement equalities, by comparing -- the current work item with inert CFunEqs -- E.g. x + y ~ z, x + y' ~ z => [D] y ~ y' -- -- See Note [FunDep and implicit parameter reactions] -improveLocalFunEqs work_ev inerts fam_tc args fsk - | isGiven work_ev -- See Note [No FunEq improvement for Givens] - || not (isImprovable work_ev) - = return () - - | otherwise - = do { eqns <- improvement_eqns - ; if not (null eqns) - then do { traceTcS "interactFunEq improvements: " $ - vcat [ text "Eqns:" <+> ppr eqns +-- Precondition: isImprovable work_ev +improveLocalFunEqs work_ev inerts fam_tc args rhs + = ASSERT( isImprovable work_ev ) + 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 eqns } - else return () } - + ; emitFunDepDeriveds improvement_eqns } where funeqs = inert_funeqs inerts - funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc + funeqs_for_tc = [ funeq_ct | EqualCtList (funeq_ct :| _) + <- findFunEqsByTyCon funeqs fam_tc + , NomEq == ctEqRel funeq_ct ] + -- representational equalities don't interact + -- with type family dependencies work_loc = ctEvLoc work_ev work_pred = ctEvPred work_ev fam_inj_info = tyConInjectivityInfo fam_tc -------------------- - improvement_eqns :: TcS [FunDepEqn CtLoc] + improvement_eqns :: [FunDepEqn CtLoc] improvement_eqns | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc = -- Try built-in families, notably for arithmethic - do { rhs <- rewriteTyVar fsk - ; concatMapM (do_one_built_in ops rhs) funeqs_for_tc } + concatMap (do_one_built_in ops rhs) funeqs_for_tc | Injective injective_args <- fam_inj_info = -- Try improvement from type families with injectivity annotations - do { rhs <- rewriteTyVar fsk - ; concatMapM (do_one_injective injective_args rhs) funeqs_for_tc } + concatMap (do_one_injective injective_args rhs) funeqs_for_tc | otherwise - = return [] + = [] -------------------- - do_one_built_in ops rhs (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev }) - = do { inert_rhs <- rewriteTyVar ifsk - ; return $ mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs inert_rhs) } + do_one_built_in ops rhs (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_ev = inert_ev }) + = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs) 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 (CFunEqCan { cc_tyargs = inert_args - , cc_fsk = ifsk, cc_ev = inert_ev }) + do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args + , cc_rhs = irhs, cc_ev = inert_ev }) | isImprovable inert_ev - = do { inert_rhs <- rewriteTyVar ifsk - ; return $ if rhs `tcEqType` inert_rhs - then mk_fd_eqns inert_ev $ - [ Pair arg iarg - | (arg, iarg, True) <- zip3 args inert_args inj_args ] - else [] } + , rhs `tcEqType` irhs + = mk_fd_eqns inert_ev $ [ Pair arg iarg + | (arg, iarg, True) <- zip3 args inert_args inj_args ] | otherwise - = return [] + = [] do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) @@ -1421,26 +1317,13 @@ improveLocalFunEqs work_ev inerts fam_tc args fsk loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` ctl_depth work_loc } -------------- -reactFunEq :: CtEvidence -> TcTyVar -- From this :: F args1 ~ fsk1 - -> CtEvidence -> TcTyVar -- Solve this :: F args2 ~ fsk2 - -> TcS () -reactFunEq from_this fsk1 solve_this fsk2 - = do { traceTcS "reactFunEq" - (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2]) - ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1) - ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$ - ppr solve_this $$ ppr fsk2) } - {- Note [Type inference for type families with injectivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have a type family with an injectivity annotation: type family F a b = r | r -> b -Then if we have two CFunEqCan constraints for F with the same RHS - F s1 t1 ~ rhs - F s2 t2 ~ rhs -then we can use the injectivity to get a new Derived constraint on +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 the injective argument [D] t1 ~ t2 @@ -1467,8 +1350,20 @@ 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). -See also Note [Injective type families] in GHC.Core.TyCon +We generate these Deriveds 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 +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 +constraints rewrites the other, as they have different LHSs. This is done +in improveLocalFunEqs, called during the interactWithInertsStage. + +3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T. +This is done in improve_top_fun_eqs, called from the top-level reactions stage. +See also Note [Injective type families] in GHC.Core.TyCon Note [Cache-caused loops] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1501,85 +1396,34 @@ which did not really made a 'step' towards proving some goal. Solved's are just an optimization so we don't lose anything in terms of completeness of solving. - -Note [Efficient Orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are interacting two FunEqCans with the same LHS: - (inert) ci :: (F ty ~ xi_i) - (work) cw :: (F ty ~ xi_w) -We prefer to keep the inert (else we pass the work item on down -the pipeline, which is a bit silly). If we keep the inert, we -will (a) discharge 'cw' - (b) produce a new equality work-item (xi_w ~ xi_i) -Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w): - new_work :: xi_w ~ xi_i - cw := ci ; sym new_work -Why? Consider the simplest case when xi1 is a type variable. If -we generate xi1~xi2, processing that constraint will kick out 'ci'. -If we generate xi2~xi1, there is less chance of that happening. -Of course it can and should still happen if xi1=a, xi1=Int, say. -But we want to avoid it happening needlessly. - -Similarly, if we *can't* keep the inert item (because inert is Wanted, -and work is Given, say), we prefer to orient the new equality (xi_i ~ -xi_w). - -Note [Carefully solve the right CFunEqCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ---- OLD COMMENT, NOW NOT NEEDED - ---- because we now allow multiple - ---- wanted FunEqs with the same head -Consider the constraints - c1 :: F Int ~ a -- Arising from an application line 5 - c2 :: F Int ~ Bool -- Arising from an application line 10 -Suppose that 'a' is a unification variable, arising only from -flattening. So there is no error on line 5; it's just a flattening -variable. But there is (or might be) an error on line 10. - -Two ways to combine them, leaving either (Plan A) - c1 :: F Int ~ a -- Arising from an application line 5 - c3 :: a ~ Bool -- Arising from an application line 10 -or (Plan B) - c2 :: F Int ~ Bool -- Arising from an application line 10 - c4 :: a ~ Bool -- Arising from an application line 5 - -Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error -on the *totally innocent* line 5. An example is test SimpleFail16 -where the expected/actual message comes out backwards if we use -the wrong plan. - -The second is the right thing to do. Hence the isMetaTyVarTy -test when solving pairwise CFunEqCan. - - ********************************************************************** * * - interactTyVarEq + interactEq * * ********************************************************************** -} -inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole +inertsCanDischarge :: InertCans -> CanEqLHS -> TcType -> CtFlavourRole -> Maybe ( CtEvidence -- The evidence for the inert , SwapFlag -- Whether we need mkSymCo , Bool) -- True <=> keep a [D] version -- of the [WD] constraint -inertsCanDischarge inerts tv rhs fr - | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_eq_rel = eq_rel } - <- findTyEqs inerts tv +inertsCanDischarge inerts lhs rhs fr + | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i + , cc_eq_rel = eq_rel } + <- findEq inerts lhs , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr , rhs_i `tcEqType` rhs ] = -- Inert: a ~ ty -- Work item: a ~ ty Just (ev_i, NotSwapped, keep_deriv ev_i) - | Just tv_rhs <- getTyVar_maybe rhs - , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_eq_rel = eq_rel } - <- findTyEqs inerts tv_rhs + | Just rhs_lhs <- canEqLHS_maybe rhs + , (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i + , cc_eq_rel = eq_rel } + <- findEq inerts rhs_lhs , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr - , rhs_i `tcEqType` mkTyVarTy tv ] + , rhs_i `tcEqType` canEqLHSType lhs ] = -- Inert: a ~ b -- Work item: b ~ a Just (ev_i, IsSwapped, keep_deriv ev_i) @@ -1595,16 +1439,15 @@ inertsCanDischarge inerts tv rhs fr | otherwise = False -- Work item is fully discharged -interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- CTyEqCans are always consumed, so always returns Stop -interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv - , cc_rhs = rhs - , cc_ev = ev - , cc_eq_rel = eq_rel }) +interactEq :: TcLevel -> InertCans -> Ct -> TcS (StopOrContinue Ct) +interactEq tclvl 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 tv rhs (ctEvFlavour ev, eq_rel) + <- inertsCanDischarge inerts lhs rhs (ctEvFlavour ev, eq_rel) = do { setEvBindIfWanted ev $ - evCoercion (maybeSym swapped $ + evCoercion (maybeTcSymCo swapped $ tcDowngradeRole (eqRelRole eq_rel) (ctEvRole ev_i) (ctEvCoercion ev_i)) @@ -1622,19 +1465,22 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv = do { traceTcS "Not unifying representational equality" (ppr workItem) ; continueWith workItem } - | isGiven ev -- See Note [Touchables and givens] - = continueWith workItem + -- try improvement, if possible + | TyFamLHS fam_tc fam_args <- lhs + , isImprovable ev + = do { improveLocalFunEqs ev inerts fam_tc fam_args rhs + ; continueWith workItem } - | otherwise - = do { tclvl <- getTcLevel - ; if canSolveByUnification tclvl tv rhs - then do { solveByUnification ev tv rhs - ; n_kicked <- kickOutAfterUnification tv - ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) } + | TyVarLHS tv <- lhs + , canSolveByUnification tclvl tv rhs + = do { solveByUnification ev tv rhs + ; n_kicked <- kickOutAfterUnification tv + ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) } - else continueWith workItem } + | otherwise + = continueWith workItem -interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi) +interactEq _ _ wi = pprPanic "interactEq" (ppr wi) solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () -- Solve with the identity coercion @@ -1645,7 +1491,7 @@ solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () -- workItem = the new Given constraint -- -- NB: No need for an occurs check here, because solveByUnification always --- arises from a CTyEqCan, a *canonical* constraint. Its invariant (TyEq:OC) +-- arises from a CEqCan, a *canonical* constraint. Its invariant (TyEq:OC) -- says that in (a ~ xi), the type variable a does not appear in xi. -- See GHC.Tc.Types.Constraint.Ct invariants. -- @@ -1694,7 +1540,7 @@ where and we want to get alpha := N b. See also #15144, which was caused by unifying a representational -equality (in the unflattener). +equality. ************************************************************************ @@ -1822,9 +1668,8 @@ topReactionsStage work_item ; case work_item of CDictCan {} -> do { inerts <- getTcSInerts ; doTopReactDict inerts work_item } - CFunEqCan {} -> doTopReactFunEq work_item + CEqCan {} -> doTopReactEq work_item CIrredCan {} -> doTopReactOther work_item - CTyEqCan {} -> doTopReactOther work_item _ -> -- Any other work item does not react with any top-level equations continueWith work_item } @@ -1832,7 +1677,7 @@ topReactionsStage work_item -------------------- doTopReactOther :: Ct -> TcS (StopOrContinue Ct) -- Try local quantified constraints for --- CTyEqCan e.g. (a ~# ty) +-- CEqCan e.g. (lhs ~# ty) -- and CIrredCan e.g. (c a) -- -- Why equalities? See GHC.Tc.Solver.Canonical @@ -1889,126 +1734,24 @@ See * Note [Evidence for quantified constraints] in GHC.Core.Predicate * Note [Equality superclasses in quantified constraints] in GHC.Tc.Solver.Canonical - -Note [Flatten when discharging CFunEqCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have the following scenario (#16512): - -type family LV (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where - LV (a ': as) b = a -> LV as b - -[WD] w1 :: LV as0 (a -> b) ~ fmv1 (CFunEqCan) -[WD] w2 :: fmv1 ~ (a -> fmv2) (CTyEqCan) -[WD] w3 :: LV as0 b ~ fmv2 (CFunEqCan) - -We start with w1. Because LV is injective, we wish to see if the RHS of the -equation matches the RHS of the CFunEqCan. The RHS of a CFunEqCan is always an -fmv, so we "look through" to get (a -> fmv2). Then we run tcUnifyTyWithTFs. -That performs the match, but it allows a type family application (such as the -LV in the RHS of the equation) to match with anything. (See "Injective type -families" by Stolarek et al., HS'15, Fig. 2) The matching succeeds, which -means we can improve as0 (and b, but that's not interesting here). However, -because the RHS of w1 can't see through fmv2 (we have no way of looking up a -LHS of a CFunEqCan from its RHS, and this use case isn't compelling enough), -we invent a new unification variable here. We thus get (as0 := a : as1). -Rewriting: - -[WD] w1 :: LV (a : as1) (a -> b) ~ fmv1 -[WD] w2 :: fmv1 ~ (a -> fmv2) -[WD] w3 :: LV (a : as1) b ~ fmv2 - -We can now reduce both CFunEqCans, using the equation for LV. We get - -[WD] w2 :: (a -> LV as1 (a -> b)) ~ (a -> a -> LV as1 b) - -Now we decompose (and flatten) to - -[WD] w4 :: LV as1 (a -> b) ~ fmv3 -[WD] w5 :: fmv3 ~ (a -> fmv1) -[WD] w6 :: LV as1 b ~ fmv4 - -which is exactly where we started. These goals really are insoluble, but -we would prefer not to loop. We thus need to find a way to bump the reduction -depth, so that we can detect the loop and abort. - -The key observation is that we are performing a reduction. We thus wish -to bump the level when discharging a CFunEqCan. Where does this bumped -level go, though? It can't just go on the reduct, as that's a type. Instead, -it must go on any CFunEqCans produced after flattening. We thus flatten -when discharging, making sure that the level is bumped in the new -fun-eqs. The flattening happens in reduce_top_fun_eq and the level -is bumped when setting up the FlatM monad in GHC.Tc.Solver.Flatten.runFlatten. -(This bumping will happen for call sites other than this one, but that -makes sense -- any constraints emitted by the flattener are offshoots -the work item and should have a higher level. We don't have any test -cases that require the bumping in this other cases, but it's convenient -and causes no harm to bump at every flatten.) - -Test case: typecheck/should_fail/T16512a - -} -------------------- -doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct) -doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc - , cc_tyargs = args, cc_fsk = fsk }) - - | fsk `elemVarSet` tyCoVarsOfTypes args - = no_reduction -- See Note [FunEq occurs-check principle] - - | otherwise -- Note [Reduction for Derived CFunEqCans] - = do { match_res <- matchFam fam_tc args - -- Look up in top-level instances, or built-in axiom - -- See Note [MATCHING-SYNONYMS] - ; case match_res of - Nothing -> no_reduction - Just match_info -> reduce_top_fun_eq old_ev fsk match_info } - where - no_reduction - = do { improveTopFunEqs old_ev fam_tc args fsk - ; continueWith work_item } - -doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w) - -reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType) - -> TcS (StopOrContinue Ct) --- We have found an applicable top-level axiom: use it to reduce --- Precondition: fsk is not free in rhs_ty --- ax_co :: F tys ~ rhs_ty, where F tys is the LHS of the old_ev -reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty) - | not (isDerived old_ev) -- Precondition of shortCutReduction - , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty - , isTypeFamilyTyCon tc - , tc_args `lengthIs` tyConArity tc -- Short-cut - = -- RHS is another type-family application - -- Try shortcut; see Note [Top-level reductions for type functions] - do { shortCutReduction old_ev fsk ax_co tc tc_args - ; stopWith old_ev "Fun/Top (shortcut)" } - - | otherwise - = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty) - , ppr old_ev $$ ppr rhs_ty ) - -- Guaranteed by Note [FunEq occurs-check principle] - do { (rhs_xi, flatten_co) <- flatten FM_FlattenAll old_ev rhs_ty - -- flatten_co :: rhs_xi ~ rhs_ty - -- See Note [Flatten when discharging CFunEqCan] - ; let total_co = ax_co `mkTcTransCo` mkTcSymCo flatten_co - ; dischargeFunEq old_ev fsk total_co rhs_xi - ; traceTcS "doTopReactFunEq" $ - vcat [ text "old_ev:" <+> ppr old_ev - , nest 2 (text ":=") <+> ppr ax_co ] - ; stopWith old_ev "Fun/Top" } - -improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS () +doTopReactEq :: Ct -> TcS (StopOrContinue Ct) +doTopReactEq work_item@(CEqCan { cc_ev = old_ev, cc_lhs = TyFamLHS fam_tc args + , cc_rhs = rhs }) + = do { improveTopFunEqs old_ev fam_tc args rhs + ; doTopReactOther work_item } +doTopReactEq work_item = doTopReactOther work_item + +improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS () -- See Note [FunDep and implicit parameter reactions] -improveTopFunEqs ev fam_tc args fsk - | isGiven ev -- See Note [No FunEq improvement for Givens] - || not (isImprovable ev) +improveTopFunEqs ev fam_tc args rhs + | not (isImprovable ev) = return () | otherwise = do { fam_envs <- getFamInstEnvs - ; rhs <- rewriteTyVar fsk ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs , ppr eqns ]) @@ -2090,127 +1833,7 @@ improve_top_fun_eqs fam_envs fam_tc args rhs_ty _ -> True , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] } - -shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion - -> TyCon -> [TcType] -> TcS () --- See Note [Top-level reductions for type functions] --- Previously, we flattened the tc_args here, but there's no need to do so. --- And, if we did, this function would have all the complication of --- GHC.Tc.Solver.Canonical.canCFunEqCan. See Note [canCFunEqCan] -shortCutReduction old_ev fsk ax_co fam_tc tc_args - = ASSERT( ctEvEqRel old_ev == NomEq) - -- ax_co :: F args ~ G tc_args - -- old_ev :: F args ~ fsk - do { new_ev <- case ctEvFlavour old_ev of - Given -> newGivenEvVar deeper_loc - ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) - , evCoercion (mkTcSymCo ax_co - `mkTcTransCo` ctEvCoercion old_ev) ) - - Wanted {} -> - -- See TcCanonical Note [Equalities with incompatible kinds] about NoBlockSubst - do { (new_ev, new_co) <- newWantedEq_SI NoBlockSubst WDeriv deeper_loc Nominal - (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) - ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co - ; return new_ev } - - Derived -> pprPanic "shortCutReduction" (ppr old_ev) - - ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc - , cc_tyargs = tc_args, cc_fsk = fsk } - ; updWorkListTcS (extendWorkListFunEq new_ct) } - where - deeper_loc = bumpCtLocDepth (ctEvLoc old_ev) - -{- Note [Top-level reductions for type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c.f. Note [The flattening story] in GHC.Tc.Solver.Flatten - -Suppose we have a CFunEqCan F tys ~ fmv/fsk, and a matching axiom. -Here is what we do, in four cases: - -* Wanteds: general firing rule - (work item) [W] x : F tys ~ fmv - instantiate axiom: ax_co : F tys ~ rhs - - Then: - Discharge fmv := rhs - Discharge x := ax_co ; sym x2 - This is *the* way that fmv's get unified; even though they are - "untouchable". - - NB: Given Note [FunEq occurs-check principle], fmv does not appear - in tys, and hence does not appear in the instantiated RHS. So - the unification can't make an infinite type. - -* Wanteds: short cut firing rule - Applies when the RHS of the axiom is another type-function application - (work item) [W] x : F tys ~ fmv - instantiate axiom: ax_co : F tys ~ G rhs_tys - - It would be a waste to create yet another fmv for (G rhs_tys). - Instead (shortCutReduction): - - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis) - - Add G rhs_xis ~ fmv to flat cache (note: the same old fmv) - - New canonical wanted [W] x2 : G rhs_xis ~ fmv (CFunEqCan) - - Discharge x := ax_co ; G cos ; x2 - -* Givens: general firing rule - (work item) [G] g : F tys ~ fsk - instantiate axiom: ax_co : F tys ~ rhs - - Now add non-canonical given (since rhs is not flat) - [G] (sym g ; ax_co) : fsk ~ rhs (Non-canonical) - -* Givens: short cut firing rule - Applies when the RHS of the axiom is another type-function application - (work item) [G] g : F tys ~ fsk - instantiate axiom: ax_co : F tys ~ G rhs_tys - - It would be a waste to create yet another fsk for (G rhs_tys). - Instead (shortCutReduction): - - Flatten rhs_tys: flat_cos : tys ~ flat_tys - - Add new Canonical given - [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk (CFunEqCan) - -Note [FunEq occurs-check principle] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I have spent a lot of time finding a good way to deal with -CFunEqCan constraints like - F (fuv, a) ~ fuv -where flatten-skolem occurs on the LHS. Now in principle we -might may progress by doing a reduction, but in practice its -hard to find examples where it is useful, and easy to find examples -where we fall into an infinite reduction loop. A rule that works -very well is this: - - *** FunEq occurs-check principle *** - - Do not reduce a CFunEqCan - F tys ~ fsk - if fsk appears free in tys - Instead we treat it as stuck. - -Examples: - -* #5837 has [G] a ~ TF (a,Int), with an instance - type instance TF (a,b) = (TF a, TF b) - This readily loops when solving givens. But with the FunEq occurs - check principle, it rapidly gets stuck which is fine. - -* #12444 is a good example, explained in comment:2. We have - type instance F (Succ x) = Succ (F x) - [W] alpha ~ Succ (F alpha) - If we allow the reduction to happen, we get an infinite loop - -Note [Cached solved FunEqs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When trying to solve, say (FunExpensive big-type ~ ty), it's important -to see if we have reduced (FunExpensive big-type) before, lest we -simply repeat it. Hence the lookup in inert_solved_funeqs. Moreover -we must use `funEqCanDischarge` because both uses might (say) be Wanteds, -and we *still* want to save the re-computation. - +{- Note [MATCHING-SYNONYMS] ~~~~~~~~~~~~~~~~~~~~~~~~ When trying to match a dictionary (D tau) to a top-level instance, or a @@ -2254,68 +1877,6 @@ kinds much match too; so it's easier to let the normal machinery handle it. Instead we are careful to orient the new derived equality with the template on the left. Delicate, but it works. -Note [No FunEq improvement for Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't do improvements (injectivity etc) for Givens. Why? - -* It generates Derived constraints on skolems, which don't do us - much good, except perhaps identify inaccessible branches. - (They'd be perfectly valid though.) - -* For type-nat stuff the derived constraints include type families; - e.g. (a < b), (b < c) ==> a < c If we generate a Derived for this, - we'll generate a Derived/Wanted CFunEqCan; and, since the same - InertCans (after solving Givens) are used for each iteration, that - massively confused the unflattening step (GHC.Tc.Solver.Flatten.unflatten). - - In fact it led to some infinite loops: - indexed-types/should_compile/T10806 - indexed-types/should_compile/T10507 - polykinds/T10742 - -Note [Reduction for Derived CFunEqCans] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You may wonder if it's important to use top-level instances to -simplify [D] CFunEqCan's. But it is. Here's an example (T10226). - - type instance F Int = Int - type instance FInv Int = Int - -Suppose we have to solve - [WD] FInv (F alpha) ~ alpha - [WD] F alpha ~ Int - - --> flatten - [WD] F alpha ~ fuv0 - [WD] FInv fuv0 ~ fuv1 -- (A) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int -- (B) - - --> Rewwrite (A) with (B), splitting it - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] FInv Int ~ fuv1 -- (C) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int - - --> Reduce (C) with top-level instance - **** This is the key step *** - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] fuv1 ~ Int -- (D) - [WD] fuv1 ~ alpha -- (E) - [WD] fuv0 ~ Int - - --> Rewrite (D) with (E) - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] alpha ~ Int -- (F) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int - - --> unify (F) alpha := Int, and that solves it - -Another example is indexed-types/should_compile/T10634 -} {- ******************************************************************* @@ -2379,47 +1940,48 @@ 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 finish_derived deeper_loc theta - else finish_wanted deeper_loc theta mk_ev } + ; 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] + -- 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 + -- See Note [Instances in no-evidence implications] + + else + do { evc_vars <- mapM (newWanted deeper_loc) theta + ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars)) + ; emitWorkNC (freshGoals evc_vars) + ; stopWith ev "Dict/Top (solved wanted)" }}} where ev = ctEvidence work_item pred = ctEvPred ev loc = ctEvLoc ev - finish_wanted :: CtLoc -> [TcPredType] - -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct) - -- Precondition: evidence term matches the predicate workItem - finish_wanted loc theta mk_ev - = do { evb <- getTcEvBindsVar - ; if isCoEvBindsVar evb - then -- See Note [Instances in no-evidence implications] - continueWith work_item - else - do { evc_vars <- mapM (newWanted loc) theta - ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars)) - ; emitWorkNC (freshGoals evc_vars) - ; stopWith ev "Dict/Top (solved wanted)" } } - - finish_derived loc theta - = -- Use type-class instances for Deriveds, in the hope - -- of generating some improvements - -- C.f. Example 3 of Note [The improvement story] - -- It's easy because no evidence is involved - do { emitNewDeriveds loc theta - ; traceTcS "finish_derived" (ppr (ctl_depth loc)) - ; stopWith ev "Dict/Top (solved derived)" } - chooseInstance work_item lookup_res = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res) 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 --- (b) we have not recursed too deep -- 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 checkInstanceOK loc what pred = do { checkWellStagedDFun loc what pred - ; checkReductionDepth deeper_loc pred ; return deeper_loc } where deeper_loc = zap_origin (bumpCtLocDepth loc) @@ -2460,7 +2022,7 @@ matchClassInst dflags inerts clas tys loc -- First check whether there is an in-scope Given that could -- match this constraint. In that case, do not use any instance -- whether top level, or local quantified constraints. --- ee Note [Instance and Given overlap] +-- See Note [Instance and Given overlap] | not (xopt LangExt.IncoherentInstances dflags) , not (naturallyCoherentClass clas) , let matchable_givens = matchableGivens loc pred inerts @@ -2533,7 +2095,7 @@ The partial solution is that: The end effect is that, much as we do for overlapping instances, we delay choosing a class instance if there is a possibility of another instance OR a given to match our constraint later on. This fixes -#4981 and #5002. +tickets #4981 and #5002. Other notes: @@ -2543,12 +2105,7 @@ Other notes: - natural numbers - Typeable -* Flatten-skolems: we do not treat a flatten-skolem as unifiable - for this purpose. - E.g. f :: Eq (F a) => [a] -> [a] - f xs = ....(xs==xs)..... - Here we get [W] Eq [a], and we don't want to refrain from solving - it because of the given (Eq (F a)) constraint! +* See also Note [What might match later?] in GHC.Tc.Solver.Monad. * The given-overlap problem is arguably not easy to appear in practice due to our aggressive prioritization of equality solving over other diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 64a80b2e94..80f6e7f3a8 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-} +{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies, ScopedTypeVariables, TypeApplications, + DerivingStrategies, GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} -- | Type definitions for the constraint solver module GHC.Tc.Solver.Monad ( @@ -8,10 +9,10 @@ module GHC.Tc.Solver.Monad ( -- The work list WorkList(..), isEmptyWorkList, emptyWorkList, extendWorkListNonEq, extendWorkListCt, - extendWorkListCts, extendWorkListEq, extendWorkListFunEq, + extendWorkListCts, extendWorkListEq, appendWorkList, selectNextWorkItem, - workListSize, workListWantedCount, + workListSize, getWorkList, updWorkListTcS, pushLevelNoWorkList, -- The TcS monad @@ -40,7 +41,7 @@ module GHC.Tc.Solver.Monad ( newWantedNC, newWantedEvVarNC, newDerivedNC, newBoundEvVarId, - unifyTyVar, unflattenFmv, reportUnifications, + unifyTyVar, reportUnifications, setEvBind, setWantedEq, setWantedEvTerm, setEvBindIfWanted, newEvVar, newGivenEvVar, newGivenEvVars, @@ -57,7 +58,7 @@ module GHC.Tc.Solver.Monad ( -- Inerts InertSet(..), InertCans(..), emptyInert, updInertTcS, updInertCans, updInertDicts, updInertIrreds, - getNoGivenEqs, setInertCans, + getHasGivenEqs, setInertCans, getInertEqs, getInertCans, getInertGivens, getInertInsols, getTcSInerts, setTcSInerts, @@ -79,9 +80,9 @@ module GHC.Tc.Solver.Monad ( DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict, addDictsByClass, delDict, foldDicts, filterDicts, findDict, - -- Inert CTyEqCans - EqualCtList, findTyEqs, foldTyEqs, isInInertEqs, - lookupInertTyVar, + -- Inert CEqCans + EqualCtList(..), findTyEqs, foldTyEqs, + findEq, -- Inert solved dictionaries addSolvedDict, lookupSolvedDict, @@ -90,18 +91,17 @@ module GHC.Tc.Solver.Monad ( foldIrreds, -- The flattening cache - lookupFlatCache, extendFlatCache, newFlattenSkolem, -- Flatten skolems - dischargeFunEq, pprKicked, + lookupFamAppInert, lookupFamAppCache, extendFamAppCache, + pprKicked, - -- Inert CFunEqCans - updInertFunEqs, findFunEq, - findFunEqsByTyCon, + -- Inert function equalities + findFunEq, findFunEqsByTyCon, instDFunType, -- Instantiation -- MetaTyVars newFlexiTcSTy, instFlexi, instFlexiX, - cloneMetaTyVar, demoteUnfilledFmv, + cloneMetaTyVar, tcInstSkolTyVarsX, TcLevel, @@ -118,11 +118,13 @@ module GHC.Tc.Solver.Monad ( getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, matchFam, matchFamTcM, checkWellStagedDFun, - pprEq -- Smaller utils, re-exported from TcM + pprEq, -- Smaller utils, re-exported from TcM -- TODO (DV): these are only really used in the -- instance matcher in GHC.Tc.Solver. I am wondering -- if the whole instance matcher simply belongs -- here + + breakTyVarCycle, flattenView ) where #include "HsVersions.h" @@ -145,6 +147,7 @@ import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDict import GHC.Tc.Utils.TcType import GHC.Driver.Session import GHC.Core.Type +import qualified GHC.Core.TyCo.Rep as Rep -- this needs to be used only very locally import GHC.Core.Coercion import GHC.Core.Unify @@ -172,9 +175,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint import GHC.Core.Predicate -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Types.Unique.DFM +import GHC.Types.Unique.Set import GHC.Core.TyCon.Env import GHC.Data.Maybe @@ -185,10 +186,13 @@ import Control.Monad import GHC.Utils.Monad import Data.IORef import Data.List ( partition, mapAccumL ) +import qualified Data.Semigroup as S +import Data.List.NonEmpty ( NonEmpty(..), cons, toList, nonEmpty ) +import qualified Data.List.NonEmpty as NE +import Control.Arrow ( first ) #if defined(DEBUG) import GHC.Data.Graph.Directed -import GHC.Types.Unique.Set #endif {- @@ -210,7 +214,6 @@ consider using this depth for prioritization as well in the future. As a simple form of priority queue, our worklist separates out * equalities (wl_eqs); see Note [Prioritise equalities] -* type-function equalities (wl_funeqs) * all the rest (wl_rest) Note [Prioritise equalities] @@ -268,15 +271,13 @@ So we arrange to put these particular class constraints in the wl_eqs. -- See Note [WorkList priorities] data WorkList - = WL { wl_eqs :: [Ct] -- CTyEqCan, CDictCan, CIrredCan + = WL { wl_eqs :: [Ct] -- CEqCan, CDictCan, CIrredCan -- Given, Wanted, and Derived -- Contains both equality constraints and their -- class-level variants (a~b) and (a~~b); -- See Note [Prioritise equalities] -- See Note [Prioritise class equalities] - , wl_funeqs :: [Ct] - , wl_rest :: [Ct] , wl_implics :: Bag Implication -- See Note [Residual implications] @@ -284,37 +285,21 @@ data WorkList appendWorkList :: WorkList -> WorkList -> WorkList appendWorkList - (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1 + (WL { wl_eqs = eqs1, wl_rest = rest1 , wl_implics = implics1 }) - (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2 + (WL { wl_eqs = eqs2, wl_rest = rest2 , wl_implics = implics2 }) = WL { wl_eqs = eqs1 ++ eqs2 - , wl_funeqs = funeqs1 ++ funeqs2 , wl_rest = rest1 ++ rest2 , wl_implics = implics1 `unionBags` implics2 } workListSize :: WorkList -> Int -workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest }) - = length eqs + length funeqs + length rest - -workListWantedCount :: WorkList -> Int --- Count the things we need to solve --- excluding the insolubles (c.f. inert_count) -workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest }) - = count isWantedCt eqs + count is_wanted rest - where - is_wanted ct - | CIrredCan { cc_status = InsolubleCIS } <- ct - = False - | otherwise - = isWantedCt ct +workListSize (WL { wl_eqs = eqs, wl_rest = rest }) + = length eqs + length rest extendWorkListEq :: Ct -> WorkList -> WorkList extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl } -extendWorkListFunEq :: Ct -> WorkList -> WorkList -extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl } - extendWorkListNonEq :: Ct -> WorkList -> WorkList -- Extension by non equality extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } @@ -330,11 +315,6 @@ extendWorkListCt :: Ct -> WorkList -> WorkList -- Agnostic extendWorkListCt ct wl = case classifyPredType (ctPred ct) of - EqPred NomEq ty1 _ - | Just tc <- tcTyConAppTyCon_maybe ty1 - , isTypeFamilyTyCon tc - -> extendWorkListFunEq ct wl - EqPred {} -> extendWorkListEq ct wl @@ -349,20 +329,16 @@ extendWorkListCts :: [Ct] -> WorkList -> WorkList extendWorkListCts cts wl = foldr extendWorkListCt wl cts isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs - , wl_rest = rest, wl_implics = implics }) - = null eqs && null rest && null funeqs && isEmptyBag implics +isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics }) + = null eqs && null rest && isEmptyBag implics emptyWorkList :: WorkList -emptyWorkList = WL { wl_eqs = [], wl_rest = [] - , wl_funeqs = [], wl_implics = emptyBag } +emptyWorkList = WL { wl_eqs = [], wl_rest = [], wl_implics = emptyBag } selectWorkItem :: WorkList -> Maybe (Ct, WorkList) -- See Note [Prioritise equalities] -selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs - , wl_rest = rest }) +selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest }) | ct:cts <- eqs = Just (ct, wl { wl_eqs = cts }) - | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes }) | ct:cts <- rest = Just (ct, wl { wl_rest = cts }) | otherwise = Nothing @@ -386,13 +362,10 @@ selectNextWorkItem -- Pretty printing instance Outputable WorkList where - ppr (WL { wl_eqs = eqs, wl_funeqs = feqs - , wl_rest = rest, wl_implics = implics }) + ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics }) = text "WL" <+> (braces $ vcat [ ppUnless (null eqs) $ text "Eqs =" <+> vcat (map ppr eqs) - , ppUnless (null feqs) $ - text "Funeqs =" <+> vcat (map ppr feqs) , ppUnless (null rest) $ text "Non-eqs =" <+> vcat (map ppr rest) , ppUnless (isEmptyBag implics) $ @@ -413,30 +386,20 @@ data InertSet -- Canonical Given, Wanted, Derived -- Sometimes called "the inert set" - , inert_fsks :: [(TcTyVar, TcType)] - -- A list of (fsk, ty) pairs; we add one element when we flatten - -- a function application in a Given constraint, creating - -- a new fsk in newFlattenSkolem. When leaving a nested scope, - -- unflattenGivens unifies fsk := ty - -- - -- We could also get this info from inert_funeqs, filtered by - -- level, but it seems simpler and more direct to capture the - -- fsk as we generate them. + , inert_cycle_breakers :: [(TcTyVar, TcType)] + -- a list of CycleBreakerTv / original family applications + -- used to undo the cycle-breaking needed to handle + -- Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical - , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour) - -- See Note [Type family equations] - -- If F tys :-> (co, rhs, flav), - -- then co :: F tys ~ rhs - -- flav is [G] or [WD] + , inert_famapp_cache :: FunEqMap (TcCoercion, TcType) + -- Just a hash-cons cache for use when reducing family applications + -- only -- - -- Just a hash-cons cache for use when flattening only - -- These include entirely un-processed goals, so don't use - -- them to solve a top-level goal, else you may end up solving - -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache - -- when allocating a new flatten-skolem. - -- Not necessarily inert wrt top-level equations (or inert_cans) - - -- NB: An ExactFunEqMap -- this doesn't match via loose types! + -- If F tys :-> (co, rhs, flav), + -- then co :: rhs ~N F tys + -- all evidence is from instances or Givens; no coercion holes here + -- (We have no way of "kicking out" from the cache, so putting + -- wanteds here means we can end up solving a Wanted with itself. Bad) , inert_solved_dicts :: DictMap CtEvidence -- All Wanteds, of form ev :: C t1 .. tn @@ -446,10 +409,8 @@ data InertSet instance Outputable InertSet where ppr (IS { inert_cans = ics - , inert_fsks = ifsks , inert_solved_dicts = solved_dicts }) = vcat [ ppr ics - , text "Inert fsks =" <+> ppr ifsks , ppUnless (null dicts) $ text "Solved dicts =" <+> vcat (map ppr dicts) ] where @@ -457,8 +418,7 @@ instance Outputable InertSet where emptyInertCans :: InertCans emptyInertCans - = IC { inert_count = 0 - , inert_eqs = emptyDVarEnv + = IC { inert_eqs = emptyDVarEnv , inert_dicts = emptyDicts , inert_safehask = emptyDicts , inert_funeqs = emptyFunEqs @@ -467,10 +427,10 @@ emptyInertCans emptyInert :: InertSet emptyInert - = IS { inert_cans = emptyInertCans - , inert_fsks = [] - , inert_flat_cache = emptyExactFunEqs - , inert_solved_dicts = emptyDictMap } + = IS { inert_cans = emptyInertCans + , inert_cycle_breakers = [] + , inert_famapp_cache = emptyFunEqs + , inert_solved_dicts = emptyDictMap } {- Note [Solved dictionaries] @@ -708,16 +668,14 @@ Result data InertCans -- See Note [Detailed InertCans Invariants] for more = IC { inert_eqs :: InertEqs -- See Note [inert_eqs: the inert equalities] - -- All CTyEqCans; index is the LHS tyvar + -- All CEqCans with a TyVarLHS; index is the LHS tyvar -- Domain = skolems and untouchables; a touchable would be unified - , inert_funeqs :: FunEqMap Ct - -- All CFunEqCans; index is the whole family head type. - -- All Nominal (that's an invariant of all CFunEqCans) + , inert_funeqs :: FunEqMap EqualCtList + -- 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] - -- See Note [Type family equations] , inert_dicts :: DictMap Ct -- Dictionaries only @@ -739,16 +697,38 @@ data InertCans -- See Note [Detailed InertCans Invariants] for more -- Irreducible predicates that cannot be made canonical, -- and which don't interact with others (e.g. (c a)) -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) - - , inert_count :: Int - -- Number of Wanted goals in - -- inert_eqs, inert_dicts, inert_safehask, inert_irreds - -- Does not include insolubles - -- When non-zero, keep trying to solve } type InertEqs = DTyVarEnv EqualCtList -type EqualCtList = [Ct] -- See Note [EqualCtList invariants] + +newtype EqualCtList = EqualCtList (NonEmpty Ct) + deriving newtype Outputable + -- See Note [EqualCtList invariants] + +unitEqualCtList :: Ct -> EqualCtList +unitEqualCtList ct = EqualCtList (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 (EqualCtList old_eqs) + | isWantedCt ct + , eq1 :| eqs <- old_eqs + = EqualCtList (eq1 :| ct : eqs) + | otherwise + = EqualCtList (ct `cons` old_eqs) + +filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList +filterEqualCtList pred (EqualCtList cts) + = fmap EqualCtList (nonEmpty $ NE.filter pred cts) + +equalCtListToList :: EqualCtList -> [Ct] +equalCtListToList (EqualCtList cts) = toList cts + +listToEqualCtList :: [Ct] -> Maybe EqualCtList +-- NB: This does not maintain invariants other than having the EqualCtList be +-- non-empty +listToEqualCtList cts = EqualCtList <$> nonEmpty cts {- Note [Detailed InertCans Invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -766,11 +746,11 @@ The InertCans represents a collection of constraints with the following properti * Given family or dictionary constraints don't mention touchable unification variables - * Non-CTyEqCan constraints are fully rewritten with respect - to the CTyEqCan equalities (modulo canRewrite of course; + * Non-CEqCan constraints are fully rewritten with respect + to the CEqCan equalities (modulo eqCanRewrite of course; eg a wanted cannot rewrite a given) - * CTyEqCan equalities: see Note [inert_eqs: the inert equalities] + * CEqCan equalities: see Note [inert_eqs: the inert equalities] Also see documentation in Constraint.Ct for a list of invariants Note [EqualCtList invariants] @@ -787,42 +767,6 @@ From the fourth invariant it follows that the list is The Wanteds can't rewrite anything which is why we put them last -Note [Type family equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type-family equations, CFunEqCans, of form (ev : F tys ~ ty), -live in three places - - * The work-list, of course - - * The inert_funeqs are un-solved but fully processed, and in - the InertCans. They can be [G], [W], [WD], or [D]. - - * The inert_flat_cache. This is used when flattening, to get maximal - sharing. Everything in the inert_flat_cache is [G] or [WD] - - It contains lots of things that are still in the work-list. - E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the - work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work - list. Now if we flatten w2 before we get to w3, we still want to - share that (G a). - Because it contains work-list things, DO NOT use the flat cache to solve - a top-level goal. Eg in the above example we don't want to solve w3 - using w3 itself! - -The CFunEqCan Ownership Invariant: - - * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv - It "owns" that fsk/fmv, in the sense that: - - reducing a [W/WD] CFunEqCan fills in the fmv - - unflattening a [W/WD] CFunEqCan fills in the fmv - (in both cases unless an occurs-check would result) - - * In contrast a [D] CFunEqCan does not "own" its fmv: - - reducing a [D] CFunEqCan does not fill in the fmv; - it just generates an equality - - unflattening ignores [D] CFunEqCans altogether - - Note [inert_eqs: the inert equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Definition [Can-rewrite relation] @@ -837,25 +781,25 @@ Lemma. If f1 >= f then f1 >= f1 Proof. By property (R2), with f1=f2 Definition [Generalised substitution] -A "generalised substitution" S is a set of triples (a -f-> t), where - a is a type variable +A "generalised substitution" S is a set of triples (t0 -f-> t), where + t0 is a type variable or an exactly-saturated type family application + (that is, t0 is a CanEqLHS) t is a type f is a flavour such that - (WF1) if (a -f1-> t1) in S - (a -f2-> t2) in S - then neither (f1 >= f2) nor (f2 >= f1) hold - (WF2) if (a -f-> t) is in S, then t /= a + (WF1) if (t0 -f1-> t1) in S + (t0' -f2-> t2) in S + then either not (f1 >= f2) or t0 does not appear within t0' + (WF2) if (t0 -f-> t) is in S, then t /= t0 Definition [Applying a generalised substitution] If S is a generalised substitution - S(f,a) = t, if (a -fs-> t) in S, and fs >= f - = a, otherwise -Application extends naturally to types S(f,t), modulo roles. -See Note [Flavours with roles]. + S(f,t0) = t, if (t0 -fs-> t) in S, and fs >= f + = apply S to components of t0, otherwise +See also Note [Flavours with roles]. -Theorem: S(f,a) is well defined as a function. -Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S, +Theorem: S(f,t0) is well defined as a function. +Proof: Suppose (t0 -f1-> t1) and (t0 -f2-> t2) are both in S, and f1 >= f and f2 >= f Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1) @@ -874,46 +818,47 @@ applying S(f,_) to t. ---------------------------------------------------------------- Our main invariant: - the inert CTyEqCans should be an inert generalised substitution + the inert CEqCans should be an inert generalised substitution ---------------------------------------------------------------- Note that inertness is not the same as idempotence. To apply S to a -type, you may have to apply it recursive. But inertness does +type, you may have to apply it recursively. But inertness does guarantee that this recursive use will terminate. Note [Extending the inert equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Main Theorem [Stability under extension] Suppose we have a "work item" - a -fw-> t + t0 -fw-> t and an inert generalised substitution S, - THEN the extended substitution T = S+(a -fw-> t) + THEN the extended substitution T = S+(t0 -fw-> t) is an inert generalised substitution PROVIDED - (T1) S(fw,a) = a -- LHS of work-item is a fixpoint of S(fw,_) - (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) - (T3) a not in t -- No occurs check in the work item + (T1) S(fw,t0) = t0 -- LHS of work-item is a fixpoint of S(fw,_) + (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) + (T3) t0 not in t -- No occurs check in the work item - AND, for every (b -fs-> s) in S: + AND, for every (t0' -fs-> s) in S: (K0) not (fw >= fs) Reason: suppose we kick out (a -fs-> s), - and add (a -fw-> t) to the inert set. + and add (t0 -fw-> t) to the inert set. The latter can't rewrite the former, so the kick-out achieved nothing - OR { (K1) not (a = b) + OR { (K1) t0 is not rewritable in t0'. That is, t0 does not occur + in t0' (except perhaps in a cast or coercion). Reason: if fw >= fs, WF1 says we can't have both - a -fw-> t and a -fs-> s + t0 -fw-> t and F t0 -fs-> s AND (K2): guarantees inertness of the new substitution { (K2a) not (fs >= fs) OR (K2b) fs >= fw - OR (K2d) a not in s } + OR (K2d) t0 not in s } AND (K3) See Note [K3: completeness of solving] - { (K3a) If the role of fs is nominal: s /= a + { (K3a) If the role of fs is nominal: s /= t0 (K3b) If the role of fs is representational: - s is not of form (a t1 .. tn) } } + s is not of form (t0 t1 .. tn) } } Conditions (T1-T3) are established by the canonicaliser @@ -924,8 +869,8 @@ The idea is that with S(fw,_). * T3 is guaranteed by a simple occurs-check on the work item. - This is done during canonicalisation, in canEqTyVar; invariant - (TyEq:OC) of CTyEqCan. + This is done during canonicalisation, in canEqCanLHSFinish; invariant + (TyEq:OC) of CEqCan. * (K1-3) are the "kick-out" criteria. (As stated, they are really the "keep" criteria.) If the current inert S contains a triple that does @@ -950,10 +895,10 @@ The idea is that 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 - (a -fs-> t) in S, s.t. (fs >= fw). + (t0 -fs-> t) in S, s.t. (fs >= fw). Proof. Suppose the contrary (fs >= fw). Then because of (T1), - S(fw,a)=a. But since fs>=fw, S(fw,a) = s, hence s=a. But now we - have (a -fs-> a) in S, which contradicts (WF2). + S(fw,t0)=t0. But since fs>=fw, S(fw,t0) = s, hence s=t0. But now we + have (t0 -fs-> t0) in S, which contradicts (WF2). * The extended substitution satisfies (WF1) and (WF2) - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1). @@ -1044,7 +989,7 @@ now reduced to reflexivity. The solution here is to kick out representational inerts whenever the tyvar of a work item is "exposed", where exposed means being at the head of the top-level application chain (a t1 .. tn). See -TcType.isTyVarHead. This is encoded in (K3b). +is_can_eq_lhs_head. This is encoded in (K3b). Beware: if we make this test succeed too often, we kick out too much, and the solver might loop. Consider (#14363) @@ -1082,14 +1027,14 @@ instance Outputable InertCans where ppr (IC { inert_eqs = eqs , inert_funeqs = funeqs, inert_dicts = dicts , inert_safehask = safehask, inert_irreds = irreds - , inert_insts = insts - , inert_count = count }) + , inert_insts = insts }) + = braces $ vcat [ ppUnless (isEmptyDVarEnv eqs) $ text "Equalities:" - <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs) + <+> pprCts (foldDVarEnv folder emptyCts eqs) , ppUnless (isEmptyTcAppMap funeqs) $ - text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs) + text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts) , ppUnless (isEmptyTcAppMap dicts) $ text "Dictionaries =" <+> pprCts (dictsToBag dicts) , ppUnless (isEmptyTcAppMap safehask) $ @@ -1098,8 +1043,9 @@ instance Outputable InertCans where text "Irreds =" <+> pprCts irreds , ppUnless (null insts) $ text "Given instances =" <+> vcat (map ppr insts) - , text "Unsolved goals =" <+> int count ] + where + folder (EqualCtList eqs) rest = nonEmptyToBag eqs `andCts` rest {- ********************************************************************* * * @@ -1115,21 +1061,13 @@ 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 - [W] Foo e ~ Foo ee -- ee is a unification variable - [W] Foo ee ~ Maybe ee + 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) - Flatten: [G] Foo e ~ fsk - [G] fsk ~ Maybe e -- (A) + The first Wanted gets rewritten to - [W] Foo ee ~ fmv - [W] fmv ~ fsk -- (B) From Foo e ~ Foo ee - [W] fmv ~ Maybe ee - - --> rewrite (B) with (A) - [W] Foo ee ~ fmv - [W] fmv ~ Maybe e - [W] fmv ~ Maybe ee + [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 @@ -1162,20 +1100,18 @@ More specifically, here's how it works (Oct 16): 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 ~ fmv - [WD] fmv ~ Maybe e - [WD] fmv ~ Maybe ee + [WD] Foo ee ~ Foo e + [WD] Foo ee ~ Maybe ee -But now when [WD] fmv ~ Maybe ee is about to be added, we'll -split it into [W] and [D], since the inert [WD] fmv ~ Maybe e +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] fmv ~ Maybe ee - inert: [W] fmv ~ Maybe ee - [WD] fmv ~ Maybe e -- (C) - [WD] Foo ee ~ fmv + 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 (C) and we soon get ee := e. +by the [WD] and we soon get ee := e. Additional notes: @@ -1189,15 +1125,14 @@ Additional notes: * We also get Derived equalities from functional dependencies and type-function injectivity; see calls to unifyDerived. - * This splitting business applies to CFunEqCans too; and then - we do apply type-function reductions to the [D] CFunEqCan. - See Note [Reduction for Derived CFunEqCans] - * It's worth having [WD] rather than just [W] and [D] because * efficiency: silly to process the same thing twice - * inert_funeqs, inert_dicts is a finite map keyed by + * 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 @@ -1205,7 +1140,7 @@ 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) or CFunEqCan (F tys ~ fsk): +* 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 @@ -1213,8 +1148,8 @@ work? because rewriting the casts or coercions won't make the thing fire more often. -* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'. - We need to check both 'a' and 'ty' against the inert set: +* 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 @@ -1245,22 +1180,17 @@ scenario: work item: [WD] a ~ beta -This is heterogeneous, so we try flattening the kinds. - - co :: F v ~ fmv - [WD] (a |> co) ~ beta - -This is still hetero, so we emit a kind equality and make the work item an +This is heterogeneous, so we emit a kind equality and make the work item an inert Irred. - work item: [D] fmv ~ alpha + 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] fmv ~ alpha (CTyEqCan) + inert: [D] F v ~ alpha (CEqCan) Can't make progress on this work item either (although GHC tries by decomposing the cast and reflattening... but that doesn't make a difference), @@ -1268,25 +1198,24 @@ which is still hetero. Emit a new kind equality and add to inert set. But, critically, we split the Irred. work list: - [D] fmv ~ alpha (CTyEqCan) + [D] F v ~ alpha (CEqCan) [D] (a |> co) ~ beta (CIrred) -- this one was split off inert: [W] (a |> co) ~ beta - [D] fmv ~ alpha + [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] fmv ~ alpha + [D] F v ~ alpha We decompose the cast, yielding [D] a ~ beta -We then flatten the kinds. The lhs kind is F v, which flattens to fmv which -then rewrites to alpha. +We then flatten the kinds. The lhs kind is F v, which flattens to alpha. co' :: F v ~ alpha [D] (a |> co') ~ beta @@ -1301,35 +1230,6 @@ 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 [Examples of how Derived shadows helps completeness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Ticket #10009, a very nasty example: - - f :: (UnF (F b) ~ b) => F b -> () - - g :: forall a. (UnF (F a) ~ a) => a -> () - g _ = f (undefined :: F a) - - For g we get [G] UnF (F a) ~ a - [WD] UnF (F beta) ~ beta - [WD] F a ~ F beta - Flatten: - [G] g1: F a ~ fsk1 fsk1 := F a - [G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1 - [G] g3: fsk2 ~ a - - [WD] w1: F beta ~ fmv1 - [WD] w2: UnF fmv1 ~ fmv2 - [WD] w3: fmv2 ~ beta - [WD] w4: fmv1 ~ fsk1 -- From F a ~ F beta using flat-cache - -- and re-orient to put meta-var on left - -Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2 -React that with g2: [D] d2: fmv2 ~ fsk2 -React that with w3: [D] beta ~ fsk2 - and g3: [D] beta ~ a -- Hooray beta := a -And that is enough to solve everything - Note [Add derived shadows only for Wanteds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We only add shadows for Wanted constraints. That is, we have @@ -1423,7 +1323,7 @@ maybeEmitShadow ics ct | let ev = ctEvidence ct , CtWanted { ctev_pred = pred, ctev_loc = loc , ctev_nosh = WDeriv } <- ev - , shouldSplitWD (inert_eqs ics) ct + , 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 } @@ -1442,45 +1342,52 @@ maybeEmitShadow ics ct | otherwise = return ct -shouldSplitWD :: InertEqs -> Ct -> Bool +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 (CFunEqCan { cc_tyargs = tys }) - = should_split_match_args inert_eqs tys - -- We don't need to split if the tv is the RHS fsk - -shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys }) - = should_split_match_args inert_eqs tys +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 (CTyEqCan { cc_tyvar = tv, cc_rhs = ty - , cc_eq_rel = eq_rel }) +shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_lhs = TyVarLHS tv, cc_rhs = ty + , cc_eq_rel = eq_rel }) = tv `elemDVarEnv` inert_eqs - || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty + || 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 (CIrredCan { cc_ev = ev }) - = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev) +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 +shouldSplitWD _ _ _ = False -- No point in splitting otherwise -should_split_match_args :: InertEqs -> [TcType] -> Bool --- True if the inert_eqs can rewrite anything in the argument --- types, ignoring casts and coercions -should_split_match_args inert_eqs tys - = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys - -- NB True: ignore casts coercions +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 (ct : _) <- lookupDVarEnv inert_eqs tv - , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct + | 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 @@ -1499,32 +1406,46 @@ isImprovable _ = True addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs addTyEq old_eqs tv ct - = extendDVarEnv_C add_eq old_eqs tv [ct] + = extendDVarEnv_C add_eq old_eqs tv (unitEqualCtList ct) where - add_eq old_eqs _ - | isWantedCt ct - , (eq1 : eqs) <- old_eqs - = eq1 : ct : eqs - | otherwise - = ct : old_eqs + add_eq old_eqs _ = addToEqualCtList ct old_eqs + +addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct + -> FunEqMap EqualCtList +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 foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b foldTyEqs k eqs z - = foldDVarEnv (\cts z -> foldr k z cts) z eqs - -findTyEqs :: InertCans -> TyVar -> EqualCtList -findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` [] + = foldDVarEnv (\(EqualCtList 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) + +delEq :: InertCans -> CanEqLHS -> TcType -> InertCans +delEq ic lhs rhs = case lhs of + TyVarLHS tv + -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv } + TyFamLHS tf args + -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd } + where + isThisOne :: Ct -> Bool + isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1 + isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other) -delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs -delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv - where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1 - isThisOne _ = False + upd :: Maybe EqualCtList -> Maybe EqualCtList + upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list + upd Nothing = Nothing -lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType -lookupInertTyVar ieqs tv - = case lookupDVarEnv ieqs tv of - Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs - _ -> Nothing +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) {- ********************************************************************* * * @@ -1590,33 +1511,13 @@ When adding an equality to the inerts: * Note that unifying a:=ty, is like adding [G] a~ty; just use kickOutRewritable with Nominal, Given. See kickOutAfterUnification. - -Note [Kicking out CFunEqCan for fundeps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - New: [D] fmv1 ~ fmv2 - Inert: [W] F alpha ~ fmv1 - [W] F beta ~ fmv2 - -where F is injective. The new (derived) equality certainly can't -rewrite the inerts. But we *must* kick out the first one, to get: - - New: [W] F alpha ~ fmv1 - Inert: [W] F beta ~ fmv2 - [D] fmv1 ~ fmv2 - -and now improvement will discover [D] alpha ~ beta. This is important; -eg in #9587. - -So in kickOutRewritable we look at all the tyvars of the -CFunEqCan, including the fsk. -} -addInertCan :: Ct -> TcS () -- Constraints *other than* equalities +addInertCan :: Ct -> TcS () -- Precondition: item /is/ canonical -- See Note [Adding an equality to the InertCans] addInertCan ct - = do { traceTcS "insertInertCan {" $ + = do { traceTcS "addInertCan {" $ text "Trying to insert new inert item:" <+> ppr ct ; ics <- getInertCans @@ -1627,58 +1528,59 @@ addInertCan ct ; traceTcS "addInertCan }" $ empty } maybeKickOut :: InertCans -> Ct -> TcS InertCans --- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan +-- For a CEqCan, kick out any inert that can be rewritten by the CEqCan maybeKickOut ics ct - | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct - = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics + | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct + = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics ; return ics' } | otherwise = return ics add_item :: InertCans -> Ct -> InertCans -add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) - = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item } +add_item ics item@(CEqCan { cc_lhs = TyFamLHS tc tys }) + = ics { inert_funeqs = addCanFunEq (inert_funeqs ics) tc tys item } -add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev }) - = ics { inert_eqs = addTyEq (inert_eqs ics) tv item - , inert_count = bumpUnsolvedCount ev (inert_count ics) } +add_item ics item@(CEqCan { cc_lhs = TyVarLHS tv }) + = ics { inert_eqs = addTyEq (inert_eqs ics) tv item } -add_item ics@(IC { inert_irreds = irreds, inert_count = count }) - item@(CIrredCan { cc_ev = ev, cc_status = status }) - = ics { inert_irreds = irreds `Bag.snocBag` item - , inert_count = case status of - InsolubleCIS -> count - _ -> bumpUnsolvedCount ev count } - -- inert_count does not include insolubles +add_item ics@(IC { inert_irreds = irreds }) item@(CIrredCan {}) + = ics { inert_irreds = irreds `Bag.snocBag` item } - -add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) - = ics { inert_dicts = addDict (inert_dicts ics) cls tys item - , inert_count = bumpUnsolvedCount ev (inert_count ics) } +add_item ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) + = ics { inert_dicts = addDict (inert_dicts ics) cls tys item } add_item _ item = pprPanic "upd_inert set: can't happen! Inserting " $ ppr item -- Can't be CNonCanonical because they only land in inert_irreds -bumpUnsolvedCount :: CtEvidence -> Int -> Int -bumpUnsolvedCount ev n | isWanted ev = n+1 - | otherwise = n - - ----------------------------------------- kickOutRewritable :: CtFlavourRole -- Flavour/role of the equality that -- is being added to the inert set - -> TcTyVar -- The new equality is tv ~ ty - -> InertCans - -> TcS (Int, InertCans) -kickOutRewritable new_fr new_tv ics - = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics + -> CanEqLHS -- The new equality is lhs ~ ty + -> InertCans + -> TcS (Int, InertCans) +kickOutRewritable new_fr new_lhs ics + = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_lhs ics n_kicked = workListSize kicked_out ; unless (n_kicked == 0) $ do { updWorkListTcS (appendWorkList kicked_out) + + -- The famapp-cache contains Given evidence from the inert set. + -- If we're kicking out Givens, we need to remove this evidence + -- from the cache, too. + ; let kicked_given_ev_vars = + [ ev_var | ct <- wl_eqs kicked_out + , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ] + ; when (new_fr `eqCanRewriteFR` (Given, NomEq) && + -- if this isn't true, no use looking through the constraints + not (null kicked_given_ev_vars)) $ + do { traceTcS "Given(s) have been kicked out; drop from famapp-cache" + (ppr kicked_given_ev_vars) + ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) } + ; csTraceTcS $ - hang (text "Kick out, tv =" <+> ppr new_tv) + hang (text "Kick out, lhs =" <+> ppr new_lhs) 2 (vcat [ text "n-kicked =" <+> int n_kicked , text "kicked_out =" <+> ppr kicked_out , text "Residual inerts =" <+> ppr ics' ]) } @@ -1687,18 +1589,17 @@ kickOutRewritable new_fr new_tv ics kick_out_rewritable :: CtFlavourRole -- Flavour/role of the equality that -- is being added to the inert set - -> TcTyVar -- The new equality is tv ~ ty + -> CanEqLHS -- The new equality is lhs ~ ty -> InertCans -> (WorkList, InertCans) -- See Note [kickOutRewritable] -kick_out_rewritable new_fr new_tv +kick_out_rewritable new_fr new_lhs ics@(IC { inert_eqs = tv_eqs , inert_dicts = dictmap , inert_safehask = safehask , inert_funeqs = funeqmap , inert_irreds = irreds - , inert_insts = old_insts - , inert_count = n }) + , inert_insts = old_insts }) | not (new_fr `eqMayRewriteFR` new_fr) = (emptyWorkList, ics) -- If new_fr can't rewrite itself, it can't rewrite @@ -1714,25 +1615,24 @@ kick_out_rewritable new_fr new_tv , inert_safehask = safehask -- ?? , inert_funeqs = feqs_in , inert_irreds = irs_in - , inert_insts = insts_in - , inert_count = n - workListWantedCount kicked_out } + , inert_insts = insts_in } kicked_out :: WorkList -- NB: use extendWorkList to ensure that kicked-out equalities get priority -- See Note [Prioritise equalities] (Kick-out). -- The irreds may include non-canonical (hetero-kinded) equality - -- constraints, which perhaps may have become soluble after new_tv + -- constraints, which perhaps may have become soluble after new_lhs -- is substituted; ditto the dictionaries, which may include (a~b) -- or (a~~b) constraints. kicked_out = foldr extendWorkListCt - (emptyWorkList { wl_eqs = tv_eqs_out - , wl_funeqs = feqs_out }) + (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out }) ((dicts_out `andCts` irs_out) `extendCtsList` insts_out) - (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs - (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap - -- See Note [Kicking out CFunEqCan for fundeps] + (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 -- Kick out even insolubles: See Note [Rewrite insolubles] @@ -1757,46 +1657,80 @@ kick_out_rewritable new_fr new_tv (_, new_role) = new_fr + 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 + where + can_rewrite :: EqRel -> TyVar -> Bool + can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv + + fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool + fr_tf_can_rewrite_ty new_tf new_tf_args role ty + = anyRewritableTyFamApp role can_rewrite ty + where + can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool + can_rewrite old_role old_tf old_tf_args + = new_role `eqCanRewrite` old_role && + tcEqTyConApps new_tf new_tf_args old_tf old_tf_args + -- it's possible for old_tf_args to have too many. This is fine; + -- we'll only check what we need to. + + {-# INLINE fr_can_rewrite_ty #-} -- perform the check here only once fr_can_rewrite_ty :: EqRel -> Type -> Bool - fr_can_rewrite_ty role ty = anyRewritableTyVar False role - fr_can_rewrite_tv ty - fr_can_rewrite_tv :: EqRel -> TyVar -> Bool - fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role - && tv == new_tv + fr_can_rewrite_ty = case new_lhs of + TyVarLHS new_tv -> fr_tv_can_rewrite_ty new_tv + 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 -- Can the new item rewrite the inert item? + {-# INLINE kick_out_ct #-} -- perform case on new_lhs here only once kick_out_ct :: Ct -> Bool - -- Kick it out if the new CTyEqCan can rewrite the inert one + -- Kick it out if the new CEqCan can rewrite the inert one -- See Note [kickOutRewritable] - kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct - = fr_may_rewrite fs - && fr_can_rewrite_ty role (ctPred ct) - -- False: ignore casts and coercions - -- NB: this includes the fsk of a CFunEqCan. It can't - -- actually be rewritten, but we need to kick it out - -- so we get to take advantage of injectivity - -- See Note [Kicking out CFunEqCan for fundeps] - - kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList) - -> ([Ct], DTyVarEnv EqualCtList) - kick_out_eqs eqs (acc_out, acc_in) - = (eqs_out ++ acc_out, case eqs_in of - [] -> acc_in - (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in) + kick_out_ct = case new_lhs of + TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in + fr_may_rewrite fs + && fr_tv_can_rewrite_ty new_tv role (ctPred ct) + TyFamLHS new_tf new_tf_args + -> \ct -> let fs@(_, role) = ctFlavourRole ct in + 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 eqs + (eqs_out, eqs_in) = partition kick_out_eq (equalCtListToList eqs) -- Implements criteria K1-K3 in Note [Extending the inert equalities] - kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty - , cc_ev = ev, cc_eq_rel = eq_rel }) + kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty + , cc_ev = ev, cc_eq_rel = eq_rel }) | not (fr_may_rewrite fs) = False -- Keep it in the inert set if the new thing can't rewrite it -- Below here (fr_may_rewrite fs) is True - | tv == new_tv = True -- (K1) + | fr_can_rewrite_ty eq_rel (canEqLHSType lhs) = True -- (K1) + -- The above check redundantly checks the role & flavour, + -- but it's very convenient + | kick_out_for_inertness = True | kick_out_for_completeness = True | otherwise = False @@ -1809,27 +1743,48 @@ kick_out_rewritable new_fr new_tv && fr_can_rewrite_ty eq_rel rhs_ty -- (K2d) -- (K2c) is guaranteed by the first guard of keep_eq - kick_out_for_completeness + kick_out_for_completeness -- (K3) and Note [K3: completeness of solving] = case eq_rel of - NomEq -> rhs_ty `eqType` mkTyVarTy new_tv - ReprEq -> isTyVarHead new_tv rhs_ty + 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) + is_can_eq_lhs_head (TyVarLHS tv) = go + where + go (Rep.TyVarTy tv') = tv == tv' + go (Rep.AppTy fun _) = go fun + go (Rep.CastTy ty _) = go ty + go (Rep.TyConApp {}) = False + go (Rep.LitTy {}) = False + go (Rep.ForAllTy {}) = False + go (Rep.FunTy {}) = False + go (Rep.CoercionTy {}) = False + is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go + where + go (Rep.TyVarTy {}) = False + go (Rep.AppTy {}) = False -- no TyConApp to the left of an AppTy + go (Rep.CastTy ty _) = go ty + go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args + go (Rep.LitTy {}) = False + go (Rep.ForAllTy {}) = False + go (Rep.FunTy {}) = False + go (Rep.CoercionTy {}) = False + kickOutAfterUnification :: TcTyVar -> TcS Int kickOutAfterUnification new_tv = do { ics <- getInertCans ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq) - new_tv ics + (TyVarLHS new_tv) ics -- Given because the tv := xi is given; NomEq because -- only nominal equalities are solved by unification ; setInertCans ics2 ; return n_kicked } --- See Wrinkle (2b) in Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" -kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () -kickOutAfterFillingCoercionHole hole +-- See Wrinkle (2a) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical +kickOutAfterFillingCoercionHole :: CoercionHole -> Coercion -> TcS () +kickOutAfterFillingCoercionHole hole filled_co = do { ics <- getInertCans ; let (kicked_out, ics') = kick_out ics n_kicked = workListSize kicked_out @@ -1844,44 +1799,50 @@ kickOutAfterFillingCoercionHole hole ; setInertCans ics' } where + holes_of_co = coercionHolesOfCo filled_co + kick_out :: InertCans -> (WorkList, InertCans) kick_out ics@(IC { inert_irreds = irreds }) - = let (to_kick, to_keep) = partitionBag kick_ct irreds + = let (to_kick, to_keep) = partitionBagWith kick_ct irreds kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList ics' = ics { inert_irreds = to_keep } in (kicked_out, ics') - kick_ct :: Ct -> Bool - -- This is not particularly efficient. Ways to do better: - -- 1) Have a custom function that looks for a coercion hole and returns a Bool - -- 2) Keep co-hole-blocked constraints in a separate part of the inert set, - -- keyed by their co-hole. (Is it possible for more than one co-hole to be - -- in a constraint? I doubt it.) - kick_ct (CIrredCan { cc_ev = ev, cc_status = BlockedCIS }) - = coHoleCoVar hole `elemVarSet` tyCoVarsOfType (ctEvPred ev) - kick_ct _other = False + 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_status = BlockedCIS holes }) + | hole `elementOfUniqSet` holes + = let new_holes = holes `delOneFromUniqSet` hole + `unionUniqSets` holes_of_co + updated_ct = ct { cc_status = BlockedCIS new_holes } + in + if isEmptyUniqSet new_holes + then Left updated_ct + else Right updated_ct + kick_ct other = Right other {- Note [kickOutRewritable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also Note [inert_eqs: the inert equalities]. -When we add a new inert equality (a ~N ty) to the inert set, +When we add a new inert equality (lhs ~N ty) to the inert set, we must kick out any inert items that could be rewritten by the new equality, to maintain the inert-set invariants. - We want to kick out an existing inert constraint if a) the new constraint can rewrite the inert one - b) 'a' is free in the inert constraint (so that it *will*) + b) 'lhs' is free in the inert constraint (so that it *will*) rewrite it if we kick it out. - For (b) we use tyCoVarsOfCt, which returns the type variables /and - the kind variables/ that are directly visible in the type. Hence + For (b) we use anyRewritableCanLHS, which examines the types /and + kinds/ that are directly visible in the type. Hence we will have exposed all the rewriting we care about to make the most precise kinds visible for matching classes etc. No need to kick out constraints that mention type variables whose kinds - contain this variable! + contain this LHS! - A Derived equality can kick out [D] constraints in inert_eqs, inert_dicts, inert_irreds etc. @@ -1999,11 +1960,6 @@ updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS () updInertSafehask upd_fn = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) } -updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertFunEqs upd_fn - = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) } - updInertIrreds :: (Cts -> Cts) -> TcS () -- Modify the inert set with the supplied function updInertIrreds upd_fn @@ -2019,13 +1975,13 @@ getInertInsols = do { inert <- getInertCans ; return (filterBag insolubleEqCt (inert_irreds inert)) } getInertGivens :: TcS [Ct] --- Returns the Given constraints in the inert set, --- with type functions *not* unflattened +-- Returns the Given constraints in the inert set getInertGivens = do { inerts <- getInertCans ; let all_cts = foldDicts (:) (inert_dicts inerts) - $ foldFunEqs (:) (inert_funeqs inerts) - $ concat (dVarEnvElts (inert_eqs inerts)) + $ foldFunEqs (\ecl out -> equalCtListToList ecl ++ out) + (inert_funeqs inerts) + $ concatMap equalCtListToList (dVarEnvElts (inert_eqs inerts)) ; return (filter isGivenCt all_cts) } getPendingGivenScs :: TcS [Ct] @@ -2077,9 +2033,7 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts }) -- Note [The superclass story] in GHC.Tc.Solver.Canonical getUnsolvedInerts :: TcS ( Bag Implication - , Cts -- Tyvar eqs: a ~ ty - , Cts -- Fun eqs: F a ~ ty - , Cts ) -- All others + , Cts ) -- All simple constraints -- Return all the unsolved [Wanted] or [Derived] constraints -- -- Post-condition: the returned simple constraints are all fully zonked @@ -2093,7 +2047,7 @@ getUnsolvedInerts } <- getInertCans ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts - unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts + unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts unsolved_irreds = Bag.filterBag is_unsolved irreds unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts unsolved_others = unsolved_irreds `unionBags` unsolved_dicts @@ -2106,78 +2060,80 @@ getUnsolvedInerts , text "others =" <+> ppr unsolved_others , text "implics =" <+> ppr implics ] - ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) } + ; return ( implics, unsolved_tv_eqs `unionBags` + unsolved_fun_eqs `unionBags` + unsolved_others) } where add_if_unsolved :: Ct -> Cts -> Cts add_if_unsolved ct cts | is_unsolved 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 - -- For CFunEqCans we ignore the Derived ones, and keep - -- only the Wanteds for flattening. The Derived ones - -- share a unification variable with the corresponding - -- Wanted, so we definitely don't want to participate - -- in unflattening - -- See Note [Type family equations] - add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts - | otherwise = cts - -isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool --- True if (a ~N ty) is in the inert set, in either Given or Wanted -isInInertEqs eqs tv rhs - = case lookupDVarEnv eqs tv of - Nothing -> False - Just cts -> any (same_pred rhs) cts - where - same_pred rhs ct - | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct - , NomEq <- eq_rel - , rhs `eqType` rhs2 = True - | otherwise = False - -getNoGivenEqs :: TcLevel -- TcLevel of this implication - -> [TcTyVar] -- Skolems of this implication - -> TcS ( Bool -- True <=> definitely no residual given equalities - , Cts ) -- Insoluble equalities arising from givens +getHasGivenEqs :: TcLevel -- TcLevel of this implication + -> TcS ( HasGivenEqs -- are there Given equalities? + , Cts ) -- Insoluble equalities arising from givens -- See Note [When does an implication have given equalities?] -getNoGivenEqs tclvl skol_tvs - = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds }) +getHasGivenEqs tclvl + = do { inerts@(IC { inert_eqs = ieqs, inert_funeqs = funeqs, inert_irreds = irreds }) <- getInertCans - ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds - || anyDVarEnv eqs_given_here ieqs + ; let has_given_eqs = foldMap check_local_given_ct irreds + S.<> foldMap (lift_equal_ct_list check_local_given_tv_eq) ieqs + S.<> foldMapFunEqs (lift_equal_ct_list check_local_given_ct) funeqs insols = filterBag insolubleEqCt irreds -- Specifically includes ones that originated in some -- outer context but were refined to an insoluble by -- a local equality; so do /not/ add ct_given_here. - ; traceTcS "getNoGivenEqs" $ - vcat [ if has_given_eqs then text "May have given equalities" - else text "No given equalities" - , text "Skols:" <+> ppr skol_tvs + ; traceTcS "getHasGivenEqs" $ + vcat [ text "has_given_eqs:" <+> ppr has_given_eqs , text "Inerts:" <+> ppr inerts , text "Insols:" <+> ppr insols] - ; return (not has_given_eqs, insols) } + ; return (has_given_eqs, insols) } where - eqs_given_here :: EqualCtList -> Bool - eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })] - -- Givens are always a singleton - = not (skolem_bound_here tv) && ct_given_here ct - eqs_given_here _ = False + check_local_given_ct :: Ct -> HasGivenEqs + check_local_given_ct ct + | given_here ev = if mentions_outer_var ev then MaybeGivenEqs else LocalGivenEqs + | otherwise = NoGivenEqs + where + ev = ctEvidence ct + + lift_equal_ct_list :: (Ct -> HasGivenEqs) -> EqualCtList -> HasGivenEqs + -- returns NoGivenEqs for non-singleton lists, as Given lists are always + -- singletons + lift_equal_ct_list check (EqualCtList (ct :| [])) = check ct + lift_equal_ct_list _ _ = NoGivenEqs + + check_local_given_tv_eq :: Ct -> HasGivenEqs + check_local_given_tv_eq (CEqCan { cc_lhs = TyVarLHS tv, cc_ev = ev}) + | given_here ev + = if is_outer_var tv then MaybeGivenEqs else NoGivenEqs + -- See Note [Let-bound skolems] + | otherwise + = NoGivenEqs + check_local_given_tv_eq other_ct = check_local_given_ct other_ct - ct_given_here :: Ct -> Bool + given_here :: CtEvidence -> Bool -- True for a Given bound by the current implication, -- i.e. the current level - ct_given_here ct = isGiven ev - && tclvl == ctLocLevel (ctEvLoc ev) - where - ev = ctEvidence ct + given_here ev = isGiven ev + && tclvl == ctLocLevel (ctEvLoc ev) + + mentions_outer_var :: CtEvidence -> Bool + mentions_outer_var = anyFreeVarsOfType is_outer_var . ctEvPred - skol_tv_set = mkVarSet skol_tvs - skolem_bound_here tv -- See Note [Let-bound skolems] - = case tcTyVarDetails tv of - SkolemTv {} -> tv `elemVarSet` skol_tv_set - _ -> False + is_outer_var :: TyCoVar -> Bool + is_outer_var tv + -- NB: a meta-tv alpha[3] may end up unifying with skolem b[2], + -- so treat it as an "outer" var, even at level 3. + -- This will become redundant after fixing #18929. + | isTyVar tv = isTouchableMetaTyVar tclvl tv || + tclvl `strictlyDeeperThan` tcTyVarLevel tv + | otherwise = False -- | Returns Given constraints that might, -- potentially, match the given pred. This is used when checking to see if a @@ -2208,10 +2164,26 @@ matchableGivens loc_w pred_w (IS { inert_cans = inert_cans }) = False mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool +-- See Note [What might match later?] mightMatchLater given_pred given_loc wanted_pred wanted_loc - = not (prohibitedSuperClassSolve given_loc wanted_loc) - && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred]) + | prohibitedSuperClassSolve given_loc wanted_loc + = False + + | SurelyApart <- tcUnifyTysFG bind_meta_tv [flattened_given] [flattened_wanted] + = False + + | otherwise + = True -- safe answer where + in_scope = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred] + + -- NB: flatten both at the same time, so that we can share mappings + -- from type family applications to variables, and also to guarantee + -- that the fresh variables are really fresh between the given and + -- the wanted. + ([flattened_given, flattened_wanted], var_mapping) + = flattenTysX in_scope [given_pred, wanted_pred] + bind_meta_tv :: TcTyVar -> BindFlag -- Any meta tyvar may be unified later, so we treat it as -- bindable when unifying with givens. That ensures that we @@ -2219,9 +2191,17 @@ mightMatchLater given_pred given_loc wanted_pred wanted_loc -- something that matches the 'given', until demonstrated -- otherwise. More info in Note [Instance and Given overlap] -- in GHC.Tc.Solver.Interact - bind_meta_tv tv | isMetaTyVar tv - , not (isFskTyVar tv) = BindMe - | otherwise = Skolem + bind_meta_tv tv | is_meta_tv tv = BindMe + + | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv + , anyFreeVarsOfTypes is_meta_tv fam_args + = BindMe + + | otherwise = Skolem + + -- CycleBreakerTvs really stands for a type family application in + -- a given; these won't contain touchable meta-variables + is_meta_tv = isMetaTyVar <&&> not . isCycleBreakerTyVar prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance @@ -2239,6 +2219,55 @@ 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 match later?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must determine whether a Given might later match a Wanted. We +definitely need to account for the possibility that any metavariable +in the Wanted might be arbitrarily instantiated. We do *not* want +to allow skolems in the Given to be instantiated. But what about +type family applications? (Examples are below the explanation.) + +To allow flexibility in how type family applications unify we use +the Core flattener. See +Note [Flattening type-family applications when matching instances] in GHC.Core.Unify. +This is *distinct* from the flattener in GHC.Tc.Solver.Flatten. +The Core flattener replaces all type family applications with +fresh variables. The next question: should we allow these fresh +variables in the domain of a unifying substitution? + +A type family application that mentions only skolems is settled: any +skolems would have been rewritten w.r.t. Givens by now. These type +family applications match only themselves. A type family application +that mentions metavariables, on the other hand, can match anything. +So, if the original type family application contains a metavariable, +we use BindMe to tell the unifier to allow it in the substitution. +On the other hand, a type family application with only skolems is +considered rigid. + +Examples: + [G] C a + [W] C alpha + This easily might match later. + + [G] C a + [W] C (F alpha) + This might match later, too, but we need to flatten the (F alpha) + to a fresh variable so that the unifier can connect the two. + + [G] C (F alpha) + [W] C a + This also might match later. Again, we will need to flatten to + find this out. (Surprised about a metavariable in a Given? See + #18929.) + + [G] C (F a) + [W] C a + This won't match later. We're not going to get new Givens that + can inform the F a, and so this is a no-go. + +This treatment fixes #18910 and is tested in +typecheck/should_compile/InstanceGivenOverlap{,2} + Note [When does an implication have given equalities?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider an implication @@ -2269,22 +2298,39 @@ are some wrinkles: beta => ...blah... If we still don't know what beta is, we conservatively treat it as potentially becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs. + Note that we can't really know what's in an irred, so any irred is considered + a potential equality. + + * What about something like forall a b. a ~ F b => [W] c ~ X y z? That Given + cannot affect the Wanted, because the Given is entirely *local*: it mentions + only skolems bound in the very same implication. Such equalities need not + prevent floating. (Test case typecheck/should_compile/LocalGivenEqs has a + real-life motivating example, with some detailed commentary.) These + equalities are noted with LocalGivenEqs: they do not prevent floating, but + they also are allowed to show up in error messages. See + Note [Suppress redundant givens during error reporting] in GHC.Tc.Errors. + The difference between what stops floating and what is suppressed from + error messages is why we need three options for HasGivenEqs. + + There is also a simpler case that triggers this behaviour: + + data T where + MkT :: F a ~ G b => a -> b -> T - * When flattening givens, we generate Given equalities like - <F [a]> : F [a] ~ f, - with Refl evidence, and we *don't* want those to count as an equality - in the givens! After all, the entire flattening business is just an - internal matter, and the evidence does not mention any of the 'givens' - of this implication. So we do not treat inert_funeqs as a 'given equality'. + f (MkT _ _) = True + + Because of this behaviour around local equality givens, we can infer the + type of f. This is typecheck/should_compile/LocalGivenEqs2. * See Note [Let-bound skolems] for another wrinkle - * We do *not* need to worry about representational equalities, because - these do not affect the ability to float constraints. + * We need not look at the equality relation involved (nominal vs representational), + because representational equalities can still imply nominal ones. For example, + if (G a ~R G b) and G's argument's role is nominal, then we can deduce a ~N b. Note [Let-bound skolems] ~~~~~~~~~~~~~~~~~~~~~~~~ -If * the inert set contains a canonical Given CTyEqCan (a ~ ty) +If * the inert set contains a canonical Given CEqCan (a ~ ty) and * 'a' is a skolem bound in this very implication, then: @@ -2296,8 +2342,7 @@ a) The Given is pretty much a let-binding, like and hence can be ignored by has_given_eqs b) 'a' will have been completely substituted out in the inert set, - so we can safely discard it. Notably, it doesn't need to be - returned as part of 'fsks' + so we can safely discard it. For an example, see #9211. @@ -2343,32 +2388,25 @@ removeInertCt is ct = CDictCan { cc_class = cl, cc_tyargs = tys } -> is { inert_dicts = delDict (inert_dicts is) cl tys } - CFunEqCan { cc_fun = tf, cc_tyargs = tys } -> - is { inert_funeqs = delFunEq (inert_funeqs is) tf tys } - - CTyEqCan { cc_tyvar = x, cc_rhs = ty } -> - is { inert_eqs = delTyEq (inert_eqs is) x ty } + CEqCan { cc_lhs = lhs, cc_rhs = rhs } -> delEq is lhs rhs CQuantCan {} -> panic "removeInertCt: CQuantCan" CIrredCan {} -> panic "removeInertCt: CIrredEvCan" CNonCanonical {} -> panic "removeInertCt: CNonCanonical" -lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour)) -lookupFlatCache fam_tc tys - = do { IS { inert_flat_cache = flat_cache - , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts - ; return (firstJusts [lookup_inerts inert_funeqs, - lookup_flats flat_cache]) } +-- | Looks up a family application in the inerts; returned coercion +-- is oriented input ~ output +lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavourRole)) +lookupFamAppInert fam_tc tys + = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts + ; return (lookup_inerts inert_funeqs) } where lookup_inerts inert_funeqs - | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk }) - <- findFunEq inert_funeqs fam_tc tys - = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev) + | Just (EqualCtList (CEqCan { cc_ev = ctev, cc_rhs = rhs } :| _)) + <- findFunEq inert_funeqs fam_tc tys + = Just (ctEvCoercion ctev, rhs, ctEvFlavourRole ctev) | otherwise = Nothing - lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys - - lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) -- Is this exact predicate type cached in the solved or canonicals of the InertSet? lookupInInerts loc pty @@ -2394,6 +2432,40 @@ lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys Just ev -> Just ev _ -> Nothing +--------------------------- +lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType)) +lookupFamAppCache fam_tc tys + = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts + ; case findFunEq famapp_cache fam_tc tys of + result@(Just (co, ty)) -> + do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys) + , ppr ty + , ppr co ]) + ; return result } + Nothing -> return Nothing } + +extendFamAppCache :: TyCon -> [Type] -> (TcCoercion, TcType) -> TcS () +-- NB: co :: rhs ~ F tys, to match expectations of flattener +extendFamAppCache tc xi_args stuff@(_, ty) + = do { dflags <- getDynFlags + ; 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 } } } + +-- Remove entries from the cache whose evidence mentions variables in the +-- supplied set +dropFromFamAppCache :: VarSet -> TcS () +dropFromFamAppCache varset + = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts + ; let filtered = filterTcAppMap check famapp_cache + ; setTcSInerts $ inerts { inert_famapp_cache = filtered } } + where + check :: (TcCoercion, TcType) -> Bool + check (co, _) = not (anyFreeVarsOfCo (`elemVarSet` varset) co) + {- ********************************************************************* * * Irreds @@ -2413,7 +2485,7 @@ foldIrreds k irreds z = foldr k z irreds Note [Use loose types in inert set] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Whenever we are looking up an inert dictionary (CDictCan) or function -equality (CFunEqCan), we use a TcAppMap, which uses the Unique of the +equality (CEqCan), we use a TcAppMap, which uses the Unique of the class/type family tycon and then a trie which maps the arguments. This trie does *not* need to match the kinds of the arguments; this Note explains why. @@ -2433,54 +2505,56 @@ looking at kinds would be harmless. -} -type TcAppMap a = UniqDFM Unique (ListMap LooseTypeMap a) +type TcAppMap a = DTyConEnv (ListMap LooseTypeMap a) -- Indexed by tycon then the arg types, using "loose" matching, where -- we don't require kind equality. This allows, for example, (a |> co) -- to match (a). -- See Note [Use loose types in inert set] -- Used for types and classes; hence UniqDFM - -- See Note [foldTM determinism] for why we use UniqDFM here + -- See Note [foldTM determinism] in GHC.Data.TrieMap for why we use DTyConEnv here isEmptyTcAppMap :: TcAppMap a -> Bool -isEmptyTcAppMap m = isNullUDFM m +isEmptyTcAppMap m = isEmptyDTyConEnv m emptyTcAppMap :: TcAppMap a -emptyTcAppMap = emptyUDFM +emptyTcAppMap = emptyDTyConEnv -findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a -findTcApp m u tys = do { tys_map <- lookupUDFM m u - ; lookupTM tys tys_map } +findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a +findTcApp m tc tys = do { tys_map <- lookupDTyConEnv m tc + ; lookupTM tys tys_map } -delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a -delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls +delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a +delTcApp m tc tys = adjustDTyConEnv (deleteTM tys) m tc -insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a -insertTcApp m cls tys ct = alterUDFM alter_tm m cls +insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a +insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc where alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) --- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b --- mapTcApp f = mapUDFM (mapTM f) +alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> (Maybe a -> Maybe a) -> TcAppMap a +alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc + where + alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a) + alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM)) -filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct -filterTcAppMap f m - = mapUDFM do_tm m +filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a +filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m where - do_tm tm = foldTM insert_mb tm emptyTM - insert_mb ct tm - | f ct = insertTM tys ct tm - | otherwise = tm - where - tys = case ct of - CFunEqCan { cc_tyargs = tys } -> tys - CDictCan { cc_tyargs = tys } -> tys - _ -> pprPanic "filterTcAppMap" (ppr ct) + one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a) + one_tycon tm + | isEmptyTM filtered_tm = Nothing + | otherwise = Just filtered_tm + where + filtered_tm = filterTM f tm tcAppMapToBag :: TcAppMap a -> Bag a tcAppMapToBag m = foldTcAppMap consBag m emptyBag foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b -foldTcAppMap k m z = foldUDFM (foldTM k) z m +foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m + +foldMapTcAppMap :: Monoid m => (a -> m) -> TcAppMap a -> m +foldMapTcAppMap f = foldMap (foldMap f) {- ********************************************************************* @@ -2547,22 +2621,22 @@ findDict m loc cls tys = Nothing -- See Note [Solving CallStack constraints] | otherwise - = findTcApp m (getUnique cls) tys + = findTcApp m (classTyCon cls) tys findDictsByClass :: DictMap a -> Class -> Bag a findDictsByClass m cls - | Just tm <- lookupUDFM_Directly m (getUnique cls) = foldTM consBag tm emptyBag - | otherwise = emptyBag + | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag + | otherwise = emptyBag delDict :: DictMap a -> Class -> [Type] -> DictMap a -delDict m cls tys = delTcApp m (getUnique cls) tys +delDict m cls tys = delTcApp m (classTyCon cls) tys addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a -addDict m cls tys item = insertTcApp m (getUnique cls) tys item +addDict m cls tys item = insertTcApp m (classTyCon cls) tys item addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct addDictsByClass m cls items - = addToUDFM_Directly m (getUnique cls) (foldr add emptyTM items) + = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items) where add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm add ct _ = pprPanic "addDictsByClass" (ppr ct) @@ -2601,10 +2675,7 @@ emptyFunEqs :: TcAppMap a emptyFunEqs = emptyTcAppMap findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a -findFunEq m tc tys = findTcApp m (getUnique tc) tys - -funEqsToBag :: FunEqMap a -> Bag a -funEqsToBag m = foldTcAppMap consBag m emptyBag +findFunEq m tc tys = findTcApp m tc tys findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] -- Get inert function equation constraints that have the given tycon @@ -2612,50 +2683,17 @@ findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] -- We use this to check for derived interactions with built-in type-function -- constructors. findFunEqsByTyCon m tc - | Just tm <- lookupUDFM m (getUnique tc) = foldTM (:) tm [] - | otherwise = [] + | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm [] + | otherwise = [] foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b foldFunEqs = foldTcAppMap --- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b --- mapFunEqs = mapTcApp - --- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct --- filterFunEqs = filterTcAppMap +foldMapFunEqs :: Monoid m => (a -> m) -> FunEqMap a -> m +foldMapFunEqs = foldMapTcAppMap insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a -insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val - -partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct) --- Optimise for the case where the predicate is false --- partitionFunEqs is called only from kick-out, and kick-out usually --- kicks out very few equalities, so we want to optimise for that case -partitionFunEqs f m = (yeses, foldr del m yeses) - where - yeses = foldTcAppMap k m [] - k ct yeses | f ct = ct : yeses - | otherwise = yeses - del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m - = delFunEq m tc tys - del ct _ = pprPanic "partitionFunEqs" (ppr ct) - -delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a -delFunEq m tc tys = delTcApp m (getUnique tc) tys - ------------------------------- -type ExactFunEqMap a = TyConEnv (ListMap TypeMap a) - -emptyExactFunEqs :: ExactFunEqMap a -emptyExactFunEqs = emptyUFM - -findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a -findExactFunEq m tc tys = do { tys_map <- lookupUFM m tc - ; lookupTM tys tys_map } - -insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a -insertExactFunEq m tc tys val = alterUFM alter_tm m tc - where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM)) +insertFunEq m tc tys val = insertTcApp m tc tys val {- ************************************************************************ @@ -2691,7 +2729,7 @@ data TcSEnv tcs_inerts :: IORef InertSet, -- Current inert set -- The main work-list and the flattening worklist - -- See Note [Work list priorities] and + -- See Note [WorkList priorities] and tcs_worklist :: IORef WorkList -- Current worklist } @@ -2796,7 +2834,7 @@ runTcS :: TcS a -- What to run -> TcM (a, EvBindMap) runTcS tcs = do { ev_binds_var <- TcM.newTcEvBinds - ; res <- runTcSWithEvBinds ev_binds_var True tcs + ; res <- runTcSWithEvBinds ev_binds_var tcs ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var ; return (res, ev_binds) } -- | This variant of 'runTcS' will keep solving, even when only Deriveds @@ -2805,32 +2843,38 @@ runTcS tcs runTcSDeriveds :: TcS a -> TcM a runTcSDeriveds tcs = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds ev_binds_var True tcs } + ; runTcSWithEvBinds ev_binds_var tcs } -- | This can deal only with equality constraints. runTcSEqualities :: TcS a -> TcM a runTcSEqualities thing_inside = do { ev_binds_var <- TcM.newNoTcEvBinds - ; runTcSWithEvBinds ev_binds_var True thing_inside } + ; runTcSWithEvBinds ev_binds_var thing_inside } -- | A variant of 'runTcS' that takes and returns an 'InertSet' for --- later resumption of the 'TcS' session. Crucially, it doesn't --- 'unflattenGivens' when done. +-- later resumption of the 'TcS' session. runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet) runTcSInerts inerts tcs = do ev_binds_var <- TcM.newTcEvBinds - -- Passing False here to prohibit unflattening - runTcSWithEvBinds ev_binds_var False $ do + runTcSWithEvBinds' False ev_binds_var $ do setTcSInerts inerts a <- tcs new_inerts <- getTcSInerts return (a, new_inerts) runTcSWithEvBinds :: EvBindsVar - -> Bool -- ^ Unflatten types afterwards? Don't if you want to reuse the InertSet. -> TcS a -> TcM a -runTcSWithEvBinds ev_binds_var unflatten tcs +runTcSWithEvBinds = runTcSWithEvBinds' True + +runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards? + -- Don't if you want to reuse the InertSet. + -- See also Note [Type variable cycles in Givens] + -- in GHC.Tc.Solver.Canonical + -> EvBindsVar + -> TcS a + -> TcM a +runTcSWithEvBinds' restore_cycles ev_binds_var tcs = do { unified_var <- TcM.newTcRef 0 ; step_count <- TcM.newTcRef 0 ; inert_var <- TcM.newTcRef emptyInert @@ -2848,7 +2892,9 @@ runTcSWithEvBinds ev_binds_var unflatten tcs ; when (count > 0) $ csTraceTcM $ return (text "Constraint solver steps =" <+> int count) - ; when unflatten $ unflattenGivens inert_var + ; when restore_cycles $ + do { inert_set <- TcM.readTcRef inert_var + ; restoreTyVarCycles inert_set } #if defined(DEBUG) ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var @@ -2899,10 +2945,8 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside) , tcs_count = count } -> do { inerts <- TcM.readTcRef old_inert_var - ; let nest_inert = emptyInert - { inert_cans = inert_cans inerts - , inert_solved_dicts = inert_solved_dicts inerts } - -- See Note [Do not inherit the flat cache] + ; let nest_inert = inerts { inert_cycle_breakers = [] } + -- all other InertSet fields are inherited ; new_inert_var <- TcM.newTcRef nest_inert ; new_wl_var <- TcM.newTcRef emptyWorkList ; let nest_env = TcSEnv { tcs_ev_binds = ref @@ -2913,7 +2957,8 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside) ; res <- TcM.setTcLevel inner_tclvl $ thing_inside nest_env - ; unflattenGivens new_inert_var + ; out_inert_set <- TcM.readTcRef new_inert_var + ; restoreTyVarCycles out_inert_set #if defined(DEBUG) -- Perform a check that the thing_inside did not cause cycles @@ -2922,22 +2967,10 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside) #endif ; return res } -{- Note [Do not inherit the flat cache] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to inherit the flat cache when processing nested -implications. Consider - a ~ F b, forall c. b~Int => blah -If we have F b ~ fsk in the flat-cache, and we push that into the -nested implication, we might miss that F b can be rewritten to F Int, -and hence perhaps solve it. Moreover, the fsk from outside is -flattened out after solving the outer level, but and we don't -do that flattening recursively. --} - nestTcS :: TcS a -> TcS a -- Use the current untouchables, augmenting the current -- evidence bindings, and solved dictionaries --- But have no effect on the InertCans, or on the inert_flat_cache +-- But have no effect on the InertCans, or on the inert_famapp_cache -- (we want to inherit the latter from processing the Givens) nestTcS (TcS thing_inside) = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> @@ -3224,143 +3257,7 @@ zonkWC wc = wrapTcS (TcM.zonkWC wc) zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv) -{- ********************************************************************* -* * -* Flatten skolems * -* * -********************************************************************* -} - -newFlattenSkolem :: CtFlavour -> CtLoc - -> TyCon -> [TcType] -- F xis - -> TcS (CtEvidence, Coercion, TcTyVar) -- [G/WD] x:: F xis ~ fsk -newFlattenSkolem flav loc tc xis - = do { stuff@(ev, co, fsk) <- new_skolem - ; let fsk_ty = mkTyVarTy fsk - ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev) - ; return stuff } - where - fam_ty = mkTyConApp tc xis - - new_skolem - | Given <- flav - = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty) - - -- Extend the inert_fsks list, for use by unflattenGivens - ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is } - - -- Construct the Refl evidence - ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk) - co = mkNomReflCo fam_ty - ; ev <- newGivenEvVar loc (pred, evCoercion co) - ; return (ev, co, fsk) } - - | otherwise -- Generate a [WD] for both Wanted and Derived - -- See Note [No Derived CFunEqCans] - = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty) - -- See (2a) in "GHC.Tc.Solver.Canonical" - -- Note [Equalities with incompatible kinds] - ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc Nominal - fam_ty (mkTyVarTy fmv) - ; return (ev, hole_co, fmv) } - ----------------------------- -unflattenGivens :: IORef InertSet -> TcM () --- Unflatten all the fsks created by flattening types in Given --- constraints. We must be sure to do this, else we end up with --- flatten-skolems buried in any residual Wanteds --- --- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv) --- is filled in. Nothing else does so. --- --- It's here (rather than in GHC.Tc.Solver.Flatten) because the Right Places --- to call it are in runTcSWithEvBinds/nestImplicTcS, where it --- is nicely paired with the creation an empty inert_fsks list. -unflattenGivens inert_var - = do { inerts <- TcM.readTcRef inert_var - ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts)) - ; mapM_ flatten_one (inert_fsks inerts) } - where - flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty - ----------------------------- -extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS () -extendFlatCache tc xi_args stuff@(_, ty, fl) - | isGivenOrWDeriv fl -- Maintain the invariant that inert_flat_cache - -- only has [G] and [WD] CFunEqCans - = do { dflags <- getDynFlags - ; when (gopt Opt_FlatCache dflags) $ - do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args - , ppr fl, ppr ty ]) - -- 'co' can be bottom, in the case of derived items - ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) -> - is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } } - - | otherwise - = return () - ----------------------------- -unflattenFmv :: TcTyVar -> TcType -> TcS () --- Fill a flatten-meta-var, simply by unifying it. --- This does NOT count as a unification in tcs_unified. -unflattenFmv tv ty - = ASSERT2( isMetaTyVar tv, ppr tv ) - TcS $ \ _ -> - do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty) - ; TcM.writeMetaTyVar tv ty } - ---------------------------- -demoteUnfilledFmv :: TcTyVar -> TcS () --- If a flatten-meta-var is still un-filled, --- turn it into an ordinary meta-var -demoteUnfilledFmv fmv - = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv - ; unless is_filled $ - do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv) - ; TcM.writeMetaTyVar fmv tv_ty } } - ------------------------------ -dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS () --- (dischargeFunEq tv co ty) --- Preconditions --- - ev :: F tys ~ tv is a CFunEqCan --- - tv is a FlatMetaTv of FlatSkolTv --- - co :: F tys ~ xi --- - fmv/fsk `notElem` xi --- - fmv not filled (for Wanteds) --- - xi is flattened (and obeys Note [Almost function-free] in GHC.Tc.Types) --- --- Then for [W] or [WD], we actually fill in the fmv: --- set fmv := xi, --- set ev := co --- kick out any inert things that are now rewritable --- --- For [D], we instead emit an equality that must ultimately hold --- [D] xi ~ fmv --- Does not evaluate 'co' if 'ev' is Derived --- --- For [G], emit this equality --- [G] (sym ev; co) :: fsk ~ xi - --- See GHC.Tc.Solver.Flatten Note [The flattening story], --- especially "Ownership of fsk/fmv" -dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi - = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co ) - ; emitWorkNC [new_ev] } - where - new_pred = mkPrimEqPred (mkTyVarTy fsk) xi - new_co = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co - -dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi - = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi ) - do { setWantedEvTerm dest (evCoercion co) - ; unflattenFmv fmv xi - ; n_kicked <- kickOutAfterUnification fmv - ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) } - -dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi - = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv) - -- FunEqs are always at Nominal role - pprKicked :: Int -> SDoc pprKicked 0 = empty pprKicked n = parens (int n <+> text "kicked out") @@ -3486,7 +3383,7 @@ Yuk! fillCoercionHole :: CoercionHole -> Coercion -> TcS () fillCoercionHole hole co = do { wrapTcS $ TcM.fillCoercionHole hole co - ; kickOutAfterFillingCoercionHole hole } + ; kickOutAfterFillingCoercionHole hole co } setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () setEvBindIfWanted ev tm @@ -3533,13 +3430,13 @@ emitNewWantedEq loc role ty1 ty2 -- | Make a new equality CtEvidence newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion) -newWantedEq = newWantedEq_SI YesBlockSubst WDeriv +newWantedEq = newWantedEq_SI WDeriv -newWantedEq_SI :: BlockSubstFlag -> ShadowInfo -> CtLoc -> Role +newWantedEq_SI :: ShadowInfo -> CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion) -newWantedEq_SI blocker si loc role ty1 ty2 - = do { hole <- wrapTcS $ TcM.newCoercionHole blocker pty +newWantedEq_SI si loc 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 @@ -3585,7 +3482,7 @@ newWanted = newWanted_SI WDeriv newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew newWanted_SI si loc pty | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = Fresh . fst <$> newWantedEq_SI YesBlockSubst si loc role ty1 ty2 + = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2 | otherwise = newWantedEvVar_SI si loc pty @@ -3632,8 +3529,8 @@ checkReductionDepth loc ty solverDepthErrorTcS loc ty } matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType)) --- Given (F tys) return (ty, co), where co :: F tys ~N ty -matchFam tycon args = wrapTcS $ matchFamTcM tycon args +-- Given (F tys) return (ty, co), where co :: ty ~N F tys +matchFam tycon args = fmap (fmap (first mkTcSymCo)) $ wrapTcS $ matchFamTcM tycon args matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType)) -- Given (F tys) return (ty, co), where co :: F tys ~N ty @@ -3662,3 +3559,71 @@ from which we get the implication (forall a. t1 ~ t2) See GHC.Tc.Solver.Monad.deferTcSForAllEq -} + +{- +************************************************************************ +* * + Breaking type variable cycles +* * +************************************************************************ +-} + +-- | Replace all type family applications in the RHS with fresh variables, +-- emitting givens that relate the type family application to the variable. +-- See Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical. +breakTyVarCycle :: CtLoc + -> TcType -- the RHS + -> TcS TcType -- new RHS that doesn't have any type families +-- This could be considerably more efficient. See Detail (5) of Note. +breakTyVarCycle loc = go + where + go ty | Just ty' <- flattenView ty = go ty' + go (Rep.TyConApp tc tys) + | isTypeFamilyTyCon tc + = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys + fun_app = mkTyConApp tc fun_args + fun_app_kind = tcTypeKind fun_app + ; new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind) + ; let new_ty = mkTyVarTy new_tv + given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind + fun_app new_ty + given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note + ; new_given <- newGivenEvVar loc (given_pred, given_term) + ; traceTcS "breakTyVarCycle replacing type family" (ppr new_given) + ; emitWorkNC [new_given] + ; updInertTcS $ \is -> + is { inert_cycle_breakers = (new_tv, fun_app) : + inert_cycle_breakers is } + ; extra_args' <- mapM go extra_args + ; return (mkAppTys new_ty extra_args') } + -- Worried that this substitution will change kinds? + -- See Detail (3) of Note + + | otherwise + = mkTyConApp tc <$> mapM go tys + + go (Rep.AppTy ty1 ty2) = mkAppTy <$> go ty1 <*> go ty2 + go (Rep.FunTy vis w arg res) = mkFunTy vis <$> go w <*> go arg <*> go res + go (Rep.CastTy ty co) = mkCastTy <$> go ty <*> pure co + + go ty@(Rep.TyVarTy {}) = return ty + go ty@(Rep.LitTy {}) = return ty + go ty@(Rep.ForAllTy {}) = return ty -- See Detail (1) of Note + go ty@(Rep.CoercionTy {}) = return ty -- See Detail (2) of Note + +-- | Fill in CycleBreakerTvs with the variables they stand for. +-- See Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical. +restoreTyVarCycles :: InertSet -> TcM () +restoreTyVarCycles is + = forM_ (inert_cycle_breakers is) $ \ (cycle_breaker_tv, orig_ty) -> + TcM.writeMetaTyVar cycle_breaker_tv orig_ty + +-- Unwrap a type synonym only when either: +-- The type synonym is forgetful, or +-- the type synonym mentions a type family in its expansion +-- See Note [Flattening synonyms] in GHC.Tc.Solver.Flatten. +flattenView :: TcType -> Maybe TcType +flattenView ty@(Rep.TyConApp tc _) + | isForgetfulSynTyCon tc || (isTypeSynonymTyCon tc && not (isFamFreeTyCon tc)) + = tcView ty +flattenView _other = Nothing diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs index 308569ace0..05fd70c674 100644 --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, MultiWayIf #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -9,12 +9,12 @@ module GHC.Tc.Types.Constraint ( QCInst(..), isPendingScInst, -- Canonical constraints - Xi, Ct(..), Cts, CtIrredStatus(..), emptyCts, andCts, andManyCts, pprCts, + Xi, Ct(..), Cts, CtIrredStatus(..), HoleSet, + emptyCts, andCts, andManyCts, pprCts, singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, - isEmptyCts, isCTyEqCan, isCFunEqCan, + isEmptyCts, isPendingScDict, superClassesMightHelp, getPendingWantedScs, - isCDictCan_Maybe, isCFunEqCan_maybe, - isCNonCanonical, isWantedCt, isDerivedCt, isGivenCt, + isWantedCt, isDerivedCt, isGivenCt, isUserTypeErrorCt, getUserTypeErrorMsg, ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, ctEvId, mkTcEqPredLikeEv, @@ -25,6 +25,9 @@ module GHC.Tc.Types.Constraint ( tyCoVarsOfCt, tyCoVarsOfCts, tyCoVarsOfCtList, tyCoVarsOfCtsList, + CanEqLHS(..), canEqLHS_maybe, canEqLHSKind, canEqLHSType, + eqCanEqLHS, + Hole(..), HoleSort(..), isOutOfScopeHole, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, @@ -37,6 +40,7 @@ module GHC.Tc.Types.Constraint ( Implication(..), implicationPrototype, checkTelescopeSkol, ImplicStatus(..), isInsolubleStatus, isSolvedStatus, + HasGivenEqs(..), SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, bumpSubGoalDepth, subGoalDepthExceeded, CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, @@ -48,7 +52,7 @@ module GHC.Tc.Types.Constraint ( -- CtEvidence CtEvidence(..), TcEvDest(..), mkKindLoc, toKindLoc, mkGivenLoc, - isWanted, isGiven, isDerived, isGivenOrWDeriv, + isWanted, isGiven, isDerived, ctEvRole, wrapType, @@ -57,7 +61,6 @@ module GHC.Tc.Types.Constraint ( CtFlavourRole, ctEvFlavourRole, ctFlavourRole, eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR, eqCanDischargeFR, - funEqCanDischarge, funEqCanDischargeF, -- Pretty printing pprEvVarTheta, @@ -100,6 +103,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic import Control.Monad ( msum ) +import qualified Data.Semigroup ( (<>) ) {- ************************************************************************ @@ -109,28 +113,54 @@ import Control.Monad ( msum ) * These are the constraints the low-level simplifier works with * * * ************************************************************************ --} --- The syntax of xi (ξ) types: --- xi ::= a | T xis | xis -> xis | ... | forall a. tau --- Two important notes: --- (i) No type families, unless we are under a ForAll --- (ii) Note that xi types can contain unexpanded type synonyms; --- however, the (transitive) expansions of those type synonyms --- will not contain any type functions, unless we are under a ForAll. --- We enforce the structure of Xi types when we flatten (GHC.Tc.Solver.Canonical) +Note [CEqCan occurs check] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A CEqCan relates a CanEqLHS (a type variable or type family applications) on +its left to an arbitrary type on its right. It is used for rewriting, in the +flattener. Because it is used for rewriting, it would be disastrous if the RHS +were to mention the LHS: this would cause a loop in rewriting. + +We thus perform an occurs-check. There is, of course, some subtlety: + +* For type variables, the occurs-check looks deeply. This is because + a CEqCan over a meta-variable is also used to inform unification, + in GHC.Tc.Solver.Interact.solveByUnification. If the LHS appears + anywhere, at all, in the RHS, unification will create an infinite + structure, which is bad. + +* For type family applications, the occurs-check is shallow; it looks + only in places where we might rewrite. (Specifically, it does not + look in kinds or coercions.) An occurrence of the LHS in, say, an + RHS coercion is OK, as we do not rewrite in coercions. No loop to + be found. + + You might also worry about the possibility that a type family + application LHS doesn't exactly appear in the RHS, but something + that reduces to the LHS does. Yet that can't happen: the RHS is + already inert, with all type family redexes reduced. So a simple + syntactic check is just fine. + +The occurs check is performed in GHC.Tc.Utils.Unify.checkTypeEq. -type Xi = Type -- In many comments, "xi" ranges over Xi +-} + +-- | A 'Xi'-type is one that has been fully rewritten with respect +-- to the inert set; that is, it has been flattened by the algorithm +-- in GHC.Tc.Solver.Flatten. (Historical note: 'Xi', for years and years, +-- meant that a type was type-family-free. It does *not* mean this +-- any more.) +type Xi = TcType type Cts = Bag Ct data Ct -- Atomic canonical constraints - = CDictCan { -- e.g. Num xi + = CDictCan { -- e.g. Num ty cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_class :: Class, - cc_tyargs :: [Xi], -- cc_tyargs are function-free, hence Xi + cc_tyargs :: [Xi], -- cc_tyargs are rewritten w.r.t. inerts, so Xi cc_pend_sc :: Bool -- See Note [The superclass story] in GHC.Tc.Solver.Canonical -- True <=> (a) cc_class has superclasses @@ -144,8 +174,7 @@ data Ct -- For the might-be-soluble case, the ctev_pred of the evidence is -- of form (tv xi1 xi2 ... xin) with a tyvar at the head - -- or (tv1 ~ ty2) where the CTyEqCan kind invariant (TyEq:K) fails - -- or (F tys ~ ty) where the CFunEqCan kind invariant fails + -- or (lhs1 ~ ty2) where the CEqCan kind invariant (TyEq:K) fails -- See Note [CIrredCan constraints] -- The definitely-insoluble case is for things like @@ -153,50 +182,32 @@ data Ct -- a ~ [a] occurs check } - | CTyEqCan { -- tv ~ rhs + | CEqCan { -- CanEqLHS ~ rhs -- Invariants: -- * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad - -- * (TyEq:OC) tv not in deep tvs(rhs) (occurs check) - -- * (TyEq:F) If tv is a TauTv, then rhs has no foralls + -- * Many are checked in checkTypeEq in GHC.Tc.Utils.Unify + -- * (TyEq:OC) lhs does not occur in rhs (occurs check) + -- Note [CEqCan occurs check] + -- * (TyEq:F) rhs has no foralls -- (this avoids substituting a forall for the tyvar in other types) - -- * (TyEq:K) tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant] - -- * (TyEq:AFF) rhs (perhaps under the one cast) is *almost function-free*, - -- See Note [Almost function-free] + -- * (TyEq:K) tcTypeKind lhs `tcEqKind` tcTypeKind rhs; Note [Ct kind invariant] -- * (TyEq:N) If the equality is representational, rhs has no top-level newtype - -- See Note [No top-level newtypes on RHS of representational - -- equalities] in GHC.Tc.Solver.Canonical - -- * (TyEq:TV) If rhs (perhaps under the cast) is also a tv, then it is oriented + -- See Note [No top-level newtypes on RHS of representational equalities] + -- in GHC.Tc.Solver.Canonical. (Applies only when constructor of newtype is + -- in scope.) + -- * (TyEq:TV) If rhs (perhaps under a cast) is also CanEqLHS, then it is oriented -- to give best chance of -- unification happening; eg if rhs is touchable then lhs is too - -- See "GHC.Tc.Solver.Canonical" Note [Canonical orientation for tyvar/tyvar equality constraints] - -- * (TyEq:H) The RHS has no blocking coercion holes. See "GHC.Tc.Solver.Canonical" + -- 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_tyvar :: TcTyVar, - cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi) - -- See invariants above + cc_lhs :: CanEqLHS, + cc_rhs :: Xi, -- See invariants above cc_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev } - | CFunEqCan { -- F xis ~ fsk - -- Invariants: - -- * isTypeFamilyTyCon cc_fun - -- * tcTypeKind (F xis) = tyVarKind fsk; Note [Ct kind invariant] - -- * always Nominal role - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_fun :: TyCon, -- A type function - - cc_tyargs :: [Xi], -- cc_tyargs are function-free (hence Xi) - -- Either under-saturated or exactly saturated - -- *never* over-saturated (because if so - -- we should have decomposed) - - cc_fsk :: TcTyVar -- [G] always a FlatSkolTv - -- [W], [WD], or [D] always a FlatMetaTv - -- See Note [The flattening story] in GHC.Tc.Solver.Flatten - } - | CNonCanonical { -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad cc_ev :: CtEvidence } @@ -207,6 +218,18 @@ data Ct -- auxiliary type ------------ +-- | A 'CanEqLHS' is a type that can appear on the left of a canonical +-- equality: a type variable or exactly-saturated type family application. +data CanEqLHS + = TyVarLHS TcTyVar + | TyFamLHS TyCon -- ^ of the family + [Xi] -- ^ exactly saturating the family + +instance Outputable CanEqLHS where + ppr (TyVarLHS tv) = ppr tv + ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args) + +------------ data QCInst -- A much simplified version of ClsInst -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical = QCI { qci_ev :: CtEvidence -- Always of type forall tvs. context => ty @@ -247,35 +270,44 @@ data HoleSort = ExprHole Id -- will be an erroring expression for -fdefer-type-errors. | TypeHole -- ^ A hole in a type (PartialTypeSignatures) + | ConstraintHole + -- ^ A hole in a constraint, like @f :: (_, Eq a) => ... + -- Differentiated from TypeHole because a ConstraintHole + -- is simplified differently. See + -- Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver. instance Outputable Hole where ppr (Hole { hole_sort = ExprHole id , hole_occ = occ , hole_ty = ty }) = parens $ (braces $ ppr occ <> colon <> ppr id) <+> dcolon <+> ppr ty - ppr (Hole { hole_sort = TypeHole + ppr (Hole { hole_sort = _other , hole_occ = occ , hole_ty = ty }) = braces $ ppr occ <> colon <> ppr ty instance Outputable HoleSort where - ppr (ExprHole id) = text "ExprHole:" <> ppr id - ppr TypeHole = text "TypeHole" + ppr (ExprHole id) = text "ExprHole:" <> ppr id + ppr TypeHole = text "TypeHole" + ppr ConstraintHole = text "CosntraintHole" ------------ -- | Used to indicate extra information about why a CIrredCan is irreducible data CtIrredStatus = InsolubleCIS -- this constraint will never be solved - | BlockedCIS -- this constraint is blocked on a coercion hole - -- The hole will appear in the ctEvPred of the constraint with this status - -- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" - -- Wrinkle (4a) + | BlockedCIS 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 (2a) of that + -- same Note. + -- INVARIANT: A BlockedCIS is a homogeneous equality whose + -- left hand side can fit in a CanEqLHS. | OtherCIS instance Outputable CtIrredStatus where - ppr InsolubleCIS = text "(insoluble)" - ppr BlockedCIS = text "(blocked)" - ppr OtherCIS = text "(soluble)" + ppr InsolubleCIS = text "(insoluble)" + ppr (BlockedCIS holes) = parens (text "blocked on" <+> ppr holes) + ppr OtherCIS = text "(soluble)" {- Note [CIrredCan constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -308,61 +340,11 @@ during constraint solving. See Note [Evidence field of CtEvidence]. Note [Ct kind invariant] ~~~~~~~~~~~~~~~~~~~~~~~~ -CTyEqCan and CFunEqCan both require that the kind of the lhs matches the kind -of the rhs. This is necessary because both constraints are used for substitutions +CEqCan requires that the kind of the lhs matches the kind +of the rhs. This is necessary because these constraints are used for substitutions during solving. If the kinds differed, then the substitution would take a well-kinded type to an ill-kinded one. -Note [Almost function-free] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type is *almost function-free* if it has no type functions (something that -responds True to isTypeFamilyTyCon), except (possibly) - * under a forall, or - * in a coercion (either in a CastTy or a CercionTy) - -The RHS of a CTyEqCan must be almost function-free, invariant (TyEq:AFF). -This is for two reasons: - -1. There cannot be a top-level function. If there were, the equality should - really be a CFunEqCan, not a CTyEqCan. - -2. Nested functions aren't too bad, on the other hand. However, consider this - scenario: - - type family F a = r | r -> a - - [D] F ty1 ~ fsk1 - [D] F ty2 ~ fsk2 - [D] fsk1 ~ [G Int] - [D] fsk2 ~ [G Bool] - - type instance G Int = Char - type instance G Bool = Char - - If it was the case that fsk1 = fsk2, then we could unifty ty1 and ty2 -- - good! They don't look equal -- but if we aggressively reduce that G Int and - G Bool they would become equal. The "almost function free" makes sure that - these redexes are exposed. - - Note that this equality does *not* depend on casts or coercions, and so - skipping these forms is OK. In addition, the result of a type family cannot - be a polytype, so skipping foralls is OK, too. We skip foralls because we - want the output of the flattener to be almost function-free. See Note - [Flattening under a forall] in GHC.Tc.Solver.Flatten. - - As I (Richard E) write this, it is unclear if the scenario pictured above - can happen -- I would expect the G Int and G Bool to be reduced. But - perhaps it can arise somehow, and maintaining almost function-free is cheap. - -Historical note: CTyEqCans used to require only condition (1) above: that no -type family was at the top of an RHS. But work on #16512 suggested that the -injectivity checks were not complete, and adding the requirement that functions -do not appear even in a nested fashion was easy (it was already true, but -unenforced). - -The almost-function-free property is checked by isAlmostFunctionFree in GHC.Tc.Utils.TcType. -The flattener (in GHC.Tc.Solver.Flatten) produces types that are almost function-free. - Note [Holes] ~~~~~~~~~~~~ This Note explains how GHC tracks *holes*. @@ -377,10 +359,7 @@ user describing the bit that is left out. When a hole is encountered, a new entry of type Hole is added to the ambient WantedConstraints. The type (hole_ty) of the hole is then simplified during solving (with respect to any Givens in surrounding implications). It is -reported with all the other errors in GHC.Tc.Errors. No type family reduction -is done on hole types; this is purely because we think it will produce -better error messages not to reduce type families. This is why the -GHC.Tc.Solver.Flatten.flattenType function uses FM_SubstOnly. +reported with all the other errors in GHC.Tc.Errors. For expression holes, the user has the option of deferring errors until runtime with -fdefer-type-errors. In this case, the hole actually has evidence: this @@ -459,8 +438,7 @@ instance Outputable Ct where ppr ct = ppr (ctEvidence ct) <+> parens pp_sort where pp_sort = case ct of - CTyEqCan {} -> text "CTyEqCan" - CFunEqCan {} -> text "CFunEqCan" + CEqCan {} -> text "CEqCan" CNonCanonical {} -> text "CNonCanonical" CDictCan { cc_pend_sc = pend_sc } | pend_sc -> text "CDictCan(psc)" @@ -470,6 +448,40 @@ instance Outputable Ct where | pend_sc -> text "CQuantCan(psc)" | otherwise -> text "CQuantCan" +----------------------------------- +-- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated +-- type family application? +-- Does not look through type synonyms. +canEqLHS_maybe :: Xi -> Maybe CanEqLHS +canEqLHS_maybe xi + | Just tv <- tcGetTyVar_maybe xi + = Just $ TyVarLHS tv + + | Just (tc, args) <- tcSplitTyConApp_maybe xi + , isTypeFamilyTyCon tc + , args `lengthIs` tyConArity tc + = Just $ TyFamLHS tc args + + | otherwise + = Nothing + +-- | Convert a 'CanEqLHS' back into a 'Type' +canEqLHSType :: CanEqLHS -> TcType +canEqLHSType (TyVarLHS tv) = mkTyVarTy tv +canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args + +-- | Retrieve the kind of a 'CanEqLHS' +canEqLHSKind :: CanEqLHS -> TcKind +canEqLHSKind (TyVarLHS tv) = tyVarKind tv +canEqLHSKind (TyFamLHS fam_tc fam_args) = piResultTys (tyConKind fam_tc) fam_args + +-- | Are two 'CanEqLHS's equal? +eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool +eqCanEqLHS (TyVarLHS tv1) (TyVarLHS tv2) = tv1 == tv2 +eqCanEqLHS (TyFamLHS fam_tc1 fam_args1) (TyFamLHS fam_tc2 fam_args2) + = tcEqTyConApps fam_tc1 fam_args1 fam_tc2 fam_args2 +eqCanEqLHS _ _ = False + {- ************************************************************************ * * @@ -705,26 +717,6 @@ isGivenCt = isGiven . ctEvidence isDerivedCt :: Ct -> Bool isDerivedCt = isDerived . ctEvidence -isCTyEqCan :: Ct -> Bool -isCTyEqCan (CTyEqCan {}) = True -isCTyEqCan _ = False - -isCDictCan_Maybe :: Ct -> Maybe Class -isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls -isCDictCan_Maybe _ = Nothing - -isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type]) -isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis) -isCFunEqCan_maybe _ = Nothing - -isCFunEqCan :: Ct -> Bool -isCFunEqCan (CFunEqCan {}) = True -isCFunEqCan _ = False - -isCNonCanonical :: Ct -> Bool -isCNonCanonical (CNonCanonical {}) = True -isCNonCanonical _ = False - {- Note [Custom type errors in constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1116,8 +1108,7 @@ data Implication -- (order does not matter) -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType - ic_no_eqs :: Bool, -- True <=> ic_givens have no equalities, for sure - -- False <=> ic_givens might have equalities + ic_given_eqs :: HasGivenEqs, -- Are there Given equalities here? ic_warn_inaccessible :: Bool, -- True <=> -Winaccessible-code is enabled @@ -1164,7 +1155,7 @@ implicationPrototype , ic_skols = [] , ic_given = [] , ic_wanted = emptyWC - , ic_no_eqs = False + , ic_given_eqs = MaybeGivenEqs , ic_status = IC_Unsolved , ic_need_inner = emptyVarSet , ic_need_outer = emptyVarSet } @@ -1181,9 +1172,47 @@ data ImplicStatus | IC_Unsolved -- Neither of the above; might go either way +-- | Does this implication have Given equalities? +-- See Note [When does an implication have given equalities?] in GHC.Tc.Solver.Monad, +-- which also explains why we need three options here. Also, see +-- Note [Suppress redundant givens during error reporting] in GHC.Tc.Errors +-- +-- Stops floating | Suppresses Givens in errors +-- ----------------------------------------------- +-- NoGivenEqs NO | YES +-- LocalGivenEqs NO | NO +-- MaybeGivenEqs YES | NO +-- +-- Examples: +-- +-- NoGivenEqs: Eq a => ... +-- (Show a, Num a) => ... +-- forall a. a ~ Either Int Bool => ... +-- See Note [Let-bound skolems] in GHC.Tc.Solver.Monad for +-- that last one +-- +-- LocalGivenEqs: forall a b. F a ~ G b => ... +-- forall a. F a ~ Int => ... +-- +-- MaybeGivenEqs: (a ~ b) => ... +-- forall a. F a ~ b => ... +-- +-- The check is conservative. A MaybeGivenEqs might not have any equalities. +-- A LocalGivenEqs might local equalities, but it definitely does not have non-local +-- equalities. A NoGivenEqs definitely does not have equalities (except let-bound +-- skolems). +data HasGivenEqs + = NoGivenEqs -- definitely no given equalities, + -- except by Note [Let-bound skolems] in GHC.Tc.Solver.Monad + | LocalGivenEqs -- might have Given equalities that affect only local skolems + -- e.g. forall a b. (a ~ F b) => ...; definitely no others + | MaybeGivenEqs -- might have any kind of Given equalities; no floating out + -- is possible. + deriving Eq + instance Outputable Implication where ppr (Implic { ic_tclvl = tclvl, ic_skols = skols - , ic_given = given, ic_no_eqs = no_eqs + , ic_given = given, ic_given_eqs = given_eqs , ic_wanted = wanted, ic_status = status , ic_binds = binds , ic_need_inner = need_in, ic_need_outer = need_out @@ -1191,7 +1220,7 @@ instance Outputable Implication where = hang (text "Implic" <+> lbrace) 2 (sep [ text "TcLevel =" <+> ppr tclvl , text "Skolems =" <+> pprTyVars skols - , text "No-eqs =" <+> ppr no_eqs + , text "Given-eqs =" <+> ppr given_eqs , text "Status =" <+> ppr status , hang (text "Given =") 2 (pprEvVars given) , hang (text "Wanted =") 2 (ppr wanted) @@ -1212,6 +1241,25 @@ checkTelescopeSkol :: SkolemInfo -> Bool checkTelescopeSkol (ForAllSkol {}) = True checkTelescopeSkol _ = False +instance Outputable HasGivenEqs where + ppr NoGivenEqs = text "NoGivenEqs" + ppr LocalGivenEqs = text "LocalGivenEqs" + ppr MaybeGivenEqs = text "MaybeGivenEqs" + +-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs +instance Semigroup HasGivenEqs where + NoGivenEqs <> other = other + other <> NoGivenEqs = other + + MaybeGivenEqs <> _other = MaybeGivenEqs + _other <> MaybeGivenEqs = MaybeGivenEqs + + LocalGivenEqs <> LocalGivenEqs = LocalGivenEqs + +-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs +instance Monoid HasGivenEqs where + mempty = NoGivenEqs + {- Note [Checking telescopes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When kind-checking a /user-written/ type, we might have a "bad telescope" @@ -1420,7 +1468,7 @@ data TcEvDest | HoleDest CoercionHole -- ^ fill in this hole with the evidence -- HoleDest is always used for type-equalities - -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep" + -- See Note [Coercion holes] in GHC.Core.TyCo.Rep data CtEvidence = CtGiven -- Truly given, not depending on subgoals @@ -1536,9 +1584,7 @@ Constraints come in four flavours: * [WD] Wanted WDeriv: a single constraint that represents both [W] and [D] - We keep them paired as one both for efficiency, and because - when we have a finite map F tys -> CFunEqCan, it's inconvenient - to have two CFunEqCans in the range + We keep them paired as one both for efficiency The ctev_nosh field of a Wanted distinguishes between [W] and [WD] @@ -1561,11 +1607,6 @@ data ShadowInfo -- See Note [The improvement story and derived shadows] in GHC.Tc.Solver.Monad deriving( Eq ) -isGivenOrWDeriv :: CtFlavour -> Bool -isGivenOrWDeriv Given = True -isGivenOrWDeriv (Wanted WDeriv) = True -isGivenOrWDeriv _ = False - instance Outputable CtFlavour where ppr Given = text "[G]" ppr (Wanted WDeriv) = text "[WD]" @@ -1591,17 +1632,15 @@ ctFlavourRole :: Ct -> CtFlavourRole -- Uses short-cuts to role for special cases ctFlavourRole (CDictCan { cc_ev = ev }) = (ctEvFlavour ev, NomEq) -ctFlavourRole (CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel }) +ctFlavourRole (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel }) = (ctEvFlavour ev, eq_rel) -ctFlavourRole (CFunEqCan { cc_ev = ev }) - = (ctEvFlavour ev, NomEq) ctFlavourRole ct = ctEvFlavourRole (ctEvidence ct) {- Note [eqCanRewrite] ~~~~~~~~~~~~~~~~~~~~~~ -(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form -tv ~ ty) can be used to rewrite ct2. It must satisfy the properties of +(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CEqCan of form +lhs ~ ty) can be used to rewrite ct2. It must satisfy the properties of a can-rewrite relation, see Definition [Can-rewrite relation] in GHC.Tc.Solver.Monad. @@ -1667,47 +1706,11 @@ eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True eqMayRewriteFR (Derived, NomEq) (Wanted WDeriv, NomEq) = True eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2 ------------------ -{- Note [funEqCanDischarge] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have two CFunEqCans with the same LHS: - (x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2) -Can we drop x2 in favour of x1, either unifying -f2 (if it's a flatten meta-var) or adding a new Given -(f1 ~ f2), if x2 is a Given? - -Answer: yes if funEqCanDischarge is true. --} - -funEqCanDischarge - :: CtEvidence -> CtEvidence - -> ( SwapFlag -- NotSwapped => lhs can discharge rhs - -- Swapped => rhs can discharge lhs - , Bool) -- True <=> upgrade non-discharded one - -- from [W] to [WD] --- See Note [funEqCanDischarge] -funEqCanDischarge ev1 ev2 - = ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 ) - ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 ) - -- CFunEqCans are all Nominal, hence asserts - funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2) - -funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool) -funEqCanDischargeF Given _ = (NotSwapped, False) -funEqCanDischargeF _ Given = (IsSwapped, False) -funEqCanDischargeF (Wanted WDeriv) _ = (NotSwapped, False) -funEqCanDischargeF _ (Wanted WDeriv) = (IsSwapped, True) -funEqCanDischargeF (Wanted WOnly) (Wanted WOnly) = (NotSwapped, False) -funEqCanDischargeF (Wanted WOnly) Derived = (NotSwapped, True) -funEqCanDischargeF Derived (Wanted WOnly) = (IsSwapped, True) -funEqCanDischargeF Derived Derived = (NotSwapped, False) - - {- Note [eqCanDischarge] ~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have two identical CTyEqCan equality constraints +Suppose we have two identical CEqCan equality constraints (i.e. both LHS and RHS are the same) - (x1:a~t) `eqCanDischarge` (xs:a~t) + (x1:lhs~t) `eqCanDischarge` (xs:lhs~t) Can we just drop x2 in favour of x1? Answer: yes if eqCanDischarge is true. diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs index 127723d4f7..602d06608c 100644 --- a/compiler/GHC/Tc/Types/Evidence.hs +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -35,14 +35,15 @@ module GHC.Tc.Types.Evidence ( -- * TcCoercion TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, - TcMCoercion, + TcMCoercion, TcMCoercionN, TcMCoercionR, Role(..), LeftOrRight(..), pickLR, mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo, mkTcTyConAppCo, mkTcAppCo, mkTcFunCo, mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos, - mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo, - tcDowngradeRole, - mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflLeftCo, mkTcPhantomCo, + mkTcSymCo, mkTcSymMCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSymCo, + maybeTcSubCo, tcDowngradeRole, + mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflRightMCo, mkTcGReflLeftCo, mkTcGReflLeftMCo, + mkTcPhantomCo, mkTcCoherenceLeftCo, mkTcCoherenceRightCo, mkTcKindCo, @@ -76,6 +77,7 @@ import GHC.Types.Var.Set import GHC.Core.Predicate import GHC.Types.Name import GHC.Data.Pair +import GHC.Types.Basic import GHC.Core import GHC.Core.Class (Class, classSCSelId ) @@ -111,10 +113,13 @@ type TcCoercion = Coercion type TcCoercionN = CoercionN -- A Nominal coercion ~N type TcCoercionR = CoercionR -- A Representational coercion ~R type TcCoercionP = CoercionP -- a phantom coercion -type TcMCoercion = MCoercion +type TcMCoercion = MCoercion +type TcMCoercionN = MCoercionN -- nominal +type TcMCoercionR = MCoercionR -- representational mkTcReflCo :: Role -> TcType -> TcCoercion mkTcSymCo :: TcCoercion -> TcCoercion +mkTcSymMCo :: TcMCoercion -> TcMCoercion mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion mkTcNomReflCo :: TcType -> TcCoercionN mkTcRepReflCo :: TcType -> TcCoercionR @@ -129,11 +134,13 @@ mkTcForAllCo :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion mkTcForAllCos :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion mkTcNthCo :: Role -> Int -> TcCoercion -> TcCoercion mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion -mkTcSubCo :: TcCoercionN -> TcCoercionR +mkTcSubCo :: HasDebugCallStack => TcCoercionN -> TcCoercionR tcDowngradeRole :: Role -> Role -> TcCoercion -> TcCoercion mkTcAxiomRuleCo :: CoAxiomRule -> [TcCoercion] -> TcCoercionR mkTcGReflRightCo :: Role -> TcType -> TcCoercionN -> TcCoercion +mkTcGReflRightMCo :: Role -> TcType -> TcMCoercionN -> TcCoercion mkTcGReflLeftCo :: Role -> TcType -> TcCoercionN -> TcCoercion +mkTcGReflLeftMCo :: Role -> TcType -> TcMCoercionN -> TcCoercion mkTcCoherenceLeftCo :: Role -> TcType -> TcCoercionN -> TcCoercion -> TcCoercion mkTcCoherenceRightCo :: Role -> TcType -> TcCoercionN @@ -153,6 +160,7 @@ isTcReflexiveCo :: TcCoercion -> Bool mkTcReflCo = mkReflCo mkTcSymCo = mkSymCo +mkTcSymMCo = mkSymMCo mkTcTransCo = mkTransCo mkTcNomReflCo = mkNomReflCo mkTcRepReflCo = mkRepReflCo @@ -169,7 +177,9 @@ mkTcSubCo = mkSubCo tcDowngradeRole = downgradeRole mkTcAxiomRuleCo = mkAxiomRuleCo mkTcGReflRightCo = mkGReflRightCo +mkTcGReflRightMCo = mkGReflRightMCo mkTcGReflLeftCo = mkGReflLeftCo +mkTcGReflLeftMCo = mkGReflLeftMCo mkTcCoherenceLeftCo = mkCoherenceLeftCo mkTcCoherenceRightCo = mkCoherenceRightCo mkTcPhantomCo = mkPhantomCo @@ -184,10 +194,14 @@ isTcReflexiveCo = isReflexiveCo -- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. -- Note that the input coercion should always be nominal. -maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion +maybeTcSubCo :: HasDebugCallStack => EqRel -> TcCoercionN -> TcCoercion maybeTcSubCo NomEq = id maybeTcSubCo ReprEq = mkTcSubCo +-- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion +maybeTcSymCo :: SwapFlag -> TcCoercion -> TcCoercion +maybeTcSymCo IsSwapped co = mkTcSymCo co +maybeTcSymCo NotSwapped co = co {- %************************************************************************ diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 6b66c32ccc..eacdf40bce 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -111,7 +111,7 @@ module GHC.Tc.Utils.Monad( getTcLevel, setTcLevel, isTouchableTcM, getLclTypeEnv, setLclTypeEnv, traceTcConstraints, - emitNamedTypeHole, emitAnonTypeHole, + emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole, -- * Template Haskell context recordThUse, recordThSpliceUse, @@ -1779,16 +1779,26 @@ traceTcConstraints msg hang (text (msg ++ ": LIE:")) 2 (ppr lie) } -emitAnonTypeHole :: TcTyVar -> TcM () -emitAnonTypeHole tv +data IsExtraConstraint = YesExtraConstraint + | NoExtraConstraint + +instance Outputable IsExtraConstraint where + ppr YesExtraConstraint = text "YesExtraConstraint" + ppr NoExtraConstraint = text "NoExtraConstraint" + +emitAnonTypeHole :: IsExtraConstraint + -> TcTyVar -> TcM () +emitAnonTypeHole extra_constraints tv = do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing - ; let hole = Hole { hole_sort = TypeHole + ; let hole = Hole { hole_sort = sort , hole_occ = occ , hole_ty = mkTyVarTy tv , hole_loc = ct_loc } ; emitHole hole } where occ = mkTyVarOcc "_" + sort | YesExtraConstraint <- extra_constraints = ConstraintHole + | otherwise = TypeHole emitNamedTypeHole :: (Name, TcTyVar) -> TcM () emitNamedTypeHole (name, tv) diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index 452c795c3b..62fab5500b 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -25,7 +25,7 @@ module GHC.Tc.Utils.TcMType ( newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind, newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel, newAnonMetaTyVar, cloneMetaTyVar, - newFmvTyVar, newFskTyVar, + newCycleBreakerTyVar, newMultiplicityVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, @@ -183,7 +183,7 @@ newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence -- Deals with both equality and non-equality predicates newWanted orig t_or_k pty = do loc <- getCtLocM orig t_or_k - d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole YesBlockSubst pty + d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole pty else EvVarDest <$> newEvVar pty return $ CtWanted { ctev_dest = d , ctev_pred = pty @@ -199,8 +199,8 @@ newWanteds orig = mapM (newWanted orig Nothing) cloneWanted :: Ct -> TcM Ct cloneWanted ct - | ev@(CtWanted { ctev_dest = HoleDest old_hole, ctev_pred = pty }) <- ctEvidence ct - = do { co_hole <- newCoercionHole (ch_blocker old_hole) pty + | ev@(CtWanted { ctev_pred = pty }) <- ctEvidence ct + = do { co_hole <- newCoercionHole pty ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) } | otherwise = return ct @@ -250,7 +250,7 @@ emitDerivedEqs origin pairs -- | Emits a new equality constraint emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion emitWantedEq origin t_or_k role ty1 ty2 - = do { hole <- newCoercionHole YesBlockSubst pty + = do { hole <- newCoercionHole pty ; loc <- getCtLocM origin (Just t_or_k) ; emitSimple $ mkNonCanonical $ CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole @@ -323,16 +323,12 @@ newImplication ************************************************************************ -} -newCoercionHole :: BlockSubstFlag -- should the presence of this hole block substitution? - -- See sub-wrinkle in TcCanonical - -- Note [Equalities with incompatible kinds] - -> TcPredType -> TcM CoercionHole -newCoercionHole blocker pred_ty +newCoercionHole :: TcPredType -> TcM CoercionHole +newCoercionHole pred_ty = do { co_var <- newEvVar pred_ty - ; traceTc "New coercion hole:" (ppr co_var <+> ppr blocker) + ; traceTc "New coercion hole:" (ppr co_var) ; ref <- newMutVar Nothing - ; return $ CoercionHole { ch_co_var = co_var, ch_blocker = blocker - , ch_ref = ref } } + ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } } -- | Put a value in a coercion hole fillCoercionHole :: CoercionHole -> Coercion -> TcM () @@ -805,11 +801,10 @@ influences the way it is tidied; see TypeRep.tidyTyVarBndr. metaInfoToTyVarName :: MetaInfo -> FastString metaInfoToTyVarName meta_info = case meta_info of - TauTv -> fsLit "t" - FlatMetaTv -> fsLit "fmv" - FlatSkolTv -> fsLit "fsk" - TyVarTv -> fsLit "a" - RuntimeUnkTv -> fsLit "r" + TauTv -> fsLit "t" + TyVarTv -> fsLit "a" + RuntimeUnkTv -> fsLit "r" + CycleBreakerTv -> fsLit "b" newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi @@ -875,19 +870,13 @@ cloneAnonMetaTyVar info tv kind ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) ; return tyvar } -newFskTyVar :: TcType -> TcM TcTyVar -newFskTyVar fam_ty - = do { details <- newMetaDetails FlatSkolTv - ; name <- newMetaTyVarName (fsLit "fsk") - ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } - -newFmvTyVar :: TcType -> TcM TcTyVar --- Very like newMetaTyVar, except sets mtv_tclvl to one less --- so that the fmv is untouchable. -newFmvTyVar fam_ty - = do { details <- newMetaDetails FlatMetaTv - ; name <- newMetaTyVarName (fsLit "s") - ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } +-- Make a new CycleBreakerTv. See Note [Type variable cycles in Givens] +-- in GHC.Tc.Solver.Canonical. +newCycleBreakerTyVar :: TcKind -> TcM TcTyVar +newCycleBreakerTyVar kind + = do { details <- newMetaDetails CycleBreakerTv + ; name <- newMetaTyVarName (fsLit "cbv") + ; return (mkTcTyVar name kind details) } newMetaDetails :: MetaInfo -> TcM TcTyVarDetails newMetaDetails info @@ -2179,18 +2168,16 @@ Why?, for example: - For CIrredCan we want to see if a constraint is insoluble with insolubleWC -On the other hand, we change CTyEqCan to CNonCanonical, because of all of -CTyEqCan's invariants, which can break during zonking. Besides, the constraint +On the other hand, we change CEqCan to CNonCanonical, because of all of +CEqCan's invariants, which can break during zonking. (Example: a ~R alpha, where +we have alpha := N Int, where N is a newtype.) Besides, the constraint will be canonicalised again, so there is little benefit in keeping the -CTyEqCan structure. - -NB: we do not expect to see any CFunEqCans, because zonkCt is only -called on unflattened constraints. +CEqCan structure. NB: Constraints are always re-flattened etc by the canonicaliser in @GHC.Tc.Solver.Canonical@ even if they come in as CDictCan. Only canonical constraints that are actually in the inert set carry all the guarantees. So it is okay if zonkCt -creates e.g. a CDictCan where the cc_tyars are /not/ function free. +creates e.g. a CDictCan where the cc_tyars are /not/ fully reduced. -} zonkCt :: Ct -> TcM Ct @@ -2200,7 +2187,7 @@ zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args }) ; args' <- mapM zonkTcType args ; return $ ct { cc_ev = ev', cc_tyargs = args' } } -zonkCt (CTyEqCan { cc_ev = ev }) +zonkCt (CEqCan { cc_ev = ev }) = mkNonCanonical <$> zonkCtEvidence ev zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag @@ -2208,10 +2195,7 @@ zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag ; return (ct { cc_ev = ev' }) } zonkCt ct - = ASSERT( not (isCFunEqCan ct) ) - -- We do not expect to see any CFunEqCans, because zonkCt is only called on - -- unflattened constraints. - do { fl' <- zonkCtEvidence (ctEvidence ct) + = do { fl' <- zonkCtEvidence (ctEvidence ct) ; return (mkNonCanonical fl') } zonkCtEvidence :: CtEvidence -> TcM CtEvidence diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index c408ffb54c..9d11505053 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -42,8 +42,7 @@ module GHC.Tc.Utils.TcType ( MetaDetails(Flexi, Indirect), MetaInfo(..), isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, - isFskTyVar, isFmvTyVar, isFlattenTyVar, - isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo, + isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, isTouchableMetaTyVar, @@ -78,14 +77,15 @@ module GHC.Tc.Utils.TcType ( -- Again, newtypes are opaque eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + tcEqTyConApps, isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isNaturalTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, - isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck, + isPredTy, isTyVarClassPred, isInsolubleOccursCheck, checkValidClsArgs, hasTyVarHead, - isRigidTy, isAlmostFunctionFree, + isRigidTy, --------------------------------- -- Misc type manipulators @@ -107,7 +107,7 @@ module GHC.Tc.Utils.TcType ( -- * Finding "exact" (non-dead) type variables exactTyCoVarsOfType, exactTyCoVarsOfTypes, - anyRewritableTyVar, + anyRewritableTyVar, anyRewritableTyFamApp, anyRewritableCanEqLHS, --------------------------------- -- Foreign import and export @@ -554,29 +554,22 @@ data MetaInfo -- unified with a type, only with a type variable -- See Note [Signature skolems] - | FlatMetaTv -- A flatten meta-tyvar - -- It is a meta-tyvar, but it is always untouchable, with level 0 - -- See Note [The flattening story] in GHC.Tc.Solver.Flatten - - | FlatSkolTv -- A flatten skolem tyvar - -- Just like FlatMetaTv, but is completely "owned" by - -- its Given CFunEqCan. - -- It is filled in /only/ by unflattenGivens - -- See Note [The flattening story] in GHC.Tc.Solver.Flatten - | RuntimeUnkTv -- A unification variable used in the GHCi debugger. -- It /is/ allowed to unify with a polytype, unlike TauTv + | CycleBreakerTv -- Used to fix occurs-check problems in Givens + -- See Note [Type variable cycles in Givens] in + -- GHC.Tc.Solver.Canonical + instance Outputable MetaDetails where ppr Flexi = text "Flexi" ppr (Indirect ty) = text "Indirect" <+> ppr ty instance Outputable MetaInfo where - ppr TauTv = text "tau" - ppr TyVarTv = text "tyv" - ppr FlatMetaTv = text "fmv" - ppr FlatSkolTv = text "fsk" - ppr RuntimeUnkTv = text "rutv" + ppr TauTv = text "tau" + ppr TyVarTv = text "tyv" + ppr RuntimeUnkTv = text "rutv" + ppr CycleBreakerTv = text "cbv" {- ********************************************************************* * * @@ -615,7 +608,7 @@ Note [TcLevel and untouchable type variables] * A unification variable is *touchable* if its level number is EQUAL TO that of its immediate parent implication, - and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv) + and it is a TauTv or TyVarTv (but /not/ CycleBreakerTv) Note [WantedInv] ~~~~~~~~~~~~~~~~ @@ -854,27 +847,41 @@ isTyFamFree :: Type -> Bool -- ^ Check that a type does not contain any type family applications. isTyFamFree = null . tcTyFamInsts -anyRewritableTyVar :: Bool -- Ignore casts and coercions - -> EqRel -- Ambient role - -> (EqRel -> TcTyVar -> Bool) - -> TcType -> Bool --- (anyRewritableTyVar ignore_cos pred ty) returns True --- if the 'pred' returns True of any free TyVar in 'ty' +any_rewritable :: Bool -- Ignore casts and coercions + -> 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 -- See Note [anyRewritableTyVar must be role-aware] -anyRewritableTyVar ignore_cos role pred ty - = go role emptyVarSet ty +-- +-- This looks like it should use foldTyCo, but that function is +-- role-agnostic, and this one must be role-aware. We could make +-- foldTyCon role-aware, but that may slow down more common usages. +{-# INLINE any_rewritable #-} -- this allows specialization of predicates +any_rewritable ignore_cos role tv_pred tc_pred should_expand + = go role emptyVarSet where - -- NB: No need to expand synonyms, because we can find - -- all free variables of a synonym by looking at its - -- arguments - go_tv rl bvs tv | tv `elemVarSet` bvs = False - | otherwise = pred rl tv + | otherwise = tv_pred rl tv + + go rl bvs ty@(TyConApp tc tys) + | isTypeSynonymTyCon tc + , should_expand tc + , Just ty' <- tcView ty -- should always match + = go rl bvs ty' + + | tc_pred rl tc tys + = True + + | otherwise + = go_tc rl bvs tc tys go rl bvs (TyVarTy tv) = go_tv rl bvs tv go _ _ (LitTy {}) = False - go rl bvs (TyConApp tc tys) = go_tc rl bvs tc tys go rl bvs (AppTy fun arg) = go rl bvs fun || go NomEq bvs arg go rl bvs (FunTy _ w arg res) = go NomEq bvs arg_rep || go NomEq bvs res_rep || go rl bvs arg || go rl bvs res || go NomEq bvs w @@ -898,6 +905,36 @@ anyRewritableTyVar ignore_cos role pred ty -- 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 + -> (EqRel -> TcTyVar -> Bool) -- check tyvar + -> TcType -> Bool +anyRewritableTyVar ignore_cos role pred + = any_rewritable ignore_cos role pred + (\ _ _ _ -> False) -- don't check tyconapps + (\ _ -> False) -- don't expand synonyms + -- NB: No need to expand synonyms, because we can find + -- all free variables of a synonym by looking at its + -- arguments + +anyRewritableTyFamApp :: EqRel -- Ambient role + -> (EqRel -> TyCon -> [TcType] -> Bool) -- check tyconapp + -- should return True only for type family applications + -> TcType -> Bool + -- always ignores casts & coercions +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. +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) + {- Note [anyRewritableTyVar must be role-aware] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ anyRewritableTyVar is used during kick-out from the inert set, @@ -969,7 +1006,7 @@ isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool isTouchableMetaTyVar ctxt_tclvl tv | isTyVar tv -- See Note [Coercion variables in free variable lists] , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv - , not (isFlattenInfo info) + , isTouchableInfo info = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) tv_tclvl `sameDepthAs` ctxt_tclvl @@ -980,7 +1017,7 @@ isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool isFloatedTouchableMetaTyVar ctxt_tclvl tv | isTyVar tv -- See Note [Coercion variables in free variable lists] , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv - , not (isFlattenInfo info) + , isTouchableInfo info = tv_tclvl `strictlyDeeperThan` ctxt_tclvl | otherwise = False @@ -989,8 +1026,7 @@ isImmutableTyVar :: TyVar -> Bool isImmutableTyVar tv = isSkolemTyVar tv isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, - isMetaTyVar, isAmbiguousTyVar, - isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool + isMetaTyVar, isAmbiguousTyVar, isCycleBreakerTyVar :: TcTyVar -> Bool isTyConableTyVar tv -- True of a meta-type variable that can be filled in @@ -1002,25 +1038,6 @@ isTyConableTyVar tv _ -> True | otherwise = True -isFmvTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_info = FlatMetaTv } -> True - _ -> False - -isFskTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_info = FlatSkolTv } -> True - _ -> False - --- | True of both given and wanted flatten-skolems (fmv and fsk) -isFlattenTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_info = info } -> isFlattenInfo info - _ -> False - isSkolemTyVar tv = ASSERT2( tcIsTcTyVar tv, ppr tv ) case tcTyVarDetails tv of @@ -1054,6 +1071,14 @@ isAmbiguousTyVar tv _ -> False | otherwise = False +isCycleBreakerTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + , MetaTv { mtv_info = CycleBreakerTv } <- tcTyVarDetails tv + = True + + | otherwise + = False + isMetaTyVarTy :: TcType -> Bool isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv isMetaTyVarTy _ = False @@ -1064,10 +1089,10 @@ metaTyVarInfo tv MetaTv { mtv_info = info } -> info _ -> pprPanic "metaTyVarInfo" (ppr tv) -isFlattenInfo :: MetaInfo -> Bool -isFlattenInfo FlatMetaTv = True -isFlattenInfo FlatSkolTv = True -isFlattenInfo _ = False +isTouchableInfo :: MetaInfo -> Bool +isTouchableInfo info + | CycleBreakerTv <- info = False + | otherwise = True metaTyVarTcLevel :: TcTyVar -> TcLevel metaTyVarTcLevel tv @@ -1540,7 +1565,15 @@ pickyEqType :: TcType -> TcType -> Bool -- This ignores kinds and coercions, because this is used only for printing. pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 - +-- | Check whether two TyConApps are the same; if the number of arguments +-- are different, just checks the common prefix of arguments. +tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool +tcEqTyConApps tc1 args1 tc2 args2 + = tc1 == tc2 && + and (zipWith tcEqTypeNoKindCheck args1 args2) + -- No kind check necessary: if both arguments are well typed, then + -- any difference in the kinds of later arguments would show up + -- as differences in earlier (dependent) arguments -- | Real worker for 'tcEqType'. No kind check! tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms @@ -2114,18 +2147,6 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of Just (tc, _) -> uniq == getUnique tc Nothing -> False --- | Does the given tyvar appear at the head of a chain of applications --- (a t1 ... tn) -isTyVarHead :: TcTyVar -> TcType -> Bool -isTyVarHead tv (TyVarTy tv') = tv == tv' -isTyVarHead tv (AppTy fun _) = isTyVarHead tv fun -isTyVarHead tv (CastTy ty _) = isTyVarHead tv ty -isTyVarHead _ (TyConApp {}) = False -isTyVarHead _ (LitTy {}) = False -isTyVarHead _ (ForAllTy {}) = False -isTyVarHead _ (FunTy {}) = False -isTyVarHead _ (CoercionTy {}) = False - {- Note [AppTy and ReprEq] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2147,24 +2168,6 @@ isRigidTy ty | otherwise = False --- | Is this type *almost function-free*? See Note [Almost function-free] --- in "GHC.Tc.Types" -isAlmostFunctionFree :: TcType -> Bool -isAlmostFunctionFree ty | Just ty' <- tcView ty = isAlmostFunctionFree ty' -isAlmostFunctionFree (TyVarTy {}) = True -isAlmostFunctionFree (AppTy ty1 ty2) = isAlmostFunctionFree ty1 && - isAlmostFunctionFree ty2 -isAlmostFunctionFree (TyConApp tc args) - | isTypeFamilyTyCon tc = False - | otherwise = all isAlmostFunctionFree args -isAlmostFunctionFree (ForAllTy bndr _) = isAlmostFunctionFree (binderType bndr) -isAlmostFunctionFree (FunTy _ w ty1 ty2) = isAlmostFunctionFree w && - isAlmostFunctionFree ty1 && - isAlmostFunctionFree ty2 -isAlmostFunctionFree (LitTy {}) = True -isAlmostFunctionFree (CastTy ty _) = isAlmostFunctionFree ty -isAlmostFunctionFree (CoercionTy {}) = True - {- ************************************************************************ * * diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index 4b0a5f8fdd..3529f598f8 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -36,7 +37,8 @@ module GHC.Tc.Utils.Unify ( matchExpectedFunKind, matchActualFunTySigma, matchActualFunTysRho, - metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..) + metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..), + checkTyVarEq, checkTyFamEq, checkTypeEq, AreTypeFamiliesOK(..) ) where @@ -73,6 +75,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic +import GHC.Exts ( inline ) import Control.Monad import Control.Arrow ( second ) @@ -949,7 +952,7 @@ buildTvImplication skol_info skol_tvs tclvl wanted ; return (implic { ic_tclvl = tclvl , ic_skols = skol_tvs - , ic_no_eqs = True + , ic_given_eqs = NoGivenEqs , ic_wanted = wanted , ic_binds = ev_binds , ic_info = skol_info }) } @@ -1431,7 +1434,8 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2 where go dflags cur_lvl | canSolveByUnification cur_lvl tv1 ty2 - , MTVU_OK ty2' <- metaTyVarUpdateOK dflags tv1 ty2 + -- See Note [Prevent unification with type families] about the NoTypeFamilies: + , MTVU_OK ty2' <- metaTyVarUpdateOK dflags NoTypeFamilies tv1 ty2 = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1) ; traceTc "uUnfilledVar2 ok" $ vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) @@ -1498,20 +1502,19 @@ lhsPriority tv RuntimeUnk -> 0 SkolemTv {} -> 0 MetaTv { mtv_info = info } -> case info of - FlatSkolTv -> 1 - TyVarTv -> 2 - TauTv -> 3 - FlatMetaTv -> 4 - RuntimeUnkTv -> 5 + CycleBreakerTv -> 0 + TyVarTv -> 1 + TauTv -> 2 + RuntimeUnkTv -> 3 {- Note [TyVar/TyVar orientation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)? +Given (a ~ b), should we orient the CEqCan as (a~b) or (b~a)? This is a surprisingly tricky question! This is invariant (TyEq:TV). -The question is answered by swapOverTyVars, which is use +The question is answered by swapOverTyVars, which is used - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1 - - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqTyVarHomo + - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqCanLHS2 First note: only swap if you have to! See Note [Avoid unnecessary swaps] @@ -1531,25 +1534,23 @@ So we look for a positive reason to swap, using a three-step test: looks for meta tyvars on the left Tie-breaking rules for MetaTvs: - - FlatMetaTv = 4: always put on the left. - See Note [Fmv Orientation Invariant] + - CycleBreakerTv: This is essentially a stand-in for another type; + it's untouchable and should have the same priority as a skolem: 0. - NB: FlatMetaTvs always have the current level, never an - outer one. So nothing can be deeper than a FlatMetaTv. + - TyVarTv: These can unify only with another tyvar, but we can't unify + a TyVarTv with a TauTv, because then the TyVarTv could (transitively) + get a non-tyvar type. So give these a low priority: 1. - - TauTv = 3: if we have tyv_tv ~ tau_tv, - put tau_tv on the left because there are fewer - restrictions on updating TauTvs. Or to say it another - way, then we won't lose the TyVarTv flag + - TauTv: This is the common case; we want these on the left so that they + can be written to: 2. - - TyVarTv = 2: remember, flat-skols are *only* updated by - the unflattener, never unified, so TyVarTvs come next - - - FlatSkolTv = 1: put on the left in preference to a SkolemTv. - See Note [Eliminate flat-skols] + - RuntimeUnkTv: These aren't really meta-variables used in type inference, + but just a convenience in the implementation of the GHCi debugger. + Eagerly write to these: 3. See Note [RuntimeUnkTv] in + GHC.Runtime.Heap.Inspect. * Names. If the level and priority comparisons are all - equal, try to eliminate a TyVars with a System Name in + equal, try to eliminate a TyVar with a System Name in favour of ones with a Name derived from a user type signature * Age. At one point in the past we tried to break any remaining @@ -1602,64 +1603,6 @@ Wanteds and Givens, but either way, deepest wins! Simple. See #15009 for an further analysis of why "deepest on the left" is a good plan. -Note [Fmv Orientation Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * We always orient a constraint - fmv ~ alpha - with fmv on the left, even if alpha is - a touchable unification variable - -Reason: doing it the other way round would unify alpha:=fmv, but that -really doesn't add any info to alpha. But a later constraint alpha ~ -Int might unlock everything. Comment:9 of #12526 gives a detailed -example. - -WARNING: I've gone to and fro on this one several times. -I'm now pretty sure that unifying alpha:=fmv is a bad idea! -So orienting with fmvs on the left is a good thing. - -This example comes from IndTypesPerfMerge. (Others include -T10226, T10009.) - From the ambiguity check for - f :: (F a ~ a) => a - we get: - [G] F a ~ a - [WD] F alpha ~ alpha, alpha ~ a - - From Givens we get - [G] F a ~ fsk, fsk ~ a - - Now if we flatten we get - [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a - - Now, if we unified alpha := fmv, we'd get - [WD] F fmv ~ fmv, [WD] fmv ~ a - And now we are stuck. - -So instead the Fmv Orientation Invariant puts the fmv on the -left, giving - [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a - - Now we get alpha:=a, and everything works out - -Note [Eliminate flat-skols] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have [G] Num (F [a]) -then we flatten to - [G] Num fsk - [G] F [a] ~ fsk -where fsk is a flatten-skolem (FlatSkolTv). Suppose we have - type instance F [a] = a -then we'll reduce the second constraint to - [G] a ~ fsk -and then replace all uses of 'a' with fsk. That's bad because -in error messages instead of saying 'a' we'll say (F [a]). In all -places, including those where the programmer wrote 'a' in the first -place. Very confusing! See #7862. - -Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate -the fsk. - Note [Avoid unnecessary swaps] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we swap without actually improving matters, we can get an infinite loop. @@ -1734,8 +1677,11 @@ It would be lovely in the future to revisit this problem and remove this extra, unnecessary check. But we retain it for now as it seems to work better in practice. -Note [Refactoring hazard: checkTauTvUpdate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Revisited in Nov '20, along with removing flattening variables. Problem +is still present, and the solution (NoTypeFamilies) is still the same. + +Note [Refactoring hazard: metaTyVarUpdateOK] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ I (Richard E.) have a sad story about refactoring this code, retained here to prevent others (or a future me!) from falling into the same traps. @@ -1957,7 +1903,7 @@ occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult () -- a) the given variable occurs in the given type. -- b) there is a forall in the type (unless we have -XImpredicativeTypes) occCheckForErrors dflags tv ty - = case mtvu_check dflags True tv ty of + = case checkTyVarEq dflags YesTypeFamilies tv ty of MTVU_OK _ -> MTVU_OK () MTVU_Bad -> MTVU_Bad MTVU_HoleBlocker -> MTVU_HoleBlocker @@ -1966,16 +1912,24 @@ occCheckForErrors dflags tv ty Just _ -> MTVU_OK () ---------------- +data AreTypeFamiliesOK = YesTypeFamilies + | NoTypeFamilies + deriving Eq + +instance Outputable AreTypeFamiliesOK where + ppr YesTypeFamilies = text "YesTypeFamilies" + ppr NoTypeFamilies = text "NoTypeFamilies" + metaTyVarUpdateOK :: DynFlags + -> AreTypeFamiliesOK -- allow type families in RHS? -> TcTyVar -- tv :: k1 -> TcType -- ty :: k2 -> MetaTyVarUpdateResult TcType -- possibly-expanded ty -- (metaTyVarUpdateOK tv ty) -- Checks that the equality tv~ty is OK to be used to rewrite --- other equalities. Equivalently, checks the conditions for CTyEqCan +-- other equalities. Equivalently, checks the conditions for CEqCan -- (a) that tv doesn't occur in ty (occurs check) --- (b) that ty does not have any foralls --- (in the impredicative case), or type functions +-- (b) that ty does not have any foralls or (perhaps) type functions -- (c) that ty does not have any blocking coercion holes -- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" -- @@ -2000,12 +1954,10 @@ metaTyVarUpdateOK :: DynFlags -- we return Nothing, leaving it to the later constraint simplifier to -- sort matters out. -- --- See Note [Refactoring hazard: checkTauTvUpdate] +-- See Note [Refactoring hazard: metaTyVarUpdateOK] -metaTyVarUpdateOK dflags tv ty - = case mtvu_check dflags False tv ty of - -- False <=> type families not ok - -- See Note [Prevent unification with type families] +metaTyVarUpdateOK dflags ty_fam_ok tv ty + = case checkTyVarEq dflags ty_fam_ok tv ty of MTVU_OK _ -> MTVU_OK ty MTVU_Bad -> MTVU_Bad -- forall, predicate, type function MTVU_HoleBlocker -> MTVU_HoleBlocker -- coercion hole @@ -2013,20 +1965,40 @@ metaTyVarUpdateOK dflags tv ty Just expanded_ty -> MTVU_OK expanded_ty Nothing -> MTVU_Occurs -mtvu_check :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult () --- Checks the invariants for CTyEqCan. In particular: +checkTyVarEq :: DynFlags -> AreTypeFamiliesOK -> TcTyVar -> TcType -> MetaTyVarUpdateResult () +checkTyVarEq dflags ty_fam_ok tv ty + = inline checkTypeEq dflags ty_fam_ok (TyVarLHS tv) ty + -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away + +checkTyFamEq :: DynFlags + -> TyCon -- type function + -> [TcType] -- args, exactly saturated + -> TcType -- RHS + -> MetaTyVarUpdateResult () +checkTyFamEq dflags fun_tc fun_args ty + = inline checkTypeEq dflags YesTypeFamilies (TyFamLHS fun_tc fun_args) ty + -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away + +checkTypeEq :: DynFlags -> AreTypeFamiliesOK -> CanEqLHS -> TcType + -> MetaTyVarUpdateResult () +-- Checks the invariants for CEqCan. In particular: -- (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 type variable (occurs check) +-- (e) an occurrence of the LHS (occurs check) -- -- 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, and for (e) we do look in the kinds of course. - -mtvu_check dflags ty_fam_ok tv ty - = fast_check ty +-- 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. +-- +-- 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 ty_fam_ok lhs ty + = go ty where ok :: MetaTyVarUpdateResult () ok = MTVU_OK () @@ -2035,53 +2007,82 @@ mtvu_check dflags ty_fam_ok tv ty -- unification variables that can unify with a polytype -- or a TyCon that would usually be disallowed by bad_tc -- See Note [RuntimeUnkTv] in GHC.Runtime.Heap.Inspect - ghci_tv = case tcTyVarDetails tv of - MetaTv { mtv_info = RuntimeUnkTv } -> True - _ -> False - - fast_check :: TcType -> MetaTyVarUpdateResult () - fast_check (TyVarTy tv') - | tv == tv' = MTVU_Occurs - | otherwise = fast_check_occ (tyVarKind tv') - -- See Note [Occurrence checking: look inside kinds] - -- in GHC.Core.Type - - fast_check (TyConApp tc tys) - | bad_tc tc, not ghci_tv = MTVU_Bad - | otherwise = mapM fast_check tys >> ok - fast_check (LitTy {}) = ok - fast_check (FunTy{ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) + ghci_tv + | TyVarLHS tv <- lhs + , MetaTv { mtv_info = RuntimeUnkTv } <- tcTyVarDetails tv + = True + + | otherwise + = False + + go :: TcType -> MetaTyVarUpdateResult () + go (TyVarTy tv') = go_tv tv' + go (TyConApp tc tys) = go_tc tc tys + go (LitTy {}) = ok + go (FunTy{ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) | InvisArg <- af , not ghci_tv = MTVU_Bad - | otherwise = fast_check w >> fast_check a >> fast_check r - fast_check (AppTy fun arg) = fast_check fun >> fast_check arg - fast_check (CastTy ty co) = fast_check ty >> fast_check_co co - fast_check (CoercionTy co) = fast_check_co co - fast_check (ForAllTy (Bndr tv' _) ty) + | otherwise = go w >> go a >> go r + go (AppTy fun arg) = go fun >> go arg + go (CastTy ty co) = go ty >> go_co co + go (CoercionTy co) = go_co co + go (ForAllTy (Bndr tv' _) ty) | not ghci_tv = MTVU_Bad - | tv == tv' = ok - | otherwise = do { fast_check_occ (tyVarKind tv') - ; fast_check_occ ty } - -- Under a forall we look only for occurrences of - -- the type variable + | otherwise = case lhs of + TyVarLHS tv | tv == tv' -> ok + | otherwise -> do { go_occ tv (tyVarKind tv') + ; go ty } + _ -> go ty + + go_tv :: TcTyVar -> MetaTyVarUpdateResult () + -- this slightly peculiar way of defining this means + -- we don't have to evaluate this `case` at every variable + -- occurrence + go_tv = case lhs of + TyVarLHS tv -> \ tv' -> if tv == tv' + then MTVU_Occurs + else go_occ tv (tyVarKind tv') + TyFamLHS {} -> \ _tv' -> ok + -- See Note [Occurrence checking: look inside kinds] in GHC.Core.Type -- For kinds, we only do an occurs check; we do not worry -- about type families or foralls -- See Note [Checking for foralls] - fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs - | otherwise = ok + go_occ tv k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs + | otherwise = ok + + go_tc :: TyCon -> [TcType] -> MetaTyVarUpdateResult () + -- this slightly peculiar way of defining this means + -- we don't have to evaluate this `case` at every tyconapp + go_tc = case lhs of + TyVarLHS {} -> \ tc tys -> + if | good_tc tc -> mapM go tys >> ok + | otherwise -> MTVU_Bad + TyFamLHS fam_tc fam_args -> \ tc tys -> + if | tcEqTyConApps fam_tc fam_args tc tys -> MTVU_Occurs + | good_tc tc -> mapM go tys >> ok + | otherwise -> MTVU_Bad + -- no bother about impredicativity in coercions, as they're -- inferred - fast_check_co co | not (gopt Opt_DeferTypeErrors dflags) - , badCoercionHoleCo co = MTVU_HoleBlocker - -- Wrinkle (4b) in "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds] - - | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs - | otherwise = ok - - bad_tc :: TyCon -> Bool - bad_tc tc - | not (isTauTyCon tc) = True - | not (ty_fam_ok || isFamFreeTyCon tc) = True - | otherwise = False + go_co co | not (gopt Opt_DeferTypeErrors dflags) + , hasCoercionHoleCo co + = MTVU_HoleBlocker -- Wrinkle (2) in GHC.Tc.Solver.Canonical + -- 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. + + | TyVarLHS tv <- lhs + , tv `elemVarSet` tyCoVarsOfCo co + = MTVU_Occurs + + -- Don't check coercions for type families; see commentary at top of function + | otherwise + = ok + + good_tc :: TyCon -> Bool + good_tc + | ghci_tv = \ _tc -> True + | otherwise = \ tc -> isTauTyCon tc && + (ty_fam_ok == YesTypeFamilies || isFamFreeTyCon tc) diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs index 56107a6087..ef78dbe6af 100644 --- a/compiler/GHC/Types/Unique/DFM.hs +++ b/compiler/GHC/Types/Unique/DFM.hs @@ -15,8 +15,12 @@ is not deterministic. -} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall #-} @@ -38,6 +42,7 @@ module GHC.Types.Unique.DFM ( adjustUDFM_Directly, alterUDFM, mapUDFM, + mapMaybeUDFM, plusUDFM, plusUDFM_C, lookupUDFM, lookupUDFM_Directly, @@ -121,7 +126,7 @@ data TaggedVal val = TaggedVal val {-# UNPACK #-} !Int -- ^ insertion time - deriving (Data, Functor) + deriving stock (Data, Functor, Foldable, Traversable) taggedFst :: TaggedVal val -> val taggedFst (TaggedVal v _) = v @@ -399,6 +404,10 @@ alterUDFM f (UDFM m i) k = mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i +mapMaybeUDFM :: forall elt1 elt2 key. + (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 +mapMaybeUDFM f (UDFM m i) = UDFM (M.mapMaybe (traverse f) m) i + anyUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst index da0461f982..30a58175f4 100644 --- a/docs/users_guide/9.2.1-notes.rst +++ b/docs/users_guide/9.2.1-notes.rst @@ -44,6 +44,10 @@ Compiler that the compiler automatically insert cost-centres on all call-sites of the named function. +- There is a significant refactoring in the solver; any type-checker plugins + will have to be updated, as GHC no longer uses flattening skolems or + flattening metavariables. + ``ghc-prim`` library ~~~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/expected-undocumented-flags.txt b/docs/users_guide/expected-undocumented-flags.txt index 23b5a4abe7..75a433189c 100644 --- a/docs/users_guide/expected-undocumented-flags.txt +++ b/docs/users_guide/expected-undocumented-flags.txt @@ -57,7 +57,6 @@ -fextended-default-rules -fffi -ffi --fflat-cache -ffloat-all-lams -ffloat-lam-args -ffrontend-opt diff --git a/docs/users_guide/exts/type_families.rst b/docs/users_guide/exts/type_families.rst index 3c09e63a14..4843e35a80 100644 --- a/docs/users_guide/exts/type_families.rst +++ b/docs/users_guide/exts/type_families.rst @@ -581,6 +581,51 @@ If the option :extension:`UndecidableInstances` is passed to the compiler, the above restrictions are not enforced and it is on the programmer to ensure termination of the normalisation of type families during type inference. +Reducing type family applications +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. ghc-flag:: -ffamily-application-cache + :shortdesc: Use a cache when reducing type family applications + :type: dynamic + :reverse: -fno-family-application-cache + :category: + + The flag :ghc-flag:`-ffamily-application-cache` (on by default) instructs + GHC to use a cache when reducing type family applications. In most cases, + this will speed up compilation. The use of this flag will not affect + runtime behaviour. + +When GHC encounters a type family application (like ``F Int a``) in a program, +it must often reduce it in order to complete type checking. Here is a simple +example:: + + type family F a where + F Int = Bool + F (Maybe Double) = Char + + g :: F Int -> Bool + g = not + +Despite the fact that ``g``\'s type mentions ``F Int``, GHC must recognize that +``g``\'s argument really has type ``Bool``. This is done by *reducing* ``F Int`` +to become ``Bool``. Sometimes, there is not enough information to reduce a type +family application; we say such an application is *stuck*. Continuing this example, +an occurrence of ``F (Maybe a)`` (for some type variable ``a``) would be stuck, as +no equation applies. + +During type checking, GHC uses heuristics to determine which type family application +to reduce next; there is no predictable ordering among different type family applications. +The non-determinism rarely matters in practice. In most programs, type family reduction +terminates, and so these choices are immaterial. However, if a type family application +does not terminate, it is possible that type-checking may unpredictably diverge. (GHC +will always take the same path for a given source program, but small changes in that +source program may induce GHC to take a different path. Compiling a given, unchanged +source program is still deterministic.) + +In order to speed up type family reduction, GHC normally uses a cache, remembering what +type family applications it has previously reduced. This feature can be disabled with +:ghc-flag:`-fno-family-application-cache`. + .. _type-wildcards-lhs: Wildcards on the LHS of data and type family instances diff --git a/testsuite/tests/gadt/T3169.stderr b/testsuite/tests/gadt/T3169.stderr index 5770e03c70..3a5fc99fb3 100644 --- a/testsuite/tests/gadt/T3169.stderr +++ b/testsuite/tests/gadt/T3169.stderr @@ -1,17 +1,20 @@ -T3169.hs:13:22: error: +T3169.hs:13:13: error: • Couldn't match type ‘elt’ with ‘Map b elt’ - Expected: Map a (Map b elt) - Actual: Map (a, b) elt + Expected: Maybe (Map b elt) + Actual: Maybe elt ‘elt’ is a rigid type variable bound by the type signature for: lookup :: forall elt. (a, b) -> Map (a, b) elt -> Maybe elt at T3169.hs:12:3-8 - • In the second argument of ‘lookup’, namely ‘m’ - In the expression: lookup a m :: Maybe (Map b elt) + • In the expression: lookup a m :: Maybe (Map b elt) In the expression: case lookup a m :: Maybe (Map b elt) of { Just (m2 :: Map b elt) -> lookup b m2 :: Maybe elt } + In an equation for ‘lookup’: + lookup (a, b) (m :: Map (a, b) elt) + = case lookup a m :: Maybe (Map b elt) of { + Just (m2 :: Map b elt) -> lookup b m2 :: Maybe elt } • Relevant bindings include m :: Map (a, b) elt (bound at T3169.hs:12:17) b :: b (bound at T3169.hs:12:13) diff --git a/testsuite/tests/gadt/T7293.stderr b/testsuite/tests/gadt/T7293.stderr index 87856d4009..5625ff01c5 100644 --- a/testsuite/tests/gadt/T7293.stderr +++ b/testsuite/tests/gadt/T7293.stderr @@ -4,7 +4,7 @@ T7293.hs:26:1: error: [-Woverlapping-patterns (in -Wdefault), -Werror=overlappin In an equation for ‘nth’: nth Nil _ = ... T7293.hs:26:5: error: [-Winaccessible-code (in -Wdefault), -Werror=inaccessible-code] - • Couldn't match type ‘'True’ with ‘'False’ + • Couldn't match type ‘'False’ with ‘'True’ Inaccessible code in a pattern with constructor: Nil :: forall a. Vec a 'Zero, in an equation for ‘nth’ diff --git a/testsuite/tests/gadt/T7294.stderr b/testsuite/tests/gadt/T7294.stderr index d7b53ee9e2..f694af8d0c 100644 --- a/testsuite/tests/gadt/T7294.stderr +++ b/testsuite/tests/gadt/T7294.stderr @@ -4,7 +4,7 @@ T7294.hs:27:1: warning: [-Woverlapping-patterns (in -Wdefault)] In an equation for ‘nth’: nth Nil _ = ... T7294.hs:27:5: warning: [-Winaccessible-code (in -Wdefault)] - • Couldn't match type ‘'True’ with ‘'False’ + • Couldn't match type ‘'False’ with ‘'True’ Inaccessible code in a pattern with constructor: Nil :: forall a. Vec a 'Zero, in an equation for ‘nth’ diff --git a/testsuite/tests/indexed-types/should_compile/CEqCanOccursCheck.hs b/testsuite/tests/indexed-types/should_compile/CEqCanOccursCheck.hs new file mode 100644 index 0000000000..f3c9918847 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/CEqCanOccursCheck.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeFamilies #-} +-- Important: no AllowAmbiguousTypes + +module CEqCanOccursCheck where + +type family F a where + F Bool = Bool +type family G a b where + G a a = a + +{- +[W] F alpha ~ alpha +[W] F alpha ~ beta +[W] G alpha beta ~ Int +-} + +foo :: (F a ~ a, F a ~ b) => G a b -> () +foo _ = () + +bar :: () +bar = foo True + +{- +[G] F a ~ a +[W] F alpha ~ alpha +[W] F alpha ~ F a +-} + +notAmbig :: F a ~ a => F a +notAmbig = undefined diff --git a/testsuite/tests/indexed-types/should_compile/GivenLoop.hs b/testsuite/tests/indexed-types/should_compile/GivenLoop.hs new file mode 100644 index 0000000000..d8ece8cb26 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/GivenLoop.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TypeFamilies #-} + +module GivenLoop where + +type family UnMaybe a where + UnMaybe (Maybe b) = b + +class C c where + meth :: c + +instance C (Maybe d) where + meth = Nothing + +f :: (e ~ Maybe (UnMaybe e)) => e +f = meth diff --git a/testsuite/tests/indexed-types/should_compile/Simple13.hs b/testsuite/tests/indexed-types/should_compile/Simple13.hs index 9e463e8e05..d4e39a9335 100644 --- a/testsuite/tests/indexed-types/should_compile/Simple13.hs +++ b/testsuite/tests/indexed-types/should_compile/Simple13.hs @@ -21,7 +21,7 @@ foo p = same p (mkf p) [G] g : a ~ [F a] [W] w : a ~ [F a] ----> +---> g' = g;[x] g'=aq4 [G] g' : a ~ [fsk] g=aqW [W] x : F a ~ fsk x=aq3 @@ -36,7 +36,7 @@ foo p = same p (mkf p) w = g' ; w2 [W] w2 : [fsk] ~ [F a] - --> decompose + --> decompose w2 = [w3] [W] w3 : fsk ~ F a @@ -44,5 +44,5 @@ foo p = same p (mkf p) cycle is aq3 = Sym (F aq4) ; aq5 x = Sym (F g') ; x2 - aq4 = apw ; aq3 g' = + aq4 = apw ; aq3 g' = -} diff --git a/testsuite/tests/indexed-types/should_compile/T18875.hs b/testsuite/tests/indexed-types/should_compile/T18875.hs new file mode 100644 index 0000000000..60fd1cb86a --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T18875.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} + +module T18875 where + +-- This exercises Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical + +type family G a b where + G (Maybe c) d = d + +h :: (e ~ Maybe (G e f)) => e -> f +h (Just x) = x diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr index 20032b6ad4..a860b3c76b 100644 --- a/testsuite/tests/indexed-types/should_compile/T3017.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr @@ -4,7 +4,7 @@ TYPE SIGNATURES insert :: forall c. Coll c => Elem c -> c -> c test2 :: forall {c} {a} {b}. - (Coll c, Num a, Num b, Elem c ~ (a, b)) => + (Elem c ~ (a, b), Coll c, Num a, Num b) => c -> c TYPE CONSTRUCTORS class Coll{1} :: * -> Constraint @@ -20,4 +20,4 @@ CLASS INSTANCES FAMILY INSTANCES type instance Elem (ListColl a) = a -- Defined at T3017.hs:13:9 Dependent modules: [] -Dependent packages: [base-4.13.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.15.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T index 8b3dd5e866..285619f570 100644 --- a/testsuite/tests/indexed-types/should_compile/all.T +++ b/testsuite/tests/indexed-types/should_compile/all.T @@ -297,3 +297,6 @@ test('T17405', normal, multimod_compile, ['T17405c', '-v0']) test('T17923', normal, compile, ['']) test('T18065', normal, compile, ['-O']) test('T18809', normal, compile, ['-O']) +test('CEqCanOccursCheck', normal, compile, ['']) +test('GivenLoop', normal, compile, ['']) +test('T18875', normal, compile, ['']) diff --git a/testsuite/tests/indexed-types/should_fail/ExpandTFs.hs b/testsuite/tests/indexed-types/should_fail/ExpandTFs.hs new file mode 100644 index 0000000000..7a0915d298 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/ExpandTFs.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies, DataKinds #-} + +module ExpandTFs where + +-- from https://mail.haskell.org/pipermail/ghc-devs/2020-November/019366.html, +-- where it is requested to expand (Foo Int) in the error message + +type family Foo a where Foo Int = String +type family Bar a :: Maybe (Foo Int) where Bar a = '() diff --git a/testsuite/tests/indexed-types/should_fail/ExpandTFs.stderr b/testsuite/tests/indexed-types/should_fail/ExpandTFs.stderr new file mode 100644 index 0000000000..ff2daf734f --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/ExpandTFs.stderr @@ -0,0 +1,6 @@ + +ExpandTFs.hs:9:52: error: + • Couldn't match kind ‘()’ with ‘Maybe String’ + Expected kind ‘Maybe (Foo Int)’, but ‘'()’ has kind ‘()’ + • In the type ‘'()’ + In the type family declaration for ‘Bar’ diff --git a/testsuite/tests/indexed-types/should_fail/Simple13.stderr b/testsuite/tests/indexed-types/should_fail/Simple13.stderr new file mode 100644 index 0000000000..129ae473c5 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/Simple13.stderr @@ -0,0 +1,13 @@ + +Simple13.hs:17:17: error: + • Couldn't match type: F [F a] + with: F a + Expected: a + Actual: [F a] + NB: ‘F’ is a non-injective type family + • In the second argument of ‘same’, namely ‘(mkf p)’ + In the expression: same p (mkf p) + In an equation for ‘foo’: foo p = same p (mkf p) + • Relevant bindings include + p :: a (bound at Simple13.hs:17:5) + foo :: a -> a (bound at Simple13.hs:17:1) diff --git a/testsuite/tests/indexed-types/should_fail/T13784.stderr b/testsuite/tests/indexed-types/should_fail/T13784.stderr index 11b1a188f2..04156ccdc9 100644 --- a/testsuite/tests/indexed-types/should_fail/T13784.stderr +++ b/testsuite/tests/indexed-types/should_fail/T13784.stderr @@ -15,7 +15,7 @@ T13784.hs:29:28: error: T13784.hs:33:24: error: • Couldn't match type: Product (a : as0) - with: (b, Product (Divide b (a : as))) + with: (b, Product (a : Divide b as)) Expected: (b, Product (Divide b (a : as))) Actual: Product (a1 : as0) • In the expression: a :* divide as diff --git a/testsuite/tests/indexed-types/should_fail/T14369.stderr b/testsuite/tests/indexed-types/should_fail/T14369.stderr index d31a77b2fa..a3a9eb73f7 100644 --- a/testsuite/tests/indexed-types/should_fail/T14369.stderr +++ b/testsuite/tests/indexed-types/should_fail/T14369.stderr @@ -1,9 +1,20 @@ T14369.hs:29:5: error: - • Couldn't match type: Demote a - with: Demote a1 + • Couldn't match type ‘a’ with ‘a1’ Expected: Sing x -> Maybe (Demote a1) Actual: Sing x -> Demote (Maybe a) + ‘a’ is a rigid type variable bound by + the type signature for: + f :: forall {a} (x :: forall a1. Maybe a1) a1. + SingKind a1 => + Sing x -> Maybe (Demote a1) + at T14369.hs:28:1-80 + ‘a1’ is a rigid type variable bound by + the type signature for: + f :: forall {a} (x :: forall a1. Maybe a1) a1. + SingKind a1 => + Sing x -> Maybe (Demote a1) + at T14369.hs:28:1-80 • In the expression: fromSing In an equation for ‘f’: f = fromSing • Relevant bindings include diff --git a/testsuite/tests/indexed-types/should_fail/T2544.stderr b/testsuite/tests/indexed-types/should_fail/T2544.stderr index 40409c10cc..721267e75d 100644 --- a/testsuite/tests/indexed-types/should_fail/T2544.stderr +++ b/testsuite/tests/indexed-types/should_fail/T2544.stderr @@ -1,13 +1,13 @@ -T2544.hs:19:18: error: - • Couldn't match type: IxMap i0 - with: IxMap l - Expected: IxMap l [Int] - Actual: IxMap i0 [Int] +T2544.hs:19:12: error: + • Couldn't match type: IxMap i1 + with: IxMap r + Expected: IxMap (l :|: r) [Int] + Actual: BiApp (IxMap i0) (IxMap i1) [Int] NB: ‘IxMap’ is a non-injective type family - The type variable ‘i0’ is ambiguous - • In the first argument of ‘BiApp’, namely ‘empty’ - In the expression: BiApp empty empty + The type variable ‘i1’ is ambiguous + • In the expression: BiApp empty empty In an equation for ‘empty’: empty = BiApp empty empty + In the instance declaration for ‘Ix (l :|: r)’ • Relevant bindings include empty :: IxMap (l :|: r) [Int] (bound at T2544.hs:19:4) diff --git a/testsuite/tests/indexed-types/should_fail/T2627b.stderr b/testsuite/tests/indexed-types/should_fail/T2627b.stderr index b69883ab88..2db3dd6397 100644 --- a/testsuite/tests/indexed-types/should_fail/T2627b.stderr +++ b/testsuite/tests/indexed-types/should_fail/T2627b.stderr @@ -1,6 +1,6 @@ T2627b.hs:20:24: error: - • Could not deduce: Dual (Dual b0) ~ b0 + • Could not deduce: Dual (Dual a0) ~ a0 arising from a use of ‘conn’ from the context: (Dual a ~ b, Dual b ~ a) bound by the type signature for: @@ -13,7 +13,12 @@ T2627b.hs:20:24: error: Rd :: forall c d. (c -> Comm d) -> Comm (R c d), in an equation for ‘conn’ at T2627b.hs:20:7-10 - The type variable ‘b0’ is ambiguous + or from: b ~ W e f + bound by a pattern with constructor: + Wr :: forall e f. e -> Comm f -> Comm (W e f), + in an equation for ‘conn’ + at T2627b.hs:20:14-19 + The type variable ‘a0’ is ambiguous • In the expression: conn undefined undefined In an equation for ‘conn’: conn (Rd k) (Wr a r) = conn undefined undefined diff --git a/testsuite/tests/indexed-types/should_fail/T3330c.stderr b/testsuite/tests/indexed-types/should_fail/T3330c.stderr index 9222e6fffe..3947abddb6 100644 --- a/testsuite/tests/indexed-types/should_fail/T3330c.stderr +++ b/testsuite/tests/indexed-types/should_fail/T3330c.stderr @@ -3,14 +3,14 @@ T3330c.hs:25:43: error: • Couldn't match kind ‘*’ with ‘* -> *’ When matching types f1 :: * -> * - f1 x :: * - Expected: Der ((->) x) (f1 x) + Der f1 x :: * + Expected: Der ((->) x) (Der f1 x) Actual: R f1 • In the first argument of ‘plug’, namely ‘rf’ In the first argument of ‘Inl’, namely ‘(plug rf df x)’ In the expression: Inl (plug rf df x) • Relevant bindings include x :: x (bound at T3330c.hs:25:29) - df :: f1 x (bound at T3330c.hs:25:25) + df :: Der f1 x (bound at T3330c.hs:25:25) rf :: R f1 (bound at T3330c.hs:25:13) plug' :: R f -> Der f x -> x -> f x (bound at T3330c.hs:25:1) diff --git a/testsuite/tests/indexed-types/should_fail/T4174.stderr b/testsuite/tests/indexed-types/should_fail/T4174.stderr index ae962edf36..396fab9469 100644 --- a/testsuite/tests/indexed-types/should_fail/T4174.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4174.stderr @@ -1,9 +1,9 @@ T4174.hs:44:12: error: - • Couldn't match type ‘b’ with ‘RtsSpinLock’ + • Couldn't match type ‘a’ with ‘SmStep’ Expected: m (Field (Way (GHC6'8 minor) n t p) a b) Actual: m (Field (WayOf m) SmStep RtsSpinLock) - ‘b’ is a rigid type variable bound by + ‘a’ is a rigid type variable bound by the type signature for: testcase :: forall (m :: * -> *) minor n t p a b. Monad m => diff --git a/testsuite/tests/indexed-types/should_fail/T4179.stderr b/testsuite/tests/indexed-types/should_fail/T4179.stderr index 4665a1a321..545c03754d 100644 --- a/testsuite/tests/indexed-types/should_fail/T4179.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4179.stderr @@ -1,13 +1,13 @@ T4179.hs:26:16: error: - • Couldn't match type: A2 (x (A2 (FCon x) -> A3 (FCon x))) - with: A2 (FCon x) + • Couldn't match type: A3 (x (A2 (FCon x) -> A3 (FCon x))) + with: A3 (FCon x) Expected: x (A2 (FCon x) -> A3 (FCon x)) -> A2 (FCon x) -> A3 (FCon x) Actual: x (A2 (FCon x) -> A3 (FCon x)) -> A2 (x (A2 (FCon x) -> A3 (FCon x))) -> A3 (x (A2 (FCon x) -> A3 (FCon x))) - NB: ‘A2’ is a non-injective type family + NB: ‘A3’ is a non-injective type family • In the first argument of ‘foldDoC’, namely ‘op’ In the expression: foldDoC op In an equation for ‘fCon’: fCon = foldDoC op diff --git a/testsuite/tests/indexed-types/should_fail/T4272.stderr b/testsuite/tests/indexed-types/should_fail/T4272.stderr index 69df514c0f..c921445d2e 100644 --- a/testsuite/tests/indexed-types/should_fail/T4272.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4272.stderr @@ -1,17 +1,16 @@ -T4272.hs:15:26: error: - • Couldn't match type ‘a’ with ‘TermFamily a a’ - Expected: TermFamily a (TermFamily a a) - Actual: TermFamily a a +T4272.hs:15:19: error: + • Couldn't match expected type ‘TermFamily a a’ + with actual type ‘a’ ‘a’ is a rigid type variable bound by the type signature for: laws :: forall a b. TermLike a => TermFamily a a -> b at T4272.hs:14:1-53 - • In the first argument of ‘terms’, namely - ‘(undefined :: TermFamily a a)’ - In the second argument of ‘prune’, namely + • In the second argument of ‘prune’, namely ‘(terms (undefined :: TermFamily a a))’ In the expression: prune t (terms (undefined :: TermFamily a a)) + In an equation for ‘laws’: + laws t = prune t (terms (undefined :: TermFamily a a)) • Relevant bindings include t :: TermFamily a a (bound at T4272.hs:15:6) laws :: TermFamily a a -> b (bound at T4272.hs:15:1) diff --git a/testsuite/tests/indexed-types/should_fail/T5934.stderr b/testsuite/tests/indexed-types/should_fail/T5934.stderr index 48f8bacef5..9024f516b8 100644 --- a/testsuite/tests/indexed-types/should_fail/T5934.stderr +++ b/testsuite/tests/indexed-types/should_fail/T5934.stderr @@ -1,8 +1,11 @@ T5934.hs:12:7: error: - • Couldn't match expected type ‘(forall s. GenST s) -> Int’ - with actual type ‘a0’ + • Couldn't match type ‘a0’ + with ‘(forall s. Gen (PrimState (ST s))) -> Int’ + Expected: (forall s. GenST s) -> Int + Actual: a0 Cannot instantiate unification variable ‘a0’ - with a type involving polytypes: (forall s. GenST s) -> Int + with a type involving polytypes: + (forall s. Gen (PrimState (ST s))) -> Int • In the expression: 0 In an equation for ‘run’: run = 0 diff --git a/testsuite/tests/indexed-types/should_fail/T7788.stderr b/testsuite/tests/indexed-types/should_fail/T7788.stderr index e591fa9b63..65c78aea3b 100644 --- a/testsuite/tests/indexed-types/should_fail/T7788.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7788.stderr @@ -1,7 +1,7 @@ T7788.hs:9:7: error: • Reduction stack overflow; size = 201 - When simplifying the following type: F (Fix Id) + When simplifying the following type: F (Id (Fix Id)) Use -freduction-depth=0 to disable this check (any upper bound you could choose might fail unpredictably with minor updates to GHC, so disabling the check is recommended if diff --git a/testsuite/tests/indexed-types/should_fail/T8227.stderr b/testsuite/tests/indexed-types/should_fail/T8227.stderr index 99d1763163..0c8cef576d 100644 --- a/testsuite/tests/indexed-types/should_fail/T8227.stderr +++ b/testsuite/tests/indexed-types/should_fail/T8227.stderr @@ -1,10 +1,8 @@ T8227.hs:17:27: error: - • Couldn't match type: Scalar (V a) - with: Scalar (V a) -> Scalar (V a) - Expected: Scalar (V a) - Actual: Scalar (V (Scalar (V a) -> Scalar (V a))) - -> Scalar (V (Scalar (V a) -> Scalar (V a))) + • Couldn't match expected type: Scalar (V a) + with actual type: Scalar (V (Scalar (V a))) + -> Scalar (V (Scalar (V a))) • In the expression: arcLengthToParam eps eps In an equation for ‘absoluteToParam’: absoluteToParam eps seg = arcLengthToParam eps eps @@ -13,3 +11,17 @@ T8227.hs:17:27: error: eps :: Scalar (V a) (bound at T8227.hs:17:17) absoluteToParam :: Scalar (V a) -> a -> Scalar (V a) (bound at T8227.hs:17:1) + +T8227.hs:17:44: error: + • Couldn't match expected type: Scalar (V (Scalar (V a))) + with actual type: Scalar (V a) + NB: ‘Scalar’ is a non-injective type family + • In the first argument of ‘arcLengthToParam’, namely ‘eps’ + In the expression: arcLengthToParam eps eps + In an equation for ‘absoluteToParam’: + absoluteToParam eps seg = arcLengthToParam eps eps + • Relevant bindings include + seg :: a (bound at T8227.hs:17:21) + eps :: Scalar (V a) (bound at T8227.hs:17:17) + absoluteToParam :: Scalar (V a) -> a -> Scalar (V a) + (bound at T8227.hs:17:1) diff --git a/testsuite/tests/indexed-types/should_fail/T8518.stderr b/testsuite/tests/indexed-types/should_fail/T8518.stderr index 1f244f9ee2..89ba8308a1 100644 --- a/testsuite/tests/indexed-types/should_fail/T8518.stderr +++ b/testsuite/tests/indexed-types/should_fail/T8518.stderr @@ -1,10 +1,9 @@ T8518.hs:14:18: error: - • Couldn't match expected type: Z c -> B c -> Maybe (F c) - with actual type: F c - • The function ‘rpt’ is applied to four value arguments, - but its type ‘Int -> c -> F c’ has only two - In the expression: rpt (4 :: Int) c z b + • Couldn't match type: F c + with: Z c -> B c -> F c + arising from a use of ‘rpt’ + • In the expression: rpt (4 :: Int) c z b In an equation for ‘callCont’: callCont c z b = rpt (4 :: Int) c z b @@ -16,17 +15,3 @@ T8518.hs:14:18: error: z :: Z c (bound at T8518.hs:14:12) c :: c (bound at T8518.hs:14:10) callCont :: c -> Z c -> B c -> Maybe (F c) (bound at T8518.hs:14:1) - -T8518.hs:16:9: error: - • Couldn't match type: F t1 - with: Z t1 -> B t1 -> F t1 - Expected: t -> t1 -> F t1 - Actual: t -> t1 -> Z t1 -> B t1 -> F t1 - • In an equation for ‘callCont’: - callCont c z b - = rpt (4 :: Int) c z b - where - rpt 0 c' z' b' = fromJust (fst <$> (continue c' z' b')) - rpt i c' z' b' = let ... in rpt (i - 1) c'' - • Relevant bindings include - rpt :: t -> t1 -> F t1 (bound at T8518.hs:16:9) diff --git a/testsuite/tests/indexed-types/should_fail/T9554.stderr b/testsuite/tests/indexed-types/should_fail/T9554.stderr index 2bd5c2ab75..b62badda9d 100644 --- a/testsuite/tests/indexed-types/should_fail/T9554.stderr +++ b/testsuite/tests/indexed-types/should_fail/T9554.stderr @@ -2,7 +2,7 @@ T9554.hs:11:9: error: • Reduction stack overflow; size = 201 When simplifying the following type: - F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F Bool)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F Bool))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) Use -freduction-depth=0 to disable this check (any upper bound you could choose might fail unpredictably with minor updates to GHC, so disabling the check is recommended if @@ -13,7 +13,7 @@ T9554.hs:11:9: error: T9554.hs:13:17: error: • Reduction stack overflow; size = 201 When simplifying the following type: - F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F Bool)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F Bool))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) Use -freduction-depth=0 to disable this check (any upper bound you could choose might fail unpredictably with minor updates to GHC, so disabling the check is recommended if diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T index 428ab8d4f1..9d2c68f095 100644 --- a/testsuite/tests/indexed-types/should_fail/all.T +++ b/testsuite/tests/indexed-types/should_fail/all.T @@ -163,3 +163,4 @@ test('T17008a', normal, compile_fail, ['-fprint-explicit-kinds']) test('T13571', normal, compile_fail, ['']) test('T13571a', normal, compile_fail, ['']) test('T18648', normal, compile_fail, ['']) +test('ExpandTFs', normal, compile_fail, ['']) diff --git a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr index ea48244e0c..7a0ad230f4 100644 --- a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr @@ -65,7 +65,7 @@ SplicesUsed.hs:16:2: warning: [-Wpartial-type-signatures (in -Wdefault)] • In the type signature: foo :: _ => _ SplicesUsed.hs:16:2: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Eq a’ + • Found extra-constraints wildcard standing for ‘Eq a’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: Eq a => a -> a -> Bool at SplicesUsed.hs:16:2-11 diff --git a/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr b/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr index a11164482c..0f1a1fa77b 100644 --- a/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr @@ -1,4 +1,4 @@ SuperCls.hs:4:14: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘()’ + • Found extra-constraints wildcard standing for ‘()’ • In the type signature: f :: (Ord a, _) => a -> Bool diff --git a/testsuite/tests/partial-sigs/should_compile/T10403.stderr b/testsuite/tests/partial-sigs/should_compile/T10403.stderr index a3cdc763fc..1a7162d612 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10403.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10403.stderr @@ -1,6 +1,6 @@ T10403.hs:15:7: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Functor f’ + • Found extra-constraints wildcard standing for ‘Functor f’ Where: ‘f’ is a rigid type variable bound by the inferred type of h1 :: Functor f => (a -> a1) -> f a -> H f at T10403.hs:17:1-41 diff --git a/testsuite/tests/partial-sigs/should_compile/T10519.stderr b/testsuite/tests/partial-sigs/should_compile/T10519.stderr index 13f1104da7..d2db5da38e 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10519.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10519.stderr @@ -1,6 +1,6 @@ T10519.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Eq a’ + • Found extra-constraints wildcard standing for ‘Eq a’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: Eq a => a -> a -> Bool at T10519.hs:5:15 diff --git a/testsuite/tests/partial-sigs/should_compile/T11016.stderr b/testsuite/tests/partial-sigs/should_compile/T11016.stderr index 49363fb24c..8d3ffe4cf5 100644 --- a/testsuite/tests/partial-sigs/should_compile/T11016.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T11016.stderr @@ -1,6 +1,6 @@ T11016.hs:5:19: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘()’ + • Found extra-constraints wildcard standing for ‘()’ • In the type signature: f1 :: (?x :: Int, _) => Int T11016.hs:8:22: warning: [-Wpartial-type-signatures (in -Wdefault)] diff --git a/testsuite/tests/partial-sigs/should_compile/T11670.stderr b/testsuite/tests/partial-sigs/should_compile/T11670.stderr index 87e36e5fc5..2d26722373 100644 --- a/testsuite/tests/partial-sigs/should_compile/T11670.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T11670.stderr @@ -9,7 +9,7 @@ T11670.hs:10:42: warning: [-Wpartial-type-signatures (in -Wdefault)] peek :: Ptr a -> IO CLong (bound at T11670.hs:10:1) T11670.hs:13:40: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Storable w’ + • Found extra-constraints wildcard standing for ‘Storable w’ Where: ‘w’ is a rigid type variable bound by the inferred type of <expression> :: Storable w => IO w at T11670.hs:13:40-48 diff --git a/testsuite/tests/partial-sigs/should_compile/T12844.stderr b/testsuite/tests/partial-sigs/should_compile/T12844.stderr index 3d8031143c..331570aa93 100644 --- a/testsuite/tests/partial-sigs/should_compile/T12844.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T12844.stderr @@ -1,10 +1,10 @@ T12844.hs:12:9: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ - standing for ‘(Foo rngs, Head rngs ~ '(r, r'))’ - Where: ‘rngs’, ‘k’, ‘r’, ‘k1’, ‘r'’ + • Found extra-constraints wildcard standing for + ‘(Head rngs ~ '(r, r'), Foo rngs)’ + Where: ‘r’, ‘r'’, ‘k’, ‘k1’, ‘rngs’ are rigid type variables bound by the inferred type of - bar :: (Foo rngs, Head rngs ~ '(r, r')) => FooData rngs + bar :: (Head rngs ~ '(r, r'), Foo rngs) => FooData rngs at T12844.hs:(12,1)-(13,9) • In the type signature: bar :: _ => FooData rngs diff --git a/testsuite/tests/partial-sigs/should_compile/T12845.stderr b/testsuite/tests/partial-sigs/should_compile/T12845.stderr index 0ca72ce5e3..fb7cc70db4 100644 --- a/testsuite/tests/partial-sigs/should_compile/T12845.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T12845.stderr @@ -1,6 +1,6 @@ T12845.hs:18:70: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘()’ + • Found extra-constraints wildcard standing for ‘()’ • In the type signature: broken :: forall r r' rngs. ('(r, r') ~ Head rngs, Bar r r' ~ 'True, _) => diff --git a/testsuite/tests/partial-sigs/should_compile/T13482.stderr b/testsuite/tests/partial-sigs/should_compile/T13482.stderr index dc2b156703..85cd1115dc 100644 --- a/testsuite/tests/partial-sigs/should_compile/T13482.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T13482.stderr @@ -1,6 +1,6 @@ T13482.hs:10:32: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘(Eq m, Monoid m)’ + • Found extra-constraints wildcard standing for ‘(Eq m, Monoid m)’ Where: ‘m’ is a rigid type variable bound by the inferred type of minimal1_noksig :: (Eq m, Monoid m) => Int -> Bool @@ -9,21 +9,21 @@ T13482.hs:10:32: warning: [-Wpartial-type-signatures (in -Wdefault)] minimal1_noksig :: forall m. _ => Int -> Bool T13482.hs:13:33: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘(Eq m, Monoid m)’ + • Found extra-constraints wildcard standing for ‘(Eq m, Monoid m)’ Where: ‘m’ is a rigid type variable bound by the inferred type of minimal1 :: (Eq m, Monoid m) => Bool at T13482.hs:13:21 • In the type signature: minimal1 :: forall (m :: Type). _ => Bool T13482.hs:16:30: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Monoid m’ + • Found extra-constraints wildcard standing for ‘Monoid m’ Where: ‘m’ is a rigid type variable bound by the inferred type of minimal2 :: (Eq m, Monoid m) => Bool at T13482.hs:16:20 • In the type signature: minimal2 :: forall m. (Eq m, _) => Bool T13482.hs:19:34: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Eq m’ + • Found extra-constraints wildcard standing for ‘Eq m’ Where: ‘m’ is a rigid type variable bound by the inferred type of minimal3 :: (Monoid m, Eq m) => Bool at T13482.hs:19:20 diff --git a/testsuite/tests/partial-sigs/should_compile/T14217.stderr b/testsuite/tests/partial-sigs/should_compile/T14217.stderr index 97f7854cdf..913753be98 100644 --- a/testsuite/tests/partial-sigs/should_compile/T14217.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T14217.stderr @@ -1,14 +1,14 @@ T14217.hs:32:11: error: - • Found type wildcard ‘_’ - standing for ‘(Eq a1, Eq a2, Eq a3, Eq a4, Eq a5, Eq a6, Eq a7, - Eq a8, Eq a9, Eq a10, Eq a11, Eq a12, Eq a13, Eq a14, Eq a15, - Eq a16, Eq a17, Eq a18, Eq a19, Eq a20, Eq a21, Eq a22, Eq a23, - Eq a24, Eq a25, Eq a26, Eq a27, Eq a28, Eq a29, Eq a30, Eq a31, - Eq a32, Eq a33, Eq a34, Eq a35, Eq a36, Eq a37, Eq a38, Eq a39, - Eq a40, Eq a41, Eq a42, Eq a43, Eq a44, Eq a45, Eq a46, Eq a47, - Eq a48, Eq a49, Eq a50, Eq a51, Eq a52, Eq a53, Eq a54, Eq a55, - Eq a56, Eq a57, Eq a58, Eq a59, Eq a60, Eq a61, Eq a62, Eq a63)’ + • Found extra-constraints wildcard standing for + ‘(Eq a1, Eq a2, Eq a3, Eq a4, Eq a5, Eq a6, Eq a7, Eq a8, Eq a9, + Eq a10, Eq a11, Eq a12, Eq a13, Eq a14, Eq a15, Eq a16, Eq a17, + Eq a18, Eq a19, Eq a20, Eq a21, Eq a22, Eq a23, Eq a24, Eq a25, + Eq a26, Eq a27, Eq a28, Eq a29, Eq a30, Eq a31, Eq a32, Eq a33, + Eq a34, Eq a35, Eq a36, Eq a37, Eq a38, Eq a39, Eq a40, Eq a41, + Eq a42, Eq a43, Eq a44, Eq a45, Eq a46, Eq a47, Eq a48, Eq a49, + Eq a50, Eq a51, Eq a52, Eq a53, Eq a54, Eq a55, Eq a56, Eq a57, + Eq a58, Eq a59, Eq a60, Eq a61, Eq a62, Eq a63)’ Where: ‘a1’, ‘a2’, ‘a3’, ‘a4’, ‘a5’, ‘a6’, ‘a7’, ‘a8’, ‘a9’, ‘a10’, ‘a11’, ‘a12’, ‘a13’, ‘a14’, ‘a15’, ‘a16’, ‘a17’, ‘a18’, ‘a19’, ‘a20’, ‘a21’, ‘a22’, ‘a23’, ‘a24’, ‘a25’, ‘a26’, ‘a27’, ‘a28’, diff --git a/testsuite/tests/partial-sigs/should_compile/T14643.stderr b/testsuite/tests/partial-sigs/should_compile/T14643.stderr index 60288670fb..e2dd144bd3 100644 --- a/testsuite/tests/partial-sigs/should_compile/T14643.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T14643.stderr @@ -1,8 +1,8 @@ T14643.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘()’ + • Found extra-constraints wildcard standing for ‘()’ • In the type signature: ag :: (Num a, _) => a -> a T14643.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘()’ + • Found extra-constraints wildcard standing for ‘()’ • In the type signature: af :: (Num a, _) => a -> a diff --git a/testsuite/tests/partial-sigs/should_compile/T14643a.stderr b/testsuite/tests/partial-sigs/should_compile/T14643a.stderr index 1514ac92ed..6f41472472 100644 --- a/testsuite/tests/partial-sigs/should_compile/T14643a.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T14643a.stderr @@ -1,8 +1,8 @@ T14643a.hs:5:14: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘()’ + • Found extra-constraints wildcard standing for ‘()’ • In the type signature: af :: (Num a, _) => a -> a T14643a.hs:8:14: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘()’ + • Found extra-constraints wildcard standing for ‘()’ • In the type signature: ag :: (Num a, _) => a -> a diff --git a/testsuite/tests/partial-sigs/should_compile/T14715.stderr b/testsuite/tests/partial-sigs/should_compile/T14715.stderr index 901ece018f..e352f0d644 100644 --- a/testsuite/tests/partial-sigs/should_compile/T14715.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T14715.stderr @@ -1,6 +1,7 @@ T14715.hs:13:53: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Reduce (LiftOf zq) zq’ + • Found extra-constraints wildcard standing for + ‘Reduce (LiftOf zq) zq’ Where: ‘zq’ is a rigid type variable bound by the inferred type of bench_mulPublic :: (z ~ LiftOf zq, Reduce (LiftOf zq) zq) => diff --git a/testsuite/tests/partial-sigs/should_compile/T15039a.stderr b/testsuite/tests/partial-sigs/should_compile/T15039a.stderr index e52d911cac..1f07a650ac 100644 --- a/testsuite/tests/partial-sigs/should_compile/T15039a.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T15039a.stderr @@ -48,7 +48,7 @@ T15039a.hs:33:14: warning: [-Wpartial-type-signatures (in -Wdefault)] ex6 :: Dict (Coercible a b) -> () (bound at T15039a.hs:33:1) T15039a.hs:35:8: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Coercible a b’ + • Found extra-constraints wildcard standing for ‘Coercible a b’ Where: ‘a’, ‘b’ are rigid type variables bound by the inferred type of ex7 :: Coercible a b => Coercion a b at T15039a.hs:35:1-44 diff --git a/testsuite/tests/partial-sigs/should_compile/T15039b.stderr b/testsuite/tests/partial-sigs/should_compile/T15039b.stderr index da14f26a17..73d366eb65 100644 --- a/testsuite/tests/partial-sigs/should_compile/T15039b.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T15039b.stderr @@ -49,7 +49,8 @@ T15039b.hs:33:14: warning: [-Wpartial-type-signatures (in -Wdefault)] ex6 :: Dict (Coercible @(*) a b) -> () (bound at T15039b.hs:33:1) T15039b.hs:35:8: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Coercible @(*) a b’ + • Found extra-constraints wildcard standing for + ‘Coercible @(*) a b’ Where: ‘a’, ‘b’ are rigid type variables bound by the inferred type of ex7 :: Coercible @(*) a b => Coercion @{*} a b at T15039b.hs:35:1-44 diff --git a/testsuite/tests/partial-sigs/should_compile/T15039c.stderr b/testsuite/tests/partial-sigs/should_compile/T15039c.stderr index c7ad5e861b..658c30c2b7 100644 --- a/testsuite/tests/partial-sigs/should_compile/T15039c.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T15039c.stderr @@ -48,7 +48,7 @@ T15039c.hs:33:14: warning: [-Wpartial-type-signatures (in -Wdefault)] ex6 :: Dict (Coercible a b) -> () (bound at T15039c.hs:33:1) T15039c.hs:35:8: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Coercible a b’ + • Found extra-constraints wildcard standing for ‘Coercible a b’ Where: ‘a’, ‘b’ are rigid type variables bound by the inferred type of ex7 :: Coercible a b => Coercion a b at T15039c.hs:35:1-44 diff --git a/testsuite/tests/partial-sigs/should_compile/T15039d.stderr b/testsuite/tests/partial-sigs/should_compile/T15039d.stderr index 68882c391f..587b64126a 100644 --- a/testsuite/tests/partial-sigs/should_compile/T15039d.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T15039d.stderr @@ -50,7 +50,8 @@ T15039d.hs:33:14: warning: [-Wpartial-type-signatures (in -Wdefault)] ex6 :: Dict (Coercible @(*) a b) -> () (bound at T15039d.hs:33:1) T15039d.hs:35:8: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Coercible @(*) a b’ + • Found extra-constraints wildcard standing for + ‘Coercible @(*) a b’ Where: ‘a’, ‘b’ are rigid type variables bound by the inferred type of ex7 :: Coercible @(*) a b => Coercion @{*} a b at T15039d.hs:35:1-44 diff --git a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr index 5dc9b0797e..e9f875b6a3 100644 --- a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr +++ b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr @@ -2,7 +2,7 @@ TYPE SIGNATURES bar :: forall {t} {w}. t -> (t -> w) -> w foo :: forall {a}. (Show a, Enum a) => a -> String Dependent modules: [] -Dependent packages: [base-4.14.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.15.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] WarningWildcardInstantiations.hs:5:14: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_a’ standing for ‘a’ @@ -12,7 +12,7 @@ WarningWildcardInstantiations.hs:5:14: warning: [-Wpartial-type-signatures (in - • In the type signature: foo :: (Show _a, _) => _a -> _ WarningWildcardInstantiations.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Enum a’ + • Found extra-constraints wildcard standing for ‘Enum a’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: (Show a, Enum a) => a -> String at WarningWildcardInstantiations.hs:6:1-21 diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr index 6978418c46..823b1f9e5e 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr @@ -1,6 +1,6 @@ ExtraConstraintsWildcardInExpressionSignature.hs:5:20: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Eq a1’ + • Found extra-constraints wildcard standing for ‘Eq a1’ Where: ‘a1’ is a rigid type variable bound by the inferred type of <expression> :: Eq a1 => a1 -> a1 -> Bool at ExtraConstraintsWildcardInExpressionSignature.hs:5:20-25 diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr index 3fc90ec240..496e1a7393 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr @@ -1,6 +1,6 @@ ExtraConstraintsWildcardNotEnabled.hs:4:10: error: - • Found type wildcard ‘_’ standing for ‘Show a’ + • Found extra-constraints wildcard standing for ‘Show a’ Where: ‘a’ is a rigid type variable bound by the inferred type of show' :: Show a => a -> String at ExtraConstraintsWildcardNotEnabled.hs:4:1-25 diff --git a/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr index 83663188fc..9e9505d7f0 100644 --- a/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr +++ b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr @@ -8,7 +8,7 @@ InstantiatedNamedWildcardsInConstraints.hs:4:14: error: • In the type signature: foo :: (Enum _a, _) => _a -> (String, b) InstantiatedNamedWildcardsInConstraints.hs:4:18: error: - • Found type wildcard ‘_’ standing for ‘Show b’ + • Found extra-constraints wildcard standing for ‘Show b’ Where: ‘b’ is a rigid type variable bound by the inferred type of foo :: (Enum b, Show b) => b -> (String, b) at InstantiatedNamedWildcardsInConstraints.hs:4:1-40 diff --git a/testsuite/tests/partial-sigs/should_fail/T10999.stderr b/testsuite/tests/partial-sigs/should_fail/T10999.stderr index b0697fe60b..356b068031 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10999.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T10999.stderr @@ -1,6 +1,6 @@ T10999.hs:5:6: error: - • Found type wildcard ‘_’ standing for ‘Ord a’ + • Found extra-constraints wildcard standing for ‘Ord a’ Where: ‘a’ is a rigid type variable bound by the inferred type of f :: Ord a => () -> Set.Set a at T10999.hs:6:1-28 diff --git a/testsuite/tests/partial-sigs/should_fail/T11515.stderr b/testsuite/tests/partial-sigs/should_fail/T11515.stderr index 2870457500..df8da03208 100644 --- a/testsuite/tests/partial-sigs/should_fail/T11515.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T11515.stderr @@ -1,5 +1,5 @@ T11515.hs:7:20: error: - • Found type wildcard ‘_’ standing for ‘()’ + • Found extra-constraints wildcard standing for ‘()’ To use the inferred type, enable PartialTypeSignatures • In the type signature: foo :: (ShowSyn a, _) => a -> String diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr index a7e31fd8c9..827356a7ae 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr @@ -8,7 +8,7 @@ WildcardInstantiations.hs:5:14: error: • In the type signature: foo :: (Show _a, _) => _a -> _ WildcardInstantiations.hs:5:18: error: - • Found type wildcard ‘_’ standing for ‘Enum a’ + • Found extra-constraints wildcard standing for ‘Enum a’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: (Show a, Enum a) => a -> String at WildcardInstantiations.hs:6:1-21 diff --git a/testsuite/tests/polykinds/T14172.stderr b/testsuite/tests/polykinds/T14172.stderr index 0f5d0271b4..3496b04538 100644 --- a/testsuite/tests/polykinds/T14172.stderr +++ b/testsuite/tests/polykinds/T14172.stderr @@ -11,11 +11,9 @@ T14172.hs:6:46: error: In the type ‘(a -> f b) -> g a -> f (h _)’ T14172.hs:7:19: error: - • Couldn't match type ‘a’ with ‘g'0 a’ - Expected: (f'0 a -> f (f'0 b)) -> Compose f'0 g'0 a -> f (h a') - Actual: (Unwrapped (Compose f'0 g'0 a) -> f (Unwrapped (h a'))) - -> Compose f'0 g'0 a -> f (h a') - ‘a’ is a rigid type variable bound by + • Couldn't match type ‘h’ with ‘Compose f'0 g'0’ + arising from a use of ‘_Wrapping’ + ‘h’ is a rigid type variable bound by the inferred type of traverseCompose :: (a -> f b) -> g a -> f (h a') at T14172.hs:6:1-47 diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr index bfc62cc196..c3bfb99faa 100644 --- a/testsuite/tests/roles/should_compile/Roles3.stderr +++ b/testsuite/tests/roles/should_compile/Roles3.stderr @@ -21,7 +21,7 @@ COERCION AXIOMS axiom Roles3.N:C3 :: C3 a b = a -> F3 b -> F3 b axiom Roles3.N:C4 :: C4 a b = a -> F4 b -> F4 b Dependent modules: [] -Dependent packages: [base-4.15.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] ==================== Typechecker ==================== Roles3.$tcC4 @@ -53,12 +53,12 @@ $krep [InlPrag=[~]] = GHC.Types.KindRepVar 1 $krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep -$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep -$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep $krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep +$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint [] +$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Types.KindRepTyConApp GHC.Types.$tc~ ((:) GHC.Types.krep$* ((:) $krep ((:) $krep []))) diff --git a/testsuite/tests/typecheck/should_compile/CbvOverlap.hs b/testsuite/tests/typecheck/should_compile/CbvOverlap.hs new file mode 100644 index 0000000000..4e3b40f161 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/CbvOverlap.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts #-} + +module CbvOverlap where + +-- This is concerned with Note [Type variable cycles in Givens] and class lookup + +class C a where + meth :: a -> () + +instance C Int where + meth _ = () + +type family F a + +foo :: C (F a) => a -> Int -> () +foo _ n = meth n diff --git a/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap.hs b/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap.hs new file mode 100644 index 0000000000..765379a203 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, + TypeFamilies, FlexibleContexts, AllowAmbiguousTypes #-} + +module InstanceGivenOverlap where + +-- See Note [Instance and Given overlap] in GHC.Tc.Solver.Interact. +-- This tests the Note when the Wanted contains a type family. + +class P a +class Q a +class R a b + +instance P x => Q [x] +instance (x ~ y) => R y [x] + +type family F a b where + F [a] a = a + +wob :: forall a b. (Q [F a b], R b a) => a -> Int +wob = undefined + +g :: forall a. Q [a] => [a] -> Int +g x = wob x diff --git a/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap2.hs b/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap2.hs new file mode 100644 index 0000000000..67c475ee23 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap2.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes, TypeApplications, + TypeFamilies, PolyKinds, DataKinds, FlexibleInstances, + MultiParamTypeClasses, FlexibleContexts, PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +module InstanceGivenOverlap2 where + +import Data.Proxy + +class P a +class Q a +class R a b + +newtype Tagged (t :: k) a = Tagged a + +type family F a +type instance F (Tagged @Bool t a) = [a] + +instance P x => Q [x] +instance (x ~ y) => R y [x] + +wob :: forall a b. (Q [b], R b a) => a -> Int +wob = undefined + +it'sABoolNow :: forall (t :: Bool). Int +it'sABoolNow = undefined + +class HasBoolKind t +instance k ~ Bool => HasBoolKind (t :: k) + +it'sABoolLater :: forall t. HasBoolKind t => Int +it'sABoolLater = undefined + +g :: forall t a. Q (F (Tagged t a)) => Proxy t -> [a] -> _ +g _ x = it'sABoolNow @t + wob x + +g2 :: forall t a. Q (F (Tagged t a)) => Proxy t -> [a] -> _ +g2 _ x = wob x + it'sABoolNow @t + +g3 :: forall t a. Q (F (Tagged t a)) => Proxy t -> [a] -> _ +g3 _ x = it'sABoolLater @t + wob x + +g4 :: forall t a. Q (F (Tagged t a)) => Proxy t -> [a] -> _ +g4 _ x = wob x + it'sABoolLater @t diff --git a/testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs b/testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs new file mode 100644 index 0000000000..f1280205b2 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE RankNTypes, TypeFamilies, FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-missing-methods -Wno-unused-matches #-} + +module LocalGivenEqs where + +-- See Note [When does an implication have given equalities?] in GHC.Tc.Solver.Monad; +-- this tests custom treatment for LocalGivenEqs + +{- +I (Richard E) tried somewhat half-heartedly to minimize this, but failed. +The key bit is the use of the ECP constructor inside the lambda in happyReduction_508. +(The lack of a type signature on that is not at issue, I believe.) The type +of ECP is + (forall b. DisambECP b => PV (Located b)) -> ECP +So, the argument to ECP gets a [G] DisambECP b, which (via its superclass) grants +us [G] b ~ (Body b) GhcPs. In order to infer the type of happy_var_2, we need to +float some wanted out past this equality. We have Note [Let-bound skolems] +in GHC.Tc.Solver.Monad to consider this Given equality to be let-like, and thus +not prevent floating. But, note that the equality isn't quite let-like, because +it mentions b in its RHS. It thus triggers Note [Type variable cycles in Givens] +in GHC.Tc.Solver.Canonical. That Note says we change the situation to + [G] b ~ cbv GhcPs + [G] Body b ~ cbv +for some fresh CycleBreakerTv cbv. Now, our original equality looks to be let-like, +but the new cbv equality is *not* let-like -- note that the variable is on the RHS. +The solution is to consider any equality whose free variables are all at the current +level to not stop equalities from floating. These are called *local*. Because both +Givens are local in this way, they no longer prevent floating, and we can type-check +this example. +-} + +import Data.Kind ( Type ) +import GHC.Exts ( Any ) + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) +newtype HappyWrap201 = HappyWrap201 (ECP) +newtype HappyWrap205 = HappyWrap205 (([Located Token],Bool)) + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +type HappyAny = Any + +newtype ECP = + ECP { unECP :: forall b. DisambECP b => PV (Located b) } + +data PV a +data P a +data GhcPs +data Token +data Located a +data AnnKeywordId = AnnIf | AnnThen | AnnElse | AnnSemi +data AddAnn +data SrcSpan +type LHsExpr a = Located (HsExpr a) +data HsExpr a + +class b ~ (Body b) GhcPs => DisambECP b where + type Body b :: Type -> Type + mkHsIfPV :: SrcSpan + -> LHsExpr GhcPs + -> Bool -- semicolon? + -> Located b + -> Bool -- semicolon? + -> Located b + -> PV (Located b) + +instance DisambECP (HsExpr GhcPs) where + type Body (HsExpr GhcPs) = HsExpr + mkHsIfPV = undefined + +instance Functor P +instance Applicative P +instance Monad P + +instance Functor PV +instance Applicative PV +instance Monad PV + +mj :: AnnKeywordId -> Located e -> AddAnn +mj = undefined + +amms :: Monad m => m (Located a) -> [AddAnn] -> m (Located a) +amms = undefined + +happyIn208 :: ECP -> HappyAbsSyn +happyIn208 = undefined + +happyReturn :: () => a -> P a +happyReturn = (return) + +happyThen :: () => P a -> (a -> P b) -> P b +happyThen = (>>=) + +comb2 :: Located a -> Located b -> SrcSpan +comb2 = undefined + +runPV :: PV a -> P a +runPV = undefined + +happyOutTok :: HappyAbsSyn -> Located Token +happyOutTok = undefined + +happyOut201 :: HappyAbsSyn -> HappyWrap201 +happyOut201 = undefined + +happyOut205 :: HappyAbsSyn -> HappyWrap205 +happyOut205 = undefined + +happyReduction_508 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut201 happy_x_2 of { (HappyWrap201 happy_var_2) -> + case happyOut205 happy_x_3 of { (HappyWrap205 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut201 happy_x_5 of { (HappyWrap201 happy_var_5) -> + case happyOut205 happy_x_6 of { (HappyWrap205 happy_var_6) -> + case happyOutTok happy_x_7 of { happy_var_7 -> + case happyOut201 happy_x_8 of { (HappyWrap201 happy_var_8) -> + -- uncomment this next signature to avoid the need + -- for special treatment of floating described above + ( runPV (unECP happy_var_2 {- :: PV (LHsExpr GhcPs) -}) >>= \ happy_var_2 -> + return $ ECP $ + unECP happy_var_5 >>= \ happy_var_5 -> + unECP happy_var_8 >>= \ happy_var_8 -> + amms (mkHsIfPV (comb2 happy_var_1 happy_var_8) happy_var_2 (snd happy_var_3) happy_var_5 (snd happy_var_6) happy_var_8) + (mj AnnIf happy_var_1:mj AnnThen happy_var_4 + :mj AnnElse happy_var_7 + :(map (\l -> mj AnnSemi l) (fst happy_var_3)) + ++(map (\l -> mj AnnSemi l) (fst happy_var_6))))}}}}}}}}) + ) (\r -> happyReturn (happyIn208 r)) diff --git a/testsuite/tests/typecheck/should_compile/LocalGivenEqs2.hs b/testsuite/tests/typecheck/should_compile/LocalGivenEqs2.hs new file mode 100644 index 0000000000..f15ab92de7 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/LocalGivenEqs2.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeFamilies, GADTSyntax, ExistentialQuantification #-} + +-- This is a simple case that exercises the LocalGivenEqs bullet +-- of Note [When does an implication have given equalities?] in GHC.Tc.Solver.Monad +-- If a future change rejects this, that's not the end of the world, but it's nice +-- to be able to infer `f`. + +module LocalGivenEqs2 where + +type family F a +type family G b + +data T where + MkT :: F a ~ G b => a -> b -> T + +f (MkT _ _) = True diff --git a/testsuite/tests/typecheck/should_compile/PolytypeDecomp.stderr b/testsuite/tests/typecheck/should_compile/PolytypeDecomp.stderr index bde2a0d703..0f1fd3e6c2 100644 --- a/testsuite/tests/typecheck/should_compile/PolytypeDecomp.stderr +++ b/testsuite/tests/typecheck/should_compile/PolytypeDecomp.stderr @@ -8,13 +8,3 @@ PolytypeDecomp.hs:30:17: error: • In the expression: x In the first argument of ‘myLength’, namely ‘[x, f]’ In the expression: myLength [x, f] - -PolytypeDecomp.hs:30:19: error: - • Couldn't match type ‘a0’ with ‘[forall a. F [a]]’ - Expected: Id a0 - Actual: [forall a. F [a]] - Cannot instantiate unification variable ‘a0’ - with a type involving polytypes: [forall a. F [a]] - • In the expression: f - In the first argument of ‘myLength’, namely ‘[x, f]’ - In the expression: myLength [x, f] diff --git a/testsuite/tests/typecheck/should_compile/T13651.stderr b/testsuite/tests/typecheck/should_compile/T13651.stderr index 150291c210..cc7af849d3 100644 --- a/testsuite/tests/typecheck/should_compile/T13651.stderr +++ b/testsuite/tests/typecheck/should_compile/T13651.stderr @@ -1,6 +1,6 @@ T13651.hs:11:8: error: - • Could not deduce: F cr (Bar (Foo h) (Foo u)) ~ Bar h (Bar r u) + • Could not deduce: F cr (Bar h (Foo u)) ~ Bar h (Bar r u) from the context: (F cr cu ~ Bar h (Bar r u), F cu cs ~ Bar (Foo h) (Bar u s)) bound by the type signature for: diff --git a/testsuite/tests/typecheck/should_compile/T15368.stderr b/testsuite/tests/typecheck/should_compile/T15368.stderr index 7f022744c4..33b0407730 100644 --- a/testsuite/tests/typecheck/should_compile/T15368.stderr +++ b/testsuite/tests/typecheck/should_compile/T15368.stderr @@ -15,8 +15,8 @@ T15368.hs:11:15: warning: [-Wtyped-holes (in -Wdefault)] trigger :: a -> b -> (F a b, F b a) (bound at T15368.hs:11:1) T15368.hs:11:15: warning: [-Wdeferred-type-errors (in -Wdefault)] - • Couldn't match type: F b a - with: F b0 a0 + • Couldn't match type: F b0 a0 + with: F b a Expected: (F a b, F b a) Actual: (F a b, F b0 a0) NB: ‘F’ is a non-injective type family diff --git a/testsuite/tests/typecheck/should_compile/T5490.hs b/testsuite/tests/typecheck/should_compile/T5490.hs index b5b7a2d98c..5679ee9baa 100644 --- a/testsuite/tests/typecheck/should_compile/T5490.hs +++ b/testsuite/tests/typecheck/should_compile/T5490.hs @@ -16,7 +16,7 @@ import Data.Functor import Control.Exception data Attempt α = Success α - | ∀ e . Exception e ⇒ Failure e + | ∀ e . Exception e ⇒ Failure e fromAttempt ∷ Attempt α → IO α fromAttempt (Success a) = return a @@ -136,7 +136,7 @@ instance IsPeano PZero where peano = PZero instance IsPeano p ⇒ IsPeano (PSucc p) where - peano = PSucc peano + peano = PSucc peano class (n ~ PSucc (PPred n)) ⇒ PHasPred n where type PPred n @@ -297,4 +297,3 @@ hGetIfNth _ _ = Nothing elem0 ∷ HNonEmpty l ⇒ HElemOf l → Maybe (HHead l) elem0 = hGetIfNth PZero - diff --git a/testsuite/tests/typecheck/should_compile/T9834.stderr b/testsuite/tests/typecheck/should_compile/T9834.stderr index 5963781325..2c410de0f2 100644 --- a/testsuite/tests/typecheck/should_compile/T9834.stderr +++ b/testsuite/tests/typecheck/should_compile/T9834.stderr @@ -1,11 +1,14 @@ T9834.hs:23:12: warning: [-Wdeferred-type-errors (in -Wdefault)] - • Couldn't match type ‘p’ with ‘(->) (p a0)’ + • Couldn't match type ‘a’ with ‘p a0’ Expected: p a Actual: p a0 -> p a0 - ‘p’ is a rigid type variable bound by - the class declaration for ‘ApplicativeFix’ - at T9834.hs:21:39 + ‘a’ is a rigid type variable bound by + the type signature for: + afix :: forall a. + (forall (q :: * -> *). Applicative q => Comp p q a -> Comp p q a) + -> p a + at T9834.hs:22:11-74 • In the expression: wrapIdComp f In an equation for ‘afix’: afix f = wrapIdComp f • Relevant bindings include diff --git a/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnifySig.hs b/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnifySig.hs index a7645a0b3e..3984df496a 100644 --- a/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnifySig.hs +++ b/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnifySig.hs @@ -20,4 +20,4 @@ data family D (a :: TYPE r) :: TYPE r newtype instance D a = MkWordD Word# newtype instance D a :: TYPE (KindOf a) where - MkIntD :: forall (a :: TYPE 'IntRep). Int# -> D a + MkIntD :: forall a. Int# -> D a diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 08f4b803c8..5aeb4d0a58 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -731,3 +731,8 @@ test('T18939_Compile', normal, compile, ['']) test('T15942', normal, compile, ['']) test('ClassDefaultInHsBoot', [extra_files(['ClassDefaultInHsBootA1.hs','ClassDefaultInHsBootA2.hs','ClassDefaultInHsBootA2.hs-boot','ClassDefaultInHsBootA3.hs'])], multimod_compile, ['ClassDefaultInHsBoot', '-v0']) test('T17186', normal, compile, ['']) +test('CbvOverlap', normal, compile, ['']) +test('InstanceGivenOverlap', normal, compile, ['']) +test('InstanceGivenOverlap2', normal, compile, ['']) +test('LocalGivenEqs', normal, compile, ['']) +test('LocalGivenEqs2', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/ContextStack2.hs b/testsuite/tests/typecheck/should_fail/ContextStack2.hs index 53634a5cd5..0e01ab6956 100644 --- a/testsuite/tests/typecheck/should_fail/ContextStack2.hs +++ b/testsuite/tests/typecheck/should_fail/ContextStack2.hs @@ -12,11 +12,11 @@ type instance TF (a,b) = (TF a, TF b) t :: (a ~ TF (a,Int)) => Int t = undefined -{- a ~ TF (a,Int) +{- a ~ TF (a,Int) ~ (TF a, TF Int) ~ (TF (TF (a,Int)), TF Int) ~ (TF (TF a, TF Int), TF Int) - ~ ((TF (TF a), TF (TF Int)), TF Int) + ~ ((TF (TF a), TF (TF Int)), TF Int) fsk ~ a @@ -28,7 +28,7 @@ t = undefined a ~ (TF a, TF Int) (flatten rhs) a ~ (fsk1, TF Int) -(wk) TF a ~ fsk1 +(wk) TF a ~ fsk1 --> (rewrite inert) @@ -43,7 +43,7 @@ t = undefined * TF (fsk1, fsk2) ~ fsk1 (wk) TF Tnt ~ fsk2 ---> +--> fsk ~ (fsk1, TF Int) a ~ (fsk1, TF Int) @@ -51,7 +51,7 @@ t = undefined (flatten rhs) fsk1 ~ (fsk3, TF fsk2) - + (wk) TF Int ~ fsk2 TF fsk1 ~ fsk3 -} diff --git a/testsuite/tests/typecheck/should_fail/GivenForallLoop.hs b/testsuite/tests/typecheck/should_fail/GivenForallLoop.hs new file mode 100644 index 0000000000..a5f109949c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/GivenForallLoop.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies, ImpredicativeTypes #-} + +module GivenForallLoop where + +type family F a b + +loopy :: (a ~ (forall b. F a b)) => a -> b +loopy x = x diff --git a/testsuite/tests/typecheck/should_fail/GivenForallLoop.stderr b/testsuite/tests/typecheck/should_fail/GivenForallLoop.stderr new file mode 100644 index 0000000000..e4260e62ed --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/GivenForallLoop.stderr @@ -0,0 +1,20 @@ + +GivenForallLoop.hs:8:11: error: + • Could not deduce: a ~ b + from the context: a ~ (forall b1. F a b1) + bound by the type signature for: + loopy :: forall a b. (a ~ (forall b1. F a b1)) => a -> b + at GivenForallLoop.hs:7:1-42 + ‘a’ is a rigid type variable bound by + the type signature for: + loopy :: forall a b. (a ~ (forall b1. F a b1)) => a -> b + at GivenForallLoop.hs:7:1-42 + ‘b’ is a rigid type variable bound by + the type signature for: + loopy :: forall a b. (a ~ (forall b1. F a b1)) => a -> b + at GivenForallLoop.hs:7:1-42 + • In the expression: x + In an equation for ‘loopy’: loopy x = x + • Relevant bindings include + x :: a (bound at GivenForallLoop.hs:8:7) + loopy :: a -> b (bound at GivenForallLoop.hs:8:1) diff --git a/testsuite/tests/typecheck/should_fail/T15629.stderr b/testsuite/tests/typecheck/should_fail/T15629.stderr index 3599acef73..c1d751bee2 100644 --- a/testsuite/tests/typecheck/should_fail/T15629.stderr +++ b/testsuite/tests/typecheck/should_fail/T15629.stderr @@ -1,17 +1,26 @@ -T15629.hs:26:37: error: +T15629.hs:26:31: error: • Couldn't match kind ‘z’ with ‘ab’ - Expected kind ‘x ~> F x ab’, - but ‘F1Sym :: x ~> F x z’ has kind ‘x ~> F x z’ + Expected kind ‘F x ab ~> F x ab’, + but ‘Comp (F1Sym :: x ~> F x z) F2Sym’ has kind ‘TyFun + (F x ab) (F x z) + -> *’ ‘z’ is a rigid type variable bound by an explicit forall z ab at T15629.hs:26:17 ‘ab’ is a rigid type variable bound by an explicit forall z ab at T15629.hs:26:19-20 - • In the first argument of ‘Comp’, namely ‘(F1Sym :: x ~> F x z)’ - In the first argument of ‘Proxy’, namely + • In the first argument of ‘Proxy’, namely ‘((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab)’ In the type signature: - g :: forall z ab. Proxy ((Comp (F1Sym :: x - ~> F x z) F2Sym) :: F x ab ~> F x ab) + g :: forall z ab. + Proxy ((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab) + In an equation for ‘f’: + f _ + = () + where + g :: + forall z ab. + Proxy ((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab) + g = sg Proxy Proxy diff --git a/testsuite/tests/typecheck/should_fail/T16512a.stderr b/testsuite/tests/typecheck/should_fail/T16512a.stderr index f18e9738bf..a799bcca21 100644 --- a/testsuite/tests/typecheck/should_fail/T16512a.stderr +++ b/testsuite/tests/typecheck/should_fail/T16512a.stderr @@ -1,12 +1,16 @@ T16512a.hs:41:25: error: - • Reduction stack overflow; size = 201 - When simplifying the following type: ListVariadic as b - Use -freduction-depth=0 to disable this check - (any upper bound you could choose might fail unpredictably with - minor updates to GHC, so disabling the check is recommended if - you're sure that type checking should terminate) + • Couldn't match type: ListVariadic as (a -> b) + with: a -> ListVariadic as b + Expected: AST (ListVariadic (a : as) b) + Actual: AST (ListVariadic as (a -> b)) • In the first argument of ‘AnApplication’, namely ‘g’ In the expression: AnApplication g (a `ConsAST` as) In a case alternative: AnApplication g as -> AnApplication g (a `ConsAST` as) + • Relevant bindings include + as :: ASTs as (bound at T16512a.hs:40:25) + g :: AST (ListVariadic as (a -> b)) (bound at T16512a.hs:40:23) + a :: AST a (bound at T16512a.hs:38:15) + f :: AST (a -> b) (bound at T16512a.hs:38:10) + unapply :: AST b -> AnApplication b (bound at T16512a.hs:38:1) diff --git a/testsuite/tests/typecheck/should_fail/T3406.stderr b/testsuite/tests/typecheck/should_fail/T3406.stderr index 70fffee3ac..70791b2cdc 100644 --- a/testsuite/tests/typecheck/should_fail/T3406.stderr +++ b/testsuite/tests/typecheck/should_fail/T3406.stderr @@ -1,6 +1,6 @@ T3406.hs:11:28: error: - • Couldn't match type ‘Int’ with ‘a -> ItemColID a b’ + • Couldn't match type ‘Int’ with ‘a -> Int’ Expected: a -> ItemColID a b Actual: ItemColID a1 b1 • In the expression: x :: ItemColID a b diff --git a/testsuite/tests/typecheck/should_fail/T5853.stderr b/testsuite/tests/typecheck/should_fail/T5853.stderr index 5d42625796..b25e1fca91 100644 --- a/testsuite/tests/typecheck/should_fail/T5853.stderr +++ b/testsuite/tests/typecheck/should_fail/T5853.stderr @@ -1,16 +1,18 @@ T5853.hs:15:52: error: - • Could not deduce: Subst (Subst fa a) b ~ Subst fa b + • Could not deduce: Subst fa1 (Elem fb) ~ fb arising from a use of ‘<$>’ - from the context: (F fa, Elem (Subst fa b) ~ b, - Subst fa b ~ Subst fa b, Subst (Subst fa b) (Elem fa) ~ fa, - F (Subst fa a), Elem (Subst fa a) ~ a, Elem fa ~ Elem fa, - Subst (Subst fa a) (Elem fa) ~ fa, Subst fa a ~ Subst fa a) + from the context: (F fa, Elem fb ~ Elem fb, + Subst fa (Elem fb) ~ fb, Subst fb (Elem fa) ~ fa, F fa1, + Elem fa1 ~ Elem fa1, Elem fa ~ Elem fa, Subst fa1 (Elem fa) ~ fa, + Subst fa (Elem fa1) ~ fa1) bound by the RULE "map/map" at T5853.hs:15:2-57 - NB: ‘Subst’ is a non-injective type family + ‘fb’ is a rigid type variable bound by + the RULE "map/map" + at T5853.hs:15:2-57 • In the expression: (f . g) <$> xs When checking the rewrite rule "map/map" • Relevant bindings include - f :: Elem fa -> b (bound at T5853.hs:15:19) - g :: a -> Elem fa (bound at T5853.hs:15:21) - xs :: Subst fa a (bound at T5853.hs:15:23) + f :: Elem fa -> Elem fb (bound at T5853.hs:15:19) + g :: Elem fa1 -> Elem fa (bound at T5853.hs:15:21) + xs :: fa1 (bound at T5853.hs:15:23) diff --git a/testsuite/tests/typecheck/should_fail/T8142.stderr b/testsuite/tests/typecheck/should_fail/T8142.stderr index a9f4590e44..a362d35367 100644 --- a/testsuite/tests/typecheck/should_fail/T8142.stderr +++ b/testsuite/tests/typecheck/should_fail/T8142.stderr @@ -1,10 +1,10 @@ T8142.hs:6:10: error: - • Couldn't match type: Nu ((,) a0) + • Couldn't match type: Nu f0 with: c -> f c Expected: (c -> f c) -> c -> f c Actual: Nu ((,) a0) -> Nu f0 - The type variable ‘a0’ is ambiguous + The type variable ‘f0’ is ambiguous • In the expression: h In an equation for ‘tracer’: tracer @@ -12,15 +12,17 @@ T8142.hs:6:10: error: where h = (\ (_, b) -> ((outI . fmap h) b)) . out • Relevant bindings include + h :: Nu ((,) a0) -> Nu f0 (bound at T8142.hs:6:18) tracer :: (c -> f c) -> c -> f c (bound at T8142.hs:6:1) T8142.hs:6:57: error: - • Couldn't match type: Nu ((,) a) - with: f1 (Nu ((,) a)) - Expected: Nu ((,) a) -> (a, f1 (Nu ((,) a))) - Actual: Nu ((,) a) -> (a, Nu ((,) a)) + • Couldn't match type: Nu ((,) a0) + with: f0 (Nu ((,) a0)) + Expected: Nu ((,) a0) -> (a0, f0 (Nu ((,) a0))) + Actual: Nu ((,) a0) -> (a0, Nu ((,) a0)) + The type variables ‘f0’, ‘a0’ are ambiguous • In the second argument of ‘(.)’, namely ‘out’ In the expression: (\ (_, b) -> ((outI . fmap h) b)) . out In an equation for ‘h’: h = (\ (_, b) -> ((outI . fmap h) b)) . out • Relevant bindings include - h :: Nu ((,) a) -> Nu f1 (bound at T8142.hs:6:18) + h :: Nu ((,) a0) -> Nu f0 (bound at T8142.hs:6:18) diff --git a/testsuite/tests/typecheck/should_fail/T9260.stderr b/testsuite/tests/typecheck/should_fail/T9260.stderr index 2a6c0ac16c..b3752e4279 100644 --- a/testsuite/tests/typecheck/should_fail/T9260.stderr +++ b/testsuite/tests/typecheck/should_fail/T9260.stderr @@ -1,8 +1,7 @@ -T9260.hs:12:14: error: - • Couldn't match type ‘1’ with ‘0’ - Expected: Fin 0 - Actual: Fin (0 + 1) - • In the first argument of ‘Fsucc’, namely ‘Fzero’ - In the expression: Fsucc Fzero +T9260.hs:12:8: error: + • Couldn't match type ‘2’ with ‘1’ + Expected: Fin 1 + Actual: Fin ((0 + 1) + 1) + • In the expression: Fsucc Fzero In an equation for ‘test’: test = Fsucc Fzero diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 5ce09273a2..958811d428 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -590,3 +590,4 @@ test('T18640b', normal, compile_fail, ['']) test('T18640c', normal, compile_fail, ['']) test('T10709', normal, compile_fail, ['']) test('T10709b', normal, compile_fail, ['']) +test('GivenForallLoop', normal, compile_fail, ['']) diff --git a/utils/haddock b/utils/haddock -Subproject 2d06af2fc535dacc4bac45d45e8eb95a7620caa +Subproject 8d260690b53f2fb6b54ba78bd13d1400d9ebd39 |