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

* Added text utilities

Browse Source 
* begin/collect, and a begin/text that is based on it (ignoring
  inter-defns spaces)
* include/text, available as `include' in the scribble/text langauge
* tests, only for begin/collect for now

svn: r11772

original commit: 26b9bd6c3d20a8faeaf56ff9ef6241b7b3dc3564
This commit is contained in:
Eli Barzilay 2008-09-16 00:46:35 +00:00
parent 8733ec9586
commit 5cee45dc0b
4 changed files with 293 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/scribble/text/output.ss Normal file
View File

@ -0,0 +1,20 @@
#lang scheme/base
(require scheme/promise)
(provide output)
(define (output x [p (current-output-port)])
(let loop ([x x])
(cond [(or (void? x) (not x) (null? x)) (void)]
[(pair? x) (loop (car x)) (loop (cdr x))]
[(promise? x) (loop (force x))]
[(keyword? x) (loop (keyword->string x))]
[(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x))]
[(bytes? x) (write-bytes x p)]
[(string? x) (write-string x p)]
[(char? x) (write-char x p)]
[(number? x) (write x p)]
[(symbol? x) (display x p)]
;; generic fallback
[else (error 'output "don't know how to render value: ~v" x)]))
(void))

189
collects/scribble/text/syntax-utils.ss Normal file
View File

@ -0,0 +1,189 @@
#lang scheme/base
(require "output.ss" (for-syntax scheme/base syntax/kerncase))
(provide module-begin/text begin/text include/text
begin/collect)
(begin-for-syntax
(define definition-ids ; ids that don't require forcing
(syntax->list #'(define-values define-syntaxes define-values-for-syntax
require provide #%require #%provide)))
(define stoplist (append definition-ids (kernel-form-identifier-list)))
(define (definition-id? id)
(and (identifier? id)
(ormap (lambda (i) (free-identifier=? id i)) definition-ids)))
(define (definition? x)
(syntax-case x () [(id . rest) (and (definition-id? #'id) #'id)] [_ #f]))
(define (begin?->list x)
(syntax-case x (begin) [(begin x ...) (syntax->list #'(x ...))] [_ #f]))
;; This function is used to group a syntax list into triplets of consecutive
;; scribble indentation syntaxes, an input expression, and scribble newlines.
;; It is used to ignore indentations before a definition and newlines after
;; it. See the following test cases for how it works.
(define (group-by pred? xs fun)
(let loop ([xs xs] [before '()] [cur #f] [after '()] [r '()])
(define (add) (cons (fun (reverse before) cur (reverse after)) r))
(if (null? xs)
(reverse (if (or cur (pair? before) (pair? after)) (add) r))
(let* ([x (car xs)] [xs (cdr xs)] [p (pred? x)])
(cond [(eq? '> p) (loop xs before cur (cons x after) r)]
[(eq? '< p) (if (or cur (pair? after))
(loop xs (list x) #f '() (add))
(loop xs (cons x before) cur after r))]
[(or cur (pair? after)) (loop xs '() x '() (add))]
[else (loop xs before x '() r)])))))
(define (group-stxs stxs fun)
(group-by (lambda (stx)
(let ([p (syntax-property stx 'scribble)])
(cond [(and (pair? p) (eq? (car p) 'newline)) '>]
[(eq? 'indentation p) '<]
[else #f])))
stxs fun))
#; ; tests for this
(for-each
(lambda (t)
(let ([r (group-by (lambda (x)
(cond [(number? x) '<] [(symbol? x) '>] [else #f]))
(car t)
list)])
(unless (equal? r (cadr t)) (printf "FAILURE: ~s -> ~s\n" (car t) r))))
'([() ()]
[("a") ((() "a" ()))]
[("a" "b") ((() "a" ()) (() "b" ()))]
[(1 "a" x) (((1) "a" (x)))]
[(1 2 3 "a" x y z) (((1 2 3) "a" (x y z)))]
[(1 2 3 "a" "b" x y z) (((1 2 3) "a" ()) (() "b" (x y z)))]
[(1 2 "a" x 3 "b" y z) (((1 2) "a" (x)) ((3) "b" (y z)))]
[(1 2 "a" 3 "b" y z) (((1 2) "a" ()) ((3) "b" (y z)))]
[(1 2 "a" 3 x "b" y z) (((1 2) "a" ()) ((3) #f (x)) (() "b" (y z)))]
[(1 2 "a" 3 4 x "b" y z) (((1 2) "a" ()) ((3 4) #f (x)) (() "b" (y z)))]
[(1 2 "a" 3 w x "b" y z) (((1 2) "a" ()) ((3) #f (w x)) (() "b" (y z)))]
[(1) (((1) #f ()))]
[(x) ((() #f (x)))]
[(1 2 3) (((1 2 3) #f ()))]
[(x y z) ((() #f (x y z)))]
[(1 2 3 x y z) (((1 2 3) #f (x y z)))]
[(1 x 2 y 3 z) (((1) #f (x)) ((2) #f (y)) ((3) #f (z)))]
[(1 x y 2 3 z) (((1) #f (x y)) ((2 3) #f (z)))]
[(1 2 x 3) (((1 2) #f (x)) ((3) #f ()))]
[(w x 3 y z) ((() #f (w x)) ((3) #f (y z)))])))
(define-syntax (toplevel-decorate stx)
(define context (syntax-local-context))
(syntax-case stx ()
[(this decor (pre ...) expr (post ...))
(let ([expr* (local-expand #'expr context stoplist)])
(define pre? (not (null? (syntax-e #'(pre ...)))))
(define post? (not (null? (syntax-e #'(post ...)))))
(define (wrap expr)
(if (or pre? post?)
#`(begin #,@(if pre? #'((decor '(pre ...))) #'())
#,expr
#,@(if post? #'((decor '(post ...))) #'()))
expr))
(cond [(begin?->list expr*)
=> (lambda (xs)
(if (null? xs)
(if (or pre? post?) #'(decor '(pre ... post ...)) expr*)
#`(process-begin/text begin decor
pre ... #,@xs post ...)))]
[(definition? expr*) expr*] ; dump pre/post
[else (wrap #`(decor #,expr*))]))]))
(define-syntax (process-begin/text stx)
(define (process-body decor body)
(group-stxs
(syntax->list body)
(lambda (pre expr post)
(with-syntax ([decor decor])
(if (not expr) ; no need to decorate these
(with-syntax ([(x ...) (append pre post)]) #`(decor '(x ...)))
(with-syntax ([pre pre]
[post post])
#`(toplevel-decorate decor pre #,expr post)))))))
(syntax-case stx ()
[(_ beginner decor expr ...)
;; add a dummy define and throw it away, to get rid of initial newlines
(with-syntax ([(_ expr ...) (process-body #'decor #'((define) expr ...))])
#'(beginner expr ...))]))
;; module-begin for text files
(define-syntax-rule (module-begin/text expr ...)
(process-begin/text #%plain-module-begin output expr ...))
;; `begin'-like utility that allows definitions and collects values
(define-for-syntax (split-collect-body exprs ctx)
(let loop ([exprs exprs] ; expressions to scan
[ds '()] [es '()]) ; collected definitions and expressions
(if (null? exprs)
(values (reverse ds) (reverse es) '())
(let ([expr* (local-expand (car exprs) ctx stoplist (car ctx))])
(syntax-case expr* (begin define-syntaxes define-values)
[(begin x ...)
(loop (append (syntax->list #'(x ...)) (cdr exprs)) ds es)]
[(define-syntaxes (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(if (null? es)
(let ([ids (syntax->list #'(id ...))])
(define (registrar ctx)
(syntax-local-bind-syntaxes
ids (local-transformer-expand #'rhs 'expression '()) ctx))
(registrar (car ctx))
(loop (cdr exprs) (cons expr* ds) es))
;; return the unexpanded expr, to be re-expanded later, in the
;; right contexts
(values (reverse ds) (reverse es) exprs))]
[(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(if (null? es)
(begin (syntax-local-bind-syntaxes
(syntax->list #'(id ...)) #f (car ctx))
(loop (cdr exprs) (cons expr* ds) es))
;; same note here
(values (reverse ds) (reverse es) exprs))]
[_ (loop (cdr exprs) ds (cons expr* es))])))))
(define-syntax (begin/collect* stx) ; helper, has a boolean flag first
(define-values (exprs always-list?)
(let ([exprs (syntax->list stx)])
(if (and (pair? exprs) (pair? (cdr exprs)))
(values (cddr exprs) (syntax-e (cadr exprs)))
(raise-syntax-error #f "bad syntax" stx))))
(define context
(cons (syntax-local-make-definition-context)
(let ([old (syntax-local-context)]) (if (list? old) old '()))))
(define-values (defns nondefns rest) (split-collect-body exprs context))
(define body
(cond [(pair? rest) #`(list* #,@nondefns (begin/collect* #t #,@rest))]
[(and (not always-list?) (= 1 (length nondefns))) (car nondefns)]
[else #`(list #,@nondefns)]))
(local-expand (if (null? defns) body #`(let () #,@defns #,body))
context stoplist (car context)))
(define-syntax-rule (begin/collect x ...) (begin/collect* #f x ...))
;; begin for templates (allowing definition blocks)
(define-syntax (begin/text stx)
(syntax-case stx ()
[(begin/text expr ...)
#'(process-begin/text begin/collect values expr ...)]))
;; include for templates
(require (for-syntax scheme/base (prefix-in scribble: "../reader.ss"))
scheme/include)
(define-syntax-rule (include/text path-spec)
(begin/text
(include-at/relative-to/reader path-spec path-spec path-spec
(let ([xs #f])
(lambda (src inp)
(unless xs
(set! xs (scribble:read-syntax-inside src inp))
(when (syntax? xs) (set! xs (or (syntax->list xs) (list xs)))))
(if (null? xs)
eof
(let ([x (car xs)])
(set! xs (cdr xs))
(if (and (null? xs)
(let ([p (syntax-property x 'scribble)])
(and (pair? p) (eq? (car p) 'newline))))
eof ; throw away the last newline from the included file
x))))))))

100
collects/scribble/text/textlang.ss
View File

@ -1,99 +1,9 @@
#lang scheme/base
(require (for-syntax scheme/base syntax/kerncase)
scheme/promise "../text.ss")
(require "syntax-utils.ss" "output.ss" scheme/promise)
(provide (except-out (all-from-out scheme/base) #%module-begin)
(rename-out [module-begin #%module-begin])
(all-from-out scheme/promise "../text.ss"))
(begin-for-syntax
(define definition-ids ; ids that don't require forcing
(syntax->list #'(define-values define-syntaxes define-values-for-syntax
require provide #%require #%provide)))
(define stoplist (append definition-ids (kernel-form-identifier-list)))
(define (definition-id? id)
(and (identifier? id)
(ormap (lambda (i) (free-identifier=? id i)) definition-ids)))
(define (newline-stx? stx)
(let ([p (syntax-property stx 'scribble)])
(and (pair? p) (eq? (car p) 'newline))))
;; This function is used to group a syntax list into triplets of consecutive
;; scribble indentation syntaxes, an input expression, and scribble newlines.
;; It is used to ignore indentations before a definition and newlines after
;; it. See the following test cases for how it works.
(define (group-by pred? xs fun)
(let loop ([xs xs] [before '()] [cur #f] [after '()] [r '()])
(define (add) (cons (fun (reverse before) cur (reverse after)) r))
(if (null? xs)
(reverse (if (or cur (pair? before) (pair? after)) (add) r))
(let* ([x (car xs)] [xs (cdr xs)] [p (pred? x)])
(cond [(eq? '> p) (loop xs before cur (cons x after) r)]
[(eq? '< p) (if (or cur (pair? after))
(loop xs (list x) #f '() (add))
(loop xs (cons x before) cur after r))]
[(or cur (pair? after)) (loop xs '() x '() (add))]
[else (loop xs before x '() r)])))))
(define (group-stxs stxs fun)
(group-by (lambda (stx)
(let ([p (syntax-property stx 'scribble)])
(cond [(and (pair? p) (eq? (car p) 'newline)) '>]
[(eq? 'indentation p) '<]
[else #f])))
stxs fun))
#; ; tests for this
(for-each
(lambda (t)
(let ([r (group-by (lambda (x)
(cond [(number? x) '<] [(symbol? x) '>] [else #f]))
(car t)
list)])
(unless (equal? r (cadr t)) (printf "FAILURE: ~s -> ~s\n" (car t) r))))
'([() ()]
[("a") ((() "a" ()))]
[("a" "b") ((() "a" ()) (() "b" ()))]
[(1 "a" x) (((1) "a" (x)))]
[(1 2 3 "a" x y z) (((1 2 3) "a" (x y z)))]
[(1 2 3 "a" "b" x y z) (((1 2 3) "a" ()) (() "b" (x y z)))]
[(1 2 "a" x 3 "b" y z) (((1 2) "a" (x)) ((3) "b" (y z)))]
[(1 2 "a" 3 "b" y z) (((1 2) "a" ()) ((3) "b" (y z)))]
[(1 2 "a" 3 x "b" y z) (((1 2) "a" ()) ((3) #f (x)) (() "b" (y z)))]
[(1 2 "a" 3 4 x "b" y z) (((1 2) "a" ()) ((3 4) #f (x)) (() "b" (y z)))]
[(1 2 "a" 3 w x "b" y z) (((1 2) "a" ()) ((3) #f (w x)) (() "b" (y z)))]
[(1) (((1) #f ()))]
[(x) ((() #f (x)))]
[(1 2 3) (((1 2 3) #f ()))]
[(x y z) ((() #f (x y z)))]
[(1 2 3 x y z) (((1 2 3) #f (x y z)))]
[(1 x 2 y 3 z) (((1) #f (x)) ((2) #f (y)) ((3) #f (z)))]
[(1 x y 2 3 z) (((1) #f (x y)) ((2 3) #f (z)))]
[(1 2 x 3) (((1 2) #f (x)) ((3) #f ()))]
[(w x 3 y z) ((() #f (w x)) ((3) #f (y z)))])))
(define-syntax (toplevel-decorate stx)
(let ([context (syntax-local-context)])
(syntax-case stx ()
[(this pre expr post)
(let ([expr* (local-expand #'expr context stoplist)])
(syntax-case expr* (begin)
;; perhaps we should dig inside for more pre/posts
[(begin x ...) #'(begin pre (this x) ... post)]
;; dump pre/post
[(id . rest) (definition-id? #'id) expr*]
[_ #`(begin pre (output #,expr*) post)]))])))
(define-syntax (module-begin stx)
(define (process-body body)
(group-stxs
(syntax->list body)
(lambda (pre expr post)
(if (not expr) ; no need to decorate these
(with-syntax ([(x ...) (append pre post)]) #`(output '(x ...)))
(with-syntax ([pre (if (null? pre) #'(begin) #`(output '#,pre))]
[post (if (null? post) #'(begin) #`(output '#,post))])
#`(toplevel-decorate pre #,expr post))))))
(syntax-case stx ()
[(_ expr ...)
;; add a dummy define and throw it away, to get rid of initial newlines
(with-syntax ([(_ expr ...) (process-body #'((define) expr ...))])
#'(#%plain-module-begin expr ...))]))
(all-from-out "output.ss" scheme/promise)
begin/text
(rename-out [module-begin/text #%module-begin]
[include/text include]))

79
collects/tests/scribble/main.ss Normal file
View File

@ -0,0 +1,79 @@
#lang scheme/base
(require tests/eli-tester scribble/text/syntax-utils)
(test
;; begin/collect scope etc
(begin/collect 1) => 1
(begin/collect 1 2 3) => '(1 2 3)
(begin/collect) => '()
(begin/collect (define x 1) x) => 1
(begin/collect (define x 1)) => '()
(begin/collect (define x 1) x x x) => '(1 1 1)
(begin/collect (define x 1) (define y 2) x y x y) => '(1 2 1 2)
(begin/collect (define x 1) x (define y 2) y) => '(1 2)
(begin/collect (define x 1) x (define y 2)) => '(1)
(begin/collect (define x 1) x x (define y 2) y y) => '(1 1 2 2)
(begin/collect (define x 1) x (define x 2) x) => '(1 2)
(begin/collect (define x 1) x x (define x 2) x x) => '(1 1 2 2)
(begin/collect (define (x) y) (define y 1) (x) (x) (x)) => '(1 1 1)
(begin/collect (define x 1) x (define y 2) x) => '(1 1)
(begin/collect (define x 1) x x (define y 2) x x) => '(1 1 1 1)
(begin/collect (define x 1) x x (define y x) y y) => '(1 1 1 1)
(begin/collect (define (x) y) (define y 1) (x) (x)
(define (x) y) (define y 2) (x) (x))
=> '(1 1 2 2)
(begin/collect (define-syntax-rule (DEF x y) (define x y)) (DEF x 1) x x)
=> '(1 1)
(begin/collect (define-syntax-rule (DEF x y) (define x y)) 1 (DEF x 2) x)
=> '(1 2)
(begin/collect (define-syntax-rule (DEF x y) (define x y))
(DEF x 1) x x
(DEF x 2) x x)
=> '(1 1 2 2)
(begin/collect (define (x) y)
(define-syntax-rule (DEF x y) (define x y))
(DEF y 1) (x) (x)
(DEF y 2) (x) (x))
=> '(1 1 1 1)
(let ([y 1]) (begin/collect y y (define x y) x y x)) => '(1 1 1 1 1)
(let ([y 1]) (begin/collect y y (define y 2) y y)) => '(1 1 2 2)
(let ([y 1]) (begin/collect (define (x) y) (x) (x))) => '(1 1)
(let ([y 1]) (begin/collect (define (x) y) (define y 2) (x) (x))) => '(2 2)
(let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y))
=> '(1 1 2 2)
(let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y (x)))
=> '(1 1 2 2 1)
(let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) (x) y y))
=> '(1 1 1 2 2)
(begin/collect (begin (define (x) y)
(define-syntax-rule (DEF x y) (define x y))
(define y 2))
(x) (x))
=> '(2 2)
(begin/collect (define (x) y)
(begin (define-syntax-rule (DEF x y) (define x y))
(define y 2))
(x) (x))
=> '(2 2)
(begin/collect (define (x) y)
(define-syntax-rule (DEF x y) (define x y))
(begin (define y 2))
(x) (x))
=> '(2 2)
(begin/collect (begin (begin (begin (define (x) y))
(begin (define-syntax-rule (DEF x y)
(define x y))))
(begin (begin (define y 2))
(begin (x)))
(begin (x))))
=> '(2 2)
(begin/collect 1
(define (f x #:< [< "<"] #:> [> ">"]) (list < x >))
(f 1)
(f #:< "[" 2)
(f 3 #:> "]" #:< "["))
=> '(1 ("<" 1 ">") ("[" 2 ">") ("[" 3 "]"))
)