A quickscript to list and search the top level definitions

defines.rkt

#lang racket/base

;;;; License: MIT/Apache2.0

(require quickscript
         racket/gui/base
         racket/class
         racket/list
         racket/match
         racket/string
         racket/format
         syntax/modread)

(script-help-string "List and search the top level definitions")


(define (file/module->value f)
  (with-input-from-file f
    (λ ()
      (port-count-lines! (current-input-port))
      (with-module-reading-parameterization
        read-syntax))))

(define (file/module-defs f)
  (define mod (file/module->value f))
  (define inmod
    (syntax-case mod ()
    [(_ name lang (_ top-levels ...))
     (syntax-e #'(top-levels ...))]
    [else #f]))
  (and
   inmod
   (filter-map
    (λ (s)
      (match (syntax->datum s)
        [`(define ,head . ,rst)
         (list head (syntax-line s))]
        [else #f]))
    inmod)))

(define fr #f)

(define-script get-defines
  #:label "defines"
  #:shortcut f6
  #:shortcut-prefix (ctl)
  #:persistent
  ;#:output-to message-box
  (λ (selection #:file f #:frame drr #:definitions ed)
    (define defs (file/module-defs f))
    (when defs
      (set! defs (sort (map (λ (d) (list (~v (first d)) (second d))) defs)
                       string<=? #:key first)))

    (when fr (send fr show #f))
    (set! fr (new frame% [parent drr] [label "Defines"]
                  [width 600] [height 400]
                  #;[style '(float)]))
    (define vp (new vertical-panel% [parent fr] [alignment '(left center)]))
    (new message% [parent vp] [label "Press Escape to exit, ↑↓ to select, Space to go there."])
    (define mtext-field%
      (class text-field%
        (define/override (on-subwindow-char tf ev)
          (case (send ev get-key-code)
            [(down)    (send lb focus)]
            [(escape)  (send fr show #f)]
            [else (super on-subwindow-char tf ev)]))
        (super-new)))
    (define search-box
      (new mtext-field% [parent vp]
           [label #f]
           [callback (λ (tf ev)
                       (case (send ev get-event-type)
                         [(text-field)
                          (update-msg (send tf get-value))]
                         #;[(text-field-enter)
                          (send fr show #f)]))]))

    (define (lb-goto-line lb)
      (define line (send lb get-data (send lb get-selection)))
      (when line
        (if ed
          (send ed set-position (send ed line-start-position line))
          (message-box "Defines" (format "I want to go to line ~a" line)))))

    (define mlist-box%
      (class list-box%
        (define/override (on-subwindow-char lb ev)
          (case (send ev get-key-code)
            [(#\return) (lb-goto-line lb)]
            [(escape)   (send search-box focus)]
            [else (super on-subwindow-char lb ev)]))
        (super-new)))
    (define lb (new mlist-box% [parent vp] [label #f]
                    [choices '()]
                    [callback
                     (λ (lb ev)
                       (case (send ev get-event-type)
                         [(list-box-dclick) (lb-goto-line lb)]))]))
    (define (update-msg filt)
      (send lb clear)
      (cond
        [defs
          (for ([d (in-list defs)])
            (define dstr (first d))
            (when (string-contains? dstr filt)
              (send lb append
                    ; label-strings can't be more than 200 chars.
                    (substring dstr 0 (min 200 (string-length dstr)))
                    (- (second d) 1))))] ; lines are off by one syntax/editor
        [f (send lb append "Could not parse file.")]
        [else (send lb append "File must be saved on disk.")])
      ;; HOW TO RESIZE PROPERLY???
      #;(define sz 32)
      #;(send lb min-height (* sz (length strs)))
      #;(send fr reflow-container))
    
    (send search-box set-value selection)
    (update-msg selection)
    
    (send fr show #t)
    (send search-box focus)
    #f))


(module+ drracket
  (file/module-defs "defines.rkt")
  (displayln (get-defines "" #:file "defines.rkt" #:frame #f #:definitions #f)))