From: simonmar Date: Thu, 18 Jan 2001 16:30:01 +0000 (+0000) Subject: [project @ 2001-01-18 16:30:00 by simonmar] X-Git-Tag: Approximately_9120_patches~2853 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=183bd26608df2c8ae25ac2754bcda45e51fdd615;p=ghc-hetmet.git [project @ 2001-01-18 16:30:00 by simonmar] Problem 1 ========= The typechecker, when deciding whether to extend the Package environment with any new typechecked declarations in its hand, was inserting new declarations into the environment only if the declaration's module differed from the "current" module. This doesn't work if the "current" module is a package module, as it could be at the GHCi command line, for example. The solution is to filter the declarations only if the current module is not a package module. Problem 2 ========= The "current" module, as obtained from the compilation manager, was always bogusly a Home module (it used mkHomeModule). To properly fix this, the GHCi state has to carry around Modules instead of ModuleNames, and CompMan.cmLoadModule needs to return a list of Modules. --- diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 16ba8d5..43c79e4 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -18,7 +18,7 @@ import CmLink import CmTypes import HscTypes import Module ( Module, ModuleName, moduleName, isHomeModule, - mkHomeModule, mkModuleName, moduleNameUserString ) + mkModuleName, moduleNameUserString ) import CmStaticInfo ( GhciMode(..) ) import DriverPipeline import GetImports @@ -68,13 +68,13 @@ cmInit gmode #ifdef GHCI cmGetExpr :: CmState -> DynFlags - -> ModuleName + -> Module -> String -> Bool -> IO (CmState, Maybe (HValue, PrintUnqualified, Type)) -cmGetExpr cmstate dflags modname expr wrap_print +cmGetExpr cmstate dflags mod expr wrap_print = do (new_pcs, maybe_stuff) <- - hscExpr dflags hst hit pcs (mkHomeModule modname) expr wrap_print + hscExpr dflags hst hit pcs mod expr wrap_print case maybe_stuff of Nothing -> return (cmstate{ pcs=new_pcs }, Nothing) Just (bcos, print_unqual, ty) -> do @@ -170,7 +170,7 @@ cmLoadModule :: CmState -> FilePath -> IO (CmState, -- new state Bool, -- was successful - [ModuleName]) -- list of modules loaded + [Module]) -- list of modules loaded cmLoadModule cmstate1 rootname = do -- version 1's are the original, before downsweep @@ -308,7 +308,7 @@ cmLoadModule cmstate1 rootname let cmstate3 = CmState { pcms=pcms3, pcs=pcs3, pls=pls3 } return (cmstate3, True, - map name_of_summary modsDone) + map ms_mod modsDone) else -- Tricky. We need to back out the effects of compiling any @@ -344,7 +344,7 @@ cmLoadModule cmstate1 rootname let cmstate4 = CmState { pcms=pcms4, pcs=pcs3, pls=pls4 } return (cmstate4, False, - mods_to_keep_names) + map ms_mod mods_to_keep) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index cf301f4..3b5c701 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.28 2001/01/18 12:54:16 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.29 2001/01/18 16:30:00 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -16,6 +16,7 @@ import CmStaticInfo import DriverFlags import DriverState import Linker +import Finder import Module import Outputable import Util @@ -110,9 +111,13 @@ interactiveUI cmstate mod = do #ifndef NO_READLINE Readline.initialize #endif + + prel <- moduleNameToModule defaultCurrentModuleName + writeIORef defaultCurrentModule prel + let this_mod = case mods of - [] -> defaultCurrentModule - m:ms -> m + [] -> prel + m:ms -> m (unGHCi uiLoop) GHCiState{ modules = mods, current_module = this_mod, @@ -122,11 +127,12 @@ interactiveUI cmstate mod = do last_expr = Nothing} return () + uiLoop :: GHCi () uiLoop = do st <- getGHCiState #ifndef NO_READLINE - l <- io (readline (moduleNameUserString (current_module st) ++ "> ")) + l <- io (readline (moduleUserString (current_module st) ++ "> ")) #else l_ok <- io (hGetLine stdin) let l = Just l_ok @@ -230,9 +236,18 @@ setContext "" = throwDyn (OtherError "syntax: `:m '") setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m)) = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'")) -setContext m - = do st <- getGHCiState - setGHCiState st{current_module = mkModuleName m} +setContext mn + = do m <- io (moduleNameToModule (mkModuleName mn)) + st <- getGHCiState + setGHCiState st{current_module = m} + +moduleNameToModule :: ModuleName -> IO Module +moduleNameToModule mn + = do maybe_stuff <- findModule mn + case maybe_stuff of + Nothing -> throwDyn (OtherError ("can't find module `" + ++ moduleNameUserString mn ++ "'")) + Just (m,_) -> return m changeDirectory :: String -> GHCi () changeDirectory d = io (setCurrentDirectory d) @@ -245,11 +260,13 @@ loadModule' path = do cmstate1 <- io (cmUnload (cmstate state)) (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path) + def_mod <- io (readIORef defaultCurrentModule) + let new_state = state{ cmstate = cmstate2, modules = mods, current_module = case mods of - [] -> defaultCurrentModule + [] -> def_mod xs -> head xs, target = Just path } @@ -258,7 +275,7 @@ loadModule' path = do let mod_commas | null mods = text "none." | otherwise = hsep ( - punctuate comma (map (text.moduleNameUserString) mods)) <> text "." + punctuate comma (map (text.moduleUserString) mods)) <> text "." case ok of False -> io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) @@ -272,11 +289,12 @@ reloadModule "" = do Nothing -> io (putStr "no current target\n") Just path -> do (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path) + def_mod <- io (readIORef defaultCurrentModule) setGHCiState state{cmstate=new_cmstate, modules = mods, current_module = case mods of - [] -> defaultCurrentModule + [] -> def_mod xs -> head xs } @@ -432,8 +450,8 @@ rememberExpr str data GHCiState = GHCiState { - modules :: [ModuleName], - current_module :: ModuleName, + modules :: [Module], + current_module :: Module, target :: Maybe FilePath, cmstate :: CmState, options :: [GHCiOption], @@ -442,7 +460,8 @@ data GHCiState = GHCiState data GHCiOption = ShowTiming | ShowType deriving Eq -defaultCurrentModule = mkModuleName "Prelude" +defaultCurrentModuleName = mkModuleName "Prelude" +GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module) newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) } diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 0a0280d..5c0262d 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -42,10 +42,9 @@ import TcTyClsDecls ( tcTyAndClassDecls ) import CoreUnfold ( unfoldingTemplate, hasUnfolding ) import Type ( funResultTy, splitForAllTys, openTypeKind ) -import Bag ( isEmptyBag ) import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass ) import Id ( idType, idName, isLocalId, idUnfolding ) -import Module ( Module ) +import Module ( Module, isHomeModule ) import Name ( Name, toRdrName, isGlobalName ) import Name ( nameEnvElts, lookupNameEnv ) import TyCon ( tyConGenInfo ) @@ -123,6 +122,8 @@ typecheckExpr dflags pcs hst unqual this_mod (expr, decls) let all_expr = mkHsLet binds expr' in zonkExpr all_expr `thenNF_Tc` \ zonked_expr -> zonkTcType 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 @@ -307,7 +308,16 @@ tcImports pcs hst get_fixity this_mod decls tcGetEnv `thenTc` \ unf_env -> let - imported_things = filter (not . isLocalThing this_mod) (nameEnvElts (getTcGEnv unf_env)) + all_things = nameEnvElts (getTcGEnv unf_env) + + -- sometimes we're compiling in the context of a package module + -- (on the GHCi command line, for example). In this case, we + -- want to treat everything we pulled in as an imported thing. + imported_things + | isHomeModule this_mod + = filter (not . isLocalThing this_mod) all_things + | otherwise + = all_things new_pte :: PackageTypeEnv new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things