139 lines
5.6 KiB
Racket
139 lines
5.6 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class
|
|
racket/function
|
|
racket/list
|
|
string-constants)
|
|
|
|
(provide (struct-out defn)
|
|
get-definitions)
|
|
|
|
;; defn = (make-defn number string number number)
|
|
(define-struct defn (indent name start-pos end-pos) #:mutable)
|
|
|
|
;; get-definitions : string boolean text -> (listof defn)
|
|
(define (get-definitions tag-string indent? text)
|
|
(let* ([min-indent 0]
|
|
[defs (let loop ([pos 0])
|
|
(let ([defn-pos (send text find-string tag-string 'forward pos 'eof #t #f)])
|
|
(cond
|
|
[(not defn-pos) null]
|
|
[(in-semicolon-comment? text defn-pos)
|
|
(loop (+ defn-pos (string-length tag-string)))]
|
|
[else
|
|
(let ([indent (get-defn-indent text defn-pos)]
|
|
[name (get-defn-name text (+ defn-pos (string-length tag-string)))])
|
|
(set! min-indent (min indent min-indent))
|
|
(cons (make-defn indent name defn-pos defn-pos)
|
|
(loop (+ defn-pos (string-length tag-string)))))])))])
|
|
|
|
;; update end-pos's based on the start pos of the next defn
|
|
(unless (null? defs)
|
|
(let loop ([first (car defs)]
|
|
[defs (cdr defs)])
|
|
(cond
|
|
[(null? defs)
|
|
(set-defn-end-pos! first (send text last-position))]
|
|
[else (set-defn-end-pos! first (max (- (defn-start-pos (car defs)) 1)
|
|
(defn-start-pos first)))
|
|
(loop (car defs) (cdr defs))])))
|
|
|
|
(when indent?
|
|
(for-each (λ (defn)
|
|
(set-defn-name! defn
|
|
(string-append
|
|
(apply string
|
|
(vector->list
|
|
(make-vector
|
|
(- (defn-indent defn) min-indent) #\space)))
|
|
(defn-name defn))))
|
|
defs))
|
|
defs))
|
|
|
|
;; in-semicolon-comment: text number -> boolean
|
|
;; returns #t if `define-start-pos' is in a semicolon comment and #f otherwise
|
|
(define (in-semicolon-comment? text define-start-pos)
|
|
(let* ([para (send text position-paragraph define-start-pos)]
|
|
[start (send text paragraph-start-position para)])
|
|
(let loop ([pos start])
|
|
(cond
|
|
[(pos . >= . define-start-pos) #f]
|
|
[(char=? #\; (send text get-character pos)) #t]
|
|
[else (loop (+ pos 1))]))))
|
|
|
|
;; get-defn-indent : text number -> number
|
|
;; returns the amount to indent a particular definition
|
|
(define (get-defn-indent text pos)
|
|
(let* ([para (send text position-paragraph pos)]
|
|
[para-start (send text paragraph-start-position para #t)])
|
|
(let loop ([c-pos para-start]
|
|
[offset 0])
|
|
(if (< c-pos pos)
|
|
(let ([char (send text get-character c-pos)])
|
|
(cond
|
|
[(char=? char #\tab)
|
|
(loop (+ c-pos 1) (+ offset (- 8 (modulo offset 8))))]
|
|
[else
|
|
(loop (+ c-pos 1) (+ offset 1))]))
|
|
offset))))
|
|
|
|
;; whitespace-or-paren?
|
|
(define (whitespace-or-paren? char)
|
|
(or (char=? #\) char)
|
|
(char=? #\( char)
|
|
(char=? #\] char)
|
|
(char=? #\[ char)
|
|
(char-whitespace? char)))
|
|
|
|
;; skip : text number (char -> bool) -> number
|
|
;; Skips characters recognized by `skip?'
|
|
(define (skip text pos skip?)
|
|
(let loop ([pos pos])
|
|
(if (>= pos (send text last-position))
|
|
(send text last-position)
|
|
(let ([char (send text get-character pos)])
|
|
(cond
|
|
[(skip? char)
|
|
(loop (+ pos 1))]
|
|
[else pos])))))
|
|
|
|
;; skip-to-whitespace/paren : text number -> number
|
|
;; skips to the next parenthesis or whitespace after `pos', returns that position.
|
|
(define (skip-to-whitespace/paren text pos)
|
|
(skip text pos (negate whitespace-or-paren?)))
|
|
|
|
;; skip-whitespace/paren : text number -> number
|
|
;; skips past any parenthesis or whitespace
|
|
(define (skip-whitespace/paren text pos)
|
|
(skip text pos whitespace-or-paren?))
|
|
|
|
;; skip-past-non-whitespace : text number -> number
|
|
;; skips to the first whitespace character after the first non-whitespace character
|
|
(define (skip-past-non-whitespace text pos)
|
|
(skip text (skip text pos char-whitespace?) (negate char-whitespace?)))
|
|
|
|
;; get-defn-name : text number -> string
|
|
;; returns the name of the definition starting at `define-pos',
|
|
;; assuming that the bound name is the first symbol to appear
|
|
;; after the one beginning at `define-pos'. This heuristic
|
|
;; usually finds the bound name, but it breaks for Redex
|
|
;; metafunction definitions (thus the hack below).
|
|
(define (get-defn-name text define-pos)
|
|
(let* ([end-suffix-pos (skip-to-whitespace/paren text define-pos)]
|
|
[suffix (send text get-text define-pos end-suffix-pos)]
|
|
[end-header-pos
|
|
(cond [(regexp-match #rx"^-metafunction(/extension)?$" suffix)
|
|
=> (λ (m)
|
|
(let ([extension? (second m)])
|
|
(skip-past-non-whitespace
|
|
text
|
|
(if extension?
|
|
(skip-past-non-whitespace text end-suffix-pos)
|
|
end-suffix-pos))))]
|
|
[else end-suffix-pos])]
|
|
[start-name-pos (skip-whitespace/paren text end-header-pos)]
|
|
[end-name-pos (skip-to-whitespace/paren text start-name-pos)])
|
|
(if (>= end-suffix-pos (send text last-position))
|
|
(string-constant end-of-buffer-define)
|
|
(send text get-text start-name-pos end-name-pos))))
|