Refactor TcRnDriver, and check exports on hi-boot files

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

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 9fb2eaf..d974c05 100644 (file)
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -23,11 +23,13 @@ import {-# SOURCE #-}       Match( matchWrapper )
 import DsMonad
 import DsGRHSs
 import DsUtils
+import DsBreakpoint
 
 import HsSyn           -- lots of things
 import CoreSyn         -- lots of things
 import CoreUtils
 
+import TcHsSyn         ( mkArbitraryType )     -- Mis-placed?
 import OccurAnal
 import CostCentre
 import Module
@@ -45,6 +47,10 @@ import BasicTypes hiding ( TopLevel )
 import FastString
 import Util            ( mapSnd )
 
+import Name
+import OccName
+import Literal
+
 import Control.Monad
 import Data.List
 \end{code}
@@ -57,7 +63,23 @@ import Data.List
 
 \begin{code}
 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+dsTopLHsBinds auto_scc binds = do
+  mb_mod_name_ref <- getModNameRefDs
+  debugging <- breakpoints_enabled
+  case mb_mod_name_ref of 
+    Nothing | debugging -> do  -- Inject a CAF with the module name as literal
+      mod <- getModuleDs
+      mod_name_ref <- do
+                 u <- newUnique 
+                 let n = mkSystemName u (mkVarOcc "_module")
+                 return (mkLocalId n stringTy)
+      let mod_name = moduleNameFS$ moduleName mod
+      mod_lit <- dsExpr (HsLit (HsString mod_name))
+      withModNameRefDs mod_name_ref $ do
+                 res <- ds_lhs_binds auto_scc binds
+                 return$ (mod_name_ref, mod_lit) : res
+    _  -> ds_lhs_binds auto_scc binds
+
 
 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
 dsLHsBinds binds = ds_lhs_binds NoSccs binds
@@ -88,9 +110,10 @@ dsHsBind auto_scc rest (VarBind var expr)
     addDictScc var core_expr   `thenDs` \ core_expr' ->
     returnDs ((var, core_expr') : rest)
 
-dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })
+dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick })
   = matchWrapper (FunRhs (idName fun)) matches         `thenDs` \ (args, body) ->
-    dsCoercion co_fn (return (mkLams args body))       `thenDs` \ rhs ->
+    mkOptTickBox tick body                             `thenDs` \ body' ->
+    dsCoercion co_fn (return (mkLams args body'))      `thenDs` \ rhs ->
     returnDs ((fun,rhs) : rest)
 
 dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
@@ -178,7 +201,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 
              mk_bind ((tyvars, global, local, prags), n)       -- locals !! n == local
                =       -- Need to make fresh locals to bind in the selector, because
-                       -- some of the tyvars will be bound to voidTy
+                       -- some of the tyvars will be bound to 'Any'
                  do { locals' <- newSysLocalsDs (map substitute local_tys)
                     ; tup_id  <- newSysLocalDs  (substitute tup_ty)
                     ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) 
@@ -191,7 +214,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
                     ; returnDs ((global', rhs) : spec_binds) }
                where
                  mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
-                                     | otherwise               = voidTy
+                                     | otherwise               = mkArbitraryType all_tyvar
                  ty_args    = map mk_ty_arg all_tyvars
                  substitute = substTyWith all_tyvars ty_args
 
@@ -266,11 +289,11 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
                                (mkVarApps (Var spec_id) bndrs)
        }
   where
-       -- Bind to voidTy any of all_ptvs that aren't 
+       -- Bind to Any any of all_ptvs that aren't 
        -- relevant for this particular function 
     fix_up body | null void_tvs = body
                | otherwise     = mkTyApps (mkLams void_tvs body) 
-                                          (map (const voidTy) void_tvs)
+                                          (map mkArbitraryType void_tvs)
     void_tvs = all_tvs \\ tvs
 
     msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))