Commit a64a26f0 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Better tracing and tiny refactoring

parent 8e347839
......@@ -14,7 +14,7 @@ import TcCanonical
import TcFlatten
import VarSet
import Type
import Kind ( isKind, isConstraintKind )
import Kind ( isKind )
import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId )
import CoAxiom(sfInteractTop, sfInteractInert)
......@@ -1620,12 +1620,19 @@ instance Outputable LookupInstResult where
where ss = text $ if s then "[safe]" else "[unsafe]"
matchClassInst :: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
matchClassInst, match_class_inst
:: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
matchClassInst dflags inerts clas tys loc
= do { traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr (mkClassPred clas tys) ]
; res <- match_class_inst dflags inerts clas tys loc
; traceTcS "matchClassInst result" $ ppr res
; return res }
-- First check whether there is an in-scope Given that could
-- match this constraint. In that case, do not use top-level
-- instances. See Note [Instance and Given overlap]
matchClassInst dflags inerts clas tys loc
match_class_inst dflags inerts clas tys loc
| not (xopt Opt_IncoherentInstances dflags)
, let matchable_givens = matchableGivens loc pred inerts
, not (isEmptyBag matchable_givens)
......@@ -1636,7 +1643,7 @@ matchClassInst dflags inerts clas tys loc
where
pred = mkClassPred clas tys
matchClassInst _ _ clas [ ty ] _
match_class_inst _ _ clas [ ty ] _
| className clas == knownNatClassName
, Just n <- isNumLitTy ty = makeDict (EvNum n)
......@@ -1672,20 +1679,19 @@ matchClassInst _ _ clas [ ty ] _
= panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
$$ vcat (map (ppr . idType) (classMethods clas)))
matchClassInst _ _ clas ts _
match_class_inst _ _ clas ts _
| isCTupleClass clas
, let data_con = tyConSingleDataCon (classTyCon clas)
tuple_ev = EvDFunApp (dataConWrapId data_con) ts
= return (GenInst ts tuple_ev True)
-- The dfun is the data constructor!
matchClassInst _ _ clas [k,t] _
match_class_inst _ _ clas [k,t] _
| className clas == typeableClassName
= matchTypeableClass clas k t
matchClassInst dflags _ clas tys loc
= do { traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr pred ]
; instEnvs <- getInstEnvs
match_class_inst dflags _ clas tys loc
= do { instEnvs <- getInstEnvs
; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]
(matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
......@@ -1815,15 +1821,16 @@ matchTypeableClass clas k t
-- See Note [No Typeable for qualified types]
| isForAllTy t = return NoInstance
-- Is the type of the form `C => t`?
| Just (t1,_) <- splitFunTy_maybe t,
isConstraintKind (typeKind t1) = return NoInstance
| isJust (tcSplitPredFunTy_maybe t) = return NoInstance
| eqType k typeNatKind = doTyLit knownNatClassName
| eqType k typeSymbolKind = doTyLit knownSymbolClassName
| Just (tc, ks) <- splitTyConApp_maybe t
, all isKind ks = doTyCon tc ks
| Just (f,kt) <- splitAppTy_maybe t = doTyApp f kt
| otherwise = return NoInstance
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment