[project @ 2001-03-02 17:35:20 by simonmar]

Fix :type again, by resurrecting typecheckExpr.  Now the expression
doesn't get the monomorphism restriction applied to it.

3 files changed, 147 insertions, 40 deletions

diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 0e10626e2a..bae0a213cd 100644
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -186,11 +186,11 @@ cmRunStmt cmstate dflags expr
 	       	ic_module   = this_mod } = icontext
 
         (new_pcs, maybe_stuff) 
-	    <- hscStmt dflags hst hit pcs icontext expr
+	    <- hscStmt dflags hst hit pcs icontext expr False{-stmt-}
 
         case maybe_stuff of
 	   Nothing -> return (cmstate{ pcs=new_pcs }, [])
-	   Just (ids, bcos) -> do
+	   Just (ids, _, bcos) -> do
 
 		-- update the interactive context
 	        let 
@@ -227,12 +227,24 @@ cmRunStmt cmstate dflags expr
 #ifdef GHCI
 cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String)
 cmTypeOfExpr cmstate dflags expr
-  = do (new_cmstate, names)
-	   <- cmRunStmt cmstate dflags ("let __cmTypeOfExpr = " ++ expr)
-       case names of
-	 [name] -> do maybe_tystr <- cmTypeOfName new_cmstate name
-		      return (new_cmstate, maybe_tystr)
-	 _other -> return (new_cmstate, Nothing)
+   = do (new_pcs, maybe_stuff) 
+	  <- hscStmt dflags hst hit pcs ic expr True{-just an expr-}
+
+	let new_cmstate = cmstate{pcs = new_pcs}
+
+	case maybe_stuff of
+	   Nothing -> return (new_cmstate, Nothing)
+	   Just (_, ty, _) ->
+	     let pit = pcs_PIT pcs
+	         modname = moduleName (ic_module ic)
+	         tidy_ty = tidyType emptyTidyEnv ty
+	         str = case lookupIfaceByModName hit pit modname of
+			  Nothing    -> showSDoc (ppr tidy_ty)
+			  Just iface -> showSDocForUser unqual (ppr tidy_ty)
+		  	     where unqual = unQualInScope (mi_globals iface)
+	     in return (new_cmstate, Just str)
+   where
+       CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate
 #endif
 
 -----------------------------------------------------------------------------
@@ -270,11 +282,11 @@ cmCompileExpr cmstate dflags expr
 
         (new_pcs, maybe_stuff) 
 	    <- hscStmt dflags hst hit pcs icontext 
-		  ("let __cmCompileExpr = "++expr)
+		  ("let __cmCompileExpr = "++expr) False{-stmt-}
 
         case maybe_stuff of
 	   Nothing -> return (cmstate{ pcs=new_pcs }, Nothing)
-	   Just (ids, bcos) -> do
+	   Just (ids, _, bcos) -> do
 
 		-- link it
 		hval <- linkExpr pls bcos
@@ -801,8 +813,13 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here
 
             source_unchanged = isJust maybe_old_linkable
 
+	   -- in interactive mode, all home modules below us *must* have an
+	   -- interface in the HIT.  We never demand-load home interfaces in
+	   -- interactive mode.
             (hst1_strictDC, hit1_strictDC)
-               = retainInTopLevelEnvs 
+               = ASSERT(ghci_mode == Batch || 
+		        all (`elemUFM` hit1) reachable_from_here)
+		 retainInTopLevelEnvs 
                     (filter (/= (name_of_summary summary1)) reachable_from_here)
                     (hst1,hit1)
 
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 29de2ac167..4bbf8557e9 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -34,6 +34,7 @@ import PrelInfo		( wiredInThingEnv, wiredInThings )
 import PrelNames	( vanillaSyntaxMap, knownKeyNames, iNTERACTIVE )
 import MkIface		( completeIface, mkModDetailsFromIface, mkModDetails,
 			  writeIface, pprIface )
+import Type		( Type )
 import TcModule
 import InstEnv		( emptyInstEnv )
 import Desugar
@@ -417,9 +418,11 @@ hscStmt
   -> PersistentCompilerState    -- IN: persistent compiler state
   -> InteractiveContext		-- Context for compiling
   -> String			-- The statement
+  -> Bool			-- just treat it as an expression
   -> IO ( PersistentCompilerState, 
 	  Maybe ( [Id], 
-		 UnlinkedBCOExpr) )
+		  Type, 
+		  UnlinkedBCOExpr) )
 \end{code}
 
 When the UnlinkedBCOExpr is linked you get an HValue of type
@@ -449,7 +452,7 @@ A naked expression returns a singleton Name [it].
 	  result not showable)	==>	error
 
 \begin{code}
