mkWantedConstraints, deCanonicaliseWanted,
makeGivens, makeSolvedByInst,
- CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst,
+ CtFlavor (..), isWanted, isGiven, isDerived,
isGivenCt, isWantedCt, pprFlavorArising,
isFlexiTcsTv,
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
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)
-- 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
| 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")
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
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,
; traceTcS "matchClass success"
(vcat [text "dict" <+> ppr pred,
text "witness" <+> ppr dfun_id
- <+> ppr (idType 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