tests/srfi-88.test \
tests/srfi-4.test \
tests/srfi-9.test \
+ tests/statprof.test \
tests/strings.test \
tests/structs.test \
+ tests/sxml.fold.test \
+ tests/sxml.ssax.test \
+ tests/sxml.transform.test \
+ tests/sxml.xpath.test \
tests/symbols.test \
tests/syncase.test \
tests/syntax.test \
+ tests/texinfo.test \
+ tests/texinfo.docbook.test \
+ tests/texinfo.serialize.test \
+ tests/texinfo.string-utils.test \
tests/threads.test \
tests/time.test \
tests/tree-il.test \
--- /dev/null
+;; guile-lib -*- scheme -*-
+;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
+;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program; if not, contact:
+;;
+;; Free Software Foundation Voice: +1-617-542-5942
+;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
+;; Boston, MA 02111-1307, USA gnu@gnu.org
+
+;;; Commentary:
+;;
+;; Unit tests for (debugging statprof).
+;;
+;;; Code:
+
+(define-module (test-suite test-statprof)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (srfi srfi-1)
+ #:use-module (statprof))
+
+;; FIXME
+(debug-enable 'debug)
+(trap-enable 'traps)
+
+(pass-if "statistical sample counts within expected range"
+ (let ()
+ ;; test to see that if we call 3 identical functions equally, they
+ ;; show up equally in the call count, +/- 30%. it's a big range, and
+ ;; I tried to do something more statistically valid, but failed (for
+ ;; the moment).
+
+ ;; make sure these are compiled so we're not swamped in `eval'
+ (define (make-func)
+ (compile '(lambda (n)
+ (do ((i 0 (+ i 1))) ((= 200 i)) (+ i i)))))
+ (define run-test
+ (compile '(lambda (num-calls funcs)
+ (let loop ((x num-calls) (funcs funcs))
+ (cond
+ ((positive? x)
+ ((car funcs) x)
+ (loop (- x 1) (cdr funcs))))))))
+
+ (let ((num-calls 40000)
+ (funcs (circular-list (make-func) (make-func) (make-func))))
+
+ ;; Run test. 10000 us == 100 Hz.
+ (statprof-reset 0 10000 #f #f)
+ (statprof-start)
+ (run-test num-calls funcs)
+ (statprof-stop)
+
+ (let* ((a-data (statprof-proc-call-data (car funcs)))
+ (b-data (statprof-proc-call-data (cadr funcs)))
+ (c-data (statprof-proc-call-data (caddr funcs)))
+ (samples (map statprof-call-data-cum-samples
+ (list a-data b-data c-data)))
+ (average (/ (apply + samples) 3))
+ (max-allowed-drift 0.30) ; 30%
+ (diffs (map (lambda (x) (abs (- x average)))
+ samples))
+ (max-diff (apply max diffs)))
+
+ (let ((drift-fraction (/ max-diff average)))
+ (or (< drift-fraction max-allowed-drift)
+ ;; don't stop the the test suite for what statistically is
+ ;; bound to happen.
+ (throw 'unresolved (pk average drift-fraction))))))))
+
+(pass-if "accurate call counting"
+ (let ()
+ ;; Test to see that if we call a function N times while the profiler
+ ;; is active, it shows up N times.
+ (let ((num-calls 200))
+
+ (define (do-nothing n)
+ (simple-format #f "FOO ~A\n" (+ n n)))
+
+ (throw 'unresolved) ;; need to fix VM tracing.
+
+ ;; Run test.
+ (statprof-reset 0 50000 #t #f)
+ (statprof-start)
+ (let loop ((x num-calls))
+ (cond
+ ((positive? x)
+ (do-nothing x)
+ (loop (- x 1))
+ #t)))
+ (statprof-stop)
+
+ ;;(statprof-display)
+
+ ;; Check result.
+ (let ((proc-data (statprof-proc-call-data do-nothing)))
+ (and proc-data
+ (= (statprof-call-data-calls proc-data)
+ num-calls))))))
--- /dev/null
+;; -*- scheme -*-
+;; guile-lib
+;; Copyright (C) 2007, 2009 Andy Wingo <wingo at pobox dot com>
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation Voice: +1-617-542-5942
+;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
+;; Boston, MA 02111-1307, USA gnu@gnu.org
+
+;;; Commentary:
+;;
+;; Unit tests for (sxml fold).
+;;
+;;; Code:
+
+(define-module (test-suite sxml-fold)
+ #:use-module (test-suite lib)
+ #:use-module (sxml fold))
+
+(define atom? (@@ (sxml fold) atom?))
+(define (id x) x)
+(define-syntax accept
+ (syntax-rules ()
+ ((_ expr)
+ (call-with-values (lambda () expr) list))))
+
+(with-test-prefix "test-fold"
+ (define test-doc
+ '(presentation
+ (@ (width 1024)
+ (height 768)
+ (title-style "font-family:Georgia")
+ (title-height 72)
+ (title-baseline-y 96)
+ (title-x 48)
+ (text-height 64)
+ (text-style "font-family:Georgia")
+ (text-upper-left-x 96)
+ (text-upper-left-y 216))
+ (slide
+ (@ (title "Declarative interface"))
+ (p "The declarative interface"
+ "lets you be more concise"
+ "when making the slides."))
+ (slide
+ (@ (title "Still cumbersome"))
+ (p "Parentheses are still"
+ "cumbersome."))))
+
+ (pass-if (atom? 'foo))
+ (pass-if (atom? '()))
+ (pass-if (not (atom? '(1 2 3))))
+
+ (pass-if "foldt identity"
+ (equal? (foldt id id test-doc) test-doc))
+
+ (pass-if "fold cons == reverse"
+ (equal? (fold cons '() test-doc)
+ (reverse test-doc)))
+
+ (pass-if "foldts identity"
+ (equal? (foldts (lambda (seed tree) '())
+ (lambda (seed kid-seed tree)
+ (cons (reverse kid-seed) seed))
+ (lambda (seed tree)
+ (cons tree seed))
+ '()
+ test-doc)
+ (cons test-doc '())))
+
+ (pass-if "foldts* identity"
+ (equal? (foldts* (lambda (seed tree) (values '() tree))
+ (lambda (seed kid-seed tree)
+ (cons (reverse kid-seed) seed))
+ (lambda (seed tree)
+ (cons tree seed))
+ '()
+ test-doc)
+ (cons test-doc '())))
+
+ (pass-if "fold-values == fold"
+ (equal? (fold-values cons test-doc '())
+ (fold cons '() test-doc)))
+
+ (pass-if "foldts*-values == foldts*"
+ (equal? (foldts*-values
+ (lambda (tree seed) (values tree '()))
+ (lambda (tree seed kid-seed)
+ (cons (reverse kid-seed) seed))
+ (lambda (tree seed)
+ (cons tree seed))
+ test-doc
+ '())
+ (foldts* (lambda (seed tree) (values '() tree))
+ (lambda (seed kid-seed tree)
+ (cons (reverse kid-seed) seed))
+ (lambda (seed tree)
+ (cons tree seed))
+ '()
+ test-doc)))
+
+ (let ()
+ (define (replace pred val list)
+ (reverse
+ (fold
+ (lambda (x xs)
+ (cons (if (pred x) val x) xs))
+ '()
+ list)))
+
+ (define (car-eq? x what)
+ (and (pair? x) (eq? (car x) what)))
+
+ ;; avoid entering <slide>
+ (pass-if "foldts* *pre* behaviour"
+ (equal? (foldts*-values
+ (lambda (tree seed)
+ (values (if (car-eq? tree 'slide) '() tree) '()))
+ (lambda (tree seed kid-seed)
+ (cons (reverse kid-seed) seed))
+ (lambda (tree seed)
+ (cons tree seed))
+ test-doc
+ '())
+ (cons
+ (replace (lambda (x) (car-eq? x 'slide))
+ '()
+ test-doc)
+ '()))))
+
+ (let ()
+ (define (all-elts tree)
+ (reverse!
+ (foldts*-values
+ (lambda (tree seed)
+ (values tree seed))
+ (lambda (tree seed kid-seed)
+ kid-seed)
+ (lambda (tree seed)
+ (cons tree seed))
+ tree
+ '())))
+
+ (define (len tree)
+ (foldts*-values
+ (lambda (tree seed)
+ (values tree seed))
+ (lambda (tree seed kid-seed)
+ kid-seed)
+ (lambda (tree seed)
+ (1+ seed))
+ tree
+ 0))
+
+ (pass-if "foldts length"
+ (equal? (length (all-elts test-doc))
+ (len test-doc)))))
+
+(with-test-prefix "test-fold-layout"
+ (define test-doc
+ '(presentation
+ (@ (width 1024)
+ (height 768)
+ (title-style "font-family:Georgia")
+ (title-height 72)
+ (title-baseline-y 96)
+ (title-x 48)
+ (text-height 64)
+ (text-style "font-family:Georgia")
+ (text-upper-left-x 96)
+ (text-upper-left-y 216))
+ (slide
+ (@ (title "Declarative interface"))
+ (p "The declarative interface"
+ "lets you be more concise"
+ "when making the slides."))
+ (slide
+ (@ (title "Still cumbersome"))
+ (p "Parentheses are still"
+ "cumbersome."))))
+
+ (define (identity-layout tree)
+ (fold-layout
+ tree
+ `((*default*
+ . ,(lambda (tag params old-layout layout kids)
+ (values layout
+ (if (null? (car params))
+ (cons tag kids)
+ (cons* tag (cons '@ (car params)) kids)))))
+ (*text*
+ . ,(lambda (text params layout)
+ (values layout text))))
+ '()
+ (cons 0 0)
+ '()))
+
+ (pass-if "fold-layout"
+ (equal? (accept (identity-layout test-doc))
+ (list test-doc (cons 0 0)))))
--- /dev/null
+;; -*- scheme -*-
+;; guile-lib
+;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
+;; Copyright (C) 2001,2002,2003,2004 Oleg Kiselyov <oleg at pobox dot com>
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation Voice: +1-617-542-5942
+;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
+;; Boston, MA 02111-1307, USA gnu@gnu.org
+
+;;; Commentary:
+;;
+;; Unit tests for (sxml ssax). You can tweak this harness to get more
+;; debugging information, but in the end I just wanted to keep Oleg's
+;; tests in the file and see if we could work with them directly.
+;;
+;;; Code:
+
+(define-module (test-suite sxml-ssax)
+ #:use-module (sxml ssax input-parse)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:use-module (sxml ssax)
+ #:use-module (ice-9 pretty-print))
+
+(define pp pretty-print)
+
+(define-macro (import module . symbols)
+ `(begin
+ ,@(map (lambda (sym)
+ `(module-define! (current-module) ',sym (module-ref (resolve-module ',module) ',sym)))
+ symbols)))
+
+;; This list was arrived at over time. See the problem is that SSAX's
+;; test cases are inline with its text, and written in the private
+;; language of SSAX. That is to say, they use procedures that (sxml
+;; ssax) doesn't export. So here we test that the procedures from (sxml
+;; ssax) actually work, but in order to do so we have to pull in private
+;; definitions. It's not the greatest solution, but it's what we got.
+(import (sxml ssax)
+ ssax:read-NCName
+ ssax:read-QName
+ ssax:largest-unres-name
+ ssax:Prefix-XML
+ ssax:resolve-name
+ ssax:scan-Misc
+ ssax:assert-token
+ ssax:handle-parsed-entity
+ ssax:warn
+ ssax:skip-pi
+ ssax:S-chars
+ ssax:skip-S
+ ssax:ncname-starting-char?
+ ssax:define-labeled-arg-macro
+ let*-values
+ ssax:make-parser/positional-args
+ when
+ make-xml-token
+ nl
+ ;unesc-string
+ parser-error
+ ascii->char
+ char->ascii
+ char-newline
+ char-return
+ char-tab
+ name-compare)
+
+(define (cout . args)
+ "Similar to @code{cout << arguments << args}, where @var{argument} can
+be any Scheme object. If it's a procedure (e.g. @code{newline}), it's
+called without args rather than printed."
+ (for-each (lambda (x)
+ (if (procedure? x) (x) (display x)))
+ args))
+
+(define (cerr . args)
+ "Similar to @code{cerr << arguments << args}, where @var{argument} can
+be any Scheme object. If it's a procedure (e.g. @code{newline}), it's
+called without args rather than printed."
+ (format (current-ssax-error-port)
+ ";;; SSAX warning: ~a\n" args))
+
+(define (list-intersperse src-l elem)
+ (if (null? src-l) src-l
+ (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
+ (if (null? l) (reverse dest)
+ (loop (cdr l) (cons (car l) (cons elem dest)))))))
+
+(define-syntax failed?
+ (syntax-rules ()
+ ((_ e ...)
+ (not (false-if-exception (begin e ... #t))))))
+
+(define *saved-port* (current-output-port))
+
+(define-syntax assert
+ (syntax-rules ()
+ ((assert expr ...)
+ (with-output-to-port *saved-port*
+ (lambda ()
+ (pass-if '(and expr ...)
+ (let* ((out (open-output-string))
+ (res (with-output-to-port out
+ (lambda ()
+ (with-ssax-error-to-port (current-output-port)
+ (lambda ()
+ (and expr ...)))))))
+ ;; (get-output-string out)
+ res)))))))
+
+(define (load-tests file)
+ (with-input-from-file (%search-load-path file)
+ (lambda ()
+ (let loop ((sexp (read)))
+ (cond
+ ((eof-object? sexp))
+ ((and (pair? sexp) (pair? (cdr sexp))
+ (eq? (cadr sexp) 'run-test))
+ (primitive-eval sexp)
+ (loop (read)))
+ ((and (pair? sexp) (eq? (car sexp) 'run-test))
+ (primitive-eval sexp)
+ (loop (read)))
+ (else
+ (loop (read))))))))
+
+(with-output-to-string
+ (lambda ()
+ (load-tests "sxml/upstream/SSAX.scm")))
--- /dev/null
+;; -*- scheme -*-
+;; guile-lib
+;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation Voice: +1-617-542-5942
+;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
+;; Boston, MA 02111-1307, USA gnu@gnu.org
+
+;;; Commentary:
+;;
+;; Unit tests for (sxml transform).
+;;
+;;; Code:
+
+(define-module (test-suite sxml-transform)
+ #:use-module (test-suite lib)
+ #:use-module (sxml transform))
+
+(let* ((tree '(root (n1 (n11) "s12" (n13))
+ "s2"
+ (n2 (n21) "s22")
+ (n3 (n31 (n311))
+ "s32"
+ (n33 (n331) "s332" (n333))
+ "s34"))))
+ (define (test pred-begin pred-end expected)
+ (pass-if expected
+ (equal? expected (car (replace-range pred-begin pred-end (list tree))))))
+
+ ;; Remove one node, "s2"
+ (test
+ (lambda (node)
+ (and (equal? node "s2") '()))
+ (lambda (node) (list node))
+ '(root (n1 (n11) "s12" (n13))
+ (n2 (n21) "s22")
+ (n3 (n31 (n311)) "s32" (n33 (n331) "s332" (n333)) "s34")))
+
+ ;; Replace one node, "s2" with "s2-new"
+ (test
+ (lambda (node)
+ (and (equal? node "s2") '("s2-new")))
+ (lambda (node) (list node))
+ '(root (n1 (n11) "s12" (n13))
+ "s2-new"
+ (n2 (n21) "s22")
+ (n3 (n31 (n311)) "s32" (n33 (n331) "s332" (n333)) "s34")))
+
+ ;; Replace one node, "s2" with "s2-new" and its brother (n-new "s")
+ (test
+ (lambda (node)
+ (and (equal? node "s2") '("s2-new" (n-new "s"))))
+ (lambda (node) (list node))
+ '(root (n1 (n11) "s12" (n13))
+ "s2-new" (n-new "s")
+ (n2 (n21) "s22")
+ (n3 (n31 (n311)) "s32" (n33 (n331) "s332" (n333)) "s34")))
+
+ ;; Remove everything from "s2" onward
+ (test
+ (lambda (node)
+ (and (equal? node "s2") '()))
+ (lambda (node) #f)
+ '(root (n1 (n11) "s12" (n13))))
+
+ ;; Remove everything from "n1" onward
+ (test
+ (lambda (node)
+ (and (pair? node) (eq? 'n1 (car node)) '()))
+ (lambda (node) #f)
+ '(root))
+
+ ;; Replace from n1 through n33
+ (test
+ (lambda (node)
+ (and (pair? node)
+ (eq? 'n1 (car node))
+ (list node '(n1* "s12*"))))
+ (lambda (node)
+ (and (pair? node)
+ (eq? 'n33 (car node))
+ (list node)))
+ '(root
+ (n1 (n11) "s12" (n13))
+ (n1* "s12*")
+ (n3
+ (n33 (n331) "s332" (n333))
+ "s34"))))
--- /dev/null
+;; -*- scheme -*-
+;; guile-lib
+;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation Voice: +1-617-542-5942
+;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
+;; Boston, MA 02111-1307, USA gnu@gnu.org
+
+;;; Commentary:
+;;
+;; Unit tests for (sxml xpath).
+;;
+;;; Code:
+
+(define-module (test-suite sxml-xpath)
+ #:use-module (test-suite lib)
+ #:use-module (sxml xpath))
+
+(define tree1
+ '(html
+ (head (title "Slides"))
+ (body
+ (p (@ (align "center"))
+ (table (@ (style "font-size: x-large"))
+ (tr
+ (td (@ (align "right")) "Talks ")
+ (td (@ (align "center")) " = ")
+ (td " slides + transition"))
+ (tr (td)
+ (td (@ (align "center")) " = ")
+ (td " data + control"))
+ (tr (td)
+ (td (@ (align "center")) " = ")
+ (td " programs"))))
+ (ul
+ (li (a (@ (href "slides/slide0001.gif")) "Introduction"))
+ (li (a (@ (href "slides/slide0010.gif")) "Summary")))
+ )))
+
+
+;; Example from a posting "Re: DrScheme and XML",
+;; Shriram Krishnamurthi, comp.lang.scheme, Nov. 26. 1999.
+;; http://www.deja.com/getdoc.xp?AN=553507805
+(define tree3
+ '(poem (@ (title "The Lovesong of J. Alfred Prufrock")
+ (poet "T. S. Eliot"))
+ (stanza
+ (line "Let us go then, you and I,")
+ (line "When the evening is spread out against the sky")
+ (line "Like a patient etherized upon a table:"))
+ (stanza
+ (line "In the room the women come and go")
+ (line "Talking of Michaelangelo."))))
+
+(define (run-test selector node expected)
+ (pass-if expected
+ (equal? expected (selector node))))
+
+(with-test-prefix "test-all"
+
+
+ ;; Location path, full form: child::para
+ ;; Location path, abbreviated form: para
+ ;; selects the para element children of the context node
+ (let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para (@) "second par"))
+ )
+ (expected '((para (@) "para") (para (@) "second par")))
+ )
+ (run-test (select-kids (node-typeof? 'para)) tree expected)
+ (run-test (sxpath '(para)) tree expected))
+
+ ;; Location path, full form: child::*
+ ;; Location path, abbreviated form: *
+ ;; selects all element children of the context node
+ (let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+ )
+ (expected
+ '((para (@) "para") (br (@)) (para "second par")))
+ )
+ (run-test (select-kids (node-typeof? '*)) tree expected)
+ (run-test (sxpath '(*)) tree expected))
+
+ ;; Location path, full form: child::text()
+ ;; Location path, abbreviated form: text()
+ ;; selects all text node children of the context node
+ (let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+ )
+ (expected
+ '("cdata"))
+ )
+ (run-test (select-kids (node-typeof? '*text*)) tree expected)
+ (run-test (sxpath '(*text*)) tree expected))
+
+ ;; Location path, full form: child::node()
+ ;; Location path, abbreviated form: node()
+ ;; selects all the children of the context node, whatever their node type
+ (let* ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+ )
+ (expected (cdr tree))
+ )
+ (run-test (select-kids (node-typeof? '*any*)) tree expected)
+ (run-test (sxpath '(*any*)) tree expected)
+ )
+
+ ;; Location path, full form: child::*/child::para
+ ;; Location path, abbreviated form: */para
+ ;; selects all para grandchildren of the context node
+
+ (let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para "third para")))
+ )
+ (expected
+ '((para "third para")))
+ )
+ (run-test
+ (node-join (select-kids (node-typeof? '*))
+ (select-kids (node-typeof? 'para)))
+ tree expected)
+ (run-test (sxpath '(* para)) tree expected)
+ )
+
+
+ ;; Location path, full form: attribute::name
+ ;; Location path, abbreviated form: @name
+ ;; selects the 'name' attribute of the context node
+
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para (@) "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((name "elem")))
+ )
+ (run-test
+ (node-join (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'name)))
+ tree expected)
+ (run-test (sxpath '(@ name)) tree expected)
+ )
+
+ ;; Location path, full form: attribute::*
+ ;; Location path, abbreviated form: @*
+ ;; selects all the attributes of the context node
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((name "elem") (id "idz")))
+ )
+ (run-test
+ (node-join (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? '*)))
+ tree expected)
+ (run-test (sxpath '(@ *)) tree expected)
+ )
+
+
+ ;; Location path, full form: descendant::para
+ ;; Location path, abbreviated form: .//para
+ ;; selects the para element descendants of the context node
+
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((para (@) "para") (para "second par") (para (@) "third para")))
+ )
+ (run-test
+ (node-closure (node-typeof? 'para))
+ tree expected)
+ (run-test (sxpath '(// para)) tree expected)
+ )
+
+ ;; Location path, full form: self::para
+ ;; Location path, abbreviated form: _none_
+ ;; selects the context node if it is a para element; otherwise selects nothing
+
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ )
+ (run-test (node-self (node-typeof? 'para)) tree '())
+ (run-test (node-self (node-typeof? 'elem)) tree (list tree))
+ )
+
+ ;; Location path, full form: descendant-or-self::node()
+ ;; Location path, abbreviated form: //
+ ;; selects the context node, all the children (including attribute nodes)
+ ;; of the context node, and all the children of all the (element)
+ ;; descendants of the context node.
+ ;; This is _almost_ a powerset of the context node.
+ (let* ((tree
+ '(para (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ (cons tree
+ (append (cdr tree)
+ '((@) "para" (@) "second par"
+ (@ (name "aa")) (para (@) "third para")
+ (@) "third para"))))
+ )
+ (run-test
+ (node-or
+ (node-self (node-typeof? '*any*))
+ (node-closure (node-typeof? '*any*)))
+ tree expected)
+ (run-test (sxpath '(//)) tree expected)
+ )
+
+ ;; Location path, full form: ancestor::div
+ ;; Location path, abbreviated form: _none_
+ ;; selects all div ancestors of the context node
+ ;; This Location expression is equivalent to the following:
+ ; /descendant-or-self::div[descendant::node() = curr_node]
+ ;; This shows that the ancestor:: axis is actually redundant. Still,
+ ;; it can be emulated as the following SXPath expression demonstrates.
+
+ ;; The insight behind "ancestor::div" -- selecting all "div" ancestors
+ ;; of the current node -- is
+ ;; S[ancestor::div] context_node =
+ ;; { y | y=subnode*(root), context_node=subnode(subnode*(y)),
+ ;; isElement(y), name(y) = "div" }
+ ;; We observe that
+ ;; { y | y=subnode*(root), pred(y) }
+ ;; can be expressed in SXPath as
+ ;; ((node-or (node-self pred) (node-closure pred)) root-node)
+ ;; The composite predicate 'isElement(y) & name(y) = "div"' corresponds to
+ ;; (node-self (node-typeof? 'div)) in SXPath. Finally, filter
+ ;; context_node=subnode(subnode*(y)) is tantamount to
+ ;; (node-closure (node-eq? context-node)), whereas node-reduce denotes the
+ ;; the composition of converters-predicates in the filtering context.
+
+ (let*
+ ((root
+ '(div (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para (@) "second par")
+ (div (@ (name "aa")) (para (@) "third para"))))
+ (context-node ; /descendant::any()[child::text() == "third para"]
+ (car
+ ((node-closure
+ (select-kids
+ (node-equal? "third para")))
+ root)))
+ (pred
+ (node-reduce (node-self (node-typeof? 'div))
+ (node-closure (node-eq? context-node))
+ ))
+ )
+ (run-test
+ (node-or
+ (node-self pred)
+ (node-closure pred))
+ root
+ (cons root
+ '((div (@ (name "aa")) (para (@) "third para")))))
+ )
+
+
+
+ ;; Location path, full form: child::div/descendant::para
+ ;; Location path, abbreviated form: div//para
+ ;; selects the para element descendants of the div element
+ ;; children of the context node
+
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")
+ (div (para "fourth para"))))
+ )
+ (expected
+ '((para (@) "third para") (para "fourth para")))
+ )
+ (run-test
+ (node-join
+ (select-kids (node-typeof? 'div))
+ (node-closure (node-typeof? 'para)))
+ tree expected)
+ (run-test (sxpath '(div // para)) tree expected)
+ )
+
+
+ ;; Location path, full form: /descendant::olist/child::item
+ ;; Location path, abbreviated form: //olist/item
+ ;; selects all the item elements that have an olist parent (which is not root)
+ ;; and that are in the same document as the context node
+ ;; See the following test.
+
+ ;; Location path, full form: /descendant::td/attribute::align
+ ;; Location path, abbreviated form: //td/@align
+ ;; Selects 'align' attributes of all 'td' elements in tree1
+ (let ((tree tree1)
+ (expected
+ '((align "right") (align "center") (align "center") (align "center"))
+ ))
+ (run-test
+ (node-join
+ (node-closure (node-typeof? 'td))
+ (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'align)))
+ tree expected)
+ (run-test (sxpath '(// td @ align)) tree expected)
+ )
+
+
+ ;; Location path, full form: /descendant::td[attribute::align]
+ ;; Location path, abbreviated form: //td[@align]
+ ;; Selects all td elements that have an attribute 'align' in tree1
+ (let ((tree tree1)
+ (expected
+ '((td (@ (align "right")) "Talks ") (td (@ (align "center")) " = ")
+ (td (@ (align "center")) " = ") (td (@ (align "center")) " = "))
+ ))
+ (run-test
+ (node-reduce
+ (node-closure (node-typeof? 'td))
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'align)))))
+ tree expected)
+ (run-test (sxpath `(// td ,(node-self (sxpath '(@ align))))) tree expected)
+ (run-test (sxpath '(// (td (@ align)))) tree expected)
+ (run-test (sxpath '(// ((td) (@ align)))) tree expected)
+ ;; note! (sxpath ...) is a converter. Therefore, it can be used
+ ;; as any other converter, for example, in the full-form SXPath.
+ ;; Thus we can mix the full and abbreviated form SXPath's freely.
+ (run-test
+ (node-reduce
+ (node-closure (node-typeof? 'td))
+ (filter
+ (sxpath '(@ align))))
+ tree expected)
+ )
+
+
+ ;; Location path, full form: /descendant::td[attribute::align = "right"]
+ ;; Location path, abbreviated form: //td[@align = "right"]
+ ;; Selects all td elements that have an attribute align = "right" in tree1
+ (let ((tree tree1)
+ (expected
+ '((td (@ (align "right")) "Talks "))
+ ))
+ (run-test
+ (node-reduce
+ (node-closure (node-typeof? 'td))
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-equal? '(align "right"))))))
+ tree expected)
+ (run-test (sxpath '(// (td (@ (equal? (align "right")))))) tree expected)
+ )
+
+ ;; Location path, full form: child::para[position()=1]
+ ;; Location path, abbreviated form: para[1]
+ ;; selects the first para child of the context node
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((para (@) "para"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (node-pos 1))
+ tree expected)
+ (run-test (sxpath '((para 1))) tree expected)
+ )
+
+ ;; Location path, full form: child::para[position()=last()]
+ ;; Location path, abbreviated form: para[last()]
+ ;; selects the last para child of the context node
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((para "second par"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (node-pos -1))
+ tree expected)
+ (run-test (sxpath '((para -1))) tree expected)
+ )
+
+ ;; Illustrating the following Note of Sec 2.5 of XPath:
+ ;; "NOTE: The location path //para[1] does not mean the same as the
+ ;; location path /descendant::para[1]. The latter selects the first
+ ;; descendant para element; the former selects all descendant para
+ ;; elements that are the first para children of their parents."
+
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ )
+ (run-test
+ (node-reduce ; /descendant::para[1] in SXPath
+ (node-closure (node-typeof? 'para))
+ (node-pos 1))
+ tree '((para (@) "para")))
+ (run-test (sxpath '(// (para 1))) tree
+ '((para (@) "para") (para (@) "third para")))
+ )
+
+ ;; Location path, full form: parent::node()
+ ;; Location path, abbreviated form: ..
+ ;; selects the parent of the context node. The context node may be
+ ;; an attribute node!
+ ;; For the last test:
+ ;; Location path, full form: parent::*/attribute::name
+ ;; Location path, abbreviated form: ../@name
+ ;; Selects the name attribute of the parent of the context node
+
+ (let* ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (para1 ; the first para node
+ (car ((sxpath '(para)) tree)))
+ (para3 ; the third para node
+ (car ((sxpath '(div para)) tree)))
+ (div ; div node
+ (car ((sxpath '(// div)) tree)))
+ )
+ (run-test
+ (node-parent tree)
+ para1 (list tree))
+ (run-test
+ (node-parent tree)
+ para3 (list div))
+ (run-test ; checking the parent of an attribute node
+ (node-parent tree)
+ ((sxpath '(@ name)) div) (list div))
+ (run-test
+ (node-join
+ (node-parent tree)
+ (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'name)))
+ para3 '((name "aa")))
+ (run-test
+ (sxpath `(,(node-parent tree) @ name))
+ para3 '((name "aa")))
+ )
+
+ ;; Location path, full form: following-sibling::chapter[position()=1]
+ ;; Location path, abbreviated form: none
+ ;; selects the next chapter sibling of the context node
+ ;; The path is equivalent to
+ ;; let cnode = context-node
+ ;; in
+ ;; parent::* / child::chapter [take-after node_eq(self::*,cnode)]
+ ;; [position()=1]
+ (let* ((tree
+ '(document
+ (preface "preface")
+ (chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (chapter (@ (id "four")) "Chap 4 text")
+ (epilogue "Epilogue text")
+ (appendix (@ (id "A")) "App A text")
+ (References "References"))
+ )
+ (a-node ; to be used as a context node
+ (car ((sxpath '(// (chapter (@ (equal? (id "two")))))) tree)))
+ (expected
+ '((chapter (@ (id "three")) "Chap 3 text")))
+ )
+ (run-test
+ (node-reduce
+ (node-join
+ (node-parent tree)
+ (select-kids (node-typeof? 'chapter)))
+ (take-after (node-eq? a-node))
+ (node-pos 1)
+ )
+ a-node expected)
+ )
+
+ ;; preceding-sibling::chapter[position()=1]
+ ;; selects the previous chapter sibling of the context node
+ ;; The path is equivalent to
+ ;; let cnode = context-node
+ ;; in
+ ;; parent::* / child::chapter [take-until node_eq(self::*,cnode)]
+ ;; [position()=-1]
+ (let* ((tree
+ '(document
+ (preface "preface")
+ (chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (chapter (@ (id "four")) "Chap 4 text")
+ (epilogue "Epilogue text")
+ (appendix (@ (id "A")) "App A text")
+ (References "References"))
+ )
+ (a-node ; to be used as a context node
+ (car ((sxpath '(// (chapter (@ (equal? (id "three")))))) tree)))
+ (expected
+ '((chapter (@ (id "two")) "Chap 2 text")))
+ )
+ (run-test
+ (node-reduce
+ (node-join
+ (node-parent tree)
+ (select-kids (node-typeof? 'chapter)))
+ (take-until (node-eq? a-node))
+ (node-pos -1)
+ )
+ a-node expected)
+ )
+
+
+ ;; /descendant::figure[position()=42]
+ ;; selects the forty-second figure element in the document
+ ;; See the next example, which is more general.
+
+ ;; Location path, full form:
+ ;; child::table/child::tr[position()=2]/child::td[position()=3]
+ ;; Location path, abbreviated form: table/tr[2]/td[3]
+ ;; selects the third td of the second tr of the table
+ (let ((tree ((node-closure (node-typeof? 'p)) tree1))
+ (expected
+ '((td " data + control"))
+ ))
+ (run-test
+ (node-join
+ (select-kids (node-typeof? 'table))
+ (node-reduce (select-kids (node-typeof? 'tr))
+ (node-pos 2))
+ (node-reduce (select-kids (node-typeof? 'td))
+ (node-pos 3)))
+ tree expected)
+ (run-test (sxpath '(table (tr 2) (td 3))) tree expected)
+ )
+
+
+ ;; Location path, full form:
+ ;; child::para[attribute::type='warning'][position()=5]
+ ;; Location path, abbreviated form: para[@type='warning'][5]
+ ;; selects the fifth para child of the context node that has a type
+ ;; attribute with value warning
+ (let ((tree
+ '(chapter
+ (para "para1")
+ (para (@ (type "warning")) "para 2")
+ (para (@ (type "warning")) "para 3")
+ (para (@ (type "warning")) "para 4")
+ (para (@ (type "warning")) "para 5")
+ (para (@ (type "warning")) "para 6"))
+ )
+ (expected
+ '((para (@ (type "warning")) "para 6"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-equal? '(type "warning")))))
+ (node-pos 5))
+ tree expected)
+ (run-test (sxpath '( (((para (@ (equal? (type "warning"))))) 5 ) ))
+ tree expected)
+ (run-test (sxpath '( (para (@ (equal? (type "warning"))) 5 ) ))
+ tree expected)
+ )
+
+
+ ;; Location path, full form:
+ ;; child::para[position()=5][attribute::type='warning']
+ ;; Location path, abbreviated form: para[5][@type='warning']
+ ;; selects the fifth para child of the context node if that child has a 'type'
+ ;; attribute with value warning
+ (let ((tree
+ '(chapter
+ (para "para1")
+ (para (@ (type "warning")) "para 2")
+ (para (@ (type "warning")) "para 3")
+ (para (@ (type "warning")) "para 4")
+ (para (@ (type "warning")) "para 5")
+ (para (@ (type "warning")) "para 6"))
+ )
+ (expected
+ '((para (@ (type "warning")) "para 5"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (node-pos 5)
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-equal? '(type "warning"))))))
+ tree expected)
+ (run-test (sxpath '( (( (para 5)) (@ (equal? (type "warning"))))))
+ tree expected)
+ (run-test (sxpath '( (para 5 (@ (equal? (type "warning")))) ))
+ tree expected)
+ )
+
+ ;; Location path, full form:
+ ;; child::*[self::chapter or self::appendix]
+ ;; Location path, semi-abbreviated form: *[self::chapter or self::appendix]
+ ;; selects the chapter and appendix children of the context node
+ (let ((tree
+ '(document
+ (preface "preface")
+ (chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (epilogue "Epilogue text")
+ (appendix (@ (id "A")) "App A text")
+ (References "References"))
+ )
+ (expected
+ '((chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (appendix (@ (id "A")) "App A text"))
+ ))
+ (run-test
+ (node-join
+ (select-kids (node-typeof? '*))
+ (filter
+ (node-or
+ (node-self (node-typeof? 'chapter))
+ (node-self (node-typeof? 'appendix)))))
+ tree expected)
+ (run-test (sxpath `(* ,(node-or (node-self (node-typeof? 'chapter))
+ (node-self (node-typeof? 'appendix)))))
+ tree expected)
+ )
+
+
+ ;; Location path, full form: child::chapter[child::title='Introduction']
+ ;; Location path, abbreviated form: chapter[title = 'Introduction']
+ ;; selects the chapter children of the context node that have one or more
+ ;; title children with string-value equal to Introduction
+ ;; See a similar example: //td[@align = "right"] above.
+
+ ;; Location path, full form: child::chapter[child::title]
+ ;; Location path, abbreviated form: chapter[title]
+ ;; selects the chapter children of the context node that have one or
+ ;; more title children
+ ;; See a similar example //td[@align] above.
+
+ (let ((tree tree3)
+ (expected
+ '("Let us go then, you and I," "In the room the women come and go")
+ ))
+ (run-test
+ (node-join
+ (node-closure (node-typeof? 'stanza))
+ (node-reduce
+ (select-kids (node-typeof? 'line)) (node-pos 1))
+ (select-kids (node-typeof? '*text*)))
+ tree expected)
+ (run-test (sxpath '(// stanza (line 1) *text*)) tree expected)
+ )
+ )
--- /dev/null
+;; -*- scheme -*-
+;; guile-lib
+;; Copyright (C) 2007, 2009 Andy Wingo <wingo at pobox dot com>
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation Voice: +1-617-542-5942
+;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
+;; Boston, MA 02111-1307, USA gnu@gnu.org
+
+;;; Commentary:
+;;
+;; Unit tests for (texinfo docbook).
+;;
+;;; Code:
+
+(define-module (test-suite texinfo-docbook)
+ #:use-module (test-suite lib)
+ #:use-module (texinfo docbook))
+
+(with-test-prefix "test-flatten"
+ (pass-if (equal?
+ (sdocbook-flatten '(refsect1 (refsect2 (para "foo"))))
+ '((refsect1) (refsect2) (para "foo")))))
--- /dev/null
+;; -*- scheme -*-
+;; guile-lib
+;; Copyright (C) 2007, 2009 Andy Wingo <wingo at pobox dot com>
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation Voice: +1-617-542-5942
+;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
+;; Boston, MA 02111-1307, USA gnu@gnu.org
+
+;;; Commentary:
+;;
+;; Unit tests for (texinfo serialize).
+;;
+;;; Code:
+
+(define-module (test-suite texinfo-serialize)
+ #:use-module (test-suite lib)
+ #:use-module (texinfo serialize))
+
+(with-test-prefix "test-serialize"
+ (define (assert-serialize stexi str)
+ (pass-if str (equal? str (stexi->texi stexi))))
+
+ (assert-serialize '(para)
+ "
+
+")
+
+ (assert-serialize '(para "foo")
+ "foo
+
+")
+
+ (assert-serialize '(var "foo")
+ "@var{foo}")
+
+
+ ;; i don't remember why braces exists, but as long as it does, a test
+ ;; is in order
+ (assert-serialize '(*braces* "foo")
+ "@{foo@}")
+
+ (assert-serialize '(value (% (key "foo")))
+ "@value{foo}")
+
+ (assert-serialize '(ref (% (node "foo")))
+ "@ref{foo}")
+ (assert-serialize '(ref (% (node "foo") (name "bar")))
+ "@ref{foo,bar}")
+ (assert-serialize '(ref (% (node "foo") (name "bar")
+ (section "qux") (info-file "xyzzy")
+ (manual "zarg")))
+ "@ref{foo,bar,qux,xyzzy,zarg}")
+ (assert-serialize '(ref (% (section "qux") (info-file "xyzzy")
+ (node "foo") (name "bar")
+ (manual "zarg")))
+ "@ref{foo,bar,qux,xyzzy,zarg}")
+ (assert-serialize '(ref (% (node "foo")
+ (manual "zarg")))
+ "@ref{foo,,,,zarg}")
+
+ (assert-serialize '(dots) "@dots{}")
+
+ (assert-serialize '(node (% (name "foo")))
+ "@node foo
+")
+
+ (assert-serialize '(node (% (name "foo bar")))
+ "@node foo bar
+")
+ (assert-serialize '(node (% (name "foo bar") (next "baz")))
+ "@node foo bar, baz
+")
+
+ (assert-serialize '(title "Foo")
+ "@title Foo
+")
+ (assert-serialize '(title "Foo is a " (var "bar"))
+ "@title Foo is a @var{bar}
+")
+
+ (assert-serialize '(title "Foo is a " (var "bar") " baz")
+ "@title Foo is a @var{bar} baz
+")
+
+ (assert-serialize '(cindex (% (entry "Bar baz, foo")))
+ "@cindex Bar baz, foo
+")
+
+ ;; there is a space after @iftex, doesn't matter tho
+ (assert-serialize '(iftex
+ (para "This is only for tex.")
+ (para "Note. Foo."))
+ "@iftex
+This is only for tex.
+
+Note. Foo.
+
+@end iftex
+
+")
+
+ (assert-serialize '(defun (% (name "frob"))
+ (para "foo?"))
+ "@defun frob
+foo?
+
+@end defun
+
+")
+
+ (assert-serialize '(defun (% (name "frob") (arguments "bar"))
+ (para "foo?"))
+ "@defun frob bar
+foo?
+
+@end defun
+
+")
+
+ (assert-serialize '(defun (% (name "frob") (arguments "bar" " " "baz"))
+ (para "foo?"))
+ "@defun frob bar baz
+foo?
+
+@end defun
+
+")
+
+ (assert-serialize '(defun (% (name "frob") (arguments (var "bar")))
+ (para "foo?"))
+ "@defun frob @var{bar}
+foo?
+
+@end defun
+
+")
+
+ (assert-serialize '(defunx (% (name "frob") (arguments (var "bar"))))
+ "@defunx frob @var{bar}
+")
+
+ (assert-serialize '(table (% (formatter (var)))
+ (entry (% (heading "Foo bar " (code "baz")))
+ (para "Frobate")
+ (para "zzzzz")))
+ "@table @var
+@item Foo bar @code{baz}
+Frobate
+
+zzzzz
+
+@end table
+
+")
+
+ (assert-serialize '(verbatim "foo")
+ "@verbatim
+foo
+@end verbatim
+
+")
+
+ (assert-serialize '(deffnx (% (name "foo") (category "bar")))
+ "@deffnx bar foo
+")
+
+ (assert-serialize '(deffnx (% (name "foo") (category "bar") (arguments "x" " " "y")))
+ "@deffnx bar foo x y
+")
+
+ (assert-serialize '(deffnx (% (name "foo") (category "bar") (arguments "(" "x" " " (code "int") ")")))
+ "@deffnx bar foo (x @code{int})
+")
+
+ )
--- /dev/null
+;; -*- scheme -*-
+;;; ----------------------------------------------------------------------
+;;; unit test
+;;; Copyright (C) 2003, 2009 Free Software Foundation, Inc.
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;; ----------------------------------------------------------------------
+(define-module (test-suite test-string-utils)
+ #:use-module (test-suite lib)
+ #:use-module (texinfo string-utils))
+
+
+;; **********************************************************************
+;; Test for expand-tabs
+;; **********************************************************************
+(with-test-prefix "test-beginning-expansion"
+ (pass-if (equal? " Hello"
+ (expand-tabs "\tHello")))
+ (pass-if (equal? " Hello"
+ (expand-tabs "\t\tHello"))))
+
+(with-test-prefix "test-ending-expansion"
+ (pass-if (equal? "Hello "
+ (expand-tabs "Hello\t")))
+ (pass-if (equal? "Hello "
+ (expand-tabs "Hello\t\t"))))
+
+(with-test-prefix "test-middle-expansion"
+ (pass-if (equal? "Hello there" (expand-tabs "Hello\tthere")))
+ (pass-if (equal? "Hello there" (expand-tabs "Hello\t\tthere"))))
+
+(with-test-prefix "test-alternate-tab-size"
+ (pass-if (equal? "Hello there"
+ (expand-tabs "Hello\tthere" 3)))
+ (pass-if (equal? "Hello there"
+ (expand-tabs "Hello\tthere" 4)))
+ (pass-if (equal? "Hello there"
+ (expand-tabs "Hello\tthere" 5))))
+
+;; **********************************************************************
+;; tests for escape-special-chars
+;; **********************************************************************
+(with-test-prefix "test-single-escape-char"
+ (pass-if (equal? "HeElElo"
+ (escape-special-chars "Hello" #\l #\E))))
+
+(with-test-prefix "test-multiple-escape-chars"
+ (pass-if (equal? "HEeElElo"
+ (escape-special-chars "Hello" "el" #\E))))
+
+
+;; **********************************************************************
+;; tests for collapsing-multiple-chars
+;; **********************************************************************
+(with-test-prefix "collapse-repeated-chars"
+ (define test-string
+ "H e l l o t h e r e")
+
+ (with-test-prefix "test-basic-collapse"
+ (pass-if (equal? "H e l l o t h e r e"
+ (collapse-repeated-chars test-string))))
+
+ (with-test-prefix "test-choose-other-char"
+ (pass-if (equal? "H-e-l-l-o-t-h-e-r-e"
+ (collapse-repeated-chars (transform-string test-string #\space #\-)
+ #\-))))
+
+ (with-test-prefix "test-choose-maximum-repeats"
+ (pass-if (equal? "H e l l o t h e r e"
+ (collapse-repeated-chars test-string #\space 2)))
+ (pass-if (equal? "H e l l o t h e r e"
+ (collapse-repeated-chars test-string #\space 3)))))
+
+;; **********************************************************************
+;; Test of the object itself...
+;; **********************************************************************
+(with-test-prefix "text wrapping"
+ (define test-string "
+The last language environment specified with
+`set-language-environment'. This variable should be
+set only with M-x customize, which is equivalent
+to using the function `set-language-environment'.
+")
+
+ (with-test-prefix "runs-without-exception"
+ (pass-if (->bool (fill-string test-string)))
+ (pass-if (->bool (fill-string test-string #:line-width 20)))
+ (pass-if (->bool (fill-string test-string #:initial-indent " * " #:tab-width 3))))
+
+ (with-test-prefix "test-fill-equivalent-to-joined-lines"
+ (pass-if (equal? (fill-string test-string)
+ (string-join (string->wrapped-lines test-string) "\n" 'infix))))
+
+ (with-test-prefix "test-no-collapse-ws"
+ (pass-if (equal? (fill-string test-string #:collapse-whitespace? #f)
+ "The last language environment specified with `set-language-environment'. This
+variable should be set only with M-x customize, which is equivalent to using
+the function `set-language-environment'.")))
+
+ (with-test-prefix "test-no-word-break"
+ (pass-if (equal? "thisisalongword
+blah
+blah"
+ (fill-string "thisisalongword blah blah"
+ #:line-width 8
+ #:break-long-words? #f)))))
--- /dev/null
+;; -*- scheme -*-
+;; guile-lib
+;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
+;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation Voice: +1-617-542-5942
+;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
+;; Boston, MA 02111-1307, USA gnu@gnu.org
+
+;;; Commentary:
+;;
+;; Unit tests for (sxml texinfo). Adapted from xml.ssax.scm.
+;;
+;;; Code:
+
+(define-module (test-suite texinfo)
+ #:use-module (test-suite lib)
+ #:use-module (texinfo))
+
+(define exception:eof-while-reading-token
+ '(parser-error . "^EOF while reading a token"))
+(define exception:wrong-character
+ '(parser-error . "^Wrong character"))
+(define exception:eof-while-reading-char-data
+ '(parser-error . "^EOF while reading char data"))
+(define exception:no-settitle
+ '(parser-error . "^No \\\\n@settitle found"))
+(define exception:unexpected-arg
+ '(parser-error . "^@-command didn't expect more arguments"))
+(define exception:bad-enumerate
+ '(parser-error . "^Invalid"))
+
+(define nl (string #\newline))
+
+(define texinfo:read-verbatim-body
+ (@@ (texinfo) read-verbatim-body))
+(with-test-prefix "test-read-verbatim-body"
+ (define (read-verbatim-body-from-string str)
+ (define (consumer fragment foll-fragment seed)
+ (cons* (if (equal? foll-fragment (string #\newline))
+ (string-append " NL" nl)
+ foll-fragment)
+ fragment seed))
+ (reverse
+ (call-with-input-string
+ str
+ (lambda (port) (texinfo:read-verbatim-body port consumer '())))))
+
+ (pass-if (equal? '()
+ (read-verbatim-body-from-string "@end verbatim\n")))
+
+ ;; after @verbatim, the current position will always directly after
+ ;; the newline.
+ (pass-if-exception "@end verbatim needs a newline"
+ exception:eof-while-reading-token
+ (read-verbatim-body-from-string "@end verbatim"))
+
+ (pass-if (equal? '("@@end verbatim" " NL\n")
+ (read-verbatim-body-from-string "@@end verbatim\n@end verbatim\n")))
+
+ (pass-if (equal? '("@@@@faosfasf adsfas " " NL\n" " asf @foo{asdf}" " NL\n")
+ (read-verbatim-body-from-string
+ "@@@@faosfasf adsfas \n asf @foo{asdf}\n@end verbatim\n")))
+
+ (pass-if (equal? '("@end verbatim " " NL\n")
+ (read-verbatim-body-from-string "@end verbatim \n@end verbatim\n"))))
+
+(define texinfo:read-arguments
+ (@@ (texinfo) read-arguments))
+(with-test-prefix "test-read-arguments"
+ (define (read-arguments-from-string str)
+ (call-with-input-string
+ str
+ (lambda (port) (texinfo:read-arguments port #\}))))
+
+ (define (test str expected-res)
+ (pass-if (equal? expected-res
+ (read-arguments-from-string str))))
+
+ (test "}" '())
+ (test "foo}" '("foo"))
+ (test "foo,bar}" '("foo" "bar"))
+ (test " foo , bar }" '("foo" "bar"))
+ (test " foo , , bar }" '("foo" #f "bar"))
+ (test "foo,,bar}" '("foo" #f "bar"))
+ (pass-if-exception "need a } when reading arguments"
+ exception:eof-while-reading-token
+ (call-with-input-string
+ "foo,,bar"
+ (lambda (port) (texinfo:read-arguments port #\})))))
+
+(define texinfo:complete-start-command
+ (@@ (texinfo) complete-start-command))
+(with-test-prefix "test-complete-start-command"
+ (define (test command str)
+ (call-with-input-string
+ str
+ (lambda (port)
+ (call-with-values
+ (lambda ()
+ (texinfo:complete-start-command command port))
+ list))))
+
+ (pass-if (equal? '(section () EOL-TEXT)
+ (test 'section "foo bar baz bonzerts")))
+ (pass-if (equal? '(deffnx ((category "Function") (name "foo") (arguments)) EOL-TEXT-ARGS)
+ (test 'deffnx "Function foo")))
+ (pass-if-exception "@emph missing a start brace"
+ exception:wrong-character
+ (test 'emph "no brace here"))
+ (pass-if (equal? '(emph () INLINE-TEXT)
+ (test 'emph "{foo bar baz bonzerts")))
+ (pass-if (equal? '(ref ((node "foo bar") (section "baz") (info-file "bonzerts"))
+ INLINE-ARGS)
+ (test 'ref "{ foo bar ,, baz, bonzerts}")))
+ (pass-if (equal? '(node ((name "referenced node")) EOL-ARGS)
+ (test 'node " referenced node\n"))))
+
+(define texinfo:read-char-data
+ (@@ (texinfo) read-char-data))
+(define make-texinfo-token cons)
+(with-test-prefix "test-read-char-data"
+ (let* ((code (make-texinfo-token 'START 'code))
+ (ref (make-texinfo-token 'EMPTY 'ref))
+ (title (make-texinfo-token 'LINE 'title))
+ (node (make-texinfo-token 'EMPTY 'node))
+ (eof-object (with-input-from-string "" read))
+ (str-handler (lambda (fragment foll-fragment seed)
+ (if (string-null? foll-fragment)
+ (cons fragment seed)
+ (cons* foll-fragment fragment seed)))))
+ (define (test str expect-eof? preserve-ws? expected-data expected-token)
+ (call-with-values
+ (lambda ()
+ (call-with-input-string
+ str
+ (lambda (port)
+ (texinfo:read-char-data
+ port expect-eof? preserve-ws? str-handler '()))))
+ (lambda (seed token)
+ (let ((result (reverse seed)))
+ (pass-if (equal? expected-data result))
+ (pass-if (equal? expected-token token))))))
+
+ ;; add some newline-related tests here
+ (test "" #t #f '() eof-object)
+ (test "foo bar baz" #t #f '("foo bar baz") eof-object)
+ (pass-if-exception "eof reading char data"
+ exception:eof-while-reading-token
+ (test "" #f #f '() eof-object))
+ (test " " #t #f '(" ") eof-object)
+ (test " @code{foo} " #f #f '(" ") code)
+ (test " @code" #f #f '(" ") code)
+ (test " {text here} asda" #f #f '(" ") (make-texinfo-token 'START '*braces*))
+ (test " blah blah} asda" #f #f '(" blah blah") (make-texinfo-token 'END #f))))
+
+
+(with-test-prefix "test-texinfo->stexinfo"
+ (define (test str expected-res)
+ (pass-if (equal? expected-res
+ (call-with-input-string str texi->stexi))))
+ (define (try-with-title title str)
+ (call-with-input-string
+ (string-append "foo bar baz\n@settitle " title "\n" str)
+ texi->stexi))
+ (define (test-with-title title str expected-res)
+ (test (string-append "foo bar baz\n@settitle " title "\n" str)
+ expected-res))
+ (define (test-body str expected-res)
+ (pass-if (equal? expected-res
+ (cddr (try-with-title "zog" str)))))
+
+ (define (list-intersperse src-l elem)
+ (if (null? src-l) src-l
+ (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
+ (if (null? l) (reverse dest)
+ (loop (cdr l) (cons (car l) (cons elem dest)))))))
+ (define (join-lines . lines)
+ (apply string-append (list-intersperse lines "\n")))
+
+ (pass-if-exception "missing @settitle"
+ exception:no-settitle
+ (call-with-input-string "@dots{}\n" texi->stexi))
+
+ (test "\\input texinfo\n@settitle my title\n@dots{}\n"
+ '(texinfo (% (title "my title")) (para (dots))))
+ (test-with-title "my title" "@dots{}\n"
+ '(texinfo (% (title "my title")) (para (dots))))
+ (test-with-title "my title" "@dots{}"
+ '(texinfo (% (title "my title")) (para (dots))))
+
+ (pass-if-exception "arg to @dots{}"
+ exception:unexpected-arg
+ (call-with-input-string
+ "foo bar baz\n@settitle my title\n@dots{arg}"
+ texi->stexi))
+
+ (test-body "@code{arg}"
+ '((para (code "arg"))))
+ (test-body "@code{ }"
+ '((para (code))))
+ (test-body "@code{ @code{} }"
+ '((para (code (code)))))
+ (test-body "@code{ abc @code{} }"
+ '((para (code "abc " (code)))))
+ (test-body "@code{ arg }"
+ '((para (code "arg"))))
+ (test-body "@example\n foo asdf asd sadf asd \n@end example\n"
+ '((example " foo asdf asd sadf asd ")))
+ (test-body (join-lines
+ "@quotation"
+ "@example"
+ " foo asdf asd sadf asd "
+ "@end example"
+ "@end quotation"
+ "")
+ '((quotation (example " foo asdf asd sadf asd "))))
+ (test-body (join-lines
+ "@quotation"
+ "@example"
+ " foo asdf @var{asd} sadf asd "
+ "@end example"
+ "@end quotation"
+ "")
+ '((quotation (example " foo asdf " (var "asd") " sadf asd "))))
+ (test-body (join-lines
+ "@quotation"
+ "@example"
+ " foo asdf @var{asd} sadf asd "
+ ""
+ "not in new para, this is an example"
+ "@end example"
+ "@end quotation"
+ "")
+ '((quotation
+ (example
+ " foo asdf " (var "asd")
+ " sadf asd \n\nnot in new para, this is an example"))))
+ (test-body (join-lines
+ "@titlepage"
+ "@quotation"
+ " foo asdf @var{asd} sadf asd "
+ ""
+ "should be in new para"
+ "@end quotation"
+ "@end titlepage"
+ "")
+ '((titlepage
+ (quotation (para "foo asdf " (var "asd") " sadf asd")
+ (para "should be in new para")))))
+ (test-body (join-lines
+ ""
+ "@titlepage"
+ ""
+ "@quotation"
+ " foo asdf @var{asd} sadf asd "
+ ""
+ "should be in new para"
+ ""
+ ""
+ "@end quotation"
+ "@end titlepage"
+ ""
+ "@bye"
+ ""
+ "@foo random crap at the end"
+ "")
+ '((titlepage
+ (quotation (para "foo asdf " (var "asd") " sadf asd")
+ (para "should be in new para")))))
+ (test-body (join-lines
+ ""
+ "random notes"
+ "@quotation"
+ " foo asdf @var{asd} sadf asd "
+ ""
+ "should be in new para"
+ ""
+ ""
+ "@end quotation"
+ ""
+ " hi mom"
+ "")
+ '((para "random notes")
+ (quotation (para "foo asdf " (var "asd") " sadf asd")
+ (para "should be in new para"))
+ (para "hi mom")))
+ (test-body (join-lines
+ "@enumerate"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end enumerate"
+ )
+ '((enumerate (item (para "one"))
+ (item (para "two"))
+ (item (para "three")))))
+ (test-body (join-lines
+ "@enumerate 44"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end enumerate"
+ )
+ '((enumerate (% (start "44"))
+ (item (para "one"))
+ (item (para "two"))
+ (item (para "three")))))
+ (pass-if-exception "bad enumerate formatter"
+ exception:bad-enumerate
+ (try-with-title "foo" (join-lines
+ "@enumerate string"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end enumerate"
+ )))
+ (pass-if-exception "bad itemize formatter"
+ exception:bad-enumerate
+ (try-with-title "foo" (join-lines
+ "@itemize string"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end itemize"
+ )))
+ (test-body (join-lines
+ "@itemize" ;; no formatter, should default to bullet
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end itemize"
+ )
+ '((itemize (% (bullet (bullet)))
+ (item (para "one"))
+ (item (para "two"))
+ (item (para "three")))))
+ (test-body (join-lines
+ "@itemize @bullet"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end itemize"
+ )
+ '((itemize (% (bullet (bullet)))
+ (item (para "one"))
+ (item (para "two"))
+ (item (para "three")))))
+ (test-body (join-lines
+ "@itemize -"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end itemize"
+ )
+ '((itemize (% (bullet "-"))
+ (item (para "one"))
+ (item (para "two"))
+ (item (para "three")))))
+ (test-body (join-lines
+ "@table @code"
+ "preliminary text -- should go in a pre-item para"
+ "@item one"
+ "item one text"
+ "@item two"
+ "item two text"
+ ""
+ "includes a paragraph"
+ "@item three"
+ "@end itemize"
+ )
+ '((table (% (formatter (code)))
+ (para "preliminary text -- should go in a pre-item para")
+ (entry (% (heading "one"))
+ (para "item one text"))
+ (entry (% (heading "two"))
+ (para "item two text")
+ (para "includes a paragraph"))
+ (entry (% (heading "three"))))))
+ (test-body (join-lines
+ "@chapter @code{foo} bar"
+ "text that should be in a para"
+ )
+ '((chapter (code "foo") " bar")
+ (para "text that should be in a para")))
+ (test-body (join-lines
+ "@deffnx Method foo bar @code{baz}"
+ "text that should be in a para"
+ )
+ '((deffnx (% (category "Method")
+ (name "foo")
+ (arguments "bar " (code "baz"))))
+ (para "text that should be in a para")))
+ )
HCoop / bpt / guile.git / commitdiff