[commit: ghc] type-nats: Bugfix: don't generate infinitely many obvious facts. (5b73674)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : type-nats

http://hackage.haskell.org/trac/ghc/changeset/5b73674a4649a835360cfd330d758399420e17bd

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

commit 5b73674a4649a835360cfd330d758399420e17bd
Author: Iavor S. Diatchki <[email protected]>
Date:   Sat Sep 22 11:46:04 2012 -0700

    Bugfix: don't generate infinitely many obvious facts.

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

 compiler/typecheck/TcTypeNats.hs |    7 ++++++-
 1 files changed, 6 insertions(+), 1 deletions(-)

diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs
index 8b84d11..8ccedcf 100644
--- a/compiler/typecheck/TcTypeNats.hs
+++ b/compiler/typecheck/TcTypeNats.hs
@@ -31,6 +31,7 @@ import TysWiredIn ( typeNatAddTyCon
 import Bag      ( bagToList )
 import Panic    ( panic )
 import Pair     (Pair(..))
+import UniqSet  ( isEmptyUniqSet )
 
 -- From type checker
 import TcTypeNatsRules( bRules, impRules, widenRules
@@ -62,6 +63,7 @@ import TcSMonad ( TcS, emitFrozenError, setEvBind
                 , modifyInertTcS
                 , traceTcS
                 , partCtFamHeadMap
+                , tyVarsOfCt
                 )
 
 -- From base libraries
@@ -779,12 +781,15 @@ widenAsmps asmps = step given wanted []
     | known c done  = step done cs ds
     | otherwise
       = let active = concatMap (`applyAsmp` c) $ map activate widenRules
-            new = map ruleResultToGiven $ interactActiveRules leq active done
+            new = filter nonTrivial $
+                  map ruleResultToGiven $ interactActiveRules leq active done
         in step (c : done) cs (new ++ ds)
 
   -- For the moment, widedning rules have no ordering side conditions.
   leq = noLeqFacts
 
+  nonTrivial ct = impossible ct || not (isEmptyUniqSet (tyVarsOfCt ct))
+
 
 --------------------------------------------------------------------------------