mkWantedConstraints, deCanonicaliseWanted,
makeGivens, makeSolvedByInst,
- CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst,
+ CtFlavor (..), isWanted, isGiven, isDerived,
isGivenCt, isWantedCt, pprFlavorArising,
+ isFlexiTcsTv,
+
DerivedOrig (..),
canRewrite, canSolve,
combineCtLoc, mkGivenFlavor, mkWantedFlavor,
compatKind,
+ TcsUntouchables,
isTouchableMetaTyVar,
isTouchableMetaTyVar_InRange,
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
-- 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]")
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
-- 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
; 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
}
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
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)))
= 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
; 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
\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
-- 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
| 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
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_vars ev_deps)
+ = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_deps
+ -- Notice that we chase the ev_deps and not the ev_vars
+ -- See Note [Dependencies in self dictionaries] in TcSimplify
+ ; return (comb_chase_res Nothing chase_results) }
chase_co assocs trg curr_grav visited co
= -- Look for all the coercion variables in the coercion
text "witness" <+> ppr dfun_id
<+> ppr (idType dfun_id) ])
-- 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"
}
}
}
- 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
projects / ghc-hetmet.git / blobdiff