[commit: ghc] type-nats: Fix uses of (<=?) as a function to reduce properly. (87d2a63)

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

On branch  : type-nats

http://hackage.haskell.org/trac/ghc/changeset/87d2a63b8d74422c5f3e3d8c06b9f760983c85dc

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

commit 87d2a63b8d74422c5f3e3d8c06b9f760983c85dc
Author: Iavor S. Diatchki <[email protected]>
Date:   Sun Nov 11 18:16:21 2012 -0800

    Fix uses of (<=?) as a function to reduce properly.

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

 compiler/typecheck/TcTypeNats.hs      |   10 ++++++++--
 compiler/typecheck/TcTypeNatsRules.hs |    5 ++++-
 2 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs
index 3d96835..4e1ce9f 100644
--- a/compiler/typecheck/TcTypeNats.hs
+++ b/compiler/typecheck/TcTypeNats.hs
@@ -25,6 +25,7 @@ import Type     ( Type, isNumLitTy, getTyVar_maybe, isTyVarTy, mkNumLitTy
 import TysWiredIn ( typeNatAddTyCon
                   , typeNatMulTyCon
                   , typeNatExpTyCon
+                  , typeNatLeqTyCon
                   , trueTy, falseTy
                   , nat1Kind, succTy
                   )
@@ -36,7 +37,8 @@ import UniqSet  ( isEmptyUniqSet )
 -- From type checker
 import TcTypeNatsRules( bRules, iffRules, impRules, widenRules
                       , axAddDef, axMulDef, axExpDef, axLeqDef
-                      , natVars, leqRefl, leqTrans, leq0, leqAsym)
+                      , natVars, boolVars
+                      , leqRefl, leqTrans, leq0, leqAsym)
 import TcTypeNatsEval ( minus, divide, logExact, rootExact )
 import TcCanonical( StopOrContinue(..) )
 import TcRnTypes  ( Ct(..), isGiven, isWanted, ctEvidence, ctEvId
@@ -573,7 +575,10 @@ funRule tc = AR
                 , (1, (TPCon tc [ TPVar a, TPVar b], TPVar c2)) ]
   , concl     = (TPVar c1, TPVar c2)
   }
-  where a : b : c1 : c2 : _ = natVars
+  where a : b : c1 : c2 : _
+           | tyConName tc == typeNatLeqTyFamName
+                       = take 2 natVars ++ drop 2 boolVars
+           | otherwise = natVars
 
 
 
@@ -826,6 +831,7 @@ interactCt withEv ct asmps0
               $ funRule typeNatAddTyCon
               : funRule typeNatMulTyCon
               : funRule typeNatExpTyCon
+              : funRule typeNatLeqTyCon
               : map activate (widenRules ++ impRules)
 
       (leq, asmps) = makeLeqModel asmps0
diff --git a/compiler/typecheck/TcTypeNatsRules.hs b/compiler/typecheck/TcTypeNatsRules.hs
index 522d2d2..23d3c67 100644
--- a/compiler/typecheck/TcTypeNatsRules.hs
+++ b/compiler/typecheck/TcTypeNatsRules.hs
@@ -15,7 +15,7 @@ import TysWiredIn ( typeNatAddTyCon
                   , typeNatExpTyCon
                   , typeNatLeqTyCon
                   , typeNatSubTyCon
-                  , trueTy, falseTy
+                  , boolKind, trueTy, falseTy
                   , nat1Kind, zeroTy
                   , fromNat1TyCon
                   )
@@ -72,6 +72,9 @@ mkFromNat1 a = mkTyConApp fromNat1TyCon [a]
 natVars :: [TyVar]
 natVars = tyVarList typeNatKind
 
+boolVars :: [TyVar]
+boolVars = tyVarList boolKind
+
 nat1Vars :: [TyVar]
 nat1Vars = tyVarList nat1Kind