GHC API: add checkAndLoadModule

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

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index e2b22ee..692c048 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -6,6 +6,13 @@
 The Desugarer: turning HsSyn into Core.
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module Desugar ( deSugar, deSugarExpr ) where
 
 #include "HsVersions.h"
@@ -65,7 +72,6 @@ deSugar hsc_env
                            tcg_type_env     = type_env,
                            tcg_imports      = imports,
                            tcg_exports      = exports,
-                           tcg_dus          = dus, 
                            tcg_inst_uses    = dfun_uses_var,
                            tcg_th_used      = th_var,
                            tcg_keep         = keep_var,
@@ -78,7 +84,8 @@ deSugar hsc_env
                            tcg_fords        = fords,
                            tcg_rules        = rules,
                            tcg_insts        = insts,
-                           tcg_fam_insts    = fam_insts })
+                           tcg_fam_insts    = fam_insts,
+                           tcg_hpc          = other_hpc_info })
 
   = do { let dflags = hsc_dflags hsc_env
         ; showPass dflags "Desugar"
@@ -87,12 +94,15 @@ deSugar hsc_env
         ; let export_set = availsToNameSet exports
        ; let auto_scc = mkAutoScc mod export_set
         ; let target = hscTarget dflags
+        ; let hpcInfo = emptyHpcInfo other_hpc_info
        ; mb_res <- case target of
-                    HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, emptyModBreaks))
+                    HscNothing -> return (Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
                      _        -> do (binds_cvr,ds_hpc_info, modBreaks) 
-                                             <- if opt_Hpc || target == HscInterpreted
+                                             <- if (opt_Hpc 
+                                                       || target == HscInterpreted)
+                                                    && (not (isHsBoot hsc_src))                                                        
                                                  then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds 
-                                                 else return (binds, noHpcInfo, emptyModBreaks)
+                                                 else return (binds, hpcInfo, emptyModBreaks)
                                     initDs hsc_env mod rdr_env type_env $ do
                                        { core_prs <- dsTopLHsBinds auto_scc binds_cvr
                                        ; (ds_fords, foreign_prs) <- dsForeigns fords
@@ -123,46 +133,16 @@ deSugar hsc_env
        ; doIfSet (dopt Opt_D_dump_ds dflags) 
                  (printDump (ppr_ds_rules ds_rules))
 
-       ; dfun_uses <- readIORef dfun_uses_var          -- What dfuns are used
-       ; th_used   <- readIORef th_var                 -- Whether TH is used
-       ; let used_names = allUses dus `unionNameSets` dfun_uses
-             pkgs | th_used   = insertList thPackageId (imp_dep_pkgs imports)
-                  | otherwise = imp_dep_pkgs imports
-
-             dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
-               -- M.hi-boot can be in the imp_dep_mods, but we must remove
-               -- it before recording the modules on which this one depends!
-               -- (We want to retain M.hi-boot in imp_dep_mods so that 
-               --  loadHiBootInterface can see if M's direct imports depend 
-               --  on M.hi-boot, and hence that we should do the hi-boot consistency 
-               --  check.)
-
-             dir_imp_mods = imp_mods imports
-
-       ; usages <- mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
-
-       ; let 
-               -- Modules don't compare lexicographically usually, 
-               -- but we want them to do so here.
-            le_mod :: Module -> Module -> Bool  
-            le_mod m1 m2 = moduleNameFS (moduleName m1) 
-                               <= moduleNameFS (moduleName m2)
-            le_dep_mod :: (ModuleName, IsBootInterface) -> (ModuleName, IsBootInterface) -> Bool        
-            le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2
-
-            deps = Deps { dep_mods   = sortLe le_dep_mod dep_mods,
-                          dep_pkgs   = sortLe (<=)   pkgs,     
-                          dep_orphs  = sortLe le_mod (imp_orphs  imports),
-                          dep_finsts = sortLe le_mod (imp_finsts imports) }
-               -- sort to get into canonical order
-
-            mod_guts = ModGuts {       
+        ; used_names <- mkUsedNames tcg_env
+       ; deps <- mkDependencies tcg_env
+
+        ; let mod_guts = ModGuts {     
                mg_module       = mod,
                mg_boot         = isHsBoot hsc_src,
                mg_exports      = exports,
                mg_deps         = deps,
-               mg_usages       = usages,
-               mg_dir_imps     = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
+               mg_used_names   = used_names,
+               mg_dir_imps     = imp_mods imports,
                mg_rdr_env      = rdr_env,
                mg_fix_env      = fix_env,
                mg_deprecs      = deprecs,