summaryrefslogtreecommitdiff
path: root/src/guile/skribe/writer.scm
diff options
context:
space:
mode:
authorLudovic Court`es2005-09-23 16:16:44 +0000
committerLudovic Court`es2005-09-23 16:16:44 +0000
commit15456d415e58a5823700fe3198cf3916e917f2b9 (patch)
tree3b3bb9c26e2b79653f1b0fe193ae64964b2f624a /src/guile/skribe/writer.scm
parentc323ee2c0207a02d8af1d0366fdf000f051fdb27 (diff)
parenta85155f7c411761cfbd75431f265675ae0f394e3 (diff)
downloadskribilo-15456d415e58a5823700fe3198cf3916e917f2b9.tar.gz
skribilo-15456d415e58a5823700fe3198cf3916e917f2b9.tar.lz
skribilo-15456d415e58a5823700fe3198cf3916e917f2b9.zip
Lots of changes...
Patches applied: * lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--base-0 tag of lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-5 * lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-1 Lots of changes. git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-6
Diffstat (limited to 'src/guile/skribe/writer.scm')
-rw-r--r--src/guile/skribe/writer.scm217
1 files changed, 0 insertions, 217 deletions
diff --git a/src/guile/skribe/writer.scm b/src/guile/skribe/writer.scm
deleted file mode 100644
index 9e7faf6..0000000
--- a/src/guile/skribe/writer.scm
+++ /dev/null
@@ -1,217 +0,0 @@
-;;;;
-;;;; writer.stk -- Skribe Writer Stuff
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 15-Sep-2003 22:21 (eg)
-;;;; Last file update: 4-Mar-2004 10:48 (eg)
-;;;;
-
-
-(define-module (skribe writer)
- :export (invoke markup-writer markup-writer-get markup-writer-get*
- lookup-markup-writer copy-markup-writer))
-
-
-(use-modules (skribe debug)
-; (skribe engine)
- (skribe output)
-
- (oop goops)
- (ice-9 optargs))
-
-
-;;;; ======================================================================
-;;;;
-;;;; INVOKE
-;;;;
-;;;; ======================================================================
-(define (invoke proc node e)
- (with-debug 5 'invoke
- (debug-item "e=" (engine-ident e))
- (debug-item "node=" node " " (if (markup? node) (markup-markup node) ""))
-
- (if (string? proc)
- (display proc)
- (if (procedure? proc)
- (proc node e)))))
-
-
-;;;; ======================================================================
-;;;;
-;;;; LOOKUP-MARKUP-WRITER
-;;;;
-;;;; ======================================================================
-(define (lookup-markup-writer node e)
- (let ((writers (slot-ref e 'writers))
- (delegate (slot-ref e 'delegate)))
- (let Loop ((w* writers))
- (cond
- ((pair? w*)
- (let ((pred (slot-ref (car w*) 'pred)))
- (if (pred node e)
- (car w*)
- (loop (cdr w*)))))
- ((engine? delegate)
- (lookup-markup-writer node delegate))
- (else
- #f)))))
-
-;;;; ======================================================================
-;;;;
-;;;; MAKE-WRITER-PREDICATE
-;;;;
-;;;; ======================================================================
-(define (make-writer-predicate markup predicate class)
- (let* ((t1 (if (symbol? markup)
- (lambda (n e) (is-markup? n markup))
- (lambda (n e) #t)))
- (t2 (if class
- (lambda (n e)
- (and (t1 n e) (equal? (markup-class n) class)))
- t1)))
- (if predicate
- (cond
- ((not (procedure? predicate))
- (skribe-error 'markup-writer
- "Illegal predicate (procedure expected)"
- predicate))
- ((not (eq? (%procedure-arity predicate) 2))
- (skribe-error 'markup-writer
- "Illegal predicate arity (2 arguments expected)"
- predicate))
- (else
- (lambda (n e)
- (and (t2 n e) (predicate n e)))))
- t2)))
-
-;;;; ======================================================================
-;;;;
-;;;; MARKUP-WRITER
-;;;;
-;;;; ======================================================================
-(define* (markup-writer markup #:optional engine
- #:key (predicate #f) (class #f) (options '())
- (validate #f)
- (before #f) (action 'unspecified) (after #f))
- (let ((e (or engine (default-engine))))
- (cond
- ((and (not (symbol? markup)) (not (eq? markup #t)))
- (skribe-error 'markup-writer "Illegal markup" markup))
- ((not (engine? e))
- (skribe-error 'markup-writer "Illegal engine" e))
- ((and (not predicate)
- (not class)
- (null? options)
- (not before)
- (eq? action 'unspecified)
- (not after))
- (skribe-error 'markup-writer "Illegal writer" markup))
- (else
- (let ((m (make-writer-predicate markup predicate class))
- (ac (if (eq? action 'unspecified)
- (lambda (n e) (output (markup-body n) e))
- action)))
- (engine-add-writer! e markup m predicate
- options before ac after class validate))))))
-
-
-;;;; ======================================================================
-;;;;
-;;;; MARKUP-WRITER-GET
-;;;;
-;;;; ======================================================================
-(define* (markup-writer-get markup :optional engine :key (class #f) (pred #f))
- (let ((e (or engine (default-engine))))
- (cond
- ((not (symbol? markup))
- (skribe-error 'markup-writer-get "Illegal symbol" markup))
- ((not (engine? e))
- (skribe-error 'markup-writer-get "Illegal engine" e))
- (else
- (let liip ((e e))
- (let loop ((w* (slot-ref e 'writers)))
- (cond
- ((pair? w*)
- (if (and (eq? (writer-ident (car w*)) markup)
- (equal? (writer-class (car w*)) class)
- (or (unspecified? pred)
- (eq? (slot-ref (car w*) 'upred) pred)))
- (car w*)
- (loop (cdr w*))))
- ((engine? (slot-ref e 'delegate))
- (liip (slot-ref e 'delegate)))
- (else
- #f))))))))
-
-;;;; ======================================================================
-;;;;
-;;;; MARKUP-WRITER-GET*
-;;;;
-;;;; ======================================================================
-
-;; Finds all writers that matches MARKUP with optional CLASS attribute.
-
-(define* (markup-writer-get* markup #:optional engine #:key (class #f))
- (let ((e (or engine (default-engine))))
- (cond
- ((not (symbol? markup))
- (skribe-error 'markup-writer "Illegal symbol" markup))
- ((not (engine? e))
- (skribe-error 'markup-writer "Illegal engine" e))
- (else
- (let liip ((e e)
- (res '()))
- (let loop ((w* (slot-ref e 'writers))
- (res res))
- (cond
- ((pair? w*)
- (if (and (eq? (slot-ref (car w*) 'ident) markup)
- (equal? (slot-ref (car w*) 'class) class))
- (loop (cdr w*) (cons (car w*) res))
- (loop (cdr w*) res)))
- ((engine? (slot-ref e 'delegate))
- (liip (slot-ref e 'delegate) res))
- (else
- (reverse! res)))))))))
-
-;;; ======================================================================
-;;;;
-;;;; COPY-MARKUP-WRITER
-;;;;
-;;;; ======================================================================
-(define* (copy-markup-writer markup old-engine :optional new-engine
- :key (predicate 'unspecified)
- (class 'unspecified)
- (options 'unspecified)
- (validate 'unspecified)
- (before 'unspecified)
- (action 'unspecified)
- (after 'unspecified))
- (let ((old (markup-writer-get markup old-engine))
- (new-engine (or new-engine old-engine)))
- (markup-writer markup new-engine
- :pred (if (unspecified? predicate) (slot-ref old 'pred) predicate)
- :class (if (unspecified? class) (slot-ref old 'class) class)
- :options (if (unspecified? options) (slot-ref old 'options) options)
- :validate (if (unspecified? validate) (slot-ref old 'validate) validate)
- :before (if (unspecified? before) (slot-ref old 'before) before)
- :action (if (unspecified? action) (slot-ref old 'action) action)
- :after (if (unspecified? after) (slot-ref old 'after) after))))