diff options
Diffstat (limited to 'compiler/GHC/Tc/Solver')
| -rw-r--r-- | compiler/GHC/Tc/Solver/Canonical.hs | 19 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Flatten.hs | 16 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Interact.hs | 13 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Monad.hs | 11 |
4 files changed, 25 insertions, 34 deletions
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index 5a231f2e44..57cf913aa4 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -34,7 +34,6 @@ 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.Name.Occurrence ( OccName ) import GHC.Utils.Outputable import GHC.Driver.Session( DynFlags ) import GHC.Types.Name.Set @@ -67,8 +66,7 @@ Canonicalization converts a simple constraint to a canonical form. It is unary (i.e. treats individual constraints one at a time). Constraints originating from user-written code come into being as -CNonCanonicals (except for CHoleCans, arising from holes). We know nothing -about these constraints. So, first: +CNonCanonicals. We know nothing about these constraints. So, first: Classify CNonCanoncal constraints, depending on whether they are equalities, class predicates, or other. @@ -137,9 +135,6 @@ canonicalize (CFunEqCan { cc_ev = ev = {-# SCC "canEqLeafFunEq" #-} canCFunEqCan ev fn xis1 fsk -canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ, cc_hole = hole }) - = canHole ev occ hole - {- ************************************************************************ * * @@ -718,17 +713,6 @@ canIrred status ev _ -> continueWith $ mkIrredCt status new_ev } } -canHole :: CtEvidence -> OccName -> HoleSort -> TcS (StopOrContinue Ct) -canHole ev occ hole_sort - = do { let pred = ctEvPred ev - ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev - , cc_occ = occ - , cc_hole = hole_sort })) - ; stopWith new_ev "Emit insoluble hole" } } - - {- ********************************************************************* * * * Quantified predicates @@ -1401,6 +1385,7 @@ can_eq_app ev s1 t1 s2 t2 | CtDerived {} <- ev = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2] ; stopWith ev "Decomposed [D] AppTy" } + | CtWanted { ctev_dest = dest } <- ev = do { co_s <- unifyWanted loc Nominal s1 s2 ; let arg_loc diff --git a/compiler/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs index 551e1de395..4dff585840 100644 --- a/compiler/GHC/Tc/Solver/Flatten.hs +++ b/compiler/GHC/Tc/Solver/Flatten.hs @@ -5,7 +5,7 @@ module GHC.Tc.Solver.Flatten( FlattenMode(..), flatten, flattenKind, flattenArgsNom, - rewriteTyVar, + rewriteTyVar, flattenType, unflattenWanteds ) where @@ -825,6 +825,20 @@ flattenArgsNom ev tc tys ; traceTcS "flatten }" (vcat (map ppr tys')) ; return (tys', cos, kind_co) } +-- | 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 +-- will never emit new constraints. Call this when the inert set contains +-- 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 $ + flatten_one ty + -- use Given flavor so that it is rewritten + -- only w.r.t. Givens, never Wanteds/Deriveds + -- (Shouldn't matter, if only Givens are present + -- anyway) + ; return xi } {- ********************************************************************* * * diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index 6a391d4406..d95c13cd54 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -195,7 +195,7 @@ solve_simple_wanteds :: WantedConstraints -> TcS (Int, 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 }) +solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_holes = holes }) = nestTcS $ do { solveSimples simples1 ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts @@ -204,7 +204,8 @@ solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1 }) -- See Note [Unflatten after solving the simple wanteds] ; return ( unif_count , WC { wc_simple = others `andCts` unflattened_eqs - , wc_impl = implics1 `unionBags` implics2 }) } + , wc_impl = implics1 `unionBags` implics2 + , wc_holes = holes }) } {- Note [The solveSimpleWanteds loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -264,7 +265,7 @@ runTcPluginsGiven -- 'solveSimpleWanteds' should feed the updated wanteds back into the -- main solver. runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints) -runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_impl = implics1 }) +runTcPluginsWanted wc@(WC { wc_simple = simples1 }) | isEmptyBag simples1 = return (False, wc) | otherwise @@ -285,11 +286,10 @@ runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_impl = implics1 }) ; mapM_ setEv solved_wanted ; return ( notNull (pluginNewCts p) - , WC { wc_simple = listToBag new_wanted `andCts` + , wc { wc_simple = listToBag new_wanted `andCts` listToBag unsolved_wanted `andCts` listToBag unsolved_derived `andCts` - listToBag insols - , wc_impl = implics1 } ) } } + listToBag insols } ) } } where setEv :: (EvTerm,Ct) -> TcS () setEv (ev,ct) = case ctEvidence ct of @@ -494,7 +494,6 @@ interactWithInertsStage wi CIrredCan {} -> interactIrred ics wi CDictCan {} -> interactDict ics wi _ -> pprPanic "interactWithInerts" (ppr wi) } - -- CHoleCan are put straight into inert_frozen, so never get here -- CNonCanonical have been canonicalised data InteractResult diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 0baad1ff4b..c865bc6190 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -198,7 +198,7 @@ import GHC.Types.Unique.Set Note [WorkList priorities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A WorkList contains canonical and non-canonical items (of all flavors). +A WorkList contains canonical and non-canonical items (of all flavours). Notice that each Ct now has a simplification depth. We may consider using this depth for prioritization as well in the future. @@ -1653,8 +1653,7 @@ add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) add_item _ item = pprPanic "upd_inert set: can't happen! Inserting " $ - ppr item -- Can't be CNonCanonical, CHoleCan, - -- because they only land in inert_irreds + ppr item -- Can't be CNonCanonical because they only land in inert_irreds bumpUnsolvedCount :: CtEvidence -> Int -> Int bumpUnsolvedCount ev n | isWanted ev = n+1 @@ -1896,10 +1895,6 @@ be decomposed. Otherwise we end up with a "Can't match [Int] ~ [[Int]]" which is true, but a bit confusing because the outer type constructors match. -Similarly, if we have a CHoleCan, we'd like to rewrite it with any -Givens, to give as informative an error messasge as possible -(#12468, #11325). - Hence: * In the main simplifier loops in GHC.Tc.Solver (solveWanteds, simpl_loop), we feed the insolubles in solveSimpleWanteds, @@ -2352,8 +2347,6 @@ removeInertCt is ct = CQuantCan {} -> panic "removeInertCt: CQuantCan" CIrredCan {} -> panic "removeInertCt: CIrredEvCan" CNonCanonical {} -> panic "removeInertCt: CNonCanonical" - CHoleCan {} -> panic "removeInertCt: CHoleCan" - lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour)) lookupFlatCache fam_tc tys |