\begin{code}
module Desugar ( deSugar, deSugarExpr ) where
+import TysWiredIn (unitDataConId)
import DynFlags
import StaticFlags
import HscTypes
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}
%************************************************************************
; (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 {
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 $
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}
= 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
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]
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 #-}