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
findEditor :: IO String
findEditor = do
getEnv "EDITOR"
- `IO.catch` \_ -> do
+ `catchIO` \_ -> do
#if mingw32_HOST_OS
win <- System.Win32.getWindowsDirectory
return (win </> "notepad.exe")
foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
+default_progname, default_prompt, default_stop :: String
+default_progname = "<interactive>"
+default_prompt = "%s> "
+default_stop = ""
+
+default_args :: [String]
+default_args = []
+
interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
-> Ghc ()
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.
default_editor <- liftIO $ findEditor
startGHCi (runGHCi srcs maybe_exprs)
- GHCiState{ progname = "<interactive>",
- args = [],
- prompt = "%s> ",
- stop = "",
+ GHCiState{ progname = default_progname,
+ args = default_args,
+ prompt = default_prompt,
+ stop = default_stop,
editor = default_editor,
-- session = session,
options = [],
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 <- IO.try (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")
-- 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 `catchIO` \_ -> return ())
where
getDirectory f = case takeDirectory f of "" -> "."; d -> d
| "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
+ result <- GhciMonad.runStmt stmt step
afterRunStmt (const True) result
--afterRunStmt :: GHC.RunResult -> GHCi Bool
info :: String -> InputT GHCi ()
info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
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 }
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
-- 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)]))
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)
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 ()
typeOfExpr :: String -> InputT GHCi ()
typeOfExpr str
= handleSourceError GHC.printException
- $ withFlattenedDynflags
$ do
ty <- GHC.exprType str
dflags <- getDynFlags
kindOfType :: String -> InputT GHCi ()
kindOfType str
= handleSourceError GHC.printException
- $ withFlattenedDynflags
$ do
ty <- GHC.typeKind str
printForUser $ text str <+> dcolon <+> ppr ty
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
-- 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,
playCtxtCmd:: Bool -> CtxtCmd -> GHCi ()
playCtxtCmd fail cmd = do
- withFlattenedDynflags $ do
(prev_as,prev_bs) <- GHC.getContext
case cmd of
SetContext as bs -> 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
-- 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))
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
_ -> 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 "<end of history>" else "..."
-- handle the "break" command
breakCmd :: String -> GHCi ()
breakCmd argLine = do
- withFlattenedDynflags $ breakSwitch $ words argLine
+ breakSwitch $ words argLine
breakSwitch :: [String] -> GHCi ()
breakSwitch [] = do
end_bold = "\ESC[0m"
listCmd :: String -> InputT GHCi ()
-listCmd c = withFlattenedDynflags $ listCmd' c
+listCmd c = listCmd' c
listCmd' :: String -> InputT GHCi ()
listCmd' "" = do
projects / ghc-hetmet.git / blobdiff