From 6e0ec24764afcf7679661a74a67fdd23f2f8a624 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 21 Nov 2000 15:00:59 +0000 Subject: [PATCH] [project @ 2000-11-21 15:00:57 by simonmar] * :t works !!! (but it's a bit excessive about qualifying everything at the moment). * lots of other things work. --- ghc/compiler/compMan/CompManager.lhs | 18 ++++++- ghc/compiler/ghci/InteractiveUI.hs | 13 +++-- ghc/compiler/main/HscMain.lhs | 89 +++++++++++++++++++++++++--------- 3 files changed, 91 insertions(+), 29 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index bb08b7b..16b139d 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -6,7 +6,7 @@ \begin{code} module CompManager ( cmInit, cmLoadModule, #ifdef GHCI - cmGetExpr, cmRunExpr, + cmGetExpr, cmTypeExpr, cmRunExpr, #endif CmState, emptyCmState -- abstract ) @@ -25,6 +25,7 @@ import DriverPipeline import GetImports import HscTypes ( HomeSymbolTable, HomeIfaceTable, PersistentCompilerState, ModDetails(..) ) +import Type ( Type ) import Name ( lookupNameEnv ) import Module import PrelNames ( mainName ) @@ -45,7 +46,7 @@ import Panic ( panic ) #ifdef GHCI import CmdLineOpts ( DynFlags(..) ) import Interpreter ( HValue ) -import HscMain ( hscExpr ) +import HscMain ( hscExpr, hscTypeExpr ) import RdrName import PrelGHC ( unsafeCoerce# ) #endif @@ -88,6 +89,19 @@ cmGetExpr cmstate dflags modname expr CmState{ pcs=pcs, pcms=pcms, pls=pls } = cmstate PersistentCMState{ hst=hst, hit=hit } = pcms +cmTypeExpr :: CmState + -> DynFlags + -> ModuleName + -> String + -> IO (CmState, Maybe Type) +cmTypeExpr cmstate dflags modname expr + = do (new_pcs, expr_type) <- + hscTypeExpr dflags hst hit pcs (mkHomeModule modname) expr + return (cmstate{ pcs=new_pcs }, expr_type) + where + CmState{ pcs=pcs, pcms=pcms, pls=pls } = cmstate + PersistentCMState{ hst=hst, hit=hit } = pcms + -- The HValue should represent a value of type IO () (Perhaps IO a?) cmRunExpr :: HValue -> IO () cmRunExpr hval diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 39bbe01..97071d7 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.8 2000/11/21 14:32:44 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.9 2000/11/21 15:00:58 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -122,7 +122,7 @@ runCommand c = doCommand (':' : command) = specialCommand command doCommand expr = do st <- getGHCiState - dflags <- io (readIORef v_DynFlags) + dflags <- io (getDynFlags) (new_cmstate, maybe_hvalue) <- io (cmGetExpr (cmstate st) dflags (current_module st) expr) setGHCiState st{cmstate = new_cmstate} @@ -216,7 +216,14 @@ setOptions str = ) typeOfExpr :: String -> GHCi () -typeOfExpr = panic "typeOfExpr" +typeOfExpr str + = do st <- getGHCiState + dflags <- io (getDynFlags) + (st, maybe_ty) <- io (cmTypeExpr (cmstate st) dflags + (current_module st) str) + case maybe_ty of + Nothing -> return () + Just ty -> io (putStrLn (showSDoc (ppr ty))) quit :: String -> GHCi () quit _ = return () diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 34917d3..22b1298 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -4,7 +4,7 @@ \section[GHC_Main]{Main driver for Glasgow Haskell compiler} \begin{code} -module HscMain ( HscResult(..), hscMain, hscExpr, +module HscMain ( HscResult(..), hscMain, hscExpr, hscTypeExpr, initPersistentCompilerState ) where #include "HsVersions.h" @@ -28,6 +28,8 @@ import PrelNames ( knownKeyNames ) import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails, writeIface, pprIface ) import TcModule +import Type +import TcHsSyn import InstEnv ( emptyInstEnv ) import Desugar import SimplCore @@ -401,42 +403,33 @@ hscExpr dflags hst hit pcs this_module expr #else hscExpr dflags hst hit pcs0 this_module expr - = do { -- Parse it - maybe_parsed <- hscParseExpr dflags expr; - case maybe_parsed of - Nothing -> return (pcs0, Nothing) - Just parsed_expr -> do { + = do { + -- parse, rename & typecheck the expression + (pcs1, maybe_tc_result) + <- hscExprFrontEnd dflags hst hit pcs0 this_module expr; - -- Rename it - (pcs1, maybe_renamed_expr) <- - renameExpr dflags hit hst pcs0 this_module parsed_expr; - case maybe_renamed_expr of - Nothing -> return (pcs1, Nothing) - Just (print_unqual, rn_expr) -> do { - - -- Typecheck it - maybe_tc_return - <- typecheckExpr dflags pcs1 hst print_unqual this_module rn_expr; - case maybe_tc_return of - Nothing -> return (pcs1, Nothing) - Just (pcs2, tc_expr, ty) -> do { + case maybe_tc_result of { + Nothing -> return (pcs1, Nothing); + Just (print_unqual, tc_expr, ty) -> do { + -- if it isn't an IO-typed expression, + -- wrap "print" around it & recompile... let { is_IO_type = case splitTyConApp_maybe ty of { Just (tycon, _) -> getUnique tycon == ioTyConKey; Nothing -> False } }; if (not is_IO_type) - then hscExpr dflags hst hit pcs2 this_module + then hscExpr dflags hst hit pcs1 this_module ("print (" ++ expr ++ ")") else do -- Desugar it - ds_expr <- deSugarExpr dflags pcs2 hst this_module + ds_expr <- deSugarExpr dflags pcs1 hst this_module print_unqual tc_expr; -- Simplify it - simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr; + simpl_expr <- simplifyExpr dflags pcs1 hst ds_expr; -- Convert to STG stg_expr <- coreToStgExpr dflags simpl_expr; @@ -446,8 +439,56 @@ hscExpr dflags hst hit pcs0 this_module expr -- Convert to InterpSyn unlinked_iexpr <- stgExprToInterpSyn dflags stg_expr; - return (pcs2, Just unlinked_iexpr); - }}}} + return (pcs1, Just unlinked_iexpr); + }}} + +hscExprFrontEnd + :: DynFlags + -> HomeSymbolTable + -> HomeIfaceTable + -> PersistentCompilerState -- IN: persistent compiler state + -> Module -- Context for compiling + -> String -- The expression + -> IO ( PersistentCompilerState, + Maybe (PrintUnqualified,TypecheckedHsExpr,Type) + ) +hscExprFrontEnd dflags hst hit pcs0 this_module expr + = do { -- Parse it + maybe_parsed <- hscParseExpr dflags expr; + case maybe_parsed of + Nothing -> return (pcs0, Nothing) + Just parsed_expr -> do { + + -- Rename it + (pcs1, maybe_renamed_expr) <- + renameExpr dflags hit hst pcs0 this_module parsed_expr; + case maybe_renamed_expr of + Nothing -> return (pcs1, Nothing) + Just (print_unqual, rn_expr) -> do { + + -- Typecheck it + maybe_tc_return + <- typecheckExpr dflags pcs1 hst print_unqual this_module rn_expr; + case maybe_tc_return of + Nothing -> return (pcs1, Nothing) + Just (pcs2, tc_expr, ty) -> + return (pcs2, Just (print_unqual, tc_expr, ty)) + }}} + +hscTypeExpr + :: DynFlags + -> HomeSymbolTable + -> HomeIfaceTable + -> PersistentCompilerState -- IN: persistent compiler state + -> Module -- Context for compiling + -> String -- The expression + -> IO (PersistentCompilerState, Maybe Type) +hscTypeExpr dflags hst hit pcs0 this_module expr + = do (pcs1, maybe_tc_result) + <- hscExprFrontEnd dflags hst hit pcs0 this_module expr + case maybe_tc_result of + Nothing -> return (pcs1, Nothing) + Just (_,_,ty) -> return (pcs1, Just ty) hscParseExpr :: DynFlags -> String -> IO (Maybe RdrNameHsExpr) hscParseExpr dflags str -- 1.7.10.4