suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

svn: r13556

Browse Source 
original commit: b9560ae309e03bbfc9675d418e0ce6a08c52452f
This commit is contained in:
Robby Findler 2009-02-13 21:45:13 +00:00
parent 48d2aa54a3
commit 919845d306
2 changed files with 83 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

152
collects/games/chat-noir/literate-lang.ss
View File

@ -1,76 +1,76 @@
#lang scheme #lang scheme
(provide (except-out (all-from-out scheme) (provide (except-out (all-from-out scheme)
#%module-begin) #%module-begin)
(rename-out [module-begin #%module-begin]) (rename-out [module-begin #%module-begin])
(all-from-out scribble/basic (all-from-out scribble/basic
scribble/manual) scribble/manual)
chunk) chunk)
(require (for-syntax scheme/base syntax/boundmap scheme/list) (require (for-syntax scheme/base syntax/boundmap scheme/list)
scribble/manual scribble/manual
scribble/struct scribble/struct
scribble/basic scribble/basic
scribble/decode) scribble/decode)
(begin-for-syntax (begin-for-syntax
(define main-id #f) (define main-id #f)
(define code-blocks (make-free-identifier-mapping)) (define code-blocks (make-free-identifier-mapping))
(define (get-id-exprs id) (define (get-id-exprs id)
(free-identifier-mapping-get code-blocks id (lambda () '()))) (free-identifier-mapping-get code-blocks id (lambda () '())))
(define (get-block id) (define (get-block id)
(map syntax-local-introduce (get-id-exprs id))) (map syntax-local-introduce (get-id-exprs id)))
(define (add-to-block! id exprs) (define (add-to-block! id exprs)
(unless main-id (set! main-id id)) (unless main-id (set! main-id id))
(free-identifier-mapping-put! (free-identifier-mapping-put!
code-blocks id code-blocks id
`(,@(get-id-exprs id) ,@(map syntax-local-introduce exprs))))) `(,@(get-id-exprs id) ,@(map syntax-local-introduce exprs)))))
(define :make-splice make-splice) (define :make-splice make-splice)
(define-syntax (chunk stx) (define-syntax (chunk stx)
(syntax-case stx () (syntax-case stx ()
[(_ name expr ...) [(_ name expr ...)
(begin (begin
(unless (identifier? #'name) (unless (identifier? #'name)
(raise-syntax-error #f "expected a chunk name" stx #'name)) (raise-syntax-error #f "expected a chunk name" stx #'name))
(unless (regexp-match #rx"^<.*>$" (symbol->string (syntax-e #'name))) (unless (regexp-match #rx"^<.*>$" (symbol->string (syntax-e #'name)))
(raise-syntax-error #f "chunk names must begin and end with angle brackets, <...>" (raise-syntax-error #f "chunk names must begin and end with angle brackets, <...>"
stx stx
#'name)) #'name))
(add-to-block! #'name (syntax->list #'(expr ...))) (add-to-block! #'name (syntax->list #'(expr ...)))
#`(:make-splice #`(:make-splice
(list (list
(italic #,(format "~a = " (syntax-e #'name))) (italic #,(format "~a = " (syntax-e #'name)))
(schemeblock expr ...))))])) (schemeblock expr ...))))]))
(define-syntax (tangle stx) (define-syntax (tangle stx)
#`(begin #`(begin
#,@(let loop ([block (get-block main-id)]) #,@(let loop ([block (get-block main-id)])
(append-map (lambda (expr) (append-map (lambda (expr)
(if (identifier? expr) (if (identifier? expr)
(let ([subs (get-block expr)]) (let ([subs (get-block expr)])
(if (pair? subs) (loop subs) (list expr))) (if (pair? subs) (loop subs) (list expr)))
(let ([subs (syntax->list expr)]) (let ([subs (syntax->list expr)])
(if subs (if subs
(list (loop subs)) (list (loop subs))
(list expr))))) (list expr)))))
block)))) block))))
(define-syntax (module-begin stx) (define-syntax (module-begin stx)
(syntax-case stx () (syntax-case stx ()
[(module-begin expr ...) [(module-begin expr ...)
(with-syntax ([doc (datum->syntax stx 'doc stx)] (with-syntax ([doc (datum->syntax stx 'doc stx)]
;; this forces expansion so `chunk' can appear anywhere, if ;; this forces expansion so `chunk' can appear anywhere, if
;; it's allowed only at the toplevel, then there's no need ;; it's allowed only at the toplevel, then there's no need
;; for it ;; for it
[(expr ...) [(expr ...)
(map (lambda (expr) (local-expand expr 'module '())) (map (lambda (expr) (local-expand expr 'module '()))
(syntax->list #'(expr ...)))]) (syntax->list #'(expr ...)))])
;; define doc as the binding that has all the scribbled documentation ;; define doc as the binding that has all the scribbled documentation
#'(#%module-begin #'(#%module-begin
(define doc '()) (define doc '())
(provide doc) (provide doc)
(set! doc (cons expr doc)) ... (set! doc (cons expr doc)) ...
(tangle) (tangle)
(set! doc (decode (reverse doc)))))])) (set! doc (decode (reverse doc)))))]))

14
collects/games/chat-noir/literate-reader.ss
View File

@ -1,7 +1,7 @@
#lang s-exp syntax/module-reader #lang s-exp syntax/module-reader
"literate-lang.ss" "literate-lang.ss"
#:read read-inside #:read read-inside
#:read-syntax read-syntax-inside #:read-syntax read-syntax-inside
#:whole-body-readers? #t #:whole-body-readers? #t
(require scribble/reader) (require scribble/reader)