diff options
| -rw-r--r-- | compiler/main/HscTypes.lhs | 2 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 6 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 154 |
3 files changed, 85 insertions, 77 deletions
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 9840b407ce..e0eea7dc4b 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1041,7 +1041,7 @@ data InteractiveImport -- ^ Bring the exports of a particular module -- (filtered by an import decl) into scope - | IIModule Module + | IIModule ModuleName -- ^ Bring into scope the entire top-level envt of -- of this module, including the things imported -- into it. diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index cdc2ca501a..b62ec40ec0 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -822,7 +822,7 @@ findGlobalRdrEnv hsc_env imports idecls :: [LImportDecl RdrName] idecls = [noLoc d | IIDecl d <- imports] - imods :: [Module] + imods :: [ModuleName] imods = [m | IIModule m <- imports] availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv @@ -836,9 +836,9 @@ availsToGlobalRdrEnv mod_name avails is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } -mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv +mkTopLevEnv :: HomePackageTable -> ModuleName -> IO GlobalRdrEnv mkTopLevEnv hpt modl - = case lookupUFM hpt (moduleName modl) of + = case lookupUFM hpt modl of Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ showSDoc (ppr modl))) Just details -> diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index fde1519d59..74547621bc 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -575,8 +575,7 @@ mkPrompt = do rev_imports = reverse imports -- rightmost are the most recent modules_bit = - hsep [ char '*' <> ppr (GHC.moduleName m) - | IIModule m <- rev_imports ] <+> + hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+> hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ]) -- use the 'as' name if there is one @@ -1290,8 +1289,8 @@ setContextAfterLoad keep_ctxt ms = do -- We import the module with a * iff -- - it is interpreted, and -- - -XSafe is off (it doesn't allow *-imports) - let new_ctx | star_ok = [IIModule m] - | otherwise = [IIDecl $ simpleImportDecl (GHC.moduleName m)] + let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)] + | otherwise = [mkIIDecl (GHC.moduleName m)] setContextKeepingPackageModules keep_ctxt new_ctx @@ -1507,7 +1506,7 @@ guessCurrentModule cmd when (null imports) $ ghcError $ CmdLineError (':' : cmd ++ ": no current module") case (head imports) of - IIModule m -> return m + IIModule m -> GHC.findModule m Nothing IIDecl d -> GHC.findModule (unLoc (ideclName d)) (ideclPkgQual d) -- without bang, show items in context of their parents and omit children @@ -1614,8 +1613,8 @@ moduleCmd str sensible ('*':m) = looksLikeModuleName m sensible m = looksLikeModuleName m - starred ('*':m) = Left m - starred m = Right m + starred ('*':m) = Left (GHC.mkModuleName m) + starred m = Right (GHC.mkModuleName m) -- ----------------------------------------------------------------------------- @@ -1625,71 +1624,64 @@ moduleCmd str -- (c) :module <stuff>: setContext -- (d) import <module>...: addImportToContext -addModulesToContext :: [String] -> [String] -> GHCi () -addModulesToContext as bs = do - mapM_ (add True) as - mapM_ (add False) bs +addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi () +addModulesToContext starred unstarred = do + mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred) setGHCContextFromGHCiState - where - add :: Bool -> String -> GHCi () - add star str = do - i <- checkAdd star str - modifyGHCiState $ \st -> - st { remembered_ctx = addNotSubsumed i (remembered_ctx st) } -remModulesFromContext :: [String] -> [String] -> GHCi () -remModulesFromContext as bs = do - mapM_ rm (as ++ bs) +remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi () +remModulesFromContext starred unstarred = do + mapM_ rm (starred ++ unstarred) setGHCContextFromGHCiState where - rm :: String -> GHCi () + rm :: ModuleName -> GHCi () rm str = do - m <- moduleName <$> lookupModule str + m <- moduleName <$> lookupModuleName str let filt = filter ((/=) m . iiModuleName) modifyGHCiState $ \st -> st { remembered_ctx = filt (remembered_ctx st) , transient_ctx = filt (transient_ctx st) } -setContext :: [String] -> [String] -> GHCi () -setContext starred not_starred = do - is1 <- mapM (checkAdd True) starred - is2 <- mapM (checkAdd False) not_starred - let iss = foldr addNotSubsumed [] (is1++is2) - modifyGHCiState $ \st -> st { remembered_ctx = iss, transient_ctx = [] } +setContext :: [ModuleName] -> [ModuleName] -> GHCi () +setContext starred unstarred = do + modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] } -- delete the transient context - setGHCContextFromGHCiState + addModulesToContext starred unstarred addImportToContext :: String -> GHCi () addImportToContext str = do idecl <- GHC.parseImportDecl str - _ <- checkAdd False (moduleNameString (unLoc (ideclName idecl))) -- #5836 - modifyGHCiState $ \st -> - st { remembered_ctx = addNotSubsumed (IIDecl idecl) (remembered_ctx st) } + addII (IIDecl idecl) -- #5836 setGHCContextFromGHCiState +-- Util used by addImportToContext and addModulesToContext +addII :: InteractiveImport -> GHCi () +addII iidecl = do + checkAdd iidecl + modifyGHCiState $ \st -> + st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st) } -- ----------------------------------------------------------------------------- -- Validate a module that we want to add to the context -checkAdd :: Bool -> String -> GHCi InteractiveImport -checkAdd star mstr = do +checkAdd :: InteractiveImport -> GHCi () +checkAdd ii = do dflags <- getDynFlags let safe = safeLanguageOn dflags - case star of - True | safe -> - ghcError $ CmdLineError "can't use * imports with Safe Haskell" - | otherwise -> do - m <- wantInterpretedModule mstr - return $ IIModule m - - False -> do - m <- lookupModule mstr + case ii of + IIModule modname + | safe -> ghcError $ CmdLineError "can't use * imports with Safe Haskell" + | otherwise -> wantInterpretedModuleName modname >> return () + + IIDecl d -> do + let modname = unLoc (ideclName d) + m <- lookupModuleName modname when safe $ do t <- GHC.isModuleTrusted m when (not t) $ - ghcError $ CmdLineError $ "can't import " ++ mstr - ++ " as it isn't trusted." - return $ IIDecl (simpleImportDecl $ moduleName m) + ghcError $ CmdLineError $ + "can't import " ++ moduleNameString modname + ++ " as it isn't trusted." -- ----------------------------------------------------------------------------- @@ -1709,16 +1701,14 @@ checkAdd star mstr = do -- setGHCContextFromGHCiState :: GHCi () setGHCContextFromGHCiState = do - let ok (IIModule m) = checkAdd True (moduleNameString (moduleName m)) - ok (IIDecl d) = checkAdd False (moduleNameString (unLoc (ideclName d))) + st <- getGHCiState -- re-use checkAdd to check whether the module is valid. If the -- module does not exist, we do *not* want to print an error -- here, we just want to silently keep the module in the context -- until such time as the module reappears again. So we ignore -- the actual exception thrown by checkAdd, using tryBool to -- turn it into a Bool. - st <- getGHCiState - iidecls <- filterM (tryBool . ok) (transient_ctx st ++ remembered_ctx st) + iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st) GHC.setContext (maybeAddPrelude iidecls) where maybeAddPrelude :: [InteractiveImport] -> [InteractiveImport] @@ -1731,27 +1721,17 @@ setGHCContextFromGHCiState = do -- ----------------------------------------------------------------------------- -- Utils on InteractiveImport --- | Returns True if the left import subsumes the right one. Doesn't --- need to be 100% accurate, conservatively returning False is fine. --- --- Note that an IIModule does not necessarily subsume an IIDecl, --- because e.g. a module might export a name that is only available --- qualified within the module itself. --- -iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool -iiSubsumes (IIModule m1) (IIModule m2) = m1==m2 -iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude - = unLoc (ideclName d1) == unLoc (ideclName d2) - && ideclAs d1 == ideclAs d2 - && (not (ideclQualified d1) || ideclQualified d2) - && (isNothing (ideclHiding d1) || ideclHiding d1 == ideclHiding d2) -iiSubsumes _ _ = False +mkIIModule :: ModuleName -> InteractiveImport +mkIIModule = IIModule + +mkIIDecl :: ModuleName -> InteractiveImport +mkIIDecl = IIDecl . simpleImportDecl -iiModules :: [InteractiveImport] -> [Module] +iiModules :: [InteractiveImport] -> [ModuleName] iiModules is = [m | IIModule m <- is] iiModuleName :: InteractiveImport -> ModuleName -iiModuleName (IIModule m) = moduleName m +iiModuleName (IIModule m) = m iiModuleName (IIDecl d) = unLoc (ideclName d) preludeModuleName :: ModuleName @@ -1770,6 +1750,23 @@ addNotSubsumed i is | any (`iiSubsumes` i) is = is | otherwise = i : filter (not . (i `iiSubsumes`)) is +-- | Returns True if the left import subsumes the right one. Doesn't +-- need to be 100% accurate, conservatively returning False is fine. +-- +-- Note that an IIModule does not necessarily subsume an IIDecl, +-- because e.g. a module might export a name that is only available +-- qualified within the module itself. +-- +iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool +iiSubsumes (IIModule m1) (IIModule m2) = m1==m2 +iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude + = unLoc (ideclName d1) == unLoc (ideclName d2) + && ideclAs d1 == ideclAs d2 + && (not (ideclQualified d1) || ideclQualified d2) + && (isNothing (ideclHiding d1) || ideclHiding d1 == ideclHiding d2) +iiSubsumes _ _ = False + + ---------------------------------------------------------------------------- -- :set @@ -2010,7 +2007,7 @@ showImports = do trans_ctx = transient_ctx st show_one (IIModule star_m) - = ":module +*" ++ moduleNameString (moduleName star_m) + = ":module +*" ++ moduleNameString star_m show_one (IIDecl imp) = showSDoc (ppr imp) prel_imp @@ -2377,7 +2374,9 @@ breakSwitch (arg1:rest) | all isDigit arg1 = do imports <- GHC.getContext case iiModules imports of - (md : _) -> breakByModuleLine md (read arg1) rest + (mn : _) -> do + md <- lookupModuleName mn + breakByModuleLine md (read arg1) rest [] -> do liftIO $ putStrLn "Cannot find default module for breakpoint." liftIO $ putStrLn "Perhaps no modules are loaded for debugging?" @@ -2539,7 +2538,9 @@ list2 [arg] | all isDigit arg = do imports <- GHC.getContext case iiModules imports of [] -> liftIO $ putStrLn "No module to list" - (md : _) -> listModuleLine md (read arg) + (mn : _) -> do + md <- lift $ lookupModuleName mn + listModuleLine md (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do md <- wantInterpretedModule arg1 listModuleLine md (read arg2) @@ -2777,7 +2778,10 @@ tryBool m = do -- Utils lookupModule :: GHC.GhcMonad m => String -> m Module -lookupModule mName = GHC.lookupModule (GHC.mkModuleName mName) Nothing +lookupModule mName = lookupModuleName (GHC.mkModuleName mName) + +lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module +lookupModuleName mName = GHC.lookupModule mName Nothing isHomeModule :: Module -> Bool isHomeModule m = GHC.modulePackageId m == mainPackageId @@ -2800,8 +2804,12 @@ expandPathIO p = return other wantInterpretedModule :: GHC.GhcMonad m => String -> m Module -wantInterpretedModule str = do - modl <- lookupModule str +wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str) + +wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module +wantInterpretedModuleName modname = do + modl <- lookupModuleName modname + let str = moduleNameString modname dflags <- getDynFlags when (GHC.modulePackageId modl /= thisPackage dflags) $ ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) |