commit 48d2aa54a37693aef8cd303400566718a4df4b7e
parent 0700b413cb4376e3688dbc6fc16caa29ee6ec48f
Author: Robby Findler <robby@racket-lang.org>
Date: Fri, 13 Feb 2009 21:37:09 +0000
setup a literate programming chat-noir
svn: r13555
original commit: 3687ef84e5bb1b9f6d0b4cc4a69a9f77cbf4d8d3
Diffstat:
2 files changed, 83 insertions(+), 0 deletions(-)
diff --git a/collects/games/chat-noir/literate-lang.ss b/collects/games/chat-noir/literate-lang.ss
@@ -0,0 +1,76 @@
+#lang scheme
+
+(provide (except-out (all-from-out scheme)
+ #%module-begin)
+ (rename-out [module-begin #%module-begin])
+ (all-from-out scribble/basic
+ scribble/manual)
+ chunk)
+
+(require (for-syntax scheme/base syntax/boundmap scheme/list)
+ scribble/manual
+ scribble/struct
+ scribble/basic
+ scribble/decode)
+
+(begin-for-syntax
+ (define main-id #f)
+ (define code-blocks (make-free-identifier-mapping))
+ (define (get-id-exprs id)
+ (free-identifier-mapping-get code-blocks id (lambda () '())))
+ (define (get-block id)
+ (map syntax-local-introduce (get-id-exprs id)))
+ (define (add-to-block! id exprs)
+ (unless main-id (set! main-id id))
+ (free-identifier-mapping-put!
+ code-blocks id
+ `(,@(get-id-exprs id) ,@(map syntax-local-introduce exprs)))))
+
+(define :make-splice make-splice)
+
+(define-syntax (chunk stx)
+ (syntax-case stx ()
+ [(_ name expr ...)
+ (begin
+ (unless (identifier? #'name)
+ (raise-syntax-error #f "expected a chunk name" stx #'name))
+ (unless (regexp-match #rx"^<.*>$" (symbol->string (syntax-e #'name)))
+ (raise-syntax-error #f "chunk names must begin and end with angle brackets, <...>"
+ stx
+ #'name))
+ (add-to-block! #'name (syntax->list #'(expr ...)))
+ #`(:make-splice
+ (list
+ (italic #,(format "~a = " (syntax-e #'name)))
+ (schemeblock expr ...))))]))
+
+(define-syntax (tangle stx)
+ #`(begin
+ #,@(let loop ([block (get-block main-id)])
+ (append-map (lambda (expr)
+ (if (identifier? expr)
+ (let ([subs (get-block expr)])
+ (if (pair? subs) (loop subs) (list expr)))
+ (let ([subs (syntax->list expr)])
+ (if subs
+ (list (loop subs))
+ (list expr)))))
+ block))))
+
+(define-syntax (module-begin stx)
+ (syntax-case stx ()
+ [(module-begin expr ...)
+ (with-syntax ([doc (datum->syntax stx 'doc stx)]
+ ;; this forces expansion so `chunk' can appear anywhere, if
+ ;; it's allowed only at the toplevel, then there's no need
+ ;; for it
+ [(expr ...)
+ (map (lambda (expr) (local-expand expr 'module '()))
+ (syntax->list #'(expr ...)))])
+ ;; define doc as the binding that has all the scribbled documentation
+ #'(#%module-begin
+ (define doc '())
+ (provide doc)
+ (set! doc (cons expr doc)) ...
+ (tangle)
+ (set! doc (decode (reverse doc)))))]))
diff --git a/collects/games/chat-noir/literate-reader.ss b/collects/games/chat-noir/literate-reader.ss
@@ -0,0 +1,7 @@
+#lang s-exp syntax/module-reader
+"literate-lang.ss"
+#:read read-inside
+#:read-syntax read-syntax-inside
+#:whole-body-readers? #t
+
+(require scribble/reader)
