leksah-0.16.2.2: src/IDE/Pane/Trace.hs
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances,
MultiParamTypeClasses, DeriveDataTypeable, OverloadedStrings #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Pane.Trace
-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie
-- License : GPL
--
-- Maintainer : maintainer@leksah.org
-- Stability : provisional
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------
module IDE.Pane.Trace (
IDETrace
, TraceState
, showTrace
, fillTraceList
) where
import Data.Typeable (Typeable(..))
import IDE.Core.State
import IDE.Package (tryDebug)
import IDE.Debug
(debugForward, debugBack, debugCommand')
import IDE.Utils.Tool (ToolOutput(..))
import IDE.LogRef (srcSpanParser)
import Text.ParserCombinators.Parsec
(anyChar,
skipMany,
(<|>),
optional,
eof,
try,
parse,
(<?>),
noneOf,
many,
CharParser)
import qualified Text.ParserCombinators.Parsec.Token as P
(integer, whiteSpace, colon, symbol, makeTokenParser)
import Text.ParserCombinators.Parsec.Language (emptyDef)
import System.Log.Logger (debugM)
import IDE.Workspaces (packageTry)
import qualified Data.Conduit.List as CL (consume)
import Control.Applicative ((<$>))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.IO.Class (MonadIO(..))
import IDE.Utils.GUIUtils (treeViewContextMenu, __)
import Data.Text (Text)
import Data.Monoid ((<>))
import qualified Data.Text as T (pack, unpack)
import qualified Text.Printf as S (printf)
import Text.Printf (PrintfType)
import GI.Gtk.Objects.ScrolledWindow
(scrolledWindowSetPolicy, scrolledWindowSetShadowType,
scrolledWindowNew, ScrolledWindow(..))
import GI.Gtk.Objects.TreeView
(treeViewGetSelection, treeViewSetHeadersVisible,
treeViewAppendColumn, treeViewSetModel, treeViewNew, TreeView(..))
import Data.GI.Gtk.ModelView.ForestStore
(forestStoreGetValue, ForestStore(..),
forestStoreInsert, forestStoreClear, forestStoreNew)
import GI.Gtk.Objects.Widget (afterWidgetFocusInEvent, toWidget)
import GI.Gtk.Objects.Notebook (Notebook(..))
import GI.Gtk.Objects.Window (Window(..))
import GI.Gtk.Objects.CellRendererToggle
(setCellRendererToggleActive, cellRendererToggleNew)
import GI.Gtk.Objects.TreeViewColumn
(treeViewColumnSetReorderable, treeViewColumnSetResizable,
treeViewColumnSetSizing, treeViewColumnSetTitle, treeViewColumnNew)
import GI.Gtk.Enums
(PolicyType(..), ShadowType(..), SelectionMode(..),
TreeViewColumnSizing(..))
import GI.Gtk.Interfaces.CellLayout (cellLayoutPackStart)
import Data.GI.Gtk.ModelView.CellLayout
(cellLayoutSetDataFunction)
import GI.Gtk.Objects.CellRendererText
(setCellRendererTextText, cellRendererTextNew)
import GI.Gtk.Objects.TreeSelection
(onTreeSelectionChanged, treeSelectionSetMode)
import GI.Gtk.Objects.Adjustment (noAdjustment)
import GI.Gtk.Objects.Container (containerAdd)
import GI.Gtk.Objects.Menu (Menu(..))
import GI.Gtk.Objects.MenuItem
(toMenuItem, onMenuItemActivate, menuItemNewWithLabel)
import GI.Gtk.Objects.SeparatorMenuItem (separatorMenuItemNew)
import GI.Gtk.Objects.MenuShell (menuShellAppend)
import Control.Monad.Reader (MonadReader(..))
import Data.GI.Gtk.ModelView.Types
(treeSelectionGetSelectedRows', treePathNewFromIndices')
printf :: PrintfType r => Text -> r
printf = S.printf . T.unpack
-- | A debugger pane description
--
data IDETrace = IDETrace {
scrolledView :: ScrolledWindow
, treeView :: TreeView
, tracepoints :: ForestStore TraceHist
} deriving Typeable
data TraceState = TraceState {
} deriving(Eq,Ord,Read,Show,Typeable)
data TraceHist = TraceHist {
thSelected :: Bool,
thIndex :: Int,
thFunction :: Text,
thPosition :: SrcSpan
}
instance Pane IDETrace IDEM
where
primPaneName _ = __ "Trace"
getAddedIndex _ = 0
getTopWidget = liftIO . toWidget . scrolledView
paneId b = "*Trace"
instance RecoverablePane IDETrace TraceState IDEM where
saveState p = return (Just TraceState)
recoverState pp TraceState = do
nb <- getNotebook pp
buildPane pp nb builder
builder = builder'
getTrace :: IDEM IDETrace
getTrace = forceGetPane (Right "*Trace")
showTrace :: IDEAction
showTrace = do
pane <- getTrace
displayPane pane False
builder' :: PanePath ->
Notebook ->
Window ->
IDEM (Maybe IDETrace,Connections)
builder' pp nb windows = do
ideR <- ask
tracepoints <- forestStoreNew []
treeView <- treeViewNew
treeViewSetModel treeView (Just tracepoints)
renderer0 <- cellRendererToggleNew
col0 <- treeViewColumnNew
treeViewColumnSetTitle col0 ""
treeViewColumnSetSizing col0 TreeViewColumnSizingAutosize
treeViewColumnSetResizable col0 False
treeViewColumnSetReorderable col0 True
treeViewAppendColumn treeView col0
cellLayoutPackStart col0 renderer0 False
cellLayoutSetDataFunction col0 renderer0 tracepoints
$ setCellRendererToggleActive renderer0 . thSelected
renderer1 <- cellRendererTextNew
col1 <- treeViewColumnNew
treeViewColumnSetTitle col1 (__ "Index")
treeViewColumnSetSizing col1 TreeViewColumnSizingAutosize
treeViewColumnSetResizable col1 True
treeViewColumnSetReorderable col1 True
treeViewAppendColumn treeView col1
cellLayoutPackStart col1 renderer1 False
cellLayoutSetDataFunction col1 renderer1 tracepoints
$ setCellRendererTextText renderer1 . T.pack . show . thIndex
renderer2 <- cellRendererTextNew
col2 <- treeViewColumnNew
treeViewColumnSetTitle col2 (__ "Function")
treeViewColumnSetSizing col2 TreeViewColumnSizingAutosize
treeViewColumnSetResizable col2 True
treeViewColumnSetReorderable col2 True
treeViewAppendColumn treeView col2
cellLayoutPackStart col2 renderer2 False
cellLayoutSetDataFunction col2 renderer2 tracepoints
$ setCellRendererTextText renderer2 . thFunction
renderer3 <- cellRendererTextNew
col3 <- treeViewColumnNew
treeViewColumnSetTitle col3 (__ "Position")
treeViewColumnSetSizing col3 TreeViewColumnSizingAutosize
treeViewColumnSetResizable col3 True
treeViewColumnSetReorderable col3 True
treeViewAppendColumn treeView col3
cellLayoutPackStart col3 renderer3 False
cellLayoutSetDataFunction col3 renderer3 tracepoints
$ setCellRendererTextText renderer3 . T.pack . displaySrcSpan . thPosition
treeViewSetHeadersVisible treeView True
sel <- treeViewGetSelection treeView
treeSelectionSetMode sel SelectionModeSingle
scrolledView <- scrolledWindowNew noAdjustment noAdjustment
scrolledWindowSetShadowType scrolledView ShadowTypeIn
containerAdd scrolledView treeView
scrolledWindowSetPolicy scrolledView PolicyTypeAutomatic PolicyTypeAutomatic
let pane = IDETrace scrolledView treeView tracepoints
cid1 <- onIDE afterWidgetFocusInEvent treeView (do
liftIDE $ makeActive pane
return True)
cids2 <- treeViewContextMenu treeView $ traceContextMenu ideR tracepoints treeView
onTreeSelectionChanged sel $ do
sel <- getSelectedTracepoint treeView tracepoints
case sel of
Just ref -> return () -- TODO reflectIDE (selectRef (Just ref)) ideR
Nothing -> return ()
return (Just pane, cid1 : cids2)
fillTraceList :: IDEAction
fillTraceList = packageTry $ do
currentHist' <- readIDE currentHist
mbTraces <- liftIDE getPane
case mbTraces of
Nothing -> return ()
Just tracePane -> tryDebug $ debugCommand' ":history" $ do
to <- CL.consume
lift $ postAsyncIDE $ do
let parseRes = parse tracesParser "" . T.unpack $ selectString to
r <- case parseRes of
Left err -> do
liftIO $ debugM "leksah" (printf (__ "trace parse error %s\ninput: %s") (show err)
(T.unpack $ selectString to))
return []
Right traces -> return traces
forestStoreClear (tracepoints tracePane)
let r' = map (\h@(TraceHist _ i _ _) -> if i == currentHist'
then h{thSelected = True}
else h) r
mapM_ (insertTrace (tracepoints tracePane))
(zip r' [0..length r'])
where
insertTrace forestStore (tr,index) = do
emptyPath <- treePathNewFromIndices' []
forestStoreInsert forestStore emptyPath index tr
selectString :: [ToolOutput] -> Text
selectString (ToolOutput str:r) = "\n" <> str <> selectString r
selectString (_:r) = selectString r
selectString [] = ""
getSelectedTracepoint :: TreeView
-> ForestStore TraceHist
-> IO (Maybe TraceHist)
getSelectedTracepoint treeView forestStore = do
treeSelection <- treeViewGetSelection treeView
paths <- treeSelectionGetSelectedRows' treeSelection
case paths of
a:r -> do
val <- forestStoreGetValue forestStore a
return (Just val)
_ -> return Nothing
selectStrings :: [ToolOutput] -> [Text]
selectStrings (ToolOutput str:r) = str : selectStrings r
selectStrings (_:r) = selectStrings r
selectStrings [] = []
traceContextMenu :: IDERef
-> ForestStore TraceHist
-> TreeView
-> Menu
-> IO ()
traceContextMenu ideR store treeView theMenu = do
item1 <- menuItemNewWithLabel (__ "Back")
onMenuItemActivate item1 $ reflectIDE debugBack ideR
sep1 <- separatorMenuItemNew >>= liftIO . toMenuItem
item2 <- menuItemNewWithLabel (__ "Forward")
onMenuItemActivate item2 $ reflectIDE debugForward ideR
item3 <- menuItemNewWithLabel (__ "Update")
onMenuItemActivate item3 $ reflectIDE fillTraceList ideR
mapM_ (menuShellAppend theMenu) [item1, sep1, item2, item3]
tracesParser :: CharParser () [TraceHist]
tracesParser = try (do
whiteSpace
symbol (T.unpack $ __ "Empty history.")
skipMany anyChar
eof
return [])
<|> do
traces <- many (try traceParser)
whiteSpace
symbol (T.unpack $ __ "<end of history>")
eof
return traces
<|> do
whiteSpace
symbol (T.unpack $ __ "Not stopped at a breakpoint")
skipMany anyChar
eof
return []
<?>
T.unpack (__ "traces parser")
traceParser :: CharParser () TraceHist
traceParser = do
whiteSpace
index <- int
colon
optional (symbol "\ESC[1m")
function <- T.pack <$> many (noneOf "(\ESC")
optional (symbol "\ESC[0m")
symbol "("
span <- srcSpanParser
symbol ")"
return (TraceHist False index function span)
<?> T.unpack (__ "trace parser")
lexer = P.makeTokenParser emptyDef
colon = P.colon lexer
symbol = P.symbol lexer
whiteSpace = P.whiteSpace lexer
int = fromInteger <$> P.integer lexer