(module trace mzscheme
       
  (require
   (lib "etc.ss")
   (file "debug.ss")
   )

  (provide define-traced
           lambda-traced)
  
  ;; syntax define-traced
  ;;
  ;; Accepts one of the following forms:
  ;;
  ;;   (define-traced (my-proc a b c ...) ...)
  ;;   (define-traced my-proc (lambda (a b c ...) ...))
  ;;   (define-traced my-proc (opt-pambda (a b c ...) ...))
  ;;
  ;; Inserts a call to dynamic-wind such that trace messages get printed
  ;; to the console whenever control passes into or out of the procedure.
  (define-syntax (define-traced stx)
    ; make-message : boolean syntax-object -> syntax-object
    ;
    ; Creates a lambda function for printing an entry or exit message.
    (define (make-message entry? header-stx)
      (datum->syntax-object
       stx
       (let ([header-list (syntax-object->datum header-stx)])
         `(lambda () 
            ; Display "> (" or "< ("
            (display ,(if entry? "> (" "< ("))
            ; Display procedure name
            (display ,(string-append (symbol->string (car header-list))))
            ; Display argument list
            ,@(let loop ([rest (cdr header-list)])
                (cond
                  [(null? rest) null]
                  [(symbol? (car rest))
                   (cons `(display " ")
                         (cons `(display ,(car rest))
                               (loop (cdr rest))))]
                  [(list? (car rest))
                   (cons `(display " ")
                         (cons `(display ,(caar rest))
                               (cons `(display "*")
                                     (loop (cdr rest)))))]
                  [else (error "Bad syntax in function header: " header-list)]))
            ; Display closing paren
            (display ")\n")))))
    (syntax-case stx ()
      [(_ (a1 a2 ...) e1 e2 ...)
       (with-syntax
           ([entry-message (make-message #t (syntax (a1 a2 ...)))]
            [exit-message (make-message #f (syntax (a1 a2 ...)))])
         (syntax
          (define (a1 a2 ...)
            (dynamic-wind
             entry-message
             (lambda ()
               e1 e2 ...)
             exit-message))))]
      [(_ a1 (lambda (a2 a3 ...) e1 e2 ...))
       (with-syntax
           ([entry-message (make-message #t (syntax (a1 a2 a3 ...)))]
            [exit-message (make-message #f (syntax (a1 a2 a3 ...)))])
         (syntax
          (define a1 
            (lambda (a2 a3 ...)
              (dynamic-wind
               entry-message
               (lambda ()
                 e1 e2 ...)
               exit-message)))))]
      [(_ a1 (opt-lambda (a2 a3 ...) e1 e2 ...))
       (with-syntax
           ([entry-message (make-message #t (syntax (a1 a2 a3 ...)))]
            [exit-message (make-message #f (syntax (a1 a2 a3 ...)))])
         (syntax
          (define a1 
            (opt-lambda (a2 a3 ...)
              (dynamic-wind
               entry-message
               (lambda ()
                 e1 e2 ...)
               exit-message)))))]))
  
  (define-syntax (lambda-traced stx)
    (syntax-case stx ()
      [(lambda-traced (arg ...) exp ...)
       #'(lambda (arg ...)
           (debug "Entering traced lambda" (list arg ...))
           (debug "Leaving traced lambda" (begin exp ...)))]))

  )