(#%require racket/trace
           (only racket/base
                 gensym
                 with-continuation-mark
                 current-continuation-marks
                 continuation-mark-set->list)
           (prefix base: racket/base))

;; /racket/collects/racket/trace.rkt

(define (display-abn a b n)
  (cond ((> n 0) (display a)
                 (display-abn b a (- n 1)))))

(define (display-args id args level)
  (display-abn ">" " " (+ level 1))
  (display `(,id ,@args))
  (newline))

(define (display-results result level)
  (display-abn "<" " " (+ level 1))
  (for-each (lambda (r)
              (display r)(display " "))
            result)
  (newline))

(define-syntax list-trace
  (syntax-rules ()
    ((my-trace fn)
     (set! fn (let ((orig fn))
                (lambda args (apply-traced orig (quote fn) args)))))))

(define -:trace-level-key (gensym))

(define (apply-traced fn id args)
  (let* ((levels (continuation-mark-set->list
                  (current-continuation-marks)
                  -:trace-level-key))
         (level (if (null? levels) 0 (base:car levels))))    
    (with-continuation-mark -:trace-level-key (+ level 1)
      (let ((new-levels (continuation-mark-set->list
                         (current-continuation-marks)
                         -:trace-level-key)))
        (if (and (base:pair? (base:cdr new-levels))
                 (> (base:car new-levels) (+ 1 (base:cadr new-levels))))
            (begin '()
                   (display-args id args (- level 1))
                   (with-continuation-mark -:trace-level-key (base:car levels)
                     (apply fn args)))
            (begin '()
                   (display-args id args level)
                   (with-continuation-mark -:trace-level-key level
                     (base:call-with-values
                      (lambda ()
                        (with-continuation-mark -:trace-level-key (+ level 1)
                          (apply fn args)))
                      (lambda results
                        (display-results results level)
                        (apply base:values results))))))))))