#!/bin/sh
#|
exec mzscheme -M errortrace -r "$0" "$@"

Generates an TAGS file suitable for Emacs consumption, from the plt-scheme 
files given on the command line. For example, the following is a useful thing:

   cd plt/collects; find -name \*.ss | xargs etags.ss

This will create a file called 'plt/collects/TAGS'. Boot Emacs and hit 'M-.'
Emacs will ask you for the location of the TAGS file (as above) and a name. 
It will then jump to its to the file and the line where that name is defined.


Sun Apr 17 2005
    Ported to MzScheme 299, based on a patch by Danny Yoo

Sun Nov 2 2003
    Written by Guillaume Marceau (gmarceau@cs.brown.edu)  

|#

(require (lib "errortrace.ss" "errortrace")
         (lib "list.ss")
         (lib "etc.ss")
         (lib "file.ss")
         (lib "string.ss"))


;; By default, use the encoding from the default locale.
(define bytes->string bytes->string/locale)



(define (string-chop str)
  (substring str 0 (- (string-length str) 1)))

(define (hash-table-mem? hash item) 
  (let/ec k (begin (hash-table-get hash item (lambda () (k false))) true)))

(define (hash-table-gad! hash key val-fn)
  (if (not (hash-table-mem? hash key)) 
      (begin (let ((v (val-fn)))
               (hash-table-put! hash key v)
               v))
      (hash-table-get hash key)))

(define (string-prefix str len)
  (substring str 0 (min (string-length str) len)))

(define (id-to-tag-line id port)
  (if (or (not (syntax-source id))
          (not (syntax-position id)))
      ""
      (let* ([name-sym (syntax-e id)]
             [s (syntax-source id)]
             [line (syntax-line id)]
             [p (syntax-position id)]
             [lead-in (open-output-string)]
             [rewound-p
              (let loop ([p p])
                (file-position port p)
                (if (and (> p 0) 
                         (not (eq? (read-char port) #\newline)))
                    (loop (- p 1))
                    (+ p 1)))])
        
        (let* ([matched (regexp-match 
                         (regexp (format "^[^\n]*~a[ \t\n]" 
                                         (regexp-quote
                                          (symbol->string name-sym))))
                         port 0 false lead-in)])
          (format
           "~a~a
~a,~a\n" 
           (if (not matched) (string-prefix (get-output-string lead-in) 22)
               (string-append (get-output-string lead-in)
                              (string-chop (bytes->string (first matched)))))
           name-sym line rewound-p)))))

(define (find-defs-in-stx stx)
  (let loop ([substx (expand stx)])
    (syntax-case substx (define-values define-syntaxes)
      [(define-values names-pt body ...) (syntax->list #'names-pt)]
      
      [(define-syntaxes names-pt body ...) (syntax->list #'names-pt)]
      
      [(i ...)  
       (apply append (map loop (syntax->list (syntax (i ...)))))]
      
      [_ empty])))



(define (for-each-tle-in-file fn target-file)
  (with-handlers
      ([exn:fail?
        (lambda (exn) (display (format "Error while processing ~a:\n~a\n\n" 
                                  target-file (exn-message exn)))
           empty)])
    
    (parameterize ([port-count-lines-enabled true]
                   [read-case-sensitive true]
                   [current-load-relative-directory 
                    (path-only (normalize-path target-file))])
      (let ([port (open-input-file target-file)])
	(skip-magic! port)
        (begin0
	      (let loop ([stx (read-syntax target-file port)])
              (unless (eof-object? stx)
                (fn (expand stx))
                (loop (read-syntax target-file port))))
          (close-input-port port))))))

;; skips the magic header off a port, for files that look like scripts.
(define (skip-magic! port)
  (when (equal? #"#!" (peek-bytes 2 0 port))
    (read-line port)))

(define (process-file target-file output-file)           
  (let ([ids empty])
    (for-each-tle-in-file 
     (lambda (stx) (set! ids (append ids (find-defs-in-stx stx))))
     target-file)
    (let* ([target-file-port (open-input-file target-file)]
           [lines (map (lambda (i) (id-to-tag-line i target-file-port)) ids)]
           [section (apply string-append lines)])
      (display (format "\n~a,~a\n~a"
                       target-file (string-length section) section)
               output-file)
      (close-input-port target-file-port))))

(define (process-stdin target-tag-file)
  (let loop ([line (read-line)])
    (unless (eof-object? line)
      (process-file line target-tag-file)
      (loop (read-line)))))

(with-handlers
    ([exn:break? (lambda (exn) (void))])
  (let ([target-tag-file (open-output-file "TAGS" 'replace)]
        [done-stdin false])
    (for-each 
     (lambda (f) 
       (if (and (equal? f "-") (not done-stdin))
           (begin (process-stdin target-tag-file)
                  (set! done-stdin true))
           (process-file f target-tag-file)))
     (vector->list argv))
    (close-output-port target-tag-file)))