summaryrefslogtreecommitdiff
path: root/legacy/stklos/writer.stk
diff options
context:
space:
mode:
Diffstat (limited to 'legacy/stklos/writer.stk')
-rw-r--r--legacy/stklos/writer.stk211
1 files changed, 0 insertions, 211 deletions
diff --git a/legacy/stklos/writer.stk b/legacy/stklos/writer.stk
deleted file mode 100644
index 2b0f91c..0000000
--- a/legacy/stklos/writer.stk
+++ /dev/null
@@ -1,211 +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-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))))
-
-)
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-01 20:26:45 +0000