("cd", keepGoing changeDirectory, False, completeFilename),
("check", keepGoing checkModule, False, completeHomeModule),
("continue", keepGoing continueCmd, False, completeNone),
+ ("cmd", keepGoing cmdCmd, False, completeIdentifier),
("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
("delete", keepGoing deleteCmd, False, completeNone),
("type", keepGoing typeOfExpr, False, completeIdentifier),
("trace", keepGoing traceCmd, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
- ("unset", keepGoing unsetOptions, True, completeSetOptions),
- ("where", keepGoing whereCmd, True, completeNone)
+ ("unset", keepGoing unsetOptions, True, completeSetOptions)
]
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
" :add <filename> ... add module(s) to the current target set\n" ++
" :browse [*]<module> display the names defined by <module>\n" ++
" :cd <dir> change directory to <dir>\n" ++
+ " :cmd <expr> run the commands returned by <expr>::IO String"++
" :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
" :def <cmd> <expr> define a command :<cmd>\n" ++
" :edit <file> edit file\n" ++
" :forward go forward in the history (after :back)\n" ++
" :history [<n>] show the last <n> items in the history (after :trace)\n" ++
" :print [<name> ...] prints a value without forcing its computation\n" ++
+ " :sprint [<name> ...] simplifed version of :print\n" ++
" :step single-step after stopping at a breakpoint\n"++
" :step <expr> single-step into <expr>\n"++
" :trace trace after stopping at a breakpoint\n"++
" :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
- " :sprint [<name> ...] simplifed version of :print\n" ++
"\n" ++
" -- Commands for changing settings:\n" ++
prelude = prel_mod,
break_ctr = 0,
breaks = [],
- tickarrays = emptyModuleEnv
+ tickarrays = emptyModuleEnv,
+ cmdqueue = []
}
#ifdef USE_READLINE
Right l ->
case removeSpaces l of
"" -> fileLoop hdl show_prompt
- l -> do quit <- runCommand l
+ l -> do quit <- runCommands l
if quit then return () else fileLoop hdl show_prompt
-stringLoop :: [String] -> GHCi Bool{-True: we quit-}
-stringLoop [] = return False
-stringLoop (s:ss) = do
- case removeSpaces s of
- "" -> stringLoop ss
- l -> do quit <- runCommand l
- if quit then return True else stringLoop ss
-
mkPrompt = do
session <- getSession
(toplevs,exports) <- io (GHC.getContext session)
"" -> readlineLoop
l -> do
io (addHistory l)
- quit <- runCommand l
+ quit <- runCommands l
if quit then return () else readlineLoop
#endif
-runCommand :: String -> GHCi Bool
-runCommand c = ghciHandle handler (doCommand c)
- where
- doCommand (':' : command) = specialCommand command
- doCommand stmt
- = do timeIt $ runStmt stmt GHC.RunToCompletion
- return False
+runCommands :: String -> GHCi Bool
+runCommands cmd = do
+ q <- ghciHandle handler (doCommand cmd)
+ if q then return True else runNext
+ where
+ runNext = do
+ st <- getGHCiState
+ case cmdqueue st of
+ [] -> return False
+ c:cs -> do setGHCiState st{ cmdqueue = cs }
+ runCommands c
+
+ doCommand (':' : cmd) = specialCommand cmd
+ doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
+ return False
+
+enqueueCommands :: [String] -> GHCi ()
+enqueueCommands cmds = do
+ st <- getGHCiState
+ setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
+
-- This version is for the GHC command-line option -e. The only difference
-- from runCommand is that it catches the ExitException exception and
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
| null (filter (not.isSpace) stmt) = return False
+ | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
| otherwise
= do st <- getGHCiState
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt step
afterRunStmt result
- return (isRunResultOk result)
-afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
+afterRunStmt :: GHC.RunResult -> GHCi Bool
+ -- False <=> the statement failed to compile
+afterRunStmt (GHC.RunException e) = throw e
afterRunStmt run_result = do
- mb_result <- switchOnRunResult run_result
- -- possibly print the type and revert CAFs after evaluating an expression
- show_types <- isOptionSet ShowType
session <- getSession
- case mb_result of
- Nothing -> return ()
- Just (is_break,names) ->
- when (is_break || show_types) $
- mapM_ (showTypeOfName session) names
-
+ case run_result of
+ GHC.RunOk names -> do
+ show_types <- isOptionSet ShowType
+ when show_types $ mapM_ (showTypeOfName session) names
+ GHC.RunBreak _ names mb_info -> do
+ resumes <- io $ GHC.getResumeContext session
+ printForUser $ ptext SLIT("Stopped at") <+>
+ ppr (GHC.resumeSpan (head resumes))
+ mapM_ (showTypeOfName session) names
+ maybe (return ()) runBreakCmd mb_info
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+ return ()
+ _ -> return ()
+
flushInterpBuffers
io installSignalHandlers
b <- isOptionSet RevertCAFs
io (when b revertCAFs)
- return mb_result
-
-
-switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
-switchOnRunResult GHC.RunFailed = return Nothing
-switchOnRunResult (GHC.RunException e) = throw e
-switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
-switchOnRunResult (GHC.RunBreak threadId names info) = do
- session <- getSession
- Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
- let modBreaks = GHC.modInfoModBreaks mod_info
- let ticks = GHC.modBreaks_locs modBreaks
-
- -- display information about the breakpoint
- let location = ticks ! GHC.breakInfo_number info
- printForUser $ ptext SLIT("Stopped at") <+> ppr location
-
- -- run the command set with ":set stop <cmd>"
- st <- getGHCiState
- runCommand (stop st)
-
- return (Just (True,names))
-
-
-isRunResultOk :: GHC.RunResult -> Bool
-isRunResultOk (GHC.RunOk _) = True
-isRunResultOk _ = False
+ return (case run_result of GHC.RunOk _ -> True; _ -> False)
+runBreakCmd :: GHC.BreakInfo -> GHCi ()
+runBreakCmd info = do
+ let mod = GHC.breakInfo_module info
+ nm = GHC.breakInfo_number info
+ st <- getGHCiState
+ case [ loc | (i,loc) <- breaks st,
+ breakModule loc == mod, breakTick loc == nm ] of
+ [] -> return ()
+ loc:_ | null cmd -> return ()
+ | otherwise -> do enqueueCommands [cmd]; return ()
+ where cmd = onBreakCmd loc
showTypeOfName :: Session -> Name -> GHCi ()
showTypeOfName session n
runMain :: String -> GHCi ()
runMain args = do
let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
- runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
- return ()
+ enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
addModule :: [FilePath] -> GHCi ()
addModule files = do
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
runMacro fun s = do
str <- io ((unsafeCoerce# fun :: String -> IO String) s)
- stringLoop (lines str)
+ enqueueCommands (lines str)
+ return False
undefineMacro :: String -> GHCi ()
undefineMacro macro_name = do
else do
io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
+cmdCmd :: String -> GHCi ()
+cmdCmd str = do
+ let expr = '(' : str ++ ") :: IO String"
+ session <- getSession
+ maybe_hv <- io (GHC.compileExpr session expr)
+ case maybe_hv of
+ Nothing -> return ()
+ Just hv -> do
+ cmds <- io $ (unsafeCoerce# hv :: IO String)
+ enqueueCommands (lines cmds)
+ return ()
loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
loadModule fs = timeIt (loadModule' fs)
st <- getGHCiState
setGHCiState st{ editor = cmd }
+setStop str@(c:_) | isDigit c
+ = do let (nm_str,rest) = break (not.isDigit) str
+ nm = read nm_str
+ st <- getGHCiState
+ let old_breaks = breaks st
+ if all ((/= nm) . fst) old_breaks
+ then printForUser (text "Breakpoint" <+> ppr nm <+>
+ text "does not exist")
+ else do
+ let new_breaks = map fn old_breaks
+ fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
+ | otherwise = (i,loc)
+ setGHCiState st{ breaks = new_breaks }
setStop cmd = do
st <- getGHCiState
setGHCiState st{ stop = cmd }
mapM_ (showTypeOfName s) names
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
- runCommand (stop st)
- return ()
+ enqueueCommands [stop st]
forwardCmd :: String -> GHCi ()
forwardCmd = noArgs $ do
mapM_ (showTypeOfName s) names
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
- runCommand (stop st)
- return ()
+ enqueueCommands [stop st]
-- handle the "break" command
breakCmd :: String -> GHCi ()
io $ putStrLn "Perhaps no modules are loaded for debugging?"
| otherwise = do -- try parsing it as an identifier
wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
- let loc = GHC.nameSrcLoc name
+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
if GHC.isGoodSrcLoc loc
then findBreakAndSet (GHC.nameModule name) $
findBreakByCoord (Just (GHC.srcLocFile loc))
{ breakModule = mod
, breakLoc = span
, breakTick = tick
+ , onBreakCmd = ""
}
printForUser $
text "Breakpoint " <> ppr nm <>
findBreakByCoord mb_file (line, col) arr
| not (inRange (bounds arr) line) = Nothing
| otherwise =
- listToMaybe (sortBy rightmost contains)
+ listToMaybe (sortBy rightmost contains) `mplus`
+ listToMaybe (sortBy leftmost_smallest after_here)
where
ticks = arr ! line
| Just f <- mb_file = GHC.srcSpanFile span == f
| otherwise = True
+ after_here = [ tick | tick@(nm,span) <- ticks,
+ GHC.srcSpanStartLine span == line,
+ GHC.srcSpanStartCol span >= col ]
+
leftmost_smallest (_,a) (_,b) = a `compare` b
leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
+-- for now, use ANSI bold on Unixy systems. On Windows, we add a line
+-- of carets under the active expression instead. The Windows console
+-- doesn't support ANSI escape sequences, and most Unix terminals
+-- (including xterm) do, so this is a reasonable guess until we have a
+-- proper termcap/terminfo library.
+#if !defined(mingw32_TARGET_OS)
+do_bold = True
+#else
+do_bold = False
+#endif
+
start_bold = BS.pack "\ESC[1m"
end_bold = BS.pack "\ESC[0m"
mb_span <- getCurrentBreakSpan
case mb_span of
Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
- Just span -> io $ listAround span True
+ Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
+ | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
listCmd str = list2 (words str)
list2 [arg] | all isDigit arg = do
listModuleLine mod (read arg2)
list2 [arg] = do
wantNameFromInterpretedModule noCanDo arg $ \name -> do
- let loc = GHC.nameSrcLoc name
+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
if GHC.isGoodSrcLoc loc
then do
tickArray <- getTickArray (GHC.nameModule name)
| otherwise = 1
pad_after = 1
- highlight no line
+ highlight | do_bold = highlight_bold
+ | otherwise = highlight_carets
+
+ highlight_bold no line
| no == line1 && no == line2
= let (a,r) = BS.splitAt col1 line
(b,c) = BS.splitAt (col2-col1) r
BS.concat [a, end_bold, b]
| otherwise = line
+ highlight_carets no line
+ | no == line1 && no == line2
+ = BS.concat [line, nl, indent, BS.replicate col1 ' ',
+ BS.replicate (col2-col1) '^']
+ | no == line1
+ = BS.concat [line, nl, indent, BS.replicate col1 ' ',
+ BS.replicate (BS.length line-col1) '^']
+ | no == line2
+ = BS.concat [line, nl, indent, BS.replicate col2 '^']
+ | otherwise = line
+ where
+ indent = BS.pack " "
+ nl = BS.singleton '\n'
+
-- --------------------------------------------------------------------------
-- Tick arrays
projects / ghc-hetmet.git / blobdiff