module IDE.Debug (
debugCommand
, debugCommand'
, debugToggled
, 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
, debugSetPrintEvldWithShow
, debugSetBreakOnException
, debugSetBreakOnError
, debugSetPrintBindResult
) where
import IDE.Core.State
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
import Data.List (stripPrefix, isSuffixOf)
import IDE.Utils.GUIUtils (getDebugToggled)
import IDE.Package (debugStart, executeDebugCommand, tryDebug, printBindResultFlag,
breakOnErrorFlag, breakOnExceptionFlag, printEvldWithShowFlag)
import IDE.Utils.Tool (ToolOutput(..), toolProcess, interruptProcessGroupOf)
import IDE.Workspaces (packageTry)
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ask)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Applicative (Alternative(..), (<$>), (<*>))
import Data.IORef (newIORef)
import Data.Monoid ((<>), Monoid(..))
import Data.Text (Text)
import qualified Data.Text as T
(pack, lines, stripPrefix, unlines, isSuffixOf, unpack)
import System.Exit (ExitCode(..))
import IDE.Pane.WebKit.Output (loadOutputUri)
sinkLast = CL.fold (\_ a -> Just a) Nothing
debugCommand :: Text -> C.Sink ToolOutput IDEM () -> DebugAction
debugCommand command handler = do
debugCommand' command handler
lift $ triggerEventIDE VariablesChanged
return ()
debugCommand' :: Text -> C.Sink ToolOutput IDEM () -> DebugAction
debugCommand' command handler = do
ghci <- ask
lift $ catchIDE (runDebug (executeDebugCommand command handler) ghci)
(\(e :: SomeException) -> (print e))
debugToggled :: IDEAction
debugToggled = do
toggled <- getDebugToggled
maybeDebug <- readIDE debugState
case (toggled, maybeDebug) of
(True, Nothing) -> packageTry debugStart
(False, Just _) -> debugQuit
_ -> return ()
debugQuit :: IDEAction
debugQuit = do
maybeDebug <- readIDE debugState
case maybeDebug of
Just debug -> runDebug (debugCommand ":quit" logOutputDefault) debug
_ -> return ()
stripComments :: Text -> Text
stripComments t = maybe t T.unlines $
mapM (T.stripPrefix "-- >>>") lines'
<|> mapM (T.stripPrefix "-- >") lines'
where
lines' = T.lines t
debugExecuteSelection :: IDEAction
debugExecuteSelection = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> do
let command = packageTry $ tryDebug $ do
debugSetLiberalScope
buffer <- liftIO $ newIORef mempty
debugCommand (stripComments text) $ do
_ <- C.getZipSink $ const
<$> C.ZipSink sinkLast
<*> C.ZipSink (logOutputPane text buffer)
mbURI <- lift $ readIDE autoURI
case mbURI of
Just uri -> lift . postSyncIDE . loadOutputUri $ T.unpack uri
Nothing -> return ()
modifyIDE_ $ \ide -> ide {autoCommand = command, autoURI = Nothing}
command
Nothing -> ideMessage Normal "Please select some text in the editor to execute"
debugExecuteAndShowSelection :: IDEAction
debugExecuteAndShowSelection = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> packageTry $ tryDebug $ do
debugSetLiberalScope
debugCommand (stripComments text) $ do
out <- C.getZipSink $ const
<$> C.ZipSink (CL.fold buildOutputString "")
<*> C.ZipSink logOutputDefault
lift . insertTextAfterSelection $ " " <> out
Nothing -> ideMessage Normal "Please select some text in the editor to execute"
where
buildOutputString :: Text -> ToolOutput -> Text
buildOutputString "" (ToolOutput str) = str
buildOutputString s (ToolOutput str) = s <> "\n" <> str
buildOutputString s _ = s
debugSetLiberalScope :: DebugAction
debugSetLiberalScope = do
maybeModuleName <- lift selectedModuleName
case maybeModuleName of
Just moduleName ->
debugCommand (":module *" <> moduleName) CL.sinkNull
Nothing -> do
mbPackage <- lift getActivePackageDescr
case mbPackage of
Nothing -> return ()
Just p -> let packageNames = map (T.pack . display . modu . mdModuleId) (pdModules p)
in debugCommand' (foldl (\a b -> a <> " *" <> b) ":module + " packageNames)
CL.sinkNull
debugAbandon :: IDEAction
debugAbandon =
packageTry $ tryDebug $ debugCommand ":abandon" logOutputDefault
debugBack :: IDEAction
debugBack = packageTry $ do
currentHist' <- lift $ readIDE currentHist
liftIDE $ modifyIDE_ (\ide -> ide{currentHist = min (currentHist' 1) 0})
tryDebug $ do
(debugPackage, _) <- ask
debugCommand ":back" (logOutputForHistoricContextDefault debugPackage)
debugForward :: IDEAction
debugForward = packageTry $ do
currentHist' <- lift $ readIDE currentHist
liftIDE $ modifyIDE_ (\ide -> ide{currentHist = currentHist' + 1})
tryDebug $ do
(debugPackage, _) <- ask
debugCommand ":forward" (logOutputForHistoricContextDefault debugPackage)
debugStop :: IDEAction
debugStop = do
maybeDebug <- readIDE debugState
liftIO $ case maybeDebug of
Just (_, ghci) -> toolProcess ghci >>= interruptProcessGroupOf
Nothing -> return ()
debugContinue :: IDEAction
debugContinue = packageTry $ tryDebug $ do
(debugPackage, _) <- ask
debugCommand ":continue" (logOutputForHistoricContextDefault debugPackage)
debugDeleteAllBreakpoints :: IDEAction
debugDeleteAllBreakpoints = do
packageTry $ tryDebug $ debugCommand ":delete *" logOutputDefault
setBreakpointList []
debugDeleteBreakpoint :: Text -> LogRef -> IDEAction
debugDeleteBreakpoint indexString lr = do
packageTry $ tryDebug $ debugCommand (":delete " <> indexString) logOutputDefault
bl <- readIDE breakpointRefs
setBreakpointList $ filter (/= lr) bl
ideR <- ask
return ()
debugForce :: IDEAction
debugForce = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> packageTry $ tryDebug $ debugCommand (":force " <> stripComments text) logOutputDefault
Nothing -> ideMessage Normal "Please select an expression in the editor"
debugHistory :: IDEAction
debugHistory = packageTry $ tryDebug $ debugCommand ":history" logOutputDefault
debugPrint :: IDEAction
debugPrint = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> packageTry $ tryDebug $ debugCommand (":print " <> stripComments text) logOutputDefault
Nothing -> ideMessage Normal "Please select an name in the editor"
debugSimplePrint :: IDEAction
debugSimplePrint = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> packageTry $ tryDebug $ debugCommand (":force " <> stripComments text) logOutputDefault
Nothing -> ideMessage Normal "Please select an name in the editor"
debugStep :: IDEAction
debugStep = packageTry $ tryDebug $ do
(debugPackage, _) <- ask
debugSetLiberalScope
debugCommand ":step" (logOutputForHistoricContextDefault debugPackage)
debugStepExpression :: IDEAction
debugStepExpression = do
maybeText <- selectedTextOrCurrentLine
packageTry $ tryDebug $ do
debugSetLiberalScope
debugStepExpr maybeText
debugStepExpr :: Maybe Text -> DebugAction
debugStepExpr maybeText = do
(debugPackage, _) <- ask
case maybeText of
Just text -> debugCommand (":step " <> stripComments text) (logOutputForHistoricContextDefault debugPackage)
Nothing -> lift $ ideMessage Normal "Please select an expression in the editor"
debugStepLocal :: IDEAction
debugStepLocal = packageTry $ tryDebug $ do
(debugPackage, _) <- ask
debugCommand ":steplocal" (logOutputForHistoricContextDefault debugPackage)
debugStepModule :: IDEAction
debugStepModule = packageTry $ tryDebug $ do
(debugPackage, _) <- ask
debugCommand ":stepmodule" (logOutputForHistoricContextDefault debugPackage)
logTraceOutput debugPackage = do
logOutputForLiveContextDefault debugPackage
lift $ triggerEventIDE TraceChanged
return ()
debugTrace :: IDEAction
debugTrace = packageTry $ tryDebug $ do
(debugPackage, _) <- ask
debugCommand ":trace" $ logTraceOutput debugPackage
debugTraceExpression :: IDEAction
debugTraceExpression = do
maybeText <- selectedTextOrCurrentLine
packageTry $ tryDebug $ do
debugSetLiberalScope
debugTraceExpr maybeText
debugTraceExpr :: Maybe Text -> DebugAction
debugTraceExpr maybeText = do
(debugPackage, _) <- ask
case maybeText of
Just text -> debugCommand (":trace " <> stripComments text) $ logTraceOutput debugPackage
Nothing -> lift $ ideMessage Normal "Please select an expression in the editor"
debugShowBindings :: IDEAction
debugShowBindings = packageTry $ tryDebug $ debugCommand ":show bindings" logOutputDefault
debugShowBreakpoints :: IDEAction
debugShowBreakpoints = packageTry $ tryDebug $ do
(debugPackage, _) <- ask
debugCommand ":show breaks" (logOutputForSetBreakpointDefault debugPackage)
debugShowContext :: IDEAction
debugShowContext = packageTry $ tryDebug $ do
(debugPackage, _) <- ask
debugCommand ":show context" (logOutputForHistoricContextDefault debugPackage)
debugShowModules :: IDEAction
debugShowModules = packageTry $ tryDebug $ debugCommand ":show modules" $
logOutputLines_Default $ \log logLaunch output -> liftIO $ do
case output of
ToolInput line -> appendLog log logLaunch (line <> "\n") InputTag
ToolOutput line | ", interpreted )" `T.isSuffixOf` line
-> appendLog log logLaunch (line <> "\n") LogTag
ToolOutput line -> appendLog log logLaunch (line <> "\n") InfoTag
ToolError line -> appendLog log logLaunch (line <> "\n") ErrorTag
ToolPrompt _ -> defaultLineLogger' log logLaunch output
ToolExit _ -> appendLog log logLaunch "X--X--X ghci process exited unexpectedly X--X--X" FrameTag
return ()
debugShowPackages :: IDEAction
debugShowPackages = packageTry $ tryDebug $ debugCommand ":show packages" logOutputDefault
debugShowLanguages :: IDEAction
debugShowLanguages = packageTry $ tryDebug $ debugCommand ":show languages" logOutputDefault
debugInformation :: IDEAction
debugInformation = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> packageTry $ tryDebug $ do
debugSetLiberalScope
debugCommand (":info "<>stripComments text) logOutputDefault
Nothing -> ideMessage Normal "Please select a name in the editor"
debugKind :: IDEAction
debugKind = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> packageTry $ tryDebug $ do
debugSetLiberalScope
debugCommand (":kind "<>stripComments text) logOutputDefault
Nothing -> ideMessage Normal "Please select a type in the editor"
debugType :: IDEAction
debugType = do
maybeText <- selectedTextOrCurrentLine
case maybeText of
Just text -> packageTry $ tryDebug $ do
debugSetLiberalScope
debugCommand (":type "<>stripComments text) logOutputDefault
Nothing -> ideMessage Normal "Please select an expression in the editor"
debugSetBreakpoint :: IDEAction
debugSetBreakpoint = do
maybeModuleName <- selectedModuleName
case maybeModuleName of
Just moduleName -> do
maybeText <- selectedText
case maybeText of
Just text -> packageTry $ tryDebug $ do
(debugPackage, _) <- ask
debugCommand (":module *" <> moduleName) logOutputDefault
debugCommand (":break " <> text) (logOutputForSetBreakpointDefault debugPackage)
Nothing -> do
maybeLocation <- selectedLocation
case maybeLocation of
Just (line, lineOffset) -> packageTry $ tryDebug $ do
(debugPackage, _) <- ask
debugCommand (":break " <> moduleName <> " " <> T.pack (show $ line + 1) <> " " <> T.pack (show lineOffset))
(logOutputForSetBreakpointDefault debugPackage)
Nothing -> ideMessage Normal "Unknown error setting breakpoint"
ref <- ask
return ()
Nothing -> ideMessage Normal "Please select module file in the editor"
debugSet :: (Bool -> Text) -> Bool -> IDEAction
debugSet flag value =
packageTry $ tryDebug $ debugCommand (":set " <> flag value) logOutputDefault
debugSetPrintEvldWithShow :: Bool -> IDEAction
debugSetPrintEvldWithShow = debugSet printEvldWithShowFlag
debugSetBreakOnException :: Bool -> IDEAction
debugSetBreakOnException = debugSet breakOnExceptionFlag
debugSetBreakOnError :: Bool -> IDEAction
debugSetBreakOnError = debugSet breakOnErrorFlag
debugSetPrintBindResult :: Bool -> IDEAction
debugSetPrintBindResult = debugSet printBindResultFlag