[commit: ghc] type-nats: Fix to avoid missing unsolved constraints (XXX: check with GHC HQ about this) (ca6fa12)

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

On branch  : type-nats

http://hackage.haskell.org/trac/ghc/changeset/ca6fa121bbf0ee0cb7a4675face0566e5e1861c7

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

commit ca6fa121bbf0ee0cb7a4675face0566e5e1861c7
Author: Iavor S. Diatchki <[email protected]>
Date:   Sun Sep 9 01:03:33 2012 -0700

    Fix to avoid missing unsolved constraints (XXX: check with GHC HQ about this)

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

 compiler/typecheck/TcErrors.lhs |    4 ++++
 compiler/types/Type.lhs         |   19 ++++++++++++++++++-
 2 files changed, 22 insertions(+), 1 deletions(-)

diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index bbf5ae6..fc5d393 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -210,6 +210,10 @@ reportInsolsAndFlats ctxt insols flats
       = True
       | otherwise 
       = case pred of
+          EqPred ty1 ty2
+            | Just tc <- isTyFun_maybe ty1, isTypeNatSpecialFunTyCon tc -> True
+            | Just tc <- isTyFun_maybe ty2, isTypeNatSpecialFunTyCon tc -> True
+
           EqPred ty1 ty2 -> isNothing (isTyFun_maybe ty1) && isNothing (isTyFun_maybe ty2)
           _              -> False
 
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 9954a45..be785a2 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -46,6 +46,7 @@ module Type (
         mkNumLitTy, isNumLitTy,
         mkStrLitTy, isStrLitTy,
         isTyLit,
+        isTypeNatSpecialFunTyCon,
 	
 	-- (Newtypes)
 	newTyConInstRhs, carefullySplitNewType_maybe,
@@ -159,7 +160,14 @@ import Class
 import TyCon
 import TysPrim
 import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy )
-import PrelNames	         ( eqTyConKey, ipClassName )
+import PrelNames( eqTyConKey, ipClassName
+                , typeNatAddTyFamName
+                , typeNatMulTyFamName
+                , typeNatExpTyFamName
+                , typeNatLeqTyFamName
+                )
+
+
 
 -- others
 import Name             ( Name )
@@ -427,6 +435,15 @@ isTyLit :: Type -> Maybe TyLit
 isTyLit (LitTy x) = Just x
 isTyLit _         = Nothing
 
+isTypeNatSpecialFunTyCon :: TyCon -> Bool
+isTypeNatSpecialFunTyCon tc =
+  n == typeNatAddTyFamName ||
+  n == typeNatMulTyFamName ||
+  n == typeNatExpTyFamName ||
+  n == typeNatLeqTyFamName
+  where n = tyConName tc
+
+
 \end{code}