aboutsummaryrefslogtreecommitdiff
path: root/legacy/stklos/writer.stk
diff options
context:
space:
mode:
authorLudovic Courtes2005-10-31 16:16:54 +0000
committerLudovic Courtes2005-10-31 16:16:54 +0000
commit89a424521b753ee7c2c67ebdc957865657f647c4 (patch)
tree7d15f69ef9aa87cd6e89153d34240baa031177c2 /legacy/stklos/writer.stk
parentfe831fd1e716de64a1b92beeabe4d865546dd986 (diff)
downloadskribilo-89a424521b753ee7c2c67ebdc957865657f647c4.tar.gz
skribilo-89a424521b753ee7c2c67ebdc957865657f647c4.tar.lz
skribilo-89a424521b753ee7c2c67ebdc957865657f647c4.zip
Moved the STkLos and Bigloo code to `legacy'.
Moved the STkLos and Bigloo code from `src' to `legacy'. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-9
Diffstat (limited to 'legacy/stklos/writer.stk')
-rw-r--r--legacy/stklos/writer.stk211
1 files changed, 211 insertions, 0 deletions
diff --git a/legacy/stklos/writer.stk b/legacy/stklos/writer.stk
new file mode 100644
index 0000000..2b0f91c
--- /dev/null
+++ b/legacy/stklos/writer.stk
@@ -0,0 +1,211 @@
+;;;;
+;;;; 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-MODULE
+ (import SKRIBE-DEBUG-MODULE SKRIBE-ENGINE-MODULE SKRIBE-OUTPUT-MODULE)
+ (export invoke markup-writer markup-writer-get markup-writer-get*
+ lookup-markup-writer copy-markup-writer)
+
+;;;; ======================================================================
+;;;;
+;;;; 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))))
+
+)