www

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README

meta-first-line.rkt (2315B)

      1 #lang racket/base
      2 
      3 (require scribble/reader
      4          racket/port
      5          racket/syntax
      6          syntax/stx
      7          syntax/strip-context
      8          "first-line-utils.rkt"
      9          (only-in "../comment-reader.rkt" make-comment-readtable)
     10          "../comments/hide-comments.rkt")
     11 
     12 (provide meta-read-inside
     13          meta-read-syntax-inside
     14          get-command-char)
     15 
     16 (define (make-at-reader+comments #:syntax? [syntax? #t]
     17                                  #:inside? [inside? #f]
     18                                  #:char [command-char #\@])
     19   (make-at-reader
     20    #:syntax? syntax?
     21    #:inside? inside?
     22    #:command-char command-char
     23    #:datum-readtable (λ (rt)
     24                        (make-comment-readtable
     25                         #:readtable rt
     26                         #:comment-wrapper '#%comment
     27                         #:unsyntax #f))))
     28 
     29 (define (get-command-char rd1)
     30   (define rd1-datum (syntax->datum (datum->syntax #f rd1)))
     31   (if (and (pair? rd1-datum)
     32            (keyword? (car rd1-datum))
     33            (= 1 (string-length (keyword->string (car rd1-datum)))))
     34       (values (string-ref (keyword->string (car rd1-datum)) 0)
     35               (if (syntax? rd1)
     36                   (datum->syntax rd1 (stx-cdr rd1) rd1 rd1)
     37                   (cdr rd1)))
     38       (values #\@ rd1)))
     39 
     40 (define (meta-read-inside in . args)
     41   (define rd1 (read-whole-first-line in))
     42   (define-values (at-exp-char new-rd1) (get-command-char #'rd1))
     43   (define rd (apply (make-at-reader+comments #:syntax? #f
     44                                              #:inside? #t
     45                                              #:char at-exp-char)
     46                     args))
     47   `(,new-rd1 . ,rd))
     48 
     49 (define (meta-read-syntax-inside source-name in . args)
     50   (with-syntax ([rd1 (read-syntax-whole-first-line source-name in)])
     51     (let-values ([(command-char new-rd1) (get-command-char #'rd1)])
     52       (with-syntax* ([new-rd1-stx new-rd1]
     53                      [rd (apply (make-at-reader+comments #:syntax? #t
     54                                                          #:inside? #t
     55                                                          #:char command-char)
     56                                 source-name
     57                                 in
     58                                 args)]
     59                      [rd-hide (hide-#%comment #'rd)])
     60         #'(new-rd1-stx . rd-hide)))))