[plt-scheme] Re: Emacs tags for MzScheme modules

On Sun, 2 Nov 2003, Bill Clementson wrote:

> Great, thanks very much for this! This appears to be
> exactly what I am after. However, when I ran the find
> command, it produced a TAGS file for just a subset of
> the collects directories (only from the profj

Oups. Bash trims the command line when it gets too long. Ok, so
I looked up how the original etags handles this problem and implemented
the same work around. If you give '-' as a filename, etags.ss will read
its files from stdin, one per line.

You can now run it as follows:

         find -name \*.ss -print | etags.ss -

This will give you a 541kb TAGS files, which seems more reasonable than
what I had before. Hopefully it is correct this time... third one's a charm.


-- 
"The thing I remember most about America is that it's silly.
 That can be quite a relief at times."  -- Thom Yorke, Radiohead

- Guillaume

-------------- next part --------------
#!/bin/sh
#|
exec mzscheme -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.


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

|#

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

(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)])

             (let loop ([p p])
               (file-position port p)
               (when (and (> p 0) 
                          (not (eq? (read-char port) #\newline)))
                 (loop (- 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 (first matched))))
                name-sym line 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
      ([not-break-exn?
        (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)])
        (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))))))


(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)))