X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2FInteractiveUI.hs;h=884059aece238ce735cb816115c4ccd1eb87e40a;hp=f12773521d31909dad7850233def36369df82ea1;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=db604b9dd4cb26b317048d1c143693bbf8fa9727 diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index f127735..884059a 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -27,6 +27,8 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), Ghc, handleSourceError ) import PprTyThing import DynFlags +import qualified Lexer +import StringBuffer import Packages -- import PackageConfig @@ -36,13 +38,12 @@ import HscTypes ( handleFlagWarnings ) import HsImpExp import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? import RdrName (RdrName) -import Outputable hiding (printForUser, printForUserPartWay) +import Outputable hiding (printForUser, printForUserPartWay, bold) import Module -- for ModuleEnv import Name import SrcLoc -- Other random utilities -import CmdLineParser import Digraph import BasicTypes hiding (isTopLevel) import Panic hiding (showException) @@ -81,7 +82,7 @@ import System.Environment import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO -import System.IO.Error as IO +import System.IO.Error import Data.Char import Data.Array import Control.Monad as Monad @@ -89,12 +90,8 @@ import Text.Printf import Foreign import GHC.Exts ( unsafeCoerce# ) -#if __GLASGOW_HASKELL__ >= 611 import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) import GHC.IO.Handle ( hFlushAll ) -#else -import GHC.IOBase ( IOErrorType(InvalidArgument) ) -#endif import GHC.TopHandler @@ -140,12 +137,13 @@ builtin_commands = [ ("kind", keepGoing' kindOfType, completeIdentifier), ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), ("list", keepGoing' listCmd, noCompletion), - ("module", keepGoing setContext, completeSetModule), + ("module", keepGoing moduleCmd, completeSetModule), ("main", keepGoing runMain, completeFilename), ("print", keepGoing printCmd, completeExpression), ("quit", quit, noCompletion), ("reload", keepGoing' reloadModule, noCompletion), ("run", keepGoing runRun, completeFilename), + ("script", keepGoing' scriptCmd, completeFilename), ("set", keepGoing setCmd, completeSetOptions), ("show", keepGoing showCmd, completeShowOptions), ("sprint", keepGoing sprintCmd, completeExpression), @@ -220,6 +218,7 @@ helpText = " :quit exit GHCi\n" ++ " :reload reload the current module set\n" ++ " :run function [ ...] run the function with the given arguments\n" ++ + " :script run the script " ++ " :type show the type of \n" ++ " :undef undefine user-defined command :\n" ++ " :! run the shell command \n" ++ @@ -261,6 +260,7 @@ helpText = "\n" ++ " Options for ':set' and ':unset':\n" ++ "\n" ++ + " +m allow multiline commands\n" ++ " +r revert top-level expressions after each evaluation\n" ++ " +s print timing/memory stats after each evaluation\n" ++ " +t print type after evaluation\n" ++ @@ -284,7 +284,7 @@ helpText = findEditor :: IO String findEditor = do getEnv "EDITOR" - `IO.catch` \_ -> do + `catchIO` \_ -> do #if mingw32_HOST_OS win <- System.Win32.getWindowsDirectory return (win "notepad.exe") @@ -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 @@ -330,7 +338,7 @@ interactiveUI srcs maybe_exprs = do -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering -#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 +#if defined(mingw32_HOST_OS) -- On Unix, stdin will use the locale encoding. The IO library -- doesn't do this on Windows (yet), so for now we use UTF-8, -- for consistency with GHC 6.10 and to make the tests work. @@ -338,20 +346,21 @@ interactiveUI srcs maybe_exprs = do #endif -- initial context is just the Prelude - prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing - GHC.setContext [] [(prel_mod, Nothing)] + let prel_mn = GHC.mkModuleName "Prelude" + GHC.setContext [] [simpleImportDecl prel_mn] 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 = [], - prelude = prel_mod, + prelude = prel_mn, + line_number = 1, break_ctr = 0, breaks = [], tickarrays = emptyModuleEnv, @@ -365,24 +374,26 @@ interactiveUI srcs maybe_exprs = do withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a withGhcAppData right left = do - either_dir <- IO.try (getAppUserDataDirectory "ghc") - case either_dir of - Right dir -> right dir - _ -> left + either_dir <- tryIO (getAppUserDataDirectory "ghc") + case either_dir of + Right dir -> + do createDirectoryIfMissing False dir `catchIO` \_ -> return () + right dir + _ -> left runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi () runGHCi paths maybe_exprs = do - let + let read_dot_files = not opt_IgnoreDotGhci current_dir = return (Just ".ghci") - app_user_dir = io $ withGhcAppData + app_user_dir = liftIO $ withGhcAppData (\dir -> return (Just (dir "ghci.conf"))) (return Nothing) home_dir = do - either_dir <- io $ IO.try (getEnv "HOME") + either_dir <- liftIO $ tryIO (getEnv "HOME") case either_dir of Right home -> return (Just (home ".ghci")) _ -> return Nothing @@ -393,25 +404,27 @@ runGHCi paths maybe_exprs = do sourceConfigFile :: FilePath -> GHCi () sourceConfigFile file = do - exists <- io $ doesFileExist file + exists <- liftIO $ doesFileExist file when exists $ do - dir_ok <- io $ checkPerms (getDirectory file) - file_ok <- io $ checkPerms file + dir_ok <- liftIO $ checkPerms (getDirectory file) + file_ok <- liftIO $ checkPerms file when (dir_ok && file_ok) $ do - either_hdl <- io $ IO.try (openFile file ReadMode) + either_hdl <- liftIO $ tryIO (openFile file ReadMode) case either_hdl of Left _e -> return () -- 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 - runCommands $ fileLoop hdl + Right hdl -> + do runInputTWithPrefs defaultPrefs defaultSettings $ + runCommands False $ fileLoop hdl + liftIO (hClose hdl `catchIO` \_ -> return ()) where getDirectory f = case takeDirectory f of "" -> "."; d -> d when (read_dot_files) $ do mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ] - mcfgs <- io $ mapM canonicalizePath' (catMaybes mcfgs0) + mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0) mapM_ sourceConfigFile $ nub $ catMaybes mcfgs -- nub, because we don't want to read .ghci twice if the -- CWD is $HOME. @@ -427,11 +440,11 @@ runGHCi paths maybe_exprs = do filePaths' <- mapM (Encoding.decode . BS.pack) filePaths loadModule (zip filePaths' phases) when (isJust maybe_exprs && failed ok) $ - io (exitWith (ExitFailure 1)) + liftIO (exitWith (ExitFailure 1)) -- if verbosity is greater than 0, or we are connected to a -- terminal, display the prompt in the interactive loop. - is_tty <- io (hIsTerminalDevice stdin) + is_tty <- liftIO (hIsTerminalDevice stdin) dflags <- getDynFlags let show_prompt = verbosity dflags > 0 || is_tty @@ -439,7 +452,7 @@ runGHCi paths maybe_exprs = do Nothing -> do -- enter the interactive loop - runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty + runGHCiInput $ runCommands True $ nextInputLine show_prompt is_tty Just exprs -> do -- just evaluate the expression we were given enqueueCommands exprs @@ -449,19 +462,19 @@ runGHCi paths maybe_exprs = do -- Jump through some hoops to get the -- current progname in the exception text: -- : - io $ withProgName (progname st) + liftIO $ withProgName (progname st) -- this used to be topHandlerFastExit, see #2228 - $ topHandler e + $ topHandler e runInputTWithPrefs defaultPrefs defaultSettings $ do - runCommands' handle (return Nothing) + runCommands' handle True (return Nothing) -- and finally, exit - io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." + liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." runGHCiInput :: InputT GHCi a -> GHCi a runGHCiInput f = do - histFile <- io $ withGhcAppData (\dir -> return (Just (dir "ghci_history"))) - (return Nothing) + histFile <- liftIO $ withGhcAppData (\dir -> return (Just (dir "ghci_history"))) + (return Nothing) let settings = setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile} runInputT settings f @@ -507,9 +520,15 @@ checkPerms name = else return True #endif -fileLoop :: MonadIO m => Handle -> InputT m (Maybe String) +incrementLines :: InputT GHCi () +incrementLines = do + st <- lift $ getGHCiState + let ln = 1+(line_number st) + lift $ setGHCiState st{line_number=ln} + +fileLoop :: Handle -> InputT GHCi (Maybe String) fileLoop hdl = do - l <- liftIO $ IO.try $ hGetLine hdl + l <- liftIO $ tryIO $ hGetLine hdl case l of Left e | isEOFError e -> return Nothing | InvalidArgument <- etype -> return Nothing @@ -519,11 +538,13 @@ fileLoop hdl = do -- this can happen if the user closed stdin, or -- perhaps did getContents which closes stdin at -- EOF. - Right l -> return (Just l) + Right l -> do + incrementLines + return (Just l) mkPrompt :: GHCi String mkPrompt = do - (toplevs,exports) <- GHC.getContext + (toplevs,imports) <- GHC.getContext resumes <- GHC.getResumeContext -- st <- getGHCiState @@ -549,7 +570,7 @@ mkPrompt = do -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+> -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+> hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> - hsep (map (ppr . GHC.moduleName) (nub (map fst exports))) + hsep (map ppr (nub (map ideclName imports))) deflt_prompt = dots <> context_bit <> modules_bit @@ -570,37 +591,44 @@ queryQueue = do c:cs -> do setGHCiState st{ cmdqueue = cs } return (Just c) -runCommands :: InputT GHCi (Maybe String) -> InputT GHCi () +runCommands :: Bool -> InputT GHCi (Maybe String) -> InputT GHCi () runCommands = runCommands' handler runCommands' :: (SomeException -> GHCi Bool) -- Exception handler + -> Bool -> InputT GHCi (Maybe String) -> InputT GHCi () -runCommands' eh getCmd = do +runCommands' eh resetLineTo1 getCmd = do + when resetLineTo1 $ lift $ do st <- getGHCiState + setGHCiState $ st { line_number = 0 } b <- ghandle (\e -> case fromException e of - Just UserInterrupt -> return False + Just UserInterrupt -> return $ Just False _ -> case fromException e of Just ghc_e -> do liftIO (print (ghc_e :: GhcException)) - return True + return Nothing _other -> liftIO (Exception.throwIO e)) (runOneCommand eh getCmd) - if b then return () else runCommands' eh getCmd + case b of + Nothing -> return () + Just _ -> runCommands' eh resetLineTo1 getCmd runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String) - -> InputT GHCi Bool + -> InputT GHCi (Maybe Bool) runOneCommand eh getCmd = do mb_cmd <- noSpace (lift queryQueue) mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd case mb_cmd of - Nothing -> return True - Just c -> ghciHandle (lift . eh) $ + Nothing -> return Nothing + Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $ handleSourceError printErrorAndKeepGoing (doCommand c) + -- source error's are handled by runStmt + -- is the handler necessary here? where printErrorAndKeepGoing err = do - GHC.printExceptionAndWarnings err - return False + GHC.printException err + return $ Just True noSpace q = q >>= maybe (return Nothing) (\c->case removeSpaces c of @@ -631,9 +659,64 @@ runOneCommand eh getCmd = do normSpace c = c -- QUESTION: is userError the one to use here? collectError = userError "unterminated multiline command :{ .. :}" - doCommand (':' : cmd) = specialCommand cmd - doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion - return False + doCommand (':' : cmd) = do + result <- specialCommand cmd + case result of + True -> return Nothing + _ -> return $ Just True + doCommand stmt = do + ml <- lift $ isOptionSet Multiline + if ml + then do + mb_stmt <- checkInputForLayout stmt getCmd + case mb_stmt of + Nothing -> return $ Just True + Just ml_stmt -> do + result <- timeIt $ lift $ runStmt ml_stmt GHC.RunToCompletion + return $ Just result + else do + result <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion + return $ Just result + +-- #4316 +-- lex the input. If there is an unclosed layout context, request input +checkInputForLayout :: String -> InputT GHCi (Maybe String) + -> InputT GHCi (Maybe String) +checkInputForLayout stmt getStmt = do + dflags' <- lift $ getDynFlags + let dflags = xopt_set dflags' Opt_AlternativeLayoutRule + st <- lift $ getGHCiState + let buf = stringToStringBuffer stmt + loc = mkRealSrcLoc (fsLit (progname st)) (line_number st) 1 + pstate = Lexer.mkPState dflags buf loc + case Lexer.unP goToEnd pstate of + (Lexer.POk _ False) -> return $ Just stmt + _other -> do + st <- lift getGHCiState + let p = prompt st + lift $ setGHCiState st{ prompt = "%s| " } + mb_stmt <- ghciHandle (\ex -> case fromException ex of + Just UserInterrupt -> return Nothing + _ -> case fromException ex of + Just ghc_e -> + do liftIO (print (ghc_e :: GhcException)) + return Nothing + _other -> liftIO (Exception.throwIO ex)) + getStmt + lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p } + -- the recursive call does not recycle parser state + -- as we use a new string buffer + case mb_stmt of + Nothing -> return Nothing + Just str -> if str == "" + then return $ Just stmt + else do + checkInputForLayout (stmt++"\n"++str) getStmt + where goToEnd = do + eof <- Lexer.nextIsEOF + if eof + then Lexer.activeContext + else Lexer.lexer return >> goToEnd enqueueCommands :: [String] -> GHCi () enqueueCommands cmds = do @@ -648,16 +731,13 @@ runStmt stmt step | "import " `isPrefixOf` stmt = do newContextCmd (Import stmt); return False | otherwise - = do -#if __GLASGOW_HASKELL__ >= 611 - -- In the new IO library, read handles buffer data even if the Handle + = do -- In the new IO library, read handles buffer data even if the Handle -- is set to NoBuffering. This causes problems for GHCi where there -- are really two stdin Handles. So we flush any bufferred data in -- GHCi's stdin Handle here (only relevant if stdin is attached to -- a file, otherwise the read buffer can't be flushed). - _ <- liftIO $ IO.try $ hFlushAll stdin -#endif - result <- withFlattenedDynflags $ GhciMonad.runStmt stmt step + _ <- liftIO $ tryIO $ hFlushAll stdin + result <- GhciMonad.runStmt stmt step afterRunStmt (const True) result --afterRunStmt :: GHC.RunResult -> GHCi Bool @@ -687,7 +767,7 @@ afterRunStmt step_here run_result = do _ -> return () flushInterpBuffers - io installSignalHandlers + liftIO installSignalHandlers b <- isOptionSet RevertCAFs when b revertCAFs @@ -755,7 +835,7 @@ lookupCommand "" = do Just c -> return $ GotCommand c Nothing -> return NoLastCommand lookupCommand str = do - mc <- io $ lookupCommand' str + mc <- liftIO $ lookupCommand' str st <- getGHCiState setGHCiState st{ last_command = mc } return $ case mc of @@ -768,8 +848,11 @@ lookupCommand' str' = do macros <- readIORef macros_ref let{ (str, cmds) = case str' of ':' : rest -> (rest, builtin_commands) - _ -> (str', macros ++ builtin_commands) } + _ -> (str', builtin_commands ++ macros) } -- look for exact match first, then the first prefix match + -- We consider builtin commands first: since new macros are appended + -- on the *end* of the macros list, this is consistent with the view + -- that things defined earlier should take precedence. See also #3858 return $ case [ c | c <- cmds, str == cmdName c ] of c:_ -> Just c [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of @@ -808,16 +891,15 @@ getCurrentBreakModule = do noArgs :: GHCi () -> String -> GHCi () noArgs m "" = m -noArgs _ _ = io $ putStrLn "This command takes no arguments" +noArgs _ _ = liftIO $ putStrLn "This command takes no arguments" help :: String -> GHCi () -help _ = io (putStr helpText) +help _ = liftIO (putStr helpText) info :: String -> InputT GHCi () info "" = ghcError (CmdLineError "syntax: ':i '") -info s = handleSourceError GHC.printExceptionAndWarnings $ - withFlattenedDynflags $ do - { let names = words s +info s = handleSourceError GHC.printException $ + do { let names = words s ; dflags <- getDynFlags ; let pefas = dopt Opt_PrintExplicitForalls dflags ; mapM_ (infoThing pefas) names } @@ -827,7 +909,7 @@ info s = handleSourceError GHC.printExceptionAndWarnings $ mb_stuffs <- mapM GHC.getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) unqual <- GHC.getPrintUnqual - outputStrLn $ showSDocForUser unqual $ + liftIO $ putStrLn $ showSDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo pefas) filtered) @@ -855,17 +937,16 @@ pprInfo pefas (thing, fixity, insts) runMain :: String -> GHCi () runMain s = case toArgs s of - Left err -> io (hPutStrLn stderr err) + 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 runRun :: String -> GHCi () runRun s = case toCmdArgs s of - Left err -> io (hPutStrLn stderr err) + Left err -> liftIO (hPutStrLn stderr err) Right (cmd, args) -> doWithArgs args cmd doWithArgs :: [String] -> String -> GHCi () @@ -887,14 +968,14 @@ addModule files = do changeDirectory :: String -> InputT GHCi () changeDirectory "" = do -- :cd on its own changes to the user's home directory - either_dir <- liftIO $ IO.try getHomeDirectory + either_dir <- liftIO $ tryIO getHomeDirectory case either_dir of Left _e -> return () Right dir -> changeDirectory dir changeDirectory dir = do graph <- GHC.getModuleGraph when (not (null graph)) $ - outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" + liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed." prev_context <- GHC.getContext GHC.setTargets [] _ <- GHC.load LoadAllTargets @@ -905,7 +986,7 @@ changeDirectory dir = do trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag trySuccess act = - handleSourceError (\e -> do GHC.printExceptionAndWarnings e + handleSourceError (\e -> do GHC.printException e return Failed) $ do act @@ -916,7 +997,7 @@ editFile str = let cmd = editor st when (null cmd) $ ghcError (CmdLineError "editor not set, use :set editor") - _ <- io $ system (cmd ++ ' ':file) + _ <- liftIO $ system (cmd ++ ' ':file) return () -- The user didn't specify a file so we pick one for them. @@ -953,16 +1034,16 @@ chooseEditFile = defineMacro :: Bool{-overwrite-} -> String -> GHCi () defineMacro _ (':':_) = - io $ putStrLn "macro name cannot start with a colon" + liftIO $ putStrLn "macro name cannot start with a colon" defineMacro overwrite s = do let (macro_name, definition) = break isSpace s - macros <- io (readIORef macros_ref) + macros <- liftIO (readIORef macros_ref) let defined = map cmdName macros if (null macro_name) then if null defined - then io $ putStrLn "no macros defined" - else io $ putStr ("the following macros are defined:\n" ++ - unlines defined) + then liftIO $ putStrLn "no macros defined" + else liftIO $ putStr ("the following macros are defined:\n" ++ + unlines defined) else do if (not overwrite && macro_name `elem` defined) then ghcError (CmdLineError @@ -976,15 +1057,15 @@ defineMacro overwrite s = do let new_expr = '(' : definition ++ ") :: String -> IO String" -- compile the expression - handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ - withFlattenedDynflags $ do + handleSourceError (\e -> GHC.printException e) $ + do hv <- GHC.compileExpr new_expr - io (writeIORef macros_ref -- - (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)])) + liftIO (writeIORef macros_ref -- + (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)])) runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool runMacro fun s = do - str <- io ((unsafeCoerce# fun :: String -> IO String) s) + str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s) -- make sure we force any exceptions in the result, while we are still -- inside the exception handler for commands: seqList str (return ()) @@ -994,20 +1075,20 @@ runMacro fun s = do undefineMacro :: String -> GHCi () undefineMacro str = mapM_ undef (words str) where undef macro_name = do - cmds <- io (readIORef macros_ref) + cmds <- liftIO (readIORef macros_ref) if (macro_name `notElem` map cmdName cmds) then ghcError (CmdLineError ("macro '" ++ macro_name ++ "' is not defined")) else do - io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) + liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) cmdCmd :: String -> GHCi () cmdCmd str = do let expr = '(' : str ++ ") :: IO String" - handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ - withFlattenedDynflags $ do + handleSourceError (\e -> GHC.printException e) $ + do hv <- GHC.compileExpr expr - cmds <- io $ (unsafeCoerce# hv :: IO String) + cmds <- liftIO $ (unsafeCoerce# hv :: IO String) enqueueCommands (lines cmds) return () @@ -1047,9 +1128,9 @@ checkModule :: String -> InputT GHCi () checkModule m = do let modl = GHC.mkModuleName m prev_context <- GHC.getContext - ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do + ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl - outputStrLn (showSDoc ( + liftIO $ putStrLn $ showSDoc $ case GHC.moduleInfo r of cm | Just scope <- GHC.modInfoTopLevelScope cm -> let @@ -1058,7 +1139,7 @@ checkModule m = do in (text "global names: " <+> ppr global) $$ (text "local names: " <+> ppr local) - _ -> empty)) + _ -> empty return True afterLoad (successIf ok) False prev_context @@ -1070,7 +1151,7 @@ reloadModule m = do else LoadUpTo (GHC.mkModuleName m) return () -doLoad :: Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> LoadHowMuch -> InputT GHCi SuccessFlag +doLoad :: Bool -> ([Module],[ImportDecl RdrName]) -> LoadHowMuch -> InputT GHCi SuccessFlag doLoad retain_context prev_context howmuch = do -- turn off breakpoints before we load: we can't turn them off later, because -- the ModBreaks will have gone away. @@ -1079,7 +1160,7 @@ doLoad retain_context prev_context howmuch = do afterLoad ok retain_context prev_context return ok -afterLoad :: SuccessFlag -> Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> InputT GHCi () +afterLoad :: SuccessFlag -> Bool -> ([Module],[ImportDecl RdrName]) -> InputT GHCi () afterLoad ok retain_context prev_context = do lift revertCAFs -- always revert CAFs on load. lift discardTickArrays @@ -1088,13 +1169,13 @@ 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 () +setContextAfterLoad :: ([Module],[ImportDecl RdrName]) -> Bool -> [GHC.ModSummary] -> GHCi () setContextAfterLoad prev keep_ctxt [] = do prel_mod <- getPrelude - setContextKeepingPackageModules prev keep_ctxt ([], [(prel_mod, Nothing)]) + setContextKeepingPackageModules prev keep_ctxt ([], [simpleImportDecl prel_mod]) setContextAfterLoad prev keep_ctxt ms = do -- load a target if one is available, otherwise load the topmost module. targets <- GHC.getTargets @@ -1122,25 +1203,40 @@ setContextAfterLoad prev keep_ctxt ms = do if b then setContextKeepingPackageModules prev keep_ctxt ([m], []) else do prel_mod <- getPrelude - setContextKeepingPackageModules prev keep_ctxt ([],[(prel_mod,Nothing),(m,Nothing)]) + setContextKeepingPackageModules prev keep_ctxt + ([], [simpleImportDecl prel_mod, + simpleImportDecl (GHC.moduleName m)]) -- | Keep any package modules (except Prelude) when changing the context. setContextKeepingPackageModules - :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- previous context + :: ([Module],[ImportDecl RdrName]) -- previous context -> Bool -- re-execute :module commands - -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- new context + -> ([Module],[ImportDecl RdrName]) -- new context -> GHCi () setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do - let (_,bs0) = prev_context + let (_,imports0) = prev_context prel_mod <- getPrelude -- filter everything, not just lefts - let pkg_modules = filter ((\p -> not (isHomeModule p) && p /= prel_mod) . fst) bs0 - let bs1 = if null as then nubBy sameFst ((prel_mod,Nothing) : bs) else bs - GHC.setContext as (nubBy sameFst (bs1 ++ pkg_modules)) + + let is_pkg_mod i + | unLoc (ideclName i) == prel_mod = return False + | otherwise = do + e <- gtry $ GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i) + case e :: Either SomeException Module of + Left _ -> return False + Right m -> return (not (isHomeModule m)) + + pkg_modules <- filterM is_pkg_mod imports0 + + let bs1 = if null as + then nubBy sameMod (simpleImportDecl prel_mod : bs) + else bs + + GHC.setContext as (nubBy sameMod (bs1 ++ pkg_modules)) if keep_ctxt then do st <- getGHCiState - mapM_ (playCtxtCmd False) (remembered_ctx st) + playCtxtCmds False (remembered_ctx st) else do st <- getGHCiState setGHCiState st{ remembered_ctx = [] } @@ -1148,8 +1244,8 @@ setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do isHomeModule :: Module -> Bool isHomeModule mod = GHC.modulePackageId mod == mainPackageId -sameFst :: (Module, Maybe (ImportDecl RdrName)) -> (Module, Maybe (ImportDecl RdrName)) -> Bool -sameFst x y = fst x == fst y +sameMod :: ImportDecl RdrName -> ImportDecl RdrName -> Bool +sameMod x y = unLoc (ideclName x) == unLoc (ideclName y) modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi () modulesLoadedMsg ok mods = do @@ -1161,15 +1257,14 @@ modulesLoadedMsg ok mods = do punctuate comma (map ppr mods)) <> text "." case ok of Failed -> - outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)) + liftIO $ putStrLn $ showSDoc (text "Failed, modules loaded: " <> mod_commas) Succeeded -> - outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)) + liftIO $ putStrLn $ showSDoc (text "Ok, modules loaded: " <> mod_commas) typeOfExpr :: String -> InputT GHCi () typeOfExpr str - = handleSourceError (\e -> GHC.printExceptionAndWarnings e) - $ withFlattenedDynflags + = handleSourceError GHC.printException $ do ty <- GHC.exprType str dflags <- getDynFlags @@ -1178,8 +1273,7 @@ typeOfExpr str kindOfType :: String -> InputT GHCi () kindOfType str - = handleSourceError (\e -> GHC.printExceptionAndWarnings e) - $ withFlattenedDynflags + = handleSourceError GHC.printException $ do ty <- GHC.typeKind str printForUser $ text str <+> dcolon <+> ppr ty @@ -1188,14 +1282,40 @@ quit :: String -> InputT GHCi Bool quit _ = return True shellEscape :: String -> GHCi Bool -shellEscape str = io (system str >> return False) +shellEscape str = liftIO (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) +----------------------------------------------------------------------------- +-- running a script file #1363 + +scriptCmd :: String -> InputT GHCi () +scriptCmd s = do + case words s of + [s] -> runScript s + _ -> ghcError (CmdLineError "syntax: :script ") + +runScript :: String -- ^ filename + -> InputT GHCi () +runScript filename = do + either_script <- liftIO $ tryIO (openFile filename ReadMode) + case either_script of + Left _err -> ghcError (CmdLineError $ "IO error: \""++filename++"\" " + ++(ioeGetErrorString _err)) + Right script -> do + st <- lift $ getGHCiState + let prog = progname st + line = line_number st + lift $ setGHCiState st{progname=filename,line_number=0} + scriptLoop script + liftIO $ hClose script + new_st <- lift $ getGHCiState + lift $ setGHCiState new_st{progname=prog,line_number=line} + where scriptLoop script = do + res <- runOneCommand handler $ fileLoop script + case res of + Nothing -> return () + Just succ -> if succ + then scriptLoop script + else return () ----------------------------------------------------------------------------- -- Browsing a module's contents @@ -1216,7 +1336,10 @@ browseCmd bang m = -- recently-added module occurs last, it seems. case (as,bs) of (as@(_:_), _) -> browseModule bang (last as) True - ([], bs@(_:_)) -> browseModule bang (fst (last bs)) True + ([], bs@(_:_)) -> do + let i = last bs + m <- GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i) + browseModule bang m True ([], []) -> ghcError (CmdLineError ":browse: no current module") _ -> ghcError (CmdLineError "syntax: :browse ") @@ -1225,14 +1348,15 @@ 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, -- just so we can get an appropriate PrintUnqualified (as,bs) <- GHC.getContext prel_mod <- lift getPrelude - if exports_only then GHC.setContext [] [(prel_mod,Nothing), (modl,Nothing)] + if exports_only then GHC.setContext [] [simpleImportDecl prel_mod, + simpleImportDecl (GHC.moduleName modl)] else GHC.setContext [modl] [] target_unqual <- GHC.getPrintUnqual GHC.setContext as bs @@ -1300,7 +1424,7 @@ browseModule bang modl exports_only = withFlattenedDynflags $ do let prettyThings = map (pretty pefas) things prettyThings' | bang = annotate $ zip modNames prettyThings | otherwise = prettyThings - outputStrLn $ showSDocForUser unqual (vcat prettyThings') + liftIO $ putStrLn $ showSDocForUser unqual (vcat prettyThings') -- ToDo: modInfoInstances currently throws an exception for -- package modules. When it works, we can do this: -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info)) @@ -1310,13 +1434,13 @@ browseModule bang modl exports_only = withFlattenedDynflags $ do newContextCmd :: CtxtCmd -> GHCi () newContextCmd cmd = do - playCtxtCmd True cmd + playCtxtCmds True [cmd] st <- getGHCiState let cmds = remembered_ctx st setGHCiState st{ remembered_ctx = cmds ++ [cmd] } -setContext :: String -> GHCi () -setContext str +moduleCmd :: String -> GHCi () +moduleCmd str | all sensible strs = newContextCmd cmd | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where @@ -1336,54 +1460,65 @@ setContext str starred ('*':m) = Left m starred m = Right m -playCtxtCmd:: Bool -> CtxtCmd -> GHCi () -playCtxtCmd fail cmd = do - withFlattenedDynflags $ do - (prev_as,prev_bs) <- GHC.getContext +type Context = ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) + +playCtxtCmds :: Bool -> [CtxtCmd] -> GHCi () +playCtxtCmds fail cmds = do + ctx <- GHC.getContext + (as,bs) <- foldM (playCtxtCmd fail) ctx cmds + GHC.setContext as bs + +playCtxtCmd:: Bool -> Context -> CtxtCmd -> GHCi Context +playCtxtCmd fail (prev_as, prev_bs) cmd = 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' + let bs'' = if null as && prel_mod `notElem` bs' + then prel_mod : bs' else bs' - GHC.setContext as' bs'' + return (as', map simpleImportDecl 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') - GHC.setContext (remaining_as ++ as') (remaining_bs ++ bs') + let (remaining_as, remaining_bs) = + prev_without (map moduleName as' ++ bs') + return (remaining_as ++ as', remaining_bs ++ map simpleImportDecl 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') - GHC.setContext new_as new_bs + let (new_as, new_bs) = prev_without (map moduleName as' ++ bs') + return (new_as, new_bs) Import str -> do m_idecl <- maybe_fail $ GHC.parseImportDecl str case m_idecl of - Nothing -> return () + Nothing -> return (prev_as, prev_bs) 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)]) - + Nothing -> return (prev_as, prev_bs) + Just _ -> return (prev_as, prev_bs ++ [idecl]) + -- we don't filter the module out of the old declarations, + -- because 'import' is supposed to be cumulative. where maybe_fail | fail = liftM Just | otherwise = trymaybe + prev_without names = (as',bs') + where as' = deleteAllBy sameModName prev_as names + bs' = deleteAllBy importsSameMod prev_bs names + do_checks as bs = do as' <- mapM (maybe_fail . wantInterpretedModule) as - bs' <- mapM (maybe_fail . lookupModule) bs - return (catMaybes as', map contextualize (catMaybes bs')) + bs' <- mapM (maybe_fail . liftM moduleName . lookupModule) bs + return (catMaybes as', catMaybes bs') - contextualize x = (x,Nothing) - deleteAllBy f a b = filter (\x->(not (any (f x) b))) a + sameModName a b = moduleName a == b + importsSameMod a b = unLoc (ideclName a) == b + + deleteAllBy :: (a -> b -> Bool) -> [a] -> [b] -> [a] + deleteAllBy f as bs = filter (\a-> not (any (f a) bs)) as trymaybe ::GHCi a -> GHCi (Maybe a) trymaybe m = do @@ -1406,18 +1541,18 @@ setCmd :: String -> GHCi () setCmd "" = do st <- getGHCiState let opts = options st - io $ putStrLn (showSDoc ( + liftIO $ putStrLn (showSDoc ( text "options currently set: " <> if null opts then text "none." else hsep (map (\o -> char '+' <> text (optToStr o)) opts) )) dflags <- getDynFlags - io $ putStrLn (showSDoc ( + liftIO $ putStrLn (showSDoc ( vcat (text "GHCi-specific dynamic flag settings:" :map (flagSetting dflags) ghciFlags) )) - io $ putStrLn (showSDoc ( + liftIO $ putStrLn (showSDoc ( vcat (text "other dynamic, non-language, flag settings:" :map (flagSetting dflags) others) )) @@ -1436,17 +1571,17 @@ setCmd str = case getCmd str of Right ("args", rest) -> case toArgs rest of - Left err -> io (hPutStrLn stderr err) + Left err -> liftIO (hPutStrLn stderr err) Right args -> setArgs args Right ("prog", rest) -> case toArgs rest of Right [prog] -> setProg prog - _ -> io (hPutStrLn stderr "syntax: :set prog ") + _ -> liftIO (hPutStrLn stderr "syntax: :set prog ") Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest Right ("editor", rest) -> setEditor $ dropWhile isSpace rest Right ("stop", rest) -> setStop $ dropWhile isSpace rest _ -> case toArgs str of - Left err -> io (hPutStrLn stderr err) + Left err -> liftIO (hPutStrLn stderr err) Right wds -> setOptions wds setArgs, setOptions :: [String] -> GHCi () @@ -1484,13 +1619,13 @@ setStop cmd = do setPrompt value = do st <- getGHCiState if null value - then io $ hPutStrLn stderr $ "syntax: :set prompt , currently \"" ++ prompt st ++ "\"" + then liftIO $ hPutStrLn stderr $ "syntax: :set prompt , currently \"" ++ prompt st ++ "\"" else case value of '\"' : _ -> case reads value of [(value', xs)] | all isSpace xs -> setGHCiState (st { prompt = value' }) _ -> - io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax." + liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax." _ -> setGHCiState (st { prompt = value }) setOptions wds = @@ -1504,11 +1639,13 @@ newDynFlags :: [String] -> GHCi () newDynFlags minus_opts = do dflags <- getDynFlags let pkg_flags = packageFlags dflags - (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts - handleFlagWarnings dflags' warns + (dflags', leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts + liftIO $ handleFlagWarnings dflags' warns if (not (null leftovers)) - then ghcError $ errorsToGhcException leftovers + then ghcError . CmdLineError + $ "Some flags have not been recognized: " + ++ (concat . intersperse ", " $ map unLoc leftovers) else return () new_pkgs <- setDynFlags dflags' @@ -1517,10 +1654,10 @@ newDynFlags minus_opts = do -- and link the new packages. dflags <- getDynFlags when (packageFlags dflags /= pkg_flags) $ do - io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..." + liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..." GHC.setTargets [] _ <- GHC.load LoadAllTargets - io (linkPackages dflags new_pkgs) + liftIO (linkPackages dflags new_pkgs) -- package flags changed, we can't re-use any of the old context setContextAfterLoad ([],[]) False [] return () @@ -1528,22 +1665,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 io (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 @@ -1557,21 +1704,23 @@ setOpt, unsetOpt :: String -> GHCi () setOpt str = case strToGHCiOpt str of - Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'")) + Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) Just o -> setOption o unsetOpt str = case strToGHCiOpt str of - Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'")) + Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) Just o -> unsetOption o strToGHCiOpt :: String -> (Maybe GHCiOption) +strToGHCiOpt "m" = Just Multiline strToGHCiOpt "s" = Just ShowTiming strToGHCiOpt "t" = Just ShowType strToGHCiOpt "r" = Just RevertCAFs strToGHCiOpt _ = Nothing optToStr :: GHCiOption -> String +optToStr Multiline = "m" optToStr ShowTiming = "s" optToStr ShowType = "t" optToStr RevertCAFs = "r" @@ -1580,17 +1729,17 @@ optToStr RevertCAFs = "r" -- code for `:show' showCmd :: String -> GHCi () -showCmd str = withFlattenedDynflags $ do +showCmd str = do st <- getGHCiState case words str of - ["args"] -> io $ putStrLn (show (args st)) - ["prog"] -> io $ putStrLn (show (progname st)) - ["prompt"] -> io $ putStrLn (show (prompt st)) - ["editor"] -> io $ putStrLn (show (editor st)) - ["stop"] -> io $ putStrLn (show (stop st)) + ["args"] -> liftIO $ putStrLn (show (args st)) + ["prog"] -> liftIO $ putStrLn (show (progname st)) + ["prompt"] -> liftIO $ putStrLn (show (prompt st)) + ["editor"] -> liftIO $ putStrLn (show (editor st)) + ["stop"] -> liftIO $ putStrLn (show (stop st)) ["modules" ] -> showModules ["bindings"] -> showBindings - ["linker"] -> io showLinkerState + ["linker"] -> liftIO showLinkerState ["breaks"] -> showBkptTable ["context"] -> showContext ["packages"] -> showPackages @@ -1602,7 +1751,7 @@ showModules :: GHCi () showModules = do loaded_mods <- getLoadedModules -- we want *loaded* modules only, see #1734 - let show_one ms = do m <- GHC.showModule ms; io (putStrLn m) + let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m) mapM_ show_one loaded_mods getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary] @@ -1642,14 +1791,9 @@ showContext = do showPackages :: GHCi () showPackages = do pkg_flags <- fmap packageFlags getDynFlags - io $ putStrLn $ showSDoc $ vcat $ + liftIO $ putStrLn $ showSDoc $ vcat $ text ("active package flags:"++if null pkg_flags then " none" else "") : map showFlag pkg_flags - pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags - io $ putStrLn $ showSDoc $ vcat $ - text "packages currently loaded:" - : map (nest 2 . text . packageIdString) - (sortBy (compare `on` packageIdFS) pkg_ids) where showFlag (ExposePackage p) = text $ " -package " ++ p showFlag (HidePackage p) = text $ " -hide-package " ++ p showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p @@ -1658,9 +1802,9 @@ showPackages = do showLanguages :: GHCi () showLanguages = do dflags <- getDynFlags - io $ putStrLn $ showSDoc $ vcat $ + liftIO $ 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 @@ -1715,8 +1859,8 @@ completeModule = wrapIdentCompleter $ \w -> do completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do modules <- case m of Just '-' -> do - (toplevs, exports) <- GHC.getContext - return $ map GHC.moduleName (nub (map fst exports) ++ toplevs) + (toplevs, imports) <- GHC.getContext + return $ map GHC.moduleName toplevs ++ map (unLoc.ideclName) imports _ -> do dflags <- GHC.getSessionDynFlags let pkg_mods = allExposedModules dflags @@ -1793,21 +1937,21 @@ handler :: SomeException -> GHCi Bool handler exception = do flushInterpBuffers - io installSignalHandlers + liftIO installSignalHandlers ghciHandle handler (showException exception >> return False) showException :: SomeException -> GHCi () showException se = - io $ case fromException se of - -- omit the location for CmdLineError: - Just (CmdLineError s) -> putStrLn s - -- ditto: - Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "") - Just other_ghc_ex -> print other_ghc_ex - Nothing -> - case fromException se of - Just UserInterrupt -> putStrLn "Interrupted." - _other -> putStrLn ("*** Exception: " ++ show se) + liftIO $ case fromException se of + -- omit the location for CmdLineError: + Just (CmdLineError s) -> putStrLn s + -- ditto: + Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "") + Just other_ghc_ex -> print other_ghc_ex + Nothing -> + case fromException se of + Just UserInterrupt -> putStrLn "Interrupted." + _ -> putStrLn ("*** Exception: " ++ show se) ----------------------------------------------------------------------------- -- recursive exception handlers @@ -1859,7 +2003,7 @@ wantNameFromInterpretedModule :: GHC.GhcMonad m -> (Name -> m ()) -> m () wantNameFromInterpretedModule noCanDo str and_then = - handleSourceError (GHC.printExceptionAndWarnings) $ do + handleSourceError GHC.printException $ do names <- GHC.parseName str case names of [] -> return () @@ -1885,7 +2029,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 @@ -1917,12 +2061,15 @@ stepModuleCmd expression = stepCmd expression -- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan -enclosingTickSpan mod src = do +enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" +enclosingTickSpan mod (RealSrcSpan src) = do ticks <- getTickArray mod let line = srcSpanStartLine src ASSERT (inRange (bounds ticks) line) do - let enclosing_spans = [ span | (_,span) <- ticks ! line - , srcSpanEnd span >= srcSpanEnd src] + let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" + toRealSrcSpan (RealSrcSpan s) = s + enclosing_spans = [ span | (_,span) <- ticks ! line + , realSrcSpanEnd (toRealSrcSpan span) >= realSrcSpanEnd src] return . head . sortBy leftmost_largest $ enclosing_spans traceCmd :: String -> GHCi () @@ -1942,16 +2089,15 @@ doContinue pred step = do abandonCmd :: String -> GHCi () abandonCmd = noArgs $ do b <- GHC.abandon -- the prompt will change to indicate the new context - when (not b) $ io $ putStrLn "There is no computation running." - return () + when (not b) $ liftIO $ putStrLn "There is no computation running." deleteCmd :: String -> GHCi () deleteCmd argLine = do deleteSwitch $ words argLine where deleteSwitch :: [String] -> GHCi () - deleteSwitch [] = - io $ putStrLn "The delete command requires at least one argument." + deleteSwitch [] = + liftIO $ putStrLn "The delete command requires at least one argument." -- delete all break points deleteSwitch ("*":_rest) = discardActiveBreakPoints deleteSwitch idents = do @@ -1966,28 +2112,28 @@ historyCmd :: String -> GHCi () historyCmd arg | null arg = history 20 | all isDigit arg = history (read arg) - | otherwise = io $ putStrLn "Syntax: :history [num]" + | otherwise = liftIO $ putStrLn "Syntax: :history [num]" where history num = do resumes <- GHC.getResumeContext case resumes of - [] -> io $ putStrLn "Not stopped at a breakpoint" + [] -> liftIO $ putStrLn "Not stopped at a breakpoint" (r:_) -> do let hist = GHC.resumeHistory r (took,rest) = splitAt num hist case hist of - [] -> io $ putStrLn $ + [] -> liftIO $ putStrLn $ "Empty history. Perhaps you forgot to use :trace?" _ -> 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))) - io $ putStrLn $ if null rest then "" else "..." + liftIO $ putStrLn $ if null rest then "" else "..." bold :: SDoc -> SDoc bold c | do_bold = text start_bold <> c <> text end_bold @@ -2016,11 +2162,11 @@ 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 - io $ putStrLn "The break command requires at least one argument." + liftIO $ putStrLn "The break command requires at least one argument." breakSwitch (arg1:rest) | looksLikeModuleName arg1 && not (null rest) = do mod <- wantInterpretedModule arg1 @@ -2030,18 +2176,20 @@ breakSwitch (arg1:rest) case toplevel of (mod : _) -> breakByModuleLine mod (read arg1) rest [] -> do - io $ putStrLn "Cannot find default module for breakpoint." - io $ putStrLn "Perhaps no modules are loaded for debugging?" + liftIO $ putStrLn "Cannot find default module for breakpoint." + liftIO $ putStrLn "Perhaps no modules are loaded for debugging?" | otherwise = do -- try parsing it as an identifier wantNameFromInterpretedModule noCanDo arg1 $ \name -> do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) - if GHC.isGoodSrcLoc loc - then ASSERT( isExternalName name ) + case loc of + RealSrcLoc l -> + ASSERT( isExternalName name ) findBreakAndSet (GHC.nameModule name) $ - findBreakByCoord (Just (GHC.srcLocFile loc)) - (GHC.srcLocLine loc, - GHC.srcLocCol loc) - else noCanDo name $ text "can't find its location: " <> ppr loc + findBreakByCoord (Just (GHC.srcLocFile l)) + (GHC.srcLocLine l, + GHC.srcLocCol l) + UnhelpfulLoc _ -> + noCanDo name $ text "can't find its location: " <> ppr loc where noCanDo n why = printForUser $ text "cannot set breakpoint on " <> ppr n <> text ": " <> why @@ -2068,9 +2216,9 @@ findBreakAndSet mod lookupTickTree = do tickArray <- getTickArray mod (breakArray, _) <- getModBreak mod case lookupTickTree tickArray of - Nothing -> io $ putStrLn $ "No breakpoints found at that location." + Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location." Just (tick, span) -> do - success <- io $ setBreakFlag True breakArray tick + success <- liftIO $ setBreakFlag True breakArray tick if success then do (alreadySet, nm) <- @@ -2106,10 +2254,12 @@ findBreakByLine line arr ticks = arr ! line starts_here = [ tick | tick@(_,span) <- ticks, - GHC.srcSpanStartLine span == line ] + GHC.srcSpanStartLine (toRealSpan span) == line ] (complete,incomplete) = partition ends_here starts_here - where ends_here (_,span) = GHC.srcSpanEndLine span == line + where ends_here (_,span) = GHC.srcSpanEndLine (toRealSpan span) == line + toRealSpan (RealSrcSpan span) = span + toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan" findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan) @@ -2126,12 +2276,16 @@ findBreakByCoord mb_file (line, col) arr is_correct_file span ] is_correct_file span - | Just f <- mb_file = GHC.srcSpanFile span == f + | Just f <- mb_file = GHC.srcSpanFile (toRealSpan span) == f | otherwise = True after_here = [ tick | tick@(_,span) <- ticks, - GHC.srcSpanStartLine span == line, - GHC.srcSpanStartCol span >= col ] + let span' = toRealSpan span, + GHC.srcSpanStartLine span' == line, + GHC.srcSpanStartCol span' >= col ] + + toRealSpan (RealSrcSpan span) = span + toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan" -- For now, use ANSI bold on terminals that we know support it. -- Otherwise, we add a line of carets under the active expression instead. @@ -2149,7 +2303,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 @@ -2157,9 +2311,9 @@ listCmd' "" = do case mb_span of Nothing -> printForUser $ text "Not stopped at a breakpoint; nothing to list" - Just span - | GHC.isGoodSrcSpan span -> listAround span True - | otherwise -> + Just (RealSrcSpan span) -> + listAround span True + Just span@(UnhelpfulSpan _) -> do resumes <- GHC.getResumeContext case resumes of [] -> panic "No resumes" @@ -2177,7 +2331,7 @@ list2 :: [String] -> InputT GHCi () list2 [arg] | all isDigit arg = do (toplevel, _) <- GHC.getContext case toplevel of - [] -> outputStrLn "No module to list" + [] -> liftIO $ putStrLn "No module to list" (mod : _) -> listModuleLine mod (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do mod <- wantInterpretedModule arg1 @@ -2185,24 +2339,25 @@ list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do list2 [arg] = do wantNameFromInterpretedModule noCanDo arg $ \name -> do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) - if GHC.isGoodSrcLoc loc - then do - tickArray <- ASSERT( isExternalName name ) + case loc of + RealSrcLoc l -> + do tickArray <- ASSERT( isExternalName name ) lift $ getTickArray (GHC.nameModule name) - let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc)) - (GHC.srcLocLine loc, GHC.srcLocCol loc) + let mb_span = findBreakByCoord (Just (GHC.srcLocFile l)) + (GHC.srcLocLine l, GHC.srcLocCol l) tickArray case mb_span of - Nothing -> listAround (GHC.srcLocSpan loc) False - Just (_,span) -> listAround span False - else + Nothing -> listAround (realSrcLocSpan l) False + Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan" + Just (_, RealSrcSpan span) -> listAround span False + UnhelpfulLoc _ -> noCanDo name $ text "can't find its location: " <> ppr loc where noCanDo n why = printForUser $ text "cannot list source code for " <> ppr n <> text ": " <> why list2 _other = - outputStrLn "syntax: :list [ | | ]" + liftIO $ putStrLn "syntax: :list [ | | ]" listModuleLine :: Module -> Int -> InputT GHCi () listModuleLine modl line = do @@ -2212,8 +2367,8 @@ listModuleLine modl line = do [] -> panic "listModuleLine" summ:_ -> do let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ)) - loc = GHC.mkSrcLoc (mkFastString (filename)) line 0 - listAround (GHC.srcLocSpan loc) False + loc = mkRealSrcLoc (mkFastString (filename)) line 0 + listAround (realSrcLocSpan loc) False -- | list a section of a source file around a particular SrcSpan. -- If the highlight flag is True, also highlight the span using @@ -2224,7 +2379,7 @@ listModuleLine modl line = do -- 2) convert the BS to String using utf-string, and write it out. -- It would be better if we could convert directly between UTF-8 and the -- console encoding, of course. -listAround :: MonadIO m => SrcSpan -> Bool -> InputT m () +listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m () listAround span do_highlight = do contents <- liftIO $ BS.readFile (unpackFS file) let @@ -2243,7 +2398,7 @@ listAround span do_highlight = do let output = BS.intercalate (BS.pack "\n") prefixed utf8Decoded <- liftIO $ BS.useAsCStringLen output $ \(p,n) -> utf8DecodeString (castPtr p) n - outputStrLn utf8Decoded + liftIO $ putStrLn utf8Decoded where file = GHC.srcSpanFile span line1 = GHC.srcSpanStartLine span @@ -2311,11 +2466,14 @@ mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray mkTickArray ticks = accumArray (flip (:)) [] (1, max_line) [ (line, (nm,span)) | (nm,span) <- ticks, - line <- srcSpanLines span ] + let span' = toRealSpan span, + line <- srcSpanLines span' ] where - max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks)) + max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks) srcSpanLines span = [ GHC.srcSpanStartLine span .. GHC.srcSpanEndLine span ] + toRealSpan (RealSrcSpan span) = span + toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan" lookupModule :: GHC.GhcMonad m => String -> m Module lookupModule modName @@ -2343,7 +2501,7 @@ deleteBreak identity = do turnOffBreak :: BreakLocation -> GHCi Bool turnOffBreak loc = do (arr, _) <- getModBreak (breakModule loc) - io $ setBreakFlag False arr (breakTick loc) + liftIO $ setBreakFlag False arr (breakTick loc) getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) getModBreak mod = do @@ -2357,3 +2515,4 @@ setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool setBreakFlag toggle array index | toggle = GHC.setBreakOn array index | otherwise = GHC.setBreakOff array index +