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

2
lib/chibi/highlight.scm
View file

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

8
lib/chibi/sxml.scm
View file

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

12
tests/match-tests.scm
View file

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