syntax-utils.rkt (9589B)
1 #lang scheme/base 2 3 (require "output.rkt" (for-syntax scheme/base syntax/kerncase)) 4 5 (provide module-begin/text begin/text include/text begin/collect 6 process-begin/text) 7 8 (begin-for-syntax 9 (define definition-ids ; ids that don't require forcing 10 (syntax->list #'(define-values define-syntaxes begin-for-syntax 11 require provide #%require #%provide #%declare))) 12 (define stoplist (append definition-ids (kernel-form-identifier-list))) 13 (define (definition-id? id) 14 (and (identifier? id) 15 (ormap (λ (i) (free-identifier=? id i)) definition-ids))) 16 (define (definition? x) 17 (syntax-case x () [(id . rest) (and (definition-id? #'id) #'id)] [_ #f])) 18 (define (begin?->list x) 19 (syntax-case x (begin) [(begin x ...) (syntax->list #'(x ...))] [_ #f])) 20 ;; This function is used to group a syntax list into triplets of consecutive 21 ;; scribble indentation syntaxes, an input expression, and scribble newlines. 22 ;; It is used to ignore indentations before a definition and newlines after 23 ;; it. See the following test cases for how it works. 24 (define (group-by pred? xs fun) 25 (let loop ([xs xs] [before '()] [cur #f] [after '()] [r '()]) 26 (define (add) (cons (fun (reverse before) cur (reverse after)) r)) 27 (if (null? xs) 28 (reverse (if (or cur (pair? before) (pair? after)) (add) r)) 29 (let* ([x (car xs)] [xs (cdr xs)] [p (pred? x)]) 30 (cond [(eq? '> p) (loop xs before cur (cons x after) r)] 31 [(eq? '< p) (if (or cur (pair? after)) 32 (loop xs (list x) #f '() (add)) 33 (loop xs (cons x before) cur after r))] 34 [(or cur (pair? after)) (loop xs '() x '() (add))] 35 [else (loop xs before x '() r)]))))) 36 (define (group-stxs stxs fun) 37 (group-by (λ (stx) 38 (define p (syntax-property stx 'scribble)) 39 (cond [(and (pair? p) (eq? (car p) 'newline)) '>] 40 [(eq? 'indentation p) '<] 41 [else #f])) 42 stxs fun)) 43 #; ; tests for this 44 (for-each 45 (λ (t) 46 (define r (group-by (λ (x) 47 (cond [(number? x) '<] [(symbol? x) '>] [else #f])) 48 (car t) 49 list)) 50 (unless (equal? r (cadr t)) (printf "FAILURE: ~s -> ~s\n" (car t) r))) 51 '([() ()] 52 [("a") ((() "a" ()))] 53 [("a" "b") ((() "a" ()) (() "b" ()))] 54 [(1 "a" x) (((1) "a" (x)))] 55 [(1 2 3 "a" x y z) (((1 2 3) "a" (x y z)))] 56 [(1 2 3 "a" "b" x y z) (((1 2 3) "a" ()) (() "b" (x y z)))] 57 [(1 2 "a" x 3 "b" y z) (((1 2) "a" (x)) ((3) "b" (y z)))] 58 [(1 2 "a" 3 "b" y z) (((1 2) "a" ()) ((3) "b" (y z)))] 59 [(1 2 "a" 3 x "b" y z) (((1 2) "a" ()) ((3) #f (x)) (() "b" (y z)))] 60 [(1 2 "a" 3 4 x "b" y z) (((1 2) "a" ()) ((3 4) #f (x)) (() "b" (y z)))] 61 [(1 2 "a" 3 w x "b" y z) (((1 2) "a" ()) ((3) #f (w x)) (() "b" (y z)))] 62 [(1) (((1) #f ()))] 63 [(x) ((() #f (x)))] 64 [(1 2 3) (((1 2 3) #f ()))] 65 [(x y z) ((() #f (x y z)))] 66 [(1 2 3 x y z) (((1 2 3) #f (x y z)))] 67 [(1 x 2 y 3 z) (((1) #f (x)) ((2) #f (y)) ((3) #f (z)))] 68 [(1 x y 2 3 z) (((1) #f (x y)) ((2 3) #f (z)))] 69 [(1 2 x 3) (((1 2) #f (x)) ((3) #f ()))] 70 [(w x 3 y z) ((() #f (w x)) ((3) #f (y z)))]))) 71 72 (define-syntax (toplevel-decorate stx) 73 (define context (syntax-local-context)) 74 (syntax-case stx () 75 [(this decor (pre ...) expr (post ...)) 76 (let ([expr* (local-expand #'expr context stoplist)]) 77 (define pre? (not (null? (syntax-e #'(pre ...))))) 78 (define post? (not (null? (syntax-e #'(post ...))))) 79 (define (wrap expr) 80 (if (or pre? post?) 81 #`(begin #,@(if pre? #'((decor 'pre) ...) #'()) 82 #,expr 83 #,@(if post? #'((decor 'post) ...) #'())) 84 expr)) 85 (cond [(begin?->list expr*) 86 => (λ (xs) 87 (if (null? xs) 88 (if (or pre? post?) 89 #'(begin (decor 'pre) ... (decor 'post) ...) 90 expr*) 91 #`(process-begin/text begin decor 92 pre ... #,@xs post ...)))] 93 [(definition? expr*) expr*] ; dump pre/post 94 [else (wrap #`(decor #,expr*))]))])) 95 96 (define-syntax (process-begin/text stx) 97 (define (process-body decor body) 98 (group-stxs 99 (syntax->list body) 100 (λ (pre expr post) 101 (with-syntax ([decor decor]) 102 (if (not expr) ; no need to decorate these 103 (with-syntax ([(x ...) (append pre post)]) #`(decor '(x ...))) 104 (with-syntax ([pre pre] 105 [post post]) 106 #`(toplevel-decorate decor pre #,expr post))))))) 107 (syntax-case stx () 108 [(_ beginner decor expr ...) 109 ;; add a dummy define and throw it away, to get rid of initial newlines 110 (with-syntax ([(_ expr ...) (process-body #'decor #'((define) expr ...))]) 111 #'(beginner expr ...))])) 112 113 ;; module-begin for text files 114 (define-syntax-rule (module-begin/text expr ...) 115 (#%plain-module-begin 116 (port-count-lines! (current-output-port)) 117 (process-begin/text begin output expr ...))) 118 119 ;; `begin'-like utility that allows definitions and collects values 120 (define-for-syntax (split-collect-body exprs ctx) 121 (let loop ([exprs exprs] ; expressions to scan 122 [ds '()] [es '()]) ; collected definitions and expressions 123 (if (null? exprs) 124 (values (reverse ds) (reverse es) '()) 125 (let ([expr* (local-expand (car exprs) ctx stoplist (car ctx))]) 126 (define (rebuild-bindings) 127 (syntax-case expr* () 128 [(def ids rhs) 129 (datum->syntax expr* 130 (list #'def 131 (map syntax-local-identifier-as-binding 132 (syntax->list #'ids)) 133 #'rhs) 134 expr* 135 expr*)])) 136 (syntax-case expr* (begin define-syntaxes define-values) 137 [(begin x ...) 138 (loop (append (syntax->list #'(x ...)) (cdr exprs)) ds es)] 139 [(define-syntaxes (id ...) rhs) 140 (andmap identifier? (syntax->list #'(id ...))) 141 (if (null? es) 142 (let ([ids (syntax->list #'(id ...))]) 143 (syntax-local-bind-syntaxes 144 ids (local-transformer-expand #'rhs 'expression '()) (car ctx)) 145 (loop (cdr exprs) (cons (rebuild-bindings) ds) es)) 146 ;; return the unexpanded expr, to be re-expanded later, in the 147 ;; right contexts 148 (values (reverse ds) (reverse es) exprs))] 149 [(define-values (id ...) rhs) 150 (andmap identifier? (syntax->list #'(id ...))) 151 (if (null? es) 152 (begin (syntax-local-bind-syntaxes 153 (syntax->list #'(id ...)) #f (car ctx)) 154 (loop (cdr exprs) (cons (rebuild-bindings) ds) es)) 155 ;; same note here 156 (values (reverse ds) (reverse es) exprs))] 157 [_ (loop (cdr exprs) ds (cons expr* es))]))))) 158 (define-syntax (begin/collect* stx) ; helper, has a boolean flag first 159 (define-values [exprs always-list?] 160 (let ([exprs (syntax->list stx)]) 161 (if (and (pair? exprs) (pair? (cdr exprs))) 162 (values (cddr exprs) (syntax-e (cadr exprs))) 163 (raise-syntax-error #f "bad syntax" stx)))) 164 (define context 165 (cons (syntax-local-make-definition-context) 166 (let ([old (syntax-local-context)]) (if (list? old) old '())))) 167 (define-values (defns nondefns rest) (split-collect-body exprs context)) 168 (define body 169 (cond [(pair? rest) #`(list* #,@nondefns (begin/collect* #t #,@rest))] 170 [(and (not always-list?) (= 1 (length nondefns))) (car nondefns)] 171 [else #`(list #,@nondefns)])) 172 (begin0 173 (local-expand (if (null? defns) body #`(let () #,@defns #,body)) 174 context stoplist (car context)) 175 (internal-definition-context-seal (car context)))) 176 (define-syntax-rule (begin/collect x ...) (begin/collect* #f x ...)) 177 178 ;; begin for templates (allowing definition blocks) 179 (define-syntax (begin/text stx) 180 (syntax-case stx () 181 [(begin/text expr ...) 182 #'(process-begin/text begin/collect begin expr ...)])) 183 184 ;; include for templates 185 (require (for-syntax scheme/base (prefix-in scribble: scribble/reader) syntax/parse) 186 scheme/include) 187 (define-syntax (include/text stx) 188 (syntax-case stx () 189 [(_ path-spec) 190 (syntax/loc stx 191 (include/text #:command-char #f path-spec))] 192 [(_ #:command-char command-char path-spec) 193 (syntax/loc stx 194 (begin/text 195 (include-at/relative-to/reader 196 path-spec path-spec path-spec 197 (let ([xs #f] 198 [command-char-v command-char]) 199 (λ (src inp) 200 (unless xs 201 (set! xs (if command-char-v 202 (scribble:read-syntax-inside #:command-char command-char-v src inp) 203 (scribble:read-syntax-inside src inp))) 204 (when (syntax? xs) (set! xs (or (syntax->list xs) (list xs))))) 205 (if (null? xs) 206 eof 207 (let ([x (car xs)]) 208 (set! xs (cdr xs)) 209 (if (and (null? xs) 210 (let ([p (syntax-property x 'scribble)]) 211 (and (pair? p) (eq? (car p) 'newline)))) 212 eof ; throw away the last newline from the included file 213 x))))))))]))