Fixing mztake for dijkstra demo

svn: r408

collects/mztake/demos/dijkstra/dijkstra-mztake.ss

@@ -33,11 +33,12 @@
       binary heap implementation without satisfying its (stronger) contract. |#
 
 (require (lib "mztake.ss" "mztake")
+         (lib "useful-code.ss" "mztake" "private")
 	 "dijkstra-solver.ss"
          (lib "match.ss"))
 
-(define/bind (loc "heap.ss" 49 6) item)
+(define inserts (trace (loc "heap.ss" 49 6) (bind (item) item)))
-(define/bind (loc "heap.ss" 67 10) result)
+(define removes (trace (loc "heap.ss" 67 10) (bind (result) result)))
 
 #| The following code merely observes the insertions and removals
    from the heap. We notice whether any of the removals are out
@@ -59,7 +60,6 @@
                                        (inserts . -=> . 'reset)))
 (define violations (not-in-order inserts-and-removes-e))
 
-
 (printf-b "all inserts and removes: ~a" (history-b inserts-and-removes-e))
 (printf-b "all violations: ~a" (history-b violations))
 (printf-b "latest-violation: ~a" (hold violations))
@@ -78,4 +78,6 @@
 (define inserters (accum-b (inserts . ==> . insert-in-model) empty))
 (define removers  (accum-b (removes . ==> . remove-from-model) inserters))
 
+(set-main! "dijkstra.ss")
+
 (set-running-e! (violations . -=> . false))

collects/mztake/demos/first-class/first-class-mztake-uncommented.ss

@@ -1,15 +0,0 @@
-(define x-before-let (trace (loc "first-class.ss" 3 29) (bind (x) x)))
-(define x-in-let (trace (loc "first-class.ss" 4 25) (bind (x) x)))
-(define x-after-let (trace (loc "first-class.ss" 5 11) (bind (x) x)))
-
-
-(printf-b "Number of times x updates, should be 12: ~a"
-          (count-b (merge-e x-before-let
-                            x-in-let
-                            x-after-let)))
-
-(printf-b "x before let, should be (2 4 6 7): ~a"  (history-b 4 x-before-let))
-(printf-b "x in let, should be (6 10 14 16): ~a"   (history-b 4 x-in-let))
-(printf-b "x after let, should be (5 9 13 15): ~a" (history-b 4 x-after-let))
-
-(set-running! true)

collects/mztake/demos/first-class/first-class-mztake.ss

@@ -1,28 +0,0 @@
-#| This program demonstrates how you can add traces to first class, anonymous functions,
-   such as those passed to map, and the traces will still respond from anywhere
-   the code is executed.
- 
-   This test also shows how you can bind to the same variable at different locations,
-   and recieve different values, watching how an algorithm unfolds.
-
-   Be sure you look at first-class.ss to see where the bindings are taken from, to get
-   and idea of why they recieve different values from the same "x". |#
-
-(define-mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x]
-                                           [x-in-let     4 25 bind 'x]
-                                           [x-after-let  5 11 bind 'x]))
-
-(printf-b "Number of times x updates, should be 12: ~a"
-          (count-b (merge-e x-before-let
-                            x-in-let
-                            x-after-let)))
-#| merge-e takes multiple event streams and turns them into one event stream.
-   count-e then counts how many pings are recieved on all three streams,
-   in other words, how many times "x" updates in all the traces. |#
-
-(printf-b "x before let, should be (2 4 6 7): ~a"  (history-b 4 x-before-let))
-(printf-b "x in let, should be (6 10 14 16): ~a"   (history-b 4 x-in-let))
-(printf-b "x after let, should be (5 9 13 15): ~a" (history-b 4 x-after-let))
-#| Prints out a FIFO list containing the last 4 values seen by each trace. |#
-
-(start/resume p)

collects/mztake/demos/first-class/first-class.ss

@@ -1,6 +0,0 @@
-(module first-class mzscheme
-  (map (lambda (x)
-         (let* ([x (* 2 (+ 1 x))]
-                [x (sub1 x)])
-           x))
-       '(2 4 6 7)))

collects/mztake/mztake-structs.ss

@@ -41,7 +41,7 @@
                                 where         ; a behavior signaling each position where we pause
                                 marks))       ; while paused, the marks at the point of the pause (else false)
   
-  (define-struct loc (modpath line col))
+  (define-struct loc (reqspec line col))
                       
   ;###########################################################################################################
   

collects/mztake/mztake.ss

@@ -167,7 +167,7 @@
 
   (define (find-client process modpath) 
     (cond
-     [(memf (lambda (c) (equal? (debug-client-modpath c) (path->string modpath)))
+     [(memf (lambda (c) (equal? (debug-client-modpath c) modpath))
             (debug-process-clients process)) => first]
      [else false]))
  
@@ -186,7 +186,6 @@
            [where-event ((frp:signal-thunk (debug-process-where process)) #t)])
       
       (set-debug-process-marks! process marks)
-
       (if (empty? traces)
 
           (frp:send-synchronous-event where-event w)
@@ -221,7 +220,6 @@
     false)
   
   (define (launch-sandbox process)
-
     (require/sandbox+annotations
      (debug-process-custodian process)
      ;; error-display-handler :
@@ -230,6 +228,7 @@
          (frp:send-event (debug-process-exceptions process) exn)
          (orig-err-disp msg exn)))
      `(file ,(debug-client-modpath (debug-process-main-client process)))
+     
      ;; annotate-module?
      (lambda (filename module-name)
         (memf (lambda (c) (equal? (debug-client-modpath c) (path->string filename)));; TODO: harmonize path & string
@@ -237,7 +236,7 @@
      ;; annotator
      (lambda (stx)
        (let ([client (and (syntax-source stx)
-                          (find-client process (syntax-source stx)))])
+                          (find-client process (path->string (syntax-source stx))))])
          (if (not client)
              stx
              (let-values ([(annotated-stx pos-list)
@@ -373,29 +372,28 @@
         (set-debug-process-clients! process
                                     (append (list client) (debug-process-clients process)))
           
-                                        ; set the main module if it has not been set
+        ; set the main module if it has not been set
-                                        ; this implies that the first client created is always the main module
+        ; this implies that the first client created is always the main module
         (unless (debug-process-main-client process)
           (set-debug-process-main-client! process client))
           
         client)))
 
-  (define (set-main! mod-path)
+  (define (set-main! reqspec)
-    (let ([client (find-client (current-process) mod-path)])
+    (let* ([modpath (reqspec->modpath reqspec)]
-      (if client
+           [maybe-client (find-client (current-process) modpath)]
-          (set-debug-process-main-client! (current-process) client)
+           [client (or maybe-client (create-debug-client (current-process) modpath))])
-          (create-debug-client (current-process) mod-path))))
+      (set-debug-process-main-client! (current-process) client)))
 
   (define (hold-b b)
     (frp:hold (frp:filter-e (lambda (ev) (not (frp:undefined? ev))) (frp:changes b))))
 
-  (define (expand-module-filename filename)
+  (define (reqspec->modpath filename)
     (define (build-module-filename str) ; taken from module-overview.ss
       (let ([try (lambda (ext)
                    (let ([tst (string-append str ext)])
                      (and (file-exists? tst) tst)))])
-        (or (try ".ss") (try ".scm") (try "") str)))
+        (or (try ".ss") (try ".scm") (try "") str)))               
-               
     (let ([modpath (symbol->string ((current-module-name-resolver) filename #f #f))])
       (build-module-filename
        (if (regexp-match #rx"^," modpath)
@@ -403,7 +401,7 @@
            modpath))))
 
   (define (trace* loc thunk)
-    (let* ([modpath (expand-module-filename (loc-modpath loc))]
+    (let* ([modpath (reqspec->modpath (loc-reqspec loc))]
            [clients (filter (lambda (c)
                               (equal? modpath (debug-client-modpath c)))
                             (debug-process-clients (current-process)))]
@@ -457,7 +455,7 @@
                      (let ([p (syntax-position stx)])
                        (string->symbol (format "~a::~a" s p)))))))))
 
-  (provide loc$ loc loc-modpath loc-line loc-col
+  (provide loc$ loc loc-reqspec loc-line loc-col
            trace trace* bind define/bind create-debug-process
            create-debug-client where set-main!
            mztake-version)