-hscStmt dflags hst hit pcs0 icontext stmt
+hscStmt dflags hst hit pcs0 icontext stmt just_expr
    = let 
 	InteractiveContext { 
 	     ic_rn_env   = rn_env, 
@@ -461,6 +464,15 @@ hscStmt dflags hst hit pcs0 icontext stmt
       	     Nothing -> return (pcs0, Nothing)
       	     Just parsed_stmt -> do {
 
+	   let { notExprStmt (ExprStmt _ _) = False;
+	         notExprStmt _              = True 
+	       };
+
+	   if (just_expr && notExprStmt parsed_stmt)
+		then do hPutStrLn stderr ("not an expression: `" ++ stmt ++ "'")
+		        return (pcs0, Nothing)
+		else do {
+
 		-- Rename it
 	  (pcs1, print_unqual, maybe_renamed_stmt)
 		 <- renameStmt dflags hit hst pcs0 scope_mod 
@@ -471,12 +483,17 @@ hscStmt dflags hst hit pcs0 icontext stmt
 		Just (bound_names, rn_stmt) -> do {
 
 		-- Typecheck it
-	  maybe_tc_return 
-		<- typecheckStmt dflags pcs1 hst type_env
-				   print_unqual iNTERACTIVE bound_names rn_stmt
-	; case maybe_tc_return of {
-		Nothing -> return (pcs0, Nothing) ;
-		Just (pcs2, tc_expr, bound_ids) -> do {
+	  maybe_tc_return <- 
+	    if just_expr 
+		then case rn_stmt of { (syn, ExprStmt e _, decls) -> 
+		     typecheckExpr dflags pcs1 hst type_env
+			   print_unqual iNTERACTIVE (syn,e,decls) }
+		else typecheckStmt dflags pcs1 hst type_env
+			   print_unqual iNTERACTIVE bound_names rn_stmt
+
+	; case maybe_tc_return of
+		Nothing -> return (pcs0, Nothing)
+		Just (pcs2, tc_expr, bound_ids, ty) ->  do {
 
 		-- Desugar it
 	  ds_expr <- deSugarExpr dflags pcs2 hst iNTERACTIVE print_unqual tc_expr
@@ -505,7 +522,8 @@ hscStmt dflags hst hit pcs0 icontext stmt
 		 = modifyIdInfo (`setFlavourInfo` makeConstantFlavour 
 					(idFlavour id)) id
 
-	; return (pcs2, Just (constant_bound_ids, bcos))
+	; return (pcs2, Just (constant_bound_ids, ty, bcos))
+
      }}}}}
 
 hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index ed05fb9343..9e063a0c06 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -5,7 +5,8 @@
 
 \begin{code}
 module TcModule (
-	typecheckModule, typecheckIface, typecheckStmt, TcResults(..)
+	typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
+	TcResults(..)
     ) where
 
 #include "HsVersions.h"
@@ -21,7 +22,8 @@ import PrelNames	( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName,
 			  itName
 			)
 import MkId		( unsafeCoerceId )
-import RnHsSyn		( RenamedHsBinds, RenamedHsDecl, RenamedStmt )
+import RnHsSyn		( RenamedHsBinds, RenamedHsDecl, RenamedStmt,
+			  RenamedHsExpr )
 import TcHsSyn		( TypecheckedMonoBinds, TypecheckedHsExpr,
 			  TypecheckedForeignDecl, TypecheckedRuleDecl,
 			  zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
@@ -29,6 +31,7 @@ import TcHsSyn		( TypecheckedMonoBinds, TypecheckedHsExpr,
 			)
 
 
+import TcExpr 		( tcMonoExpr )
 import TcMonad
 import TcType		( newTyVarTy, zonkTcType, tcInstType )
 import TcMatches	( tcStmtsAndThen )
@@ -46,13 +49,12 @@ import TcRules		( tcIfaceRules, tcSourceRules )
 import TcForeign	( tcForeignImports, tcForeignExports )
 import TcIfaceSig	( tcInterfaceSigs )
 import TcInstDcls	( tcInstDecls1, tcInstDecls2 )
-import TcSimplify	( tcSimplifyTop )
+import TcSimplify	( tcSimplifyTop, tcSimplifyInfer )
 import TcTyClsDecls	( tcTyAndClassDecls )
 
 import CoreUnfold	( unfoldingTemplate, hasUnfolding )
 import TysWiredIn	( mkListTy, unitTy )
-import Type		( funResultTy, splitForAllTys, 
-			  liftedTypeKind, mkTyConApp, tidyType )
+import Type
 import ErrUtils		( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass )
 import Id		( Id, idType, idName, isLocalId, idUnfolding )
 import Module           ( Module, moduleName )
@@ -81,19 +83,23 @@ import VarSet
 %************************************************************************
 
 \begin{code}
-typecheckStmt :: DynFlags
-	      -> PersistentCompilerState
-	      -> HomeSymbolTable
-	      -> TypeEnv		-- The interactive context's type envt 
-	      -> PrintUnqualified	-- For error printing
-	      -> Module			-- Is this really needed
-	      -> [Name]			-- Names bound by the Stmt (empty for expressions)
-	      -> (SyntaxMap,
-		  RenamedStmt, 		-- The stmt itself
-	          [RenamedHsDecl])	-- Plus extra decls it sucked in from interface files
-	      -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, [Id]))
-			-- The returned [Name] is the same as the input except for
-			-- ExprStmt, in which case the returned [Name] is [itName]
+typecheckStmt
+   :: DynFlags
+   -> PersistentCompilerState
+   -> HomeSymbolTable
+   -> TypeEnv		   -- The interactive context's type envt 
+   -> PrintUnqualified	   -- For error printing
+   -> Module		   -- Is this really needed
+   -> [Name]		   -- Names bound by the Stmt (empty for expressions)
+   -> (SyntaxMap,
+       RenamedStmt, 	   -- The stmt itself
+       [RenamedHsDecl])	   -- Plus extra decls it sucked in from interface files
+   -> IO (Maybe (PersistentCompilerState, 
+		 TypecheckedHsExpr, 
+		 [Id],
+		 Type))
+		-- The returned [Id] is the same as the input except for
+		-- ExprStmt, in which case the returned [Name] is [itName]
 
 typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, iface_decls)
   = typecheck dflags syn_map pcs hst unqual $
