;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; cdb.scm - A console-based CHICKEN debugger
;;;
;;; Copyright (c) 2015-2018, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

(declare
  (module cdb)
  (export connect disconnect terminate)
  (export continue next step)
  (export argument arguments)
  (export break mask)
  (export event events global source trace)
  (import (chicken blob)
          (chicken condition)
          (chicken file)
          (chicken foreign)
          (chicken format)
          (chicken io)
          (chicken memory representation)
          (chicken port)
          (chicken pretty-print)
          (chicken process signal)
          (chicken repl)
          (chicken sort)
          (chicken string))
  (import (compile-file)
          (srfi 13)
          (srfi 14)
          (srfi 69)
          (except (srfi 1) break)
          (prefix debugger-protocol debugger-)
          (vector-lib))
  (import-for-syntax (vector-lib)))



;;;
;;; Helper syntax.
;;;

(define-syntax begin0-let
  (syntax-rules ()
    ((_ ((a e) . r) . b)
     (let ((a e) . r) (begin . b) a))))

(define-syntax interruptable
  (syntax-rules ()
    ((_ e)
     (condition-case e
       ((user-interrupt)
        (comment "interrupted")
        (unbound))))))

(define-syntax fallible
  (syntax-rules ()
    ((_ e) (fallible () e))
    ((_ c e) (condition-case e (x c x)))))

