X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyFuns.lhs;h=5777955ed73cd5536c52baec3d4aa004a38b31b2;hb=0bc0144c2b982da47af56037bd2e3eac84e9560e;hp=2237e3f19f446c66a8d3dc4b682642b7e71146f8;hpb=32a5c61dc1df5e12aaf1f21e5928fbb261d62043;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcTyFuns.lhs b/compiler/typecheck/TcTyFuns.lhs
index 2237e3f..5777955 100644
--- a/compiler/typecheck/TcTyFuns.lhs
+++ b/compiler/typecheck/TcTyFuns.lhs
@@ -37,6 +37,7 @@ import Name
 import Bag
 import Outputable
 import SrcLoc	( Located(..) )
+import Util	( debugIsOn )
 import Maybes
 import FastString
 
@@ -69,21 +70,16 @@ tcUnfoldSynFamInst (TyConApp tycon tys)
   | not (isOpenSynTyCon tycon)     -- unfold *only* _synonym_ family instances
   = return Nothing
   | otherwise
-  = do { -- we only use the indexing arguments for matching, 
-         -- not the additional ones
-       ; maybeFamInst <- tcLookupFamInst tycon idxTys
+  = do { -- The TyCon might be over-saturated, but that's ok for tcLookupFamInst
+       ; maybeFamInst <- tcLookupFamInst tycon tys
        ; case maybeFamInst of
            Nothing                -> return Nothing
-           Just (rep_tc, rep_tys) -> return $ Just (mkTyConApp rep_tc tys',
-		                                    mkTyConApp coe_tc tys')
+           Just (rep_tc, rep_tys) -> return $ Just (mkTyConApp rep_tc rep_tys,
+		                                    mkTyConApp coe_tc rep_tys)
              where
-               tys'   = rep_tys ++ restTys
                coe_tc = expectJust "TcTyFuns.tcUnfoldSynFamInst" 
                                    (tyConFamilyCoercion_maybe rep_tc)
        }
-    where
-        n                = tyConArity tycon
-        (idxTys, restTys) = splitAt n tys
 tcUnfoldSynFamInst _other = return Nothing
 \end{code}
 
@@ -283,7 +279,15 @@ no further propoagation is possible.
 --
 normaliseEqs :: [Inst] -> TcM EqConfig
 normaliseEqs eqs 
-  = do { ASSERTM2( allM wantedEqInstIsUnsolved eqs, ppr eqs )
+  = do { if debugIsOn then do { all_unsolved <- allM wantedEqInstIsUnsolved eqs
+       	    	      	      ; let msg = ptext (sLit "(This warning is harmless; for Simon & Manuel)")
+       	    	      	      ; WARN( not all_unsolved, msg $$ ppr eqs ) return () }
+		      else return ()
+	    -- This is just a warning (not an error) because a current
+	    -- harmless bug means that we sometimes solve the same
+	    -- equality more than once It'll go away with the new
+	    -- solver. See Trac #2999 for example
+
        ; traceTc $ ptext (sLit "Entering normaliseEqs")
 
        ; (eqss, skolemss) <- mapAndUnzipM normEqInst eqs