(define *tttime-stack* #f)
(import (only (chicken process) process-sleep)
        (chicken base)
        (only (chicken time) current-milliseconds)
        (only (chicken format) printf format))
(define (report-tttime!)
  (define (tots s)
    (if (null? (caddr s))
        (list (cadr s))
        (cons (apply + (map cadr (caddr s)))
              (map tots (caddr s)))))

  (define (P s t ind)
    (let* ([t1 (cadr s)]
           [t2 (car t)]
           [td (- t1 t2)])
      (printf "~a~a: ~ams~a\n"
              ind (car s) t1
              (if (and (not (null? (cdr t))) (<= .1 td))
                  (format " (~ams hidden)" td)
                  "")))
    (for-each (cute P <> <> (string-append "  " ind))
              (caddr s)
              (cdr t)))

  (define (rev s)
    (list (car s) (cadr s) (reverse (map rev (caddr s)))))

  (let ([stack (rev *tttime-stack*)])
    (P stack (tots stack) ""))
  (set! *tttime-stack* #f))

(define-syntax tttime
  (ir-macro-transformer
   (lambda (e inj cmp)
     (apply
      (lambda (name . body)
	`(let ([stack *tttime-stack*]
               [_ (set! *tttime-stack* '())]
               [start-t (current-milliseconds)])
	   (receive r (begin ,@body)
             (let ([e (list ,name (- (current-milliseconds) start-t) *tttime-stack*)])
	       (if stack
		   (set! *tttime-stack* (cons e stack))
		   (begin
		     (set! *tttime-stack* e)
		     (report-tttime!))))
	     (apply values r))))
      (cdr e)))))

(receive v (tttime "total"
                   (values (tttime "do this" (+ (tttime "1" 1)
                                          (begin (sleep 1) 2)
                                          (tttime "2" (sleep 1) 2)))
                           (tttime "do that"
                                   (+ (tttime "3" 3)
                                      (tttime "2" 2)))))
  (print v))