[project @ 2002-04-11 12:03:29 by simonpj]

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

diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index aa0fde2..3965a36 100644 (file)
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -4,19 +4,21 @@
 \section[Desugar]{@deSugar@: the main function}
 
 \begin{code}
-module Desugar ( deSugar, deSugarExpr ) where
+module Desugar ( deSugar, deSugarExpr,
+                 deSugarCore ) where
 
 #include "HsVersions.h"
 
 import CmdLineOpts     ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn )
-import HscTypes                ( ModDetails(..) )
+import HscTypes                ( ModDetails(..), TypeEnv )
 import HsSyn           ( MonoBinds, RuleDecl(..), RuleBndr(..), 
                          HsExpr(..), HsBinds(..), MonoBinds(..) )
-import TcHsSyn         ( TypecheckedRuleDecl, TypecheckedHsExpr )
+import TcHsSyn         ( TypecheckedRuleDecl, TypecheckedHsExpr,
+                          TypecheckedCoreBind )
 import TcModule                ( TcResults(..) )
 import Id              ( Id )
 import CoreSyn
-import PprCore         ( pprIdCoreRule, pprCoreExpr )
+import PprCore         ( pprIdRules, pprCoreExpr )
 import Subst           ( substExpr, mkSubst, mkInScopeSet )
 import DsMonad
 import DsExpr          ( dsExpr )
@@ -51,14 +53,14 @@ deSugar :: DynFlags
        -> PersistentCompilerState -> HomeSymbolTable
        -> Module -> PrintUnqualified
         -> TcResults
-       -> IO (ModDetails, (SDoc, SDoc, [CoreBndr]))
+       -> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr]))
 
 deSugar dflags pcs hst mod_name unqual
-        (TcResults {tc_env   = type_env,
-                   tc_binds = all_binds,
-                   tc_insts = insts,
-                   tc_rules = rules,
-                   tc_fords = fo_decls})
+        (TcResults {tc_env    = type_env,
+                   tc_binds  = all_binds,
+                   tc_insts  = insts,
+                   tc_rules  = rules,
+                   tc_fords  = fo_decls})
   = do { showPass dflags "Desugar"
        ; us <- mkSplitUniqSupply 'd'
 
@@ -67,7 +69,7 @@ deSugar dflags pcs hst mod_name unqual
                                             (dsProgram mod_name all_binds rules fo_decls)    
 
              (ds_binds, ds_rules, foreign_stuff) = ds_result
-       
+             
              mod_details = ModDetails { md_types = type_env,
                                         md_insts = insts,
                                         md_rules = ds_rules,
@@ -130,7 +132,7 @@ deSugarExpr dflags pcs hst mod_name unqual tc_expr
 
 dsProgram mod_name all_binds rules fo_decls
   = dsMonoBinds auto_scc all_binds []  `thenDs` \ core_prs ->
-    dsForeigns mod_name fo_decls       `thenDs` \ (fe_binders, foreign_binds, h_code, c_code) ->
+    dsForeigns mod_name fo_decls       `thenDs` \ (fe_binders, foreign_binds, h_code, c_code, headers) ->
     let
        ds_binds      = [Rec (foreign_binds ++ core_prs)]
        -- Notice that we put the whole lot in a big Rec, even the foreign binds
@@ -142,7 +144,7 @@ dsProgram mod_name all_binds rules fo_decls
        local_binders = mkVarSet (bindersOfBinds ds_binds)
     in
     mapDs (dsRule local_binders) rules `thenDs` \ rules' ->
-    returnDs (ds_binds, rules', (h_code, c_code, fe_binders))
+    returnDs (ds_binds, rules', (h_code, c_code, headers, fe_binders))
   where
     auto_scc | opt_SccProfilingOn = TopLevel
             | otherwise          = NoSccs
@@ -150,7 +152,25 @@ dsProgram mod_name all_binds rules fo_decls
 ppr_ds_rules [] = empty
 ppr_ds_rules rules
   = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
-    vcat (map pprIdCoreRule rules)
+    pprIdRules rules
+\end{code}
+
+Simplest thing in the world, desugaring External Core:
+
+\begin{code}
+deSugarCore :: (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])
+           -> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr]))
+deSugarCore (type_env, pairs, rules) 
+  = return (mod_details, no_foreign_stuff)
+  where
+    mod_details = ModDetails { md_types = type_env
+                            , md_insts = []
+                            , md_rules = ds_rules
+                            , md_binds = ds_binds }
+    ds_binds = [Rec pairs]
+    ds_rules = [(fun,rule) | IfaceRuleOut fun rule <- rules]
+
+    no_foreign_stuff = (empty,empty,[],[])
 \end{code}
 
 
@@ -162,13 +182,16 @@ ppr_ds_rules rules
 
 \begin{code}
 dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule)
-dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc)
+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 tpl_vars args core_rhs)
+    returnDs (fn, Rule name act tpl_vars args core_rhs)
   where
-    tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars]
+    tpl_vars = [var | RuleBndr var <- vars]
     all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
 
 ds_lhs all_vars lhs