#include "HsVersions.h"
+#if defined(GHCI) && defined(BREAKPOINT)
+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 )
+#endif
+
-- The GHC interface
import qualified GHC
import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..),
" :set <option> ... set options\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" ++
"\n" ++
" :show modules show the currently loaded modules\n" ++
" :show bindings show the current bindings made at the prompt\n" ++
" (eg. -v2, -fglasgow-exts, etc.)\n"
+#if defined(GHCI) && defined(BREAKPOINT)
+globaliseAndTidy :: Id -> Id
+globaliseAndTidy id
+-- Give the Id a Global Name, and tidy its type
+ = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
+ where
+ tidy_type = tidyTopType (idType id)
+
+
+printScopeMsg :: Session -> String -> [Id] -> IO ()
+printScopeMsg session location ids
+ = GHC.getPrintUnqual session >>= \unqual ->
+ printForUser stdout unqual $
+ text "Local bindings in scope:" $$
+ nest 2 (pprWithCommas showId ids)
+ where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
+
+jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
+jumpFunction session@(Session ref) (I# idsPtr) hValues location b
+ = unsafePerformIO $
+ do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
+ let names = map idName ids
+ ASSERT (length names == length hValues) return ()
+ printScopeMsg session location ids
+ hsc_env <- readIORef ref
+
+ let ictxt = hsc_IC hsc_env
+ global_ids = map globaliseAndTidy ids
+ rn_env = ic_rn_local_env ictxt
+ type_env = ic_type_env ictxt
+ bound_names = map idName global_ids
+ new_rn_env = extendLocalRdrEnv rn_env bound_names
+ -- Remove any shadowed bindings from the type_env;
+ -- they are inaccessible but might, I suppose, cause
+ -- a space leak if we leave them there
+ shadowed = [ n | name <- bound_names,
+ let rdr_name = mkRdrUnqual (nameOccName name),
+ Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
+ filtered_type_env = delListFromNameEnv type_env shadowed
+ new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ writeIORef ref (hsc_env { hsc_IC = new_ic })
+ withExtendedLinkEnv (zip names hValues) $
+ startGHCi (runGHCi [] Nothing)
+ GHCiState{ progname = "<interactive>",
+ args = [],
+ prompt = location++"> ",
+ session = session,
+ options = [] }
+ writeIORef ref hsc_env
+ putStrLn $ "Returning to normal execution..."
+ return b
+#endif
+
interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
interactiveUI session srcs maybe_expr = do
-
+#if defined(GHCI) && defined(BREAKPOINT)
+ initDynLinker =<< GHC.getSessionDynFlags session
+ extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))]
+#endif
-- HACK! If we happen to get into an infinite loop (eg the user
-- types 'let x=x in x' at the prompt), then the thread will block
-- on a blackhole, and become unreachable during GC. The GC will
startGHCi (runGHCi srcs maybe_expr)
GHCiState{ progname = "<interactive>",
args = [],
+ prompt = "%s> ",
session = session,
options = [] }
#endif
fileLoop :: Handle -> Bool -> GHCi ()
-fileLoop hdl prompt = do
+fileLoop hdl show_prompt = do
session <- getSession
(mod,imports) <- io (GHC.getContext session)
- when prompt (io (putStr (mkPrompt mod imports)))
+ st <- getGHCiState
+ when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
l <- io (IO.try (hGetLine hdl))
case l of
Left e | isEOFError e -> return ()
-- EOF.
Right l ->
case removeSpaces l of
- "" -> fileLoop hdl prompt
+ "" -> fileLoop hdl show_prompt
l -> do quit <- runCommand l
- if quit then return () else fileLoop hdl prompt
+ if quit then return () else fileLoop hdl show_prompt
stringLoop :: [String] -> GHCi ()
stringLoop [] = return ()
l -> do quit <- runCommand l
if quit then return () else stringLoop ss
-mkPrompt toplevs exports
- = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
- <+> hsep (map pprModule exports)
- <> text "> ")
+mkPrompt toplevs exports prompt
+ = showSDoc $ f prompt
+ where
+ f ('%':'s':xs) = perc_s <> f xs
+ f ('%':'%':xs) = char '%' <> f xs
+ f (x:xs) = char x <> f xs
+ f [] = empty
+
+ perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+>
+ hsep (map pprModule exports)
+
#ifdef USE_READLINE
readlineLoop :: GHCi ()
(mod,imports) <- io (GHC.getContext session)
io yield
saveSession -- for use by completion
- l <- io (readline (mkPrompt mod imports)
+ st <- getGHCiState
+ l <- io (readline (mkPrompt mod imports (prompt st))
`finally` setNonBlockingFD 0)
-- readline sometimes puts stdin into blocking mode,
-- so we need to put it back for the IO library
graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
setContextAfterLoad session graph'
modulesLoadedMsg ok (map GHC.ms_mod graph')
+#if defined(GHCI) && defined(BREAKPOINT)
+ io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))])
+#endif
setContextAfterLoad session [] = do
io (GHC.setContext session [] [prelude_mod])
= case words str of
("args":args) -> setArgs args
("prog":prog) -> setProg prog
+ ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
wds -> setOptions wds
setArgs args = do
setProg _ = do
io (hPutStrLn stderr "syntax: :set prog <progname>")
+setPrompt value = do
+ st <- getGHCiState
+ if null value
+ then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
+ else setGHCiState st{ prompt = remQuotes value }
+ where
+ remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
+ remQuotes x = x
+
setOptions wds =
do -- first, deal with the GHCi opts (+s, +t, etc.)
let (plus_opts, minus_opts) = partition isPlus wds
-- -----------------------------------------------------------------------------
-- Completion
+completeNone :: String -> IO [String]
+completeNone w = return []
+
#ifdef USE_READLINE
completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
completeWord w start end = do
_other
| Just c <- is_cmd line -> do
maybe_cmd <- lookupCommand c
- let (n,w') = selectWord 0 (words line)
+ let (n,w') = selectWord (words' 0 line)
case maybe_cmd of
Nothing -> return Nothing
Just (_,_,False,complete) -> wrapCompleter complete w
| otherwise -> do
--printf "complete %s, start = %d, end = %d\n" w start end
wrapCompleter completeIdentifier w
- where selectWord _ [] = (0,w)
- selectWord n (x:xs)
- | n+length x >= start = (start-n-1,take (end-n+1) x)
- | otherwise = selectWord (n+length x) xs
+ where words' _ [] = []
+ words' n str = let (w,r) = break isSpace str
+ (s,r') = span isSpace r
+ in (n,w):words' (n+length w+length s) r'
+ -- In a Haskell expression we want to parse 'a-b' as three words
+ -- where a compiler flag (ie. -fno-monomorphism-restriction) should
+ -- only be a single word.
+ selectWord [] = (0,w)
+ selectWord ((offset,x):xs)
+ | offset+length x >= start = (start-offset,take (end-offset) x)
+ | otherwise = selectWord xs
is_cmd line
| ((':':w) : _) <- words (dropWhile isSpace line) = Just w
| otherwise = Nothing
-completeNone w = return []
-
completeCmd w = do
cmds <- readIORef commands
return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
= map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
where
pkg_db = pkgIdMap (pkgState dflags)
+#else
+completeCmd = completeNone
+completeMacro = completeNone
+completeIdentifier = completeNone
+completeModule = completeNone
+completeHomeModule = completeNone
+completeSetOptions = completeNone
+completeFilename = completeNone
+completeHomeModuleOrFile=completeNone
#endif
-----------------------------------------------------------------------------
{
progname :: String,
args :: [String],
+ prompt :: String,
session :: GHC.Session,
options :: [GHCiOption]
}
projects / ghc-hetmet.git / blobdiff