X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSMonad.lhs;h=1e998767e63100943fccf2a3556193ffbb23498c;hp=0a6865082a83aa84c278c146819c7142a86197f1;hb=a3bab0506498db41853543558c52a4fda0d183af;hpb=c80364f8e4681b34e974f5df36ecdacec7cd9cd8 diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 0a68650..1e99876 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -11,9 +11,11 @@ module TcSMonad ( mkWantedConstraints, deCanonicaliseWanted, makeGivens, makeSolvedByInst, - CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst, + CtFlavor (..), isWanted, isGiven, isDerived, isGivenCt, isWantedCt, pprFlavorArising, + isFlexiTcsTv, + DerivedOrig (..), canRewrite, canSolve, combineCtLoc, mkGivenFlavor, mkWantedFlavor, @@ -55,6 +57,7 @@ module TcSMonad ( compatKind, + TcsUntouchables, isTouchableMetaTyVar, isTouchableMetaTyVar_InRange, @@ -84,14 +87,11 @@ import InstEnv import FamInst import FamInstEnv -import NameSet ( addOneToNameSet ) - import qualified TcRnMonad as TcM import qualified TcMType as TcM import qualified TcEnv as TcM ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys ) import TcType -import Module import DynFlags import Coercion @@ -181,8 +181,9 @@ 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 }) +makeGivens :: Bag WantedEvVar -> Bag (CtFlavor,EvVar) +makeGivens = mapBag (\(WantedEvVar ev wloc) -> (mkGivenFlavor (Wanted wloc) UnkSkol, ev)) +-- 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) @@ -297,9 +298,10 @@ data CtFlavor -- these wanteds | Wanted WantedLoc -- We have no evidence bindings for this constraint. -data DerivedOrig = DerSC | DerInst +data DerivedOrig = DerSC | DerInst | DerSelf -- Deriveds are either superclasses of other wanteds or deriveds, or partially --- solved wanteds from instances. +-- solved wanteds from instances, or 'self' dictionaries containing yet wanted +-- superclasses. instance Outputable CtFlavor where ppr (Given _) = ptext (sLit "[Given]") @@ -318,14 +320,6 @@ 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 - pprFlavorArising :: CtFlavor -> SDoc pprFlavorArising (Derived wl _) = pprArisingAt wl pprFlavorArising (Wanted wl) = pprArisingAt wl @@ -418,9 +412,14 @@ data TcSEnv -- Frozen errors that we defer reporting as much as possible, in order to -- make them as informative as possible. See Note [Frozen Errors] - tcs_untch :: Untouchables + tcs_untch :: TcsUntouchables } +type TcsUntouchables = (Untouchables,TcTyVarSet) +-- Like the TcM Untouchables, +-- but records extra TcsTv variables generated during simplification +-- See Note [Extra TcsTv untouchables] in TcSimplify + data FrozenError = FrozenError ErrorKind CtFlavor TcType TcType @@ -461,6 +460,7 @@ data SimplContext | SimplRuleLhs -- Inferring type of a RULE lhs | SimplInteractive -- Inferring type at GHCi prompt | SimplCheck -- Checking a type signature or RULE rhs + deriving Eq instance Outputable SimplContext where ppr SimplInfer = ptext (sLit "SimplInfer") @@ -535,7 +535,7 @@ runTcS context untouch tcs ; let env = TcSEnv { tcs_ev_binds = ev_binds_var , tcs_ty_binds = ty_binds_var , tcs_context = context - , tcs_untch = untouch + , tcs_untch = (untouch, emptyVarSet) -- No Tcs untouchables yet , tcs_errors = err_ref } @@ -552,9 +552,11 @@ runTcS context untouch tcs where do_unification (tv,ty) = TcM.writeMetaTyVar tv ty -nestImplicTcS :: EvBindsVar -> Untouchables -> TcS a -> TcS a +nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a nestImplicTcS ref untch (TcS thing_inside) - = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, tcs_context = ctxt, tcs_errors = err_ref } -> + = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, + tcs_context = ctxt, + tcs_errors = err_ref } -> let nest_env = TcSEnv { tcs_ev_binds = ref , tcs_ty_binds = ty_binds @@ -598,7 +600,7 @@ getTcSContext = TcS (return . tcs_context) getTcEvBinds :: TcS EvBindsVar getTcEvBinds = TcS (return . tcs_ev_binds) -getUntouchables :: TcS Untouchables +getUntouchables :: TcS TcsUntouchables getUntouchables = TcS (return . tcs_untch) getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType))) @@ -724,10 +726,11 @@ isTouchableMetaTyVar tv = do { untch <- getUntouchables ; return $ isTouchableMetaTyVar_InRange untch tv } -isTouchableMetaTyVar_InRange :: Untouchables -> TcTyVar -> Bool -isTouchableMetaTyVar_InRange untch tv +isTouchableMetaTyVar_InRange :: TcsUntouchables -> TcTyVar -> Bool +isTouchableMetaTyVar_InRange (untch,untch_tcs) tv = case tcTyVarDetails tv of - MetaTv TcsTv _ -> True -- See Note [Touchable meta type variables] + MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs) + -- See Note [Touchable meta type variables] MetaTv {} -> inTouchableRange untch tv _ -> False @@ -792,6 +795,12 @@ newFlexiTcSTy knd ; let name = mkSysTvName uniq (fsLit "uf") ; return $ mkTyVarTy (mkTcTyVar name knd (MetaTv TcsTv ref)) } +isFlexiTcsTv :: TyVar -> Bool +isFlexiTcsTv tv + | not (isTcTyVar tv) = False + | MetaTv TcsTv _ <- tcTyVarDetails tv = True + | otherwise = False + newKindConstraint :: TcTyVar -> Kind -> TcS CoVar -- Create new wanted CoVar that constrains the type to have the specified kind. newKindConstraint tv knd @@ -844,7 +853,7 @@ newDictVar cl tys = wrapTcS $ TcM.newDict cl tys \begin{code} -isGoodRecEv :: EvVar -> WantedEvVar -> TcS Bool +isGoodRecEv :: EvVar -> EvVar -> TcS Bool -- In a call (isGoodRecEv ev wv), we are considering solving wv -- using some term that involves ev, such as: -- by setting wv = ev @@ -859,7 +868,7 @@ isGoodRecEv :: EvVar -> WantedEvVar -> TcS Bool -- call (constructor) and -1 for every superclass selection (destructor). -- -- See Note [Superclasses and recursive dictionaries] in TcInteract -isGoodRecEv ev_var (WantedEvVar wv _) +isGoodRecEv ev_var wv = do { tc_evbinds <- getTcEvBindsBag ; mb <- chase_ev_var tc_evbinds wv 0 [] ev_var ; return $ case mb of @@ -879,16 +888,7 @@ isGoodRecEv ev_var (WantedEvVar wv _) | Just (EvBind _ ev_trm) <- lookupEvBind assocs orig = chase_ev assocs trg curr_grav (orig:visited) ev_trm -{- No longer needed: evidence is in the EvBinds - | isTcTyVar orig && isMetaTyVar orig - = do { meta_details <- wrapTcS $ TcM.readWantedCoVar orig - ; case meta_details of - Flexi -> return Nothing - Indirect tyco -> chase_ev assocs trg curr_grav - (orig:visited) (EvCoercion tyco) - } --} - | otherwise = return Nothing + | otherwise = return Nothing chase_ev assocs trg curr_grav visited (EvId v) = chase_ev_var assocs trg curr_grav visited v @@ -901,9 +901,9 @@ isGoodRecEv ev_var (WantedEvVar wv _) chase_ev assocs trg curr_grav visited (EvCoercion co) = chase_co assocs trg curr_grav visited co - chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_vars) - = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_vars - ; return (comb_chase_res Nothing chase_results) } + chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_deps) + = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_deps + ; return (comb_chase_res Nothing chase_results) } chase_co assocs trg curr_grav visited co = -- Look for all the coercion variables in the coercion @@ -935,7 +935,7 @@ matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcT matchClass clas tys = do { let pred = mkClassPred clas tys ; instEnvs <- getInstEnvs - ; case lookupInstEnv instEnvs clas tys of { + ; case lookupInstEnv instEnvs clas tys of { ([], unifs) -- Nothing matches -> do { traceTcS "matchClass not matching" (vcat [ text "dict" <+> ppr pred, @@ -947,10 +947,9 @@ matchClass clas tys ; traceTcS "matchClass success" (vcat [text "dict" <+> ppr pred, text "witness" <+> ppr dfun_id - <+> ppr (idType dfun_id) ]) + <+> ppr (idType dfun_id), ppr instEnvs ]) -- Record that this dfun is needed - ; record_dfun_usage dfun_id - ; return $ MatchInstSingle (dfun_id, inst_tys) + ; return $ MatchInstSingle (dfun_id, inst_tys) } ; (matches, unifs) -- More than one matches -> do { traceTcS "matchClass multiple matches, deferring choice" @@ -961,26 +960,8 @@ matchClass clas tys } } } - where record_dfun_usage :: Id -> TcS () - record_dfun_usage dfun_id - = do { hsc_env <- getTopEnv - ; let dfun_name = idName dfun_id - dfun_mod = ASSERT( isExternalName dfun_name ) - nameModule dfun_name - ; if isInternalName dfun_name || -- Internal name => defined in this module - modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env) - then return () -- internal, or in another package - else do updInstUses dfun_id - } - - updInstUses :: Id -> TcS () - updInstUses dfun_id - = do { tcg_env <- getGblEnv - ; wrapTcS $ TcM.updMutVar (tcg_inst_uses tcg_env) - (`addOneToNameSet` idName dfun_id) - } - -matchFam :: TyCon + +matchFam :: TyCon -> [Type] -> TcS (MatchInstResult (TyCon, [Type])) matchFam tycon args