diff --git a/collects/games/chat-noir/chat-noir-doc.ss b/collects/games/chat-noir/chat-noir-doc.ss new file mode 100644 index 00000000..d7981e0f --- /dev/null +++ b/collects/games/chat-noir/chat-noir-doc.ss @@ -0,0 +1,75 @@ +#lang scribble/doc + +@(require (for-syntax scheme/base + syntax/boundmap + scheme/list + (prefix-in scr: scribble/reader) + compiler/cm-accomplice)) + +@(require scribble/manual + scribble/struct + scribble/basic + scribble/decode) + +@(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)) + #`(:make-splice + (list + (italic #,(format "~a = " (syntax-e #'name))) + (schemeblock expr ...))))])) + +@;{the two lines below seem like they shoudl work, but they loop forever; probably the read-syntax-inside vs read-syntax difference. If they did work, then all of the stuff below could go away} +@;(require scheme/include) +@;(include/reader "chat-noir-literate.ss" scr:read-syntax-inside) + +@(define-syntax (content-elsewhere stx) + (syntax-case stx () + [(_ fn) + (string? (syntax-e #'fn)) + (let ([fn (syntax-e #'fn)]) + (register-external-file (path->complete-path fn)) + (call-with-input-file fn + (λ (port) + (port-count-lines! port) + (let ([reader-line (read-line port)]) + (unless (regexp-match #rx"^#reader" reader-line) + (raise-syntax-error #f (format "expected a #reader line, found ~s" reader-line) stx)) + (let* ([content (scr:read-syntax-inside fn port)] + [w/context (give-lexical-content stx content)]) + #`(begin #,@w/context))))))])) + +@;{ stolen from include.ss. Should probably be refactored to just have one of these.} +@(define-for-syntax (give-lexical-content ctx content) + (let loop ([content content]) + (cond + [(pair? content) + (cons (loop (car content)) + (loop (cdr content)))] + [(null? content) null] + [else + (let ([v (syntax-e content)]) + (datum->syntax + ctx + (cond + [(pair? v) + (loop v)] + [(vector? v) + (list->vector (loop (vector->list v)))] + [(box? v) + (box (loop (unbox v)))] + [else + v]) + content + content))]))) + +@content-elsewhere["chat-noir-literate.ss"] diff --git a/collects/games/chat-noir/literate-lang.ss b/collects/games/chat-noir/literate-lang.ss index 0c6aa809..93358715 100644 --- a/collects/games/chat-noir/literate-lang.ss +++ b/collects/games/chat-noir/literate-lang.ss @@ -7,7 +7,10 @@ scribble/manual) chunk) -(require (for-syntax scheme/base syntax/boundmap scheme/list) +(require (for-syntax scheme/base + syntax/boundmap + scheme/list + syntax/kerncase) scribble/manual scribble/struct scribble/basic @@ -45,10 +48,7 @@ stx #'name)) (add-to-block! #'name (syntax->list #'(expr ...))) - #`(:make-splice - (list - (italic #,(format "~a = " (syntax-e #'name))) - (schemeblock expr ...))))])) + #`(void))])) (define-syntax (tangle stx) (define block-mentions '()) @@ -80,17 +80,34 @@ (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)))))])) + (let ([body-code + (let loop ([exprs (syntax->list #'(expr ...))]) + (cond + [(null? exprs) null] + [else + (let ([expanded + (local-expand (car exprs) + 'module + (append (kernel-form-identifier-list) + (syntax->list #'(provide + require + #%provide + #%require))))]) + (syntax-case expanded (begin) + [(begin rest ...) + (append (loop (syntax->list #'(rest ...))) + (loop (cdr exprs)))] + [(id . rest) + (ormap (lambda (kw) (free-identifier=? #'id kw)) + (syntax->list #'(require + provide + chunk + #%require + #%provide))) + (cons expanded (loop (cdr exprs)))] + [else (loop (cdr exprs))]))]))]) + + (with-syntax ([(body-code ...) body-code]) + #'(#%module-begin + body-code ... + (tangle))))]))