X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2FInteractiveUI.hs;h=d4757ccf2f250c660f2807c4fac4357d3c9b1364;hp=a62e10d05998b15587878b46bb3605624c407983;hb=a6f2d598e1e7760d334d1b5ea0b7745e66835e11;hpb=de1a1f9f882cf1a5c81c4a152edc001aafd3f8a3 diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index a62e10d..d4757cc 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -140,7 +140,7 @@ builtin_commands = [ ("kind", keepGoing' kindOfType, completeIdentifier), ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), ("list", keepGoing' listCmd, noCompletion), - ("module", keepGoing setContext, completeModule), + ("module", keepGoing setContext, completeSetModule), ("main", keepGoing runMain, completeFilename), ("print", keepGoing printCmd, completeExpression), ("quit", quit, noCompletion), @@ -497,7 +497,7 @@ checkPerms name = putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!" return False else do - let mode = fileMode st + let mode = System.Posix.fileMode st if (groupWriteMode == (mode `intersectFileModes` groupWriteMode)) || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) then do @@ -643,8 +643,10 @@ enqueueCommands cmds = do runStmt :: String -> SingleStep -> GHCi Bool runStmt stmt step - | null (filter (not.isSpace) stmt) = return False - | x@('i':'m':'p':'o':'r':'t':' ':_) <- stmt = keepGoing' (importContext True) x + | null (filter (not.isSpace) stmt) + = return False + | "import " `isPrefixOf` stmt + = do newContextCmd (Import stmt); return False | otherwise = do #if __GLASGOW_HASKELL__ >= 611 @@ -655,7 +657,7 @@ runStmt stmt step -- a file, otherwise the read buffer can't be flushed). _ <- liftIO $ IO.try $ hFlushAll stdin #endif - result <- GhciMonad.runStmt stmt step + result <- withFlattenedDynflags $ GhciMonad.runStmt stmt step afterRunStmt (const True) result --afterRunStmt :: GHC.RunResult -> GHCi Bool @@ -813,7 +815,8 @@ help _ = io (putStr helpText) info :: String -> InputT GHCi () info "" = ghcError (CmdLineError "syntax: ':i '") -info s = handleSourceError GHC.printExceptionAndWarnings $ do +info s = handleSourceError GHC.printExceptionAndWarnings $ + withFlattenedDynflags $ do { let names = words s ; dflags <- getDynFlags ; let pefas = dopt Opt_PrintExplicitForalls dflags @@ -854,7 +857,8 @@ runMain :: String -> GHCi () runMain s = case toArgs s of Left err -> io (hPutStrLn stderr err) Right args -> - do dflags <- getDynFlags + withFlattenedDynflags $ do + dflags <- getDynFlags case mainFunIs dflags of Nothing -> doWithArgs args "main" Just f -> doWithArgs args f @@ -972,7 +976,8 @@ defineMacro overwrite s = do let new_expr = '(' : definition ++ ") :: String -> IO String" -- compile the expression - handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ + withFlattenedDynflags $ do hv <- GHC.compileExpr new_expr io (writeIORef macros_ref -- (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)])) @@ -999,7 +1004,8 @@ undefineMacro str = mapM_ undef (words str) cmdCmd :: String -> GHCi () cmdCmd str = do let expr = '(' : str ++ ") :: IO String" - handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ + withFlattenedDynflags $ do hv <- GHC.compileExpr expr cmds <- io $ (unsafeCoerce# hv :: IO String) enqueueCommands (lines cmds) @@ -1082,7 +1088,7 @@ afterLoad ok retain_context prev_context = do loaded_mod_names = map GHC.moduleName loaded_mods modulesLoadedMsg ok loaded_mod_names - lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries + withFlattenedDynflags $ lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi () @@ -1134,10 +1140,7 @@ setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do if keep_ctxt then do st <- getGHCiState - let mem = remembered_ctx st - playCmd (Left x) = playCtxtCmd False x - playCmd (Right x) = importContext False x - mapM_ playCmd mem + mapM_ (playCtxtCmd False) (remembered_ctx st) else do st <- getGHCiState setGHCiState st{ remembered_ctx = [] } @@ -1165,7 +1168,9 @@ modulesLoadedMsg ok mods = do typeOfExpr :: String -> InputT GHCi () typeOfExpr str - = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + = handleSourceError (\e -> GHC.printExceptionAndWarnings e) + $ withFlattenedDynflags + $ do ty <- GHC.exprType str dflags <- getDynFlags let pefas = dopt Opt_PrintExplicitForalls dflags @@ -1173,7 +1178,9 @@ typeOfExpr str kindOfType :: String -> InputT GHCi () kindOfType str - = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + = handleSourceError (\e -> GHC.printExceptionAndWarnings e) + $ withFlattenedDynflags + $ do ty <- GHC.typeKind str printForUser $ text str <+> dcolon <+> ppr ty @@ -1183,6 +1190,13 @@ quit _ = return True shellEscape :: String -> GHCi Bool shellEscape str = io (system str >> return False) +withFlattenedDynflags :: GHC.GhcMonad m => m a -> m a +withFlattenedDynflags m + = do dflags <- GHC.getSessionDynFlags + gbracket (GHC.setSessionDynFlags (ensureFlattenedExtensionFlags dflags)) + (\_ -> GHC.setSessionDynFlags dflags) + (\_ -> m) + ----------------------------------------------------------------------------- -- Browsing a module's contents @@ -1211,7 +1225,7 @@ browseCmd bang m = -- indicate import modules, to aid qualifying unqualified names -- with sorted, sort items alphabetically browseModule :: Bool -> Module -> Bool -> InputT GHCi () -browseModule bang modl exports_only = do +browseModule bang modl exports_only = withFlattenedDynflags $ do -- :browse! reports qualifiers wrt current context current_unqual <- GHC.getPrintUnqual -- Temporarily set the context to the module we're interested in, @@ -1294,39 +1308,25 @@ browseModule bang modl exports_only = do ----------------------------------------------------------------------------- -- Setting the module context -importContext :: Bool -> String -> GHCi () -importContext fail str - = do - (as,bs) <- GHC.getContext - x <- do_checks fail - case Monad.join x of - Nothing -> return () - (Just a) -> do - m <- loadModuleName a - GHC.setContext as (bs++[(m,Just a)]) - st <- getGHCiState - let cmds = remembered_ctx st - setGHCiState st{ remembered_ctx = cmds++[Right str] } - where - do_checks True = liftM Just (GhciMonad.parseImportDecl str) - do_checks False = trymaybe (GhciMonad.parseImportDecl str) +newContextCmd :: CtxtCmd -> GHCi () +newContextCmd cmd = do + playCtxtCmd True cmd + st <- getGHCiState + let cmds = remembered_ctx st + setGHCiState st{ remembered_ctx = cmds ++ [cmd] } setContext :: String -> GHCi () setContext str - | all sensible strs = do - playCtxtCmd True (cmd, as, bs) - st <- getGHCiState - let cmds = remembered_ctx st - setGHCiState st{ remembered_ctx = cmds ++ [Left (cmd,as,bs)] } + | all sensible strs = newContextCmd cmd | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where - (cmd, strs, as, bs) = + (cmd, strs) = case str of '+':stuff -> rest AddModules stuff '-':stuff -> rest RemModules stuff stuff -> rest SetContext stuff - rest cmd stuff = (cmd, strs, as, bs) + rest cmd stuff = (cmd as bs, strs) where strs = words stuff (as,bs) = partitionWith starred strs @@ -1336,38 +1336,52 @@ setContext str starred ('*':m) = Left m starred m = Right m -playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi () -playCtxtCmd fail (cmd, as, bs) - = do - (as',bs') <- do_checks fail +playCtxtCmd:: Bool -> CtxtCmd -> GHCi () +playCtxtCmd fail cmd = do + withFlattenedDynflags $ do (prev_as,prev_bs) <- GHC.getContext - (new_as, new_bs) <- - case cmd of - SetContext -> do + case cmd of + SetContext as bs -> do + (as',bs') <- do_checks as bs prel_mod <- getPrelude - let bs'' = if null as && prel_mod `notElem` (map fst bs') then (prel_mod,Nothing):bs' - else bs' - return (as', bs'') - AddModules -> do + let bs'' = if null as && prel_mod `notElem` (map fst bs') + then (prel_mod,Nothing):bs' + else bs' + GHC.setContext as' bs'' + + AddModules as bs -> do + (as',bs') <- do_checks as bs -- it should replace the old stuff, not the other way around -- need deleteAllBy, not deleteFirstsBy for sameFst let remaining_as = prev_as \\ (as' ++ map fst bs') remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as') - return (remaining_as ++ as', remaining_bs ++ bs') - RemModules -> do + GHC.setContext (remaining_as ++ as') (remaining_bs ++ bs') + + RemModules as bs -> do + (as',bs') <- do_checks as bs let new_as = prev_as \\ (as' ++ map fst bs') new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs') - return (new_as, new_bs) - GHC.setContext new_as new_bs + GHC.setContext new_as new_bs + + Import str -> do + m_idecl <- maybe_fail $ GHC.parseImportDecl str + case m_idecl of + Nothing -> return () + Just idecl -> do + m_mdl <- maybe_fail $ loadModuleName idecl + case m_mdl of + Nothing -> return () + Just m -> GHC.setContext prev_as (prev_bs ++ [(m, Just idecl)]) + where - do_checks True = do - as' <- mapM wantInterpretedModule as - bs' <- mapM lookupModule bs - return (as', map contextualize bs') - do_checks False = do - as' <- mapM (trymaybe . wantInterpretedModule) as - bs' <- mapM (trymaybe . lookupModule) bs - return (catMaybes as', map contextualize (catMaybes bs')) + maybe_fail | fail = liftM Just + | otherwise = trymaybe + + do_checks as bs = do + as' <- mapM (maybe_fail . wantInterpretedModule) as + bs' <- mapM (maybe_fail . lookupModule) bs + return (catMaybes as', map contextualize (catMaybes bs')) + contextualize x = (x,Nothing) deleteAllBy f a b = filter (\x->(not (any (f x) b))) a @@ -1405,15 +1419,13 @@ setCmd "" )) io $ putStrLn (showSDoc ( vcat (text "other dynamic, non-language, flag settings:" - :map (flagSetting dflags) nonLanguageDynFlags) + :map (flagSetting dflags) others) )) where flagSetting dflags (str, f, _) | dopt f dflags = text " " <> text "-f" <> text str | otherwise = text " " <> text "-fno-" <> text str (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags) DynFlags.fFlags - nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions) - others flags = [Opt_PrintExplicitForalls ,Opt_PrintBindResult ,Opt_BreakOnException @@ -1568,7 +1580,7 @@ optToStr RevertCAFs = "r" -- code for `:show' showCmd :: String -> GHCi () -showCmd str = do +showCmd str = withFlattenedDynflags $ do st <- getGHCiState case words str of ["args"] -> io $ putStrLn (show (args st)) @@ -1648,12 +1660,13 @@ showLanguages = do dflags <- getDynFlags io $ putStrLn $ showSDoc $ vcat $ text "active language flags:" : - [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags] + [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags] -- ----------------------------------------------------------------------------- -- Completion completeCmd, completeMacro, completeIdentifier, completeModule, + completeSetModule, completeHomeModule, completeSetOptions, completeShowOptions, completeHomeModuleOrFile, completeExpression :: CompletionFunc GHCi @@ -1699,6 +1712,18 @@ completeModule = wrapIdentCompleter $ \w -> do return $ filter (w `isPrefixOf`) $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods +completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do + modules <- case m of + Just '-' -> do + (toplevs, exports) <- GHC.getContext + return $ map GHC.moduleName (nub (map fst exports) ++ toplevs) + _ -> do + dflags <- GHC.getSessionDynFlags + let pkg_mods = allExposedModules dflags + loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules + return $ loaded_mods ++ pkg_mods + return $ filter (w `isPrefixOf`) $ map (showSDoc.ppr) modules + completeHomeModule = wrapIdentCompleter listHomeModules listHomeModules :: String -> GHCi [String] @@ -1736,6 +1761,12 @@ wrapCompleter breakChars fun = completeWord Nothing breakChars wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi wrapIdentCompleter = wrapCompleter word_break_chars +wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi +wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars + $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest) + where + getModifier = find (`elem` modifChars) + allExposedModules :: DynFlags -> [ModuleName] allExposedModules dflags = concat (map exposedModules (filter exposed (eltsUFM pkg_db))) @@ -1854,7 +1885,7 @@ forceCmd = pprintCommand False True pprintCommand :: Bool -> Bool -> String -> GHCi () pprintCommand bind force str = do - pprintClosureCommand bind force str + withFlattenedDynflags $ pprintClosureCommand bind force str stepCmd :: String -> GHCi () stepCmd [] = doContinue (const True) GHC.SingleStep @@ -1985,7 +2016,7 @@ forwardCmd = noArgs $ do -- handle the "break" command breakCmd :: String -> GHCi () breakCmd argLine = do - breakSwitch $ words argLine + withFlattenedDynflags $ breakSwitch $ words argLine breakSwitch :: [String] -> GHCi () breakSwitch [] = do @@ -2118,7 +2149,10 @@ end_bold :: String end_bold = "\ESC[0m" listCmd :: String -> InputT GHCi () -listCmd "" = do +listCmd c = withFlattenedDynflags $ listCmd' c + +listCmd' :: String -> InputT GHCi () +listCmd' "" = do mb_span <- lift getCurrentBreakSpan case mb_span of Nothing -> @@ -2137,7 +2171,7 @@ listCmd "" = do printForUser (text "Unable to list source for" <+> ppr span $$ text "Try" <+> doWhat) -listCmd str = list2 (words str) +listCmd' str = list2 (words str) list2 :: [String] -> InputT GHCi () list2 [arg] | all isDigit arg = do