#lang scheme

(provide debug
         dprintf
         begin/debug
         define/debug
         define/private/debug
         define/public/debug
         define/override/debug
         define/augment/debug
         let/debug
         let*/debug
         letrec/debug
         let-values/debug
         let*-values/debug
         letrec-values/debug
         with-syntax/debug
         with-syntax*/debug
         parameterize/debug
         with-debugging)

(require "syntax.ss"
         (for-syntax scheme/match syntax/parse "syntax.ss"))

(define-syntax (let/debug stx)
  (syntax-parse stx
    [(_ (~optional loop:id) ... ([lhs:id rhs:expr] ...) body:expr ... last:expr)
     #`(with-debugging
        #:name '#,(if (attribute loop) #'loop #'let/debug)
        #:source (quote-srcloc #,stx)
        (let #,@(if (attribute loop) (list #'loop) null)
          ([lhs (with-debugging #:name 'lhs rhs)] ...)
          (debug body) ... (debug last)))]))

(define-syntaxes
  [ let*/debug
    letrec/debug
    let-values/debug
    let*-values/debug
    letrec-values/debug
    with-syntax/debug
    with-syntax*/debug
    parameterize/debug ]

  (let ()

    (define ((expander binder-id) stx)
      (with-syntax ([binder binder-id])
        (syntax-parse stx
          [(binder/debug:id ([lhs rhs:expr] ...) body:expr ... last:expr)
           #`(with-debugging
              #:name 'binder/debug
              #:source (quote-srcloc #,stx)
              (binder
               ([lhs (with-debugging #:name 'lhs rhs)] ...)
               (debug body) ... (debug last)))])))

    (values (expander #'let*)
            (expander #'letrec)
            (expander #'let-values)
            (expander #'let*-values)
            (expander #'letrec-values)
            (expander #'with-syntax)
            (expander #'with-syntax*)
            (expander #'parameterize))))

(define-syntaxes
  [ define/debug
    define/private/debug
    define/public/debug
    define/override/debug
    define/augment/debug ]

  (let ()

    (define-syntax-class header
      #:attributes [name]
      (pattern (name:id . _))
      (pattern (inner:header . _) #:attr name (attribute inner.name)))

    (define ((expander definer-id) stx)
      (with-syntax ([definer definer-id])
        (syntax-parse stx
          [(definer/debug:id name:id body:expr)
           #`(definer name
               (with-debugging
                #:name 'name
                #:source (quote-srcloc #,stx)
                body))]
          [(definer/debug:id spec:header body:expr ... last:expr)
           #`(definer spec
               (with-debugging
                #:name 'spec.name
                #:source (quote-srcloc #,stx)
                (let () body ... last)))])))

    (values (expander #'define)
            (expander #'define/private)
            (expander #'define/public)
            (expander #'define/override)
            (expander #'define/augment))))

(define-syntax (begin/debug stx)
  (syntax-parse stx
    [(_ term:expr ...)
     #`(with-debugging
        #:name 'begin/debug
        #:source (quote-srcloc #,stx)
        (begin (debug term) ...))]))

(define-syntax (debug stx)
  (syntax-parse stx
    [(_ term:expr)
     (syntax (with-debugging term))]))

(define-syntax (with-debugging stx)
  (syntax-parse stx
    [(_ (~or (~optional (~seq #:name name:expr))
             (~optional (~seq #:source source:expr)))
        ...
        body:expr)
     (with-syntax* ([name (or (attribute name) #'(quote body))]
                    [source (or (attribute source) #'(quote-srcloc body))])
       #'(with-debugging/proc
          name
          source
          (quote body)
          (lambda () (#%expression body))))]))

(define (srcloc->string src)
  (match src
    [(struct srcloc [source line col pos span])
     (format "~a~a"
       (or source "")
       (if line
         (if col
           (format ":~a.~a" line col)
           (format ":~a" line))
         (if pos
           (if span
             (format "::~a-~a" pos (+ pos span))
             (format "::~a" pos))
           "")))]))

(define (srcloc->prefix src)
  (let* ([str (srcloc->string src)])
    (if (string=? str "") "" (string-append str ": "))))

(define (with-debugging/proc name source term thunk)
  (let* ([src (srcloc->prefix (src->srcloc source))])
    (begin
      (dprintf ">> ~a~s" src name)
      (begin0
        (parameterize ([current-debug-depth
                        (add1 (current-debug-depth))])
          (call-with-values thunk
            (lambda results
              (match results
                [(list v) (dprintf "~s" v)]
                [(list vs ...)
                 (dprintf "(values~a)"
                          (apply string-append
                            (for/list ([v (in-list vs)])
                              (format " ~s" v))))])
              (apply values results))))
        (dprintf "<< ~a~s" src name)))))

(define (dprintf fmt . args)
  (let* ([message (apply format fmt args)]
         [prefix (make-string (* debug-indent (current-debug-depth)) #\space)]
         [indented
          (string-append
           prefix
           (regexp-replace* "\n" message (string-append "\n" prefix)))])
    (log-debug indented)))

(define current-debug-depth (make-parameter 0))
(define debug-indent 2)