module IDE.Pane.Trace (
IDETrace
, TraceState
, showTrace
, fillTraceList
) where
import Graphics.UI.Gtk
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 Graphics.UI.Gtk.Gdk.Events (Event(..))
import Graphics.UI.Gtk.General.Enums (MouseButton(..))
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)
printf :: PrintfType r => Text -> r
printf = S.printf . T.unpack
data IDETrace = IDETrace {
scrolledView :: ScrolledWindow
, treeView :: TreeView
, tracepoints :: TreeStore 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 = castToWidget . 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 = reifyIDE $ \ ideR -> do
tracepoints <- treeStoreNew []
treeView <- treeViewNew
treeViewSetModel treeView tracepoints
renderer0 <- cellRendererToggleNew
col0 <- treeViewColumnNew
treeViewColumnSetTitle col0 (""::Text)
treeViewColumnSetSizing col0 TreeViewColumnAutosize
treeViewColumnSetResizable col0 False
treeViewColumnSetReorderable col0 True
treeViewAppendColumn treeView col0
cellLayoutPackStart col0 renderer0 False
cellLayoutSetAttributes col0 renderer0 tracepoints
$ \row -> [ cellToggleActive := thSelected row]
renderer1 <- cellRendererTextNew
col1 <- treeViewColumnNew
treeViewColumnSetTitle col1 (__ "Index")
treeViewColumnSetSizing col1 TreeViewColumnAutosize
treeViewColumnSetResizable col1 True
treeViewColumnSetReorderable col1 True
treeViewAppendColumn treeView col1
cellLayoutPackStart col1 renderer1 False
cellLayoutSetAttributes col1 renderer1 tracepoints
$ \row -> [ cellText := T.pack $ show (thIndex row)]
renderer2 <- cellRendererTextNew
col2 <- treeViewColumnNew
treeViewColumnSetTitle col2 (__ "Function")
treeViewColumnSetSizing col2 TreeViewColumnAutosize
treeViewColumnSetResizable col2 True
treeViewColumnSetReorderable col2 True
treeViewAppendColumn treeView col2
cellLayoutPackStart col2 renderer2 False
cellLayoutSetAttributes col2 renderer2 tracepoints
$ \row -> [ cellText := thFunction row]
renderer3 <- cellRendererTextNew
col3 <- treeViewColumnNew
treeViewColumnSetTitle col3 (__ "Position")
treeViewColumnSetSizing col3 TreeViewColumnAutosize
treeViewColumnSetResizable col3 True
treeViewColumnSetReorderable col3 True
treeViewAppendColumn treeView col3
cellLayoutPackStart col3 renderer3 False
cellLayoutSetAttributes col3 renderer3 tracepoints
$ \row -> [ cellText := T.pack $ displaySrcSpan (thPosition row)]
treeViewSetHeadersVisible treeView True
sel <- treeViewGetSelection treeView
treeSelectionSetMode sel SelectionSingle
scrolledView <- scrolledWindowNew Nothing Nothing
scrolledWindowSetShadowType scrolledView ShadowIn
containerAdd scrolledView treeView
scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic
let pane = IDETrace scrolledView treeView tracepoints
cid1 <- after treeView focusInEvent $ do
liftIO $ reflectIDE (makeActive pane) ideR
return True
(cid2, cid3) <- treeViewContextMenu treeView $ traceContextMenu ideR tracepoints treeView
on sel treeSelectionSelectionChanged $ do
sel <- getSelectedTracepoint treeView tracepoints
case sel of
Just ref -> return ()
Nothing -> return ()
return (Just pane, map ConnectC [cid1, cid2, cid3])
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
liftIO $ postGUIAsync $ do
let parseRes = parse tracesParser "" . T.unpack $ selectString to
r <- case parseRes of
Left err -> do
debugM "leksah" (printf (__ "trace parse error %s\ninput: %s") (show err)
(T.unpack $ selectString to))
return []
Right traces -> return traces
treeStoreClear (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 treeStore (tr,index) = treeStoreInsert treeStore [] index tr
selectString :: [ToolOutput] -> Text
selectString (ToolOutput str:r) = "\n" <> str <> selectString r
selectString (_:r) = selectString r
selectString [] = ""
getSelectedTracepoint :: TreeView
-> TreeStore TraceHist
-> IO (Maybe TraceHist)
getSelectedTracepoint treeView treeStore = do
treeSelection <- treeViewGetSelection treeView
paths <- treeSelectionGetSelectedRows treeSelection
case paths of
a:r -> do
val <- treeStoreGetValue treeStore a
return (Just val)
_ -> return Nothing
selectStrings :: [ToolOutput] -> [Text]
selectStrings (ToolOutput str:r) = str : selectStrings r
selectStrings (_:r) = selectStrings r
selectStrings [] = []
traceContextMenu :: IDERef
-> TreeStore TraceHist
-> TreeView
-> Menu
-> IO ()
traceContextMenu ideR store treeView theMenu = do
item1 <- menuItemNewWithLabel (__ "Back")
item1 `on` menuItemActivate $ reflectIDE debugBack ideR
sep1 <- separatorMenuItemNew
item2 <- menuItemNewWithLabel (__ "Forward")
item2 `on` menuItemActivate $ reflectIDE debugForward ideR
item3 <- menuItemNewWithLabel (__ "Update")
item3 `on` menuItemActivate $ reflectIDE fillTraceList ideR
mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1,
castToMenuItem item2, castToMenuItem 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