implemented pattern matching locations

svn: r1872

collects/mztake/demos/sine/sine-mztake.ss

@@ -2,7 +2,8 @@
          (lib "useful-code.ss" "mztake"))
 (require (lib "mztake.ss" "mztake"))
 
-(define/bind (loc "sine.ss" 5 ) x sin-x)
+;(define/bind (loc "sine.ss" 5 ) x sin-x)
+(define/bind (loc "sine.ss" '(if  _ ...) ) x sin-x)
 
 (define (pick-cute-color x y)
   (if (< 200 y)

collects/mztake/engine.ss

@@ -7,7 +7,8 @@
            "more-useful-code.ss" ; mostly for hash- bindings
            "mztake-structs.ss"
            "load-sandbox.ss"
-           "annotator.ss")
+           "annotator.ss"
+           (lib "match.ss"))
   
   (provide process:set-main!
            current-policy
@@ -20,40 +21,44 @@
            process:paused->running 
            pause
            resume
-           trace*)
+           trace*
+           
+           read-all-syntax
+           pattern->pos)
   
   ;Keeps track of all debugging processes
   (define all-debug-processes null)  
   
+  ; produces a nested list of (line column offset) for all addressable syntax    
+  (define (unwrap-syntax stx)
+    (let ([elt (list (syntax-line stx)
+                     (syntax-column stx)
+                     (sub1 (syntax-position stx)))])
+      (syntax-case stx ()
+        [(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))]
+        [x elt])))
+  
+  (define (read-all-syntax filename)
+    (parameterize ([port-count-lines-enabled #t])
+      (let ([port (open-input-file filename)])
+        (begin0
+          (let loop ([stx (read-syntax filename port)])
+            (if (eof-object? stx) '()
+                (cons stx 
+                      (loop (read-syntax filename port)))))
+          (close-input-port port)))))
+  
   ;; returns a memoized function that takes (line column) -> position
   ;; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?)))
