+ dflags = hsc_dflags hsc_env
+ print_unqual = unQualInScope rdr_env
+
+ -- Desugarer warnings are SDocs; here we
+ -- add the info about whether or not to print unqualified
+ mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc)
+ mk_warn (loc, sdoc) = addShortWarnLocLine loc print_unqual sdoc
+
+ -- The lookup function passed to initDs is used for well-known Ids,
+ -- such as fold, build, cons etc, so the chances are
+ -- it'll be found in the package symbol table. That's
+ -- why we don't merge all these tables
+ eps = pcs_EPS pcs
+ pte = eps_PTE eps
+ hpt = hsc_HPT hsc_env
+ lookup n = case lookupType hpt pte n of {
+ Just v -> v ;
+ other ->
+ case lookupNameEnv type_env n of
+ Just v -> v ;
+ other -> pprPanic "Desugar: lookup:" (ppr n)
+ }
+
+deSugarExpr :: HscEnv
+ -> PersistentCompilerState
+ -> Module -> PrintUnqualified
+ -> TypecheckedHsExpr
+ -> IO CoreExpr
+deSugarExpr hsc_env pcs mod_name unqual tc_expr
+ = do { showPass dflags "Desugar"
+ ; us <- mkSplitUniqSupply 'd'
+
+ -- Do desugaring
+ ; let (core_expr, ds_warns) = initDs dflags us lookup mod_name (dsExpr tc_expr)
+ warn_doc = pprBagOfWarnings (mapBag mk_warn ds_warns)
+ mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc)
+ mk_warn (loc,sdoc) = addShortWarnLocLine loc unqual sdoc
+
+ -- Display any warnings
+ ; doIfSet (not (isEmptyBag ds_warns))
+ (printErrs warn_doc)
+
+ -- Dump output
+ ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
+
+ ; return core_expr
+ }
+ where
+ dflags = hsc_dflags hsc_env
+ hpt = hsc_HPT hsc_env
+ pte = eps_PTE (pcs_EPS pcs)
+ lookup n = case lookupType hpt pte n of
+ Just v -> v
+ other -> pprPanic "Desugar: lookup:" (ppr n)
+
+dsProgram all_binds rules fo_decls
+ = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs ->
+ dsForeigns fo_decls `thenDs` \ (ds_fords, foreign_binds) ->
+ let
+ ds_binds = [Rec (foreign_binds ++ core_prs)]
+ -- Notice that we put the whole lot in a big Rec, even the foreign binds
+ -- When compiling PrelFloat, which defines data Float = F# Float#
+ -- we want F# to be in scope in the foreign marshalling code!
+ -- You might think it doesn't matter, but the simplifier brings all top-level
+ -- things into the in-scope set before simplifying; so we get no unfolding for F#!
+
+ local_binders = mkVarSet (bindersOfBinds ds_binds)
+ in
+ mapDs (dsRule local_binders) rules `thenDs` \ ds_rules ->
+ returnDs (ds_binds, ds_rules, ds_fords)
+ where
+ auto_scc | opt_SccProfilingOn = TopLevel
+ | otherwise = NoSccs
+
+ppr_ds_rules [] = empty
+ppr_ds_rules rules
+ = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
+ pprIdRules rules
+\end{code}
+
+
+
+%************************************************************************
+%* *
+%* Desugaring transformation rules
+%* *
+%************************************************************************
+
+\begin{code}
+dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule)
+dsRule in_scope (IfaceRuleOut fun rule) -- Built-in rules come this way
+ = returnDs (fun, rule)
+
+dsRule in_scope (HsRule name act vars lhs rhs loc)
+ = putSrcLocDs loc $
+ ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
+ dsExpr rhs `thenDs` \ core_rhs ->
+ returnDs (fn, Rule name act tpl_vars args core_rhs)
+ where
+ tpl_vars = [var | RuleBndr var <- vars]
+ all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
+
+ds_lhs all_vars lhs
+ = let
+ (dict_binds, body) = case lhs of
+ (HsLet (MonoBind dict_binds _ _) body) -> (dict_binds, body)
+ other -> (EmptyMonoBinds, lhs)
+ in
+ ds_dict_binds dict_binds `thenDs` \ dict_binds' ->
+ dsExpr body `thenDs` \ body' ->
+
+ -- Substitute the dict bindings eagerly,
+ -- and take the body apart into a (f args) form
+ let
+ subst_env = mkSubstEnv [id | (id,rhs) <- dict_binds']
+ [ContEx subst_env rhs | (id,rhs) <- dict_binds']
+ -- Note recursion here... substitution won't terminate
+ -- if there is genuine recursion... which there isn't