hpc-tracer (empty) → 0.3.0
raw patch · 27 files changed
+2699/−0 lines, 27 filesdep +arraydep +basedep +containerssetup-changedbinary-added
Dependencies added: array, base, containers, haskell98, hpc, network, parsec, pretty, process, unix
Files
- LICENSE +25/−0
- Setup.hs +2/−0
- fs/code.html +5/−0
- fs/default.css +6/−0
- fs/default.js +1056/−0
- fs/favicon.ico binary
- fs/footer.html +15/−0
- fs/header.html +41/−0
- fs/progressbar_green.gif binary
- fs/root.html +10/−0
- fs/status.html +100/−0
- hpc-tracer.cabal +43/−0
- includefile.pl +26/−0
- src/AjaxAPI.hs +224/−0
- src/BreakPoint.hs +73/−0
- src/CodeRenderActor.hs +179/−0
- src/Common.hs +109/−0
- src/Debug.hs +9/−0
- src/Flags.hs +38/−0
- src/Main.hs +118/−0
- src/MixActor.hs +9/−0
- src/Reactive.hs +107/−0
- src/StreamHandle.hs +44/−0
- src/TixActor.hs +88/−0
- src/TixStreamActor.hs +174/−0
- src/TracerActor.hs +188/−0
- src/Utils.hs +10/−0
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2006 Andy Gill, Colin Runciman+Copyright (c) 2006-2007 Galois, Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. The names of the authors may not be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fs/code.html view
@@ -0,0 +1,5 @@+<html>+ <body>+ The Boot Sequence...+ </body>+</html>
+ fs/default.css view
@@ -0,0 +1,6 @@+span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }+span.spaces { background: white; border: none }+.cap { font-size: 140% }+td.logo { letter-spacing: 1.2px }+td.rhs { font-weight: bold }+input.hdbutton { height: 40px }
+ fs/default.js view
@@ -0,0 +1,1056 @@+// We want to load this code once.++//////////////////////////////////////////////////////////////////////////////+// Some global vars++var run_status = 0;++//////////////////////////////////////////////////////////////////////////////++var XMLHttpRequests = new Array();++function XMLHttpRequestFactory() {+ if (XMLHttpRequests.length > 0) {+ return XMLHttpRequests.pop();+ } else { + var request = false;+ try {+ request = new XMLHttpRequest();+ } catch (failed) {+ request = false;+ }+ if (!request) {+ alert("Error initializing XMLHttpRequest!");+ }+ return request;+ }+}++// This is a uniq number for all requests, to avoid cache hit problems.+uq = 0;++function send(msg,args) {+ // progressbar(true);+ var i = 0;+ var request = XMLHttpRequestFactory();+ var argMsg = msg + "?uq=" + uq++;+ if (args != "") {+ argMsg += "&" + args;+ }+ request.open("GET", argMsg,true);+ // Abort the request if there is no response in a timely manner. (1 minute).+ var timeout = setTimeout(function () { + alert("request did not get response, aborting");+ request.abort();+ XMLHttpRequests.push(request);+ },60000);+ request.onreadystatechange = function () {+ if (request.readyState == 4) { + // Please do not cancel this request; we will return it to the factory.+ clearTimeout(timeout);+ // progressbar(false);+ try { + if (request.status == 200) {+ // alert(request.responseText);+ // Frightfully simple; evaluate the text in the content of top.status+ try {+ eval(request.responseText);+ } catch (problem) {+ alert('callback failure : ' + problem + "\n" + request.responseText);+ }+ } else {+ // Should *never* happen.+ alert('status != 200 ' + request.status);+ }+ } catch (problem) {+ alert('status wrong or callback aborted:' + problem);+ request.abort();+ }+ // Return the completed xml+ XMLHttpRequests.push(request);+ }+ };+ request.send(null);+}++//////////////////////////////////////////////////////////////////////////////++function setField(name,val) {+ var w = top.status.document.getElementById(name);+ if (w.innerHTML != val) {+ w.innerHTML = val;+ } +}++//////////////////////////////////////////////////////////////////////////////+// Show functions++function showLocation(loc) {+ if (loc == null) {+ return "-";+ } else {+ if (loc.startLine == loc.endLine) {+ return loc.startLine + ":" + loc.startCol + "-" + loc.endCol;+ }+ return loc.startLine + ":" + loc.startCol + "-" ++ loc.endLine + ":" + loc.endCol;+ }+}++//////////////////////////////////////////////////////////////////////////////+// Local State ++var state = new Object();++state.module = ''; // which module is the cursor at?+state.location = ''; // HTML of location+state.event = ''; // simple string of event+state.eventtext = ''; // HTML of event description+state.counter = '';+state.threadid = '';+state.tixboxNo = '';+state.tixboxType = '';+state.lineno = '';+state.viewedModule = ''; // which module is the user looking at?+state.modNames = new Object();+state.fontsize = '10';+state.linespacing = '13';+++function stateAlert () {+ alert("state.module = " + state.module + "\n" ++ "state.viewedModule = " + state.viewedModule + "\n" + + "");+ +}++// These functions both modify the state, and also+// modify any viewer on the data, like the status box.++function setModule(mod) {+ setField("module",mod);+ // Also set the pulldown box to the correct module.++ if (state.module != mod) {+ var w = state.modNames["mod_" + state.module];+ if (w != undefined) {+ w.setAttribute("style","background: white");+ }+ var w = state.modNames["mod_" + mod];+ if (w != undefined) {+ w.setAttribute("style","background: yellow");+ }+ }+ state.module = mod;+}++function setLocation(loc) {+ state.location = loc;+ setField("location",showLocation(loc));+}++function setEvent2(e,et) {+ state.event = e;+ state.eventtext = e;+ setField("event",et);+}++function setCounter(c) {+ state.counter = c;+ setField("counter",c);+}++function setThreadID(tid) {+ state.counter = tid;+ setField("thread_no",tid);+}++function setTickInfo(tick,ty,lineno) {+ state.tixboxNo = tick;+ state.tixboxType = ty;+ state.lineno = lineno;+}++function clearTickInfo() {+ state.tixboxNo = '';+ state.tixboxType = '';+ state.lineno = '';+ unmark();+}+++function setViewedModule(modName) {+ state.viewedModule = modName;+ top.status.document.getElementById('allmodules').value = modName;+}++var breakpoints = new Array(0);+var breakpoints2 = new Array(0);++function setBreakpoint(o) {+ var name = breakPointToName(o);+ var fullName = breakPointToText(o);+ breakpoints.push(name);+ var name = breakPointToName(o);+ // Do not add if we already have it.+ for(var i = 0;i < breakpoints2.length;i++) {+ // TODO: We could cache the JSON string inside the breakpoints+ if (breakPointToName(breakpoints2[i]) == name) {+ return;+ }+ }+ breakpoints2.push(o); // Adding this to the bottom of the breakpoint list++ // showLog("set " + breakpoints.length);+ var w = top.status.document.getElementById(name);++ if (w != undefined) {+ // If this value is ticked, then do not display it in the + // Create Breakpoints list.+ w.style.display = 'none';+ }++ // Now we look for this exception in the Active Breakpoints list.+ var w = top.status.document.getElementById(name + '_active');+ if (w != undefined) {+ var rows = w.parentNode;+ rows.removeChild(w);+ }++ var tab = top.status.document.getElementById('Breakpoints');+ var newRow = tab.insertRow(-1); // insert at bottom+ if (breakpoints2.length % 2 == 0) {+ newRow.setAttribute("style","background: #f0f0f0");+ } else {+ newRow.setAttribute("style","background: #f8f8f8");+ }+ newRow.setAttribute("id",name + '_active');+ + var newCell = newRow.insertCell(0);+ + var newText = top.status.document.createTextNode(fullName);+ newCell.setAttribute("align","right");+ newCell.appendChild(newText);+ + var newCell = newRow.insertCell(1);+ var newElem = top.status.document.createElement("input");+ newElem.setAttribute("type","checkbox");+ newElem.checked = true;+ newElem.onchange = function () {+ breakpoint(o,newElem.checked);+ };+ newCell.appendChild(newElem);+}++function clearBreakpoint(o) {+ var name = breakPointToName(o);+ for(var i = 0;i < breakpoints2.length;i++) {+ if (breakPointToName(breakpoints2[i]) == name) {+ breakpoints2.splice(i,1);+ }+ }+ //showLog("clear " + breakpoints + " " + breakpoints.length);+ var w = top.status.document.getElementById(name);+ if (w != undefined) {+ w.style.display = '';+ }++ var tb = top.status.document.getElementById(name + '_checkbox');+ if (tb != undefined) {+ tb.checked = false;+ }+ + // Now we look for this exception in the Active Breakpoints list.+ var w = top.status.document.getElementById(name + '_active');+ if (w != undefined) {+ var rows = w.parentNode;+ rows.removeChild(w);+ }+}++function breakPointToText(o) {+ switch (o) {+ case "AllExceptions":+ return 'All Exceptions';+ break;+ case "ThreadChange":+ return 'All Thread Changes';+ break;+ case "ThreadTermination":+ return 'All Thread Terminations';+ break;+ default:+ switch(o.tag) {+ case "CounterAt":+ return 'Counter # ' + o.count;+ break;+ case "ThreadChangeTo":+ return 'Thread Change To TID# ' + o.tid;+ break;+ case "TickBox":+ var loc = o.tickInfo.location;+ return o.tickInfo.module + " " + + loc.startLine + ":" + loc.startCol + "-" ++ loc.endLine + ":" + loc.endCol;+ break;+ default:+ alert("switch problem: breakPointToText" + o.toJSONString());+ }+ }+}++function breakPointToName(o) {+ switch (o) {+ case "AllExceptions":+ case "ThreadChange":+ case "ThreadTermination":+ return(o);+ break;+ default:+ switch(o.tag) {+ case "CounterAt":+ return 'CounterAt_' + o.count;+ break;+ case "ThreadChangeTo":+ return 'ThreadChangeTo_' + o.tid;+ break;+ case "TickBox":+ return 'TickBox_' + o.tickInfo.global;+ break;+ default:+ alert("switch problem: breakPointToName" + o.toJSONString());+ }+ }+}++//////////////////////////////////////////////////////////////////////////////+// All the modules in this section have an entry in AjaxAPI.hs+++function setEvent(event) {+ switch(event) {+ case "Raise":+ setEvent2("Exception","<div style='color: red'>Exception!</div>");+ break;+ case "Finished":+ setEvent2("Finished","<div style='color: green'>Program Finished</div>");+ break;+ case "ThreadFinished":+ setEvent2("Finished","<div style='color: green'>Thread Finished</div>");+ break;+ default:+ switch(event.tag) {+ case "Tick":+ var tick = event.tick;+ setEvent2(tick,"#" + tick); + break;+ default:+ alert("switch problem " + event.toJSONString());+ }+ }+}+++function setTicked(tickInfo) {+ //alert(tickInfo.toJSONString());+ if (tickInfo == null) {+ setModule("-");+ setLocation(null);+ clearTickInfo();+ unmark();+ } else {+ setLocation(tickInfo.location);+ setModule(tickInfo.module);+ setTickInfo(tickInfo.local,tickInfo.tickType,tickInfo.location.startLine);+ addMarkings();+ }+}++function setModules(modNames) {+ for(var i = 0; i < modNames.length;i++) {+ var modName = modNames[i];+ var w = top.status.document.getElementById("allmodules"); + var o = document.createElement("option");+ o.setAttribute("value",modName);+ w.appendChild(o);+ o.appendChild(document.createTextNode(modName));+ state.modNames["mod_" + modName] = o;+ }+}++function clearBreakPoints () {+ // Simply remove all the breakpoints+ while(breakpoints2.length > 0) {+ clearBreakpoint(breakpoints2[0]);+ }+}++// TODO: rename this back+function setBreakPoint2(o) {+ setBreakpoint(o);+}++function setBreakPointLights(lights) {+ for(var i = 0;i < breakpoints2.length;i++) {+ var name = breakPointToName(breakpoints2[i]);+ var w = top.status.document.getElementById(name + '_active');+ if (w != undefined) {+ if (lights[i]) {+ w.setAttribute("style","background: orange"); + } else {+ w.setAttribute("style","background: "); + }+ }+ }+}+++function setRunning(run) {+ // Hmm, async issues, + switch(run) {+ case "Stopped":+ progressbar(false);+ top.heading.document.getElementById("runbackbutton").disabled = false;+ top.heading.document.getElementById("runbutton").disabled = false;+ top.heading.document.getElementById("stopbutton").disabled = true;+ break;+ case "Forward":+ case "Backward":+ progressbar(true);+ top.heading.document.getElementById("runbackbutton").disabled = true;+ top.heading.document.getElementById("runbutton").disabled = true;+ top.heading.document.getElementById("stopbutton").disabled = false;+ please_continue();+ }+}+++//////////////////////////////////////////////////////////////////////////////++function running(count) {+ setCounter(count);+ // Check to see if the breakpoint has been found+ // The result is either + // - (re)calling running+ // - calling setState+ // This is where any animation might live.+ pleasecontinue();+} +++//////////////////////////////////////////////////////////////////////////////++function showMessage(msg) {+ top.footing.document.getElementById("global_message").innerHTML = msg;+}+++function showLog(msg) {+ var newText = top.status.document.createTextNode(msg);+ top.status.document.getElementById("scratch").appendChild(newText); + var br = top.status.document.createElement("BR");+ top.status.document.getElementById("scratch").appendChild(br);+}+++// Combine these below ++function drawStart(count) {+ setEvent("Booting","booting...");+ clearTickInfo();+ unmark();+}++function drawRaise(count,tid) {+ // Mark up the global tick count+ setEvent("Exception","<div style='color: red'>Exception!</div>");+ clearTickInfo();+ unmark();+}++function drawThread(count,tid) {+ // Mark up the global tick count+ setEvent("ThreadChange","<div style='color: green'>Change to Thread # " + tid + "</div>");+ clearTickInfo();+ unmark();+}++function drawThreadFinished(count,tid) {+ // Mark up the global tick count+ setEvent("ThreadFinished","<div style='color: green'>Thread# " + tid + " finished</div>");+ clearTickInfo();+ unmark();+}++// This makes sure that the currently marked module is+// highlighted in yellow+function markModule(modName) {+ // o.setAttribute("style","background: green");+}++function menu(m) {+ if (m.value == 'Next Exception') {+ send("/next_exception");+ }+ m.value = '...';+}+++theLineSpacing = 16;++// For some reason, when you ask for font size 12, you get 14, etc, etc.+// The argument is the font size you asked for, 'theLineSpacing' contains+// the real size of the font. Perhaps this is just spacing between lines?+function fontsize(fs) {+ alert("font: " + fs);+ if (fs == 12) { + theLineSpacing = 16;+ } else if (fs == 10) { + theLineSpacing = 13;+ } else {+ alert("strange font size");+ }+}++++var mark_elem = null;++function unmark() {+ if (mark_elem != null) {+ mark_elem.style.border = '';+ mark_elem.style.background = '';+ }+}++var ps = null;+var oldScroll = 0;+var when = null;++function mark(n,ty,lineno) {+ unmark();+ mark_elem = top.code.document.getElementById("t_" + n);+ if (mark_elem != null) {+ switch (ty) {+ case "ExpBox":+ case "AltBox":+ // mark_elem.style.border = '1px solid orange';+ mark_elem.style.background = '#f0f000';+ break;+ default:+ switch(ty.tag) {+ case "TopLevelBox":+ case "LocalBox":+ mark_elem.style.background = '#f0f000';+ break;+ case "GuardBinBox":+ case "CondBinBox":+ case "QualBinBox":+ if (ty.value) {+ mark_elem.style.borderBottom = '3px double green';+ } else {+ mark_elem.style.borderBottom = '3px double red';+ }+ break;+ default:+ alert("switch problem " + ty.toJSONString());+ }++ }+ // var viewerHeight = top.code.window.innerHeight;+ // window.status = top.code.window.innerHeight;++ var newScroll = (lineno - 10) * state.linespacing;+ + // Dont scroll if your newScoll is on your viewer.+ top.code.scroll(0,newScroll);++ }+}++// Add any markup onto the current page. +// If we do not have the correct page loaded, then initiate the+// load of the correct page, which will eventually re-call addMarkings.++// TODO: rename this function better.++function addMarkings() {+ if (state.module != state.viewedModule) {+ viewModule(state.module);+ return;+ }+ mark(state.tixboxNo,state.tixboxType,state.lineno);+}+++//////////////////////////////////////////////////////////////////////////////++// Called after every loading the code page.+//+// This is a chance to set the font, move the scroll bar, +// markup the text, restore callbacks, etc, etc.++function codeloaded (modName) {+ setViewedModule(modName);+ top.code.document.body.style.fontSize = "" + state.fontsize + "pt";+ top.code.onmousedown = mousedownCode;+ top.code.onmousemove = mousemoveCode;+ top.code.onmouseup = mouseupCode;+ if (state.module == state.viewedModule) {+ // This module needs markup, because it contains the cursor+ // We do not just call addMarkings, because it loaded+ // the cursor page as a side-effect.+ addMarkings();+ }+}++//////////////////////////////////////////////////////////////////////////////+// Callbacks from Javascript buttons, etc, to perform actions.++function viewModule(modName) {+ // TODO: perhaps some sort of visual cue of action pending.+ // top.code.document.body.innerHTML = "loading : " + modName;+ top.code.location.href=modulecode(modName)+}++//////////////////////////////////////////////////////////////////////////////++function numberEnterFrom(myfield,e,name,field) {+ var keycode;+ if (window.event) {+ keycode = window.event.keyCode;+ } else {+ if (e) { + keycode = e.which;+ } else {+ return true;+ }+ }+ if (keycode == 13) {+ // TODO: check for number value only+ var obj = { "tag" : name };+ obj[field] = myfield.value;+ breakpoint(obj,true);+ myfield.value = "";+ return false;+ }+ return true;+}++//////////////////////////////////////////////////////////////////////////////++function getTextFromCodeNode(w) {+ if (w.nodeType == Node.TEXT_NODE) {+ if (w.nodeValue == undefined) {+ return "{{*}}";+ } else { + return w.nodeValue;+ }+ } else {+ var children = w.childNodes;+ var text = "";+ for(var i = 0;i < children.length;i++) {+ text += getTextFromCodeNode(children[i]);+ }+ return text;+ }+}+++function mousedownCode(mouseEvent) {+ var x = mouseEvent.clientX;+ var y = mouseEvent.clientY;+ var x2 = mouseEvent.pageX;+ var y2 = mouseEvent.pageY;+ var target = mouseEvent.target;+ var id = mouseEvent.target.id;+ var t = ("" + x + " " ++ y + " " ++ x2 + " " + + y2 + " " + + target + " " + + target.id + " " + + "");++// alert("clicked: " + t);++// target.style.background = 'pink';++ var txtls = "";+ var re = /t_(\d+)/;+ var w = target;+ var menuItems = new Array(0);+ while (w != null && w.parentNode != undefined) {+ if (w.id != undefined) {+ var o = re.exec(w.id);+ if (o != null) {+ var text = getTextFromCodeNode(w);+ if (text.length > 30) {+ text = text.substr(0,28) + " ...";+ }+ menuItems.push({ id : o[1], text : text });+ }+ }+ w = w.parentNode;+ }++ t += " " + txtls;++ if (menuItems.length > 0) {+ var newElem = top.status.document.createElement("div");+ + newElem.setAttribute("id","codemenu");+ newElem.style.position='absolute';+ newElem.style.top = "" + (y2 - 5) + 'px';+ newElem.style.left = "" + (x2 - 5) + 'px';+ newElem.style.width = "200px";+ newElem.style.opacity = '0.95';+ newElem.style.backgroundColor = 'white';+ + var table = document.createElement("table");+ table.setAttribute("border", "1");+// table.setAttribute("background", "white");+ var tbody = document.createElement("tbody");+ var tr = document.createElement("tr");+ var th = document.createElement("th");+ th.appendChild(document.createTextNode("Set Breakpoint"));+ tr.appendChild(th);+ tbody.appendChild(tr);+ for(var i = 0;i < menuItems.length;i++) {+ var tr = document.createElement("tr");+ var td = document.createElement("td");+ td.appendChild(document.createTextNode(menuItems[i].text));+ td.id = 'menu_' + i;+ td.onmouseover = function(event) {+ event.target.style.background = 'orange';+ }+ td.onmouseout = function(event) {+ event.target.style.background = 'white';+ }+ td.onmouseup = function(event) {+ var ix = /menu_(\d+)/.exec(event.target.id)[1];+// alert(menuItems[ix].toJSONString());+ breakpoint({ tag : "ReqTickBox", + module : state.viewedModule,+ id : parseInt(menuItems[ix].id)+ },true);+ return true; // so the widget above can remove the menu+ }+ tr.appendChild(td);+ tbody.appendChild(tr);+ }+ table.appendChild(tbody);+ + newElem.appendChild(table);+ + top.code.document.body.appendChild(newElem);+ }+ return false;+}++var bp_highlighted = null;++function mousemoveCode(mouseEvent) {+/*+ var x = mouseEvent.clientX;+ var y = mouseEvent.clientY;+ var x2 = mouseEvent.pageX;+ var y2 = mouseEvent.pageY;+ var target = mouseEvent.target;+ if (mouseEvent.ctrlKey) { // For now, untill we debug it+ var id = mouseEvent.target.id; + // Perhaps dig for the + if (id != undefined) {+ + } else {+ if (bp_highlighted = null;+ }+ mousedownCode(mouseEvent); + }+*/+ return true;+}++function mouseupCode(mouseEvent) {+ var o = top.code.document.getElementById('codemenu');+ if (o != undefined) {+ var p = o.parentNode;+ p.removeChild(o);+ }++ return true; // someone else might want to see the mouseup button.+// value = modName; +}+++//////////////////////////////////////////////////////////////////////////////+++var progressTid = null;++// Show progress bar+function progressbar(show) {+ if (show == true) { + if (progressTid != null) {+ return;+ }+ /* You could put this into a timeout */+ var d = top.status.document;+ var w = d.getElementById("progress");+ w.style.visibility = ""; + progressTid = {};+// progressTid = setTimeout(function () {},100);+ } else {+ if (progressTid == null) {+ return;+ }+// clearInterval(progressTid);+ progressTid = null;+ var d = top.status.document+ var w = d.getElementById("progress");+ w.style.visibility = "hidden";+ }+}++/*+++ if (w == null) {+ var newElem = d.createElement("div");+ newElem.setAttribute("id","progress");+ newElem.style.position='absolute';+ newElem.style.top = "0px";+ newElem.style.left = "100px"+ newElem.style.opacity = '0.95';+ newElem.style.backgroundColor = 'white';++ var newImage = d.createElement("img");+ newImage.src = "progress.gif";+ newElem.appendChild(newImage);+ d.body.appendChild(newElem);+ w = newElem;+ }++ if (show) {+ w.style.visibility = "";+ } else {+ w.style.visibility = "hidden";+ }+}+*/+++//////////////////////////////////////////////////////////////////////////////+++setTimeout(function () { +// alert(escape(({ "Hello World": "This is a %32 Test", "World": 2.0 }).toString()));+// alert(true.toJSONString());+ init_please();+ send("/boot","") },500);+++function init_please() {+// top.code.onclick = function () { alert("loaded"); }+// onclick = function () { alert("loaded2"); }+// top.onclick = function () { alert("loaded3"); }+}++//////////////////////////////////////////////////////////////////////////////+/* AJG: from http://www.json.org/json.js + */+/*+ json.js+ 2006-12-06++ This file adds these methods to JavaScript:++ array.toJSONString()+ boolean.toJSONString()+ date.toJSONString()+ number.toJSONString()+ object.toJSONString()+ string.toJSONString()+ These methods produce a JSON text from a JavaScript value.+ It must not contain any cyclical references. Illegal values+ will be excluded.++ The default conversion for dates is to an ISO string. You can+ add a toJSONString method to any date object to get a different+ representation.++ string.parseJSON(hook)+ This method parses a JSON text to produce an object or+ array. It can throw a SyntaxError exception.++ The optional hook parameter is a function which can filter and+ transform the results. It receives each of the values, and its+ return value is used instead. If it returns what it received, then+ structure is not modified.++ Example:++ // Parse the text. If it contains any "NaN" strings, replace them+ // with the NaN value. All other values are left alone.++ myData = text.parseJSON(function (value) {+ if (value === 'NaN') {+ return NaN;+ }+ return value;+ });++ It is expected that these methods will formally become part of the+ JavaScript Programming Language in the Fourth Edition of the+ ECMAScript standard in 2007.+*/+if (!Object.prototype.toJSONString) {+ Array.prototype.toJSONString = function () {+ var a = ['['], b, i, l = this.length, v;++ function p(s) {+ if (b) {+ a.push(',');+ }+ a.push(s);+ b = true;+ }++ for (i = 0; i < l; i += 1) {+ v = this[i];+ switch (typeof v) {+ case 'undefined':+ case 'function':+ case 'unknown':+ break;+ case 'object':+ if (v) {+ if (typeof v.toJSONString === 'function') {+ p(v.toJSONString());+ }+ } else {+ p("null");+ }+ break;+ default:+ p(v.toJSONString());+ }+ }+ a.push(']');+ return a.join('');+ };++ Boolean.prototype.toJSONString = function () {+ return String(this);+ };++ Date.prototype.toJSONString = function () {++ function f(n) {+ return n < 10 ? '0' + n : n;+ }++ return '"' + this.getFullYear() + '-' ++ f(this.getMonth() + 1) + '-' ++ f(this.getDate()) + 'T' ++ f(this.getHours()) + ':' ++ f(this.getMinutes()) + ':' ++ f(this.getSeconds()) + '"';+ };++ Number.prototype.toJSONString = function () {+ return isFinite(this) ? String(this) : "null";+ };++ Object.prototype.toJSONString = function () {+ var a = ['{'], b, i, v;++ function p(s) {+ if (b) {+ a.push(',');+ }+ a.push(i.toJSONString(), ':', s);+ b = true;+ }++ for (i in this) {+ if (this.hasOwnProperty(i)) {+ v = this[i];+ switch (typeof v) {+ case 'undefined':+ case 'function':+ case 'unknown':+ break;+ case 'object':+ if (v) {+ if (typeof v.toJSONString === 'function') {+ p(v.toJSONString());+ }+ } else {+ p("null");+ }+ break;+ default:+ p(v.toJSONString());+ }+ }+ }+ a.push('}');+ return a.join('');+ };+++ (function (s) {+ var m = {+ '\b': '\\b',+ '\t': '\\t',+ '\n': '\\n',+ '\f': '\\f',+ '\r': '\\r',+ '"' : '\\"',+ '\\': '\\\\'+ };++ s.parseJSON = function (hook) {+ try {+ if (/^("(\\.|[^"\\\n\r])*?"|[,:{}\[\]0-9.\-+Eaeflnr-u \n\r\t])+?$/.+ test(this)) {+ var j = eval('(' + this + ')');+ if (typeof hook === 'function') {+ function walk(v) {+ if (v && typeof v === 'object') {+ for (var i in v) {+ if (v.hasOwnProperty(i)) {+ v[i] = walk(v[i]);+ }+ }+ }+ return hook(v);+ }+ return walk(j);+ }+ return j;+ }+ } catch (e) {+ }+ throw new SyntaxError("parseJSON");+ };++ s.toJSONString = function () {+ if (/["\\\x00-\x1f]/.test(this)) {+ return '"' + this.replace(/([\x00-\x1f\\"])/g, function(a, b) {+ var c = m[b];+ if (c) {+ return c;+ }+ c = b.charCodeAt();+ return '\\u00' ++ Math.floor(c / 16).toString(16) ++ (c % 16).toString(16);+ }) + '"';+ }+ return '"' + this + '"';+ };+ })(String.prototype);+}+
+ fs/favicon.ico view
binary file changed (absent → 198 bytes)
@@ -0,0 +1,15 @@+<html>+ <HEAD>+ <LINK REL ="stylesheet" HREF ="default.css" TYPE ="text/css"></LINK>+ </HEAD>+ <body bgcolor="#eeeeee" style="margin: 2px" class="headbar">+ <table height="36px" width="100%" border=0 style="border: 1px; margin: 0px">+ <td align="left" width="*" id="global_message">booting...+ </td>+ <td width="10"> + </td>+ <td align="right" width="150" id="global_count">+ </td>+ </table>+ </body>+</html>
+ fs/header.html view
@@ -0,0 +1,41 @@+<html>+ <HEAD>+ <LINK REL ="stylesheet" HREF ="default.css" TYPE ="text/css"></LINK>+ </HEAD>+ <body bgcolor="#eeeeee" style="margin: 2px" class="headbar">+ <table height="56px" width="100%" border=0 style="border: 1px; margin: 0px">+ <tr>+ <td width="10px"><input type="submit" value="Step [Back]" + onclick="top.status.step_backward()" class="hdbutton">+ </td>+ <td width="10px">+ </td>+ <td width="10px"><input type="submit" value="Step" + onclick="top.status.step_forward()" class="hdbutton">+ </td>+ <td width="10px">+ </td>+ <td width="10px"><input id="runbackbutton" type="submit" value="Run [Back]" + onclick="top.status.run_backward()" class="hdbutton">+ </td>+ <td width="10px">+ </td>+ <td width="10px"><input id="runbutton" type="submit" value="Run" + onclick="top.status.run_forward()" class="hdbutton">+ </td>+ <td width="10px">+ </td>+ <td width="10px"><input id="stopbutton" type="submit" value="Stop" + onclick="top.status.please_stop()" class="hdbutton"+ disabled="true">+ </td>+ <td width="10px">+ </td>+ <td align="right" width="80%" class="logo">+ <span class="cap">P</span>rogram <span class="cap">C</span>overage <span class="cap">T</span>racer + </td>+ </tr>+ </table>+ </body>+</html>+
+ fs/progressbar_green.gif view
binary file changed (absent → 1522 bytes)
+ fs/root.html view
@@ -0,0 +1,10 @@+<html>+<frameset rows="60,*" frameborder=2 border=1 framespacing=2>+ <frame src="header.html" name="heading" scrolling=no noresize/>+ <frameset cols="*,280" BORDER=3>+ <frame name="code" src="code.html"/>+ <frame name="status" src="status.html"/>+ </frameset>+</frameset>+</html>+
+ fs/status.html view
@@ -0,0 +1,100 @@+<html>+ <HEAD>+ <LINK REL ="stylesheet" HREF ="default.css" TYPE ="text/css"></LINK>+ </HEAD>+ <body id="scratch">+ <FIELDSET>+ <LEGEND>Status</LEGEND>+ <table border=0 style="margin-left: 10px">+ <tr>+ <td class="rhs" align="right">Module : </td>+ <td id="module"></td>+ </tr>+ <tr>+ <td class="rhs" align="right">Location : </td>+ <td id="location"></td>+ </tr>+ <tr>+ <td class="rhs" align="right">Event : </td>+ <td id="event"></td>+ </tr>+ <tr>+ <td class="rhs" align="right">Counter : </td>+ <td id="counter"></td>+ </tr>+ <tr>+ <td class="rhs" align="right">Thread # : </td>+ <td id="thread_no"></td>+ </tr>+ <tr>+ <td colspan="2" + id="progress" + style="visibility: hidden" + align="center">+ <img src="progress.gif" width="100px"/>+ </td>+ </tr>+ </table>+ </FIELDSET>+ <BR/>+ <FIELDSET>+ <LEGEND>View Module</LEGEND>+ <SELECT ID="allmodules" NAME="viewmodule" style="width: 100%"+ onChange="top.status.viewModule(document.getElementById('allmodules').value)">+ </SELECT>+ </FIELDSET>+ <BR/>+ <FIELDSET style="background: #f0f0f0">+ <LEGEND>Breakpoints</LEGEND>+ <table width="100%" border=0 id="Breakpoints" style="border-collapse: collapse">+ </table>+ </FIELDSET>+ <BR/>+ <FIELDSET>+ <LEGEND>Create Breakpoints</LEGEND>++ <table width="100%" style="padding: 0px; margin: 0px" id="CreateBreakpoints">+ <tr>+ <td class="rhs" align="left" colspan="2">Stop at ...</td>+ <td></td>+ </tr>+ <tr id="AllExceptions">+ <td class="rhs" align="right">All Exceptions</td>+ <td><INPUT type="CHECKBOX" + onChange="breakpoint('AllExceptions',this.checked);"+ id="AllExceptions_checkbox"+ /></td>+ </tr>+ <tr id="ThreadChange">+ <td class="rhs" align="right">All Thread Changes</td>+ <td><INPUT type="CHECKBOX" + onChange="breakpoint('ThreadChange',this.checked)"+ id="ThreadChange_checkbox"+ /></td>+ </tr>+ <tr id="ThreadTermination">+ <td class="rhs" align="right">All Thread Terminations</td>+ <td><INPUT type="CHECKBOX"+ onChange="breakpoint('ThreadTermination',this.checked)"+ id="ThreadTermination_checkbox"+ /></td>+ </tr>+ <tr>+ <td class="rhs" align="right" colspan="2">+ Thread #+ <input id="countby" name="countby" type="text" size=6 value=""+ onKeyPress="numberEnterFrom(this,event,'ThreadChangeTo','tid')">+ </td>+ </tr>+ <tr>+ <td class="rhs" align="right" colspan="2">+ Counter #+ <input id="bp_count" name="bp_count" type="text" size=8 value="" + onKeyPress="numberEnterFrom(this,event,'CounterAt','count')">+ </td>+ </tr>+ </FIELDSET>+ <SCRIPT TYPE ="text/javascript" src="/ajax.js"/>+ <SCRIPT TYPE ="text/javascript" src="/default.js"/>+ </body>+</html>
+ hpc-tracer.cabal view
@@ -0,0 +1,43 @@+name: hpc-tracer+version: 0.3.0+license: BSD3+license-file: LICENSE+Build-depends: base, hpc, unix, parsec, haskell98, network, process, containers, pretty, array+author: Andy Gill <andygill@ku.edu>+maintainer: Andy Gill <andygill@ku.edu>+homepage: http://darcs.unsafePerformIO.com/hpc-tracer+category: Trace, Test+Synopsis: Tracer with AJAX interface+description:+ An incomplete component of the Hpc toolkit which provides the+ ability to step through coverage ticks as they happen, giving a+ poor mans debugger. Requires the binary being traced to be build+ using a specific version of ghc-6.7, so YMWV.++ The plan is to port this to the new GHC API, giving both tracing+ and free variable examination via an Ajax interface.+Copyright: (c) 2006 Andy Gill, Colin Runciman, (c) 2006-2007 Galois Inc.+Stability: builds+build-type: Simple+extra-source-files:+ includefile.pl + fs/code.html+ fs/default.css+ fs/default.js+ fs/favicon.ico+ fs/footer.html+ fs/header.html+ fs/progressbar_green.gif+ fs/root.html+ fs/status.html++executable: hpc-tracer+main-is: Main.hs+hs-source-dirs: src+extensions: OverlappingInstances, RankNTypes, GADTs, TypeSynonymInstances+other-modules: Main,+ AjaxAPI,Debug,Reactive,TracerActor+ BreakPoint,Flags,StreamHandle,Utils+ CodeRenderActor,Main,TixActor+ Common,MixActor,TixStreamActor+
+ includefile.pl view
@@ -0,0 +1,26 @@+#/usr/bin/perl++$name = shift;+$bin = shift;+++print "$name :: String\n";+print "$name =\n";++if ($bin eq '-bin') {+ @file = <STDIN>;+ @file = map { split(//,$_); } @file;+ @file = map { ord $_; } @file;+ $file = join(",\n\t\t",@file);+ print "\t map toEnum [ $file ]\n";+} else {+ foreach (<STDIN>) {+ chop($_);+ s/\\/\\\\/g;+ s/\"/\\"/g;+ s/\t/\\t/g;+ print "\t\"$_\\n\" ++ \n";+ }+ print "\t\"\" -- end of $name\n"+}+
+ src/AjaxAPI.hs view
@@ -0,0 +1,224 @@+module AjaxAPI + ( module AjaxAPI+ , AjaxCallback+ ) where++import Network.AjaxServer+import Common+import Trace.Hpc.Util (HpcPos, toHpcPos, fromHpcPos)+import Trace.Hpc.Mix +import qualified Data.JSON as JSON+import Debug.Trace+import Data.Maybe+import Utils++-- The new API++setCounter :: Integer -> AjaxCallback+setCounter counter = + ajaxCallback "setCounter"+ <@> showWithCommas counter++ -- Start using Strings, for when we can name threads+setThreadID :: Int -> AjaxCallback+setThreadID tid = + ajaxCallback "setThreadID"+ <@> show tid+ +setEvent :: Event -> AjaxCallback+setEvent event = ajaxCallback "setEvent" <@> event++------------------------------------------------------------------------------++setTracerState :: TracerState -> [AjaxCallback]+setTracerState state =+ [ setCounter $ tracerCounter state+ , setThreadID $ tracerThreadID state+ , setEvent $ tracerEvent state+ , setRunning $ tracerRunning state+ ] +++ (setBreakPoints $ tracerBreakPoints state)++setTicked :: Maybe TickBoxInfo -> AjaxCallback+setTicked Nothing = ajaxCallback "setTicked" <@> JSON.Null+setTicked (Just ticked) = ajaxCallback "setTicked" <@> ticked++setBreakPoints :: BreakPoints -> [AjaxCallback]+setBreakPoints bps = + [ ajaxCallback "clearBreakPoints" + ] ++ + [ setBreakPoint bp + | bp <- bps + ]++setBreakPoint :: BreakPoint -> AjaxCallback+setBreakPoint bp = ajaxCallback "setBreakPoint2" <@> bp++setBreakPointLights :: [Bool] -> AjaxCallback+setBreakPointLights bps = ajaxCallback "setBreakPointLights" <@> bps++setRunning :: Maybe Direction -> AjaxCallback+setRunning Nothing = ajaxCallback "setRunning" <@> "Stopped"+setRunning (Just Forward) = ajaxCallback "setRunning" <@> "Forward"+setRunning (Just Backward) = ajaxCallback "setRunning" <@> "Backward"++------------------------------------------------------------------------------+--++sendTracerResponse :: TracerResponse -> [AjaxCallback]+sendTracerResponse (TracerStateResponse state) = setGUIState state+sendTracerResponse (MultiResponse responses) = concatMap sendTracerResponse responses+sendTracerResponse (ModuleListResponse mods) = [ ajaxCallback "setModules" <@> mods ]+sendTracerResponse (RunResponse count) = [ ajaxCallback "running" <@> showWithCommas count ]++------------------------------------------------------------------------------++setGUIState :: GUIState -> [AjaxCallback]+setGUIState (GUIState state ticked bps) =+ setTracerState state ++ + [setTicked ticked,+ setBreakPointLights bps]++------------------------------------------------------------------------------+-- These encodings have to be respected by the JavaScript.+-- This code is the cannonical specification of encodings.++instance JSON BreakPoint where+ toJSON (AllExceptions) = JSON.String "AllExceptions"+ toJSON (ThreadChange) = JSON.String "ThreadChange"+ toJSON (ThreadTermination) = JSON.String "ThreadTermination"+ toJSON (ThreadChangeTo n) = JSON.Object $ JSON.fromList + [ ("tag",JSON.String "ThreadChangeTo")+ , ("tid", JSON.String $ show n) -- yes, a string+ ]+ toJSON (CounterAt n) = JSON.Object $ JSON.fromList + [ ("tag",JSON.String "CounterAt")+ , ("count", JSON.String $ showWithCommas n) -- yes, a string+ ]+ toJSON (TickBox tInfo) = JSON.Object $ JSON.fromList + [ ("tag",JSON.String "TickBox")+ , ("tickInfo",toJSON tInfo)+ ]+ toJSON (ReqTickBox mod' id') = JSON.Object $ JSON.fromList + [ ("tag",JSON.String "ReqTickBox")+ , ("module",JSON.String $ mod')+ , ("id", JSON.Int $ id')+ ]+ fromJSON (JSON.String "AllExceptions") = return AllExceptions+ fromJSON (JSON.String "ThreadChange") = return ThreadChange+ fromJSON (JSON.String "ThreadTermination") = return ThreadTermination+ fromJSON (JSON.Object o) = listToMaybe $ catMaybes + [ do JSON.String "CounterAt" <- JSON.lookup "tag" o+ JSON.String n <- JSON.lookup "count" o+ () <- trace (show n) $ return ()+ case reads (filter (/= ',') n) of+ [(v,"")] -> return (CounterAt v)+ _ -> Nothing+ , do JSON.String "ThreadChangeTo" <- JSON.lookup "tag" o+ JSON.String n <- JSON.lookup "tid" o+ () <- trace (show n) $ return ()+ case reads n of+ [(v,"")] -> return (ThreadChangeTo v)+ _ -> Nothing+ , do JSON.String "TickBox" <- JSON.lookup "tag" o+ tickInfoJSON <- JSON.lookup "tickInfo" o++ tickInfo <- fromJSON tickInfoJSON+ return $ TickBox tickInfo+ , do JSON.String "ReqTickBox" <- JSON.lookup "tag" o+ JSON.String mod' <- JSON.lookup "module" o+ JSON.Int id' <- JSON.lookup "id" o+ return $ ReqTickBox mod' id'+ ]+ fromJSON _ = Nothing+++instance JSON TickBoxInfo where+ toJSON (TickBoxInfo mod' loc local_no global_no ty) = JSON.Object $ JSON.fromList + [ ("module", JSON.String mod')+ , ("location", toJSON loc)+ , ("local", JSON.Int local_no)+ , ("global", JSON.Int global_no)+ , ("tickType", toJSON ty)+ ]++ fromJSON (JSON.Object o) = do+ mod' <- findJSON "module" o+ loc <- findJSON "location" o+ local_no <- findJSON "local" o+ global_no <- findJSON "global" o+ ty <- findJSON "tickType" o+ return $ TickBoxInfo mod' loc local_no global_no ty+ fromJSON _ = Nothing++instance JSON HpcPos where + toJSON pos = JSON.Object $ JSON.fromList + [ ("startLine",JSON.Int startLine)+ , ("startCol", JSON.Int startCol)+ , ("endLine", JSON.Int endLine)+ , ("endCol", JSON.Int endCol)+ ]+ where (startLine,startCol,endLine,endCol) = fromHpcPos pos+ fromJSON (JSON.Object o) = do+ startLine <- findJSON "startLine" o+ startCol <- findJSON "startCol" o+ endLine <- findJSON "endLine" o+ endCol <- findJSON "endCol" o+ return $ toHpcPos (startLine,startCol,endLine,endCol)+ fromJSON _ = Nothing++instance JSON BoxLabel where + toJSON (ExpBox False) = JSON.String "ExpBox"+ toJSON (ExpBox True) = JSON.String "AltBox"+ toJSON (TopLevelBox path) = JSON.Object $ JSON.fromList + [ ("tag", JSON.String "TopLevelBox")+ , ("path", toJSON $ path)+ ]+ toJSON (LocalBox path) = JSON.Object $ JSON.fromList + [ ("tag", JSON.String "LocalBox")+ , ("path", toJSON $ path)+ ]+ toJSON (BinBox GuardBinBox bool) = JSON.Object $ JSON.fromList + [ ("tag", JSON.String "GuardBinBox")+ , ("value", toJSON $ bool)+ ]+ toJSON (BinBox CondBinBox bool) = JSON.Object $ JSON.fromList + [ ("tag", JSON.String "CondBinBox")+ , ("value", toJSON $ bool)+ ]+ toJSON (BinBox QualBinBox bool) = JSON.Object $ JSON.fromList + [ ("tag", JSON.String "QualBinBox")+ , ("value", toJSON $ bool)+ ]+ toJSON _ = error "toJSON" ++ fromJSON (JSON.String "ExpBox") = return $ ExpBox False+ fromJSON (JSON.String "AltBox") = return $ ExpBox True+ fromJSON (JSON.Object o) = altsJSON + [ do "TopLevelBox" <- findJSON "tag" o+ path <- findJSON "path" o+ return $ TopLevelBox path+ , do "LocalBox" <- findJSON "tag" o+ path <- findJSON "path" o+ return $ LocalBox path+ , do "GuardBinBox" <- findJSON "tag" o+ value <- findJSON "value" o+ return $ BinBox GuardBinBox value+ , do "CondBinBox" <- findJSON "tag" o+ value <- findJSON "value" o+ return $ BinBox CondBinBox value+ , do "QualBinBox" <- findJSON "tag" o+ value <- findJSON "value" o+ return $ BinBox QualBinBox value+ ]+ fromJSON _ = error "fromJSON"++instance JSON Event where + toJSON (Tick tick) = JSON.Object $ JSON.fromList + [ ("tag", JSON.String "Tick")+ , ("tick", JSON.Int tick)+ ]+ toJSON (Raise) = JSON.String "Raise"+ toJSON (ThreadFinished) = JSON.String "ThreadFinished"+ toJSON (Finished) = JSON.String "Finished"+ fromJSON _ = error "fromJSON"
+ src/BreakPoint.hs view
@@ -0,0 +1,73 @@+module BreakPoint where++import Common+import TixActor +import Data.List+import qualified Data.Set as Set+import Data.Set (Set)++setBreakPoint :: BreakPoint -> BreakPoints -> BreakPoints+setBreakPoint bp bps + | bp `elem` bps = bps+ | otherwise = bps ++ [bp]+clearBreakPoint :: BreakPoint -> BreakPoints -> BreakPoints+clearBreakPoint bp bps = filter (/= bp) bps++-- This is where we lookup the module, local tick number, +-- at turn it into a complete tick info structure.++normalizeBreakPoint :: TixActor -> BreakPoint -> IO BreakPoint+normalizeBreakPoint tixActor (ReqTickBox modName localTickId) = do+ tickInfo <- lookupLocalTickInfo tixActor modName localTickId+ return $ TickBox tickInfo+normalizeBreakPoint tixActor other = return $ other++isBreakPoint :: TracerState -> Bool+isBreakPoint = or . checkBreakPoints++checkBreakPoints :: TracerState -> [Bool]+checkBreakPoints state = map isBP (tracerBreakPoints state)+ where+ counter = tracerCounter state+ isBP (CounterAt count) = counter == count+ isBP (AllExceptions) = case tracerEvent state of+ Raise -> True+ _ -> False+{-+ isBP (ThreadChange) = case tracerEvent state of+ Thread {} -> True+ _ -> False+ isBP (ThreadChangeTo id1) + = case tracerEvent state of+ Thread id2 -> id1 == id2+ _ -> False+-}+ isBP (ThreadTermination)+ = case tracerEvent state of+ ThreadFinished -> True+ _ -> False+ isBP (TickBox info) = case tracerEvent state of+ Tick i -> i == tbiGlobalTickNo info+ _ -> False++ isBP _ = False++++nextCounterBreakPoint :: TracerState -> Maybe Integer+nextCounterBreakPoint state =+ case counter_bps of+ [] -> Nothing+ (n:_) -> Just n+ where+ counter_bps = sort + [ n | CounterAt n <- tracerBreakPoints state+ -- must be in the future+ , n > tracerCounter state+ ]+++tickIdBreakPointSet :: TracerState -> Set GlobalTickId+tickIdBreakPointSet state = Set.unions $+ [ Set.singleton (tbiGlobalTickNo info) | TickBox info <- tracerBreakPoints state ]+
+ src/CodeRenderActor.hs view
@@ -0,0 +1,179 @@+module CodeRenderActor where+++import Trace.Hpc.Mix+import Trace.Hpc.Tix+import Trace.Hpc.Util++import Data.List++import Data.Maybe(fromJust)+import Reactive+import Common+++codeRenderActor :: String -> String -> IO (String -> IO String)+codeRenderActor hpcDir srcDir = do+ mkActor [] $ + request $ \ file state -> do+ (contents,state') + <- case lookup file state of+ Nothing -> do + contents <- createHtml hpcDir srcDir file+ return (contents,(file,contents) : state)+ Just contents -> do+ return (contents,state)++ let wrap = "<html><HEAD>" +++ "<LINK REL =\"stylesheet\" HREF =\"default.css\" TYPE =\"text/css\"></LINK></HEAD>" +++ "<body>" ++ contents ++ + "<script type=\"text/javascript\">\n" +++ "parent.status.codeloaded( " ++ show file ++ ");\n" +++ "</script>\n" +++ "</body></html>"+ return (wrap,state')+++------------------------------------------------------------------------------++createHtml :: String -> String -> String -> IO String+createHtml hpcDir srcDir modName = do+ + mix@(Mix origFile _ _ tabStop mix') <- readMix [srcDir ++ "/" ++ hpcDir] (Left modName)++-- print mix++ let info = [ (pos,id)+ | (id,(pos,boxLabel)) <- zip [0 ..] mix'+{-+ , case boxLabel of+ ExpBox {} -> True+ AltBox {} -> True+ TopLevelBox {} -> True+ LocalBox {} -> True+ _ -> False+-}+ ]++ let tickLocs = [ (Loc ln1 c1,Loc ln2 c2,id)+ | (pos,id) <- info+ , let (ln1,c1,ln2,c2) = fromHpcPos pos+ ]++ let sortedTickLocs = sortBy (\ (locA1,locZ1,_) (locA2,locZ2,_) ->+ (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs++-- print sortedTickLocs++ content <- readFileFromPath origFile srcDir++ let content' = addMarkup 1 content (Loc 1 1) [] sortedTickLocs+ let show' = reverse . take 5 . (++ " ") . reverse . show+ let addLine n xs = "<span class=\"lineno\">" ++ show' n ++ " </span>" ++ xs + let addLines = unlines . map (uncurry addLine) . zip [1..] . lines+ return ("<pre>\n" ++ addLines content' ++ "\n</pre>\n")++type Markup = Int++addMarkup :: Int -- tabStop+ -> String -- text to mark up+ -> Loc -- current location+ -> [(Loc,Markup)] -- stack of open ticks, with closing location+ -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs+ -> String++-- check the pre-condition.+--addMarkup tabStop cs loc os ticks +-- | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os++--addMarkup tabStop cs loc os@(_:_) ticks +-- | trace (show (loc,os,take 10 ticks)) False = undefined++-- close all open ticks, if we have reached the end+addMarkup _ [] loc os [] =+ concatMap (const closeTick) os +addMarkup tabStop cs loc ((o,_):os) ticks | loc > o =+ closeTick ++ addMarkup tabStop cs loc os ticks++--addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 =+-- openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks++addMarkup tabStop cs loc os ((t1,t2,tik):ticks) | loc == t1 =+ openTick tik ++ addMarkup tabStop cs loc (addTo (t2,tik) os) ticks+ where++ addTo (t,tik) [] = [(t,tik)]+ addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs+ | t > t' = (t',tik):(t',tik'):xs ++addMarkup tabStop cs loc os ((t1,t2,tik):ticks) | loc > t1 =+ -- throw away this tick, because it is from a previous place ??+ addMarkup tabStop cs loc os ticks++addMarkup tabStop ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks + | ln == ln2 && col < col2+ = addMarkup tabStop (' ':'\n':cs) loc os ticks +addMarkup tabStop (c:cs) loc@(Loc _ p) os ticks =+ if c=='\n' && os/=[] then+ c : "<span class=\"spaces\">" ++ expand 1 w ++ "</span>" +++ addMarkup tabStop cs' loc' os ticks+ else if c=='\t' then+ expand p "\t" ++ addMarkup tabStop cs (incBy c loc) os ticks+ else+ escape c ++ addMarkup tabStop cs (incBy c loc) os ticks+ where+ (w,cs') = span (`elem` " \t") cs+ loc' = foldl (flip incBy) loc (c:w)+ escape '>' = ">"+ escape '<' = "<"+ escape '"' = """+ escape '&' = "&"+ escape c = [c]++ expand :: Int -> String -> String+ expand _ "" = "" + expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s+ where+ c' = tabStopAfter 8 c+ expand c (' ':s) = ' ' : expand (c+1) s+ expand _ _ = error "bad character in string for expansion"+ + incBy :: Char -> Loc -> Loc+ incBy '\n' (Loc ln c) = Loc (succ ln) 1+ incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop c)+ incBy _ (Loc ln c) = Loc ln (succ c)+ + tabStopAfter :: Int -> Int -> Int+ tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..])+ +addMarkup tabStop cs loc os ticks = + "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks)++data Loc = Loc !Int !Int+ deriving (Eq,Ord,Show)++openTick :: Markup -> String+openTick n = "<span class=\"tick\" id=\"t_" ++ show n ++ "\">" ++closeTick = "</span>"++++readFileFromPath :: String -> String -> IO String+readFileFromPath filename@('/':_) _ = readFile filename+readFileFromPath filename path = readTheFile (splitPath path)+ where+ splitPath path = case span (/= ':') path of+ (dir,':':more) -> dir : splitPath more+ (dir,[]) -> [dir]++ readTheFile :: [String] -> IO String+ readTheFile [] = error $ "could not find " ++ show filename + ++ " in path " ++ show path+ readTheFile (dir:dirs) = + Prelude.catch + (do str <- readFile (dir ++ "/" ++ filename) + return str) + (\ _ -> readTheFile dirs)++------------------------------------------------------------------------------
+ src/Common.hs view
@@ -0,0 +1,109 @@+module Common where++import Trace.Hpc.Util (HpcPos)+import Trace.Hpc.Mix (BoxLabel)++------------------------------------------------------------------------------+-- |An @Event@ is an item in the stream from the debugged process.++-- our debugging trail is a list of events.+data Event = Tick !Int -- The global tick number+ | Raise -- Any Raised exception+ | ThreadFinished -- last event in a Thread+ | Finished -- final event++------------------------------------------------------------------------------+-- |@TracerRequest@ are requests made by the Ajax interface of the debuggger.++data TracerRequest + = StepRequest Direction+ | InitRequest -- ^called at initialization time, to set things up+ | RunRequest Direction -- until a breakpointable event+ | SetBreakPoint BreakPoint+ | ClearBreakPoint BreakPoint+ | ContinueRequest -- ^keep running (looking for a breakpoint)+ | StopRequest -- ^stop please (looking for a breakpoint)++data Direction = Forward | Backward+ deriving Show++------------------------------------------------------------------------------+-- |The @TracerState@ is the micro-architecture of the debugger; what information+-- we hold onto from step to step.++data TracerState = TracerState+ { tracerCounter :: !Integer -- ^the cursor+ , tracerThreadID :: !ThreadID -- ^what thread is currently active+ , tracerEvent :: !Event -- ^The current event+ , tracerBreakPoints :: !BreakPoints+ , tracerRunning :: Maybe Direction -- ^looking for a breakpoint+ }+ deriving Show++-- Consider include the global id as well as the local id here.+data TickBoxInfo = TickBoxInfo+ { tbiModule :: !String -- ^what module is at this cursor+ , tbiLocation :: !HpcPos -- ^where is the cursor in the source?+ , tbiLocalTickNo :: !LocalTickId -- ^local tick number, for displaying+ , tbiGlobalTickNo :: !GlobalTickId -- ^global tick number+ , tbiTickType :: !BoxLabel -- ^possible style of highlight+ }+ deriving (Show, Eq, Ord)++type BreakPoints = [BreakPoint] -- does not include any abrevited breakpoints.++data BreakPoint + = AllExceptions+ | ThreadChange+ | ThreadTermination+ | ThreadChangeTo ThreadID+ | CounterAt Integer+ | TickBox TickBoxInfo++-- These are abreviated versions sent from the GUI, +-- which does not have access to things like tick box location information.+ | ReqTickBox String LocalTickId++ deriving (Show, Eq, Ord)++------------------------------------------------------------------------------+-- This is basically the TracerState, with some derived infomation.++data GUIState = GUIState + { guiTracerState :: TracerState+ , guiTracerTicked :: Maybe TickBoxInfo -- which tick box to light up+ , guiTracerBreakers :: [Bool] -- which breakpoints to light up+ }++------------------------------------------------------------------------------+-- The @TracerResponse@ is what messages get sent back to the GUI about+-- changes in the TracerState.++data TracerResponse+ = TracerStateResponse !GUIState -- ^The brute force update; just update everything!+ | MultiResponse [TracerResponse] -- ^For when you want to send several responses+ | ModuleListResponse [String] -- ^A list of all possible modules in this program+ | RunResponse !Integer -- ^The curent cursor when looking for a breakpoint++type ThreadID = Int -- Threads later will be strings+type GlobalTickId = Int -- tick number inside a specific executable+type LocalTickId = Int -- tick number inside a specific module++------------------------------------------------------------------------------++instance Show Event where+ show (Tick n) = show n+ show (Raise) = "Raise"+ show (ThreadFinished) = "ThreadFinished"+ show (Finished) = "Finished"++instance Read Event where+ readsPrec _p ('R':'a':'i':'s':'e':xs)+ = [(Raise,xs)]+ readsPrec _p ('T':'h':'r':'e':'a':'d':'F':'i':'n':'i':'s':'h':'e':'d':xs) + = [(ThreadFinished,xs)]+ readsPrec _p ('F':'i':'n':'i':'s':'h':'e':'d':xs)+ = [(Finished,xs)]+ readsPrec p xs = [ (Tick n,ys) | (n,ys) <- readsPrec p xs ]+ +
+ src/Debug.hs view
@@ -0,0 +1,9 @@+module Main where+++fib :: Int -> Int+fib n = if n < 2 then 1 else fib(n-1) + fib (n-2)++main = print $ fib 30++
+ src/Flags.hs view
@@ -0,0 +1,38 @@+module Flags where+++-- Where to get the debugging stream from+data Mode+ = ExecMode String [String]+ | FileMode String+ | AddrMode String Int++data Flags = Flags+ { mode :: Mode + , hpcdir :: String+ , srcdir :: String+ , port :: Int -- ^which port to provide HTTP on for Ajax viewer+ , woop :: Int -- ^window of opertunity+ }+++-- Hack for now++parseFlags :: [String] -> Flags+parseFlags ("--port":num:args) + = (parseFlags args)+ { port = read num }+parseFlags ("--hpcdir":dir:args) + = (parseFlags args)+ { hpcdir = dir }+parseFlags ("--srcdir":dir:args) + = (parseFlags args)+ { srcdir = dir }+parseFlags (arg:args) = Flags (ExecMode arg args)+ (".hpc")+ (".")+ 8091+ 10000+++
+ src/Main.hs view
@@ -0,0 +1,118 @@+-- The Hpc tracer viewer/debugger++module Main where++import Trace.Hpc.Mix+import Trace.Hpc.Tix+import Trace.Hpc.Util++import Control.Concurrent+import Control.Exception as Exc+import Control.Concurrent.MVar++import Network.TrivialWebServer+import Network.AjaxServer++import System.Environment (getArgs, withArgs)++++import Reactive+import Common++import MixActor+import TixActor+import CodeRenderActor+import TixStreamActor+import TracerActor+import AjaxAPI++import CachedFiles++import Flags+import StreamHandle++------------------------------------------------------------------------------++main = do+ args <- getArgs + let flags = parseFlags args+ + (d_h,c_h) <- openStream flags++ step <- tracerActor (hpcdir flags) (srcdir flags) d_h c_h++ let tracerActor :: TracerRequest -> IO [AjaxCallback]+ tracerActor req = do resp <- step req+ let respTxt = sendTracerResponse resp+-- print respTxt+ return $ respTxt++ toScreenRender <- codeRenderActor (hpcdir flags) (srcdir flags)++ let mkPage ty body = return $ PageResponse 200 False ty body++ let rpc = alts $+ [ call "boot" (tracerActor InitRequest)+{-+ , call "step" (\ (n :: Int) -> tracerActor (StepRequest Forward))+ <*> jsonArg "count"+-}+ , call "step/forward" (tracerActor (StepRequest Forward))+ , call "step/backward" (tracerActor (StepRequest Backward))+ , call "run/forward" (tracerActor (RunRequest Forward))+ , call "run/backward" (tracerActor (RunRequest Backward))+ , call "run/backward" (tracerActor (RunRequest Backward))+ , call "please/continue" (tracerActor ContinueRequest)+ , call "please/stop" (tracerActor StopRequest)+ ] +++ [ jsonArg "status" <*>+ jsonArg "breakpoint" <*>+ call ("breakpoint")+ ( \ bp onOff -> tracerActor + $ (if onOff then SetBreakPoint + else ClearBreakPoint)+ $ bp+ )+ ] {- ++++ [ jsonArg "name" <*>+ call "usertext" (\ name value -> do print (name::String,value::String)+ return [])+ ] -}+ -- later, implement http://..:8091/modules/Foo as the render engine+ let pageRpc = alts+ [ jsonArg "module" <*>+ call "modulecode" (\ mod -> do+ txt <- toScreenRender mod+ mkPage "text/html" txt)+ ]+++ mVar <- newEmptyMVar ++ let pages :: String -> IO PageResponse+ pages "/favicon.ico" = mkPage "text/ico" favicon+ pages "/progress.gif" = mkPage "image/gif" progress+ pages "/" = mkPage "text/html" root_html+ pages "/code.html" = mkPage "text/html" code_html+ pages "/header.html" = mkPage "text/html" header_html+ pages "/status.html" = mkPage "text/html" status_html+ pages "/footer.html" = mkPage "text/html" footer_html+ pages "/default.css" = do+ -- hack to improve compile cycle.+-- default_css <- readFile "/Users/andy/darcs/hpc/tools/tracer/fs/default.css"+ mkPage "text/css" default_css+ pages "/default.js" = do+ -- hack to improve compile cycle.+-- default_js <- readFile "/Users/andy/darcs/hpc/tools/tracer/fs/default.js"+ mkPage "text/js" default_js+ pages "/quit" = do putMVar mVar ()+ mkPage "text/html" "aborting"+ pages other = do print other+ mkPage "text/html" other++ forkIO $ ajaxServer (port flags) rpc pageRpc pages++ takeMVar mVar+ return ()
+ src/MixActor.hs view
@@ -0,0 +1,9 @@+module MixActor where++import Trace.Hpc.Mix+import Reactive++-- Cache the Mix file inside here.+mixActor :: String -> String -> IO (String -> IO Mix)+mixActor hpcDir srcDir = return $+ \ file -> readMix [srcDir ++ "/" ++ hpcDir] (Left file)
+ src/Reactive.hs view
@@ -0,0 +1,107 @@+module Reactive where++import Control.Concurrent+import Control.Exception as Exc+import Control.Concurrent.MVar++type Method s d = ((s -> IO s) -> IO ()) -> d+ +mkActor :: s -> Method s d -> IO d+mkActor initState body = do+ chan <- newChan++ let loop state = do body <- readChan chan+ state' <- body state+ loop state'++ myForkIO $ loop initState++ return $ body (writeChan chan)++request :: (a -> s -> IO (r,s)) -> Method s (a -> IO r)+request fn send arg = do+ m <- newEmptyMVar + send (\ st -> do (rep,st') <- fn arg st+ putMVar m rep+ return st')+ takeMVar m ++mkActor3 :: s + -> ( (forall r . (s -> IO (r,s)) -> IO r) + -> ( (s -> IO s) -> IO ()) + -> actor)+ -> IO actor+mkActor3 initState body = do+ state <- newMVar initState++ let reqs fn = do + s <- takeMVar state+ (r,s') <- fn s+ putMVar state s'+ return r++ let acts = undefined++ return $ body reqs acts++mkActor2 :: s + -> ( (forall r . (s -> IO (r,s)) -> IO r) + -> ( (s -> IO s) -> IO ()) + -> actor)+ -> IO actor+mkActor2 initState body = do+ chan <- newChan++ let loop state = do body <- readChan chan+ state' <- body state+ loop state'++ myForkIO $ loop initState++ let reqs fn = do+ m <- newEmptyMVar + writeChan chan $ \ st -> do (rep,st') <- fn st+ putMVar m rep+ return st'+ takeMVar m ++ let acts fn = do+ writeChan chan $ \ st -> fn st++ return $ body reqs acts++request2 :: ((s -> IO s) -> IO ()) -> (s -> IO (r,s)) -> IO r+request2 send fn = do+ m <- newEmptyMVar + send (\ st -> do (rep,st') <- fn st+ putMVar m rep+ return st')+ takeMVar m ++action :: (a -> s -> IO s) -> Method s (a -> IO ())+action fn send arg = send (fn arg)++test = mkActor ((99 :: Int))+ $ request (\ _a s -> return (show s,s + 1)) ++myForkIO m = do+ forkIO (m `Exc.catch` \ e -> do+ print "thread problem: "+ print e+ return ())++------------------------------------------------------------------------------++liftMethod :: ((a1 -> IO r1) -> (a2 -> IO r2) -> r)+ -> Method s (a1 -> IO r1) + -> Method s (a2 -> IO r2)+ -> Method s r+liftMethod fn m1 m2 arg = fn (m1 arg) (m2 arg)++lift3Method :: ((a1 -> IO r1) -> (a2 -> IO r2) -> (a3 -> IO r3) -> r)+ -> Method s (a1 -> IO r1) + -> Method s (a2 -> IO r2)+ -> Method s (a3 -> IO r3)+ -> Method s r+lift3Method fn m1 m2 m3 arg = fn (m1 arg) (m2 arg) (m3 arg)+
+ src/StreamHandle.hs view
@@ -0,0 +1,44 @@+module StreamHandle where++import System.Posix.Process+import System.Posix.IO+import System.Posix.Env+import System.IO+import System.Exit+import Control.Concurrent ++import System.Cmd++import Flags ++openStream :: Flags -> IO (Handle,Handle)+openStream flags =+ case mode flags of+ ExecMode exec args -> do++ (cmd_rd,cmd_wt) <- createPipe + (event_rd,event_wt) <- createPipe ++ pid <- getProcessID++ forkProcess $ do+ closeFd cmd_wt+ closeFd event_rd+ t1 <- getEnv "HPCRIX"+ unsetEnv "HPCRIX"+ setEnv "HPCRIX" (show event_wt ++ ":" ++ show cmd_rd) True+ t2 <- getEnv "HPCRIX"+ executeFile exec False args Nothing+ -- should never return+ return ()++ d_h <- fdToHandle event_rd+ c_h <- fdToHandle cmd_wt++ closeFd cmd_rd+ closeFd event_wt++ return (d_h,c_h)+ FileMode filename ->+ undefined+
+ src/TixActor.hs view
@@ -0,0 +1,88 @@+module TixActor where++import Trace.Hpc.Mix++import Data.Array.MArray+import Data.Array.IO++import Reactive+import MixActor++import Common++data TixActor = TixActor + { lookupGlobalTickInfo :: GlobalTickId -> IO TickBoxInfo+ , lookupLocalTickInfo :: String -> LocalTickId -> IO TickBoxInfo+ }++globalTixActor :: String + -> String + -> [(String,Int)] + -> IO TixActor+globalTixActor hpcDir srcDir modSizes = do+ getMix <- mixActor hpcDir srcDir++ let modOffsets = 0 : zipWith (+) (map snd modSizes) modOffsets ++ let modInfo = [ (mod,(sz,offset))+ | ((mod,sz),offset) <- zip modSizes modOffsets+ ]+ +-- print modInfo++ let maxTixId = sum (map snd modSizes) - 1++ -- fill the array with module name initially++ arr <- newListArray (0::Int,maxTixId) $+ concat [ [ Left mod | _ <- take sz [0..] ]+ | (mod,sz) <- modSizes+ ]++ let _types = (arr :: IOArray Int (Either String TickBoxInfo))++ let fillIn modName = do+ case lookup modName modInfo of+ Nothing -> print $ "can not find : " ++ show modName+ + Just (sz,offset) -> do+ mix@(Mix _ _ _ _ mix') <- getMix modName+ -- assert length mix' == sz+-- print ("writing",offset,length mix' + offset - 1,sz,length mix',modName)+ sequence_ [ do writeArray arr ix $ Right $ TickBoxInfo + modName+ loc+ lix+ ix+ ty+ | (lix,ix,(loc,ty)) <- zip3 [0..] [offset..] mix'+ ]++ let findVal :: GlobalTickId -> IO TickBoxInfo+ findVal n = do+ val <- readArray arr n+ case val of+ Left modName -> do + fillIn modName + val' <- readArray arr n+ case val' of+ Left modName' -> do+ print ("problem with loading array" ++ show (val,val',n))+ error ""+ Right val' -> return $ val'+ Right val -> return $ val+ + let initState = ()++ mkActor2 initState (\ request action -> TixActor+ { lookupGlobalTickInfo = \ globId -> request $ \ () -> do+ -- print ("glob=",globId)+ val <- findVal globId+ -- print ("find:",val)+ return (val,())+ , lookupLocalTickInfo = \ modName localId -> request $ \ () -> do+ case lookup modName modInfo of+ Just (_,offset) -> do val <- findVal (localId + offset)+ return (val,())+ Nothing -> error $ "bad module" ++ modName+ })
+ src/TixStreamActor.hs view
@@ -0,0 +1,174 @@+-- TODO: renamed as RixStreamActor++module TixStreamActor (readTickActor, StreamActorResult(..), finished) where++import Data.List as List+import System.IO+import Reactive++import Common++import Debug.Trace+import Data.Set(Set)+import qualified Data.Set as Set++data State = State + { cursor :: ThreadedEvent+ , count :: !Integer -- where we are + , target :: !Integer -- where we are going to+ , before :: ![ThreadedEvent]+ , after :: ![ThreadedEvent]+ , stopAtTicks :: Set GlobalTickId+ , remoteStopAtTicks + :: Set GlobalTickId+ } deriving (Show)+++finished :: State -> Bool+finished state = case cursor state of+ ThreadedEvent Finished _ -> True+ _ -> False ++-- Move this into TixStream.+data ThreadedEvent = ThreadedEvent !Event !ThreadID+ deriving (Show)++addEvent :: Event -> State -> ThreadedEvent+addEvent ev (State { cursor = ThreadedEvent _ tid }) = ThreadedEvent ev tid++data StreamActorResult + = StreamActorResult + { counter :: !Integer -- ^global tick counter+ , event :: !Event -- ^event at the cursor+ , threadId :: !ThreadID -- ^the current thread (before/at the event)+ , live :: !Bool -- ^is this the live event (False == historical result)+ }++-- move forward or back, finding the tick number.+readTickActor :: Handle -> Handle -> IO (Integer -> Set GlobalTickId -> IO StreamActorResult)+readTickActor d_handle cmd_handle = do+ -- Will this help+-- t <- hGetBuffering d_handle+-- print t++-- hSetBuffering d_handle (LineBuffering)+-- hSetBuffering cmd_handle (LineBuffering)++ tixTxt <- hGetLine d_handle+ let (0,threadId',event') = parseEvent tixTxt++ let initState = + State { cursor = ThreadedEvent event' threadId'+ , count = 0+ , target = 0+ , before = []+ , after = []+ , stopAtTicks = Set.empty+ , remoteStopAtTicks = Set.empty+ }++ let pull' :: Integer -> Set GlobalTickId -> State -> IO State+ pull' n ticks state = pull $ state { target = n+ , stopAtTicks = ticks+ }++ -- check for breakpoint+ check :: State -> IO State+ check state@State { stopAtTicks = stopTicks, cursor = ThreadedEvent (Tick tickid) _ }+ | tickid `Set.member` stopTicks = return state+ check state = pull state++ pull :: State -> IO State+ pull state@State { target = n , count = c } +-- | trace (show state) False = undefined++ -- reached target+ | n == c = return state++ | n > c && null (after state) && not (finished state) = do+ -- We need to read a new entry from the remote process+ -- set break at the target+ hPutStrLn cmd_handle ("c" ++ show n) -- set counter bp+ sequence [ do hPutStrLn cmd_handle ("u" ++ show x) +-- print ("unseting bp at ",x)+ | x <- Set.elems $ remoteStopAtTicks state+ ]+ sequence [ do hPutStrLn cmd_handle ("s" ++ show x) +-- print ("seting bp at ",x)+ | x <- Set.elems $ stopAtTicks state+ ]+ hPutStrLn cmd_handle ("") -- run+ hFlush cmd_handle+ +-- print ("waiting for message")+ -- and wait for the breakpoint to activate+ tixTxt <- hGetLine d_handle+-- print ("got : ",tixTxt)+-- print tixTxt+ let (count',threadId',event') = parseEvent tixTxt++ let before' = if c == count' - 1+ then cursor state : before state+ else []++ -- something interesting happened so we return anyway.++ return $ state { cursor = ThreadedEvent event' threadId' + , count = count'+ , before = before'+ , remoteStopAtTicks = stopAtTicks state+ }++ | n > c && not (null $ after state) = + check (state { cursor = head $! after state + , count = count state + 1+ , before = cursor state : before state+ , after = tail $! after state+ })++ | n < c && (null $ before state) && (current_loc /= 0) = do+ -- we want to rewind here, so we pull some history+ hPutStrLn cmd_handle ("h") -- history+ hFlush cmd_handle++ befores <-+ sequence [ do tixTxt <- hGetLine d_handle+-- print ("got(h): ",tixTxt)+ let (count',threadId',event') = parseEvent tixTxt+ if count' /= ix + then error $ "strangeness" ++ show (ix,count')+ else return $ ThreadedEvent event' threadId'+ | ix <- [(max 0 (current_loc - 1024)) .. (current_loc - 1) ]+ ]++ pull $ state { before = drop (length $ after state) $ reverse befores }++ | n < c && not (null $ before state) = + check (state { cursor = head $! before state + , count = count state - 1+ , before = tail $! before state+ , after = cursor state : after state+ })++ | otherwise = return state++ where + current_loc = c + fromIntegral (length (after state))+++ mkActor2 initState $ \ request action targetCount tickBreakPoints ->+ request $ \ state -> do+ state' <- pull' targetCount tickBreakPoints state+ let (ThreadedEvent event tid) = cursor state'+ let isLive = not (List.null $ after state')+ return (StreamActorResult (count state') event tid isLive,state')+++parseEvent :: String -> (Integer,ThreadID,Event)+parseEvent xs = case words xs of+ ["Event",counter,tid,op] + -> (read counter, read tid, read op)+ _ -> error $ "parseEvent failure: " ++ show xs+++
+ src/TracerActor.hs view
@@ -0,0 +1,188 @@+module TracerActor where++import Trace.Hpc.Mix+import Trace.Hpc.Util++import System.IO+import qualified Data.Set as Set++import TixActor+import TixStreamActor++import Reactive+import Common+import BreakPoint++import Control.Concurrent++-- The main actor++data State = State+ { count :: Integer+ }++type TracerActorState = (Maybe TracerState,TracerState)+++tracerActor :: String + -> String + -> Handle -> Handle -> IO (TracerRequest -> IO TracerResponse)+tracerActor hpcDir srcDir d_handle cmd_handle = do + starts <- hGetLine d_handle+ mods <- hGetLine d_handle++ getTix <- readTickActor d_handle cmd_handle++ StreamActorResult { counter = count+ , event = tixInfo+ , threadId = tid+ , live = isLive+ } <- getTix 0 (Set.empty)++ -- We actually store a pair of states, + -- - the current state according to the GUI,+ -- - and the current state.++ let initState = TracerState + { tracerCounter = count+ , tracerThreadID = tid+ , tracerEvent = tixInfo+ , tracerBreakPoints = []+ , tracerRunning = Nothing+ }++-- print mods+ + let send v = return (v,0)++ let modSizes :: [(String,Int)]+ modSizes = read mods+ + -- we will need to improve this in the future+ tixActor <- globalTixActor hpcDir srcDir modSizes+++ let record Nothing newState = do+ return ( MultiResponse+ [ ModuleListResponse (map fst modSizes)+ , TracerStateResponse (GUIState newState Nothing [])+ ]+ , (Just newState,newState)+ )++ record (Just oldState) newState = do+ opt_ticked <- + case tracerRunning newState of+ Nothing -> + case tracerEvent newState of+ Tick tixNo -> do+ tixInfo <- lookupGlobalTickInfo tixActor tixNo+ return $ Just tixInfo+ _ -> return $ Nothing+ _ -> return $ Nothing+-- print (oldState,newState)+ return ( TracerStateResponse $+ GUIState + { guiTracerState = newState+ , guiTracerTicked = opt_ticked+ , guiTracerBreakers = checkBreakPoints newState+ }+ , (Just newState,newState)+ )+++ let setBP bp state0 = do+ bp' <- normalizeBreakPoint tixActor bp+ let state1 = state0 { tracerBreakPoints = setBreakPoint bp' $ tracerBreakPoints state0 }+-- print $ tracerBreakPoints state1+ return state1++ let clearBP bp state0 = do+ bp' <- normalizeBreakPoint tixActor bp+ let state1 = state0 { tracerBreakPoints = clearBreakPoint bp' $ tracerBreakPoints state0 }+-- print $ tracerBreakPoints state1+ return state1++ let dir Forward = 1+ dir Backward = -1++ let step d state0 = do+-- print "step(1)"+ StreamActorResult { counter = count+ , event = tixInfo+ , threadId = tid+ } <- getTix (fromIntegral d + tracerCounter state0) + (tickIdBreakPointSet state0)++-- print "step(2)"+-- print ("284",count,tixInfo)++ let state1 = state0 { tracerCounter = count+ , tracerThreadID = tid+ , tracerEvent = tixInfo+ }+ return state1++ searchForBP :: Direction+ -> ((TracerActorState -> IO TracerActorState) -> IO ()) + -> TracerActorState+ -> IO TracerActorState+ searchForBP d action (oldState,state0 @ TracerState { tracerRunning = Nothing }) + = return $ (oldState,state0)++ searchForBP d action (oldState,state0) = do+ let steps = 314159 -- large(ish) prime, also pi * 100,000+ let target = ((dir d * steps + tracerCounter state0) `div` steps) * steps+ let next_bp = case nextCounterBreakPoint state0 of+ Nothing -> target+ Just target' -> min target' target+ res <- getTix next_bp (tickIdBreakPointSet state0)+ case res of+ StreamActorResult + { counter = count+ , event = tixInfo+ , threadId = tid+ } -> do+ let state1 = state0 { tracerCounter = count+ , tracerThreadID = tid+ , tracerEvent = tixInfo+ }++ case tixInfo of+ _ | isBreakPoint state1 -> return $ (oldState, state1 { tracerRunning = Nothing })+ Finished -> return $ (oldState, state1 { tracerRunning = Nothing })+ _ | otherwise -> do+ action (searchForBP d action)+ return $ (oldState,state1)+ _ -> error "bad actor"++ initRunToBP d action state0 = do+ action (searchForBP d action)+ let state1 = state0 { tracerRunning = Just $ d }+ return state1++ mkActor2 (Nothing,initState) $ \ request action req -> + request $ \ (state0,state1) -> do+ state2 <- case req of+ InitRequest -> return $ state1+ StepRequest Forward -> step 1 state1+ StepRequest Backward -> step (-1) state1+ RunRequest Forward -> initRunToBP Forward action state1+ RunRequest Backward -> initRunToBP Backward action state1+ (SetBreakPoint bp) -> setBP bp state1+ (ClearBreakPoint bp) -> clearBP bp state1+ ContinueRequest -> return $ state1+ StopRequest -> return $ state1 { tracerRunning = Nothing }++ record state0 state2++------------------------------------------------------------------------------++showUsingXml :: [(String,[(String,String)])] -> String+showUsingXml cmds = + "<?xml version=\"1.0\"?>" +++ "<cmds>" ++ + unlines [ "<" ++ cmd ++ concatMap showArgs args ++ "/>" | (cmd,args) <- cmds ] +++ "</cmds>\n"+ where showArgs (nm,val) = " " ++ nm ++ "=\"" ++ val ++ "\""+
+ src/Utils.hs view
@@ -0,0 +1,10 @@+module Utils where++showWithCommas :: Integer -> String+showWithCommas n = showBigNum n+ where showBigNum n | n <= 9999 = show n+ | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000)+ showBigNum' n | n <= 999 = show n+ | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000)+ showWith n = take 3 $ (take (3 - length (show n)) "000" ++) $ show n+