fix compile error due to erroneous import

[ghc-hetmet.git] / compiler / deSugar / Desugar.lhs

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 60dec30..2898460 100644 (file)
--- 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
@@ -40,6 +41,7 @@ import MonadUtils
 import OrdList
 import Data.List
 import Data.IORef
+import Control.Exception ( catch, ErrorCall, Exception(..) )
 \end{code}
 
 %************************************************************************
@@ -134,7 +136,25 @@ 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
 
         ; let used_names = mkUsedNames tcg_env
@@ -222,7 +242,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 $
@@ -232,8 +252,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}