[commit: ghc] master: Better tracing and tiny refactoring (a64a26f)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/a64a26f0a1a864522937caaf68687baf1a5f9bcb/ghc

>---------------------------------------------------------------

commit a64a26f0a1a864522937caaf68687baf1a5f9bcb
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Jun 26 15:57:28 2015 +0100

    Better tracing and tiny refactoring


>---------------------------------------------------------------

a64a26f0a1a864522937caaf68687baf1a5f9bcb
 compiler/typecheck/TcInteract.hs | 29 ++++++++++++++++++-----------
 1 file changed, 18 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index fca57d7..b68dd34 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -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