;; from chicken, csi.scm (interactive interpreter)
;; see $chicken/doc/manual/"using the interpreter"->macros and procs

(define-module trace
  (export trace untrace advise unadvise))

(select-module trace)

(define (delq x lst)
  (let loop ([lst lst])
    (if (null? lst)
	'()
	(let ([y (car lst)])
	  (if (eq? x y)
	      (cdr lst)
	      (cons y (loop (cdr lst))))))))

(define trace-indent-level 0)
(define traced-procedures '())
(define advised-procedures '())

(define trace-indent
  (lambda ()
    (write-char #\|)
    (do ((i trace-indent-level (- i 1)))
	((<= i 0))
      (write-char #\space))))

(define traced-procedure-entry
  (lambda (name args)
    (trace-indent)
    (inc! trace-indent-level)
    (write (cons name args))
    (newline) 
    (flush)))

(define traced-procedure-exit
  (lambda (name results)
    (dec! trace-indent-level)
    (trace-indent)
    (write name)
    (display " -> ")
    (for-each
     (lambda (x)
       (write x)
       (write-char #\space))
     results)
    (newline) 
    (flush)))

(define (do-advise name old)
  (unless (assq name advised-procedures)
    (when (not (procedure? old))
      (error "advise: can not advise non-procedure" old))
    (set! advised-procedures (cons (cons name old) advised-procedures))))

(define (do-unadvise name prev)
  (let ((a (assq name advised-procedures)))
    (if a
	(begin
	  (set! advised-procedures (delq a advised-procedures))
	  ;;(##sys#slot a 1)) XXX WTF?
          )
	(begin
	  (format #f "Procedure `~s' was never advised.\n" name)
	  prev))))

(define-macro (trace . names)
  `(begin
     ,@(map
        (lambda (s)
          (let ((name (gensym))
                (old (gensym)) )
            `(let* ((,name ',s)
                    (,old ,s) )
               (if (not (procedure? ,old))
                   (error "trace: can not trace non-procedure" ,old))
               (set! traced-procedures
                     (cons (cons ,name ,old) traced-procedures))
               (set! ,s (lambda args
                          (traced-procedure-entry ,name args)
                          (call-with-values (lambda () (apply ,old args))
                            (lambda results
                              (traced-procedure-exit ,name results) 
                              (apply values results))))))))
        names)))

(define-macro (untrace . names)
  `(begin
     ,@(map
        (lambda (s)
          (let ((var (gensym))
                (old (gensym)))
            `(let* ((,var ',s)
                    (,old (assq ,var traced-procedures)))
               (if ,old
                   (set! ,s (cdr ,old))
                   (format #f "Procedure `~s' was not traced.\n" ,var))
               (set! traced-procedures (delq ,old traced-procedures)))))
        names)))

(define-macro (advise name mode proc)
  (let ((tmp (gensym))
	(old (gensym)))
    `(let* ((,tmp ,proc)
	    (,old ,name))
       (do-advise ',name ,old)
       (set! ,name
             ,(case mode
                ((before)
                 `(lambda args
                    (apply ,tmp args)
                    (apply ,old args)))
                ((after)
                 `(lambda args
                    (call-with-values
                        (lambda () (apply ,old args))
                      (lambda results
                        (apply ,tmp results)
                        (apply values results)))))
                ((around)
                 `(lambda args
                    (apply ,tmp ,old args) ) )
                (else (error "advise: invalid mode" ',mode)))))))

(define-macro (unadvise . names)
  `(begin
     ,@(map (lambda (n) 
	      `(set! ,n (do-unadvise ',n ,n)))
	    names)))

(provide "trace")

;; -----------------------------------------------------------------
;; test
(import trace)

;; double recursive
(define (fibonacci n)
  (cond ((= n 0) 0)
        ((= n 1) 1)
        (else (+ (fibonacci (- n 1)) (fibonacci (- n 2))))))

(trace fibonacci)
(fibonacci 10)

;; -----------------------------------------------------------------
;; (define trace-hl-macros #<<EOF
;;   (begin

;;     (define-syntax trace
;;       (lambda (x)
;;         (syntax-case x ()
;;                      [(_) (syntax (##core#undefined))]
;;                      [(_ name ...)
;;                       (with-syntax ([(tmp ...) (generate-temporaries (syntax (name ...)))])
;;                                    (syntax
;;                                     (let ([tmp name] ...)
;;                                       (if (not (procedure? tmp)) (##sys#error 'trace "can not trace non-procedure" tmp)) ...
;;                                       (set! ##csi#traced-procedures (cons (cons 'name tmp) ##csi#traced-procedures)) ...
;;                                       (set! name (lambda args
;;                                                    (##csi#traced-procedure-entry 'name args)
;;                                                    (##sys#call-with-values (lambda () (##sys#apply tmp args))
;;                                                                            (lambda results
;;                                                                              (##csi#traced-procedure-exit 'name results)
;;                                                                              (##sys#apply ##sys#values results) ) ) ) )
;;                                       ...) ) ) ] ) ) )

;;     (define-syntax untrace
;;       (lambda (x)
;;         (syntax-case x ()
;;                      [(_) (syntax (##core#undefined))]
;;                      [(_ name ...)
;;                       (with-syntax ([(tmp ...) (generate-temporaries (syntax (name ...)))])
;;                                    (syntax
;;                                     (let ([tmp (assq 'name ##csi#traced-procedures)] ...)
;;                                       (if tmp (set! name (cdr tmp))) ...
;;                                       (set! ##csi#traced-procedures (##csi#delq tmp ##csi#traced-procedures)) ...) ) ) ] ) ) )

;;     (define-syntax advise
;;       (syntax-rules (before after around)
;;         [(_ "1" name before tmp old)
;;          (set! name (lambda args (apply tmp args) (apply old args))) ]
;;         [(_ "1" name after tmp old)
;;          (set! name
;;                (lambda args
;;                  (call-with-values (lambda () (apply old args))
;;                    (lambda results 
;;                      (apply tmp results)
;;                      (apply values results) ) ) ) ) ]
;;         [(_ "1" name around tmp old)
;;          (set! name (lambda args (apply tmp old args))) ]
;;         [(_ name mode proc)
;;          (let ([tmp proc]
;;                [old name] )
;;            (##csi#do-advise 'name old)
;;            (advise "1" name mode tmp old) ) ] ) )

;;     (define-syntax unadvise
;;       (syntax-rules ()
;;         [(_ name ...)
;;          (begin
;;            (set! name (##csi#do-unadvise 'name name)) ...) ] ) )

;;     )
;;   EOF
;;   )