[project @ 2004-06-22 11:03:42 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcRnDriver.lhs

diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index 83c99a6..c4707d9 100644 (file)
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -23,7 +23,7 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
 import CmdLineOpts     ( DynFlag(..), opt_PprStyle_Debug, dopt )
 import DriverState     ( v_MainModIs, v_MainFunIs )
 import HsSyn           ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
-                         nlHsApp, nlHsVar )
+                         nlHsApp, nlHsVar, pprLHsBinds )
 import RdrHsSyn                ( findSplice )
 
 import PrelNames       ( runIOName, rootMainName, mAIN_Name,
@@ -33,7 +33,7 @@ import RdrName                ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
 import TcHsSyn         ( zonkTopDecls )
 import TcExpr          ( tcInferRho )
 import TcRnMonad
-import TcType          ( tidyTopType )
+import TcType          ( tidyTopType, isUnLiftedType )
 import Inst            ( showLIE )
 import TcBinds         ( tcTopBinds )
 import TcDefaults      ( tcDefaults )
@@ -62,14 +62,15 @@ import TyCon                ( tyConHasGenerics )
 import SrcLoc          ( srcLocSpan, Located(..), noLoc )
 import Outputable
 import HscTypes                ( ModGuts(..), HscEnv(..),
-                         GhciMode(..), noDependencies,
+                         GhciMode(..), Dependencies(..), noDependencies,
                          Deprecs( NoDeprecs ), plusDeprecs,
                          ForeignStubs(NoStubs), TypeEnv, 
                          extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
                          emptyFixityEnv
                        )
 #ifdef GHCI
-import HsSyn           ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), LStmt, LHsExpr,
+import HsSyn           ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), 
+                         LStmt, LHsExpr, LHsType,
                          collectStmtsBinders, mkSimpleMatch, placeHolderType,
                          nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
 import RdrName         ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
@@ -278,7 +279,7 @@ tcRnStmt hsc_env ictxt rdr_stmt
 
     returnM (new_ic, bound_names, tc_expr)
     }
-\end{code}             
+\end{code}
 
 
 Here is the grand plan, implemented in tcUserStmt
@@ -291,10 +292,10 @@ Here is the grand plan, implemented in tcUserStmt
        pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
                                        bindings: [x,y,...]
 
-       expr (of IO type)       ==>     expr >>= \ v -> return [coerce HVal v]
+       expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
          [NB: result not printed]      bindings: [it]
          
-       expr (of non-IO type,   ==>     let v = expr in print v >> return [coerce HVal v]
+       expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
          result showable)              bindings: [it]
 
        expr (of non-IO type, 
@@ -316,8 +317,8 @@ tcUserStmt (L _ (ExprStmt expr _))
                tc_stmts [
                    nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
                    nlExprStmt (nlHsApp (nlHsVar printName) 
-                                             (nlHsVar fresh_it)) 
-               ] })
+                                             (nlHsVar fresh_it))       
+       ] })
          (do {         -- Try this first 
                traceTc (text "tcs 1a") ;
                tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
@@ -389,10 +390,16 @@ tc_stmts stmts
        zonked_expr <- zonkTopLExpr expr ;
        zonked_ids  <- zonkTopBndrs ids ;
 
+       -- 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) ;
+
        return (zonked_ids, zonked_expr)
        }
   where
     combine stmt (ids, stmts) = (ids, stmt:stmts)
+    bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
+                                 nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
 \end{code}
 
 
@@ -840,6 +847,9 @@ mkExportEnv hsc_env exports
 getModuleExports :: ModuleName -> TcM GlobalRdrEnv
 getModuleExports mod 
   = do { iface <- load_iface mod
+       ; loadOrphanModules (dep_orphs (mi_deps iface))
+                       -- Load any orphan-module interfaces,
+                       -- so their instances are visible
        ; avails <- exportsToAvails (mi_exports iface)
        ; let { gres =  [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
                        | avail <- avails, name <- availNames avail ] }
@@ -897,8 +907,8 @@ filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
 filter_decl occs decl
   = decl
 
-keep_sig occs (IfaceClassOp occ _ _)      = occ `elem` occs
-keep_con occs (IfaceConDecl occ _ _ _ _ _) = occ `elem` occs
+keep_sig occs (IfaceClassOp occ _ _)        = occ `elem` occs
+keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs
 
 availOccs avail = map nameOccName (availNames avail)
 
@@ -1016,7 +1026,7 @@ tcDump env
    }
   where
     short_dump = pprTcGblEnv env
-    full_dump  = ppr (tcg_binds env)
+    full_dump  = pprLHsBinds (tcg_binds env)
        -- NB: foreign x-d's have undefined's in their types; 
        --     hence can't show the tc_fords