X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSMonad.lhs;h=3d8163d997dfdd6cdb173a49b85c968bdb4f0946;hb=e646bb2961a7250915e519e7852fecdb3f86cc15;hp=3c1961b13a6480df31cf6aaa8bdaeece1507c104;hpb=27225b0c9f799a251c96242f502e8cfd6bf76d7c;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 3c1961b..3d8163d 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -4,16 +4,22 @@ module TcSMonad ( -- Canonical constraints CanonicalCts, emptyCCan, andCCan, andCCans, - singleCCan, extendCCans, isEmptyCCan, - CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, + singleCCan, extendCCans, isEmptyCCan, isCTyEqCan, + isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, + + CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, mkWantedConstraints, deCanonicaliseWanted, - makeGivens, makeSolved, + makeGivens, makeSolvedByInst, + + CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst, + isGivenCt, isWantedCt, - CtFlavor (..), isWanted, isGiven, isDerived, canRewrite, + DerivedOrig (..), + canRewrite, canSolve, combineCtLoc, mkGivenFlavor, TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0, -- Basic functionality - tryTcS, nestImplicTcS, wrapErrTcS, wrapWarnTcS, + tryTcS, nestImplicTcS, recoverTcS, wrapErrTcS, wrapWarnTcS, SimplContext(..), isInteractive, simplEqsOnly, performDefaulting, -- Creation of evidence variables @@ -42,7 +48,12 @@ module TcSMonad ( isGoodRecEv, + zonkTcTypeTcS, -- Zonk through the TyBinds of the Tcs Monad + compatKind, + + isTouchableMetaTyVar, + isTouchableMetaTyVar_InRange, getDefaultInfo, getDynFlags, @@ -133,7 +144,7 @@ data CanonicalCt | CIPCan { -- ?x::tau -- See note [Canonical implicit parameter constraints]. cc_id :: EvVar, - cc_flavor :: CtFlavor, + cc_flavor :: CtFlavor, cc_ip_nm :: IPName Name, cc_ip_ty :: TcTauType } @@ -141,19 +152,25 @@ data CanonicalCt | CTyEqCan { -- tv ~ xi (recall xi means function free) -- Invariant: -- * tv not in tvs(xi) (occurs check) - -- * If tv is a MetaTyVar, then typeKind xi <: typeKind tv - -- a skolem, then typeKind xi = typeKind tv + -- * If constraint is given then typeKind xi `compatKind` typeKind tv + -- See Note [Spontaneous solving and kind compatibility] + -- * If 'xi' is a flatten skolem then 'tv' can only be: + -- - a flatten skolem or a unification variable + -- i.e. equalities prefer flatten skolems in their LHS + -- See Note [Loopy Spontaneous Solving, Example 4] + -- Also related to [Flatten Skolem Equivalence Classes] cc_id :: EvVar, cc_flavor :: CtFlavor, - cc_tyvar :: TcTyVar, - cc_rhs :: Xi + cc_tyvar :: TcTyVar, + cc_rhs :: Xi } | CFunEqCan { -- F xis ~ xi -- Invariant: * isSynFamilyTyCon cc_fun -- * cc_rhs is not a touchable unification variable -- See Note [No touchables as FunEq RHS] - -- * typeKind (TyConApp cc_fun cc_tyargs) == typeKind cc_rhs + -- * If constraint is given then + -- typeKind (TyConApp cc_fun cc_tyargs) `compatKind` typeKind cc_rhs cc_id :: EvVar, cc_flavor :: CtFlavor, cc_fun :: TyCon, -- A type function @@ -163,17 +180,20 @@ data CanonicalCt } +compatKind :: Kind -> Kind -> Bool +compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 + makeGivens :: CanonicalCts -> CanonicalCts makeGivens = mapBag (\ct -> ct { cc_flavor = mkGivenFlavor (cc_flavor ct) UnkSkol }) -- The UnkSkol doesn't matter because these givens are -- not contradictory (else we'd have rejected them already) -makeSolved :: CanonicalCt -> CanonicalCt +makeSolvedByInst :: CanonicalCt -> CanonicalCt -- Record that a constraint is now solved -- Wanted -> Derived -- Given, Derived -> no-op -makeSolved ct - | Wanted loc <- cc_flavor ct = ct { cc_flavor = Derived loc } +makeSolvedByInst ct + | Wanted loc <- cc_flavor ct = ct { cc_flavor = Derived loc DerInst } | otherwise = ct mkWantedConstraints :: CanonicalCts -> Bag Implication -> WantedConstraints @@ -192,6 +212,13 @@ tyVarsOfCanonical (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes ( tyVarsOfCanonical (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys tyVarsOfCanonical (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty +tyVarsOfCDict :: CanonicalCt -> TcTyVarSet +tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys +tyVarsOfCDict _ct = emptyVarSet + +tyVarsOfCDicts :: CanonicalCts -> TcTyVarSet +tyVarsOfCDicts = foldrBag (unionVarSet . tyVarsOfCDict) emptyVarSet + tyVarsOfCanonicals :: CanonicalCts -> TcTyVarSet tyVarsOfCanonicals = foldrBag (unionVarSet . tyVarsOfCanonical) emptyVarSet @@ -224,6 +251,8 @@ variable, is not canonical. Why? Hence the invariant. +The invariant is + Note [Canonical implicit parameter constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The type in a canonical implicit parameter constraint doesn't need to @@ -253,6 +282,24 @@ emptyCCan = emptyBag isEmptyCCan :: CanonicalCts -> Bool isEmptyCCan = isEmptyBag + +isCTyEqCan :: CanonicalCt -> Bool +isCTyEqCan (CTyEqCan {}) = True +isCTyEqCan (CFunEqCan {}) = False +isCTyEqCan _ = False + +isCDictCan_Maybe :: CanonicalCt -> Maybe Class +isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls +isCDictCan_Maybe _ = Nothing + +isCIPCan_Maybe :: CanonicalCt -> Maybe (IPName Name) +isCIPCan_Maybe (CIPCan {cc_ip_nm = nm }) = Just nm +isCIPCan_Maybe _ = Nothing + +isCFunEqCan_Maybe :: CanonicalCt -> Maybe TyCon +isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc +isCFunEqCan_Maybe _ = Nothing + \end{code} %************************************************************************ @@ -265,16 +312,21 @@ isEmptyCCan = isEmptyBag \begin{code} data CtFlavor = Given GivenLoc -- We have evidence for this constraint in TcEvBinds - | Derived WantedLoc -- We have evidence for this constraint in TcEvBinds; + | Derived WantedLoc DerivedOrig + -- We have evidence for this constraint in TcEvBinds; -- *however* this evidence can contain wanteds, so -- it's valid only provisionally to the solution of -- these wanteds | Wanted WantedLoc -- We have no evidence bindings for this constraint. +data DerivedOrig = DerSC | DerInst +-- Deriveds are either superclasses of other wanteds or deriveds, or partially +-- solved wanteds from instances. + instance Outputable CtFlavor where - ppr (Given _) = ptext (sLit "[Given]") - ppr (Wanted _) = ptext (sLit "[Wanted]") - ppr (Derived _) = ptext (sLit "[Derived]") + ppr (Given _) = ptext (sLit "[Given]") + ppr (Wanted _) = ptext (sLit "[Wanted]") + ppr (Derived {}) = ptext (sLit "[Derived]") isWanted :: CtFlavor -> Bool isWanted (Wanted {}) = True @@ -288,27 +340,51 @@ isDerived :: CtFlavor -> Bool isDerived (Derived {}) = True isDerived _ = False +isDerivedSC :: CtFlavor -> Bool +isDerivedSC (Derived _ DerSC) = True +isDerivedSC _ = False + +isDerivedByInst :: CtFlavor -> Bool +isDerivedByInst (Derived _ DerInst) = True +isDerivedByInst _ = False + +isWantedCt :: CanonicalCt -> Bool +isWantedCt ct = isWanted (cc_flavor ct) +isGivenCt :: CanonicalCt -> Bool +isGivenCt ct = isGiven (cc_flavor ct) + +canSolve :: CtFlavor -> CtFlavor -> Bool +-- canSolve ctid1 ctid2 +-- The constraint ctid1 can be used to solve ctid2 +-- "to solve" means a reaction where the active parts of the two constraints match. +-- active(F xis ~ xi) = F xis +-- active(tv ~ xi) = tv +-- active(D xis) = D xis +-- active(IP nm ty) = nm +----------------------------------------- +canSolve (Given {}) _ = True +canSolve (Derived {}) (Wanted {}) = True +canSolve (Derived {}) (Derived {}) = True +canSolve (Wanted {}) (Wanted {}) = True +canSolve _ _ = False + canRewrite :: CtFlavor -> CtFlavor -> Bool -- canRewrite ctid1 ctid2 --- The constraint ctid1 can be used to rewrite ctid2 -canRewrite (Given {}) _ = True -canRewrite (Derived {}) (Wanted {}) = True -canRewrite (Derived {}) (Derived {}) = True -canRewrite (Wanted {}) (Wanted {}) = True -canRewrite _ _ = False +-- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 +canRewrite = canSolve combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc -- Precondition: At least one of them should be wanted -combineCtLoc (Wanted loc) _ = loc -combineCtLoc _ (Wanted loc) = loc -combineCtLoc (Derived loc) _ = loc -combineCtLoc _ (Derived loc) = loc +combineCtLoc (Wanted loc) _ = loc +combineCtLoc _ (Wanted loc) = loc +combineCtLoc (Derived loc _) _ = loc +combineCtLoc _ (Derived loc _) = loc combineCtLoc _ _ = panic "combineCtLoc: both given" mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor -mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) -mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) -mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk) +mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) +mkGivenFlavor (Derived loc _) sk = Given (setCtLocOrigin loc sk) +mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk) \end{code} @@ -450,6 +526,11 @@ nestImplicTcS ref untch (TcS thing_inside) in thing_inside nest_env +recoverTcS :: TcS a -> TcS a -> TcS a +recoverTcS (TcS recovery_code) (TcS thing_inside) + = TcS $ \ env -> + TcM.recoverM (recovery_code env) (thing_inside env) + ctxtUnderImplic :: SimplContext -> SimplContext -- See Note [Simplifying RULE lhs constraints] in TcSimplify ctxtUnderImplic SimplRuleLhs = SimplCheck @@ -567,13 +648,20 @@ pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2) isTouchableMetaTyVar :: TcTyVar -> TcS Bool isTouchableMetaTyVar tv - = case tcTyVarDetails tv of - MetaTv TcsTv _ -> return True -- See Note [Touchable meta type variables] - MetaTv {} -> do { untch <- getUntouchables - ; return (inTouchableRange untch tv) } - _ -> return False + = do { untch <- getUntouchables + ; return $ isTouchableMetaTyVar_InRange untch tv } + +isTouchableMetaTyVar_InRange :: Untouchables -> TcTyVar -> Bool +isTouchableMetaTyVar_InRange untch tv + = case tcTyVarDetails tv of + MetaTv TcsTv _ -> True -- See Note [Touchable meta type variables] + MetaTv {} -> inTouchableRange untch tv + _ -> False + + \end{code} + Note [Touchable meta type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Meta type variables allocated *by the constraint solver itself* are always @@ -613,11 +701,35 @@ instDFunTypes mb_inst_tys instDFunConstraints :: TcThetaType -> TcS [EvVar] instDFunConstraints preds = wrapTcS $ TcM.newWantedEvVars preds -newFlexiTcS :: TyVar -> TcS TcTyVar --- Make a TcsTv meta tyvar; it is always touchable, --- but we are supposed to guess its instantiation --- See Note [Touchable meta type variables] -newFlexiTcS tv = wrapTcS $ TcM.instMetaTyVar TcsTv tv + +-- newFlexiTcS :: TyVar -> TcS TcTyVar +-- -- Make a TcsTv meta tyvar; it is always touchable, +-- -- but we are supposed to guess its instantiation +-- -- See Note [Touchable meta type variables] +-- newFlexiTcS tv = wrapTcS $ TcM.instMetaTyVar TcsTv tv + +newFlexiTcS :: TyVar -> TcS TcTyVar +-- Like TcM.instMetaTyVar but the variable that is created is always +-- touchable; we are supposed to guess its instantiation. +-- See Note [Touchable meta type variables] +newFlexiTcS tv = newFlexiTcSHelper (tyVarName tv) (tyVarKind tv) + +newKindConstraint :: TcTyVar -> Kind -> TcS (CoVar, Type) +-- Create new wanted CoVar that constrains the type to have the specified kind. +newKindConstraint tv knd + = do { tv_k <- newFlexiTcSHelper (tyVarName tv) knd + ; let ty_k = mkTyVarTy tv_k + ; co_var <- newWantedCoVar (mkTyVarTy tv) ty_k + ; return (co_var, ty_k) } + +newFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar +newFlexiTcSHelper tvname tvkind + = wrapTcS $ + do { uniq <- TcM.newUnique + ; ref <- TcM.newMutVar Flexi + ; let name = setNameUnique tvname uniq + kind = tvkind + ; return (mkTcTyVar name kind (MetaTv TcsTv ref)) } -- Superclasses and recursive dictionaries -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -641,8 +753,6 @@ newGivOrDerCoVar ty1 ty2 co newWantedCoVar :: TcType -> TcType -> TcS EvVar newWantedCoVar ty1 ty2 = wrapTcS $ TcM.newWantedCoVar ty1 ty2 -newKindConstraint :: TcType -> Kind -> TcS (CoVar, TcType) -newKindConstraint ty kind = wrapTcS $ TcM.newKindConstraint ty kind newCoVar :: TcType -> TcType -> TcS EvVar newCoVar ty1 ty2 = wrapTcS $ TcM.newCoVar ty1 ty2 @@ -805,6 +915,20 @@ matchFam tycon args } +zonkTcTypeTcS :: TcType -> TcS TcType +-- Zonk through the TyBinds of the Tcs Monad +zonkTcTypeTcS ty + = do { subst <- getTcSTyBindsMap >>= return . varEnvElts + ; let (dom,rng) = unzip subst + apply_once = substTyWith dom rng + ; let rng_idemp = [ substTyWith dom rng_idemp (apply_once t) | t <- rng ] + ; return (substTyWith dom rng_idemp ty) } + + + + + + -- Functional dependencies, instantiation of equations -------------------------------------------------------