Turn an ASSERT into a WARN

This is to do with SPECIALISE pragmas in instance declarations,
which I need to think more about

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 0222594..04c84cd 100644 (file)
--- 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 (file)
--- 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}