leksah-0.8: src/IDE/Debug.hs
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
{-# OPTIONS_GHC -XScopedTypeVariables #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Debug
-- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken
-- License : GNU-GPL
--
-- Maintainer : <maintainer at leksah.org>
-- Stability : provisional
-- Portability : portable
--
--
-- | The debug methods of ide.
--
---------------------------------------------------------------------------------
module IDE.Debug (
executeDebugCommand
, debugCommand
, debugCommand'
, debugQuit
, debugExecuteSelection
, debugExecuteAndShowSelection
, debugSetBreakpoint
, debugDeleteAllBreakpoints
, debugDeleteBreakpoint
, debugContinue
, debugAbandon
, debugStop
, debugStep
, debugStepExpression
, debugStepExpr
, debugStepLocal
, debugStepModule
, debugTrace
, debugTraceExpression
, debugTraceExpr
, debugHistory
, debugBack
, debugForward
, debugForce
, debugPrint
, debugSimplePrint
, debugShowBindings
, debugShowBreakpoints
, debugShowContext
, debugShowModules
, debugShowPackages
, debugShowLanguages
, debugInformation
, debugKind
, debugType
, interactiveFlags
, debugSetPrintEvldWithShow
, debugSetBreakOnException
, debugSetBreakOnError
, debugSetPrintBindResult
) where
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
-- import System.Process (getProcessExitCode, ProcessHandle(..))
-- import Data.Maybe (isNothing)
import GHC.ConsoleHandler (Handler(..), installHandler)
import System.Win32
(-- th32SnapEnumProcesses,
DWORD(..),
cTRL_BREAK_EVENT,
generateConsoleCtrlEvent)
-- tH32CS_SNAPPROCESS,
-- withTh32Snap)
import System.Process.Internals
(withProcessHandle, ProcessHandle__(..))
import Control.Concurrent.MVar (tryTakeMVar)
#else
import System.Posix
(sigINT,
installHandler,
signalProcessGroup,
getProcessGroupID)
import System.Posix.Signals (Handler(..))
#endif
import Control.Monad.Reader
import IDE.Core.State
import IDE.Utils.Tool
import IDE.LogRef
import Control.Exception (SomeException(..))
import IDE.Pane.SourceBuffer
(selectedLocation, selectedText, selectedModuleName,
insertTextAfterSelection, selectedTextOrCurrentLine)
import IDE.Metainfo.Provider (getActivePackageDescr)
import Distribution.Text (display)
import IDE.Pane.Log (appendLog)
import Data.List (isSuffixOf)
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
foreign import stdcall unsafe "winbase.h GetCurrentProcessId"
c_GetCurrentProcessId :: IO DWORD
foreign import stdcall unsafe "winbase.h GetProcessId"
c_GetProcessId :: DWORD -> IO DWORD
#endif
executeDebugCommand :: String -> ([ToolOutput] -> IDEAction) -> IDEAction
executeDebugCommand command handler = do
maybeGhci <- readIDE ghciState
case maybeGhci of
Just ghci -> do
triggerEventIDE (StatusbarChanged [CompartmentState command, CompartmentBuild True])
reifyIDE $ \ideR -> do
executeGhciCommand ghci command $ \output ->
reflectIDE (do
handler output
triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])
return ()
) ideR
_ -> sysMessage Normal "Debugger not running"
debugCommand :: String -> ([ToolOutput] -> IDEAction) -> IDEAction
debugCommand command handler = debugCommand' command
(\to -> do
handler to
triggerEventIDE VariablesChanged
return ())
-- | Comment3
debugCommand' :: String -> ([ToolOutput] -> IDEAction) -> IDEAction
debugCommand' command handler = do
ideR <- ask
catchIDE (executeDebugCommand command handler)
(\(e :: SomeException) -> putStrLn (show e))
debugQuit :: IDEAction
debugQuit = debugCommand ":quit" logOutput
debugExecuteSelection :: IDEAction
debugExecuteSelection = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> do
debugSetLiberalScope
debugCommand text logOutput
Nothing -> ideMessage Normal "Please select some text in the editor to execute"
debugExecuteAndShowSelection :: IDEAction
debugExecuteAndShowSelection = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> do
debugSetLiberalScope
debugCommand text (\to -> do
insertTextAfterSelection $ " " ++ buildOutputString to
logOutput to)
Nothing -> ideMessage Normal "Please select some text in the editor to execute"
where
buildOutputString :: [ToolOutput] -> String
buildOutputString (ToolOutput str:[]) = str
buildOutputString (ToolOutput str:r) = str ++ "\n" ++ (buildOutputString r)
buildOutputString (_:r) = buildOutputString r
buildOutputString [] = ""
debugSetLiberalScope :: IDEAction
debugSetLiberalScope = do
maybeModuleName <- selectedModuleName
case maybeModuleName of
Just moduleName -> do
debugCommand (":module *" ++ moduleName) (\ _ -> return ())
Nothing -> do
mbPackage <- getActivePackageDescr
case mbPackage of
Nothing -> return ()
Just p -> let packageNames = map (display . modu . mdModuleId) (pdModules p)
in debugCommand' (foldl (\a b -> a ++ " *" ++ b) ":module + " packageNames)
(\ _ -> return ())
debugAbandon :: IDEAction
debugAbandon = debugCommand ":abandon" logOutput
debugBack :: IDEAction
debugBack = do
currentHist' <- readIDE currentHist
rootPath <- activeProjectDir
modifyIDE_ (\ide -> ide{currentHist = min (currentHist' - 1) 0})
debugCommand ":back" (logOutputForHistoricContext rootPath)
debugForward :: IDEAction
debugForward = do
currentHist' <- readIDE currentHist
rootPath <- activeProjectDir
modifyIDE_ (\ide -> ide{currentHist = currentHist' + 1})
debugCommand ":forward" (logOutputForHistoricContext rootPath)
debugStop :: IDEAction
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
debugStop = do
maybeGhci <- readIDE ghciState
case maybeGhci of
Just ghci -> do
liftIO $ do
maybeProcess <- tryTakeMVar (toolProcess ghci)
processGroupId <- case maybeProcess of
Just h -> do
withProcessHandle h (\h2 -> do
case h2 of
OpenHandle oh -> do
pid <- c_GetProcessId oh
return (h2, pid)
_ -> return (h2, 0))
_ -> return 0
old <- installHandler Ignore
putStrLn $ show processGroupId
generateConsoleCtrlEvent cTRL_BREAK_EVENT processGroupId
installHandler old
return ()
Nothing -> return ()
#else
debugStop = do
maybeGhci <- readIDE ghciState
case maybeGhci of
Just ghci -> liftIO $ do
group <- getProcessGroupID
old_int <- installHandler sigINT Ignore Nothing
signalProcessGroup sigINT group
installHandler sigINT old_int Nothing
return ()
Nothing -> return ()
#endif
debugContinue :: IDEAction
debugContinue = do
rootPath <- activeProjectDir
debugCommand ":continue" (logOutputForLiveContext rootPath)
debugDeleteAllBreakpoints :: IDEAction
debugDeleteAllBreakpoints = do
debugCommand ":delete *" $ \output -> do
logOutput output
setBreakpointList []
debugDeleteBreakpoint :: String -> LogRef -> IDEAction
debugDeleteBreakpoint indexString lr = do
debugCommand (":delete " ++ indexString) $ \output -> do
logOutput output
bl <- readIDE breakpointRefs
setBreakpointList $ filter (/= lr) bl
ideR <- ask
return ()
debugForce :: IDEAction
debugForce = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> debugCommand (":force " ++ text) logOutput
Nothing -> ideMessage Normal "Please select an expression in the editor"
debugHistory :: IDEAction
debugHistory = debugCommand ":history" logOutput
debugPrint :: IDEAction
debugPrint = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> debugCommand (":print " ++ text) logOutput
Nothing -> ideMessage Normal "Please select an name in the editor"
debugSimplePrint :: IDEAction
debugSimplePrint = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> debugCommand (":force " ++ text) logOutput
Nothing -> ideMessage Normal "Please select an name in the editor"
debugStep :: IDEAction
debugStep = do
rootPath <- activeProjectDir
debugSetLiberalScope
debugCommand ":step" (logOutputForLiveContext rootPath)
debugStepExpression :: IDEAction
debugStepExpression = do
maybeText <- selectedTextOrCurrentLine
debugSetLiberalScope
debugStepExpr maybeText
debugStepExpr :: Maybe String -> IDEAction
debugStepExpr maybeText = do
rootPath <- activeProjectDir
case maybeText of
Just text -> debugCommand (":step " ++ text) (logOutputForLiveContext rootPath)
Nothing -> ideMessage Normal "Please select an expression in the editor"
debugStepLocal :: IDEAction
debugStepLocal = do
rootPath <- activeProjectDir
debugCommand ":steplocal" (logOutputForLiveContext rootPath)
debugStepModule :: IDEAction
debugStepModule = do
rootPath <- activeProjectDir
debugCommand ":stepmodule" (logOutputForLiveContext rootPath)
debugTrace :: IDEAction
debugTrace = do
rootPath <- activeProjectDir
debugCommand ":trace" (\to -> do
logOutputForLiveContext rootPath to
triggerEventIDE TraceChanged
return ())
debugTraceExpression :: IDEAction
debugTraceExpression = do
maybeText <- selectedTextOrCurrentLine
debugSetLiberalScope
debugTraceExpr maybeText
debugTraceExpr :: Maybe String -> IDEAction
debugTraceExpr maybeText =
case maybeText of
Just text -> debugCommand (":trace " ++ text) (\to -> do
rootPath <- activeProjectDir
logOutputForLiveContext rootPath to
triggerEventIDE TraceChanged
return ())
Nothing -> ideMessage Normal "Please select an expression in the editor"
debugShowBindings :: IDEAction
debugShowBindings = debugCommand ":show bindings" logOutput
debugShowBreakpoints :: IDEAction
debugShowBreakpoints = do
rootPath <- activeProjectDir
debugCommand ":show breaks" (logOutputForBreakpoints rootPath)
debugShowContext :: IDEAction
debugShowContext = do
rootPath <- activeProjectDir
debugCommand ":show context" (logOutputForLiveContext rootPath)
debugShowModules :: IDEAction
debugShowModules = debugCommand ":show modules" $
logOutputLines_ $ \log output -> liftIO $ do
case output of
ToolInput line -> appendLog log (line ++ "\n") InputTag
ToolOutput line | ", interpreted )" `isSuffixOf` line
-> appendLog log (line ++ "\n") LogTag
ToolOutput line -> appendLog log (line ++ "\n") InfoTag
ToolError line -> appendLog log (line ++ "\n") ErrorTag
ToolExit _ -> appendLog log "X--X--X ghci process exited unexpectedly X--X--X" FrameTag
return ()
debugShowPackages :: IDEAction
debugShowPackages = debugCommand ":show packages" logOutput
debugShowLanguages :: IDEAction
debugShowLanguages = debugCommand ":show languages" logOutput
debugInformation :: IDEAction
debugInformation = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> do
debugSetLiberalScope
debugCommand (":info "++text) logOutput
Nothing -> ideMessage Normal "Please select a name in the editor"
debugKind :: IDEAction
debugKind = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> do
debugSetLiberalScope
debugCommand (":kind "++text) logOutput
Nothing -> ideMessage Normal "Please select a type in the editor"
debugType :: IDEAction
debugType = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> do
debugSetLiberalScope
debugCommand (":type "++text) logOutput
Nothing -> ideMessage Normal "Please select an expression in the editor"
debugSetBreakpoint :: IDEAction
debugSetBreakpoint = do
rootPath <- activeProjectDir
maybeModuleName <- selectedModuleName
case maybeModuleName of
Just moduleName -> do
-- ### debugCommand (":add *"++moduleName) $ logOutputForBuild True
maybeText <- selectedText
case maybeText of
Just text -> do
debugCommand (":module *" ++ moduleName) logOutput
debugCommand (":break " ++ text) (logOutputForSetBreakpoint rootPath)
Nothing -> do
maybeLocation <- selectedLocation
case maybeLocation of
Just (line, lineOffset) ->
debugCommand (":break " ++ moduleName ++ " " ++ (show (line+1)) ++ " " ++
(show lineOffset)) (logOutputForSetBreakpoint rootPath)
Nothing -> ideMessage Normal "Unknown error setting breakpoint"
ref <- ask
return ()
Nothing -> ideMessage Normal "Please select module file in the editor"
interactiveFlag :: String -> Bool -> String
interactiveFlag name f = (if f then "-f" else "-fno-") ++ name
printEvldWithShowFlag :: Bool -> String
printEvldWithShowFlag = interactiveFlag "print-evld-with-show"
breakOnExceptionFlag :: Bool -> String
breakOnExceptionFlag = interactiveFlag "break-on-exception"
breakOnErrorFlag :: Bool -> String
breakOnErrorFlag = interactiveFlag "break-on-error"
printBindResultFlag :: Bool -> String
printBindResultFlag = interactiveFlag "print-bind-result"
interactiveFlags :: Prefs -> [String]
interactiveFlags prefs =
(printEvldWithShowFlag $ printEvldWithShow prefs)
: (breakOnExceptionFlag $ breakOnException prefs)
: (breakOnErrorFlag $ breakOnError prefs)
: [printBindResultFlag $ printBindResult prefs]
debugSet :: (Bool -> String) -> Bool -> IDEAction
debugSet flag value = do
debugCommand (":set "++(flag value)) logOutput
debugSetPrintEvldWithShow :: Bool -> IDEAction
debugSetPrintEvldWithShow = debugSet printEvldWithShowFlag
debugSetBreakOnException :: Bool -> IDEAction
debugSetBreakOnException = debugSet breakOnExceptionFlag
debugSetBreakOnError :: Bool -> IDEAction
debugSetBreakOnError = debugSet breakOnErrorFlag
debugSetPrintBindResult :: Bool -> IDEAction
debugSetPrintBindResult = debugSet printBindResultFlag