(define-syntax define-foreign
  (cond-expand
    (compiling
     (syntax-rules ()
       ((_ name expr) (define name expr))))
    (else
     (syntax-rules ()
       ((_ name expr)
        (begin
          (with-output-to-file "_f.scm" (lambda () (write `(define name expr))))
          (compile-file "_f.scm")
          (delete-file "_f.scm")))))))

(define-constant runtime-location "<runtime>")
(define-constant more-trace-message #f)
(define-constant help-text "\
; break [<event>]    toggle breakpoint
; connect            await connection
; continue           resume program
; disconnect         terminate program and reconnect
; events             show breakable events
; global [<item>]    inspect item
; info               show current event
; mask [<mask> ...]  set active event types
; next [<event> ...] run program until next event
; quit               terminate program and exit
; step [<count>]     step program
; trace              print call history
")



;;;
;;; General-purpose utilities.
;;;

(define error-message
  (condition-property-accessor 'exn 'message "unknown"))

(define error-arguments
  (condition-property-accessor 'exn 'arguments '()))

(define (comment format . args)
  (fprintf (current-error-port) "; ~?~n" format args))

(define (comment-error e)
  (let ((m (error-message e))
        (a (error-arguments e)))
    (if (null? a)
        (comment "error: ~a" m)
        (comment "error: ~a: ~a" m (string-join (map ->string a))))))

(define (make-error type message . args)
  (make-composite-condition
   (make-property-condition type)
   (make-property-condition 'exn 'message message 'arguments args)))

(define (fail . args)
  (signal (apply make-error args)))

(define (user-interrupt n)
  (signal (make-property-condition 'user-interrupt 'signal n)))

(define (eof) #!eof)

(define nonnegative-integer?
  (conjoin integer? (complement negative?)))

(define (unbound . _)
  (block-ref 'aardvark 0))

(define undefined void)

(define (unbound? x)
  (eq? (unbound) x))

(define (undefined? x)
  (eq? (undefined) x))

(define (datum->string s)
  (sprintf "~s" s))

(define (string->datum s)
  (call-with-input-string s read))

(define (read-line* . port)
  (read-list (open-input-string (apply read-line port))))

(define (lset-disjoin f l . ls)
  (lset-difference f l ls))

(define (vector-max f v)
  (vector-fold (lambda (_ n e) (max (f e) n)) 0 v))

(define (vector-filter f v)
  (list->vector (filter-map f (vector->list v))))

(define (symbol-length x)
  (string-length (symbol->string x)))

(define ((adjoin f) . a)
  (and (apply f a)
       (apply values a)))

(define ((partial f . a) . b)
  (apply f (append a b)))

(define read-lines/vector
  (compose list->vector read-lines))



;;;
;;; Procedure call memoization, used for caching remote object slots.
;;;

(define (with-cached-result table key thunk)
  (condition-case (hash-table-ref (table) key)
    ((exn access)
     (begin0-let ((value (thunk)))
       (hash-table-set! (table) key value)))))

(define (forget-cached-results! table)
  (hash-table-clear! (table)))



;;;
;;; Debug info helpers.
;;;

;; XXX this is a nasty hack
;; shadow record type from debugger-client
(define-record dbg-info event location value c-location data)

(define make-dbg-info
  (let ((make-dbg-info make-dbg-info))
    (lambda args
      (begin0-let ((x (apply make-dbg-info args)))
        (block-set! x 0 'debugger-protocol#dbg-info)))))

(define debug-info-separators
  (char-set #\# #\space))

(define (debug-info-location s)
  (and (string? s)
       (let* ((i (string-index s #\:))
              (j (if (not i)
                     (string-index s debug-info-separators)
                     (string-index s debug-info-separators (+ i 1)))))
         (cond ((not i) runtime-location)
               ((not j) s)
               ((= i j) s)
               (else (substring s 0 j))))))

(define (debug-info-value s)
  (and (string? s)
       (let* ((i (string-index-right s debug-info-separators))
              (x (string->datum (if (not i) s (substring s (+ i 1))))))
         (and (symbol? x)
              (symbol->string x)))))

(define (debug-info-filename s)
  (and (string? s)
       (let ((i (string-index s #\:)))
         (and i (substring s 0 i)))))

(define (debug-info-line-number s)
  (and (string? s)
       (let ((i (string-index s #\:)))
         (and i (string->number (substring s (add1 i)))))))

(define (debug-info->trace s)
  (and-let* ((location (debug-info-location s))
             (value    (debug-info-value s)))
    (string-append (location-prefix location) value)))

(define (dbg-info-type info)
  (debugger-dbg-info-event info))

(define (dbg-info-location info)
  (debug-info-location (debugger-dbg-info-location info)))

(define (dbg-info-value info)
  (debug-info-value (debugger-dbg-info-value info)))

(define (dbg-info->trace info)
  (and-let* ((location (dbg-info-location info))
             (value    (dbg-info-value info)))
    (string-append (location-prefix location) value)))

(define (print-dbg-info info)
  (and-let* ((type     (dbg-info-type info))
             (location (dbg-info-location info))
             (value    (dbg-info-value info)))
    (printf "~a[~a] ~a~n" (location-prefix location) type value)))

(define (location-prefix location)
  (if (string-prefix? "<" location)
      (string-append location " ")
      (string-append location ": ")))



;;;
;;; Source file handling
;;;

(define (read-source path)
  (call-with-input-file path read-lines/vector))

(define (format-source-location f i s n-min n-max)
  (format "~a:~a ~a" f (format-number string-pad-right (+ n-min i 1) n-max) s))

(define (dbg-info-source-listing i #!optional (n-context 5))
  (and-let* ((l (dbg-info-location i))
             (f (debug-info-filename l))
             (n (debug-info-line-number l))
             (_ (file-exists? f))
             (v (read-source f))
             (n-min (max (- n n-context 1) 0))
             (n-max (min (+ n n-context 0) (vector-length v))))
    (vector-map
     (lambda (i s) (format-source-location f i s n-min n-max))
     (vector-copy v n-min n-max))))



;;;
;;; Events
;;;

(define-constant event-types
  #(call global-assign gc entry signal connect listen interrupted))

(define-constant mask/none '(#x00))
(define-constant mask/all  '(#xff))
(define-constant mask/every (vector->list event-types))

(define-inline (event-type? x)
  (memq x mask/every))

(define (valid-mask? x)
  (and (list? x) (every (disjoin event-type? integer?) x)))

(define (make-mask x)
  (if (valid-mask? x)
      (delete-duplicates x)
      (fail 'cdb "invalid event mask" x)))

(define unknown
  (let ()
    (define-record unknown)
    (make-unknown)))

(define (unknown? x)
  (eq? x unknown))

(define-record event id type location value)

(define-record-printer (event x port)
  (fprintf port "#<event ~a ~a ~a ~a>"
           (event-id x)
           (event-type x)
           (event-location x)
           (event-value x)))

(define (list->event l)
  (let ((type     (second l))
        (location (third l))
        (value    (fourth l)))
    (make-event (first l)
                (vector-ref event-types (sub1 type))
                (debug-info-location location)
                (debug-info-value value))))

(define (event->dbg-info e)
  (make-dbg-info (event-type e) (event-location e) (event-value e) #f #f))

(define (event->debug-info e)
  (conc (event-location e) " " (event-value e) (event-value e)))

(define (dbg-info->event i)
  (make-event #f (dbg-info-type i) (dbg-info-location i) (dbg-info-value i)))

(define (event=? . es)
  (apply = (map event-id es)))

(define (event<? . es)
  (apply < (map event-id es)))

(define (event-exists? e)
  (vector-any (constantly #t) (find-events e (current-events))))

(define (make-event-predicate x)
  (cond ((event? x)
         (lambda (e) (event=? x e)))
        ((number? x)
         (lambda (e) (= (event-id e) x)))
        ((symbol? x)
         (make-event-predicate (symbol->string x)))
        ((string? x)
         (lambda (e)
           (let* ((value    (event-value e))
                  (location (event-location e))
                  (filename (debug-info-filename location)))
             (or (and (string? value)
                      (string-contains value x))
                 (and (string? location)
                      (string=? location x))
                 (and (not (string-index x #\:))
                      (string? filename)
                      (string=? filename x))))))
        (else
         (fail 'cdb "invalid event specifier" x))))

(define (find-event x #!optional (events (current-events)))
  (let* ((f (make-event-predicate x))
         (n (vector-count (lambda (_ e) (f e)) events)))
    (when (> n 1)
      (fail 'cdb "ambiguous event" x))
    (begin0-let ((e (vector-any (lambda (e) (and (f e) e)) events)))
      (when (not e)
        (fail 'cdb "no such event" x)))))

(define (find-events x #!optional (events (current-events)))
  (let ((f (make-event-predicate x)))
    (vector-filter (lambda (e) (and (f e) e)) events)))

(define (fetch-events debugger)
  (let ((data (debugger-dbg-info-data (debugger-list-events debugger))))
    (for-each pp data)
    (list->vector (filter-map list->event data))))



;;;
;;; Remote object handling.
;;;

(define-record remote address cache)

(define-record-printer (remote x port)
  (fprintf port "#<~a (remote) #x~a>"
           (remote-type x)
           (number->string (remote-address x) 16)))

(define-foreign become-flonum!
  (foreign-lambda* void ((scheme-object x))
    "C_block_header(x) &= C_HEADER_SIZE_MASK;"
    "C_block_header(x) |= C_FLONUM_TYPE;"))

(define-record lambda-info >string)

(define-record-printer (lambda-info x port)
  (fprintf port "#<lambda-info ~s>" (lambda-info->string x)))

(define (remote-slots x)
  (with-cached-result current-remote-slots
   x
   (lambda ()
     (let ((data (debugger-dbg-info-data
                  (debugger-get-slots (debugger) (remote-address x)))))
       (first data)))))

(define (remote-type x)
  (case (list-ref (remote-slots x) 1)
    ((0)  'vector)
    ((1)  'symbol)
    ((3)  'pair)
    ((8)  'structure)
    ((15) 'bucket)
    ((36) 'procedure)
    ((39) 'port)
    ((41) 'pointer)
    ((42) 'locative)
    ((43) 'tagged-pointer)
    ((66) 'string)
    ((77) 'lambda-info)
    ((80) 'blob)
    ((85) 'flonum)
    (else (error "unrecognized value type" x))))

(define (localize-remote x)
  (define slots
    (list-tail (remote-slots x) 2))
  (define (localize-string)
    (list->string (map integer->char slots)))
  (case (remote-type x)
    ((string)
     (localize-string))
    ((blob)
     (string->blob (localize-string)))
    ((symbol)
     (string->symbol (localize (translate (second slots)))))
    ((lambda-info)
     (make-lambda-info (localize-string)))
    ((pair)
     (cons (localize (translate (first slots)))
           (localize (translate (second slots)))))
    ((flonum)
     (begin0-let ((x’ (localize-string)))
       (become-flonum! x’)))
    ((vector)
     (list->vector (map (compose localize translate) slots)))
    (else x)))

(define (localize x)
  (if (remote? x) (localize-remote x) x))



(define (translate-fixnum x) x)

(define (translate-immediate x)
  (case x
    ((6)  #f)
    ((22) #t)
    ((30) (undefined))
    ((46) (unbound))
    ((62) (eof))
    ((14) (list))
    (else (integer->char x))))

(define (translate-remote x)
  (make-remote x #f))

(define (translate-complex x)
  (let* ((s (symbol->string x))
         (n (string->number (substring s 1))))
    (case (string-ref s 0)
      ((#\=) (translate-immediate n))
      ((#\@) (translate-remote n))
      (else  (error "unknown value" x)))))

(define (translate x)
  (cond ((fixnum? x) (translate-fixnum x))
        ((symbol? x) (translate-complex x))
        (else        (error "unknown value" x))))



;;;
;;; Debugger state.
;;;

;; Local parameters.
(define current-mask (make-parameter '()))
(define current-breakpoints
  (make-parameter '() (lambda (events) (sort events event<?))))

;; Connection-specific parameters.
(define current-info (make-parameter #f))
(define current-trace (make-parameter #f))
(define current-events (make-parameter #()))
(define current-source-files (make-parameter #f))
(define current-remote-slots (make-parameter #f))

(define current-connection
  (make-parameter
   #f
   (adjoin
    (lambda (connection)
      (unless (not connection)
        (current-info #f)
        (current-trace #f)
        (current-events #())
        (current-breakpoints '())
        (current-source-files (make-hash-table))
        (current-remote-slots (make-hash-table)))))))

(define disconnect-handler (make-parameter void))

(define (debugger)
  (or (current-connection)
      (fail 'cdb "no debugger connection")))

(define (current-arguments)
  (let* ((data (debugger-dbg-info-data (debugger-get-arguments (debugger))))
         (args (first data)))
    (if (null? args)
        (list)
        (cons (translate (car args))
              (map translate (cddr args))))))

(define (continue-program)
  (let ((info (debugger-continue (debugger))))
    (unless (debugger-dbg-info? info)
      (fail 'i/o "client program terminated"))
    (case (dbg-info-type info)
      ((call) (current-trace (dbg-info->trace info)))
      (else   (current-trace #f)))
    (forget-cached-results! current-remote-slots)
    (current-info info)))

(define (set-mask! x)
  (let ((mask (make-mask x)))
    (unless (lset= equal? (current-mask) mask)
      (debugger-set-event-mask (debugger) mask)
      (current-mask mask))))

(define (debug-wind before thunk after)
  (dynamic-wind before thunk (lambda () (fallible (debug) (after)))))

(define (with-mask mask thunk)
  (let ((original (current-mask)))
    (debug-wind
     (lambda () (set-mask! mask))
     (lambda () (thunk))
     (lambda () (set-mask! original)))))

(define (set-breakpoints! events)
  (let*-values (((diff int) (lset-diff+intersection event=? (current-breakpoints) events))
                ((events’)  (lset-difference event=? events int)))
    (for-each remove-breakpoint! diff)
    (for-each add-breakpoint! events’)))

(define (add-breakpoint! event)
  (debugger-set-breakpoint (debugger) (event-id event))
  (current-breakpoints (lset-adjoin event=? (current-breakpoints) event)))

(define (remove-breakpoint! event)
  (debugger-clear-breakpoint (debugger) (event-id event))
  (current-breakpoints (lset-disjoin event=? (current-breakpoints) event)))

(define (breakpoint-enabled? event)
  (member event (current-breakpoints) event=?))

(define (toggle-breakpoint! event)
  (if (breakpoint-enabled? event)
      (remove-breakpoint! event)
      (add-breakpoint! event)))

(define (with-breakpoints events thunk)
  (let ((original (current-breakpoints)))
    (debug-wind
     (lambda () (set-breakpoints! events))
     (lambda () (thunk))
     (lambda () (set-breakpoints! original)))))

(define (list-events!)
  (current-events
   (vector-append (current-events)
                  (fetch-events (debugger)))))



(define (assert-argument-count args n #!optional (m n))
  (unless (<= n (length args) m)
    (fail 'arity ; Fake a runtime-generated arity error.
          (sprintf "bad argument count - received ~a but expected ~a"
                   (length args)
                   (if (= n m) n (sprintf "~a-~a" n m))))))

(define (format-string pad s len-max)
  (pad s len-max))

(define (format-number pad n n-max)
  (pad (number->string n)
       (inexact->exact (max (ceiling (/ (log (max n-max 1)) (log 9))) 1))))

(define (print-events events)
  (let* ((n (vector-length events))
         (max-id   (vector-max event-id events))
         (max-loc  (vector-max (compose string-length ->string event-location) events))
         (max-type (vector-max (compose string-length ->string event-type) events)))
    (do ((i 0 (add1 i)))
        ((= i n))
      (let ((e (vector-ref events i)))
        (printf "[~a] ~a ~a | ~a~n"
                (format-number string-pad (event-id e) max-id)
                (format-string string-pad-right (or (event-location e) "(none)") (add1 max-loc))
                (format-string string-pad (symbol->string (event-type e)) max-type)
                (or (event-value e) "(none)"))))))

(define (print-arguments arguments)
  (let* ((v (list->vector arguments))
         (n (vector-length v)))
    (do ((i 0 (add1 i)))
        ((= i n))
      (printf "[~a] ~s~n" (format-number string-pad i n) (vector-ref v i)))))



;;;
;;; Command definitions.
;;;

(define-record command name arguments)

(define (command name . arguments)
  (make-command name arguments))

(define-record-printer (command x port)
  (fprintf port "~a" (cons (command-name x) (command-arguments x))))

(define-syntax define-command
  (syntax-rules ()
    ((_ (n . a) . b)
     (define (n . a)
       (condition-case (begin . b)
         (e (debug)
          (comment (error-message e))
          (undefined))
         (e (i/o)
          (comment "connection lost: ~a" (error-message e))
          (disconnect)))))))

(define (help)
  (display help-text))

(define (connect)
  (comment "awaiting client connection...")
  (current-connection
   (begin0-let ((connection (debugger-wait)))
     (debugger-set-event-mask connection (current-mask)))))

(define (disconnect)
  (current-connection #f)
  ((disconnect-handler)))

(define (terminate)
  (when (current-connection)
    (comment "terminating client program...")
    (fallible (i/o) (debugger-terminate (debugger)))
    (disconnect)))

(define-command (arguments)
  (current-arguments))

(define-command (argument x)
  (unless (nonnegative-integer? x)
    (error 'argument "invalid argument number" x))
  (let ((a (current-arguments)))
    (if (<= (length a) x)
        (undefined)
        (list-ref a x))))

(define-command (breakpoints)
  (current-breakpoints))

(define-command (break . points)
  (assert-argument-count points 0 1)
  (list-events!)
  (if (pair? points)
      (toggle-breakpoint! (find-event (car points)))
      (current-breakpoints)))

(define-command (event . id)
  (assert-argument-count id 0 1)
  (list-events!)
  (if (pair? id)
      (find-event (car id) (current-events))
      (and (current-info)
           (dbg-info->event (current-info)))))

(define-command (events . filter)
  (assert-argument-count filter 0 1)
  (list-events!)
  (if (pair? filter)
      (find-events (car filter) (current-events))
      (current-events)))

(define-command (continue)
  (continue-program))

(define-command (step . count)
  (assert-argument-count count 0 1)
  (with-mask mask/all
   (lambda ()
     (let ((n (optional count 1)))
       (do ((i 0 (+ i 1))
            (e (undefined) (continue-program)))
           ((= i n) e))))))

(define-command (next . args)
  (define (next/events events)
    (let ((events* (map find-event events)))
      (with-breakpoints events* continue-program)))
  (define (next/mask events)
    (let ((mask (if (pair? events) events mask/all)))
      (with-mask mask continue-program)))
  (let-values (((mask events) (partition event-type? args)))
    (cond ((null? args) (step))
          ((null? mask) (next/events events))
          ((null? events) (next/mask mask))
          (else (with-breakpoints (map find-event events)
                 (lambda () (next/mask mask)))))))

(define-command (mask . events)
  (assert-argument-count events 0 +inf.0)
  (cond ((memq 'none events)
         (set-mask! mask/none))
        ((memq 'all events)
         (set-mask! mask/every))
        ((pair? events)
         (set-mask! events))
        (else
         (current-mask))))

(define-command (source)
  (and-let* ((i (current-info)))
    (dbg-info-source-listing i 4)))

(define-command (trace)
  (filter-map
   (lambda (data)
     (let ((s (first data)))
       (cond ((string=? s "") (current-trace))
             ((string=? s "...more...") more-trace-message)
             ((string-suffix? "<--" s)
              (debug-info->trace (string-trim-right (string-drop-right s 3))))
             (else
              (debug-info->trace s)))))
   (debugger-dbg-info-data (debugger-get-trace (debugger)))))

(define-command (global name)
  (let ((data (debugger-dbg-info-data (debugger-get-global (debugger) name))))
    (case (first (first data))
      ((UNKNOWN) (unbound))
      (else => translate))))



;;;
;;; Console.
;;;

(define (run-command c)
  (case (command-name c)
    ((h help ?)
     (apply help (command-arguments c)))
    ((connect)
     (apply disconnect (command-arguments c)))
    ((disconnect)
     (apply terminate (command-arguments c)))
    ((terminate)
     (parameterize ((disconnect-handler void))
       (apply terminate (command-arguments c))))
    ((q quit)
     (parameterize ((disconnect-handler quit))
       (apply terminate (command-arguments c))))
    ((b break)
     (let ((x (apply break (command-arguments c))))
       (cond ((undefined? x))
             ((pair? x) (print-events (list->vector x)))
             (else (comment "no breakpoints")))))
    ((n next)
     (let ((x (apply next (command-arguments c))))
       (when (debugger-dbg-info? x) (print-dbg-info x))))
    ((s step)
     (let ((x (apply step (command-arguments c))))
       (when (debugger-dbg-info? x) (print-dbg-info x))))
    ((c continue)
     (let ((x (apply continue (command-arguments c))))
       (when (debugger-dbg-info? x) (print-dbg-info x))))
    ((a arguments)
     (let ((a (apply arguments (command-arguments c))))
       (if (pair? a)
           (print-arguments a)
           (comment "no arguments"))))
    ((e events)
     (let ((e (apply events (command-arguments c))))
       (if (vector? e)
           (print-events e)
           (comment "no events"))))
    ((i info)
     (let ((e (apply event (command-arguments c))))
       (if (event? e)
           (print-dbg-info (event->dbg-info e))
           (comment "no info"))))
    ((l list)
     (let ((x (apply source (command-arguments c))))
       (if (vector? x)
           (vector-for-each (lambda (_ line) (print line)) x)
           (comment "no source file"))))
    ((m mask)
     (let ((x (apply mask (command-arguments c))))
       (if (pair? x)
           (comment (string-join (map ->string (current-mask))))
           (comment "none"))))
    ((p print)
     (print (apply global (command-arguments c))))
    ((t trace)
     (let ((t (apply trace (command-arguments c))))
       (if (pair? t)
           (for-each print t)
           (comment "no trace"))))
    (else
     (comment "unrecognized command ~a" c))))

(define (read-command)
  (let ((e (interruptable (read))))
    (cond ((symbol? e)
           (make-command e (read-line*)))
          (else e))))

(define (evaluate c)
  (let ((x (eval c)))
    (unless (undefined? x) (printf "~s~n" x))))

(define (run-input)
  (let ((c (read-command)))
    (cond ((unbound? c))
          ((undefined? c))
          ((eof-object? c) (disconnect))
          ((command? c) (run-command c))
          (else (evaluate c)))))

(define (console . _)
  (let ((connection (interruptable (connect))))
    (when (unbound? connection) (quit))
    (parameterize ((current-connection connection)
                   (disconnect-handler console))
      (let loop ()
        (printf "> ")
        (run-input)
        (condition-case (run-input)
          (e () (comment-error e)))
        (loop)))))



;;;
;;; Entry point.
;;;

(cond-expand
  (compiling
   (set-signal-handler! signal/int user-interrupt)
   (console))
  (chicken-script
   (console))
  (else))