Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-16 09:27:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Using standard @ instead of ^ as the SXML attributes symbols.

Browse source 
This was never a portable aspect of SXML before because in earlier
standards @ was an illegal identifier, but it is allowed in R7RS.
Scribble requires escaping with @|@| to pass through a raw @ symbol.
Considering using \ as the default scribble escape instead.
This commit is contained in:
Alex Shinn 2013-07-13 10:04:40 +09:00
parent b713fb8c34
commit 92b7304f89
6 changed files with 31 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
lib/chibi/config.scm
View file

@ -19,7 +19,7 @@
;;> command-line options, config files, environment variables, and/or ;;> command-line options, config files, environment variables, and/or
;;> other specialized settings. These all have various pros and cons: ;;> other specialized settings. These all have various pros and cons:
;;> ;;>
;;> @table[(^ (border 1) (style border-collapse:collapse) (width "100%"))]{ ;;> @table[(@|@| (border 1) (style border-collapse:collapse) (width "100%"))]{
;;> @tr{@th{name} @th{pros} @th{cons}} ;;> @tr{@th{name} @th{pros} @th{cons}}
;;> @tr{@td{environment variables} ;;> @tr{@td{environment variables}
;;> @td{implicit - no need to retype; can share between applications} ;;> @td{implicit - no need to retype; can share between applications}
@ -55,7 +55,7 @@
;;> coercing to a list. The result is determined according to the ;;> coercing to a list. The result is determined according to the
;;> structure of the alist cell as follows: ;;> structure of the alist cell as follows:
;;> ;;>
;;> @table[(^ (border 1) (style border-collapse:collapse) (width "100%"))]{ ;;> @table[(@|@| (border 1) (style border-collapse:collapse) (width "100%"))]{
;;> @tr{@th{Cell} @th{@scheme{conf-get} result} @th{@scheme{conf-get-list} result}} ;;> @tr{@th{Cell} @th{@scheme{conf-get} result} @th{@scheme{conf-get-list} result}}
;;> @tr{@td{@scheme{(key)}} @td{@scheme{()}} @td{@scheme{()}}} ;;> @tr{@td{@scheme{(key)}} @td{@scheme{()}} @td{@scheme{()}}}
;;> @tr{@td{@scheme{(key . non-list-value)}} @td{@scheme{non-list-value}} @td{@scheme{(non-list-value)}}} ;;> @tr{@td{@scheme{(key . non-list-value)}} @td{@scheme{non-list-value}} @td{@scheme{(non-list-value)}}}

28
lib/chibi/doc.scm
View file

@ -84,7 +84,7 @@
(define (sxml-body x) (define (sxml-body x)
(cond ((not (and (pair? x) (pair? (cdr x)))) '()) (cond ((not (and (pair? x) (pair? (cdr x)))) '())
((and (pair? (cadr x)) (eq? '^ (car (cadr x)))) (cddr x)) ((and (pair? (cadr x)) (eq? '@ (car (cadr x)))) (cddr x))
(else (cdr x)))) (else (cdr x))))
(define (env-ref env name . o) (define (env-ref env name . o)
@ -168,27 +168,27 @@
(body (map (lambda (x) (expand-docs x env)) (body (map (lambda (x) (expand-docs x env))
(if name (cdr (cddr sxml)) (cdr sxml)))) (if name (cdr (cddr sxml)) (cdr sxml))))
(name (or name (sxml-strip (cons tag body))))) (name (or name (sxml-strip (cons tag body)))))
`(div (a (^ (name . ,(section-name tag name)))) (,tag ,@body)))))) `(div (a (@ (name . ,(section-name tag name)))) (,tag ,@body))))))
(define (expand-url sxml env) (define (expand-url sxml env)
(if (not (= 2 (length sxml))) (if (not (= 2 (length sxml)))
(error "url expects one argument" sxml) (error "url expects one argument" sxml)
(let ((url (expand-docs (cadr sxml) env))) (let ((url (expand-docs (cadr sxml) env)))
`(a (^ (href . ,url)) ,url)))) `(a (@ (href . ,url)) ,url))))
(define (expand-hyperlink sxml env) (define (expand-hyperlink sxml env)
(if (not (>= (length sxml) 3)) (if (not (>= (length sxml) 3))
(error "hyperlink expects at least two arguments" sxml) (error "hyperlink expects at least two arguments" sxml)
(let ((url (expand-docs (cadr sxml) env))) (let ((url (expand-docs (cadr sxml) env)))
`(a (^ (href . ,url)) `(a (@ (href . ,url))
,(map (lambda (x) (expand-docs x env)) (cddr sxml)))))) ,(map (lambda (x) (expand-docs x env)) (cddr sxml))))))
(define (expand-note sxml env) (define (expand-note sxml env)
`(div (^ (id . "notes")) `(div (@ (id . "notes"))
,@(map (lambda (x) (expand-docs x env)) (cdr sxml)))) ,@(map (lambda (x) (expand-docs x env)) (cdr sxml))))
(define (expand-author sxml env) (define (expand-author sxml env)
`(div (^ (id . "notes")) `(div (@ (id . "notes"))
,@(map (lambda (x) (expand-docs x env)) (cdr sxml)) ,@(map (lambda (x) (expand-docs x env)) (cdr sxml))
(br) (br)
,(seconds->string (current-seconds)))) ,(seconds->string (current-seconds))))
@ -213,7 +213,7 @@
`(div `(div
,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env) ,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)
(code (code
(div (^ (class . "result")) (div (@ (class . "result"))
,(call-with-output-string ,(call-with-output-string
(lambda (out) (lambda (out)
(protect (exn (#t (print-exception exn out))) (protect (exn (#t (print-exception exn out)))
@ -227,7 +227,7 @@
"") "")
(define (expand-command sxml env) (define (expand-command sxml env)
`(pre (^ (class . "command")) `(pre (@ (class . "command"))
(code ,@(map (lambda (x) (expand-docs x env)) (cdr sxml))))) (code ,@(map (lambda (x) (expand-docs x env)) (cdr sxml)))))
(define (expand-tagged tag ls env) (define (expand-tagged tag ls env)
@ -260,10 +260,10 @@
(define (extract-contents x) (define (extract-contents x)
(match x (match x
(('div ('a ('^ ('name . name)) . _) (('div ('a ('@ ('name . name)) . _)
((and h (or 'h1 'h2 'h3 'h4 'h5 'h6)) . section)) ((and h (or 'h1 'h2 'h3 'h4 'h5 'h6)) . section))
`((,(header-index h) `((,(header-index h)
(a (^ (href . ,(string-append "#" name))) (a (@ (href . ,(string-append "#" name)))
,(sxml-strip (cons h section)))))) ,(sxml-strip (cons h section))))))
((a . b) ((a . b)
(append (extract-contents a) (extract-contents b))) (append (extract-contents a) (extract-contents b)))
@ -289,7 +289,7 @@
`(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x))) `(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
(else '())) (else '()))
"\n" "\n"
(style (^ (type . "text/css")) (style (@ (type . "text/css"))
" "
body {color: #000; background-color: #FFF} body {color: #000; background-color: #FFF}
div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 180px; height: 100%} div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 180px; height: 100%}
@ -302,15 +302,15 @@ div#footer {padding-bottom: 50px}
,(highlight-style)) ,(highlight-style))
"\n") "\n")
(body (body
(div (^ (id . "menu")) (div (@ (id . "menu"))
,(get-contents (extract-contents x))) ,(get-contents (extract-contents x)))
(div (^ (id . "main")) (div (@ (id . "main"))
,@(map (lambda (x) ,@(map (lambda (x)
(if (and (pair? x) (eq? 'title (car x))) (if (and (pair? x) (eq? 'title (car x)))
(cons 'h1 (cdr x)) (cons 'h1 (cdr x))
x)) x))
x) x)
(div (^ (id . "footer"))))))) (div (@ (id . "footer")))))))
(define (fix-paragraphs x) (define (fix-paragraphs x)
(let lp ((ls x) (p '()) (res '())) (let lp ((ls x) (p '()) (res '()))

2
lib/chibi/highlight.scm
View file

@ -98,7 +98,7 @@
(cdr (iota (+ 1 (length highlight-paren-styles)))))))) (cdr (iota (+ 1 (length highlight-paren-styles))))))))
(define (highlight-class class x) (define (highlight-class class x)
`(span (^ (class . ,class)) ,@(if (list? x) x (list x)))) `(span (@ (class . ,class)) ,@(if (list? x) x (list x))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

8
lib/chibi/mime.scm
View file

@ -268,7 +268,7 @@
(if (and (pair? o) (pair? (cdr o))) (if (and (pair? o) (pair? (cdr o)))
(car (cdr o)) (car (cdr o))
(lambda (headers parent-seed seed) (lambda (headers parent-seed seed)
`((mime (^ ,@headers) `((mime (@ ,@headers)
,@(if (pair? seed) (reverse seed) seed)) ,@(if (pair? seed) (reverse seed) seed))
,@parent-seed)))) ,@parent-seed))))
(headers (headers
@ -319,7 +319,7 @@
;;> ;;>
;;> Parse the given source as a MIME message and return ;;> Parse the given source as a MIME message and return
;;> the result as an SXML object of the form: ;;> the result as an SXML object of the form:
;;> @scheme{(mime (^ (header . value) ...) parts ...)}. ;;> @scheme{(mime (@ (header . value) ...) parts ...)}.
(define (mime-message->sxml . o) (define (mime-message->sxml . o)
(car (car
@ -327,11 +327,11 @@
mime-message-fold mime-message-fold
(if (pair? o) (car o) (current-input-port)) (if (pair? o) (car o) (current-input-port))
(lambda (parent-headers headers body seed) (lambda (parent-headers headers body seed)
`((mime (^ ,@headers) ,body) ,@seed)) `((mime (@ ,@headers) ,body) ,@seed))
'() '()
(lambda (headers seed) '()) (lambda (headers seed) '())
(lambda (headers parent-seed seed) (lambda (headers parent-seed seed)
`((mime (^ ,@headers) `((mime (@ ,@headers)
,@(if (pair? seed) (reverse seed) seed)) ,@(if (pair? seed) (reverse seed) seed))
,@parent-seed)) ,@parent-seed))
(if (pair? o) (cdr o) '())))) (if (pair? o) (cdr o) '()))))

8
lib/chibi/sxml.scm
View file

@ -89,7 +89,7 @@
(cond (cond
((and (pair? rest) ((and (pair? rest)
(pair? (car rest)) (pair? (car rest))
(eq? '^ (caar rest))) (eq? '@ (caar rest)))
(display (html-tag->string tag (cdar rest)) out) (display (html-tag->string tag (cdar rest)) out)
(for-each lp (cdr rest)) (for-each lp (cdr rest))
(display "</" out) (display tag out) (display ">" out)) (display "</" out) (display tag out) (display ">" out))
@ -110,7 +110,7 @@
((pair? x) ((pair? x)
(for-each (for-each
strip strip
(if (and (pair? (cdr x)) (eq? '^ (cadr x))) (cddr x) (cdr x)))) (if (and (pair? (cdr x)) (eq? '@ (cadr x))) (cddr x) (cdr x))))
((string? x) ((string? x)
(display x out))))))) (display x out)))))))
@ -127,13 +127,13 @@
(and (eq? 'div tag) (and (eq? 'div tag)
(pair? (cdr sxml)) (pair? (cdr sxml))
(pair? (cadr sxml)) (pair? (cadr sxml))
(eq? '^ (car (cadr sxml))) (eq? '@ (car (cadr sxml)))
(equal? '(id . "menu") (assq 'id (cdr (cadr sxml))))))) (equal? '(id . "menu") (assq 'id (cdr (cadr sxml)))))))
;; recurse other tags, appending newlines for new sections ;; recurse other tags, appending newlines for new sections
((symbol? tag) ((symbol? tag)
(for-each (for-each
lp lp
(if (and (pair? (cdr sxml)) (eq? '^ (cadr sxml))) (if (and (pair? (cdr sxml)) (eq? '@ (cadr sxml)))
(cddr sxml) (cddr sxml)
(cdr sxml))) (cdr sxml)))
(if (memq tag '(p br h1 h2 h3 h4 h5 h6)) (if (memq tag '(p br h1 h2 h3 h4 h5 h6))

12
tests/match-tests.scm
View file

@ -122,21 +122,21 @@
(else #f))) (else #f)))
(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode")) (test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode"))
(match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) (match '(p (ul (li a (b c) (a (@ (href . "http://synthcode.com/")) "synthcode") d e f)))
(((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) (((or 'p 'ul 'li 'b) *** ('a ('@ attrs ...) text ...))
(list attrs text)) (list attrs text))
(else #f))) (else #f)))
(test "failed sxml tree search" #f (test "failed sxml tree search" #f
(match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) (match '(p (ol (li a (b c) (a (@ (href . "http://synthcode.com/")) "synthcode") d e f)))
(((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) (((or 'p 'ul 'li 'b) *** ('a ('@ attrs ...) text ...))
(list attrs text)) (list attrs text))
(else #f))) (else #f)))
(test "collect tree search" (test "collect tree search"
'((p ul li) ((href . "http://synthcode.com/")) ("synthcode")) '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
(match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) (match '(p (ul (li a (b c) (a (@ (href . "http://synthcode.com/")) "synthcode") d e f)))
(((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) (((and tag (or 'p 'ul 'li 'b)) *** ('a ('@ attrs ...) text ...))
(list tag attrs text)) (list tag attrs text))
(else #f))) (else #f)))