Remove GADT refinements, part 3
[ghc-hetmet.git] / compiler / typecheck / TcRnDriver.lhs
index c744c15..43b9d38 100644 (file)
@@ -69,7 +69,7 @@ import ErrUtils
 import Id
 import Var
 import Module
-import UniqFM
+import LazyUniqFM
 import Name
 import NameEnv
 import NameSet
@@ -85,7 +85,6 @@ import DataCon
 import TcHsType
 import TcMType
 import TcMatches
-import TcGadt
 import RnTypes
 import RnExpr
 import IfaceEnv
@@ -102,7 +101,7 @@ import Maybes
 import Util
 import Bag
 
-import Control.Monad    ( unless )
+import Control.Monad
 import Data.Maybe      ( isJust )
 
 \end{code}
@@ -320,8 +319,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 
        mod_guts = ModGuts {    mg_module    = this_mod,
                                mg_boot      = False,
-                               mg_usages    = [],              -- ToDo: compute usage
-                               mg_dir_imps  = [],              -- ??
+                               mg_used_names = emptyNameSet, -- ToDo: compute usage
+                               mg_dir_imps  = emptyModuleEnv, -- ??
                                mg_deps      = noDependencies,  -- ??
                                mg_exports   = my_exports,
                                mg_types     = final_type_env,
@@ -896,19 +895,10 @@ tcRnStmt hsc_env ictxt rdr_stmt
     
        -- None of the Ids should be of unboxed type, because we
        -- cast them all to HValues in the end!
-    mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
+    mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
 
     traceTc (text "tcs 1") ;
-    let {      -- (a) Make all the bound ids "global" ids, now that
-               --     they're notionally top-level bindings.  This is
-               --     important: otherwise when we come to compile an expression
-               --     using these ids later, the byte code generator will consider
-               --     the occurrences to be free rather than global.
-               -- 
-               -- (b) Tidy their types; this is important, because :info may
-               --     ask to look at them, and :info expects the things it looks
-               --     up to have tidy types
-       global_ids = map globaliseAndTidy zonked_ids ;
+    let { global_ids = map globaliseAndTidy zonked_ids } ;
     
 {- ---------------------------------------------
    At one stage I removed any shadowed bindings from the type_env;
@@ -928,26 +918,47 @@ tcRnStmt hsc_env ictxt rdr_stmt
    Hence this code is commented out
 
 -------------------------------------------------- -}
-    } ;
 
     dumpOptTcRn Opt_D_dump_tc 
        (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
               text "Typechecked expr" <+> ppr zonked_expr]) ;
 
-    returnM (global_ids, zonked_expr)
+    return (global_ids, zonked_expr)
     }
   where
     bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
                                  nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
 
 globaliseAndTidy :: Id -> Id
-globaliseAndTidy id
--- Give the Id a Global Name, and tidy its type
+globaliseAndTidy id    -- Note [Interactively-bound Ids in GHCi]
   = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
   where
     tidy_type = tidyTopType (idType id)
 \end{code}
 
+Note [Interactively-bound Ids in GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The Ids bound by previous Stmts in Template Haskell are currently
+       a) GlobalIds
+       b) with an Internal Name (not External)
+       c) and a tidied type
+
+ (a) They must be GlobalIds (not LocalIds) otherwise when we come to
+     compile an expression using these ids later, the byte code
+     generator will consider the occurrences to be free rather than
+     global.
+
+ (b) They retain their Internal names becuase we don't have a suitable
+     Module to name them with.  We could revisit this choice.
+
+ (c) Their types are tidied.  This is important, because :info may ask
+     to look at them, and :info expects the things it looks up to have
+     tidy types
+       
+
+--------------------------------------------------------------------------
+               Typechecking Stmts in GHCi
+
 Here is the grand plan, implemented in tcUserStmt
 
        What you type                   The IO [HValue] that hscStmt returns
@@ -1000,7 +1011,7 @@ mkPlan (L loc (ExprStmt expr _ _))        -- An expression typed at the prompt
        ; runPlans [    -- Plan A
                    do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
                       ; it_ty <- zonkTcType (idType it_id)
-                      ; ifM (isUnitTy it_ty) failM
+                      ; when (isUnitTy it_ty) failM
                       ; return stuff },
 
                        -- Plan B; a naked bind statment
@@ -1025,7 +1036,7 @@ mkPlan stmt@(L loc (BindStmt {}))
        ; let print_plan = do
                  { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
                  ; v_ty <- zonkTcType (idType v_id)
-                 ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
+                 ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
                  ; return stuff }
 
        -- The plans are:
@@ -1044,11 +1055,9 @@ tcGhciStmts stmts
  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
        ret_id  <- tcLookupId returnIOName ;            -- return @ IO
        let {
-           io_ty     = mkTyConApp ioTyCon [] ;
            ret_ty    = mkListTy unitTy ;
            io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
-           tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts 
-                                       (emptyRefinement, io_ret_ty) ;
+           tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts io_ret_ty ;
 
            names = map unLoc (collectLStmtsBinders stmts) ;
 
@@ -1072,7 +1081,7 @@ tcGhciStmts stmts
        -- OK, we're ready to typecheck the stmts
        traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ;
        ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
-                                          mappM tcLookupId names ;
+                                          mapM tcLookupId names ;
                                        -- Look up the names right in the middle,
                                        -- where they will all be in scope
 
@@ -1317,8 +1326,8 @@ tcDump env
  = do { dflags <- getDOpts ;
 
        -- Dump short output if -ddump-types or -ddump-tc
-       ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
-           (dumpTcRn short_dump) ;
+       when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
+            (dumpTcRn short_dump) ;
 
        -- Dump bindings if -ddump-tc
        dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
@@ -1331,8 +1340,8 @@ tcDump env
 
 tcCoreDump mod_guts
  = do { dflags <- getDOpts ;
-       ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
-           (dumpTcRn (pprModGuts mod_guts)) ;
+       when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
+            (dumpTcRn (pprModGuts mod_guts)) ;
 
        -- Dump bindings if -ddump-tc
        dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }