X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDesugar.lhs;h=7d0be3f65b507d7b720c82be7a79a7d73ace6e49;hp=d154e045ab8860634d5bb63378ea54597c35b26e;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=92267aa26adb1ab5a6d8004a80fdf6aa06ea4e44

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index d154e04..7d0be3f 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -8,6 +8,7 @@ The Desugarer: turning HsSyn into Core.
 \begin{code}
 module Desugar ( deSugar, deSugarExpr ) where
 
+import TysWiredIn (unitDataConId)
 import DynFlags
 import StaticFlags
 import HscTypes
@@ -34,13 +35,14 @@ import CoreMonad	( endPass, CoreToDo(..) )
 import ErrUtils
 import Outputable
 import SrcLoc
-import FastString
 import Coverage
 import Util
 import MonadUtils
 import OrdList
 import Data.List
 import Data.IORef
+import DsHetMet
+import Control.Exception ( catch, ErrorCall, Exception(..) )
 \end{code}
 
 %************************************************************************
@@ -135,10 +137,28 @@ deSugar hsc_env
 	; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
 	      		 -- The simpleOptPgm gets rid of type 
 			 -- bindings plus any stupid dead code
-
+{-
+        ; dumpIfSet_dyn dflags Opt_D_dump_proof "input to flattener" (text $ showSDoc $ pprCoreBindings ds_binds)
+        ; let uhandler (err::ErrorCall)
+                      = dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof"
+                                       (text $ "\\begin{verbatim}\n" ++
+                                               show err ++
+                                               "\\end{verbatim}\n\n")
+          in (dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof" $
+               (vcat (map (\ bind -> let e = case bind of
+                                               NonRec b e -> e
+                                               Rec    lve -> Let (Rec lve) (Var unitDataConId)
+                                     in text $ "\\begin{verbatim}\n" ++
+                                               (showSDoc $ pprCoreBindings ds_binds) ++
+                                               "\\end{verbatim}\n\n" ++
+                                               "$$\n"++
+                                               (core2proofAndShow e) ++
+                                               "$$\n"
+                          ) ds_binds))) `Control.Exception.catch` uhandler
+-}
 	; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
 
-        ; used_names <- mkUsedNames tcg_env
+        ; let used_names = mkUsedNames tcg_env
 	; deps <- mkDependencies tcg_env
 
         ; let mod_guts = ModGuts {	
@@ -223,7 +243,7 @@ deSugarExpr :: HscEnv
 
 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
     let dflags = hsc_dflags hsc_env
-    showPass dflags "Desugar"
+    showPass dflags "Desugarz"
 
     -- Do desugaring
     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
@@ -233,8 +253,10 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
       Nothing   -> return (msgs, Nothing)
       Just expr -> do
 
+{-
         -- Dump output
-        dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
+        dumpIfSet_dyn dflags Opt_D_dump_ds    "Desugared"            (text $ "$$\n"++(core2proofAndShow expr)++"$$\n")
+-}
 
         return (msgs, Just expr)
 \end{code}
@@ -338,16 +360,17 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
   = putSrcSpanDs loc $ 
     do	{ let bndrs' = [var | RuleBndr (L _ var) <- vars]
 
-	; lhs' <- unsetOptM Opt_EnableRewriteRules $
-	          dsLExpr lhs	-- Note [Desugaring RULE left hand sides]
+        ; lhs' <- unsetOptM Opt_EnableRewriteRules $
+                  unsetOptM Opt_WarnIdentities $
+                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 
 	; rhs' <- dsLExpr rhs
 
 	-- Substitute the dict bindings eagerly,
 	-- and take the body apart into a (f args) form
-	; case decomposeRuleLhs lhs' of {
-		Nothing -> do { warnDs msg; return Nothing } ;
-		Just (fn_id, args) -> do
+	; case decomposeRuleLhs bndrs' lhs' of {
+		Left msg -> do { warnDs msg; return Nothing } ;
+		Right (final_bndrs, fn_id, args) -> do
 	
 	{ let is_local = isLocalId fn_id
 		-- NB: isLocalId is False of implicit Ids.  This is good becuase
@@ -356,12 +379,9 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
 	      fn_name   = idName fn_id
 	      final_rhs = simpleOptExpr rhs'	-- De-crap it
 	      rule      = mkRule False {- Not auto -} is_local 
-                                 name act fn_name bndrs' args final_rhs
+                                 name act fn_name final_bndrs args final_rhs
 	; return (Just rule)
 	} } }
-  where
-    msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored"))
-	     2 (ppr lhs)
 \end{code}
 
 Note [Desugaring RULE left hand sides]
@@ -374,4 +394,6 @@ switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 
 That keeps the desugaring of list comprehensions simple too.
 
-
+Nor do we want to warn of conversion identities on the LHS;
+the rule is precisly to optimise them:
+  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}