@@ -120,11 +126,11 @@ typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, i
     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Bound Ids" (vcat (map ppr zonked_ids)))	`thenNF_Tc_`
     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr))		`thenNF_Tc_`
 
-    returnTc (new_pcs, zonked_expr, zonked_ids)
+    returnTc (new_pcs, zonked_expr, zonked_ids, error "typecheckStmt: no type")
 
   where
     get_fixity :: Name -> Maybe Fixity
-    get_fixity n = pprPanic "typecheckExpr" (ppr n)
+    get_fixity n = pprPanic "typecheckStmt" (ppr n)
 \end{code}
 
 Here is the grand plan, implemented in tcUserStmt
@@ -211,6 +217,72 @@ tc_stmts names stmts
     combine stmt (ids, stmts) = (ids, stmt:stmts)
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Typechecking an expression}
+%*									*
+%************************************************************************
+
+\begin{code}
+typecheckExpr :: DynFlags
+	      -> PersistentCompilerState
+	      -> HomeSymbolTable
+	      -> TypeEnv	   -- The interactive context's type envt 
+	      -> PrintUnqualified	-- For error printing
+	      -> Module
+	      -> (SyntaxMap,
+		  RenamedHsExpr, 	-- The expression itself
+	          [RenamedHsDecl])	-- Plus extra decls it sucked in from interface files
+	      -> IO (Maybe (PersistentCompilerState, 
+			    TypecheckedHsExpr, 
+			    [Id],	-- always empty (matches typecheckStmt)
+			    Type))
+
+typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls)
+  = typecheck dflags syn_map pcs hst unqual $
+
+ 	 -- use the default default settings, i.e. [Integer, Double]
+    tcSetDefaultTys defaultDefaultTys $
+
+	-- Typecheck the extra declarations
+    fixTc (\ ~(unf_env, _, _, _, _) ->
+	tcImports unf_env pcs hst get_fixity this_mod decls
+    )			`thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
+    ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
+
+	-- Now typecheck the expression
+    tcSetEnv env			$
+    tcExtendGlobalTypeEnv ic_type_env	$
+
+    newTyVarTy openTypeKind		`thenTc` \ ty ->
+    tcMonoExpr expr ty 			`thenTc` \ (e', lie) ->
+    tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie 
+    		    	`thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
+    tcSimplifyTop lie_free		`thenTc` \ const_binds ->
+
+    let all_expr = mkHsLet const_binds	$
+    		   TyLam qtvs  		$
+    		   DictLam dict_ids	$
+    		   mkHsLet dict_binds	$	
+    		   e'
+
+    	all_expr_ty = mkForAllTys qtvs 	$
+    		      mkFunTys (map idType dict_ids) $
+    		      ty
+    in
+
+    zonkExpr all_expr				`thenNF_Tc` \ zonked_expr ->
+    zonkTcType all_expr_ty			`thenNF_Tc` \ zonked_ty ->
+    ioToTc (dumpIfSet_dyn dflags 
+		Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
+    returnTc (new_pcs, zonked_expr, [], zonked_ty) 
+
+  where
+    get_fixity :: Name -> Maybe Fixity
+    get_fixity n = pprPanic "typecheckExpr" (ppr n)
+
+    smpl_doc = ptext SLIT("main expression")
+\end{code}
 
 %************************************************************************
 %*									*