X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FInteractiveUI.hs;h=e22eaef83ceae73c4bbb302a04bd17036bf46cf2;hb=05859437c5dfd2967418e3267f7cfc37e4f8952d;hp=9807556435d7e2711c5bb0723484220ca51b7852;hpb=0eca7e0b307c5862212c9eebfc69af9743ef06f3;p=ghc-hetmet.git diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 9807556..e22eaef 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -294,6 +294,14 @@ findEditor = do foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt +default_progname, default_prompt, default_stop :: String +default_progname = "" +default_prompt = "%s> " +default_stop = "" + +default_args :: [String] +default_args = [] + interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () interactiveUI srcs maybe_exprs = do @@ -344,10 +352,10 @@ interactiveUI srcs maybe_exprs = do default_editor <- liftIO $ findEditor startGHCi (runGHCi srcs maybe_exprs) - GHCiState{ progname = "", - args = [], - prompt = "%s> ", - stop = "", + GHCiState{ progname = default_progname, + args = default_args, + prompt = default_prompt, + stop = default_stop, editor = default_editor, -- session = session, options = [], @@ -404,8 +412,10 @@ runGHCi paths maybe_exprs = do -- NOTE: this assumes that runInputT won't affect the terminal; -- can we assume this will always be the case? -- This would be a good place for runFileInputT. - Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do + Right hdl -> + do runInputTWithPrefs defaultPrefs defaultSettings $ runCommands $ fileLoop hdl + liftIO (hClose hdl `IO.catch` \_ -> return ()) where getDirectory f = case takeDirectory f of "" -> "."; d -> d @@ -657,7 +667,7 @@ runStmt stmt step -- a file, otherwise the read buffer can't be flushed). _ <- liftIO $ IO.try $ hFlushAll stdin #endif - result <- withFlattenedDynflags $ GhciMonad.runStmt stmt step + result <- GhciMonad.runStmt stmt step afterRunStmt (const True) result --afterRunStmt :: GHC.RunResult -> GHCi Bool @@ -816,8 +826,7 @@ help _ = liftIO (putStr helpText) info :: String -> InputT GHCi () info "" = ghcError (CmdLineError "syntax: ':i '") info s = handleSourceError GHC.printException $ - withFlattenedDynflags $ do - { let names = words s + do { let names = words s ; dflags <- getDynFlags ; let pefas = dopt Opt_PrintExplicitForalls dflags ; mapM_ (infoThing pefas) names } @@ -857,8 +866,7 @@ runMain :: String -> GHCi () runMain s = case toArgs s of Left err -> liftIO (hPutStrLn stderr err) Right args -> - withFlattenedDynflags $ do - dflags <- getDynFlags + do dflags <- getDynFlags case mainFunIs dflags of Nothing -> doWithArgs args "main" Just f -> doWithArgs args f @@ -977,7 +985,7 @@ defineMacro overwrite s = do -- compile the expression handleSourceError (\e -> GHC.printException e) $ - withFlattenedDynflags $ do + do hv <- GHC.compileExpr new_expr liftIO (writeIORef macros_ref -- (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)])) @@ -1005,7 +1013,7 @@ cmdCmd :: String -> GHCi () cmdCmd str = do let expr = '(' : str ++ ") :: IO String" handleSourceError (\e -> GHC.printException e) $ - withFlattenedDynflags $ do + do hv <- GHC.compileExpr expr cmds <- liftIO $ (unsafeCoerce# hv :: IO String) enqueueCommands (lines cmds) @@ -1088,7 +1096,7 @@ afterLoad ok retain_context prev_context = do loaded_mod_names = map GHC.moduleName loaded_mods modulesLoadedMsg ok loaded_mod_names - withFlattenedDynflags $ lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries + lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi () @@ -1169,7 +1177,6 @@ modulesLoadedMsg ok mods = do typeOfExpr :: String -> InputT GHCi () typeOfExpr str = handleSourceError GHC.printException - $ withFlattenedDynflags $ do ty <- GHC.exprType str dflags <- getDynFlags @@ -1179,7 +1186,6 @@ typeOfExpr str kindOfType :: String -> InputT GHCi () kindOfType str = handleSourceError GHC.printException - $ withFlattenedDynflags $ do ty <- GHC.typeKind str printForUser $ text str <+> dcolon <+> ppr ty @@ -1190,13 +1196,6 @@ quit _ = return True shellEscape :: String -> GHCi Bool shellEscape str = liftIO (system str >> return False) -withFlattenedDynflags :: GHC.GhcMonad m => m a -> m a -withFlattenedDynflags m - = do dflags <- GHC.getSessionDynFlags - gbracket (GHC.setSessionDynFlags dflags) - (\_ -> GHC.setSessionDynFlags dflags) - (\_ -> m) - ----------------------------------------------------------------------------- -- Browsing a module's contents @@ -1225,7 +1224,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 = withFlattenedDynflags $ do +browseModule bang modl exports_only = do -- :browse! reports qualifiers wrt current context current_unqual <- GHC.getPrintUnqual -- Temporarily set the context to the module we're interested in, @@ -1338,7 +1337,6 @@ setContext str playCtxtCmd:: Bool -> CtxtCmd -> GHCi () playCtxtCmd fail cmd = do - withFlattenedDynflags $ do (prev_as,prev_bs) <- GHC.getContext case cmd of SetContext as bs -> do @@ -1528,22 +1526,32 @@ newDynFlags minus_opts = do unsetOptions :: String -> GHCi () unsetOptions str - = do -- first, deal with the GHCi opts (+s, +t, etc.) - let opts = words str - (minus_opts, rest1) = partition isMinus opts - (plus_opts, rest2) = partitionWith isPlus rest1 - - if (not (null rest2)) - then liftIO (putStrLn ("unknown option: '" ++ head rest2 ++ "'")) - else do + = -- first, deal with the GHCi opts (+s, +t, etc.) + let opts = words str + (minus_opts, rest1) = partition isMinus opts + (plus_opts, rest2) = partitionWith isPlus rest1 + (other_opts, rest3) = partition (`elem` map fst defaulters) rest2 + + defaulters = + [ ("args" , setArgs default_args) + , ("prog" , setProg default_progname) + , ("prompt", setPrompt default_prompt) + , ("editor", liftIO findEditor >>= setEditor) + , ("stop" , setStop default_stop) + ] + + no_flag ('-':'f':rest) = return ("-fno-" ++ rest) + no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f)) + + in if (not (null rest3)) + then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'")) + else do + mapM_ (fromJust.flip lookup defaulters) other_opts - mapM_ unsetOpt plus_opts - - let no_flag ('-':'f':rest) = return ("-fno-" ++ rest) - no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f)) + mapM_ unsetOpt plus_opts - no_flags <- mapM no_flag minus_opts - newDynFlags no_flags + no_flags <- mapM no_flag minus_opts + newDynFlags no_flags isMinus :: String -> Bool isMinus ('-':_) = True @@ -1580,7 +1588,7 @@ optToStr RevertCAFs = "r" -- code for `:show' showCmd :: String -> GHCi () -showCmd str = withFlattenedDynflags $ do +showCmd str = do st <- getGHCiState case words str of ["args"] -> liftIO $ putStrLn (show (args st)) @@ -1880,7 +1888,7 @@ forceCmd = pprintCommand False True pprintCommand :: Bool -> Bool -> String -> GHCi () pprintCommand bind force str = do - withFlattenedDynflags $ pprintClosureCommand bind force str + pprintClosureCommand bind force str stepCmd :: String -> GHCi () stepCmd [] = doContinue (const True) GHC.SingleStep @@ -1975,11 +1983,11 @@ historyCmd arg _ -> do spans <- mapM GHC.getHistorySpan took let nums = map (printf "-%-3d:") [(1::Int)..] - names = map GHC.historyEnclosingDecl took + names = map GHC.historyEnclosingDecls took printForUser (vcat(zipWith3 (\x y z -> x <+> y <+> z) (map text nums) - (map (bold . ppr) names) + (map (bold . hcat . punctuate colon . map text) names) (map (parens . ppr) spans))) liftIO $ putStrLn $ if null rest then "" else "..." @@ -2010,7 +2018,7 @@ forwardCmd = noArgs $ do -- handle the "break" command breakCmd :: String -> GHCi () breakCmd argLine = do - withFlattenedDynflags $ breakSwitch $ words argLine + breakSwitch $ words argLine breakSwitch :: [String] -> GHCi () breakSwitch [] = do @@ -2143,7 +2151,7 @@ end_bold :: String end_bold = "\ESC[0m" listCmd :: String -> InputT GHCi () -listCmd c = withFlattenedDynflags $ listCmd' c +listCmd c = listCmd' c listCmd' :: String -> InputT GHCi () listCmd' "" = do