makeGivens, makeSolved,
CtFlavor (..), isWanted, isGiven, isDerived, canRewrite,
- joinFlavors, mkGivenFlavor,
+ combineCtLoc, mkGivenFlavor,
TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0, -- Basic functionality
tryTcS, nestImplicTcS, wrapErrTcS, wrapWarnTcS,
newTcEvBindsTcS,
getInstEnvs, getFamInstEnvs, -- Getting the environments
- getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
+ getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
import TcRnTypes
-import Control.Monad
import Data.IORef
\end{code}
canRewrite (Wanted {}) (Wanted {}) = True
canRewrite _ _ = False
-joinFlavors :: CtFlavor -> CtFlavor -> CtFlavor
-joinFlavors (Wanted loc) _ = Wanted loc
-joinFlavors _ (Wanted loc) = Wanted loc
-joinFlavors (Derived loc) _ = Derived loc
-joinFlavors _ (Derived loc) = Derived loc
-joinFlavors (Given loc) _ = Given loc
+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 _ _ = panic "combineCtLoc: both given"
mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk)
tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
-- Global type bindings
- tcs_context :: SimplContext
+ tcs_context :: SimplContext,
+
+ tcs_untch :: Untouchables
}
data SimplContext
traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc
runTcS :: SimplContext
- -> TcTyVarSet -- Untouchables
+ -> Untouchables -- Untouchables
-> TcS a -- What to run
-> TcM (a, Bag EvBind)
runTcS context untouch tcs
; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var
- , tcs_context = context }
+ , tcs_context = context
+ , tcs_untch = untouch }
-- Run the computation
- ; res <- TcM.setUntouchables untouch (unTcS tcs env)
+ ; res <- unTcS tcs env
-- Perform the type unifications required
; ty_binds <- TcM.readTcRef ty_binds_var
do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
-nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a
-nestImplicTcS ref untouch tcs
+nestImplicTcS :: EvBindsVar -> Untouchables -> TcS a -> TcS a
+nestImplicTcS ref untch (TcS thing_inside)
= TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, tcs_context = ctxt } ->
let
nest_env = TcSEnv { tcs_ev_binds = ref
, tcs_ty_binds = ty_binds
- , tcs_context = ctxtUnderImplic ctxt }
+ , tcs_untch = untch
+ , tcs_context = ctxtUnderImplic ctxt }
in
- TcM.setUntouchables untouch (unTcS tcs nest_env)
+ thing_inside nest_env
ctxtUnderImplic :: SimplContext -> SimplContext
-- See Note [Simplifying RULE lhs constraints] in TcSimplify
ctxtUnderImplic SimplRuleLhs = SimplCheck
ctxtUnderImplic ctxt = ctxt
-tryTcS :: TcTyVarSet -> TcS a -> TcS a
+tryTcS :: TcS a -> TcS a
-- Like runTcS, but from within the TcS monad
-- Ignore all the evidence generated, and do not affect caller's evidence!
-tryTcS untch tcs
+tryTcS tcs
= TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
; ev_binds_var <- TcM.newTcEvBinds
; let env1 = env { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var }
- ; TcM.setUntouchables untch (unTcS tcs env1) })
+ ; unTcS tcs env1 })
-- Update TcEvBinds
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
getTcEvBinds :: TcS EvBindsVar
getTcEvBinds = TcS (return . tcs_ev_binds)
+getUntouchables :: TcS Untouchables
+getUntouchables = TcS (return . tcs_untch)
+
getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
getTcSTyBinds = TcS (return . tcs_ty_binds)
getGblEnv :: TcS TcGblEnv
getGblEnv = wrapTcS $ TcM.getGblEnv
-getUntouchablesTcS :: TcS TcTyVarSet
-getUntouchablesTcS = wrapTcS $ TcM.getUntouchables
-
-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
isTouchableMetaTyVar :: TcTyVar -> TcS Bool
--- is touchable variable!
-isTouchableMetaTyVar v
- | isMetaTyVar v = wrapTcS $ do { untch <- TcM.isUntouchable v;
- ; return (not untch) }
- | otherwise = return False
+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
+\end{code}
+
+Note [Touchable meta type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Meta type variables allocated *by the constraint solver itself* are always
+touchable. Example:
+ instance C a b => D [a] where...
+if we use this instance declaration we "make up" a fresh meta type
+variable for 'b', which we must later guess. (Perhaps C has a
+functional dependency.) But since we aren't in the constraint *generator*
+we can't allocate a Unique in the touchable range for this implication
+constraint. Instead, we mark it as a "TcsTv", which makes it always-touchable.
+\begin{code}
-- Flatten skolems
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
newFlattenSkolemTy :: TcType -> TcS TcType
newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
- where newFlattenSkolemTyVar :: TcType -> TcS TcTyVar
- newFlattenSkolemTyVar ty
- = wrapTcS $ do { uniq <- TcM.newUnique
- ; let name = mkSysTvName uniq (fsLit "f")
- ; return $
- mkTcTyVar name (typeKind ty) (FlatSkol ty)
- }
+
+newFlattenSkolemTyVar :: TcType -> TcS TcTyVar
+newFlattenSkolemTyVar ty
+ = wrapTcS $ do { uniq <- TcM.newUnique
+ ; let name = mkSysTvName uniq (fsLit "f")
+ ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) }
-- Instantiations
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
instDFunTypes :: [Either TyVar TcType] -> TcS [TcType]
-instDFunTypes mb_inst_tys =
- let inst_tv :: Either TyVar TcType -> TcS Type
- inst_tv (Left tv) = wrapTcS $ TcM.tcInstTyVar tv >>= return . mkTyVarTy
- inst_tv (Right ty) = return ty
- in mapM inst_tv mb_inst_tys
-
+instDFunTypes mb_inst_tys
+ = mapM inst_tv mb_inst_tys
+ where
+ inst_tv :: Either TyVar TcType -> TcS Type
+ inst_tv (Left tv) = mkTyVarTy <$> newFlexiTcS tv
+ inst_tv (Right ty) = return ty
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
-- Superclasses and recursive dictionaries
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
where
to_work_item :: (Equation, (PredType,SDoc), (PredType,SDoc)) -> TcS [WantedEvVar]
to_work_item ((qtvs, pairs), _, _)
- = do { (_, _, tenv) <- wrapTcS $ TcM.tcInstTyVars (varSetElems qtvs)
- ; mapM (do_one tenv) pairs }
+ = do { let tvs = varSetElems qtvs
+ ; tvs' <- mapM newFlexiTcS tvs
+ ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs')
+ ; mapM (do_one subst) pairs }
- do_one tenv (ty1, ty2) = do { let sty1 = substTy tenv ty1
- sty2 = substTy tenv ty2
+ do_one subst (ty1, ty2) = do { let sty1 = substTy subst ty1
+ sty2 = substTy subst ty2
; ev <- newWantedCoVar sty1 sty2
; return (WantedEvVar ev loc) }
projects / ghc-hetmet.git / blobdiff