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

On Sun, 2 Nov 2003, Guillaume Marceau wrote:

> I am also attaching a tag file for plt-205 to this email. It's a wooping 17k!
>

Fixed a bug, documentation bug, and a stylistic bug, then regenerated the
TAGS file for drscheme v205. The TAGS file now weights in at 91kb.


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


(with-handlers
    ([exn:break? (lambda (exn) (void))])
  (let ([target-tag-file (open-output-file "TAGS" 'replace)])
    (for-each 
     (lambda (f) (process-file f target-tag-file))
     (vector->list argv))
    (close-output-port target-tag-file)))


-------------- next part --------------
A non-text attachment was scrubbed...
Name: TAGS.gz
Type: application/octet-stream
Size: 21725 bytes
Desc: 
URL: <http://lists.racket-lang.org/users/archive/attachments/20031102/d5f51db4/attachment.obj>