diff options
Diffstat (limited to 'src/guile/skribilo/engine.scm')
| -rw-r--r-- | src/guile/skribilo/engine.scm | 391 |
1 files changed, 238 insertions, 153 deletions
diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm index 06667ad..b1e4235 100644 --- a/src/guile/skribilo/engine.scm +++ b/src/guile/skribilo/engine.scm @@ -1,7 +1,7 @@ ;;; engine.scm -- Skribilo engines. ;;; -;;; Copyright 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -32,25 +32,38 @@ :use-module (ice-9 optargs) :autoload (srfi srfi-39) (make-parameter) - :export (<engine> engine? engine-ident engine-format - engine-customs engine-filter engine-symbol-table + :export (<engine-class> engine-class? engine-class-ident + engine-class-format + engine-class-customs engine-class-filter + engine-class-symbol-table + copy-engine-class + + <engine> engine? engine-custom + engine-custom-set! engine-custom-add! + engine-format? + + engine-ident engine-format + engine-filter engine-symbol-table *current-engine* - default-engine default-engine-set! - make-engine copy-engine find-engine lookup-engine - engine-custom engine-custom-set! engine-custom-add! - engine-format? engine-add-writer! + default-engine-class default-engine-class-set! + push-default-engine-class pop-default-engine-class + + make-engine-class lookup-engine-class + make-engine copy-engine engine-class + engine-class-add-writer! + processor-get-engine - push-default-engine pop-default-engine - engine-loaded? when-engine-is-loaded)) + engine-class-loaded? when-engine-class-is-loaded + when-engine-is-instantiated)) (fluid-set! current-reader %skribilo-module-reader) ;;; -;;; Class definition. +;;; Class definitions. ;;; ;; Note on writers @@ -81,7 +94,7 @@ ;; For more details, see `markup-writer-get' and `lookup-markup-writer' in ;; `(skribilo writer)'. -(define-class <engine> () +(define-class <engine-class> (<class>) (ident :init-keyword :ident :init-value '???) (format :init-keyword :format :init-value "raw") (info :init-keyword :info :init-value '()) @@ -92,75 +105,98 @@ (free-writers :init-value '()) (filter :init-keyword :filter :init-value #f) (customs :init-keyword :custom :init-value '()) - (symbol-table :init-keyword :symbol-table :init-value '())) - + (symbol-table :init-keyword :symbol-table :init-value '())) + +(define-class <engine> (<object>) + (customs :init-keyword :customs :init-value '()) + :metaclass <engine-class>) + + +(define %format format) +(define* (make-engine-class ident :key (version 'unspecified) + (format "raw") + (filter #f) + (delegate #f) + (symbol-table '()) + (custom '()) + (info '())) + ;; We use `make-class' from `(oop goops)' (currently undocumented). + (let ((e (make-class (list <engine>) '() + :metaclass <engine-class> + :name (symbol-append '<engine: ident '>) + + :ident ident :version version :format format + :filter filter :delegate delegate + :symbol-table symbol-table + :custom custom :info info))) + (%format (current-error-port) "make-engine-class returns ~a~%" e) + e)) -(define (engine? obj) - (is-a? obj <engine>)) +(define (engine-class? obj) + (is-a? obj <engine-class>)) -(define (engine-ident obj) +(define (engine-class-ident obj) (slot-ref obj 'ident)) -(define (engine-format obj) +(define (engine-class-format obj) (slot-ref obj 'format)) -(define (engine-customs obj) +(define (engine-class-customs obj) (slot-ref obj 'customs)) -(define (engine-filter obj) +(define (engine-class-filter obj) (slot-ref obj 'filter)) -(define (engine-symbol-table obj) +(define (engine-class-symbol-table obj) (slot-ref obj 'symbol-table)) ;;; -;;; Default engines. +;;; Engine instances. ;;; -(define *default-engine* #f) -(define *default-engines* '()) - - -(define (default-engine) - *default-engine*) - - -(define (default-engine-set! e) - (with-debug 5 'default-engine-set! - (debug-item "engine=" e) - - (if (not (engine? e)) - (skribe-error 'default-engine-set! "bad engine ~S" e)) - (set! *default-engine* e) - (set! *default-engines* (cons e *default-engines*)) - e)) - -(define (push-default-engine e) - (set! *default-engines* (cons e *default-engines*)) - (default-engine-set! e)) - -(define (pop-default-engine) - (if (null? *default-engines*) - (skribe-error 'pop-default-engine "Empty engine stack" '()) - (begin - (set! *default-engines* (cdr *default-engines*)) - (if (pair? *default-engines*) - (default-engine-set! (car *default-engines*)) - (set! *default-engine* #f))))) - - -(define (processor-get-engine combinator newe olde) - (cond - ((procedure? combinator) - (combinator newe olde)) - ((engine? newe) - newe) - (else - olde))) +(define (engine? obj) + (is-a? obj <engine>)) +(define (engine-class e) + (and (engine? e) (class-of e))) + +;; A mapping of engine classes to hooks. +(define %engine-instantiate-hook (make-hash-table)) + +(define-method (make-instance (class <engine-class>) . args) + (define (initialize-engine! engine) + ;; Automatically initialize the `customs' slot of the newly created + ;; engine. + (let ((init-values (engine-class-customs class))) + (slot-set! engine 'customs (map list-copy init-values)) + engine)) + + (format #t "making engine of class ~a~%" class) + (let ((engine (next-method))) + (if (engine? engine) + (let ((hook (hashq-ref %engine-instantiate-hook class))) + (format (current-error-port) "engine made: ~a~%" engine) + (initialize-engine! engine) + (if (hook? hook) + (run-hook hook engine class)) + engine) + engine))) + +(define (make-engine engine-class) + ;; Instantiate ENGINE-CLASS. + (make engine-class)) + + +;; Convenience functions. + +(define (engine-ident obj) (engine-class-ident (engine-class obj))) +(define (engine-format obj) (engine-class-format (engine-class obj))) +(define (engine-filter obj) (engine-class-filter (engine-class obj))) +(define (engine-symbol-table obj) + (engine-class-symbol-table (engine-class obj))) (define (engine-format? fmt . e) (let ((e (cond @@ -170,31 +206,83 @@ (skribe-error 'engine-format? "no engine" e) (string=? fmt (engine-format e))))) + + ;;; -;;; MAKE-ENGINE +;;; Writers. ;;; -(define* (make-engine ident :key (version 'unspecified) - (format "raw") - (filter #f) - (delegate #f) - (symbol-table '()) - (custom '()) - (info '())) - (let ((e (make <engine> :ident ident :version version :format format - :filter filter :delegate delegate - :symbol-table symbol-table - :custom custom :info info))) - e)) + +(define (engine-class-add-writer! e ident pred upred opt before action + after class valid) + ;; Add a writer to engine class E. If IDENT is a symbol, then it should + ;; denote a markup name and the writer being added is specific to that + ;; markup. If IDENT is `#t' (for instance), then it is assumed to be a + ;; ``free writer'' that may apply to any kind of markup for which PRED + ;; returns true. + + (define (check-procedure name proc arity) + (cond + ((not (procedure? proc)) + (skribe-error ident "Illegal procedure" proc)) + ((not (equal? (%procedure-arity proc) arity)) + (skribe-error ident + (format #f "Illegal ~S procedure" name) + proc)))) + + (define (check-output name proc) + (and proc (or (string? proc) (check-procedure name proc 2)))) + + ;; + ;; Engine-add-writer! starts here + ;; + (if (not (is-a? e <engine-class>)) + (skribe-error ident "Illegal engine" e)) + + ;; check the options + (if (not (or (eq? opt 'all) (list? opt))) + (skribe-error ident "Illegal options" opt)) + + ;; check the correctness of the predicate + (if pred + (check-procedure "predicate" pred 2)) + + ;; check the correctness of the validation proc + (if valid + (check-procedure "validate" valid 2)) + + ;; check the correctness of the three actions + (check-output "before" before) + (check-output "action" action) + (check-output "after" after) + + ;; create a new writer and bind it + (let ((n (make <writer> + :ident (if (symbol? ident) ident 'all) + :class class :pred pred :upred upred :options opt + :before before :action action :after after + :validate valid))) + (if (symbol? ident) + (let ((writers (slot-ref e 'writers))) + (hashq-set! writers ident + (cons n (hashq-ref writers ident '())))) + (slot-set! e 'free-writers + (cons n (slot-ref e 'free-writers)))) + n)) ;;; ;;; COPY-ENGINE ;;; -(define* (copy-engine ident e :key (version 'unspecified) - (filter #f) - (delegate #f) - (symbol-table #f) - (custom #f)) +(define (copy-engine e) + (let ((new (shallow-clone e))) + (slot-set! new 'customs (map list-copy (slot-ref e 'customs))) + new)) + +(define* (copy-engine-class ident e :key (version 'unspecified) + (filter #f) + (delegate #f) + (symbol-table #f) + (custom #f)) (let ((new (shallow-clone e))) (slot-set! new 'ident ident) (slot-set! new 'version version) @@ -212,14 +300,11 @@ (hash-for-each (lambda (m w*) (hashq-set! new-writers m w*)) (slot-ref e 'writers)) - (slot-set! new 'writers new-writers)) - - new)) - + (slot-set! new 'writers new-writers)))) ;;; -;;; Engine loading. +;;; Engine class loading. ;;; ;; Each engine is to be stored in its own module with the `(skribilo engine)' @@ -229,39 +314,47 @@ (define (engine-id->module-name id) `(skribilo engine ,id)) -(define (engine-loaded? id) +(define (engine-class-loaded? id) "Check whether engine @var{id} is already loaded." ;; Trick taken from `resolve-module' in `boot-9.scm'. (nested-ref the-root-module `(%app modules ,@(engine-id->module-name id)))) ;; A mapping of engine names to hooks. -(define %engine-load-hook (make-hash-table)) +(define %engine-class-load-hook (make-hash-table)) (define (consume-load-hook! id) (with-debug 5 'consume-load-hook! - (let ((hook (hashq-ref %engine-load-hook id))) + (let ((hook (hashq-ref %engine-class-load-hook id))) (if hook (begin (debug-item "running hook " hook " for engine " id) - (hashq-remove! %engine-load-hook id) + (hashq-remove! %engine-class-load-hook id) (run-hook hook)))))) -(define (when-engine-is-loaded id thunk) +(define (when-engine-class-is-loaded id thunk) "Run @var{thunk} only when engine with identifier @var{id} is loaded." - (if (engine-loaded? id) + (if (engine-class-loaded? id) (begin ;; Maybe the engine had already been loaded via `use-modules'. (consume-load-hook! id) (thunk)) - (let ((hook (or (hashq-ref %engine-load-hook id) + (let ((hook (or (hashq-ref %engine-class-load-hook id) (let ((hook (make-hook))) - (hashq-set! %engine-load-hook id hook) + (hashq-set! %engine-class-load-hook id hook) hook)))) (add-hook! hook thunk)))) +(define (when-engine-is-instantiated engine-class proc) + (let loop ((hook (hashq-ref %engine-instantiate-hook engine-class))) + (if (not hook) + (let ((hook (make-hook 2))) + (hashq-set! %engine-instantiate-hook engine-class hook) + (loop hook)) + (add-hook! hook proc)))) -(define* (lookup-engine id :key (version 'unspecified)) + +(define* (lookup-engine-class id :key (version 'unspecified)) "Look for an engine named @var{name} (a symbol) in the @code{(skribilo engine)} module hierarchy. If no such engine was found, an error is raised, otherwise the requested engine is returned." @@ -271,16 +364,17 @@ otherwise the requested engine is returned." (let* ((engine (symbol-append id '-engine)) (m (resolve-module (engine-id->module-name id)))) (if (module-bound? m engine) - (let ((e (module-ref m engine))) - (if e (consume-load-hook! id)) - e) + (let* ((e (module-ref m engine)) + ;; We have to have this thin compatibility layer here. + (c (cond ((engine-class? e) e) + ((engine? e) (engine-class e)) + (else + (skribe-error 'lookup-engine-class + "not an engine class" e))))) + (if c (consume-load-hook! id)) + c) (error "no such engine" id))))) -(define* (find-engine id :key (version 'unspecified)) - (false-if-exception (apply lookup-engine (list id version)))) - - - ;;; @@ -294,7 +388,6 @@ otherwise the requested engine is returned." (cadr c) 'unspecified))) - (define (engine-custom-set! e id val) (let* ((customs (slot-ref e 'customs)) (c (assq id customs))) @@ -308,61 +401,47 @@ otherwise the requested engine is returned." (engine-custom-set! e id (list val)) (engine-custom-set! e id (cons val old))))) -(define (engine-add-writer! e ident pred upred opt before action - after class valid) - ;; Add a writer to engine E. If IDENT is a symbol, then it should denote - ;; a markup name and the writer being added is specific to that markup. If - ;; IDENT is `#t' (for instance), then it is assumed to be a ``free writer'' - ;; that may apply to any kind of markup for which PRED returns true. +(define (processor-get-engine combinator newe olde) + (cond + ((procedure? combinator) + (combinator newe olde)) + ((engine? newe) + newe) + (else + olde))) - (define (check-procedure name proc arity) - (cond - ((not (procedure? proc)) - (skribe-error ident "Illegal procedure" proc)) - ((not (equal? (%procedure-arity proc) arity)) - (skribe-error ident - (format #f "Illegal ~S procedure" name) - proc)))) - (define (check-output name proc) - (and proc (or (string? proc) (check-procedure name proc 2)))) + +;;; +;;; Default engines. +;;; - ;; - ;; Engine-add-writer! starts here - ;; - (if (not (is-a? e <engine>)) - (skribe-error ident "Illegal engine" e)) +(define *default-engine-classes* '(html)) - ;; check the options - (if (not (or (eq? opt 'all) (list? opt))) - (skribe-error ident "Illegal options" opt)) +(define (default-engine-class) + (let ((class (car *default-engine-classes*))) + (cond ((symbol? class) (lookup-engine-class class)) + (else class)))) - ;; check the correctness of the predicate - (if pred - (check-procedure "predicate" pred 2)) +(define (default-engine-class-set! e) + (with-debug 5 'default-engine-set! + (debug-item "engine=" e) - ;; check the correctness of the validation proc - (if valid - (check-procedure "validate" valid 2)) + (if (not (or (symbol? e) (engine-class? e))) + (skribe-error 'default-engine-class-set! "bad engine class ~S" e)) + (set-car! *default-engine-classes* e) + e)) - ;; check the correctness of the three actions - (check-output "before" before) - (check-output "action" action) - (check-output "after" after) - ;; create a new writer and bind it - (let ((n (make <writer> - :ident (if (symbol? ident) ident 'all) - :class class :pred pred :upred upred :options opt - :before before :action action :after after - :validate valid))) - (if (symbol? ident) - (let ((writers (slot-ref e 'writers))) - (hashq-set! writers ident - (cons n (hashq-ref writers ident '())))) - (slot-set! e 'free-writers - (cons n (slot-ref e 'free-writers)))) - n)) +(define (push-default-engine-class e) + (set! *default-engine-classes* + (cons e *default-engine-classes*)) + e) + +(define (pop-default-engine-class) + (if (null? *default-engine-classes*) + (skribe-error 'pop-default-engine-class "empty engine class stack" '()) + (set! *default-engine-classes* (cdr *default-engine-classes*)))) @@ -374,14 +453,20 @@ otherwise the requested engine is returned." (use-modules (skribilo module)) ;; At this point, we're almost done with the bootstrap process. -;(format #t "base engine: ~a~%" (lookup-engine 'base)) +(format (current-error-port) "HERE~%") +(format #t "base engine: ~a~%" (lookup-engine-class 'base)) +(format (current-error-port) "THERE~%") (define *current-engine* ;; By default, use the HTML engine. - (make-parameter (lookup-engine 'html) + (make-parameter #f ;'html ;(make-engine (lookup-engine-class 'html)) (lambda (val) - (cond ((symbol? val) (lookup-engine val)) + (cond ((symbol? val) + (make-engine (lookup-engine-class val))) + ((engine-class? val) + (make-engine val)) ((engine? val) val) + ((not val) val) (else (error "invalid value for `*current-engine*'" val)))))) |