mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

add test suites

Browse source
This commit is contained in:
Andy Wingo 2009-12-20 23:11:34 +01:00
parent c55cb58ac1
commit 500f6a47e2
10 changed files with 2024 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

9
test-suite/Makefile.am
View file

@ -92,11 +92,20 @@ SCM_TESTS = tests/alist.test \
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 \

111
test-suite/tests/statprof.test Normal file
View file

@ -0,0 +1,111 @@
;; 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))))))

212
test-suite/tests/sxml.fold.test Normal file
View file

@ -0,0 +1,212 @@
;; -*- 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)))))

143
test-suite/tests/sxml.ssax.test Normal file
View file

@ -0,0 +1,143 @@
;; -*- 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")))

101
test-suite/tests/sxml.transform.test Normal file
View file

@ -0,0 +1,101 @@
;; -*- 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"))))

700
test-suite/tests/sxml.xpath.test Normal file
View file

@ -0,0 +1,700 @@
;; -*- 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)
)
)

35
test-suite/tests/texinfo.docbook.test Normal file
View file

@ -0,0 +1,35 @@
;; -*- 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")))))

188
test-suite/tests/texinfo.serialize.test Normal file
View file

@ -0,0 +1,188 @@
;; -*- 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})
")
)

118
test-suite/tests/texinfo.string-utils.test Normal file
View file

@ -0,0 +1,118 @@
;; -*- 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)))))

407
test-suite/tests/texinfo.test Normal file
View file

@ -0,0 +1,407 @@
;; -*- 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")))
)