[commit: ghc] master: A bit more tracing to do with SPECIALISE pragmas (b340681)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/b34068144ec3d7bfe4279b16ad16d54dd46f1c5a/ghc

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

commit b34068144ec3d7bfe4279b16ad16d54dd46f1c5a
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Mar 13 08:36:28 2014 +0000

    A bit more tracing to do with SPECIALISE pragmas


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

b34068144ec3d7bfe4279b16ad16d54dd46f1c5a
 compiler/deSugar/DsBinds.lhs   |    6 +++---
 compiler/typecheck/TcBinds.lhs |    3 ++-
 2 files changed, 5 insertions(+), 4 deletions(-)

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index cd683ba..6d247dd 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -596,7 +596,7 @@ decomposeRuleLhs bndrs lhs
 		where
 		   args' = [Type (idType bndr), Type ty, scrut, body]
 
-	_other -> Left bad_shape_msg
+        _other -> Left bad_shape_msg
  where
    opt_lhs = simpleOptExpr lhs
 
@@ -614,9 +614,9 @@ decomposeRuleLhs bndrs lhs
                           | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
          	          , isDictId d]
 
-
    bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
-                      2 (ppr opt_lhs)
+                      2 (vcat [ text "Optimised lhs:" <+> ppr opt_lhs
+                              , text "Orig lhs:" <+> ppr lhs])
    dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
 			     , ptext (sLit "is not bound in RULE lhs")])
                       2 (ppr opt_lhs)
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 5725e09..8b2928c 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -739,7 +739,8 @@ tcSpecPrags :: Id -> [LSig Name]
 -- Pre-condition: the poly_id is zonked
 -- Reason: required by tcSubExp
 tcSpecPrags poly_id prag_sigs
-  = do { unless (null bad_sigs) warn_discarded_sigs
+  = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
+       ; unless (null bad_sigs) warn_discarded_sigs
        ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs }
   where
     spec_sigs = filter isSpecLSig prag_sigs