From 98de5f474de6eb5dc9b2e2ec582e02902fdb3856 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Fri, 30 Oct 2009 18:00:51 +0000
Subject: [PATCH] Turn an ASSERT into a WARN

This is to do with SPECIALISE pragmas in instance declarations,
which I need to think more about
---
 compiler/deSugar/DsBinds.lhs |   20 ++++++++++----------
 compiler/hsSyn/HsBinds.lhs   |    3 +++
 2 files changed, 13 insertions(+), 10 deletions(-)

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 0222594..04c84cd 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -144,9 +144,9 @@ dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
 	      ar_env = mkArityEnv binds
 	      do_one (lcl_id, rhs) 
 		| Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
-		= ASSERT( null spec_prags )	  -- Not overloaded
-                  makeCorePair gbl_id (lookupArity ar_env lcl_id) $
-		  addAutoScc auto_scc gbl_id rhs
+		= WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags )	  -- Not overloaded
+                  makeCorePair gbl_id (lookupArity ar_env lcl_id)
+		               (addAutoScc auto_scc gbl_id rhs)
 
 		| otherwise = (lcl_id, rhs)
 
@@ -228,14 +228,14 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 
 	      do_one lg_binds (lcl_id, rhs) 
 		| Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
-		= ASSERT( null spec_prags )	  -- Not overloaded
-                  let rhs' = addAutoScc auto_scc gbl_id  $
-			     mkLams id_tvs $
-			     mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
-			            | tv <- tyvars, not (tv `elem` id_tvs)] $
-		             add_lets lg_binds rhs
+		= WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags )	  -- Not overloaded
+                  (let rhs' = addAutoScc auto_scc gbl_id  $
+			      mkLams id_tvs $
+			      mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
+			             | tv <- tyvars, not (tv `elem` id_tvs)] $
+		              add_lets lg_binds rhs
 		  in return (mk_lg_bind lcl_id gbl_id id_tvs,
-			     makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs')
+			     makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs'))
 		| otherwise
 		= do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
 		     ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index a6d8523..ba3dbd6 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -477,6 +477,9 @@ data SpecPrag
   = SpecPrag   
 	HsWrapper	-- An wrapper, that specialises the polymorphic function
 	InlinePragma 	-- Inlining spec for the specialised function
+
+instance Outputable SpecPrag where
+  ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p
 \end{code}
 
 \begin{code}
-- 
1.7.10.4