mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

import statprof, sxml, and texinfo from guile-lib

Browse source 
* module/Makefile.am (LIB_SOURCES): Add statprof, sxml, and texinfo to
  the build.
  (NOCOMP_SOURCES): Reindent, and add the upstream SSAX files.

* module/statprof.scm:
* module/sxml/apply-templates.scm:
* module/sxml/fold.scm:
* module/sxml/simple.scm:
* module/sxml/ssax.scm:
* module/sxml/ssax/input-parse.scm:
* module/sxml/transform.scm:
* module/sxml/upstream/COPYING.SSAX:
* module/sxml/upstream/SSAX.scm:
* module/sxml/upstream/SXML-tree-trans.scm:
* module/sxml/upstream/SXPath-old.scm:
* module/sxml/upstream/assert.scm:
* module/sxml/upstream/input-parse.scm:
* module/sxml/xpath.scm:
* module/texinfo.scm:
* module/texinfo/docbook.scm:
* module/texinfo/html.scm:
* module/texinfo/indexing.scm:
* module/texinfo/plain-text.scm:
* module/texinfo/reflection.scm:
* module/texinfo/serialize.scm:
* module/texinfo/string-utils.scm: Add files from guile-lib to Guile.
  It's only Richard, Andreas, Rob, and myself that have copyright on
  these, and we have all assigned to the FSF. SSAX itself is in the
  public domain.
This commit is contained in:
Andy Wingo 2009-12-21 00:01:13 +01:00
parent c66fe8a9a0
commit 47f3ce525e
23 changed files with 10811 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

54
module/Makefile.am
View file