-  (define (line-col->pos filename)
+  (define (line-col->pos stx)
-    ; produces a nested list of (line column offset) for all addressable syntax
+    (let ([pos-list (flatten (map unwrap-syntax stx))])    
-    (define (unwrap-syntax stx)
-      (let ([elt (list (syntax-line stx)
-                       (syntax-column stx)
-                       (sub1 (syntax-position stx)))])
-        (syntax-case stx ()
-          [(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))]
-          [x elt])))
-    
-    (let ([pos-list
-           (flatten (parameterize ([port-count-lines-enabled #t])
-                      (let ([port (open-input-file filename)])
-                        (begin0
-                          (let loop ([stx (read-syntax filename port)])
-                            (if (eof-object? stx) '()
-                                (cons (unwrap-syntax stx)
-                                      (loop (read-syntax filename port)))))
-                          (close-input-port port)))))])
-      
       (lambda (line maybe-col)
         (let loop ([lst pos-list])
           (cond
             [(empty? lst)
              (error 'loc
-                    "No syntax found for trace at line/column ~a:~a in client `~a'"
+                    "No syntax found for trace at line/column ~a:~a in `~a'"
-                    line maybe-col filename)]
+                    line maybe-col (syntax-source stx))]
             [(and (<= line (first (first lst)))
                   (or (not maybe-col)
                       (<= maybe-col (second (first lst)))))
@@ -61,6 +66,52 @@
             
             [else (loop (rest lst))])))))
   
+  (define (pattern->pos stx-lst)
+    (define (quote-symbols lst)
+      (cond 
+        [(empty? lst) empty]
+        [(eq? lst '_) lst]
+        [(eq? lst '...) lst]
+        [(symbol? lst) `(quote ,lst)]
+        [else (cons (quote-symbols (first lst))
+                    (quote-symbols (rest lst)))]))
+    
+    (define (collect-locations h stx lst)
+      (let loop ([stx stx] [lst lst])
+        (cond 
+          [(empty? stx) (void)]
+          [(pair? stx)
+           (loop (first stx) (first lst))
+           (loop (rest stx) (rest lst))]
+          [else 
+           (when (syntax-line stx) 
+             (hash-put! h lst (sub1 (syntax-position stx))))
+           (when (pair? (syntax-e stx)) 
+             (loop (first (syntax-e stx)) (first lst))
+             (loop (rest (syntax-e stx)) (rest lst)))])))
+    
+    (define stx2line-col (make-hash))
+    (define lst (map syntax-object->datum stx-lst))
+    
+    (for-each (lambda (s l) (collect-locations stx2line-col s l))
+              stx-lst lst)
+    
+    (lambda (pattern) 
+      (let ([pred (eval `(begin (require (lib "match.ss"))
+                                (lambda (v) 
+                                  (match v 
+                                    [,(quote-symbols pattern) #t]
+                                    [_ #f]))))])
+        (let loop ([lst lst])
+          (let ([sub (if (pair? lst)
+                         (append (loop (first lst))
+                                 (loop (rest lst)))
+                         empty)])
+            (if (and (hash-mem? stx2line-col lst) (pred lst))
+                (cons (hash-get stx2line-col lst) sub)
+                sub))))))
+  
+  
   (define (find-client process modpath)
     (cond
       [(memf (lambda (c) (equal? (debug-client-modpath c) modpath))
@@ -292,7 +343,8 @@
   (define (create-debug-client process modpath)
     ; throwaway namespace so the module-name-resolver doesn't load an unannotated module
     (parameterize ([current-namespace (make-namespace)])
-      (let ([client (create-empty-debug-client)])
+      (let ([client (create-empty-debug-client)]
+            [stx (read-all-syntax modpath)])
         (for-each (lambda (c)
                     (when (equal? modpath (debug-client-modpath c))
                       (raise-syntax-error 'mztake:script-error:create-debug-client
@@ -301,7 +353,8 @@
         
         (set-debug-client-modpath! client modpath)
         (set-debug-client-process! client process)
-        (set-debug-client-line-col->pos! client (line-col->pos modpath))
+        (set-debug-client-line-col->pos! client (line-col->pos stx))
+        (set-debug-client-pattern->pos! client (pattern->pos stx))
         (set-debug-process-clients! process
                                     (append (list client) (debug-process-clients process)))
         
@@ -324,16 +377,23 @@
            (substring modpath 1 (string-length modpath))
            modpath))))
   
+  (define (loc->positions client loc)
+    (if (loc/lc? loc)
+        (list ((debug-client-line-col->pos client) (loc/lc-line loc) (loc/lc-col loc)))
+        ((debug-client-pattern->pos client) (loc/p-pattern loc))))
+  
   (define (trace* p loc thunk)
     (let* ([modpath (reqspec->modpath (loc-reqspec loc))]
            [client (find-client/create p modpath)]
            [trace-hash (debug-client-tracepoints client)]
            [trace (make-trace-struct (frp:event-receiver) thunk)]
-           [pos ((debug-client-line-col->pos client) (loc-line loc) (loc-col loc))])
+           [positions (loc->positions client loc)])      
-      ; add the trace to the list of traces for that byte-offset
+      ; add the trace to the list of traces for these byte-offsets
-      (hash-put! trace-hash pos
+      (for-each (lambda (pos) 
-                 (append (hash-get trace-hash pos (lambda () '()))
+                  (hash-put! trace-hash pos
-                         (list trace)))
+                             (append (hash-get trace-hash pos (lambda () '()))
+                                     (list trace))))
+                positions)
       (trace-struct-evnt-rcvr trace)))
   
   (define (syntax-local-infer-name stx)

collects/mztake/mztake-structs.ss

@@ -26,6 +26,7 @@
   (define-struct debug-client (modpath          ; complete-path of the module
                                tracepoints      ; hash-table of traces
                                line-col->pos    ; memoized O(n) function to map line/col -> byte offset
+                               pattern->pos
                                process))        ; parent debug-process
   
   (define-struct debug-process (custodian     ; If you shutdown-all it will kill the debugger process
@@ -44,7 +45,9 @@
                                 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 (reqspec line col))
+  (define-struct loc (reqspec))
+  (define-struct (loc/lc loc) (line col))
+  (define-struct (loc/p loc) (pattern))
                       
   ;###########################################################################################################
   
@@ -68,6 +71,7 @@
     (make-debug-client null        ; modpath
                        (make-hash) ; tracepoints
                        null        ; line-col->pos function
+                       null
                        null))      ; process
   
   ;###########################################################################################################

collects/mztake/mztake.ss

@@ -18,14 +18,10 @@
            bind
            define/bind
            define/bind-e
+           [rename loc/opt-col loc]
            [rename mztake-top #%top])
   
-  (provide/contract [loc-reqspec (loc? . -> . require-spec?)]
+  (provide/contract [exceptions (() (debug-process?) . opt-> . frp:event?)]
-                    [loc-line (loc? . -> . number?)]
-                    [loc-col (loc? . -> . number?)]
-                    [rename loc/opt-col loc
-                            ((any/c number?) (number?) . opt-> . loc?)]
-                    [exceptions (() (debug-process?) . opt-> . frp:event?)]
                     [exited? (() (debug-process?) . opt-> . frp:behavior?)]
                     [kill (() (debug-process?) . opt-> . void?)]
                     [kill-all (-> void?)]
@@ -42,8 +38,10 @@
                     [bind* (debug-process? symbol? . -> . any)])
   
   (define loc/opt-col
-    (opt-lambda (reqspec line [col #f])
+    (opt-lambda (reqspec line/pattern [col #f])
-      (loc reqspec line col)))
+      (if (number? line/pattern)
+          (make-loc/lc reqspec line/pattern col)
+          (make-loc/p reqspec line/pattern))))
   
   (define exceptions
     (opt-lambda ([p (current-process)])

collects/mztake/tests/engine-test.ss

@@ -0,0 +1,12 @@
+(module engine-test mzscheme
+  
+  (require "../engine.ss")
+  
+  (define stx (read-all-syntax "../demos/dijkstra/dijkstra.ss"))
+  
+  (define fn (pattern->pos stx))
+  (define result (fn '(define (_ ...) _ ...)))
+  
+  (define expected  '((7 2 147) (18 2 463)))
+  (printf "~a~n" (list (equal? result expected) result expected))
+  )