;;;; debugger api

(module debugger-protocol (debugger-connection-in
                           debugger-connection-out
                           debugger-connection?
                           dbg-info?
                           dbg-info-event
                           dbg-info-location
                           dbg-info-value
                           dbg-info-c-location
                           dbg-info-data
                           wait
                           terminate
                           continue
                           list-events
                           get-arguments
                           set-event-mask
                           set-breakpoint
                           clear-breakpoint
                           get-global
                           get-bytes
                           get-slots
                           get-statistics
                           get-trace)

(import-syntax (matchable))

(import (scheme)
        (chicken base)
        (chicken bitwise)
        (chicken format)
        (chicken tcp))

(define C_DEBUG_REPLY_UNUSED 0)
(define C_DEBUG_REPLY_SETMASK 1)
(define C_DEBUG_REPLY_TERMINATE 2)
(define C_DEBUG_REPLY_CONTINUE 3)
(define C_DEBUG_REPLY_SET_BREAKPOINT 4)
(define C_DEBUG_REPLY_CLEAR_BREAKPOINT 5)
(define C_DEBUG_REPLY_LIST_EVENTS 6)
(define C_DEBUG_REPLY_GET_BYTES 7)
(define C_DEBUG_REPLY_GET_AV 8)
(define C_DEBUG_REPLY_GET_SLOTS 9)
(define C_DEBUG_REPLY_GET_GLOBAL 10)
(define C_DEBUG_REPLY_GET_STATS 11)
(define C_DEBUG_REPLY_GET_TRACE 12)

(define default-tcp-port 9999)
(define default-listener #f)

(define-record debugger-connection in out)
(define-record dbg-info event location value c-location data)

(define event-names
  '((call 0)
    (global-assign 1)
    (gc 2)
    (entry 3)
    (signal 4)
    (connect 5)
    (listen 6)
    (interrupted 7)))

(define-record-printer (dbg-info dinfo port)
  (fprintf port "#<dbg-info ~S ~S ~S ~S>"
           (dbg-info-event dinfo)
           (dbg-info-location dinfo)
           (dbg-info-value dinfo)
           (dbg-info-data dinfo)))

(define (wait #!optional (listener default-listener))
  (unless listener
    (set! listener (tcp-listen default-tcp-port))
    (set! default-listener listener))
  (parameterize ((tcp-read-timeout #f))
    (let-values (((in out) (tcp-accept listener)))
      (let ((con (make-debugger-connection in out)))
        ;; read initial event (connect)
        (match (read in)
          ((5 . _)
           (let-values (((us them) (tcp-addresses in)))
             (fprintf (current-error-port) "; client connected from ~A~%" them)
             con))
          (evt (error "unexpected connection event" evt)))))))

(define (send-reply con reply)
  (let ((in (debugger-connection-in con))
        (out (debugger-connection-out con)))
    (write reply out)
    (newline out)
    (flush-output out)
    (parameterize ((tcp-read-timeout #f))
      (let ((evt (read in)))
        (process-event con evt '())))))

(define (process-event con evt pdata)
  (match evt
    ((? eof-object?)
     (fprintf (current-error-port) "; client closed connection~%")
     (reverse pdata))
    (('* data ...)
     (let ((more (read (debugger-connection-in con))))
       (process-event con more (cons data pdata))))
    (((? number? e) loc val cloc)
     (make-dbg-info
      (car (list-ref event-names e))
      loc
      val
      cloc
      (reverse pdata)))
    (_ (error "corrupted debug event" evt))))

(define (terminate con)
  (send-reply con (list C_DEBUG_REPLY_TERMINATE))
  (close-input-port (debugger-connection-in con))
  (close-output-port (debugger-connection-out con)))

(define (continue con)
  (send-reply con (list C_DEBUG_REPLY_CONTINUE)))

(define (list-events con #!optional (mstr ""))
  (send-reply con (list C_DEBUG_REPLY_LIST_EVENTS mstr)))

(define (get-arguments con)
  (send-reply con (list C_DEBUG_REPLY_GET_AV)))

(define (set-event-mask con mask)
  (send-reply
   con
   (list C_DEBUG_REPLY_SETMASK
         (apply bitwise-ior
                (map (lambda (x)
                       (cond ((integer? x) x)
                             ((assq x event-names) =>
                              (lambda (a)
                                (arithmetic-shift 1 (cadr a))))
                             (else
                              (print "bad event: " x)
                              0)))
                     mask)))))

(define (set-breakpoint con . nums)
  (for-each
   (lambda (num)
     (send-reply con (list C_DEBUG_REPLY_SET_BREAKPOINT num)))
   nums))

(define (clear-breakpoint con . nums)
  (for-each
   (lambda (num)
     (send-reply con (list C_DEBUG_REPLY_CLEAR_BREAKPOINT num)))
   nums))

(define (get-global con name)
  (assert (symbol? name))
  (send-reply con (list C_DEBUG_REPLY_GET_GLOBAL (sprintf "~s" name))))

(define (get-bytes con addr num)
  (send-reply con (list C_DEBUG_REPLY_GET_BYTES addr num)))

(define (get-slots con val)
  (send-reply con (list C_DEBUG_REPLY_GET_SLOTS val)))

(define (get-statistics con)
  (send-reply con (list C_DEBUG_REPLY_GET_STATS)))

(define (get-trace con)
  (send-reply con (list C_DEBUG_REPLY_GET_TRACE)))

)