;;;; trace.stk -- Trace & Untrace
;;;; 
;;;; Copyright © 1997-2002 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 
;;;; USA.
;;;; 
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 26-Apr-1997 16:02 (eg)
;;;; Last file update:  1-May-2002 23:31 (eg)
;;;;
;;;; 20021223 Adapted for Gauche by Michel van de Ven <hipster@xs4all.nl>
;;;;

#|
<doc EXT-SYNTAX trace
* (trace f-name ...)
*
* Invoking |trace| with one or more function names causes the functions
* named to be traced. Henceforth, whenever such a function is invoked,
* information about the call and the returned values, if any, will be
* printed on the current error port.
*
* Calling |trace| with no argument returns the list of traced functions.
doc>
|#

#|
<doc EXT-SYNTAX untrace
* (untrace f-name ...)
*
* Invoking |untrace| with one or more function names causes the functions
* named not to be traced anymore.
* 
* Calling |untrace| with no argument will print the list of traced
* functions on the current error port.
doc>
|#

(define-module trace
  (export trace untrace)
  (define *traced-symbols* (make-hash-table 'equal?))
  (define *indentation* -1)             ; XXX why the extra level with 0?
  (define *err-port* (current-error-port))
  (define (indent)
    (with-output-to-string
      (lambda ()
        (dotimes (i *indentation*)
          (display "| ")))))
  (define (indent-more)
    (inc! *indentation*))
  (define (indent-less)
    (dec! *indentation*))
  (define (display-result l)
    (if (= (length l) 1)
        ;; Only one result
        (format *err-port* "~S\n" (car l))
        ;; Result is a multiple value
        (begin
          (format *err-port* "<< ")
          (for-each (lambda (x)
                      (format *err-port* "~S " x))
                    l)
          (format *err-port* ">>\n")))
    ;; Return all the values as "normal" result
    (apply values l))

  ;;==================================================================
  ;;
  ;; Class <Traced-generic>
  ;;
  ;; Trace of a generic function is done using MOP.  In fact, to trace
  ;; a gf we change its class from <generic> to <traced-generic>
  ;; Untracing is of course just the contrary
  ;;
  ;;==================================================================
  (define-class <traced-generic> (<generic>)
    ())

  ;;
  ;; How to apply the methods of a <traced-generic>
  ;; 
  (define-method apply-method ((gf <traced-generic>)
                               methods-list build-next args)
    (let* ((name (generic-function-name gf))
	   (m    (car methods-list))
	   (spec (method-specializers m)))
      ;; Trace the closure application in a dynamic wind to restore
      ;; indentation on error.
      (dynamic-wind 
	  indent-more
	  (lambda ()
	    (let ((I   (indent))
		  (res #f))
	      (format *err-port* "~A -> generic function ~S\n" I name)
	      (format *err-port* "~A    spec = ~S\n~A    args = ~S\n" 
		      I (map* class-name spec) I args)
	      (call-with-values
		  (lambda () (apply (method-procedure (car methods-list))
				    (build-next (cdr methods-list) args)
				    args))
                (lambda l
                  (format *err-port* "~A <- GF ~S returns " I name)
                  (display-result l)))))
	  indent-less)))

  ;; ======================================================================
  ;;
  ;; 				T R A C E
  ;;
  ;; ======================================================================
  
  ;;
  ;; Trace-closure
  ;;
  (define (trace-closure symbol value)
    (lambda l
      ;; We trace the closure in a dynamic-wind to restore indentation on error
      (dynamic-wind 
	  indent-more
	  (lambda ()
	    (format *err-port* "~A(~A ~S)\n" (indent) symbol l)
	    (call-with-values
		(lambda () (apply value l))
              (lambda l
                (format *err-port* "~A" (indent))
                (display-result l))))
	  indent-less)))

  ;;
  ;; Trace-generic
  ;;
  (define (trace-generic symbol gf)
    ;; Verify that gf is "exactly" a <generic> (not "is-a?")
    ;; Otherwise, we can lost some information when untracing
    (unless (eq? (class-of gf) <generic>)
      (error 'trace "cannot trace ~S (descendant of <generic>)" symbol))
    (change-class gf <traced-generic>)
    gf)
  
  ;;
  ;; Trace-symbol
  ;;
  (define (trace-symbol symbol proc mod)
    (unless (symbol? symbol)
      (error 'trace "bad symbol: ~S" symbol))
    ;; Verify if "symbol" is already traced
    (let ((entry (hash-table-get *traced-symbols* (cons symbol mod) #f)))
      (when entry
        ;; (car entry) contains the traced proc and (cdr entry) the
        ;; untraced one
	(let ((new (car entry)))
	  (if (and (procedure? new) (eq? new proc))
	      (error 'trace "~S is already traced" symbol)))))
    ;; Do the trace
    (let ((traced-proc (cond  ; Order is important!!!
                        ((is-a? proc <generic>) (trace-generic symbol proc))
                        ((procedure? proc) (trace-closure symbol proc))
                        (else (error 'trace "cannot trace ~S" proc)))))
      (hash-table-put! *traced-symbols*
                       (cons symbol mod)
                       (cons traced-proc proc))
      traced-proc))

  ;;
  ;; The TRACE macro
  ;;
  (define-macro (trace . args)
    (let ((trace-symbol (with-module trace trace-symbol)))
      (if (null? args)
	  ;; Show all the traced symbols
	  `(list ,@(hash-table-map *traced-symbols*
				   (lambda (x y) (list 'quote x))))
	  ;; We have arguments. Trace them
	  `(begin
	     ,@(map (lambda (x) 
		      `(set! ,x (,trace-symbol
                                 ',x ,x (module-name (current-module)))))
		    args)))))

  ;; ======================================================================
  ;;
  ;; 				U N T R A C E
  ;;
  ;; ======================================================================
  
  ;;
  ;; Untrace-symbol
  ;; 
  (define (untrace-symbol symbol mod)
    (unless (symbol? symbol)
      (error 'untrace "bad symbol: ~S" symbol))

    ;; Verify if symbol is already traced
    (let ((entry (hash-table-get *traced-symbols* (cons symbol mod) #f)))
      (if entry
	  (let ((res (cdr entry)))
	    (hash-table-remove! *traced-symbols* (cons symbol mod))
	    ;; For <traced-generic>, revert the function to <generic>
	    (when (is-a? res <traced-generic>) (change-class res <generic>))
	    res)
	  (error 'untrace "~S is not traced" symbol))))

  ;;
  ;; The UNTRACE macro
  ;;
  (define-macro (untrace . args)
    (let ((untrace-symbol (with-module trace trace-symbol)))
      (if (null? args)
	  ;; Untrace, all the traced arguments
	  (let ((traced-symbols (hash-table-map *traced-symbols*
                                                (lambda (x y) (car x)))))
	    (if (null? traced-symbols)
		(void)
		`(untrace ,@traced-symbols)))
	  ;; Normal case, trace only the specified arguments
	  `(begin
	     ,@(map (lambda (x) 
		      `(set! ,x (,untrace-symbol ',x (current-module))))
		    args))))))

(provide "trace")

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

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

;; ;; with accumulator
;; (define (fibonacci2 n)
;;   (define (fibonacci2+ n acc1 acc2)
;;     (if (= n 0)
;;         0
;;         (if (= n 1)
;;               acc1
;;               (fibonacci2+ (- n 1) (+ acc1 acc2) acc1))))
;;   (trace fibonacci2+)
;;   (fibonacci2+ n 1 0))

;; (trace fibonacci1 fibonacci2)
;; (fibonacci1 5)
;; (fibonacci2 5)

;; guile trace output:
;; [fibonacci1 5]
;; |  [fibonacci1 4]
;; |  |  [fibonacci1 3]
;; |  |  |  [fibonacci1 2]
;; |  |  |  |  [fibonacci1 1]
;; |  |  |  |  1
;; |  |  |  |  [fibonacci1 0]
;; |  |  |  |  0
;; |  |  |  1
;; |  |  |  [fibonacci1 1]
;; |  |  |  1
;; |  |  2
;; |  |  [fibonacci1 2]
;; |  |  |  [fibonacci1 1]
;; |  |  |  1
;; |  |  |  [fibonacci1 0]
;; |  |  |  0
;; |  |  1
;; |  3
;; |  [fibonacci1 3]
;; |  |  [fibonacci1 2]
;; |  |  |  [fibonacci1 1]
;; |  |  |  1
;; |  |  |  [fibonacci1 0]
;; |  |  |  0
;; |  |  1
;; |  |  [fibonacci1 1]
;; |  |  1
;; |  2
;; 5