--
-- GHC Interactive User Interface
--
--- (c) The GHC Team 2005
+-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------
module InteractiveUI (
import GHC.Exts ( Int(..), Ptr(..), int2Addr# )
import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
import System.IO.Unsafe ( unsafePerformIO )
-import Var ( Id, globaliseId, idName, idType )
-import HscTypes ( Session(..), InteractiveContext(..), HscEnv(..)
- , extendTypeEnvWithIds )
-import RdrName ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv )
-import NameEnv ( delListFromNameEnv )
-import TcType ( tidyTopType )
-import qualified Id ( setIdType )
-import IdInfo ( GlobalIdDetails(..) )
-import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,
- initDynLinker )
-import PrelNames ( breakpointJumpName, breakpointCondJumpName )
+import Var
+import HscTypes
+import RdrName
+import NameEnv
+import TcType
+import qualified Id
+import IdInfo
+import PrelNames
#endif
-- The GHC interface
import qualified GHC
-import GHC ( Session, dopt, DynFlag(..), Target(..),
- TargetId(..), DynFlags(..),
- pprModule, Type, Module, ModuleName, SuccessFlag(..),
- TyThing(..), Name, LoadHowMuch(..), Phase,
- GhcException(..), showGhcException,
- CheckedModule(..), SrcLoc )
-import DynFlags ( allFlags )
-import Packages ( PackageState(..) )
-import PackageConfig ( InstalledPackageInfo(..) )
-import UniqFM ( eltsUFM )
+import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
+ Type, Module, ModuleName, TyThing(..), Phase )
+import DynFlags
+import Packages
+import PackageConfig
+import UniqFM
import PprTyThing
import Outputable
--- for createtags (should these come via GHC?)
-import Name ( nameSrcLoc, nameModule, nameOccName )
-import OccName ( pprOccName )
-import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
+-- for createtags
+import Name
+import OccName
+import SrcLoc
-- Other random utilities
-import Digraph ( flattenSCCs )
-import BasicTypes ( failed, successIf )
-import Panic ( panic, installSignalHandlers )
+import Digraph
+import BasicTypes
+import Panic hiding (showException)
import Config
-import StaticFlags ( opt_IgnoreDotGhci )
-import Linker ( showLinkerState, linkPackages )
-import Util ( removeSpaces, handle, global, toArgs,
- looksLikeModuleName, prefixMatch, sortLe )
+import StaticFlags
+import Linker
+import Util
#ifndef mingw32_HOST_OS
import System.Posix
#else
import GHC.ConsoleHandler ( flushConsole )
import System.Win32 ( setConsoleCP, setConsoleOutputCP )
+import qualified System.Win32
#endif
#ifdef USE_READLINE
--import SystemExts
import Control.Exception as Exception
-import Data.Dynamic
-- import Control.Concurrent
import Numeric
import Data.List
import Data.Int ( Int64 )
-import Data.Maybe ( isJust, fromMaybe, catMaybes )
+import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
import System.Cmd
-import System.CPUTime
import System.Environment
import System.Exit ( exitWith, ExitCode(..) )
import System.Directory
("browse", keepGoing browseCmd, False, completeModule),
("cd", keepGoing changeDirectory, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
+ ("e", keepGoing editFile, False, completeFilename),
+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap
+ ("edit", keepGoing editFile, False, completeFilename),
("help", keepGoing help, False, completeNone),
("?", keepGoing help, False, completeNone),
("info", keepGoing info, False, completeIdentifier),
" :browse [*]<module> display the names defined by <module>\n" ++
" :cd <dir> change directory to <dir>\n" ++
" :def <cmd> <expr> define a command :<cmd>\n" ++
+ " :edit <file> edit file\n" ++
+ " :edit edit last module\n" ++
" :help, :? display this list of commands\n" ++
" :info [<name> ...] display information about the given names\n" ++
" :load <filename> ... load module(s) and their dependents\n" ++
" :set args <arg> ... set the arguments returned by System.getArgs\n" ++
" :set prog <progname> set the value returned by System.getProgName\n" ++
" :set prompt <prompt> set the prompt used in GHCi\n" ++
+ " :set editor <cmd> set the command used for :edit\n" ++
"\n" ++
" :show modules show the currently loaded modules\n" ++
" :show bindings show the current bindings made at the prompt\n" ++
"\n" ++
" :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
- " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
+ " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
" :type <expr> show the type of <expr>\n" ++
" :kind <type> show the kind of <type>\n" ++
" :undef <cmd> undefine user-defined command :<cmd>\n" ++
writeIORef ref (hsc_env { hsc_IC = new_ic })
is_tty <- hIsTerminalDevice stdin
prel_mod <- GHC.findModule session prel_name Nothing
+ default_editor <- findEditor
withExtendedLinkEnv (zip names hValues) $
startGHCi (interactiveLoop is_tty True)
GHCiState{ progname = "<interactive>",
args = [],
prompt = location++"> ",
+ editor = default_editor,
session = session,
options = [],
prelude = prel_mod }
return b
#endif
+findEditor = do
+ getEnv "EDITOR"
+ `IO.catch` \_ -> do
+#if mingw32_HOST_OS
+ win <- System.Win32.getWindowsDirectory
+ return (win `joinFileName` "notepad.exe")
+#else
+ return ""
+#endif
+
interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
interactiveUI session srcs maybe_expr = do
#if defined(GHCI) && defined(BREAKPOINT)
newStablePtr stdout
newStablePtr stderr
- hFlush stdout
- hSetBuffering stdout NoBuffering
-
-- Initialise buffering for the *interpreted* I/O system
initInterpBuffering session
+ when (isNothing maybe_expr) $ do
+ -- Only for GHCi (not runghc and ghc -e):
+ -- Turn buffering off for the compiled program's stdout/stderr
+ turnOffBuffering
+ -- Turn buffering off for GHCi's stdout
+ hFlush stdout
+ hSetBuffering stdout NoBuffering
-- We don't want the cmd line to buffer any input that might be
-- intended for the program, so unbuffer stdin.
- hSetBuffering stdin NoBuffering
+ hSetBuffering stdin NoBuffering
-- initial context is just the Prelude
prel_mod <- GHC.findModule session prel_name Nothing
Readline.setCompleterWordBreakCharacters word_break_chars
#endif
+ default_editor <- findEditor
+
startGHCi (runGHCi srcs maybe_expr)
GHCiState{ progname = "<interactive>",
args = [],
prompt = "%s> ",
+ editor = default_editor,
session = session,
options = [],
prelude = prel_mod }
-- failure to run the command causes exit(1) for ghc -e.
_ -> finishEvalExpr nms
--- This is the exception handler for exceptions generated by the
--- user's code; it normally just prints out the exception. The
--- handler must be recursive, in case showing the exception causes
--- more exceptions to be raised.
---
--- Bugfix: if the user closed stdout or stderr, the flushing will fail,
--- raising another exception. We therefore don't put the recursive
--- handler arond the flushing operation, so if stderr is closed
--- GHCi will just die gracefully rather than going into an infinite loop.
-handler :: Exception -> GHCi Bool
-handler exception = do
- flushInterpBuffers
- io installSignalHandlers
- ghciHandle handler (showException exception >> return False)
-
-showException (DynException dyn) =
- case fromDynamic dyn of
- Nothing -> io (putStrLn ("*** Exception: (unknown)"))
- Just Interrupted -> io (putStrLn "Interrupted.")
- Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
- Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
- Just other_ghc_ex -> io (print other_ghc_ex)
-
-showException other_exception
- = io (putStrLn ("*** Exception: " ++ show other_exception))
-
runStmt :: String -> GHCi (Maybe [Name])
runStmt stmt
| null (filter (not.isSpace) stmt) = return (Just [])
Nothing -> return ()
Just thing -> showTyThing thing
-showForUser :: SDoc -> GHCi String
-showForUser doc = do
- session <- getSession
- unqual <- io (GHC.getPrintUnqual session)
- return $! showSDocForUser unqual doc
-
specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
specialCommand str = do
c:_ -> return (Just c)
-----------------------------------------------------------------------------
--- To flush buffers for the *interpreted* computation we need
--- to refer to *its* stdout/stderr handles
-
-GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
-GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
-
-no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
- " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
-flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
-
-initInterpBuffering :: Session -> IO ()
-initInterpBuffering session
- = do maybe_hval <- GHC.compileExpr session no_buf_cmd
-
- case maybe_hval of
- Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
- other -> panic "interactiveUI:setBuffering"
-
- maybe_hval <- GHC.compileExpr session flush_cmd
- case maybe_hval of
- Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
- _ -> panic "interactiveUI:flush"
-
- turnOffBuffering -- Turn it off right now
-
- return ()
-
-
-flushInterpBuffers :: GHCi ()
-flushInterpBuffers
- = io $ do Monad.join (readIORef flush_interp)
- return ()
-
-turnOffBuffering :: IO ()
-turnOffBuffering
- = do Monad.join (readIORef turn_off_buffering)
- return ()
-
------------------------------------------------------------------------------
-- Commands
help :: String -> GHCi ()
filterOutChildren :: [Name] -> [Name]
filterOutChildren names = filter (not . parent_is_there) names
where parent_is_there n
- | Just p <- GHC.nameParent_maybe n = p `elem` names
+-- | Just p <- GHC.nameParent_maybe n = p `elem` names
+-- ToDo!!
| otherwise = False
pprInfo exts (thing, fixity, insts)
dir <- expandPath dir
io (setCurrentDirectory dir)
+editFile :: String -> GHCi ()
+editFile str
+ | null str = do
+ -- find the name of the "topmost" file loaded
+ session <- getSession
+ graph0 <- io (GHC.getModuleGraph session)
+ graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
+ let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
+ case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
+ Just file -> do_edit file
+ Nothing -> throwDyn (CmdLineError "unknown file name")
+ | otherwise = do_edit str
+ where
+ do_edit file = do
+ st <- getGHCiState
+ let cmd = editor st
+ when (null cmd) $
+ throwDyn (CmdLineError "editor not set, use :set editor")
+ io $ system (cmd ++ ' ':file)
+ return ()
+
defineMacro :: String -> GHCi ()
defineMacro s = do
let (macro_name, definition) = break isSpace s
case result of
Nothing -> io $ putStrLn "Nothing"
Just r -> io $ putStrLn (showSDoc (
- case checkedModuleInfo r of
+ case GHC.checkedModuleInfo r of
Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
let
(local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
))
setCmd str
- = case words str of
+ = case toArgs str of
("args":args) -> setArgs args
("prog":prog) -> setProg prog
- ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
+ ("prompt":prompt) -> setPrompt (after 6)
+ ("editor":cmd) -> setEditor (after 6)
wds -> setOptions wds
+ where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
setArgs args = do
st <- getGHCiState
setProg _ = do
io (hPutStrLn stderr "syntax: :set prog <progname>")
+setEditor cmd = do
+ st <- getGHCiState
+ setGHCiState st{ editor = cmd }
+
setPrompt value = do
st <- getGHCiState
if null value
completeHomeModuleOrFile=completeNone
#endif
------------------------------------------------------------------------------
--- GHCi monad
-
-data GHCiState = GHCiState
- {
- progname :: String,
- args :: [String],
- prompt :: String,
- session :: GHC.Session,
- options :: [GHCiOption],
- prelude :: Module
- }
-
-data GHCiOption
- = ShowTiming -- show time/allocs after evaluation
- | ShowType -- show the type of expressions
- | RevertCAFs -- revert CAFs after every evaluation
- deriving Eq
-
-newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
-
-startGHCi :: GHCi a -> GHCiState -> IO a
-startGHCi g state = do ref <- newIORef state; unGHCi g ref
-
-instance Monad GHCi where
- (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
- return a = GHCi $ \s -> return a
-
-ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
-ghciHandleDyn h (GHCi m) = GHCi $ \s ->
- Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
-
-getGHCiState = GHCi $ \r -> readIORef r
-setGHCiState s = GHCi $ \r -> writeIORef r s
-
--- for convenience...
-getSession = getGHCiState >>= return . session
-getPrelude = getGHCiState >>= return . prelude
-
-GLOBAL_VAR(saved_sess, no_saved_sess, Session)
-no_saved_sess = error "no saved_ses"
-saveSession = getSession >>= io . writeIORef saved_sess
-splatSavedSession = io (writeIORef saved_sess no_saved_sess)
-restoreSession = readIORef saved_sess
-
-getDynFlags = do
- s <- getSession
- io (GHC.getSessionDynFlags s)
-setDynFlags dflags = do
- s <- getSession
- io (GHC.setSessionDynFlags s dflags)
-
-isOptionSet :: GHCiOption -> GHCi Bool
-isOptionSet opt
- = do st <- getGHCiState
- return (opt `elem` options st)
-
-setOption :: GHCiOption -> GHCi ()
-setOption opt
- = do st <- getGHCiState
- setGHCiState (st{ options = opt : filter (/= opt) (options st) })
-
-unsetOption :: GHCiOption -> GHCi ()
-unsetOption opt
- = do st <- getGHCiState
- setGHCiState (st{ options = filter (/= opt) (options st) })
-
-io :: IO a -> GHCi a
-io m = GHCi { unGHCi = \s -> m >>= return }
-
------------------------------------------------------------------------------
--- recursive exception handlers
-
--- Don't forget to unblock async exceptions in the handler, or if we're
--- in an exception loop (eg. let a = error a in a) the ^C exception
--- may never be delivered. Thanks to Marcin for pointing out the bug.
-
-ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
-ghciHandle h (GHCi m) = GHCi $ \s ->
- Exception.catch (m s)
- (\e -> unGHCi (ghciUnblock (h e)) s)
-
-ghciUnblock :: GHCi a -> GHCi a
-ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
-
------------------------------------------------------------------------------
--- timing & statistics
-
-timeIt :: GHCi a -> GHCi a
-timeIt action
- = do b <- isOptionSet ShowTiming
- if not b
- then action
- else do allocs1 <- io $ getAllocations
- time1 <- io $ getCPUTime
- a <- action
- allocs2 <- io $ getAllocations
- time2 <- io $ getCPUTime
- io $ printTimes (fromIntegral (allocs2 - allocs1))
- (time2 - time1)
- return a
-
-foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
- -- defined in ghc/rts/Stats.c
-
-printTimes :: Integer -> Integer -> IO ()
-printTimes allocs psecs
- = do let secs = (fromIntegral psecs / (10^12)) :: Float
- secs_str = showFFloat (Just 2) secs
- putStrLn (showSDoc (
- parens (text (secs_str "") <+> text "secs" <> comma <+>
- text (show allocs) <+> text "bytes")))
-
------------------------------------------------------------------------------
--- reverting CAFs
-
-revertCAFs :: IO ()
-revertCAFs = do
- rts_revertCAFs
- turnOffBuffering
- -- Have to turn off buffering again, because we just
- -- reverted stdout, stderr & stdin to their defaults.
-
-foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
- -- Make it "safe", just in case
-
-- ----------------------------------------------------------------------------
-- Utils
projects / ghc-hetmet.git / blobdiff