@ -63,7 +63,8 @@ SOURCES = \
$(SCRIPTS_SOURCES) \ $(SCRIPTS_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \ $(ECMASCRIPT_LANG_SOURCES) \
$(ELISP_LANG_SOURCES) \ $(ELISP_LANG_SOURCES) \
$(BRAINFUCK_LANG_SOURCES) $(BRAINFUCK_LANG_SOURCES) \
$(LIB_SOURCES)
## test.scm is not currently installed. ## test.scm is not currently installed.
EXTRA_DIST += \ EXTRA_DIST += \
@ -283,20 +284,43 @@ SYSTEM_SOURCES = \
system/repl/repl.scm system/repl/common.scm \ system/repl/repl.scm system/repl/common.scm \
system/repl/command.scm system/repl/command.scm
LIB_SOURCES = \
statprof.scm \
sxml/apply-templates.scm \
sxml/fold.scm \
sxml/simple.scm \
sxml/ssax/input-parse.scm \
sxml/ssax.scm \
sxml/transform.scm \
sxml/xpath.scm \
texinfo.scm \
texinfo/docbook.scm \
texinfo/html.scm \
texinfo/indexing.scm \
texinfo/string-utils.scm \
texinfo/plain-text.scm \
texinfo/reflection.scm \
texinfo/serialize.scm
EXTRA_DIST += oop/ChangeLog-2008 EXTRA_DIST += oop/ChangeLog-2008
NOCOMP_SOURCES = \ NOCOMP_SOURCES = \
ice-9/gds-client.scm \ ice-9/gds-client.scm \
ice-9/psyntax.scm \ ice-9/psyntax.scm \
ice-9/quasisyntax.scm \ ice-9/quasisyntax.scm \
system/repl/describe.scm \ system/repl/describe.scm \
ice-9/debugger/command-loop.scm \ ice-9/debugger/command-loop.scm \
ice-9/debugger/commands.scm \ ice-9/debugger/commands.scm \
ice-9/debugger/state.scm \ ice-9/debugger/state.scm \
ice-9/debugger/trc.scm \ ice-9/debugger/trc.scm \
ice-9/debugger/utils.scm \ ice-9/debugger/utils.scm \
ice-9/debugging/example-fns.scm \ ice-9/debugging/example-fns.scm \
ice-9/debugging/steps.scm \ ice-9/debugging/steps.scm \
ice-9/debugging/trace.scm \ ice-9/debugging/trace.scm \
ice-9/debugging/traps.scm \ ice-9/debugging/traps.scm \
ice-9/debugging/trc.scm ice-9/debugging/trc.scm \
sxml/upstream/SSAX.scm \
sxml/upstream/SXML-tree-trans.scm \
sxml/upstream/SXPath-old.scm \
sxml/upstream/assert.scm \
sxml/upstream/input-parse.scm

688
module/statprof.scm Normal file
View file

@ -0,0 +1,688 @@
;;;; (statprof) -- a statistical profiler for Guile
;;;; -*-scheme-*-
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;;@code{(statprof)} is intended to be a fairly simple
;;statistical profiler for guile. It is in the early stages yet, so
;;consider its output still suspect, and please report any bugs to
;;@email{guile-devel at gnu.org}, or to me directly at @email{rlb at
;;defaultvalue.org}.
;;
;;A simple use of statprof would look like this:
;;
;;@example
;; (statprof-reset 0 50000 #t)
;; (statprof-start)
;; (do-something)
;; (statprof-stop)
;; (statprof-display)
;;@end example
;;
;;This would reset statprof, clearing all accumulated statistics, then
;;start profiling, run some code, stop profiling, and finally display a
;;gprof flat-style table of statistics which will look something like
;;this:
;;
;;@example
;; % cumulative self self total
;; time seconds seconds calls ms/call ms/call name
;; 35.29 0.23 0.23 2002 0.11 0.11 -
;; 23.53 0.15 0.15 2001 0.08 0.08 positive?
;; 23.53 0.15 0.15 2000 0.08 0.08 +
;; 11.76 0.23 0.08 2000 0.04 0.11 do-nothing
;; 5.88 0.64 0.04 2001 0.02 0.32 loop
;; 0.00 0.15 0.00 1 0.00 150.59 do-something
;; ...
;;@end example
;;
;;All of the numerical data with the exception of the calls column is
;;statistically approximate. In the following column descriptions, and
;;in all of statprof, "time" refers to execution time (both user and
;;system), not wall clock time.
;;
;;@table @asis
;;@item % time
;;The percent of the time spent inside the procedure itself
;;(not counting children).
;;@item cumulative seconds
;;The total number of seconds spent in the procedure, including
;;children.
;;@item self seconds
;;The total number of seconds spent in the procedure itself (not counting
;;children).
;;@item calls
;;The total number of times the procedure was called.
;;@item self ms/call
;;The average time taken by the procedure itself on each call, in ms.
;;@item total ms/call
;;The average time taken by each call to the procedure, including time
;;spent in child functions.
;;@item name
;;The name of the procedure.
;;@end table
;;
;;The profiler uses @code{eq?} and the procedure object itself to
;;identify the procedures, so it won't confuse different procedures with
;;the same name. They will show up as two different rows in the output.
;;
;;Right now the profiler is quite simplistic. I cannot provide
;;call-graphs or other higher level information. What you see in the
;;table is pretty much all there is. Patches are welcome :-)
;;
;;@section Implementation notes
;;
;;The profiler works by setting the unix profiling signal
;;@code{ITIMER_PROF} to go off after the interval you define in the call
;;to @code{statprof-reset}. When the signal fires, a sampling routine is
;;run which looks at the current procedure that's executing, and then
;;crawls up the stack, and for each procedure encountered, increments
;;that procedure's sample count. Note that if a procedure is encountered
;;multiple times on a given stack, it is only counted once. After the
;;sampling is complete, the profiler resets profiling timer to fire
;;again after the appropriate interval.
;;
;;Meanwhile, the profiler keeps track, via @code{get-internal-run-time},
;;how much CPU time (system and user -- which is also what
;;@code{ITIMER_PROF} tracks), has elapsed while code has been executing
;;within a statprof-start/stop block.
;;
;;The profiler also tries to avoid counting or timing its own code as
;;much as possible.
;;
;;; Code:
;; When you add new features, please also add tests to ./tests/ if you
;; have time, and then add the new files to ./run-tests. Also, if
;; anyone's bored, there are a lot of existing API bits that don't
;; have tests yet.
;; TODO
;;
;; Check about profiling C functions -- does profiling primitives work?
;; Also look into stealing code from qprof so we can sample the C stack
;; Call graphs?
(define-module (statprof)
#:use-module (srfi srfi-1)
#:autoload (ice-9 format) (format)
#:export (statprof-active?
statprof-start
statprof-stop
statprof-reset
statprof-accumulated-time
statprof-sample-count
statprof-fold-call-data
statprof-proc-call-data
statprof-call-data-name
statprof-call-data-calls
statprof-call-data-cum-samples
statprof-call-data-self-samples
statprof-call-data->stats
statprof-stats-proc-name
statprof-stats-%-time-in-proc
statprof-stats-cum-secs-in-proc
statprof-stats-self-secs-in-proc
statprof-stats-calls
statprof-stats-self-secs-per-call
statprof-stats-cum-secs-per-call
statprof-display
statprof-display-anomolies
statprof-fetch-stacks
statprof-fetch-call-tree
with-statprof))
;; This profiler tracks two numbers for every function called while
;; it's active. It tracks the total number of calls, and the number
;; of times the function was active when the sampler fired.
;;
;; Globally the profiler tracks the total time elapsed and the number
;; of times the sampler was fired.
;;
;; Right now, this profiler is not per-thread and is not thread safe.
(define accumulated-time #f) ; total so far.
(define last-start-time #f) ; start-time when timer is active.
(define sample-count #f) ; total count of sampler calls.
(define sampling-frequency #f) ; in (seconds . microseconds)
(define remaining-prof-time #f) ; time remaining when prof suspended.
(define profile-level 0) ; for user start/stop nesting.
(define %count-calls? #t) ; whether to catch apply-frame.
(define gc-time-taken 0) ; gc time between statprof-start and
; statprof-stop.
(define record-full-stacks? #f) ; if #t, stash away the stacks
; for later analysis.
(define stacks '())
;; procedure-data will be a hash where the key is the function object
;; itself and the value is the data. The data will be a vector like
;; this: #(name call-count cum-sample-count self-sample-count)
(define procedure-data #f)
;; If you change the call-data data structure, you need to also change
;; sample-uncount-frame.
(define (make-call-data name call-count cum-sample-count self-sample-count)
(vector (or name (error "internal error (we don't count anonymous procs)"))
call-count cum-sample-count self-sample-count))
(define (call-data-name cd) (vector-ref cd 0))
(define (call-data-call-count cd) (vector-ref cd 1))
(define (call-data-cum-sample-count cd) (vector-ref cd 2))
(define (call-data-self-sample-count cd) (vector-ref cd 3))
(define (set-call-data-name! cd name)
(vector-set! cd 0 name))
(define (inc-call-data-call-count! cd)
(vector-set! cd 1 (1+ (vector-ref cd 1))))
(define (inc-call-data-cum-sample-count! cd)
(vector-set! cd 2 (1+ (vector-ref cd 2))))
(define (inc-call-data-self-sample-count! cd)
(vector-set! cd 3 (1+ (vector-ref cd 3))))
(define-macro (accumulate-time stop-time)
`(set! accumulated-time
(+ accumulated-time 0.0 (- ,stop-time last-start-time))))
(define (get-call-data proc)
(or (hashq-ref procedure-data proc)
(let ((call-data (make-call-data (procedure-name proc) 0 0 0)))
(hashq-set! procedure-data proc call-data)
call-data)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SIGPROF handler
(define (sample-stack-procs stack)
(let ((stacklen (stack-length stack))
(hit-count-call? #f))
(if record-full-stacks?
(set! stacks (cons stack stacks)))
(set! sample-count (+ sample-count 1))
;; Now accumulate stats for the whole stack.
(let loop ((frame (stack-ref stack 0))
(procs-seen (make-hash-table 13))
(self #f))
(cond
((not frame)
(hash-fold
(lambda (proc val accum)
(inc-call-data-cum-sample-count!
(get-call-data proc)))
#f
procs-seen)
(and=> (and=> self get-call-data)
inc-call-data-self-sample-count!))
((frame-procedure frame)
=> (lambda (proc)
(cond
((eq? proc count-call)
;; We're not supposed to be sampling count-call and
;; its sub-functions, so loop again with a clean
;; slate.
(set! hit-count-call? #t)
(loop (frame-previous frame) (make-hash-table 13) #f))
((procedure-name proc)
(hashq-set! procs-seen proc #t)
(loop (frame-previous frame)
procs-seen
(or self proc)))
(else
(loop (frame-previous frame) procs-seen self)))))
(else
(loop (frame-previous frame) procs-seen self))))
hit-count-call?))
(define inside-profiler? #f)
(define (profile-signal-handler sig)
(set! inside-profiler? #t)
;; FIXME: with-statprof should be able to set an outer frame for the
;; stack cut
(if (positive? profile-level)
(let* ((stop-time (get-internal-run-time))
;; cut down to the signal handler, then we rely on
;; knowledge of guile: it dispatches signal handlers
;; through a thunk, so cut one more procedure
(stack (make-stack #t profile-signal-handler 0 1))
(inside-apply-trap? (sample-stack-procs stack)))
(if (not inside-apply-trap?)
(begin
;; disabling here is just a little more efficient, but
;; not necessary given inside-profiler?. We can't just
;; disable unconditionally at the top of this function
;; and eliminate inside-profiler? because it seems to
;; confuse guile wrt re-enabling the trap when
;; count-call finishes.
(if %count-calls? (trap-disable 'apply-frame))
(accumulate-time stop-time)))
(setitimer ITIMER_PROF
0 0
(car sampling-frequency)
(cdr sampling-frequency))
(if (not inside-apply-trap?)
(begin
(set! last-start-time (get-internal-run-time))
(if %count-calls? (trap-enable 'apply-frame))))))
(set! inside-profiler? #f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Count total calls.
(define (count-call trap-name continuation tail)
(if (not inside-profiler?)
(begin
(accumulate-time (get-internal-run-time))
(and=> (frame-procedure (last-stack-frame continuation))
(lambda (proc)
(if (procedure-name proc)
(inc-call-data-call-count!
(get-call-data proc)))))
(set! last-start-time (get-internal-run-time)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (statprof-active?)
"Returns @code{#t} if @code{statprof-start} has been called more times
than @code{statprof-stop}, @code{#f} otherwise."
(positive? profile-level))
;; Do not call this from statprof internal functions -- user only.
(define (statprof-start)
"Start the profiler.@code{}"
;; After some head-scratching, I don't *think* I need to mask/unmask
;; signals here, but if I'm wrong, please let me know.
(set! profile-level (+ profile-level 1))
(if (= profile-level 1)
(let* ((rpt remaining-prof-time)
(use-rpt? (and rpt
(or (positive? (car rpt))
(positive? (cdr rpt))))))
(set! remaining-prof-time #f)
(set! last-start-time (get-internal-run-time))
(set! gc-time-taken
(cdr (assq 'gc-time-taken (gc-stats))))
(if use-rpt?
(setitimer ITIMER_PROF 0 0 (car rpt) (cdr rpt))
(setitimer ITIMER_PROF
0 0
(car sampling-frequency)
(cdr sampling-frequency)))
(trap-enable 'apply-frame)
#t)))
;; Do not call this from statprof internal functions -- user only.
(define (statprof-stop)
"Stop the profiler.@code{}"
;; After some head-scratching, I don't *think* I need to mask/unmask
;; signals here, but if I'm wrong, please let me know.
(set! profile-level (- profile-level 1))
(if (zero? profile-level)
(begin
(set! gc-time-taken
(- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
(trap-disable 'apply-frame)
;; I believe that we need to do this before getting the time
;; (unless we want to make things even more complicated).
(set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0))
(accumulate-time (get-internal-run-time))
(set! last-start-time #f))))
(define (statprof-reset sample-seconds sample-microseconds count-calls?
. full-stacks?)
"Reset the statprof sampler interval to @var{sample-seconds} and
@var{sample-microseconds}. If @var{count-calls?} is true, arrange to
instrument procedure calls as well as collecting statistical profiling
data. If @var{full-stacks?} is true, collect all sampled stacks into a
list for later analysis.
Enables traps and debugging as necessary."
(if (positive? profile-level)
(error "Can't reset profiler while profiler is running."))
(set! %count-calls? count-calls?)
(set! accumulated-time 0)
(set! last-start-time #f)
(set! sample-count 0)
(set! sampling-frequency (cons sample-seconds sample-microseconds))
(set! remaining-prof-time #f)
(set! procedure-data (make-hash-table 131))
(if %count-calls?
(begin
(trap-set! apply-frame-handler count-call)
(trap-enable 'traps)))
(set! record-full-stacks? (and (pair? full-stacks?) (car full-stacks?)))
(set! stacks '())
(debug-enable 'debug)
(sigaction SIGPROF profile-signal-handler)
#t)
(define (statprof-fold-call-data proc init)
"Fold @var{proc} over the call-data accumulated by statprof. Cannot be
called while statprof is active. @var{proc} should take two arguments,
@code{(@var{call-data} @var{prior-result})}.
Note that a given proc-name may appear multiple times, but if it does,
it represents different functions with the same name."
(if (positive? profile-level)
(error "Can't call statprof-fold-called while profiler is running."))
(hash-fold
(lambda (key value prior-result)
(proc value prior-result))
init
procedure-data))
(define (statprof-proc-call-data proc)
"Returns the call-data associated with @var{proc}, or @code{#f} if
none is available."
(if (positive? profile-level)
(error "Can't call statprof-fold-called while profiler is running."))
(hashq-ref procedure-data proc))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stats
(define (statprof-call-data->stats call-data)
"Returns an object of type @code{statprof-stats}."
;; returns (vector proc-name
;; %-time-in-proc
;; cum-seconds-in-proc
;; self-seconds-in-proc
;; num-calls
;; self-secs-per-call
;; total-secs-per-call)
(let* ((proc-name (call-data-name call-data))
(self-samples (call-data-self-sample-count call-data))
(cum-samples (call-data-cum-sample-count call-data))
(all-samples (statprof-sample-count))
(secs-per-sample (/ (statprof-accumulated-time)
(statprof-sample-count)))
(num-calls (and %count-calls? (statprof-call-data-calls call-data))))
(vector proc-name
(* (/ self-samples all-samples) 100.0)
(* cum-samples secs-per-sample 1.0)
(* self-samples secs-per-sample 1.0)
num-calls
(and num-calls ;; maybe we only sampled in children
(if (zero? self-samples) 0.0
(/ (* self-samples secs-per-sample) 1.0 num-calls)))
(and num-calls ;; cum-samples must be positive
(/ (* cum-samples secs-per-sample) 1.0 num-calls)))))
(define (statprof-stats-proc-name stats) (vector-ref stats 0))
(define (statprof-stats-%-time-in-proc stats) (vector-ref stats 1))
(define (statprof-stats-cum-secs-in-proc stats) (vector-ref stats 2))
(define (statprof-stats-self-secs-in-proc stats) (vector-ref stats 3))
(define (statprof-stats-calls stats) (vector-ref stats 4))
(define (statprof-stats-self-secs-per-call stats) (vector-ref stats 5))
(define (statprof-stats-cum-secs-per-call stats) (vector-ref stats 6))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (stats-sorter x y)
(let ((diff (- (statprof-stats-self-secs-in-proc x)
(statprof-stats-self-secs-in-proc y))))
(positive?
(if (= diff 0)
(- (statprof-stats-cum-secs-in-proc x)
(statprof-stats-cum-secs-in-proc y))
diff))))
(define (statprof-display . port)
"Displays a gprof-like summary of the statistics collected. Unless an
optional @var{port} argument is passed, uses the current output port."
(if (null? port) (set! port (current-output-port)))
(cond
((zero? (statprof-sample-count))
(format port "No samples recorded.\n"))
(else
(let* ((stats-list (statprof-fold-call-data
(lambda (data prior-value)
(cons (statprof-call-data->stats data)
prior-value))
'()))
(sorted-stats (sort stats-list stats-sorter)))
(define (display-stats-line stats)
(if %count-calls?
(format port "~6,2f ~9,2f ~9,2f ~8r ~8,2f ~8,2f "
(statprof-stats-%-time-in-proc stats)
(statprof-stats-cum-secs-in-proc stats)
(statprof-stats-self-secs-in-proc stats)
(statprof-stats-calls stats)
(* 1000 (statprof-stats-self-secs-per-call stats))
(* 1000 (statprof-stats-cum-secs-per-call stats)))
(format port "~6,2f ~9,2f ~9,2f "
(statprof-stats-%-time-in-proc stats)
(statprof-stats-cum-secs-in-proc stats)
(statprof-stats-self-secs-in-proc stats)))
(display (statprof-stats-proc-name stats) port)
(newline port))
(if %count-calls?
(begin
(format port "~5a ~10a ~7a ~8a ~8a ~8a ~8@a\n"
"% " "cumulative" "self" "" "self" "total" "")
(format port "~5a ~9a ~8a ~8a ~8a ~8a ~8@a\n"
"time" "seconds" "seconds" "calls" "ms/call" "ms/call" "name"))
(begin
(format port "~5a ~10a ~7a ~8@a\n"
"%" "cumulative" "self" "")
(format port "~5a ~10a ~7a ~8@a\n"
"time" "seconds" "seconds" "name")))
(for-each display-stats-line sorted-stats)
(display "---\n" port)
(simple-format #t "Sample count: ~A\n" (statprof-sample-count))
(simple-format #t "Total time: ~A seconds (~A seconds in GC)\n"
(statprof-accumulated-time)
(/ gc-time-taken internal-time-units-per-second))))))
(define (statprof-display-anomolies)
"A sanity check that attempts to detect anomolies in statprof's
statistics.@code{}"
(statprof-fold-call-data
(lambda (data prior-value)
(if (and %count-calls?
(zero? (call-data-call-count data))
(positive? (call-data-sample-count data)))
(simple-format #t
"==[~A ~A ~A]\n"
(call-data-name data)
(call-data-call-count data)
(call-data-sample-count data))))
#f)
(simple-format #t "Total time: ~A\n" (statprof-accumulated-time))
(simple-format #t "Sample count: ~A\n" (statprof-sample-count)))
(define (statprof-accumulated-time)
"Returns the time accumulated during the last statprof run.@code{}"
(if (positive? profile-level)
(error "Can't get accumulated time while profiler is running."))
(/ accumulated-time internal-time-units-per-second))
(define (statprof-sample-count)
"Returns the number of samples taken during the last statprof run.@code{}"
(if (positive? profile-level)
(error "Can't get accumulated time while profiler is running."))
sample-count)
(define statprof-call-data-name call-data-name)
(define statprof-call-data-calls call-data-call-count)
(define statprof-call-data-cum-samples call-data-cum-sample-count)
(define statprof-call-data-self-samples call-data-self-sample-count)
(define (statprof-fetch-stacks)
"Returns a list of stacks, as they were captured since the last call
to @code{statprof-reset}.
Note that stacks are only collected if the @var{full-stacks?} argument
to @code{statprof-reset} is true."
stacks)
(define procedure=?
(if (false-if-exception (resolve-interface '(system base compile)))
(lambda (a b)
(cond
((eq? a b))
((and ((@ (system vm program) program?) a)
((@ (system vm program) program?) b))
(eq? ((@ (system vm program) program-objcode) a)
((@ (system vm program) program-objcode) b)))
((and (closure? a) (closure? b)
(procedure-source a) (procedure-source b))
(and (eq? (procedure-name a) (procedure-name b))
(equal? (procedure-source a) (procedure-source b))))
(else
#f)))
(lambda (a b)
(cond
((eq? a b))
((and (closure? a) (closure? b)
(procedure-source a) (procedure-source b))
(and (eq? (procedure-name a) (procedure-name b))
(equal? (procedure-source a) (procedure-source b))))
(else
#f)))))
;; tree ::= (car n . tree*)
(define (lists->trees lists equal?)
(let lp ((in lists) (n-terminal 0) (tails '()))
(cond
((null? in)
(let ((trees (map (lambda (tail)
(cons (car tail)
(lists->trees (cdr tail) equal?)))
tails)))
(cons (apply + n-terminal (map cadr trees))
(sort trees
(lambda (a b) (> (cadr a) (cadr b)))))))
((null? (car in))
(lp (cdr in) (1+ n-terminal) tails))
((find (lambda (x) (equal? (car x) (caar in)))
tails)
=> (lambda (tail)
(lp (cdr in)
n-terminal
(assq-set! tails
(car tail)
(cons (cdar in) (cdr tail))))))
(else
(lp (cdr in)
n-terminal
(acons (caar in) (list (cdar in)) tails))))))
(define (stack->procedures stack)
(filter identity
(unfold-right (lambda (x) (not x))
frame-procedure
frame-previous
(stack-ref stack 0))))
(define (statprof-fetch-call-tree)
"Return a call tree for the previous statprof run.
The return value is a list of nodes, each of which is of the type:
@code
node ::= (@var{proc} @var{count} . @var{nodes})
@end code"
(cons #t (lists->trees (map stack->procedures stacks) procedure=?)))
(define-macro (with-statprof . args)
"Profiles the expressions in its body.
Keyword arguments:
@table @code
@item #:loop
Execute the body @var{loop} number of times, or @code{#f} for no looping
default: @code{#f}
@item #:hz
Sampling rate
default: @code{20}
@item #:count-calls?
Whether to instrument each function call (expensive)
default: @code{#f}
@item #:full-stacks?
Whether to collect away all sampled stacks into a list
default: @code{#f}
@end table"
(define (kw-arg-ref kw args def)
(cond
((null? args) (error "Invalid macro body"))
((keyword? (car args))
(if (eq? (car args) kw)
(cadr args)
(kw-arg-ref kw (cddr args) def)))
((eq? kw #f def) ;; asking for the body
args)
(else def))) ;; kw not found
(let ((loop (kw-arg-ref #:loop args #f))
(hz (kw-arg-ref #:hz args 20))
(count-calls? (kw-arg-ref #:count-calls? args #f))
(full-stacks? (kw-arg-ref #:full-stacks? args #f))
(body (kw-arg-ref #f args #f)))
`(dynamic-wind
(lambda ()
(statprof-reset (inexact->exact (floor (/ 1 ,hz)))
(inexact->exact (* 1e6 (- (/ 1 ,hz)
(floor (/ 1 ,hz)))))
,count-calls?
,full-stacks?)
(statprof-start))
(lambda ()
,(if loop
(let ((lp (gensym "statprof ")) (x (gensym)))
`(let ,lp ((,x ,loop))
(if (not (zero? ,x))
(begin ,@body (,lp (1- ,x))))))
`(begin ,@body)))
(lambda ()
(statprof-stop)
(statprof-display)
(set! (@@ (statprof) procedure-data) #f)))))
;;; arch-tag: 83969178-b576-4c52-a31c-6a9c2be85d10

102
module/sxml/apply-templates.scm Normal file
View file

@ -0,0 +1,102 @@
;;;; (sxml apply-templates) -- xslt-like transformation for sxml
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Copyright 2004 by Andy Wingo <wingo at pobox dot com>.
;;;; Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as apply-templates.scm.
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;; Pre-order traversal of a tree and creation of a new tree:
;;
;;@smallexample
;; apply-templates:: tree x <templates> -> <new-tree>
;;@end smallexample
;; where
;;@smallexample
;; <templates> ::= (<template> ...)
;; <template> ::= (<node-test> <node-test> ... <node-test> . <handler>)
;; <node-test> ::= an argument to node-typeof? above
;; <handler> ::= <tree> -> <new-tree>
;;@end smallexample
;;
;; This procedure does a @emph{normal}, pre-order traversal of an SXML
;; tree. It walks the tree, checking at each node against the list of
;; matching templates.
;;
;; If the match is found (which must be unique, i.e., unambiguous), the
;; corresponding handler is invoked and given the current node as an
;; argument. The result from the handler, which must be a @code{<tree>},
;; takes place of the current node in the resulting tree.
;;
;; The name of the function is not accidental: it resembles rather
;; closely an @code{apply-templates} function of XSLT.
;;
;;; Code:
(define-module (sxml apply-templates)
#:use-module (sxml ssax)
#:use-module ((sxml xpath) :hide (filter))
#:export (apply-templates))
(define (apply-templates tree templates)
; Filter the list of templates. If a template does not
; contradict the given node (that is, its head matches
; the type of the node), chop off the head and keep the
; rest as the result. All contradicting templates are removed.
(define (filter-templates node templates)
(cond
((null? templates) templates)
((not (pair? (car templates))) ; A good template must be a list
(filter-templates node (cdr templates)))
(((node-typeof? (caar templates)) node)
(cons (cdar templates) (filter-templates node (cdr templates))))
(else
(filter-templates node (cdr templates)))))
; Here <templates> ::= [<template> | <handler>]
; If there is a <handler> in the above list, it must
; be only one. If found, return it; otherwise, return #f
(define (find-handler templates)
(and (pair? templates)
(cond
((procedure? (car templates))
(if (find-handler (cdr templates))
(error "ambiguous template match"))
(car templates))
(else (find-handler (cdr templates))))))
(let loop ((tree tree) (active-templates '()))
;(cout "active-templates: " active-templates nl "tree: " tree nl)
(if (nodeset? tree)
(map-union (lambda (a-tree) (loop a-tree active-templates)) tree)
(let ((still-active-templates
(append
(filter-templates tree active-templates)
(filter-templates tree templates))))
(cond
;((null? still-active-templates) '())
((find-handler still-active-templates) =>
(lambda (handler) (handler tree)))
((not (pair? tree)) '())
(else
(loop (cdr tree) still-active-templates)))))))
;;; arch-tag: 88cd87de-8825-4ab3-9721-cf99694fb787
;;; templates.scm ends here

259
module/sxml/fold.scm Normal file
View file

@ -0,0 +1,259 @@
;;;; (sxml fold) -- transformation of sxml via fold operations
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Written 2007 by Andy Wingo <wingo at pobox dot com>.
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;; @code{(sxml fold)} defines a number of variants of the @dfn{fold}
;; algorithm for use in transforming SXML trees. Additionally it defines
;; the layout operator, @code{fold-layout}, which might be described as
;; a context-passing variant of SSAX's @code{pre-post-order}.
;;
;;; Code:
(define-module (sxml fold)
#:export (foldt
fold
foldts
foldts*
fold-values
foldts*-values
fold-layout))
(define (atom? x)
(not (pair? x)))
(define (foldt fup fhere tree)
"The standard multithreaded tree fold.
@var{fup} is of type [a] -> a. @var{fhere} is of type object -> a.
"
(if (atom? tree)
(fhere tree)
(fup (map (lambda (kid)
(foldt fup fhere kid))
tree))))
(define (fold proc seed list)
"The standard list fold.
@var{proc} is of type a -> b -> b. @var{seed} is of type b. @var{list}
is of type [a]."
(if (null? list)
seed
(fold proc (proc (car list) seed) (cdr list))))
(define (foldts fdown fup fhere seed tree)
"The single-threaded tree fold originally defined in SSAX.
@xref{sxml ssax,,(sxml ssax)}, for more information."
(if (atom? tree)
(fhere seed tree)
(fup seed
(fold (lambda (kid kseed)
(foldts fdown fup fhere kseed kid))
(fdown seed tree)
tree)
tree)))
(define (foldts* fdown fup fhere seed tree)
"A variant of @ref{sxml fold foldts,,foldts} that allows pre-order
tree rewrites. Originally defined in Andy Wingo's 2007 paper,
@emph{Applications of fold to XML transformation}."
(if (atom? tree)
(fhere seed tree)
(call-with-values
(lambda () (fdown seed tree))
(lambda (kseed tree)
(fup seed
(fold (lambda (kid kseed)
(foldts* fdown fup fhere
kseed kid))
kseed
tree)
tree)))))
(define (fold-values proc list . seeds)
"A variant of @ref{sxml fold fold,,fold} that allows multi-valued
seeds. Note that the order of the arguments differs from that of
@code{fold}."
(if (null? list)
(apply values seeds)
(call-with-values
(lambda () (apply proc (car list) seeds))
(lambda seeds
(apply fold-values proc (cdr list) seeds)))))
(define (foldts*-values fdown fup fhere tree . seeds)
"A variant of @ref{sxml fold foldts*,,foldts*} that allows
multi-valued seeds. Originally defined in Andy Wingo's 2007 paper,
@emph{Applications of fold to XML transformation}."
(if (atom? tree)
(apply fhere tree seeds)
(call-with-values
(lambda () (apply fdown tree seeds))
(lambda (tree . kseeds)
(call-with-values
(lambda ()
(apply fold-values
(lambda (tree . seeds)
(apply foldts*-values
fdown fup fhere tree seeds))
tree kseeds))
(lambda kseeds
(apply fup tree (append seeds kseeds))))))))
(define (assq-ref alist key default)
(cond ((assq key alist) => cdr)
(else default)))
(define (fold-layout tree bindings params layout stylesheet)
"A traversal combinator in the spirit of SSAX's @ref{sxml transform
pre-post-order,,pre-post-order}.
@code{fold-layout} was originally presented in Andy Wingo's 2007 paper,
@emph{Applications of fold to XML transformation}.
@example
bindings := (<binding>...)
binding := (<tag> <bandler-pair>...)
| (*default* . <post-handler>)
| (*text* . <text-handler>)
tag := <symbol>
handler-pair := (pre-layout . <pre-layout-handler>)
| (post . <post-handler>)
| (bindings . <bindings>)
| (pre . <pre-handler>)
| (macro . <macro-handler>)
@end example
@table @var
@item pre-layout-handler
A function of three arguments:
@table @var
@item kids
the kids of the current node, before traversal
@item params
the params of the current node
@item layout
the layout coming into this node
@end table
@var{pre-layout-handler} is expected to use this information to return a
layout to pass to the kids. The default implementation returns the
layout given in the arguments.
@item post-handler
A function of five arguments:
@table @var
@item tag
the current tag being processed
@item params
the params of the current node
@item layout
the layout coming into the current node, before any kids were processed
@item klayout
the layout after processing all of the children
@item kids
the already-processed child nodes
@end table
@var{post-handler} should return two values, the layout to pass to the
next node and the final tree.
@item text-handler
@var{text-handler} is a function of three arguments:
@table @var
@item text
the string
@item params
the current params
@item layout
the current layout
@end table
@var{text-handler} should return two values, the layout to pass to the
next node and the value to which the string should transform.
@end table
"
(define (err . args)
(error "no binding available" args))
(define (fdown tree bindings pcont params layout ret)
(define (fdown-helper new-bindings new-layout cont)
(let ((cont-with-tag (lambda args
(apply cont (car tree) args)))
(bindings (if new-bindings
(append new-bindings bindings)
bindings))
(style-params (assq-ref stylesheet (car tree) '())))
(cond
((null? (cdr tree))
(values
'() bindings cont-with-tag (cons style-params params) new-layout '()))
((and (pair? (cadr tree)) (eq? (caadr tree) '@))
(let ((params (cons (append (cdadr tree) style-params) params)))
(values
(cddr tree) bindings cont-with-tag params new-layout '())))
(else
(values
(cdr tree) bindings cont-with-tag (cons style-params params) new-layout '())))))
(define (no-bindings)
(fdown-helper #f layout (assq-ref bindings '*default* err)))
(define (macro macro-handler)
(fdown (apply macro-handler tree)
bindings pcont params layout ret))
(define (pre pre-handler)
(values '() bindings
(lambda (params layout old-layout kids)
(values layout (reverse kids)))
params layout (apply pre-handler tree)))
(define (have-bindings tag-bindings)
(fdown-helper
(assq-ref tag-bindings 'bindings #f)
((assq-ref tag-bindings 'pre-layout
(lambda (tag params layout)
layout))
tree params layout)
(assq-ref tag-bindings 'post
(assq-ref bindings '*default* err))))
(let ((tag-bindings (assq-ref bindings (car tree) #f)))
(cond
((not tag-bindings) (no-bindings))
((assq-ref tag-bindings 'macro #f) => macro)
((assq-ref tag-bindings 'pre #f) => pre)
(else (have-bindings tag-bindings)))))
(define (fup tree bindings cont params layout ret
kbindings kcont kparams klayout kret)
(call-with-values
(lambda ()
(kcont kparams layout klayout (reverse kret)))
(lambda (klayout kret)
(values bindings cont params klayout (cons kret ret)))))
(define (fhere tree bindings cont params layout ret)
(call-with-values
(lambda ()
((assq-ref bindings '*text* err) tree params layout))
(lambda (tlayout tret)
(values bindings cont params tlayout (cons tret ret)))))
(call-with-values
(lambda ()
(foldts*-values
fdown fup fhere tree bindings #f (cons params '()) layout '()))
(lambda (bindings cont params layout ret)
(values (car ret) layout))))

169
module/sxml/simple.scm Normal file
View file

@ -0,0 +1,169 @@
;;;; (sxml simple) -- a simple interface to the SSAX parser
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
;;;; Originally written by Oleg Kiselyov <oleg at pobox dot com> as SXML-to-HTML.scm.
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;;A simple interface to XML parsing and serialization.
;;
;;; Code:
(define-module (sxml simple)
#:use-module (sxml ssax)
#:use-module (sxml transform)
#:use-module (ice-9 optargs)
#:use-module (srfi srfi-13)
#:export (xml->sxml sxml->xml sxml->string universal-sxslt-rules))
(define* (xml->sxml #:optional (port (current-input-port)))
"Use SSAX to parse an XML document into SXML. Takes one optional
argument, @var{port}, which defaults to the current input port."
(ssax:xml->sxml port '()))
;; Universal transformation rules. Works for all XML.
(define universal-sxslt-rules
#;
"A set of @code{pre-post-order} rules that transform any SXML tree
into a form suitable for XML serialization by @code{(sxml transform)}'s
@code{SRV:send-reply}. Used internally by @code{sxml->xml}."
`((@
((*default* . ,(lambda (attr-key . value) ((enattr attr-key) value))))
. ,(lambda (trigger . value) (list '@ value)))
(*ENTITY* . ,(lambda (tag name) (list "&" name ";")))
(*PI* . ,(lambda (pi tag str) (list "<?" tag " " str "?>")))
;; Is this right for entities? I don't have a reference for
;; public-id/system-id at the moment...
(*default* . ,(lambda (tag . elems) (apply (entag tag) elems)))
(*text* . ,(lambda (trigger str)
(if (string? str) (string->escaped-xml str) str)))))
(define* (sxml->xml tree #:optional (port (current-output-port)))
"Serialize the sxml tree @var{tree} as XML. The output will be written
to the current output port, unless the optional argument @var{port} is
present."
(with-output-to-port port
(lambda ()
(SRV:send-reply
(post-order
tree
universal-sxslt-rules)))))
(define (sxml->string sxml)
"Detag an sxml tree @var{sxml} into a string. Does not perform any
formatting."
(string-concatenate-reverse
(foldts
(lambda (seed tree) ; fdown
'())
(lambda (seed kid-seed tree) ; fup
(append! kid-seed seed))
(lambda (seed tree) ; fhere
(if (string? tree) (cons tree seed) seed))
'()
sxml)))
;; The following two functions serialize tags and attributes. They are
;; being used in the node handlers for the post-order function, see
;; above.
(define (check-name name)
(let* ((str (symbol->string name))
(i (string-index str #\:))
(head (or (and i (substring str 0 i)) str))
(tail (and i (substring str (1+ i)))))
(and i (string-index (substring str (1+ i)) #\:)
(error "Invalid QName: more than one colon" name))
(for-each
(lambda (s)
(and s
(or (char-alphabetic? (string-ref s 0))
(eq? (string-ref s 0) #\_)
(error "Invalid name starting character" s name))
(string-for-each
(lambda (c)
(or (char-alphabetic? c) (string-index "0123456789.-_" c)
(error "Invalid name character" c s name)))
s)))
(list head tail))))
(define (entag tag)
(check-name tag)
(lambda elems
(if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
(list #\< tag (cdar elems)
(if (pair? (cdr elems))
(list #\> (cdr elems) "</" tag #\>)
" />"))
(list #\< tag
(if (pair? elems)
(list #\> elems "</" tag #\>)
" />")))))
(define (enattr attr-key)
(check-name attr-key)
(let ((attr-str (symbol->string attr-key)))
(lambda (value)
(list #\space attr-str
"=\"" (and (not (null? value)) value) #\"))))
(define (make-char-quotator char-encoding)
(let ((bad-chars (map car char-encoding)))
;; Check to see if str contains one of the characters in charset,
;; from the position i onward. If so, return that character's index.
;; otherwise, return #f
(define (index-cset str i charset)
(let loop ((i i))
(and (< i (string-length str))
(if (memv (string-ref str i) charset) i
(loop (+ 1 i))))))
;; The body of the function
(lambda (str)
(let ((bad-pos (index-cset str 0 bad-chars)))
(if (not bad-pos) str ; str had all good chars
(string-concatenate-reverse
(let loop ((from 0) (to bad-pos) (out '()))
(cond
((>= from (string-length str)) out)
((not to)
(cons (substring str from (string-length str)) out))
(else
(let ((quoted-char
(cdr (assv (string-ref str to) char-encoding)))
(new-to
(index-cset str (+ 1 to) bad-chars)))
(loop (1+ to) new-to
(if (< from to)
(cons* quoted-char (substring str from to) out)
(cons quoted-char out)))))))))))))
;; Given a string, check to make sure it does not contain characters
;; such as '<' or '&' that require encoding. Return either the original
;; string, or a list of string fragments with special characters
;; replaced by appropriate character entities.
(define string->escaped-xml
(make-char-quotator
'((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;"))))
;;; arch-tag: 9c853b25-d82f-42ef-a959-ae26fdc7d1ac
;;; simple.scm ends here

246
module/sxml/ssax.scm Normal file
View file

@ -0,0 +1,246 @@
;;;; (sxml ssax) -- the SSAX parser
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
;;;; Written 2001,2002,2003,2004 by Oleg Kiselyov <oleg at pobox dot com> as SSAX.scm.
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;@subheading Functional XML parsing framework
;@subsubheading SAX/DOM and SXML parsers with support for XML Namespaces and validation
;
; This is a package of low-to-high level lexing and parsing procedures
; that can be combined to yield a SAX, a DOM, a validating parser, or
; a parser intended for a particular document type. The procedures in
; the package can be used separately to tokenize or parse various
; pieces of XML documents. The package supports XML Namespaces,
; internal and external parsed entities, user-controlled handling of
; whitespace, and validation. This module therefore is intended to be
; a framework, a set of "Lego blocks" you can use to build a parser
; following any discipline and performing validation to any degree. As
; an example of the parser construction, this file includes a
; semi-validating SXML parser.
; The present XML framework has a "sequential" feel of SAX yet a
; "functional style" of DOM. Like a SAX parser, the framework scans the
; document only once and permits incremental processing. An application
; that handles document elements in order can run as efficiently as
; possible. @emph{Unlike} a SAX parser, the framework does not require
; an application register stateful callbacks and surrender control to
; the parser. Rather, it is the application that can drive the framework
; -- calling its functions to get the current lexical or syntax element.
; These functions do not maintain or mutate any state save the input
; port. Therefore, the framework permits parsing of XML in a pure
; functional style, with the input port being a monad (or a linear,
; read-once parameter).
; Besides the @var{port}, there is another monad -- @var{seed}. Most of
; the middle- and high-level parsers are single-threaded through the
; @var{seed}. The functions of this framework do not process or affect
; the @var{seed} in any way: they simply pass it around as an instance
; of an opaque datatype. User functions, on the other hand, can use the
; seed to maintain user's state, to accumulate parsing results, etc. A
; user can freely mix his own functions with those of the framework. On
; the other hand, the user may wish to instantiate a high-level parser:
; @code{SSAX:make-elem-parser} or @code{SSAX:make-parser}. In the latter
; case, the user must provide functions of specific signatures, which
; are called at predictable moments during the parsing: to handle
; character data, element data, or processing instructions (PI). The
; functions are always given the @var{seed}, among other parameters, and
; must return the new @var{seed}.
; From a functional point of view, XML parsing is a combined
; pre-post-order traversal of a "tree" that is the XML document
; itself. This down-and-up traversal tells the user about an element
; when its start tag is encountered. The user is notified about the
; element once more, after all element's children have been
; handled. The process of XML parsing therefore is a fold over the
; raw XML document. Unlike a fold over trees defined in [1], the
; parser is necessarily single-threaded -- obviously as elements
; in a text XML document are laid down sequentially. The parser
; therefore is a tree fold that has been transformed to accept an
; accumulating parameter [1,2].
; Formally, the denotational semantics of the parser can be expressed
; as
;@smallexample
; parser:: (Start-tag -> Seed -> Seed) ->
; (Start-tag -> Seed -> Seed -> Seed) ->
; (Char-Data -> Seed -> Seed) ->
; XML-text-fragment -> Seed -> Seed
; parser fdown fup fchar "<elem attrs> content </elem>" seed
; = fup "<elem attrs>" seed
; (parser fdown fup fchar "content" (fdown "<elem attrs>" seed))
;
; parser fdown fup fchar "char-data content" seed
; = parser fdown fup fchar "content" (fchar "char-data" seed)
;
; parser fdown fup fchar "elem-content content" seed
; = parser fdown fup fchar "content" (
; parser fdown fup fchar "elem-content" seed)
;@end smallexample
; Compare the last two equations with the left fold
;@smallexample
; fold-left kons elem:list seed = fold-left kons list (kons elem seed)
;@end smallexample
; The real parser created by @code{SSAX:make-parser} is slightly more
; complicated, to account for processing instructions, entity
; references, namespaces, processing of document type declaration, etc.
; The XML standard document referred to in this module is
; @uref{http://www.w3.org/TR/1998/REC-xml-19980210.html}
;
; The present file also defines a procedure that parses the text of an
; XML document or of a separate element into SXML, an S-expression-based
; model of an XML Information Set. SXML is also an Abstract Syntax Tree
; of an XML document. SXML is similar but not identical to DOM; SXML is
; particularly suitable for Scheme-based XML/HTML authoring, SXPath
; queries, and tree transformations. See SXML.html for more details.
; SXML is a term implementation of evaluation of the XML document [3].
; The other implementation is context-passing.
; The present frameworks fully supports the XML Namespaces Recommendation:
; @uref{http://www.w3.org/TR/REC-xml-names/}
; Other links:
;@table @asis
;@item [1]
; Jeremy Gibbons, Geraint Jones, "The Under-appreciated Unfold,"
; Proc. ICFP'98, 1998, pp. 273-279.
;@item [2]
; Richard S. Bird, The promotion and accumulation strategies in
; transformational programming, ACM Trans. Progr. Lang. Systems,
; 6(4):487-504, October 1984.
;@item [3]
; Ralf Hinze, "Deriving Backtracking Monad Transformers,"
; Functional Pearl. Proc ICFP'00, pp. 186-197.
;@end table
;;
;;; Code:
(define-module (sxml ssax)
#:use-module (sxml ssax input-parse)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:export (current-ssax-error-port
with-ssax-error-to-port
xml-token? xml-token-kind xml-token-head
make-empty-attlist attlist-add
attlist-null?
attlist-remove-top
attlist->alist attlist-fold
ssax:uri-string->symbol
ssax:skip-internal-dtd
ssax:read-pi-body-as-string
ssax:reverse-collect-str-drop-ws
ssax:read-markup-token
ssax:read-cdata-body
ssax:read-char-ref
ssax:read-attributes
ssax:complete-start-tag
ssax:read-external-id
ssax:read-char-data
ssax:xml->sxml
ssax:make-parser
ssax:make-pi-parser
ssax:make-elem-parser))
(define (parser-error port message . rest)
(apply throw 'parser-error port message rest))
(define ascii->char integer->char)
(define char->ascii char->integer)
(define *current-ssax-error-port* (make-fluid))
(define (current-ssax-error-port)
(fluid-ref *current-ssax-error-port*))
(define (with-ssax-error-to-port port thunk)
(with-fluids ((*current-ssax-error-port* port))
(thunk)))
(define (ssax:warn port msg . args)
(format (current-ssax-error-port)
";;; SSAX warning: ~a ~a\n" msg args))
(define (ucscode->string codepoint)
(string (integer->char codepoint)))
(define char-newline #\newline)
(define char-return #\return)
(define char-tab #\tab)
(define nl "\n")
;; if condition is true, execute stmts in turn and return the result of
;; the last statement otherwise, return #f
(define-syntax when
(syntax-rules ()
((when condition . stmts)
(and condition (begin . stmts)))))
;; Execute a sequence of forms and return the result of the _first_ one.
;; Like PROG1 in Lisp. Typically used to evaluate one or more forms with
;; side effects and return a value that must be computed before some or
;; all of the side effects happen.
(define-syntax begin0
(syntax-rules ()
((begin0 form form1 ... )
(let ((val form)) form1 ... val))))
; Like let* but allowing for multiple-value bindings
(define-syntax let*-values
(syntax-rules ()
((let*-values () . bodies) (begin . bodies))
((let*-values (((var) initializer) . rest) . bodies)
(let ((var initializer)) ; a single var optimization
(let*-values rest . bodies)))
((let*-values ((vars initializer) . rest) . bodies)
(call-with-values (lambda () initializer) ; the most generic case
(lambda vars (let*-values rest . bodies))))))
;; needed for some dumb reason
(define inc 1+)
(define dec 1-)
(define-syntax include-from-path/filtered
(lambda (x)
(define (read-filtered accept-list file)
(with-input-from-file (%search-load-path file)
(lambda ()
(let loop ((sexp (read)) (out '()))
(cond
((eof-object? sexp) (reverse out))
((and (pair? sexp) (memq (car sexp) accept-list))
(loop (read) (cons sexp out)))
(else
(loop (read) out)))))))
(syntax-case x ()
((_ accept-list file)
(with-syntax (((exp ...) (datum->syntax
x
(read-filtered
(syntax->datum #'accept-list)
(syntax->datum #'file)))))
#'(begin exp ...))))))
(include-from-path "sxml/upstream/assert.scm")
(include-from-path/filtered
(define define-syntax ssax:define-labeled-arg-macro)
"sxml/upstream/SSAX.scm")

180
module/sxml/ssax/input-parse.scm Normal file
View file

@ -0,0 +1,180 @@
;;;; (sxml ssax input-parse) -- a simple lexer
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
;;;; Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as input-parse.scm.
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;; A simple lexer.
;;
;; The procedures in this module surprisingly often suffice to parse an
;; input stream. They either skip, or build and return tokens, according
;; to inclusion or delimiting semantics. The list of characters to
;; expect, include, or to break at may vary from one invocation of a
;; function to another. This allows the functions to easily parse even
;; context-sensitive languages.
;;
;; EOF is generally frowned on, and thrown up upon if encountered.
;; Exceptions are mentioned specifically. The list of expected
;; characters (characters to skip until, or break-characters) may
;; include an EOF "character", which is to be coded as the symbol,
;; @code{*eof*}.
;;
;; The input stream to parse is specified as a @dfn{port}, which is
;; usually the last (and optional) argument. It defaults to the current
;; input port if omitted.
;;
;; If the parser encounters an error, it will throw an exception to the
;; key @code{parser-error}. The arguments will be of the form
;; @code{(@var{port} @var{message} @var{specialising-msg}*)}.
;;
;; The first argument is a port, which typically points to the offending
;; character or its neighborhood. You can then use @code{port-column}
;; and @code{port-line} to query the current position. @var{message} is
;; the description of the error. Other arguments supply more details
;; about the problem.
;;
;;; Code:
(define-module (sxml ssax input-parse)
#:use-module (ice-9 rdelim)
#:export (peek-next-char
assert-curr-char
skip-until
skip-while
next-token
next-token-of
read-text-line
read-string
find-string-from-port?))
(define ascii->char integer->char)
(define char->ascii char->integer)
(define char-newline #\newline)
(define char-return #\return)
(define inc 1+)
(define dec 1-)
;; rewrite oleg's define-opt into define* style
(define-macro (define-opt bindings body . body-rest)
(let* ((rev-bindings (reverse bindings))
(opt-bindings
(and (pair? rev-bindings) (pair? (car rev-bindings))
(eq? 'optional (caar rev-bindings))
(cdar rev-bindings))))
(if opt-bindings
`(define* ,(append (reverse (cons #:optional (cdr rev-bindings)))
opt-bindings)
,body ,@body-rest)
`(define* ,bindings ,body ,@body-rest))))
(define (parser-error port message . rest)
(apply throw 'parser-error port message rest))
(include-from-path "sxml/upstream/input-parse.scm")
;; This version for guile is quite speedy, due to read-delimited (which
;; is implemented in C).
(define-opt (next-token prefix-skipped-chars break-chars
(optional (comment "") (port (current-input-port))) )
(let ((delims (list->string (delete '*eof* break-chars))))
(if (eof-object? (if (null? prefix-skipped-chars)
(peek-char port)
(skip-while prefix-skipped-chars port)))
(if (memq '*eof* break-chars)
""
(parser-error port "EOF while reading a token " comment))
(let ((token (read-delimited delims port 'peek)))
(if (and (eof-object? (peek-char port))
(not (memq '*eof* break-chars)))
(parser-error port "EOF while reading a token " comment)
token)))))
(define-opt (read-text-line (optional (port (current-input-port))) )
(read-line port))
;; Written 1995, 1996 by Oleg Kiselyov (oleg@acm.org)
;; Modified 1996, 1997, 1998, 2001 by A. Jaffer (agj@alum.mit.edu)
;; Modified 2003 by Steve VanDevender (stevev@hexadecimal.uoregon.edu)
;; Modified 2004 Andy Wingo <wingo at pobox dot com>
;; This function is from SLIB's strsrch.scm, and is in the public domain.
(define (find-string-from-port? str <input-port> . max-no-char)
"Looks for @var{str} in @var{<input-port>}, optionally within the
first @var{max-no-char} characters."
(set! max-no-char (if (null? max-no-char) #f (car max-no-char)))
(letrec
((no-chars-read 0)
(peeked? #f)
(my-peek-char ; Return a peeked char or #f
(lambda () (and (or (not (number? max-no-char))
(< no-chars-read max-no-char))
(let ((c (peek-char <input-port>)))
(cond (peeked? c)
((eof-object? c) #f)
((procedure? max-no-char)
(set! peeked? #t)
(if (max-no-char c) #f c))
((eqv? max-no-char c) #f)
(else c))))))
(next-char (lambda () (set! peeked? #f) (read-char <input-port>)
(set! no-chars-read (+ 1 no-chars-read))))
(match-1st-char ; of the string str
(lambda ()
(let ((c (my-peek-char)))
(and c
(begin (next-char)
(if (char=? c (string-ref str 0))
(match-other-chars 1)
(match-1st-char)))))))
;; There has been a partial match, up to the point pos-to-match
;; (for example, str[0] has been found in the stream)
;; Now look to see if str[pos-to-match] for would be found, too
(match-other-chars
(lambda (pos-to-match)
(if (>= pos-to-match (string-length str))
no-chars-read ; the entire string has matched
(let ((c (my-peek-char)))
(and c
(if (not (char=? c (string-ref str pos-to-match)))
(backtrack 1 pos-to-match)
(begin (next-char)
(match-other-chars (+ 1 pos-to-match)))))))))
;; There had been a partial match, but then a wrong char showed up.
;; Before discarding previously read (and matched) characters, we check
;; to see if there was some smaller partial match. Note, characters read
;; so far (which matter) are those of str[0..matched-substr-len - 1]
;; In other words, we will check to see if there is such i>0 that
;; substr(str,0,j) = substr(str,i,matched-substr-len)
;; where j=matched-substr-len - i
(backtrack
(lambda (i matched-substr-len)
(let ((j (- matched-substr-len i)))
(if (<= j 0)
;; backed off completely to the begining of str
(match-1st-char)
(let loop ((k 0))
(if (>= k j)
(match-other-chars j) ; there was indeed a shorter match
(if (char=? (string-ref str k)
(string-ref str (+ i k)))
(loop (+ 1 k))
(backtrack (+ 1 i) matched-substr-len))))))))
)
(match-1st-char)))

298
module/sxml/transform.scm Normal file
View file

@ -0,0 +1,298 @@
;;;; (sxml transform) -- pre- and post-order sxml transformation
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
;;;; Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as SXML-tree-trans.scm.
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;;@heading SXML expression tree transformers
;
;@subheading Pre-Post-order traversal of a tree and creation of a new tree
;@smallexample
;pre-post-order:: <tree> x <bindings> -> <new-tree>
;@end smallexample
; where
;@smallexample
; <bindings> ::= (<binding> ...)
; <binding> ::= (<trigger-symbol> *preorder* . <handler>) |
; (<trigger-symbol> *macro* . <handler>) |
; (<trigger-symbol> <new-bindings> . <handler>) |
; (<trigger-symbol> . <handler>)
; <trigger-symbol> ::= XMLname | *text* | *default*
; <handler> :: <trigger-symbol> x [<tree>] -> <new-tree>
;@end smallexample
;
; The pre-post-order function visits the nodes and nodelists
; pre-post-order (depth-first). For each @code{<Node>} of the form
; @code{(@var{name} <Node> ...)}, it looks up an association with the
; given @var{name} among its @var{<bindings>}. If failed,
; @code{pre-post-order} tries to locate a @code{*default*} binding. It's
; an error if the latter attempt fails as well. Having found a binding,
; the @code{pre-post-order} function first checks to see if the binding
; is of the form
;@smallexample
; (<trigger-symbol> *preorder* . <handler>)
;@end smallexample
;
; If it is, the handler is 'applied' to the current node. Otherwise, the
; pre-post-order function first calls itself recursively for each child
; of the current node, with @var{<new-bindings>} prepended to the
; @var{<bindings>} in effect. The result of these calls is passed to the
; @var{<handler>} (along with the head of the current @var{<Node>}). To
; be more precise, the handler is _applied_ to the head of the current
; node and its processed children. The result of the handler, which
; should also be a @code{<tree>}, replaces the current @var{<Node>}. If
; the current @var{<Node>} is a text string or other atom, a special
; binding with a symbol @code{*text*} is looked up.
;
; A binding can also be of a form
;@smallexample
; (<trigger-symbol> *macro* . <handler>)
;@end smallexample
; This is equivalent to @code{*preorder*} described above. However, the
; result is re-processed again, with the current stylesheet.
;;
;;; Code:
(define-module (sxml transform)
#:export (SRV:send-reply
foldts
post-order
pre-post-order
replace-range))
;; Upstream version:
; $Id: SXML-tree-trans.scm,v 1.8 2003/04/24 19:39:53 oleg Exp oleg $
; Like let* but allowing for multiple-value bindings
(define-macro (let*-values bindings . body)
(if (null? bindings) (cons 'begin body)
(apply
(lambda (vars initializer)
(let ((cont
(cons 'let*-values
(cons (cdr bindings) body))))
(cond
((not (pair? vars)) ; regular let case, a single var
`(let ((,vars ,initializer)) ,cont))
((null? (cdr vars)) ; single var, see the prev case
`(let ((,(car vars) ,initializer)) ,cont))
(else ; the most generic case
`(call-with-values (lambda () ,initializer)
(lambda ,vars ,cont))))))
(car bindings))))
(define (SRV:send-reply . fragments)
"Output the @var{fragments} to the current output port.
The fragments are a list of strings, characters, numbers, thunks,
@code{#f}, @code{#t} -- and other fragments. The function traverses the
tree depth-first, writes out strings and characters, executes thunks,
and ignores @code{#f} and @code{'()}. The function returns @code{#t} if
anything was written at all; otherwise the result is @code{#f} If
@code{#t} occurs among the fragments, it is not written out but causes
the result of @code{SRV:send-reply} to be @code{#t}."
(let loop ((fragments fragments) (result #f))
(cond
((null? fragments) result)
((not (car fragments)) (loop (cdr fragments) result))
((null? (car fragments)) (loop (cdr fragments) result))
((eq? #t (car fragments)) (loop (cdr fragments) #t))
((pair? (car fragments))
(loop (cdr fragments) (loop (car fragments) result)))
((procedure? (car fragments))
((car fragments))
(loop (cdr fragments) #t))
(else
(display (car fragments))
(loop (cdr fragments) #t)))))
;------------------------------------------------------------------------
; Traversal of an SXML tree or a grove:
; a <Node> or a <Nodelist>
;
; A <Node> and a <Nodelist> are mutually-recursive datatypes that
; underlie the SXML tree:
; <Node> ::= (name . <Nodelist>) | "text string"
; An (ordered) set of nodes is just a list of the constituent nodes:
; <Nodelist> ::= (<Node> ...)
; Nodelists, and Nodes other than text strings are both lists. A
; <Nodelist> however is either an empty list, or a list whose head is
; not a symbol (an atom in general). A symbol at the head of a node is
; either an XML name (in which case it's a tag of an XML element), or
; an administrative name such as '@'.
; See SXPath.scm and SSAX.scm for more information on SXML.
;; see the commentary for docs
(define (pre-post-order tree bindings)
(let* ((default-binding (assq '*default* bindings))
(text-binding (or (assq '*text* bindings) default-binding))
(text-handler ; Cache default and text bindings
(and text-binding
(if (procedure? (cdr text-binding))
(cdr text-binding) (cddr text-binding)))))
(let loop ((tree tree))
(cond
((null? tree) '())
((not (pair? tree))
(let ((trigger '*text*))
(if text-handler (text-handler trigger tree)
(error "Unknown binding for " trigger " and no default"))))
((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist
(else ; tree is an SXML node
(let* ((trigger (car tree))
(binding (or (assq trigger bindings) default-binding)))
(cond
((not binding)
(error "Unknown binding for " trigger " and no default"))
((not (pair? (cdr binding))) ; must be a procedure: handler
(apply (cdr binding) trigger (map loop (cdr tree))))
((eq? '*preorder* (cadr binding))
(apply (cddr binding) tree))
((eq? '*macro* (cadr binding))
(loop (apply (cddr binding) tree)))
(else ; (cadr binding) is a local binding
(apply (cddr binding) trigger
(pre-post-order (cdr tree) (append (cadr binding) bindings)))
))))))))
; post-order is a strict subset of pre-post-order without *preorder*
; (let alone *macro*) traversals.
; Now pre-post-order is actually faster than the old post-order.
; The function post-order is deprecated and is aliased below for
; backward compatibility.
(define post-order pre-post-order)
;------------------------------------------------------------------------
; Extended tree fold
; tree = atom | (node-name tree ...)
;
; foldts fdown fup fhere seed (Leaf str) = fhere seed str
; foldts fdown fup fhere seed (Nd kids) =
; fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids
; procedure fhere: seed -> atom -> seed
; procedure fdown: seed -> node -> seed
; procedure fup: parent-seed -> last-kid-seed -> node -> seed
; foldts returns the final seed
(define (foldts fdown fup fhere seed tree)
(cond
((null? tree) seed)
((not (pair? tree)) ; An atom
(fhere seed tree))
(else
(let loop ((kid-seed (fdown seed tree)) (kids (cdr tree)))
(if (null? kids)
(fup seed kid-seed tree)
(loop (foldts fdown fup fhere kid-seed (car kids))
(cdr kids)))))))
;------------------------------------------------------------------------
; Traverse a forest depth-first and cut/replace ranges of nodes.
;
; The nodes that define a range don't have to have the same immediate
; parent, don't have to be on the same level, and the end node of a
; range doesn't even have to exist. A replace-range procedure removes
; nodes from the beginning node of the range up to (but not including)
; the end node of the range. In addition, the beginning node of the
; range can be replaced by a node or a list of nodes. The range of
; nodes is cut while depth-first traversing the forest. If all
; branches of the node are cut a node is cut as well. The procedure
; can cut several non-overlapping ranges from a forest.
; replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
; where
; type FOREST = (NODE ...)
; type NODE = Atom | (Name . FOREST) | FOREST
;
; The range of nodes is specified by two predicates, beg-pred and end-pred.
; beg-pred:: NODE -> #f | FOREST
; end-pred:: NODE -> #f | FOREST
; The beg-pred predicate decides on the beginning of the range. The node
; for which the predicate yields non-#f marks the beginning of the range
; The non-#f value of the predicate replaces the node. The value can be a
; list of nodes. The replace-range procedure then traverses the tree and skips
; all the nodes, until the end-pred yields non-#f. The value of the end-pred
; replaces the end-range node. The new end node and its brothers will be
; re-scanned.
; The predicates are evaluated pre-order. We do not descend into a node that
; is marked as the beginning of the range.
(define (replace-range beg-pred end-pred forest)
; loop forest keep? new-forest
; forest is the forest to traverse
; new-forest accumulates the nodes we will keep, in the reverse
; order
; If keep? is #t, keep the curr node if atomic. If the node is not atomic,
; traverse its children and keep those that are not in the skip range.
; If keep? is #f, skip the current node if atomic. Otherwise,
; traverse its children. If all children are skipped, skip the node
; as well.
(define (loop forest keep? new-forest)
(if (null? forest) (values (reverse new-forest) keep?)
(let ((node (car forest)))
(if keep?
(cond ; accumulate mode
((beg-pred node) => ; see if the node starts the skip range
(lambda (repl-branches) ; if so, skip/replace the node
(loop (cdr forest) #f
(append (reverse repl-branches) new-forest))))
((not (pair? node)) ; it's an atom, keep it
(loop (cdr forest) keep? (cons node new-forest)))
(else
(let*-values
(((node?) (symbol? (car node))) ; or is it a nodelist?
((new-kids keep?) ; traverse its children
(loop (if node? (cdr node) node) #t '())))
(loop (cdr forest) keep?
(cons
(if node? (cons (car node) new-kids) new-kids)
new-forest)))))
; skip mode
(cond
((end-pred node) => ; end the skip range
(lambda (repl-branches) ; repl-branches will be re-scanned
(loop (append repl-branches (cdr forest)) #t
new-forest)))
((not (pair? node)) ; it's an atom, skip it
(loop (cdr forest) keep? new-forest))
(else
(let*-values
(((node?) (symbol? (car node))) ; or is it a nodelist?
((new-kids keep?) ; traverse its children
(loop (if node? (cdr node) node) #f '())))
(loop (cdr forest) keep?
(if (or keep? (pair? new-kids))
(cons
(if node? (cons (car node) new-kids) new-kids)
new-forest)
new-forest) ; if all kids are skipped
)))))))) ; skip the node too
(let*-values (((new-forest keep?) (loop forest #t '())))
new-forest))
;;; arch-tag: 6c814f4b-38f7-42c1-b8ef-ce3447edefc7
;;; transform.scm ends here

2
module/sxml/upstream/COPYING.SSAX Normal file
View file

@ -0,0 +1,2 @@
The files in this directory are imported directly from upstream SSAX,
and are in the public domain.

3212
module/sxml/upstream/SSAX.scm Normal file
View file

File diff suppressed because it is too large Load diff

249
module/sxml/upstream/SXML-tree-trans.scm Normal file
View file

@ -0,0 +1,249 @@
; XML/HTML processing in Scheme
; SXML expression tree transformers
;
; IMPORT
; A prelude appropriate for your Scheme system
; (myenv-bigloo.scm, myenv-mit.scm, etc.)
;
; EXPORT
; (provide SRV:send-reply
; post-order pre-post-order replace-range)
;
; See vSXML-tree-trans.scm for the validation code, which also
; serves as usage examples.
;
; $Id: SXML-tree-trans.scm,v 1.6 2003/04/25 19:16:15 oleg Exp $
; Output the 'fragments'
; The fragments are a list of strings, characters,
; numbers, thunks, #f, #t -- and other fragments.
; The function traverses the tree depth-first, writes out
; strings and characters, executes thunks, and ignores
; #f and '().
; The function returns #t if anything was written at all;
; otherwise the result is #f
; If #t occurs among the fragments, it is not written out
; but causes the result of SRV:send-reply to be #t
(define (SRV:send-reply . fragments)
(let loop ((fragments fragments) (result #f))
(cond
((null? fragments) result)
((not (car fragments)) (loop (cdr fragments) result))
((null? (car fragments)) (loop (cdr fragments) result))
((eq? #t (car fragments)) (loop (cdr fragments) #t))
((pair? (car fragments))
(loop (cdr fragments) (loop (car fragments) result)))
((procedure? (car fragments))
((car fragments))
(loop (cdr fragments) #t))
(else
(display (car fragments))
(loop (cdr fragments) #t)))))
;------------------------------------------------------------------------
; Traversal of an SXML tree or a grove:
; a <Node> or a <Nodelist>
;
; A <Node> and a <Nodelist> are mutually-recursive datatypes that
; underlie the SXML tree:
; <Node> ::= (name . <Nodelist>) | "text string"
; An (ordered) set of nodes is just a list of the constituent nodes:
; <Nodelist> ::= (<Node> ...)
; Nodelists, and Nodes other than text strings are both lists. A
; <Nodelist> however is either an empty list, or a list whose head is
; not a symbol (an atom in general). A symbol at the head of a node is
; either an XML name (in which case it's a tag of an XML element), or
; an administrative name such as '@'.
; See SXPath.scm and SSAX.scm for more information on SXML.
; Pre-Post-order traversal of a tree and creation of a new tree:
; pre-post-order:: <tree> x <bindings> -> <new-tree>
; where
; <bindings> ::= (<binding> ...)
; <binding> ::= (<trigger-symbol> *preorder* . <handler>) |
; (<trigger-symbol> *macro* . <handler>) |
; (<trigger-symbol> <new-bindings> . <handler>) |
; (<trigger-symbol> . <handler>)
; <trigger-symbol> ::= XMLname | *text* | *default*
; <handler> :: <trigger-symbol> x [<tree>] -> <new-tree>
;
; The pre-post-order function visits the nodes and nodelists
; pre-post-order (depth-first). For each <Node> of the form (name
; <Node> ...) it looks up an association with the given 'name' among
; its <bindings>. If failed, pre-post-order tries to locate a
; *default* binding. It's an error if the latter attempt fails as
; well. Having found a binding, the pre-post-order function first
; checks to see if the binding is of the form
; (<trigger-symbol> *preorder* . <handler>)
; If it is, the handler is 'applied' to the current node. Otherwise,
; the pre-post-order function first calls itself recursively for each
; child of the current node, with <new-bindings> prepended to the
; <bindings> in effect. The result of these calls is passed to the
; <handler> (along with the head of the current <Node>). To be more
; precise, the handler is _applied_ to the head of the current node
; and its processed children. The result of the handler, which should
; also be a <tree>, replaces the current <Node>. If the current <Node>
; is a text string or other atom, a special binding with a symbol
; *text* is looked up.
;
; A binding can also be of a form
; (<trigger-symbol> *macro* . <handler>)
; This is equivalent to *preorder* described above. However, the result
; is re-processed again, with the current stylesheet.
(define (pre-post-order tree bindings)
(let* ((default-binding (assq '*default* bindings))
(text-binding (or (assq '*text* bindings) default-binding))
(text-handler ; Cache default and text bindings
(and text-binding
(if (procedure? (cdr text-binding))
(cdr text-binding) (cddr text-binding)))))
(let loop ((tree tree))
(cond
((null? tree) '())
((not (pair? tree))
(let ((trigger '*text*))
(if text-handler (text-handler trigger tree)
(error "Unknown binding for " trigger " and no default"))))
((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist
(else ; tree is an SXML node
(let* ((trigger (car tree))
(binding (or (assq trigger bindings) default-binding)))
(cond
((not binding)
(error "Unknown binding for " trigger " and no default"))
((not (pair? (cdr binding))) ; must be a procedure: handler
(apply (cdr binding) trigger (map loop (cdr tree))))
((eq? '*preorder* (cadr binding))
(apply (cddr binding) tree))
((eq? '*macro* (cadr binding))
(loop (apply (cddr binding) tree)))
(else ; (cadr binding) is a local binding
(apply (cddr binding) trigger
(pre-post-order (cdr tree) (append (cadr binding) bindings)))
))))))))
; post-order is a strict subset of pre-post-order without *preorder*
; (let alone *macro*) traversals.
; Now pre-post-order is actually faster than the old post-order.
; The function post-order is deprecated and is aliased below for
; backward compatibility.
(define post-order pre-post-order)
;------------------------------------------------------------------------
; Extended tree fold
; tree = atom | (node-name tree ...)
;
; foldts fdown fup fhere seed (Leaf str) = fhere seed str
; foldts fdown fup fhere seed (Nd kids) =
; fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids
; procedure fhere: seed -> atom -> seed
; procedure fdown: seed -> node -> seed
; procedure fup: parent-seed -> last-kid-seed -> node -> seed
; foldts returns the final seed
(define (foldts fdown fup fhere seed tree)
(cond
((null? tree) seed)
((not (pair? tree)) ; An atom
(fhere seed tree))
(else
(let loop ((kid-seed (fdown seed tree)) (kids (cdr tree)))
(if (null? kids)
(fup seed kid-seed tree)
(loop (foldts fdown fup fhere kid-seed (car kids))
(cdr kids)))))))
;------------------------------------------------------------------------
; Traverse a forest depth-first and cut/replace ranges of nodes.
;
; The nodes that define a range don't have to have the same immediate
; parent, don't have to be on the same level, and the end node of a
; range doesn't even have to exist. A replace-range procedure removes
; nodes from the beginning node of the range up to (but not including)
; the end node of the range. In addition, the beginning node of the
; range can be replaced by a node or a list of nodes. The range of
; nodes is cut while depth-first traversing the forest. If all
; branches of the node are cut a node is cut as well. The procedure
; can cut several non-overlapping ranges from a forest.
; replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
; where
; type FOREST = (NODE ...)
; type NODE = Atom | (Name . FOREST) | FOREST
;
; The range of nodes is specified by two predicates, beg-pred and end-pred.
; beg-pred:: NODE -> #f | FOREST
; end-pred:: NODE -> #f | FOREST
; The beg-pred predicate decides on the beginning of the range. The node
; for which the predicate yields non-#f marks the beginning of the range
; The non-#f value of the predicate replaces the node. The value can be a
; list of nodes. The replace-range procedure then traverses the tree and skips
; all the nodes, until the end-pred yields non-#f. The value of the end-pred
; replaces the end-range node. The new end node and its brothers will be
; re-scanned.
; The predicates are evaluated pre-order. We do not descend into a node that
; is marked as the beginning of the range.
(define (replace-range beg-pred end-pred forest)
; loop forest keep? new-forest
; forest is the forest to traverse
; new-forest accumulates the nodes we will keep, in the reverse
; order
; If keep? is #t, keep the curr node if atomic. If the node is not atomic,
; traverse its children and keep those that are not in the skip range.
; If keep? is #f, skip the current node if atomic. Otherwise,
; traverse its children. If all children are skipped, skip the node
; as well.
(define (loop forest keep? new-forest)
(if (null? forest) (values (reverse new-forest) keep?)
(let ((node (car forest)))
(if keep?
(cond ; accumulate mode
((beg-pred node) => ; see if the node starts the skip range
(lambda (repl-branches) ; if so, skip/replace the node
(loop (cdr forest) #f
(append (reverse repl-branches) new-forest))))
((not (pair? node)) ; it's an atom, keep it
(loop (cdr forest) keep? (cons node new-forest)))
(else
(let*-values
(((node?) (symbol? (car node))) ; or is it a nodelist?
((new-kids keep?) ; traverse its children
(loop (if node? (cdr node) node) #t '())))
(loop (cdr forest) keep?
(cons
(if node? (cons (car node) new-kids) new-kids)
new-forest)))))
; skip mode
(cond
((end-pred node) => ; end the skip range
(lambda (repl-branches) ; repl-branches will be re-scanned
(loop (append repl-branches (cdr forest)) #t
new-forest)))
((not (pair? node)) ; it's an atom, skip it
(loop (cdr forest) keep? new-forest))
(else
(let*-values
(((node?) (symbol? (car node))) ; or is it a nodelist?
((new-kids keep?) ; traverse its children
(loop (if node? (cdr node) node) #f '())))
(loop (cdr forest) keep?
(if (or keep? (pair? new-kids))
(cons
(if node? (cons (car node) new-kids) new-kids)
new-forest)
new-forest) ; if all kids are skipped
)))))))) ; skip the node too
(let*-values (((new-forest keep?) (loop forest #t '())))
new-forest))

1216
module/sxml/upstream/SXPath-old.scm Normal file
View file

File diff suppressed because it is too large Load diff

35
module/sxml/upstream/assert.scm Normal file
View file

@ -0,0 +1,35 @@
;
; syntax: assert ?expr ?expr ... [report: ?r-exp ?r-exp ...]
;
; If (and ?expr ?expr ...) evaluates to anything but #f, the result
; is the value of that expression.
; If (and ?expr ?expr ...) evaluates to #f, an error is reported.
; The error message will show the failed expressions, as well
; as the values of selected variables (or expressions, in general).
; The user may explicitly specify the expressions whose
; values are to be printed upon assertion failure -- as ?r-exp that
; follow the identifier 'report:'
; Typically, ?r-exp is either a variable or a string constant.
; If the user specified no ?r-exp, the values of variables that are
; referenced in ?expr will be printed upon the assertion failure.
(define-syntax assert
(syntax-rules (report:)
((assert "doit" (expr ...) (r-exp ...))
(cond
((and expr ...) => (lambda (x) x))
(else
(error "assertion failure: ~a" (list '(and expr ...) r-exp ...)))))
((assert "collect" (expr ...))
(assert "doit" (expr ...) ()))
((assert "collect" (expr ...) report: r-exp ...)
(assert "doit" (expr ...) (r-exp ...)))
((assert "collect" (expr ...) expr1 stuff ...)
(assert "collect" (expr ... expr1) stuff ...))
((assert stuff ...)
(assert "collect" () stuff ...))))
(define-syntax assure
(syntax-rules ()
((assure exp error-msg)
(assert exp report: error-msg))))

326
module/sxml/upstream/input-parse.scm Normal file
View file

@ -0,0 +1,326 @@
;****************************************************************************
; Simple Parsing of input
;
; The following simple functions surprisingly often suffice to parse
; an input stream. They either skip, or build and return tokens,
; according to inclusion or delimiting semantics. The list of
; characters to expect, include, or to break at may vary from one
; invocation of a function to another. This allows the functions to
; easily parse even context-sensitive languages.
;
; EOF is generally frowned on, and thrown up upon if encountered.
; Exceptions are mentioned specifically. The list of expected characters
; (characters to skip until, or break-characters) may include an EOF
; "character", which is to be coded as symbol *eof*
;
; The input stream to parse is specified as a PORT, which is usually
; the last (and optional) argument. It defaults to the current input
; port if omitted.
;
; IMPORT
; This package relies on a function parser-error, which must be defined
; by a user of the package. The function has the following signature:
; parser-error PORT MESSAGE SPECIALISING-MSG*
; Many procedures of this package call parser-error to report a parsing
; error. The first argument is a port, which typically points to the
; offending character or its neighborhood. Most of the Scheme systems
; let the user query a PORT for the current position. MESSAGE is the
; description of the error. Other arguments supply more details about
; the problem.
; myenv.scm, myenv-bigloo.scm or a similar prelude is assumed.
; From SRFI-13, string-concatenate-reverse
; If a particular implementation lacks SRFI-13 support, please
; include the file srfi-13-local.scm
;
; $Id: input-parse.scm,v 1.7 2004/07/07 16:02:31 sperber Exp $
;------------------------------------------------------------------------
; -- procedure+: peek-next-char [PORT]
; advances to the next character in the PORT and peeks at it.
; This function is useful when parsing LR(1)-type languages
; (one-char-read-ahead).
; The optional argument PORT defaults to the current input port.
(define-opt (peek-next-char (optional (port (current-input-port))))
(read-char port)
(peek-char port))
;------------------------------------------------------------------------
; -- procedure+: assert-curr-char CHAR-LIST STRING [PORT]
; Reads a character from the PORT and looks it up
; in the CHAR-LIST of expected characters
; If the read character was found among expected, it is returned
; Otherwise, the procedure writes a nasty message using STRING
; as a comment, and quits.
; The optional argument PORT defaults to the current input port.
;
(define-opt (assert-curr-char expected-chars comment
(optional (port (current-input-port))))
(let ((c (read-char port)))
(if (memv c expected-chars) c
(parser-error port "Wrong character " c
" (0x" (if (eof-object? c) "*eof*"
(number->string (char->integer c) 16)) ") "
comment ". " expected-chars " expected"))))
; -- procedure+: skip-until CHAR-LIST [PORT]
; Reads and skips characters from the PORT until one of the break
; characters is encountered. This break character is returned.
; The break characters are specified as the CHAR-LIST. This list
; may include EOF, which is to be coded as a symbol *eof*
;
; -- procedure+: skip-until NUMBER [PORT]
; Skips the specified NUMBER of characters from the PORT and returns #f
;
; The optional argument PORT defaults to the current input port.
(define-opt (skip-until arg (optional (port (current-input-port))) )
(cond
((number? arg) ; skip 'arg' characters
(do ((i arg (dec i)))
((not (positive? i)) #f)
(if (eof-object? (read-char port))
(parser-error port "Unexpected EOF while skipping "
arg " characters"))))
(else ; skip until break-chars (=arg)
(let loop ((c (read-char port)))
(cond
((memv c arg) c)
((eof-object? c)
(if (memq '*eof* arg) c
(parser-error port "Unexpected EOF while skipping until " arg)))
(else (loop (read-char port))))))))
; -- procedure+: skip-while CHAR-LIST [PORT]
; Reads characters from the PORT and disregards them,
; as long as they are mentioned in the CHAR-LIST.
; The first character (which may be EOF) peeked from the stream
; that is NOT a member of the CHAR-LIST is returned. This character
; is left on the stream.
; The optional argument PORT defaults to the current input port.
(define-opt (skip-while skip-chars (optional (port (current-input-port))) )
(do ((c (peek-char port) (peek-char port)))
((not (memv c skip-chars)) c)
(read-char port)))
; whitespace const
;------------------------------------------------------------------------
; Stream tokenizers
; -- procedure+:
; next-token PREFIX-CHAR-LIST BREAK-CHAR-LIST [COMMENT-STRING] [PORT]
; skips any number of the prefix characters (members of the
; PREFIX-CHAR-LIST), if any, and reads the sequence of characters
; up to (but not including) a break character, one of the
; BREAK-CHAR-LIST.
; The string of characters thus read is returned.
; The break character is left on the input stream
; The list of break characters may include EOF, which is to be coded as
; a symbol *eof*. Otherwise, EOF is fatal, generating an error message
; including a specified COMMENT-STRING (if any)
;
; The optional argument PORT defaults to the current input port.
;
; Note: since we can't tell offhand how large the token being read is
; going to be, we make a guess, pre-allocate a string, and grow it by
; quanta if necessary. The quantum is always the length of the string
; before it was extended the last time. Thus the algorithm does
; a Fibonacci-type extension, which has been proven optimal.
; Note, explicit port specification in read-char, peek-char helps.
; Procedure: input-parse:init-buffer
; returns an initial buffer for next-token* procedures.
; The input-parse:init-buffer may allocate a new buffer per each invocation:
; (define (input-parse:init-buffer) (make-string 32))
; Size 32 turns out to be fairly good, on average.
; That policy is good only when a Scheme system is multi-threaded with
; preemptive scheduling, or when a Scheme system supports shared substrings.
; In all the other cases, it's better for input-parse:init-buffer to
; return the same static buffer. next-token* functions return a copy
; (a substring) of accumulated data, so the same buffer can be reused.
; We shouldn't worry about an incoming token being too large:
; next-token will use another chunk automatically. Still,
; the best size for the static buffer is to allow most of the tokens to fit in.
; Using a static buffer _dramatically_ reduces the amount of produced garbage
; (e.g., during XML parsing).
(define input-parse:init-buffer
(let ((buffer (make-string 512)))
(lambda () buffer)))
; See a better version below
(define-opt (next-token-old prefix-skipped-chars break-chars
(optional (comment "") (port (current-input-port))) )
(let* ((buffer (input-parse:init-buffer))
(curr-buf-len (string-length buffer))
(quantum curr-buf-len))
(let loop ((i 0) (c (skip-while prefix-skipped-chars port)))
(cond
((memv c break-chars) (substring buffer 0 i))
((eof-object? c)
(if (memq '*eof* break-chars)
(substring buffer 0 i) ; was EOF expected?
(parser-error port "EOF while reading a token " comment)))
(else
(if (>= i curr-buf-len) ; make space for i-th char in buffer
(begin ; -> grow the buffer by the quantum
(set! buffer (string-append buffer (make-string quantum)))
(set! quantum curr-buf-len)
(set! curr-buf-len (string-length buffer))))
(string-set! buffer i c)
(read-char port) ; move to the next char
(loop (inc i) (peek-char port))
)))))
; A better version of next-token, which accumulates the characters
; in chunks, and later on reverse-concatenates them, using
; SRFI-13 if available.
; The overhead of copying characters is only 100% (or even smaller: bulk
; string copying might be well-optimised), compared to the (hypothetical)
; circumstance if we had known the size of the token beforehand.
; For small tokens, the code performs just as above. For large
; tokens, we expect an improvement. Note, the code also has no
; assignments.
; See next-token-comp.scm
(define-opt (next-token prefix-skipped-chars break-chars
(optional (comment "") (port (current-input-port))) )
(let outer ((buffer (input-parse:init-buffer)) (filled-buffer-l '())
(c (skip-while prefix-skipped-chars port)))
(let ((curr-buf-len (string-length buffer)))
(let loop ((i 0) (c c))
(cond
((memv c break-chars)
(if (null? filled-buffer-l) (substring buffer 0 i)
(string-concatenate-reverse filled-buffer-l buffer i)))
((eof-object? c)
(if (memq '*eof* break-chars) ; was EOF expected?
(if (null? filled-buffer-l) (substring buffer 0 i)
(string-concatenate-reverse filled-buffer-l buffer i))
(parser-error port "EOF while reading a token " comment)))
((>= i curr-buf-len)
(outer (make-string curr-buf-len)
(cons buffer filled-buffer-l) c))
(else
(string-set! buffer i c)
(read-char port) ; move to the next char
(loop (inc i) (peek-char port))))))))
; -- procedure+: next-token-of INC-CHARSET [PORT]
; Reads characters from the PORT that belong to the list of characters
; INC-CHARSET. The reading stops at the first character which is not
; a member of the set. This character is left on the stream.
; All the read characters are returned in a string.
;
; -- procedure+: next-token-of PRED [PORT]
; Reads characters from the PORT for which PRED (a procedure of one
; argument) returns non-#f. The reading stops at the first character
; for which PRED returns #f. That character is left on the stream.
; All the results of evaluating of PRED up to #f are returned in a
; string.
;
; PRED is a procedure that takes one argument (a character
; or the EOF object) and returns a character or #f. The returned
; character does not have to be the same as the input argument
; to the PRED. For example,
; (next-token-of (lambda (c)
; (cond ((eof-object? c) #f)
; ((char-alphabetic? c) (char-downcase c))
; (else #f))))
; will try to read an alphabetic token from the current
; input port, and return it in lower case.
;
; The optional argument PORT defaults to the current input port.
;
; This procedure is similar to next-token but only it implements
; an inclusion rather than delimiting semantics.
(define-opt (next-token-of incl-list/pred
(optional (port (current-input-port))) )
(let* ((buffer (input-parse:init-buffer))
(curr-buf-len (string-length buffer)))
(if (procedure? incl-list/pred)
(let outer ((buffer buffer) (filled-buffer-l '()))
(let loop ((i 0))
(if (>= i curr-buf-len) ; make sure we have space
(outer (make-string curr-buf-len) (cons buffer filled-buffer-l))
(let ((c (incl-list/pred (peek-char port))))
(if c
(begin
(string-set! buffer i c)
(read-char port) ; move to the next char
(loop (inc i)))
; incl-list/pred decided it had had enough
(if (null? filled-buffer-l) (substring buffer 0 i)
(string-concatenate-reverse filled-buffer-l buffer i)))))))
; incl-list/pred is a list of allowed characters
(let outer ((buffer buffer) (filled-buffer-l '()))
(let loop ((i 0))
(if (>= i curr-buf-len) ; make sure we have space
(outer (make-string curr-buf-len) (cons buffer filled-buffer-l))
(let ((c (peek-char port)))
(cond
((not (memv c incl-list/pred))
(if (null? filled-buffer-l) (substring buffer 0 i)
(string-concatenate-reverse filled-buffer-l buffer i)))
(else
(string-set! buffer i c)
(read-char port) ; move to the next char
(loop (inc i))))))))
)))
; -- procedure+: read-text-line [PORT]
; Reads one line of text from the PORT, and returns it as a string.
; A line is a (possibly empty) sequence of characters terminated
; by CR, CRLF or LF (or even the end of file).
; The terminating character (or CRLF combination) is removed from
; the input stream. The terminating character(s) is not a part
; of the return string either.
; If EOF is encountered before any character is read, the return
; value is EOF.
;
; The optional argument PORT defaults to the current input port.
(define *read-line-breaks* (list char-newline char-return '*eof*))
(define-opt (read-text-line (optional (port (current-input-port))) )
(if (eof-object? (peek-char port)) (peek-char port)
(let* ((line
(next-token '() *read-line-breaks*
"reading a line" port))
(c (read-char port))) ; must be either \n or \r or EOF
(and (eqv? c char-return) (eqv? (peek-char port) #\newline)
(read-char port)) ; skip \n that follows \r
line)))
; -- procedure+: read-string N [PORT]
; Reads N characters from the PORT, and returns them in a string.
; If EOF is encountered before N characters are read, a shorter string
; will be returned.
; If N is not positive, an empty string will be returned.
; The optional argument PORT defaults to the current input port.
(define-opt (read-string n (optional (port (current-input-port))) )
(if (not (positive? n)) ""
(let ((buffer (make-string n)))
(let loop ((i 0) (c (read-char port)))
(if (eof-object? c) (substring buffer 0 i)
(let ((i1 (inc i)))
(string-set! buffer i c)
(if (= i1 n) buffer
(loop i1 (read-char port)))))))))

493
module/sxml/xpath.scm Normal file
View file

@ -0,0 +1,493 @@
;;;; (sxml xpath) -- SXPath
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
;;;; Written 2001 by Oleg Kiselyov <oleg at pobox dot com> SXPath.scm.
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;;@heading SXPath: SXML Query Language
;;
;; SXPath is a query language for SXML, an instance of XML Information
;; set (Infoset) in the form of s-expressions. See @code{(sxml ssax)}
;; for the definition of SXML and more details. SXPath is also a
;; translation into Scheme of an XML Path Language,
;; @uref{http://www.w3.org/TR/xpath,XPath}. XPath and SXPath describe
;; means of selecting a set of Infoset's items or their properties.
;;
;; To facilitate queries, XPath maps the XML Infoset into an explicit
;; tree, and introduces important notions of a location path and a
;; current, context node. A location path denotes a selection of a set of
;; nodes relative to a context node. Any XPath tree has a distinguished,
;; root node -- which serves as the context node for absolute location
;; paths. Location path is recursively defined as a location step joined
;; with a location path. A location step is a simple query of the
;; database relative to a context node. A step may include expressions
;; that further filter the selected set. Each node in the resulting set
;; is used as a context node for the adjoining location path. The result
;; of the step is a union of the sets returned by the latter location
;; paths.
;;
;; The SXML representation of the XML Infoset (see SSAX.scm) is rather
;; suitable for querying as it is. Bowing to the XPath specification,
;; we will refer to SXML information items as 'Nodes':
;;@example
;; <Node> ::= <Element> | <attributes-coll> | <attrib>
;; | "text string" | <PI>
;;@end example
;; This production can also be described as
;;@example
;; <Node> ::= (name . <Nodeset>) | "text string"
;;@end example
;; An (ordered) set of nodes is just a list of the constituent nodes:
;;@example
;; <Nodeset> ::= (<Node> ...)
;;@end example
;; Nodesets, and Nodes other than text strings are both lists. A
;; <Nodeset> however is either an empty list, or a list whose head is not
;; a symbol. A symbol at the head of a node is either an XML name (in
;; which case it's a tag of an XML element), or an administrative name
;; such as '@@'. This uniform list representation makes processing rather
;; simple and elegant, while avoiding confusion. The multi-branch tree
;; structure formed by the mutually-recursive datatypes <Node> and
;; <Nodeset> lends itself well to processing by functional languages.
;;
;; A location path is in fact a composite query over an XPath tree or
;; its branch. A singe step is a combination of a projection, selection
;; or a transitive closure. Multiple steps are combined via join and
;; union operations. This insight allows us to @emph{elegantly}
;; implement XPath as a sequence of projection and filtering primitives
;; -- converters -- joined by @dfn{combinators}. Each converter takes a
;; node and returns a nodeset which is the result of the corresponding
;; query relative to that node. A converter can also be called on a set
;; of nodes. In that case it returns a union of the corresponding
;; queries over each node in the set. The union is easily implemented as
;; a list append operation as all nodes in a SXML tree are considered
;; distinct, by XPath conventions. We also preserve the order of the
;; members in the union. Query combinators are high-order functions:
;; they take converter(s) (which is a Node|Nodeset -> Nodeset function)
;; and compose or otherwise combine them. We will be concerned with only
;; relative location paths [XPath]: an absolute location path is a
;; relative path applied to the root node.
;;
;; Similarly to XPath, SXPath defines full and abbreviated notations
;; for location paths. In both cases, the abbreviated notation can be
;; mechanically expanded into the full form by simple rewriting
;; rules. In case of SXPath the corresponding rules are given as
;; comments to a sxpath function, below. The regression test suite at
;; the end of this file shows a representative sample of SXPaths in
;; both notations, juxtaposed with the corresponding XPath
;; expressions. Most of the samples are borrowed literally from the
;; XPath specification, while the others are adjusted for our running
;; example, tree1.
;;
;;; Code:
(define-module (sxml xpath)
#:use-module (ice-9 pretty-print)
#:export (nodeset? node-typeof? node-eq? node-equal? node-pos
filter take-until take-after map-union node-reverse
node-trace select-kids node-self node-join node-reduce
node-or node-closure node-parent
sxpath))
;; Upstream version:
; $Id: SXPath.scm,v 3.5 2001/01/12 23:20:35 oleg Exp oleg $
(define (nodeset? x)
(or (and (pair? x) (not (symbol? (car x)))) (null? x)))
;-------------------------
; Basic converters and applicators
; A converter is a function
; type Converter = Node|Nodeset -> Nodeset
; A converter can also play a role of a predicate: in that case, if a
; converter, applied to a node or a nodeset, yields a non-empty
; nodeset, the converter-predicate is deemed satisfied. Throughout
; this file a nil nodeset is equivalent to #f in denoting a failure.
; The following function implements a 'Node test' as defined in
; Sec. 2.3 of XPath document. A node test is one of the components of a
; location step. It is also a converter-predicate in SXPath.
;
; The function node-typeof? takes a type criterion and returns a function,
; which, when applied to a node, will tell if the node satisfies
; the test.
; node-typeof? :: Crit -> Node -> Boolean
;
; The criterion 'crit' is a symbol, one of the following:
; id - tests if the Node has the right name (id)
; @ - tests if the Node is an <attributes-coll>
; * - tests if the Node is an <Element>
; *text* - tests if the Node is a text node
; *PI* - tests if the Node is a PI node
; *any* - #t for any type of Node
(define (node-typeof? crit)
(lambda (node)
(case crit
((*) (and (pair? node) (not (memq (car node) '(@ *PI*)))))
((*any*) #t)
((*text*) (string? node))
(else
(and (pair? node) (eq? crit (car node))))
)))
; Curried equivalence converter-predicates
(define (node-eq? other)
(lambda (node)
(eq? other node)))
(define (node-equal? other)
(lambda (node)
(equal? other node)))
; node-pos:: N -> Nodeset -> Nodeset, or
; node-pos:: N -> Converter
; Select the N'th element of a Nodeset and return as a singular Nodeset;
; Return an empty nodeset if the Nth element does not exist.
; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset,
; if exists; ((node-pos 2) Nodeset) selects the Node after that, if
; exists.
; N can also be a negative number: in that case the node is picked from
; the tail of the list.
; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset;
; ((node-pos -2) Nodeset) selects the last but one node, if exists.
(define (node-pos n)
(lambda (nodeset)
(cond
((not (nodeset? nodeset)) '())
((null? nodeset) nodeset)
((eqv? n 1) (list (car nodeset)))
((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset))
(else
(or (positive? n) (error "yikes!"))
((node-pos (1- n)) (cdr nodeset))))))
; filter:: Converter -> Converter
; A filter applicator, which introduces a filtering context. The argument
; converter is considered a predicate, with either #f or nil result meaning
; failure.
(define (filter pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))) (res '()))
(if (null? lst)
(reverse res)
(let ((pred-result (pred? (car lst))))
(loop (cdr lst)
(if (and pred-result (not (null? pred-result)))
(cons (car lst) res)
res)))))))
; take-until:: Converter -> Converter, or
; take-until:: Pred -> Node|Nodeset -> Nodeset
; Given a converter-predicate and a nodeset, apply the predicate to
; each element of the nodeset, until the predicate yields anything but #f or
; nil. Return the elements of the input nodeset that have been processed
; till that moment (that is, which fail the predicate).
; take-until is a variation of the filter above: take-until passes
; elements of an ordered input set till (but not including) the first
; element that satisfies the predicate.
; The nodeset returned by ((take-until (not pred)) nset) is a subset --
; to be more precise, a prefix -- of the nodeset returned by
; ((filter pred) nset)
(define (take-until pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))))
(if (null? lst) lst
(let ((pred-result (pred? (car lst))))
(if (and pred-result (not (null? pred-result)))
'()
(cons (car lst) (loop (cdr lst)))))
))))
; take-after:: Converter -> Converter, or
; take-after:: Pred -> Node|Nodeset -> Nodeset
; Given a converter-predicate and a nodeset, apply the predicate to
; each element of the nodeset, until the predicate yields anything but #f or
; nil. Return the elements of the input nodeset that have not been processed:
; that is, return the elements of the input nodeset that follow the first
; element that satisfied the predicate.
; take-after along with take-until partition an input nodeset into three
; parts: the first element that satisfies a predicate, all preceding
; elements and all following elements.
(define (take-after pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))))
(if (null? lst) lst
(let ((pred-result (pred? (car lst))))
(if (and pred-result (not (null? pred-result)))
(cdr lst)
(loop (cdr lst))))
))))
; Apply proc to each element of lst and return the list of results.
; if proc returns a nodeset, splice it into the result
;
; From another point of view, map-union is a function Converter->Converter,
; which places an argument-converter in a joining context.
(define (map-union proc lst)
(if (null? lst) lst
(let ((proc-res (proc (car lst))))
((if (nodeset? proc-res) append cons)
proc-res (map-union proc (cdr lst))))))
; node-reverse :: Converter, or
; node-reverse:: Node|Nodeset -> Nodeset
; Reverses the order of nodes in the nodeset
; This basic converter is needed to implement a reverse document order
; (see the XPath Recommendation).
(define node-reverse
(lambda (node-or-nodeset)
(if (not (nodeset? node-or-nodeset)) (list node-or-nodeset)
(reverse node-or-nodeset))))
; node-trace:: String -> Converter
; (node-trace title) is an identity converter. In addition it prints out
; a node or nodeset it is applied to, prefixed with the 'title'.
; This converter is very useful for debugging.
(define (node-trace title)
(lambda (node-or-nodeset)
(display "\n-->")
(display title)
(display " :")
(pretty-print node-or-nodeset)
node-or-nodeset))
;-------------------------
; Converter combinators
;
; Combinators are higher-order functions that transmogrify a converter
; or glue a sequence of converters into a single, non-trivial
; converter. The goal is to arrive at converters that correspond to
; XPath location paths.
;
; From a different point of view, a combinator is a fixed, named
; _pattern_ of applying converters. Given below is a complete set of
; such patterns that together implement XPath location path
; specification. As it turns out, all these combinators can be built
; from a small number of basic blocks: regular functional composition,
; map-union and filter applicators, and the nodeset union.
; select-kids:: Pred -> Node -> Nodeset
; Given a Node, return an (ordered) subset its children that satisfy
; the Pred (a converter, actually)
; select-kids:: Pred -> Nodeset -> Nodeset
; The same as above, but select among children of all the nodes in
; the Nodeset
;
; More succinctly, the signature of this function is
; select-kids:: Converter -> Converter
(define (select-kids test-pred?)
(lambda (node) ; node or node-set
(cond
((null? node) node)
((not (pair? node)) '()) ; No children
((symbol? (car node))
((filter test-pred?) (cdr node))) ; it's a single node
(else (map-union (select-kids test-pred?) node)))))
; node-self:: Pred -> Node -> Nodeset, or
; node-self:: Converter -> Converter
; Similar to select-kids but apply to the Node itself rather
; than to its children. The resulting Nodeset will contain either one
; component, or will be empty (if the Node failed the Pred).
(define node-self filter)
; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or
; node-join:: [Converter] -> Converter
; join the sequence of location steps or paths as described
; in the title comments above.
(define (node-join . selectors)
(lambda (nodeset) ; Nodeset or node
(let loop ((nodeset nodeset) (selectors selectors))
(if (null? selectors) nodeset
(loop
(if (nodeset? nodeset)
(map-union (car selectors) nodeset)
((car selectors) nodeset))
(cdr selectors))))))
; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or
; node-reduce:: [Converter] -> Converter
; A regular functional composition of converters.
; From a different point of view,
; ((apply node-reduce converters) nodeset)
; is equivalent to
; (foldl apply nodeset converters)
; i.e., folding, or reducing, a list of converters with the nodeset
; as a seed.
(define (node-reduce . converters)
(lambda (nodeset) ; Nodeset or node
(let loop ((nodeset nodeset) (converters converters))
(if (null? converters) nodeset
(loop ((car converters) nodeset) (cdr converters))))))
; node-or:: [Converter] -> Converter
; This combinator applies all converters to a given node and
; produces the union of their results.
; This combinator corresponds to a union, '|' operation for XPath
; location paths.
; (define (node-or . converters)
; (lambda (node-or-nodeset)
; (if (null? converters) node-or-nodeset
; (append
; ((car converters) node-or-nodeset)
; ((apply node-or (cdr converters)) node-or-nodeset)))))
; More optimal implementation follows
(define (node-or . converters)
(lambda (node-or-nodeset)
(let loop ((result '()) (converters converters))
(if (null? converters) result
(loop (append result (or ((car converters) node-or-nodeset) '()))
(cdr converters))))))
; node-closure:: Converter -> Converter
; Select all _descendants_ of a node that satisfy a converter-predicate.
; This combinator is similar to select-kids but applies to
; grand... children as well.
; This combinator implements the "descendant::" XPath axis
; Conceptually, this combinator can be expressed as
; (define (node-closure f)
; (node-or
; (select-kids f)
; (node-reduce (select-kids (node-typeof? '*)) (node-closure f))))
; This definition, as written, looks somewhat like a fixpoint, and it
; will run forever. It is obvious however that sooner or later
; (select-kids (node-typeof? '*)) will return an empty nodeset. At
; this point further iterations will no longer affect the result and
; can be stopped.
(define (node-closure test-pred?)
(lambda (node) ; Nodeset or node
(let loop ((parent node) (result '()))
(if (null? parent) result
(loop ((select-kids (node-typeof? '*)) parent)
(append result
((select-kids test-pred?) parent)))
))))
; node-parent:: RootNode -> Converter
; (node-parent rootnode) yields a converter that returns a parent of a
; node it is applied to. If applied to a nodeset, it returns the list
; of parents of nodes in the nodeset. The rootnode does not have
; to be the root node of the whole SXML tree -- it may be a root node
; of a branch of interest.
; Given the notation of Philip Wadler's paper on semantics of XSLT,
; parent(x) = { y | y=subnode*(root), x=subnode(y) }
; Therefore, node-parent is not the fundamental converter: it can be
; expressed through the existing ones. Yet node-parent is a rather
; convenient converter. It corresponds to a parent:: axis of SXPath.
; Note that the parent:: axis can be used with an attribute node as well!
(define (node-parent rootnode)
(lambda (node) ; Nodeset or node
(if (nodeset? node) (map-union (node-parent rootnode) node)
(let ((pred
(node-or
(node-reduce
(node-self (node-typeof? '*))
(select-kids (node-eq? node)))
(node-join
(select-kids (node-typeof? '@))
(select-kids (node-eq? node))))))
((node-or
(node-self pred)
(node-closure pred))
rootnode)))))
;-------------------------
; Evaluate an abbreviated SXPath
; sxpath:: AbbrPath -> Converter, or
; sxpath:: AbbrPath -> Node|Nodeset -> Nodeset
; AbbrPath is a list. It is translated to the full SXPath according
; to the following rewriting rules
; (sxpath '()) -> (node-join)
; (sxpath '(path-component ...)) ->
; (node-join (sxpath1 path-component) (sxpath '(...)))
; (sxpath1 '//) -> (node-or
; (node-self (node-typeof? '*any*))
; (node-closure (node-typeof? '*any*)))
; (sxpath1 '(equal? x)) -> (select-kids (node-equal? x))
; (sxpath1 '(eq? x)) -> (select-kids (node-eq? x))
; (sxpath1 ?symbol) -> (select-kids (node-typeof? ?symbol)
; (sxpath1 procedure) -> procedure
; (sxpath1 '(?symbol ...)) -> (sxpath1 '((?symbol) ...))
; (sxpath1 '(path reducer ...)) ->
; (node-reduce (sxpath path) (sxpathr reducer) ...)
; (sxpathr number) -> (node-pos number)
; (sxpathr path-filter) -> (filter (sxpath path-filter))
(define (sxpath path)
(lambda (nodeset)
(let loop ((nodeset nodeset) (path path))
(cond
((null? path) nodeset)
((nodeset? nodeset)
(map-union (sxpath path) nodeset))
((procedure? (car path))
(loop ((car path) nodeset) (cdr path)))
((eq? '// (car path))
(loop
((if (nodeset? nodeset) append cons) nodeset
((node-closure (node-typeof? '*any*)) nodeset))
(cdr path)))
((symbol? (car path))
(loop ((select-kids (node-typeof? (car path))) nodeset)
(cdr path)))
((and (pair? (car path)) (eq? 'equal? (caar path)))
(loop ((select-kids (apply node-equal? (cdar path))) nodeset)
(cdr path)))
((and (pair? (car path)) (eq? 'eq? (caar path)))
(loop ((select-kids (apply node-eq? (cdar path))) nodeset)
(cdr path)))
((pair? (car path))
(let reducer ((nodeset
(if (symbol? (caar path))
((select-kids (node-typeof? (caar path))) nodeset)
(loop nodeset (caar path))))
(reducing-path (cdar path)))
(cond
((null? reducing-path) (loop nodeset (cdr path)))
((number? (car reducing-path))
(reducer ((node-pos (car reducing-path)) nodeset)
(cdr reducing-path)))
(else
(reducer ((filter (sxpath (car reducing-path))) nodeset)
(cdr reducing-path))))))
(else
(error "Invalid path step: " (car path)))))))
;;; arch-tag: c4e57abf-6b61-4612-a6aa-d1536d440774
;;; xpath.scm ends here

1217
module/texinfo.scm Normal file
View file

File diff suppressed because it is too large Load diff

233
module/texinfo/docbook.scm Normal file
View file

@ -0,0 +1,233 @@
;;;; (texinfo docbook) -- translating sdocbook into stexinfo
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 2007, 2009 Andy Wingo <wingo at pobox dot com>
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;; @c
;; This module exports procedures for transforming a limited subset of
;; the SXML representation of docbook into stexi. It is not complete by
;; any means. The intention is to gather a number of routines and
;; stylesheets so that external modules can parse specific subsets of
;; docbook, for example that set generated by certain tools.
;;
;;; Code:
(define-module (texinfo docbook)
:use-module (sxml fold)
:export (*sdocbook->stexi-rules*
*sdocbook-block-commands*
sdocbook-flatten
filter-empty-elements
replace-titles))
(define (identity . args)
args)
(define (identity-deattr tag . body)
`(,tag ,@(if (and (pair? body) (pair? (car body))
(eq? (caar body) '@))
(cdr body)
body)))
(define (detag-one tag body)
body)
(define tag-replacements
'((parameter var)
(replaceable var)
(type code)
(function code)
(literal samp)
(emphasis emph)
(simpara para)
(programlisting example)
(firstterm dfn)
(filename file)
(quote cite)
(application cite)
(symbol code)
(note cartouche)
(envar env)))
(define ignore-list '())
(define (stringify exp)
(with-output-to-string (lambda () (write exp))))
(define *sdocbook->stexi-rules*
#;
"A stylesheet for use with SSAX's @code{pre-post-order}, which defines
a number of generic rules for transforming docbook into texinfo."
`((@ *preorder* . ,identity)
(% *preorder* . ,identity)
(para . ,identity-deattr)
(orderedlist ((listitem
. ,(lambda (tag . body)
`(item ,@body))))
. ,(lambda (tag . body)
`(enumerate ,@body)))
(itemizedlist ((listitem
. ,(lambda (tag . body)
`(item ,@body))))
. ,(lambda (tag . body)
`(itemize ,@body)))
(term . ,detag-one)
(informalexample . ,detag-one)
(section . ,identity)
(subsection . ,identity)
(subsubsection . ,identity)
(ulink . ,(lambda (tag attrs . body)
`(uref (% ,(assq 'url (cdr attrs))
(title ,@body)))))
(*text* . ,detag-one)
(*default* . ,(lambda (tag . body)
(let ((subst (assq tag tag-replacements)))
(cond
(subst
(if (and (pair? body) (pair? (car body)) (eq? (caar body) '@))
(begin
(warn "Ignoring" tag "attributes" (car body))
(append (cdr subst) (cdr body)))
(append (cdr subst) body)))
((memq tag ignore-list) #f)
(else
(warn "Don't know how to convert" tag "to stexi")
`(c (% (all ,(stringify (cons tag body))))))))))))
;; (variablelist
;; ((varlistentry
;; . ,(lambda (tag term . body)
;; `(entry (% (heading ,@(cdr term))) ,@body)))
;; (listitem
;; . ,(lambda (tag simpara)
;; simpara)))
;; . ,(lambda (tag attrs . body)
;; `(table (% (formatter (var))) ,@body)))
(define *sdocbook-block-commands*
#;
"The set of sdocbook element tags that should not be nested inside
each other. @xref{texinfo docbook sdocbook-flatten,,sdocbook-flatten},
for more information."
'(para programlisting informalexample indexterm variablelist
orderedlist refsect1 refsect2 refsect3 refsect4 title example
note itemizedlist))
(define (inline-command? command)
(not (memq command *sdocbook-block-commands*)))
(define (sdocbook-flatten sdocbook)
"\"Flatten\" a fragment of sdocbook so that block elements do not nest
inside each other.
Docbook is a nested format, where e.g. a @code{refsect2} normally
appears inside a @code{refsect1}. Logical divisions in the document are
represented via the tree topology; a @code{refsect2} element
@emph{contains} all of the elements in its section.
On the contrary, texinfo is a flat format, in which sections are marked
off by standalone section headers like @code{@@chapter}, and block
elements do not nest inside each other.
This function takes a nested sdocbook fragment @var{sdocbook} and
flattens all of the sections, such that e.g.
@example
(refsect1 (refsect2 (para \"Hello\")))
@end example
becomes
@example
((refsect1) (refsect2) (para \"Hello\"))
@end example
Oftentimes (always?) sectioning elements have @code{<title>} as their
first element child; users interested in processing the @code{refsect*}
elements into proper sectioning elements like @code{chapter} might be
interested in @code{replace-titles} and @code{filter-empty-elements}.
@xref{texinfo docbook replace-titles,,replace-titles}, and @ref{texinfo
docbook filter-empty-elements,,filter-empty-elements}.
Returns a nodeset, as described in @ref{sxml xpath}. That is to say,
this function returns an untagged list of stexi elements."
(define (fhere str accum block cont)
(values (cons str accum)
block
cont))
(define (fdown node accum block cont)
(let ((command (car node))
(attrs (and (pair? (cdr node)) (pair? (cadr node))
(eq? (caadr node) '%)
(cadr node))))
(values (if attrs (cddr node) (cdr node))
'()
'()
(lambda (accum block)
(values
`(,command ,@(if attrs (list attrs) '())
,@(reverse accum))
block)))))
(define (fup node paccum pblock pcont kaccum kblock kcont)
(call-with-values (lambda () (kcont kaccum kblock))
(lambda (ret block)
(if (inline-command? (car ret))
(values (cons ret paccum) (append kblock pblock) pcont)
(values paccum (append kblock (cons ret pblock)) pcont)))))
(call-with-values
(lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f))
(lambda (accum block cont)
(reverse block))))
(define (filter-empty-elements sdocbook)
"Filters out empty elements in an sdocbook nodeset. Mostly useful
after running @code{sdocbook-flatten}."
(reverse
(fold
(lambda (x rest)
(if (and (pair? x) (null? (cdr x)))
rest
(cons x rest)))
'()
sdocbook)))
(define (replace-titles sdocbook-fragment)
"Iterate over the sdocbook nodeset @var{sdocbook-fragment},
transforming contiguous @code{refsect} and @code{title} elements into
the appropriate texinfo sectioning command. Most useful after having run
@code{sdocbook-flatten}.
For example:
@example
(replace-titles '((refsect1) (title \"Foo\") (para \"Bar.\")))
@result{} '((chapter \"Foo\") (para \"Bar.\"))
@end example
"
(define sections '((refsect1 . chapter)
(refsect2 . section)
(refsect3 . subsection)
(refsect4 . subsubsection)))
(let lp ((in sdocbook-fragment) (out '()))
(cond
((null? in)
(reverse out))
((and (pair? (car in)) (assq (caar in) sections))
;; pull out the title
=> (lambda (pair)
(lp (cddr in) (cons `(,(cdr pair) ,@(cdadr in)) out))))
(else
(lp (cdr in) (cons (car in) out))))))

259
module/texinfo/html.scm Normal file
View file

@ -0,0 +1,259 @@
;;;; (texinfo html) -- translating stexinfo into shtml
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;;This module implements transformation from @code{stexi} to HTML. Note
;;that the output of @code{stexi->shtml} is actually SXML with the HTML
;;vocabulary. This means that the output can be further processed, and
;;that it must eventually be serialized by
;;@ref{sxml simple sxml->xml,sxml->xml}.
;;
;;References (i.e., the @code{@@ref} family of commands) are resolved by
;;a @dfn{ref-resolver}.
;;@xref{texinfo html add-ref-resolver!,add-ref-resolver!}, for more
;;information.
;;
;;; Code:
;; TODO: nice ref resolving API, default CSS stylesheet (esp. to remove
;; margin-top on dd > p)
(define-module (texinfo html)
:use-module (texinfo)
:use-module (sxml transform)
:use-module (srfi srfi-13)
:export (stexi->shtml add-ref-resolver! urlify))
;; The caller is responsible for carring the returned list.
(define (arg-ref key %-args)
(and=> (assq key (cdr %-args)) (lambda (x) (stexi->shtml (cdr x)))))
(define (arg-req key %-args)
(or (arg-ref key %-args)
(error "Missing argument:" key %-args)))
(define (car* x) (and x (car x)))
(define (urlify str)
(string-downcase
(string-map
(lambda (c)
(case c
((#\space #\/ #\:) #\-)
(else c)))
str)))
(define ref-resolvers
(list
(lambda (node-name manual-name) ;; the default
(urlify (string-append (or manual-name "") "#" node-name)))))
(define (add-ref-resolver! proc)
"Add @var{proc} to the head of the list of ref-resolvers. @var{proc}
will be expected to take the name of a node and the name of a manual and
return the URL of the referent, or @code{#f} to pass control to the next
ref-resolver in the list.
The default ref-resolver will return the concatenation of the manual
name, @code{#}, and the node name."
(set! ref-resolvers (cons proc ref-resolvers)))
(define (resolve-ref node manual)
(or (or-map (lambda (x) (x node manual)) ref-resolvers)
(error "Could not resolve reference" node manual)))
(define (ref tag args)
(let* ((node (car (arg-req 'node args)))
(section (or (car* (arg-ref 'section args)) node))
(manual (car* (arg-ref 'manual args)))
(target (resolve-ref node manual)))
`(span ,(and=> (assq tag '((xref "See ") (pxref "see "))) cdr)
(a (@ (href ,target)) ,section))))
(define (uref tag args)
(let ((url (car (arg-req 'url args))))
`(a (@ (href ,url)) ,(or (car* (arg-ref 'title args)) url))))
;; @!*&%( Mozilla gets confused at an empty ("<a .. />") a tag. Put an
;; empty string here to placate the reptile.
(define (node tag args)
`(a (@ (name ,(urlify (car (arg-req 'name args))))) ""))
(define (def tag args . body)
(define (code x) (and x (cons 'code x)))
(define (var x) (and x (cons 'var x)))
(define (b x) (and x (cons 'b x)))
(define (list/spaces . elts)
(let lp ((in elts) (out '()))
(cond ((null? in) (reverse! out))
((null? (car in)) (lp (cdr in) out))
(else (lp (cdr in)
(cons (car in)
(if (null? out) out (cons " " out))))))))
(define (left-td-contents)
(list/spaces (code (arg-ref 'data-type args))
(b (list (code (arg-ref 'class args)))) ;; is this right?
(b (list (code (arg-ref 'name args))))
(if (memq tag '(deftypeop deftypefn deftypefun))
(code (arg-ref 'arguments args))
(var (list (code (arg-ref 'arguments args)))))))
(let* ((category (case tag
((defun) "Function")
((defspec) "Special Form")
((defvar) "Variable")
(else (car (arg-req 'category args))))))
`(div
(table
(@ (cellpadding "0") (cellspacing "0") (width "100%") (class "def"))
(tr (td ,@(left-td-contents))
(td (div (@ (class "right")) "[" ,category "]"))))
(div (@ (class "description")) ,@body))))
(define (enumerate tag . elts)
(define (tonumber start)
(let ((c (string-ref start 0)))
(cond ((number? c) (string->number start))
(else (1+ (- (char->integer c)
(char->integer (if (char-upper-case? c) #\A #\a))))))))
`(ol ,@(if (and (pair? elts) (pair? (car elts)) (eq? (caar elts) '%))
(cons `(@ (start ,@(tonumber (arg-req 'start (car elts)))))
;; (type ,(type (arg-ref 'start (car elts)))))
(cdr elts))
elts)))
(define (table tag args . body)
(let ((formatter (caar (arg-req 'formatter args))))
(cons 'dl
(map (lambda (x)
(cond ((and (pair? x) (eq? (car x) 'dt))
(list (car x) (cons formatter (cdr x))))
(else x)))
(apply append body)))))
(define (entry tag args . body)
`((dt ,@(arg-req 'heading args))
(dd ,@body)))
(define tag-replacements
'((titlepage div (@ (class "titlepage")))
(title h2 (@ (class "title")))
(subtitle h3 (@ (class "subtitle")))
(author h3 (@ (class "author")))
(example pre)
(lisp pre)
(smallexample pre (@ (class "smaller")))
(smalllisp pre (@ (class "smaller")))
(cartouche div (@ (class "cartouche")))
(verbatim pre (@ (class "verbatim")))
(chapter h2)
(section h3)
(subsection h4)
(subsubsection h5)
(appendix h2)
(appendixsec h3)
(appendixsubsec h4)
(appendixsubsubsec h5)
(unnumbered h2)
(unnumberedsec h3)
(unnumberedsubsec h4)
(unnumberedsubsubsec h5)
(majorheading h2)
(chapheading h2)
(heading h3)
(subheading h4)
(subsubheading h5)
(quotation blockquote)
(itemize ul)
(item li) ;; itemx ?
(para p)
(*fragment* div) ;; should be ok
(asis span)
(bold b)
(sample samp)
(samp samp)
(code code)
(kbd kbd)
(key code (@ (class "key")))
(var var)
(env code (@ (class "env")))
(file code (@ (class "file")))
(command code (@ (class "command")))
(option code (@ (class "option")))
(url code (@ (class "url")))
(dfn dfn)
(cite cite)
(acro acronym)
(email code (@ (class "email")))
(emph em)
(strong strong)
(sc span (@ (class "small-caps")))))
(define ignore-list
'(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip
menu ignore syncodeindex comment c dircategory direntry top shortcontents
cindex printindex))
(define (ignored? tag)
(memq tag ignore-list))
(define rules
`((% *preorder* . ,(lambda args args)) ;; Keep these around...
(texinfo . ,(lambda (tag args . body)
(pre-post-order
`(html
(@ (xmlns "http://www.w3.org/1999/xhtml"))
(head (title ,(car (arg-req 'title args))))
(body ,@body))
`((% *preorder* . ,(lambda args #f)) ;; ... filter out.
(*text* . ,(lambda (tag x) x))
(*default* . ,(lambda (tag . body)
(cons tag body)))))))
(copyright . ,(lambda args '(*ENTITY* "copy")))
(result . ,(lambda args '(*ENTITY* "rArr")))
(xref . ,ref) (ref . ,ref) (pxref . ,ref)
(uref . ,uref)
(node . ,node) (anchor . ,node)
(table . ,table)
(enumerate . ,enumerate)
(entry . ,entry)
(deftp . ,def) (defcv . ,def) (defivar . ,def) (deftypeivar . ,def)
(defop . ,def) (deftypeop . ,def) (defmethod . ,def)
(deftypemethod . ,def) (defopt . ,def) (defvr . ,def) (defvar . ,def)
(deftypevr . ,def) (deftypevar . ,def) (deffn . ,def)
(deftypefn . ,def) (defmac . ,def) (defspec . ,def) (defun . ,def)
(deftypefun . ,def)
(ifnottex . ,(lambda (tag . body) body))
(*text* . ,(lambda (tag x) x))
(*default* . ,(lambda (tag . body)
(let ((subst (assq tag tag-replacements)))
(cond
(subst (append (cdr subst) body))
((memq tag ignore-list) #f)
(else
(warn "Don't know how to convert" tag "to HTML")
body)))))))
(define (stexi->shtml tree)
"Transform the stexi @var{tree} into shtml, resolving references via
ref-resolvers. See the module commentary for more details."
(pre-post-order tree rules))
;;; arch-tag: ab05f3fe-9981-4a78-b64c-48efcd9983a6

78
module/texinfo/indexing.scm Normal file
View file

@ -0,0 +1,78 @@
;;;; (texinfo indexing) -- indexing stexinfo
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;;@c texinfo formatting
;;Given a piece of stexi, return an index of a specified variety.
;;
;;Note that currently, @code{stexi-extract-index} doesn't differentiate
;;between different kinds of index entries. That's a bug ;)
;;; Code:
(define-module (texinfo indexing)
#:use-module (sxml simple)
#:use-module (srfi srfi-13)
#:export (stexi-extract-index))
(define (def-name def)
(cadr (assq 'name (cdadr def))))
(define defines
'(deftp defcv defivar deftypeivar defop deftypeop defmethod
deftypemethod defopt defvr defvar deftypevr deftypevar deffn
deftypefn defspec defmac defun deftypefun))
(define indices
'(cindex findex vindex kindex pindex tindex))
(define (stexi-extract-index tree manual-name kind)
"Given an stexi tree @var{tree}, index all of the entries of type
@var{kind}. @var{kind} can be one of the predefined texinfo indices
(@code{concept}, @code{variable}, @code{function}, @code{key},
@code{program}, @code{type}) or one of the special symbols @code{auto}
or @code{all}. @code{auto} will scan the stext for a @code{(printindex)}
statement, and @code{all} will generate an index from all entries,
regardless of type.
The returned index is a list of pairs, the @sc{car} of which is the
entry (a string) and the @sc{cdr} of which is a node name (a string)."
(let loop ((in tree) (entries '()))
(cond
((null? in)
entries)
((pair? (car in))
(cond
((and (pair? (cdr in)) (pair? (cadr in))
(eq? (caar in) 'anchor) (memq (caadr in) defines))
(loop (cddr in) (acons (cadr (assq 'name (cdr (cadadr in))))
(cadr (assq 'name (cdadar in)))
entries)))
((and (pair? (cdr in)) (pair? (cadr in))
(eq? (caar in) 'anchor) (memq (caadr in) indices))
(loop (cddr in) (acons (sxml->string (cadr in))
(cadr (assq 'name (cdadar in)))
entries)))
(else
(loop (cdr in) (loop (car in) entries)))))
(else
(loop (cdr in) entries)))))
;;; arch-tag: 216d29d3-1ed9-433f-9c19-0dc4d6b439b6

319
module/texinfo/plain-text.scm Normal file
View file

@ -0,0 +1,319 @@
;;;; (texinfo plain-text) -- rendering stexinfo as plain text
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;;Transformation from stexi to plain-text. Strives to re-create the
;;output from @code{info}; comes pretty damn close.
;;
;;; Code:
(define-module (texinfo plain-text)
#:use-module (texinfo)
#:use-module (texinfo string-utils)
#:use-module (sxml transform)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:export (stexi->plain-text))
;; The return value is a string.
(define (arg-ref key %-args)
(and=> (and=> (assq key (cdr %-args)) cdr)
stexi->plain-text))
(define (arg-req key %-args)
(or (arg-ref key %-args)
(error "Missing argument:" key %-args)))
(define *indent* (make-fluid))
(define *itemizer* (make-fluid))
(define (make-ticker str)
(lambda () str))
(define (make-enumerator n)
(lambda ()
(let ((last n))
(set! n (1+ n))
(format #f "~A. " last))))
(fluid-set! *indent* "")
;; Shouldn't be necessary to do this, but just in case.
(fluid-set! *itemizer* (make-ticker "* "))
(define-macro (with-indent n . body)
`(with-fluids ((*indent* (string-append (fluid-ref *indent*)
(make-string ,n #\space))))
,@body))
(define (make-indenter n proc)
(lambda args (with-indent n (apply proc args))))
(define (string-indent str)
(string-append (fluid-ref *indent*) str "\n"))
(define-macro (with-itemizer itemizer . body)
`(with-fluids ((*itemizer* ,itemizer))
,@body))
(define (wrap* . strings)
(let ((indent (fluid-ref *indent*)))
(fill-string (string-concatenate strings)
#:line-width 72 #:initial-indent indent
#:subsequent-indent indent)))
(define (wrap . strings)
(string-append (apply wrap* strings) "\n\n"))
(define (wrap-heading . strings)
(string-append (apply wrap* strings) "\n"))
(define (ref tag args)
(let* ((node (arg-req 'node args))
(name (or (arg-ref 'name args) node))
(manual (arg-ref 'manual args)))
(string-concatenate
(cons*
(or (and=> (assq tag '((xref "See ") (pxref "see "))) cadr) "")
name
(if manual `(" in manual " ,manual) '())))))
(define (uref tag args)
(let ((url (arg-req 'url args))
(title (arg-ref 'title args)))
(if title
(string-append title " (" url ")")
(string-append "`" url "'"))))
(define (def tag args . body)
(define (list/spaces . elts)
(let lp ((in elts) (out '()))
(cond ((null? in) (reverse! out))
((null? (car in)) (lp (cdr in) out))
(else (lp (cdr in)
(cons (car in)
(if (null? out) out (cons " " out))))))))
(define (first-line)
(string-join
(filter identity
(map (lambda (x) (arg-ref x args))
'(data-type class name arguments)))
" "))
(let* ((category (case tag
((defun) "Function")
((defspec) "Special Form")
((defvar) "Variable")
(else (arg-req 'category args)))))
(string-append
(wrap-heading (string-append " - " category ": " (first-line)))
(with-indent 5 (stexi->plain-text body)))))
(define (enumerate tag . elts)
(define (tonumber start)
(let ((c (string-ref start 0)))
(cond ((number? c) (string->number start))
(else (1+ (- (char->integer c)
(char->integer (if (char-upper-case? c) #\A #\a))))))))
(let* ((args? (and (pair? elts) (pair? (car elts))
(eq? (caar elts) '%)))
(start (and args? (arg-ref 'start (car elts)))))
(with-itemizer (make-enumerator (if start (tonumber start) 1))
(with-indent 5
(stexi->plain-text (if start (cdr elts) elts))))))
(define (itemize tag args . elts)
(with-itemizer (make-ticker "* ")
(with-indent 5
(stexi->plain-text elts))))
(define (item tag . elts)
(let* ((ret (stexi->plain-text elts))
(tick ((fluid-ref *itemizer*)))
(tick-pos (- (string-length (fluid-ref *indent*))
(string-length tick))))
(if (and (not (string-null? ret)) (not (negative? tick-pos)))
(string-copy! ret tick-pos tick))
ret))
(define (table tag args . body)
(stexi->plain-text body))
(define (entry tag args . body)
(let ((heading (wrap-heading
(stexi->plain-text (arg-req 'heading args)))))
(string-append heading
(with-indent 5 (stexi->plain-text body)))))
(define (make-underliner char)
(lambda (tag . body)
(let ((str (stexi->plain-text body)))
(string-append
"\n"
(string-indent str)
(string-indent (make-string (string-length str) char))
"\n"))))
(define chapter (make-underliner #\*))
(define section (make-underliner #\=))
(define subsection (make-underliner #\-))
(define subsubsection (make-underliner #\.))
(define (example tag . body)
(let ((ret (stexi->plain-text body)))
(string-append
(string-concatenate
(with-indent 5 (map string-indent (string-split ret #\newline))))
"\n")))
(define (verbatim tag . body)
(let ((ret (stexi->plain-text body)))
(string-append
(string-concatenate
(map string-indent (string-split ret #\newline)))
"\n")))
(define (fragment tag . body)
(string-concatenate (map-in-order stexi->plain-text body)))
(define (para tag . body)
(wrap (stexi->plain-text body)))
(define (make-surrounder str)
(lambda (tag . body)
(string-append str (stexi->plain-text body) str)))
(define (code tag . body)
(string-append "`" (stexi->plain-text body) "'"))
(define (key tag . body)
(string-append "<" (stexi->plain-text body) ">"))
(define (var tag . body)
(string-upcase (stexi->plain-text body)))
(define (passthrough tag . body)
(stexi->plain-text body))
(define (ignore . args)
"")
(define (texinfo tag args . body)
(let ((title (chapter 'foo (arg-req 'title args))))
(string-append title (stexi->plain-text body))))
(define ignore-list
'(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip
menu ignore syncodeindex comment c % node anchor))
(define (ignored? tag)
(memq tag ignore-list))
(define tag-handlers
`((title ,chapter)
(chapter ,chapter)
(section ,section)
(subsection ,subsection)
(subsubsection ,subsubsection)
(appendix ,chapter)
(appendixsec ,section)
(appendixsubsec ,subsection)
(appendixsubsubsec ,subsubsection)
(unnumbered ,chapter)
(unnumberedsec ,section)
(unnumberedsubsec ,subsection)
(unnumberedsubsubsec ,subsubsection)
(majorheading ,chapter)
(chapheading ,chapter)
(heading ,section)
(subheading ,subsection)
(subsubheading ,subsubsection)
(strong ,(make-surrounder "*"))
(sample ,code)
(samp ,code)
(code ,code)
(kbd ,code)
(key ,key)
(var ,var)
(env ,code)
(file ,code)
(command ,code)
(option ,code)
(url ,code)
(dfn ,(make-surrounder "\""))
(cite ,(make-surrounder "\""))
(acro ,passthrough)
(email ,key)
(emph ,(make-surrounder "_"))
(sc ,var)
(copyright ,(lambda args "(C)"))
(result ,(lambda args "==>"))
(xref ,ref)
(ref ,ref)
(pxref ,ref)
(uref ,uref)
(texinfo ,texinfo)
(quotation ,(make-indenter 5 para))
(itemize ,itemize)
(enumerate ,enumerate)
(item ,item)
(table ,table)
(entry ,entry)
(example ,example)
(lisp ,example)
(smallexample ,example)
(smalllisp ,example)
(verbatim ,verbatim)
(*fragment* ,fragment)
(deftp ,def)
(defcv ,def)
(defivar ,def)
(deftypeivar ,def)
(defop ,def)
(deftypeop ,def)
(defmethod ,def)
(deftypemethod ,def)
(defopt ,def)
(defvr ,def)
(defvar ,def)
(deftypevr ,def)
(deftypevar ,def)
(deffn ,def)
(deftypefn ,def)
(defmac ,def)
(defspec ,def)
(defun ,def)
(deftypefun ,def)))
(define (stexi->plain-text tree)
"Transform @var{tree} into plain text. Returns a string."
(cond
((null? tree) "")
((string? tree) tree)
((pair? tree)
(cond
((symbol? (car tree))
(let ((handler (and (not (ignored? (car tree)))
(or (and=> (assq (car tree) tag-handlers) cadr)
para))))
(if handler (apply handler tree) "")))
(else
(string-concatenate (map-in-order stexi->plain-text tree)))))
(else "")))
;;; arch-tag: f966c3f6-3b46-4790-bbf9-3ad27e4917c2

528
module/texinfo/reflection.scm Normal file
View file

@ -0,0 +1,528 @@
;;;; (texinfo reflection) -- documenting Scheme as stexinfo
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;;Routines to generare @code{stexi} documentation for objects and
;;modules.
;;
;;Note that in this context, an @dfn{object} is just a value associated
;;with a location. It has nothing to do with GOOPS.
;;
;;; Code:
(define-module (texinfo reflection)
#:use-module ((srfi srfi-1) #:select (append-map))
#:use-module (oop goops)
#:use-module (texinfo)
#:use-module (texinfo plain-text)
#:use-module (srfi srfi-13)
#:use-module (ice-9 session)
#:use-module (ice-9 documentation)
#:use-module (ice-9 optargs)
#:use-module ((sxml transform) #:select (pre-post-order))
#:export (module-stexi-documentation
script-stexi-documentation
object-stexi-documentation
package-stexi-standard-copying
package-stexi-standard-titlepage
package-stexi-generic-menu
package-stexi-standard-menu
package-stexi-extended-menu
package-stexi-standard-prologue
package-stexi-documentation))
;; List for sorting the definitions in a module
(define defs
'(deftp defcv defivar deftypeivar defop deftypeop defmethod
deftypemethod defopt defvr defvar deftypevr deftypevar deffn
deftypefn defmac defspec defun deftypefun))
(define (sort-defs ordering a b)
(define (def x)
;; a and b are lists of the form ((anchor ...) (def* ...)...)
(cadr x))
(define (name x)
(cadr (assq 'name (cdadr (def x)))))
(define (priority x)
(list-index defs (car (def x))))
(define (order x)
(or (list-index ordering (string->symbol (name x)))
;; if the def is not in the list, a big number
1234567890))
(define (compare-in-order proc eq? < . args)
(if (not (eq? (proc a) (proc b)))
(< (proc a) (proc b))
(or (null? args)
(apply compare-in-order args))))
(compare-in-order order = <
priority = <
name string=? string<=?))
(define (list*-join l infix restfix)
(let lp ((in l) (out '()))
(cond ((null? in) (reverse! out))
((symbol? in) (reverse! (cons* in restfix out)))
(else (lp (cdr in) (if (null? out)
(list (car in))
(cons* (car in) infix out)))))))
(define (process-args args)
(map (lambda (x) (if (symbol? x) (symbol->string x) x))
(list*-join (or args '())
" " " . ")))
(define (get-proc-args proc)
(cond
((procedure-property proc 'arglist)
=> (lambda (arglist)
(let ((required-args (car arglist))
(optional-args (cadr arglist))
(keyword-args (caddr arglist))
(rest-arg (car (cddddr arglist))))
(process-args
(append
;; start with the required args...
(map symbol->string required-args)
;; add any optional args if needed...
(map (lambda (a)
(if (list? a)
(format #f "[~a = ~s]" (car a) (cadr a))
(format #f "[~a]" a)))
optional-args)
;; now the keyword args..
(map (lambda (a)
(if (list? a)
(format #f "[#:~a = ~s]" (car a) (cadr a))
(format #f "[#:~a]" a)))
keyword-args)
;; now the rest arg...
(if rest-arg
(list "." (symbol->string rest-arg))
'()))))))
(else
(process-args (and=> (procedure-source proc) cadr)))))
;; like the normal false-if-exception, but doesn't affect the-last-stack
(define-macro (false-if-exception exp)
`(catch #t
(lambda ()
(with-fluids ((the-last-stack (fluid-ref the-last-stack)))
,exp))
(lambda args #f)))
;; This is really nasty, I wish guile gave a better way to get this...
(define (get-macro-args macro)
(process-args
(case (macro-type macro)
((syncase-macro)
(case (syncase-macro-type macro)
((macro)
(get-proc-args (car (syncase-macro-binding macro))))
(else #f)))
(else #f))))
(define many-space? (make-regexp "[[:space:]][[:space:]][[:space:]]"))
(define initial-space? (make-regexp "^[[:space:]]"))
(define (string->stexi str)
(or (and (or (not str) (string-null? str))
'(*fragment*))
(and (or (string-index str #\@)
(and (not (regexp-exec many-space? str))
(not (regexp-exec initial-space? str))))
(false-if-exception
(texi-fragment->stexi str)))
`(*fragment* (verbatim ,str))))
(define method-formals
(and (defined? 'method-formals) method-formals))
(define (method-stexi-arguments method)
(cond
(method-formals
(let lp ((formals (method-formals method))
(specializers (method-specializers method))
(out '()))
(define (arg-texinfo formal specializer)
`(" (" (var ,(symbol->string formal)) " "
(code ,(symbol->string (class-name specializer))) ")"))
(cond
((null? formals) (reverse out))
((pair? formals)
(lp (cdr formals) (cdr specializers)
(append (reverse (arg-texinfo (car formals) (car specializers)))
out)))
(else
(append (reverse out) (arg-texinfo formals specializers)
(list "..."))))))
((method-source method)
(let lp ((bindings (cadr (method-source method))) (out '()))
(define (arg-texinfo arg)
`(" (" (var ,(symbol->string (car arg))) " "
(code ,(symbol->string (cadr arg))) ")"))
(cond
((null? bindings)
(reverse out))
((not (pair? (car bindings)))
(append (reverse out) (arg-texinfo bindings) (list "...")))
(else
(lp (cdr bindings)
(append (reverse (arg-texinfo (car bindings))) out))))))
(else (warn method) '())))
(define* (object-stexi-documentation object #:optional (name "[unknown]")
#:key (force #f))
(if (symbol? name)
(set! name (symbol->string name)))
(let ((stexi ((lambda (x)
(cond ((string? x) (string->stexi x))
((and (pair? x) (eq? (car x) '*fragment*)) x)
(force `(*fragment*))
(else #f)))
(object-documentation
(if (is-a? object <method>)
(method-procedure object)
object)))))
(define (make-def type args)
`(,type (% ,@args) ,@(cdr stexi)))
(cond
((not stexi) #f)
;; stexi is now a list, headed by *fragment*.
((and (pair? (cdr stexi)) (pair? (cadr stexi))
(memq (caadr stexi) defs))
;; it's already a deffoo.
stexi)
((is-a? object <class>)
(make-def 'deftp `((name ,name)
(category "Class"))))
((is-a? object <macro>)
(make-def 'defspec `((name ,name)
(arguments ,@(get-macro-args object)))))
((is-a? object <procedure>)
(make-def 'defun `((name ,name)
(arguments ,@(get-proc-args object)))))
((is-a? object <method>)
(make-def 'deffn `((category "Method")
(name ,name)
(arguments ,@(method-stexi-arguments object)))))
((is-a? object <generic>)
`(*fragment*
,(make-def 'deffn `((name ,name)
(category "Generic")))
,@(map
(lambda (method)
(object-stexi-documentation method name #:force force))
(generic-function-methods object))))
(else
(make-def 'defvar `((name ,name)))))))
(define (module-name->node-name sym-name)
(string-join (map symbol->string sym-name) " "))
;; this copied from (ice-9 session); need to find a better way
(define (module-filename name)
(let* ((name (map symbol->string name))
(reverse-name (reverse name))
(leaf (car reverse-name))
(dir-hint-module-name (reverse (cdr reverse-name)))
(dir-hint (apply string-append
(map (lambda (elt)
(string-append elt "/"))
dir-hint-module-name))))
(%search-load-path (in-vicinity dir-hint leaf))))
(define (read-module name)
(let ((filename (module-filename name)))
(if filename
(let ((port (open-input-file filename)))
(let lp ((out '()) (form (read port)))
(if (eof-object? form)
(reverse out)
(lp (cons form out) (read port)))))
'())))
(define (module-export-list sym-name)
(define (module-form-export-list form)
(and (pair? form)
(eq? (car form) 'define-module)
(equal? (cadr form) sym-name)
(and=> (memq #:export (cddr form)) cadr)))
(let lp ((forms (read-module sym-name)))
(cond ((null? forms) '())
((module-form-export-list (car forms)) => identity)
(else (lp (cdr forms))))))
(define* (module-stexi-documentation sym-name
#:optional (docs-resolver
(lambda (name def) def)))
"Return documentation for the module named @var{sym-name}. The
documentation will be formatted as @code{stexi}
(@pxref{texinfo,texinfo})."
(let* ((commentary (and=> (module-commentary sym-name)
(lambda (x) (string-trim-both x #\newline))))
(stexi (string->stexi commentary))
(node-name (module-name->node-name sym-name))
(name-str (with-output-to-string
(lambda () (display sym-name))))
(module (resolve-interface sym-name))
(export-list (module-export-list sym-name)))
(define (anchor-name sym)
(string-append node-name " " (symbol->string sym)))
(define (make-defs)
(sort!
(module-map
(lambda (sym var)
`((anchor (% (name ,(anchor-name sym))))
,@((lambda (x)
(if (eq? (car x) '*fragment*)
(cdr x)
(list x)))
(if (variable-bound? var)
(docs-resolver
sym
(object-stexi-documentation (variable-ref var) sym
#:force #t))
(begin
(warn "variable unbound!" sym)
`(defvar (% (name ,(symbol->string sym)))
"[unbound!]"))))))
module)
(lambda (a b) (sort-defs export-list a b))))
`(texinfo (% (title ,name-str))
(node (% (name ,node-name)))
(section "Overview")
,@(cdr stexi)
(section "Usage")
,@(apply append! (make-defs)))))
(define (script-stexi-documentation scriptpath)
"Return documentation for given script. The documentation will be
taken from the script's commentary, and will be returned in the
@code{stexi} format (@pxref{texinfo,texinfo})."
(let ((commentary (file-commentary scriptpath)))
`(texinfo (% (title ,(basename scriptpath)))
(node (% (name ,(basename scriptpath))))
,@(if commentary
(cdr
(string->stexi
(string-trim-both commentary #\newline)))
'()))))
(cond
((defined? 'add-value-help-handler!)
(add-value-help-handler!
(lambda (name value)
(stexi->plain-text
(object-stexi-documentation value name #:force #t))))
(add-name-help-handler!
(lambda (name)
(and (list? name)
(and-map symbol? name)
(stexi->plain-text (module-stexi-documentation name)))))))
;; we could be dealing with an old (ice-9 session); fondle it to get
;; module-commentary
(define module-commentary (@@ (ice-9 session) module-commentary))
(define (package-stexi-standard-copying name version updated years
copyright-holder permissions)
"Create a standard texinfo @code{copying} section.
@var{years} is a list of years (as integers) in which the modules
being documented were released. All other arguments are strings."
`(copying
(para "This manual is for " ,name
" (version " ,version ", updated " ,updated ")")
(para "Copyright " ,(string-join (map number->string years) ",")
" " ,copyright-holder)
(quotation
(para ,permissions))))
(define (package-stexi-standard-titlepage name version updated authors)
"Create a standard GNU title page.
@var{authors} is a list of @code{(@var{name} . @var{email})}
pairs. All other arguments are strings.
Here is an example of the usage of this procedure:
@smallexample
(package-stexi-standard-titlepage
\"Foolib\"
\"3.2\"
\"26 September 2006\"
'((\"Alyssa P Hacker\" . \"alyssa@@example.com\"))
'(2004 2005 2006)
\"Free Software Foundation, Inc.\"
\"Standard GPL permissions blurb goes here\")
@end smallexample
"
`(;(setchapternewpage (% (all "odd"))) makes manuals too long
(titlepage
(title ,name)
(subtitle "version " ,version ", updated " ,updated)
,@(map (lambda (pair)
`(author ,(car pair)
" (" (email ,(cdr pair)) ")"))
authors)
(page)
(vskip (% (all "0pt plus 1filll")))
(insertcopying))))
(define (package-stexi-generic-menu name entries)
"Create a menu from a generic alist of entries, the car of which
should be the node name, and the cdr the description. As an exception,
an entry of @code{#f} will produce a separator."
(define (make-entry node description)
`("* " ,node "::"
,(make-string (max (- 21 (string-length node)) 2) #\space)
,@description "\n"))
`((ifnottex
(node (% (name "Top")))
(top (% (title ,name)))
(insertcopying)
(menu
,@(apply
append
(map
(lambda (entry)
(if entry
(make-entry (car entry) (cdr entry))
'("\n")))
entries))))
(iftex
(shortcontents))))
(define (package-stexi-standard-menu name modules module-descriptions
extra-entries)
"Create a standard top node and menu, suitable for processing
by makeinfo."
(package-stexi-generic-menu
name
(let ((module-entries (map cons
(map module-name->node-name modules)
module-descriptions))
(separate-sections (lambda (x) (if (null? x) x (cons #f x)))))
`(,@module-entries
,@(separate-sections extra-entries)))))
(define (package-stexi-extended-menu name module-pairs script-pairs
extra-entries)
"Create an \"extended\" menu, like the standard menu but with a
section for scripts."
(package-stexi-generic-menu
name
(let ((module-entries (map cons
(map module-name->node-name
(map car module-pairs))
(map cdr module-pairs)))
(script-entries (map cons
(map basename (map car script-pairs))
(map cdr script-pairs)))
(separate-sections (lambda (x) (if (null? x) x (cons #f x)))))
`(,@module-entries
,@(separate-sections script-entries)
,@(separate-sections extra-entries)))))
(define (package-stexi-standard-prologue name filename category
description copying titlepage
menu)
"Create a standard prologue, suitable for later serialization
to texinfo and .info creation with makeinfo.
Returns a list of stexinfo forms suitable for passing to
@code{package-stexi-documentation} as the prologue. @xref{texinfo
reflection package-stexi-documentation}, @ref{texinfo reflection
package-stexi-standard-titlepage,package-stexi-standard-titlepage},
@ref{texinfo reflection
package-stexi-standard-copying,package-stexi-standard-copying},
and @ref{texinfo reflection
package-stexi-standard-menu,package-stexi-standard-menu}."
`(,copying
(dircategory (% (category ,category)))
(direntry
"* " ,name ": (" ,filename "). " ,description ".")
,@titlepage
,@menu))
(define (stexi->chapter stexi)
(pre-post-order
stexi
`((texinfo . ,(lambda (tag attrs node . body)
`(,node
(chapter ,@(assq-ref (cdr attrs) 'title))
,@body)))
(*text* . ,(lambda (tag text) text))
(*default* . ,(lambda args args)))))
(define* (package-stexi-documentation modules name filename
prologue epilogue
#:key
(module-stexi-documentation-args
'())
(scripts '()))
"Create stexi documentation for a @dfn{package}, where a
package is a set of modules that is released together.
@var{modules} is expected to be a list of module names, where a
module name is a list of symbols. The stexi that is returned will
be titled @var{name} and a texinfo filename of @var{filename}.
@var{prologue} and @var{epilogue} are lists of stexi forms that
will be spliced into the output document before and after the
generated modules documentation, respectively.
@xref{texinfo reflection package-stexi-standard-prologue}, to
create a conventional GNU texinfo prologue.
@var{module-stexi-documentation-args} is an optional argument that, if
given, will be added to the argument list when
@code{module-texi-documentation} is called. For example, it might be
useful to define a @code{#:docs-resolver} argument."
(define (verify-modules-list l)
(define (all pred l)
(and (pred (car l))
(or (null? (cdr l)) (all pred (cdr l)))))
(false-if-exception
(all (lambda (x) (all symbol? x)) modules)))
(if (not (verify-modules-list modules))
(error "expected modules to be a list of a list of symbols"
modules))
`(texinfo
(% (title ,name)
(filename ,filename))
,@prologue
,@(append-map (lambda (mod)
(stexi->chapter
(apply module-stexi-documentation
mod module-stexi-documentation-args)))
modules)
,@(append-map (lambda (script)
(stexi->chapter
(script-stexi-documentation script)))
scripts)
,@epilogue))
;;; arch-tag: bbe2bc03-e16d-4a9e-87b9-55225dc9836c

263
module/texinfo/serialize.scm Normal file
View file

@ -0,0 +1,263 @@
;;;; (texinfo serialize) -- rendering stexinfo as texinfo
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;;Serialization of @code{stexi} to plain texinfo.
;;
;;; Code:
(define-module (texinfo serialize)
#:use-module (texinfo)
#:use-module (texinfo string-utils)
#:use-module (sxml transform)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:export (stexi->texi))
(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)))))))
;; converts improper lists to proper lists.
(define (filter* pred l)
(let lp ((in l) (out '()))
(cond ((null? in)
(reverse! out))
((pair? in)
(lp (cdr in) (if (pred (car in)) (cons (car in) out) out)))
(else
(lp '() (if (pred in) (cons in out) out))))))
;; (list* 'a '(b c) 'd '(e f g)) => '(a b c d e f g)
(define (list* . args)
(let* ((args (reverse args))
(tail (car args)))
(let lp ((in (cdr args)) (out tail))
(cond ((null? in) out)
((pair? (car in)) (lp (cdr in) (append (car in) out)))
((null? (car in)) (lp (cdr in) out))
(else (lp (cdr in) (cons (car in) out)))))))
;; Why? Well, because syntax-case defines `include', and carps about its
;; wrong usage below...
(eval-when (eval load compile)
(define (include exp lp command type formals args accum)
(list* "\n"
(list-intersperse
args
" ")
" " command "@" accum)))
(define (empty-command exp lp command type formals args accum)
(list* " " command "@" accum))
(define (inline-text exp lp command type formals args accum)
(if (not (string=? command "*braces*")) ;; fixme :(
(list* "}"
(append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
"{" command "@" accum)
(list* "@}"
(append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
"@{" accum)))
(define (inline-args exp lp command type formals args accum)
(list* "}"
(if (not args) ""
(list-intersperse
(map
(lambda (x)
(cond ((not x) "")
((pair? x)
(if (pair? (cdr x))
(warn "Strange inline-args!" args))
(car x))
(else (error "Invalid inline-args" args))))
(drop-while not
(map (lambda (x) (assq-ref args x))
(reverse formals))))
","))
"{" command "@" accum))
(define (serialize-text-args lp formals args)
(apply
append
(list-intersperse
(map (lambda (arg) (append-map (lambda (x) (lp x '())) arg))
(map
reverse
(drop-while
not (map (lambda (x) (assq-ref args x))
(reverse formals)))))
'(" "))))
(define (eol-text-args exp lp command type formals args accum)
(list* "\n"
(serialize-text-args lp formals args)
" " command "@" accum))
(define (eol-text exp lp command type formals args accum)
(list* "\n"
(append-map (lambda (x) (lp x '()))
(reverse (if args (cddr exp) (cdr exp))))
" " command "@" accum))
(define (eol-args exp lp command type formals args accum)
(list* "\n"
(list-intersperse
(apply append
(drop-while not
(map (lambda (x) (assq-ref args x))
(reverse formals))))
", ")
" " command "@" accum))
(define (environ exp lp command type formals args accum)
(case (car exp)
((texinfo)
(list* "@bye\n"
(append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
"\n@c %**end of header\n\n"
(reverse (assq-ref args 'title)) "@settitle "
(or (and=> (assq-ref args 'filename)
(lambda (filename)
(cons "\n" (reverse (cons "@setfilename " filename)))))
"")
"\\input texinfo @c -*-texinfo-*-\n@c %**start of header\n"
accum))
(else
(list* "\n\n" command "@end "
(let ((body (append-map (lambda (x) (lp x '()))
(reverse (if args (cddr exp) (cdr exp))))))
(if (or (null? body)
(eqv? (string-ref (car body)
(1- (string-length (car body))))
#\newline))
body
(cons "\n" body)))
"\n"
(serialize-text-args lp formals args)
" " command "@" accum))))
(define (table-environ exp lp command type formals args accum)
(list* "\n\n" command "@end "
(append-map (lambda (x) (lp x '()))
(reverse (if args (cddr exp) (cdr exp))))
"\n"
(let* ((arg (if args (cadar args) ""))) ;; zero or one args
(if (pair? arg)
(list (symbol->string (car arg)) "@")
arg))
" " command "@" accum))
(define (wrap strings)
(fill-string (string-concatenate strings)
#:line-width 72))
(define (paragraph exp lp command type formals args accum)
(list* "\n\n"
(wrap
(reverse
(append-map (lambda (x) (lp x '())) (reverse (cdr exp)))))
accum))
(define (item exp lp command type formals args accum)
(list* (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
"@item\n"
accum))
(define (entry exp lp command type formals args accum)
(list* (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
"\n"
(append-map (lambda (x) (lp x '())) (reverse (cdar args)))
"@item "
accum))
(define (fragment exp lp command type formals args accum)
(list* "\n@c %end of fragment\n"
(append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
"\n@c %start of fragment\n\n"
accum))
(define serializers
`((EMPTY-COMMAND . ,empty-command)
(INLINE-TEXT . ,inline-text)
(INLINE-ARGS . ,inline-args)
(EOL-TEXT . ,eol-text)
(EOL-TEXT-ARGS . ,eol-text-args)
(INDEX . ,eol-text-args)
(EOL-ARGS . ,eol-args)
(ENVIRON . ,environ)
(TABLE-ENVIRON . ,table-environ)
(ENTRY . ,entry)
(ITEM . ,item)
(PARAGRAPH . ,paragraph)
(FRAGMENT . ,fragment)
(#f . ,include))) ; support writing include statements
(define (serialize exp lp command type formals args accum)
((or (assq-ref serializers type)
(error "Unknown command type" exp type))
exp lp command type formals args accum))
(define escaped-chars '(#\} #\{ #\@))
(define (escape str)
"Escapes any illegal texinfo characters (currently @{, @}, and @@)."
(let loop ((in (string->list str)) (out '()))
(if (null? in)
(apply string (reverse out))
(if (memq (car in) escaped-chars)
(loop (cdr in) (cons* (car in) #\@ out))
(loop (cdr in) (cons (car in) out))))))
(define (stexi->texi tree)
"Serialize the stexi @var{tree} into plain texinfo."
(string-concatenate-reverse
(let lp ((in tree) (out '()))
(cond
((or (not in) (null? in)) out)
((string? in) (cons (escape in) out))
((pair? in)
(let ((command-spec (assq (car in) texi-command-specs)))
(if (not command-spec)
(begin
(warn "Unknown stexi command, not rendering" in)
out)
(serialize in
lp
(symbol->string (car in))
(cadr command-spec)
(filter* symbol? (cddr command-spec))
(cond
((and (pair? (cdr in)) (pair? (cadr in))
(eq? (caadr in) '%))
(cdadr in))
((not (cadr command-spec))
;; include
(cdr in))
(else
#f))
out))))
(else
(error "Invalid stexi" in))))))
;;; arch-tag: d3fa16ea-0bf7-4ec5-ab9f-3f08490f77f5

400
module/texinfo/string-utils.scm Normal file
View file

@ -0,0 +1,400 @@
;;;; (texinfo string-utils) -- text filling and wrapping
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 2003 Richard Todd
;;;;
;;;; 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 3 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;; Module @samp{(texinfo string-utils)} provides various string-related
;; functions useful to Guile's texinfo support.
;;; Code:
(define-module (texinfo string-utils)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-14)
#:use-module (oop goops)
#:export (escape-special-chars
transform-string
expand-tabs
center-string
left-justify-string
right-justify-string
collapse-repeated-chars
make-text-wrapper
fill-string
string->wrapped-lines))
(define* (transform-string str match? replace #:optional (start #f) (end #f))
"Uses @var{match?} against each character in @var{str}, and performs a
replacement on each character for which matches are found.
@var{match?} may either be a function, a character, a string, or
@code{#t}. If @var{match?} is a function, then it takes a single
character as input, and should return @samp{#t} for matches.
@var{match?} is a character, it is compared to each string character
using @code{char=?}. If @var{match?} is a string, then any character
in that string will be considered a match. @code{#t} will cause
every character to be a match.
If @var{replace} is a function, it is called with the matched
character as an argument, and the returned value is sent to the output
string via @samp{display}. If @var{replace} is anything else, it is
sent through the output string via @samp{display}.
Note that te replacement for the matched characters does not need to
be a single character. That is what differentiates this function from
@samp{string-map}, and what makes it useful for applications such as
converting @samp{#\\&} to @samp{\"&amp;\"} in web page text. Some other
functions in this module are just wrappers around common uses of
@samp{transform-string}. Transformations not possible with this
function should probably be done with regular expressions.
If @var{start} and @var{end} are given, they control which portion
of the string undergoes transformation. The entire input string
is still output, though. So, if @var{start} is @samp{5}, then the
first five characters of @var{str} will still appear in the returned
string.
@lisp
; these two are equivalent...
(transform-string str #\\space #\\-) ; change all spaces to -'s
(transform-string str (lambda (c) (char=? #\\space c)) #\\-)
@end lisp"
;; I had implemented this with string-fold, but it was
;; slower...
(let* ((os (open-output-string))
(matcher (cond ((char? match?)
(lambda (c) (char=? match? c)))
((procedure? match?)
match?)
((string? match?)
(lambda (c) (string-index match? c)))
((boolean? match?)
(lambda (c) match?))
(else (throw 'bad-type "expected #t, char, string, or procedure"))))
(replacer (if (procedure? replace)
(lambda (c) (display (replace c) os))
(lambda (c) (display replace os)))))
;; put the first part in, un-transformed if they asked for it...
(if (and start (<= start (string-length str)))
(display (substring str 0 start) os))
;; process the portion they want processed....
(string-for-each
(lambda (c)
(if (matcher c)
;; we have a match! replace the char as directed...
(replacer c)
;; not a match, just insert the character itself...
(write-char c os)))
str
(or start 0)
(or end (string-length str)))
;; if there was any at the end, tack it on...
(if (and end (< end (string-length str)))
(display (substring str end) os))
(get-output-string os)))
(define* (expand-tabs str #:optional (tab-size 8))
"Returns a copy of @var{str} with all tabs expanded to spaces. @var{tab-size} defaults to 8.
Assuming tab size of 8, this is equivalent to: @lisp
(transform-string str #\\tab \" \")
@end lisp"
(transform-string str
#\tab
(make-string tab-size #\space)))
(define (escape-special-chars str special-chars escape-char)
"Returns a copy of @var{str} with all given special characters preceded
by the given @var{escape-char}.
@var{special-chars} can either be a single character, or a string consisting
of all the special characters.
@lisp
;; make a string regexp-safe...
(escape-special-chars \"***(Example String)***\"
\"[]()/*.\"
#\\\\)
=> \"\\\\*\\\\*\\\\*\\\\(Example String\\\\)\\\\*\\\\*\\\\*\"
;; also can escape a singe char...
(escape-special-chars \"richardt@@vzavenue.net\"
#\\@@
#\\@@)
=> \"richardt@@@@vzavenue.net\"
@end lisp"
(transform-string str
(if (char? special-chars)
;; if they gave us a char, use char=?
(lambda (c) (char=? c special-chars))
;; if they gave us a string, see if our character is in it
(lambda (c) (string-index special-chars c)))
;; replace matches with the character preceded by the escape character
(lambda (c) (string escape-char c))))
(define* (center-string str #:optional (width 80) (chr #\space) (rchr #f))
"Returns a copy of @var{str} centered in a field of @var{width}
characters. Any needed padding is done by character @var{chr}, which
defaults to @samp{#\\space}. If @var{rchr} is provided, then the
padding to the right will use it instead. See the examples below.
left and @var{rchr} on the right. The default @var{width} is 80. The
default @var{lchr} and @var{rchr} is @samp{#\\space}. The string is
never truncated.
@lisp
(center-string \"Richard Todd\" 24)
=> \" Richard Todd \"
(center-string \" Richard Todd \" 24 #\\=)
=> \"===== Richard Todd =====\"
(center-string \" Richard Todd \" 24 #\\< #\\>)
=> \"<<<<< Richard Todd >>>>>\"
@end lisp"
(let* ((len (string-length str))
(lpad (make-string (max (quotient (- width len) 2) 0) chr))
;; right-char == char unless it has been provided by the user
(right-chr (or rchr chr))
(rpad (if (char=? right-chr chr)
lpad
(make-string (max (quotient (- width len) 2) 0) right-chr))))
(if (>= len width)
str
(string-append lpad str rpad (if (odd? (- width len)) (string right-chr) "")))))
(define* (left-justify-string str #:optional (width 80) (chr #\space))
"@code{left-justify-string str [width chr]}.
Returns a copy of @var{str} padded with @var{chr} such that it is left
justified in a field of @var{width} characters. The default
@var{width} is 80. Unlike @samp{string-pad} from srfi-13, the string
is never truncated."
(let* ((len (string-length str))
(pad (make-string (max (- width len) 0) chr)))
(if (>= len width)
str
(string-append str pad))))
(define* (right-justify-string str #:optional (width 80) (chr #\space))
"Returns a copy of @var{str} padded with @var{chr} such that it is
right justified in a field of @var{width} characters. The default
@var{width} is 80. The default @var{chr} is @samp{#\\space}. Unlike
@samp{string-pad} from srfi-13, the string is never truncated."
(let* ((len (string-length str))
(pad (make-string (max (- width len) 0) chr)))
(if (>= len width)
str
(string-append pad str))))
(define* (collapse-repeated-chars str #:optional (chr #\space) (num 1))
"Returns a copy of @var{str} with all repeated instances of
@var{chr} collapsed down to at most @var{num} instances.
The default value for @var{chr} is @samp{#\\space}, and
the default value for @var{num} is 1.
@lisp
(collapse-repeated-chars \"H e l l o\")
=> \"H e l l o\"
(collapse-repeated-chars \"H--e--l--l--o\" #\\-)
=> \"H-e-l-l-o\"
(collapse-repeated-chars \"H-e--l---l----o\" #\\- 2)
=> \"H-e--l--l--o\"
@end lisp"
;; define repeat-locator as a stateful match? function which remembers
;; the last character it had seen.
(let ((repeat-locator
;; initialize prev-chr to something other than what we're seeking...
(let ((prev-chr (if (char=? chr #\space) #\A #\space))
(match-count 0))
(lambda (c)
(if (and (char=? c prev-chr)
(char=? prev-chr chr))
;; found enough duplicates if the match-count is high enough
(begin
(set! match-count (+ 1 match-count))
(>= match-count num))
;; did not find a duplicate
(begin (set! match-count 0)
(set! prev-chr c)
#f))))))
;; transform the string with our stateful matcher...
;; deleting matches...
(transform-string str repeat-locator "")))
;; split a text string into segments that have the form...
;; <ws non-ws> <ws non-ws> etc..
(define (split-by-single-words str)
(let ((non-wschars (char-set-complement char-set:whitespace)))
(let loop ((ans '())
(index 0))
(let ((next-non-ws (string-index str non-wschars index)))
(if next-non-ws
;; found non-ws...look for ws following...
(let ((next-ws (string-index str char-set:whitespace next-non-ws)))
(if next-ws
;; found the ws following...
(loop (cons (substring str index next-ws) ans)
next-ws)
;; did not find ws...must be the end...
(reverse (cons (substring str index) ans))))
;; did not find non-ws... only ws at end of the string...
(reverse ans))))))
(define* (make-text-wrapper #:key
(line-width 80)
(expand-tabs? #t)
(tab-width 8)
(collapse-whitespace? #t)
(subsequent-indent "")
(initial-indent "")
(break-long-words? #t))
"Returns a procedure that will split a string into lines according to the
given parameters.
@table @code
@item #:line-width
This is the target length used when deciding where to wrap lines.
Default is 80.
@item #:expand-tabs?
Boolean describing whether tabs in the input should be expanded. Default
is #t.
@item #:tab-width
If tabs are expanded, this will be the number of spaces to which they
expand. Default is 8.
@item #:collapse-whitespace?
Boolean describing whether the whitespace inside the existing text
should be removed or not. Default is #t.
If text is already well-formatted, and is just being wrapped to fit in a
different width, then set this to @samp{#f}. This way, many common text
conventions (such as two spaces between sentences) can be preserved if
in the original text. If the input text spacing cannot be trusted, then
leave this setting at the default, and all repeated whitespace will be
collapsed down to a single space.
@item #:initial-indent
Defines a string that will be put in front of the first line of wrapped
text. Default is the empty string, ``''.
@item #:subsequent-indent
Defines a string that will be put in front of all lines of wrapped
text, except the first one. Default is the empty string, ``''.
@item #:break-long-words?
If a single word is too big to fit on a line, this setting tells the
wrapper what to do. Defaults to #t, which will break up long words.
When set to #f, the line will be allowed, even though it is longer
than the defined @code{#:line-width}.
@end table
The return value is a procedure of one argument, the input string, which
returns a list of strings, where each element of the list is one line."
(lambda (str)
;; replace newlines with spaces
(set! str (transform-string str (lambda (c) (char=? c #\nl)) #\space))
;; expand tabs if they wanted us to...
(if expand-tabs?
(set! str (expand-tabs str tab-width)))
;; collapse whitespace if they wanted us to...
(if collapse-whitespace?
(set! str (collapse-repeated-chars str)))
;; drop any whitespace from the front...
(set! str (string-trim str))
;; now start breaking the text into lines...
(let loop ((ans '())
(words (split-by-single-words str))
(line initial-indent)
(count 0))
(if (null? words)
;; out of words? ...done!
(reverse (if (> count 0)
(cons line ans)
ans))
;; not out of words...keep going...
(let ((length-left (- line-width
(string-length line)))
(next-word (if (= count 0)
(string-trim (car words))
(car words))))
(cond
;; does the next entry fit?
((<= (string-length next-word)
length-left)
(loop ans
(cdr words)
(string-append line next-word)
(+ count 1)))
;; ok, it didn't fit...is there already at least one word on the line?
((> count 0)
;; try to use it for the next line, then...
(loop (cons line ans)
words
subsequent-indent
0))
;; ok, it didn't fit...and it's the first word.
;; were we told to break up long words?
(break-long-words?
;; break the like at the limit, since the user wants us to...
(loop (cons (string-append line (substring next-word 0 length-left))
ans)
(cons (substring next-word length-left)
(cdr words))
subsequent-indent
0))
;; well, then is it the first word and we *shouldn't* break long words, then...
(else
(loop (cons (string-append line next-word)
ans)
(cdr words)
subsequent-indent
0))))))))
(define (string->wrapped-lines str . kwargs)
"@code{string->wrapped-lines str keywds ...}. Wraps the text given in
string @var{str} according to the parameters provided in @var{keywds},
or the default setting if they are not given. Returns a list of strings
representing the formatted lines. Valid keyword arguments are discussed
in @code{make-text-wrapper}."
((apply make-text-wrapper kwargs) str))
(define (fill-string str . kwargs)
"Wraps the text given in string @var{str} according to the parameters
provided in @var{keywds}, or the default setting if they are not
given. Returns a single string with the wrapped text. Valid keyword
arguments are discussed in @code{make-text-wrapper}."
(string-join (apply string->wrapped-lines str kwargs)
"\n"
'infix))