suzanne.soy/aful
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add support for better rendering of the #λ in hyper-literate programs and programs which use scribble-enhanced.

Browse Source
This commit is contained in:
Georges Dupéron 2016-12-27 19:17:05 +01:00
parent 17ecdc23cf
commit f20a10f0b8
2 changed files with 39 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
aful/reader.rkt
View File

@ -19,6 +19,8 @@
racket/function racket/function
syntax/srcloc syntax/srcloc
hygienic-reader-extension/extend-reader hygienic-reader-extension/extend-reader
"scribble-enhanced.rkt"
phc-toolkit/stx
(for-meta -10 racket/base) (for-meta -10 racket/base)
(for-meta -9 racket/base) (for-meta -9 racket/base)
(for-meta -8 racket/base) (for-meta -8 racket/base)
@ -51,7 +53,7 @@
((wrap-reader read) in))) ((wrap-reader read) in)))
(define (aful-read-syntax [src (object-name (current-input-port))] [in (current-input-port)] (define (aful-read-syntax [src (object-name (current-input-port))] [in (current-input-port)]
#:arg-str [arg-str (current-arg-string)]) #:arg-str [arg-str (current-arg-string)])
(parameterize ([current-arg-string arg-str]) (parameterize ([current-arg-string arg-str])
((wrap-reader read-syntax) src in))) ((wrap-reader read-syntax) src in)))
@ -66,14 +68,14 @@
#:outer-scope outer-scope #:outer-scope outer-scope
#:arg-str [arg-str (current-arg-string)]) #:arg-str [arg-str (current-arg-string)])
(make-aful-readtable orig-rt (make-aful-readtable orig-rt
#:outer-scope (λ (stx [mode 'flip]) stx) #:outer-scope (λ (stx [mode 'flip]) stx)
#:arg-str arg-str)) #:arg-str arg-str))
#:hygiene? #f) #:hygiene? #f)
p-args))) p-args)))
(define (make-aful-readtable [orig-rt (current-readtable)] (define (make-aful-readtable [orig-rt (current-readtable)]
#:outer-scope outer-scope #:outer-scope outer-scope
#:arg-str [arg-str (current-arg-string)]) #:arg-str [arg-str (current-arg-string)])
(define reader-proc (make-reader-proc orig-rt outer-scope #:arg-str arg-str)) (define reader-proc (make-reader-proc orig-rt outer-scope #:arg-str arg-str))
(let* ([rt orig-rt] (let* ([rt orig-rt]
[rt (make-readtable rt #\λ 'dispatch-macro reader-proc)] [rt (make-readtable rt #\λ 'dispatch-macro reader-proc)]
@ -146,9 +148,9 @@
(define loc-stx (build-source-location-syntax loc)) (define loc-stx (build-source-location-syntax loc))
(define λ-loc (define λ-loc
(update-source-location loc-stx (update-source-location loc-stx
#:column (and col (+ col 1)) #:column (and col (+ col 1))
#:position (and pos (+ pos 1)) #:position (and pos (+ pos 1))
#:span (and stx-pos pos (max 0 (- stx-pos pos 1))))) #:span (and stx-pos pos (max 0 (- stx-pos pos 1)))))
(hygienic-app (hygienic-app
#:outer-scope outer-scope #:outer-scope outer-scope
(lambda (stx*) (lambda (stx*)
@ -157,10 +159,14 @@
[% (string->id stx* arg-str)] [% (string->id stx* arg-str)]
[%1 (string->id stx* arg-str "1")] [%1 (string->id stx* arg-str "1")]
[body stx*]) [body stx*])
(syntax/loc loc-stx (syntax-property
(lambda args (syntax/top-loc loc-stx
(define-syntax % (make-rename-transformer #'%1)) (lambda args
body)))) (define-syntax % (make-rename-transformer #'%1))
body))
'scribble-render
aful-scribble-render)
))
stx))) stx)))
(define (orig stx) (define (orig stx)
@ -172,25 +178,25 @@
(syntax->datum (parse stx identity))) (syntax->datum (parse stx identity)))
(check-equal? (chk #'(+)) (check-equal? (chk #'(+))
'(lambda () '(lambda ()
(define-syntax % (make-rename-transformer #'%1)) (define-syntax % (make-rename-transformer #'%1))
(+))) (+)))
(check-equal? (chk #'(+ 2 %1 %1)) (check-equal? (chk #'(+ 2 %1 %1))
'(lambda (%1) '(lambda (%1)
(define-syntax % (make-rename-transformer #'%1)) (define-syntax % (make-rename-transformer #'%1))
(+ 2 %1 %1))) (+ 2 %1 %1)))
(check-equal? (chk #'(+ 2 %3 %2 %1)) (check-equal? (chk #'(+ 2 %3 %2 %1))
'(lambda (%1 %2 %3) '(lambda (%1 %2 %3)
(define-syntax % (make-rename-transformer #'%1)) (define-syntax % (make-rename-transformer #'%1))
(+ 2 %3 %2 %1))) (+ 2 %3 %2 %1)))
(check-equal? (chk #'(apply list* % %&)) (check-equal? (chk #'(apply list* % %&))
'(lambda (%1 . %&) '(lambda (%1 . %&)
(define-syntax % (make-rename-transformer #'%1)) (define-syntax % (make-rename-transformer #'%1))
(apply list* % %&))) (apply list* % %&)))
(check-equal? (parameterize ([current-arg-string "_"]) (check-equal? (parameterize ([current-arg-string "_"])
(chk #'(apply list* _ _&))) (chk #'(apply list* _ _&)))
'(lambda (_1 . _&) '(lambda (_1 . _&)
(define-syntax _ (make-rename-transformer #'_1)) (define-syntax _ (make-rename-transformer #'_1))
(apply list* _ _&)))) (apply list* _ _&))))
;; parse-args : Stx -> KW-Formals-Stx ;; parse-args : Stx -> KW-Formals-Stx
(define (parse-args stx #:arg-str [arg-str (current-arg-string)]) (define (parse-args stx #:arg-str [arg-str (current-arg-string)])

11
aful/scribble-enhanced.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang racket
(require scribble-enhanced/with-manual)
(provide aful-scribble-render)
(define (aful-scribble-render self)
(syntax-case self ()
[(_ _ _ body)
#`(elem (list (seclink "_lang_aful" #:doc '(lib "aful/docs/aful.scrbl")
(tt "#λ"))
(racket body)))]))