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

make scribble executable work

Browse Source 
svn: r7883
This commit is contained in:
Matthew Flatt 2007-12-01 13:33:13 +00:00
parent 6872912820
commit 4d146f1a7b
5 changed files with 9 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/scribble/info.ss
View File

@ -1,6 +1,6 @@
(module info setup/infotab
(define name "Scribble")
(define blurb '("MzScheme extensions for writing text."))
(define blurb '("Text and documention typesetting."))
(define mzscheme-launcher-names '("scribble"))
(define mzscheme-launcher-libraries '("run-scribble.ss"))
(define mzscheme-launcher-libraries '("scribble.ss"))
(define compile-omit-files '("test-reader.ss")))

64
collects/scribble/run-scribble.ss
View File

@ -1,64 +0,0 @@
(module run-scribble mzscheme
(require (lib "cmdline.ss"))
(define exe-name 'scribble) ; for errors
(define (error* msg . args)
(apply raise-user-error exe-name msg args))
(define formats
`([sexpr ,(lambda (v)
((dynamic-require '(lib "pretty.ss") 'pretty-print) v))]))
(define default-format 'sexpr)
(define (format->renderer format)
(cond [(assq format formats)
=> (lambda (f)
(let ([f (cadr f)])
(cond [(procedure? f) f]
[else (error 'format->renderer
"internal error: ~s" f)])))]
[else (error* "unknown format ~e (use -L for a list of formats)"
format)]))
(provide render-file)
(define (render-file input output format)
(unless (file-exists? input)
(error* "cannot find input file: ~e" input))
(let* ([contents (dynamic-require `(file ,input) 'contents)]
[renderer (format->renderer format)]
[render (lambda () (renderer contents))])
(if output (with-output-to-file output render #:exists 'truncate) (render))))
(provide main)
(define (main args)
(define *output-name #f)
(define *format #f)
(command-line (car args) (cdr args)
[once-each
[("-o" "--output") output-name "output name (sometimes a directory)"
(set! *output-name output-name)]
[("-f" "--format") format "output format (implies suffix)"
"(use -L to list available formats)"
(set! *format (string->symbol format))]
[("-L" "--list-formats") "show available output-formats"
(printf "Available formats:\n")
(for-each (lambda (f) (printf " ~a\n" (car f))) formats)
(printf "The default is ~a\n" default-format)
(exit)]]
[args (input-file)
(let* ([fmt (cond [*format *format]
[(and *output-name
(regexp-match #rx"[.]([^.]+)$" *output-name))
=> (lambda (m) (string->symbol (cadr m)))]
[else default-format])]
[output (or *output-name (path-replace-suffix
input-file (symbol->string fmt)))]
[output (and (not (equal? "-" output)) output)])
(render-file input-file output fmt))]))
(main (cons (symbol->string exe-name)
(vector->list (current-command-line-arguments))))
)

2
collects/scribble/run.ss
View File

@ -54,7 +54,7 @@
[("++info-in") file "load format-specific link information form <file>"
(current-info-input-files
(cons file (current-info-input-files)))]]
[args file file]))
[args (file . another-file) (cons file another-file)]))
(define (build-docs-files files)
(build-docs (map (lambda (file)

74
collects/scribble/scribble.ss
View File

@ -1,73 +1,9 @@
(module scribble mzscheme
(require (prefix a: "reader.ss") (lib "kw.ss") (lib "list.ss"))
(provide (all-from-except mzscheme read read-syntax define lambda)
(rename a:read read) (rename a:read-syntax read-syntax)
(rename define/kw define) (rename lambda/kw lambda))
#lang scheme/base
;; --------------------------------------------------------------------------
;; Utilities
(require "run.ss")
(define-syntax define*
(syntax-rules ()
[(_ (name . args) . body)
(begin (provide name) (define/kw (name . args) . body))]
[(_ name val)
(begin (provide name) (define name val))]))
(define files (get-command-line-files
(current-command-line-arguments)))
(define-syntax define-format-element
(syntax-rules ()
([_ name tag]
(begin (define (name . args) (cons tag args))
(provide name)))))
;; allows specifying attributes through sub-elements
(define (subs->keys x keys)
(let ([syms+keys
(append (map (lambda (k) (string->symbol (keyword->string k))) keys)
keys)]
[tag (car x)])
(define (amb-error key)
(error tag "ambiguous `~a' specification" key))
(let loop ([xs (cdr x)] [kvs '()] [seen '()])
(if (not (or (null? xs) (null? (cdr xs)) (not (keyword? (car xs)))))
(let ([key (car xs)])
(when (memq key seen) (amb-error key))
(loop (cddr xs) (list* (cadr xs) key kvs) (cons key seen)))
(let loop ([xs xs] [body '()] [seen seen])
(cond [(null? xs)
(cons tag (append (reverse kvs) (reverse body)))]
[(or (not (pair? (car xs))) (not (memq (caar xs) syms+keys)))
(loop (cdr xs) (cons (car xs) body) seen)]
[else
(let ([key (if (keyword? (caar xs))
(caar xs)
(string->keyword (symbol->string (caar xs))))])
(when (memq key seen) (amb-error (caar xs)))
(when (and (pair? (cdar xs)) (keyword? (cadar xs)))
(error tag "sub-element for `~s' key as its own keys"
(caar xs)))
(set! kvs (list* (cdar xs) key kvs))
(loop (cdr xs) body (cons key seen)))]))))))
;; --------------------------------------------------------------------------
;; Formatting values and functions
(define* (document . body)
(subs->keys (cons 'document body) '(#:title #:author #:date)))
(define-format-element b 'bold)
(define-format-element bf 'bold)
(define-format-element bold 'bold)
(define-format-element i 'italic)
(define-format-element it 'italic)
(define-format-element italic 'italic)
(define-format-element u 'underline)
(define-format-element ul 'underline)
(define-format-element underline 'underline)
(define-format-element tt 'tt)
(define-format-element title 'title)
(define-format-element author 'author)
;; (define-format-element date 'date)
)
(build-docs-files files)

2
collects/scribble/text-render.ss
View File

@ -18,7 +18,7 @@
render-flow-element)
(define/override (render-part d ht)
(let ([number (collected-info-number (part-collected-info d))])
(let ([number (collected-info-number (part-collected-info d ht))])
(when (or (ormap values number)
(part-title-content d))
(newline))