www

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs

debug-format.rkt (3574B)

      1 #lang racket/base
      2 (require racket/pretty)
      3 (provide write-debug-file
      4          load-debug-file
      5          serialize-datum
      6          approx-parse-state)
      7 
      8 (define (write-debug-file file exn events)
      9   (with-output-to-file file
     10     (lambda ()
     11       (write-string "`(\n")
     12       (for ([event (in-list events)])
     13         (let ([event (list (car event) (cdr event))])
     14           (pretty-write (serialize-datum* event))))
     15       (write-string ")\n")
     16       (newline)
     17       (write (exn-message exn))
     18       (newline)
     19       (pretty-write
     20        (map serialize-context-frame
     21             (continuation-mark-set->context
     22              (exn-continuation-marks exn)))))
     23     #:exists 'replace))
     24 
     25 (define (quoted? x) (and (pair? x) (eq? (car x) 'quote)))
     26 
     27 (define (serialize-datum d)
     28   (list 'quasiquote (serialize-datum* d)))
     29 
     30 (define (serialize-datum* d)
     31   (define (UNQUOTE x) (list 'unquote x))
     32   (cond [(number? d) d]
     33         [(boolean? d) d]
     34         [(symbol? d)
     35          (case d
     36            ((unquote) (UNQUOTE '(quote unquote)))
     37            ((unquote-splicing) (UNQUOTE '(quote unquote-splicing)))
     38            (else d))]
     39         [(string? d) d]
     40         [(bytes? d) d]
     41         [(null? d) d]
     42         [(pair? d)
     43          (cons (serialize-datum* (car d)) (serialize-datum* (cdr d)))]
     44         [(exn? d) (UNQUOTE `(make-exn ,(exn-message d) (current-continuation-marks)))]
     45         [(syntax? d) (UNQUOTE `(datum->syntax #f ',(syntax->datum d)))]
     46         [(module-path-index? d)
     47          (define-values (path rel)
     48            (module-path-index-split d))
     49          (UNQUOTE `(module-path-index-join
     50                     ,(serialize-datum path)
     51                     ,(serialize-datum rel)))]
     52         [(resolved-module-path? d)
     53          (UNQUOTE `(make-resolved-module-path
     54                     ,(serialize-datum
     55                       (resolved-module-path-name d))))]
     56         [(path? d)
     57          (UNQUOTE `(bytes->path
     58                     ,(serialize-datum (path->bytes d))
     59                     ,(serialize-datum (path-convention-type d))))]
     60         [else
     61          (eprintf "unserializable value: ~e" d)
     62          `(UNSERIALIZABLE ,(format "~s" d))]))
     63 
     64 (define (serialize-context-frame frame)
     65   (cons (car frame)
     66         (if (cdr frame)
     67             (serialize-srcloc (cdr frame))
     68             null)))
     69 
     70 (define (serialize-srcloc s)
     71   (list (let ([src (srcloc-source s)])
     72           (cond [(path? src) (path->string src)]
     73                 [(string? src) src]
     74                 [else '?]))
     75         (srcloc-line s)
     76         (srcloc-column s)))
     77 
     78 (define (load-debug-file file)
     79   (parameterize ((read-accept-compiled #t))
     80     (with-input-from-file file
     81       (lambda ()
     82         (let* ([events-expr (read)]
     83                [exnmsg (read)]
     84                [ctx (read)])
     85           (let* ([events (eval events-expr)]
     86                  [events
     87                   (if (andmap (lambda (e) (and (list? e) (= 2 (length e)))) events)
     88                       (map (lambda (l) (cons (car l) (cadr l))) events)
     89                       events)])
     90             (values events exnmsg ctx)))))))
     91 
     92 (define (approx-parse-state events N)
     93   (for/fold ([state null]) ([event (in-list events)] [index (in-range N)])
     94     (define (pop expect)
     95       (let ([top (car state)])
     96         (unless (eq? (cadr top) expect)
     97           (error "bad state on ~e: ~e" (car event) state))
     98         (cdr state)))
     99     (case (car event)
    100       ((enter-macro enter-prim enter-local)
    101        (cons (cons index event) state))
    102       ((exit-macro)
    103        (pop 'enter-macro))
    104       ((exit-prim)
    105        (pop 'enter-prim))
    106       ((exit-local)
    107        (pop 'enter-local))
    108       (else state))))