Better tracing and tiny refactoring
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 26 Jun 2015 14:57:28 +0000 (15:57 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 26 Jun 2015 16:53:30 +0000 (17:53 +0100)
compiler/typecheck/TcInteract.hs

index fca57d7..b68dd34 100644 (file)
@@ -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