From c323ee2c0207a02d8af1d0366fdf000f051fdb27 Mon Sep 17 00:00:00 2001
From: Ludovic Court`es
Date: Thu, 16 Jun 2005 14:03:52 +0000
Subject: One step further with the Guile port.
* src/guile/skribilo.scm: Use `getopt-long'; include all the necessary
modules that user-visible macros depend on.
Use `read-hash-extend' to allow for DSSSL-style keywords, as needed by
Skribe modules.
* src/guile/skribe/debug.scm: Export `with-debug' and `%with-debug'.
* src/guile/skribe/lib.scm (new): Fixed.
(define-markup): Fixed (more the `rest' argument to the end).
git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-5
---
src/guile/skribe/debug.scm | 5 +-
src/guile/skribe/lib.scm | 29 +++--
src/guile/skribilo.scm | 271 +++++++++++++++++++++++++++++++++++----------
3 files changed, 237 insertions(+), 68 deletions(-)
(limited to 'src')
diff --git a/src/guile/skribe/debug.scm b/src/guile/skribe/debug.scm
index 01f88c2..e2bff27 100644
--- a/src/guile/skribe/debug.scm
+++ b/src/guile/skribe/debug.scm
@@ -25,7 +25,8 @@
(define-module (skribe debug)
- :export (debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol
+ :export (with-debug %with-debug
+ debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol
no-debug-color))
(define *skribe-debug* 0)
@@ -138,7 +139,7 @@
r)))
(define-macro (with-debug level label . body)
- `((in-module SKRIBE-DEBUG-MODULE %with-debug) ,level ,label (lambda () ,@body)))
+ `(%with-debug ,level ,label (lambda () ,@body)))
;;(define-macro (with-debug level label . body)
;; `(begin ,@body))
diff --git a/src/guile/skribe/lib.scm b/src/guile/skribe/lib.scm
index 4a9b471..fa5e962 100644
--- a/src/guile/skribe/lib.scm
+++ b/src/guile/skribe/lib.scm
@@ -29,23 +29,34 @@
;;;
;;; NEW
;;;
-(define (maybe-copy obj)
- (if (pair-mutable? obj)
- obj
- (copy-tree obj)))
-
(define-macro (new class . parameters)
- `(make ,(string->symbol (format "<~a>" class))
+ `(make ,(string->symbol (format #f "<~a>" class))
,@(apply append (map (lambda (x)
- `(,(make-keyword (car x)) (maybe-copy ,(cadr x))))
+ `(,(symbol->keyword (car x)) ,(cadr x)))
parameters))))
;;;
;;; DEFINE-MARKUP
;;;
(define-macro (define-markup bindings . body)
- ;; This is just a STklos extended lambda. Nothing to do
- `(define ,bindings ,@body))
+ ;; This is just an `(ice-9 optargs)' kind of `lambda*', with DSSSL
+ ;; keyword-style conversion enabled. However, using `(ice-9 optargs)', the
+ ;; `#:rest' argument can only appear last which not what Skribe/DSSSL
+ ;; expect, hence `fix-rest-arg'.
+ (define (fix-rest-arg args)
+ (let loop ((args args)
+ (result '())
+ (rest-arg #f))
+ (if (null? args)
+ (if rest-arg (append (reverse result) rest-arg) (reverse result))
+ (let ((is-rest-arg? (eq? (car args) #:rest)))
+ (loop (if is-rest-arg? (cddr args) (cdr args))
+ (if is-rest-arg? result (cons (car args) result))
+ (if is-rest-arg? (list (car args) (cadr args)) rest-arg))))))
+
+ (let ((name (car bindings))
+ (opts (cdr bindings)))
+ `(define* ,(cons name (fix-rest-arg opts)) ,@body)))
;;;
diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm
index 77e9618..e766830 100755
--- a/src/guile/skribilo.scm
+++ b/src/guile/skribilo.scm
@@ -42,6 +42,28 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
;; Allow for this `:style' of keywords.
(read-set! keywords 'prefix)
+;; Allow for DSSSL-style keywords (i.e. `#!key', etc.).
+;; See http://lists.gnu.org/archive/html/guile-devel/2005-06/msg00060.html
+;; for details.
+(read-hash-extend #\! (lambda (chr port)
+ (symbol->keyword (read port))))
+
+(let ((gensym-orig gensym))
+ ;; In Skribe, `gensym' expects a symbol as its (optional) argument, while
+ ;; Guile's `gensym' expect a string. XXX
+ (set! gensym
+ (lambda (. args)
+ (if (null? args)
+ (gensym-orig)
+ (let ((the-arg (car args)))
+ (cond ((symbol? the-arg)
+ (gensym-orig (symbol->string the-arg)))
+ ((string? the-arg)
+ (gensym-orig the-arg))
+ (else
+ (skribe-error 'gensym "Invalid argument type"
+ the-arg))))))))
+
; (use-modules (skribe eval)
; (skribe configure)
; (skribe runtime)
@@ -63,45 +85,169 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
(skribe configure)
(skribe eval)
(skribe engine)
+ (skribe types) ;; because `new' is a macro and refers to classes
- (ice-9 optargs))
+ (oop goops) ;; because `new' is a macro
+ (ice-9 optargs)
+
+ (ice-9 getopt-long))
(load "skribe/lib.scm")
(load "../common/configure.scm")
(load "../common/param.scm")
-
-; (include "vars.stk")
-; (include "reader.stk")
-; (include "configure.stk")
-; (include "types.stk")
-; (include "debug.stk")
-; (include "lib.stk")
(load "../common/lib.scm")
-; (include "resolve.stk")
-; (include "writer.stk")
-; (include "verify.stk")
-; (include "output.stk")
-; (include "prog.stk")
-; (include "eval.stk")
-; (include "runtime.stk")
-; (include "engine.stk")
-; (include "biblio.stk")
-; (include "source.stk")
-; (include "lisp.stk")
-; (include "xml.stk")
-; (include "c.stk")
-; (include "color.stk")
(load "../common/sui.scm")
-
(load "../common/index.scm")
+
+;; Markup definitions...
(load "../common/api.scm")
-;;; KLUDGE for allowing redefinition of Skribe INCLUDE
-;(remove-expander! 'include)
+
+(define* (process-option-specs longname #:key (alternate #f)
+ (arg #f) (help #f)
+ #:rest thunk)
+ "Process STkLos-like option specifications and return getopt-long option
+specifications."
+ `(,(string->symbol longname)
+ ,@(if alternate
+ `((single-char ,(string-ref alternate 0)))
+ '())
+ (value #f)))
+
+(define (raw-options->getopt-long options)
+ "Converts @var{options} to a getopt-long-compatible representation."
+ (map (lambda (option-specs)
+ (apply process-option-specs (car option-specs)))
+ options))
+
+(define-macro (define-options binding . options)
+ `(define ,binding (quote ,(raw-options->getopt-long options))))
+
+(define-options skribilo-options
+ (("target" :alternate "t" :arg target
+ :help "sets the output format to <target>")
+ (set! engine (string->symbol target)))
+ (("I" :arg path :help "adds <path> to Skribe path")
+ (set! paths (cons path paths)))
+ (("B" :arg path :help "adds <path> to bibliography path")
+ (skribe-bib-path-set! (cons path (skribe-bib-path))))
+ (("S" :arg path :help "adds <path> to source path")
+ (skribe-source-path-set! (cons path (skribe-source-path))))
+ (("P" :arg path :help "adds <path> to image path")
+ (skribe-image-path-set! (cons path (skribe-image-path))))
+ (("split-chapters" :alternate "C" :arg chapter
+ :help "emit chapter's sections in separate files")
+ (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*)))
+ (("preload" :arg file :help "preload <file>")
+ (set! *skribe-preload* (cons file *skribe-preload*)))
+ (("use-variant" :alternate "u" :arg variant
+ :help "use <variant> output format")
+ (set! *skribe-variants* (cons variant *skribe-variants*)))
+ (("base" :alternate "b" :arg base
+ :help "base prefix to remove from hyperlinks")
+ (set! *skribe-ref-base* base))
+ (("rc-dir" :arg dir :alternate "d" :help "set the RC directory to <dir>")
+ (set! *skribe-rc-directory* dir))
+
+ ;;"File options:"
+ (("no-init-file" :help "Dont load rc Skribe file")
+ (set! *load-rc* #f))
+ (("output" :alternate "o" :arg file :help "set the output to <file>")
+ (set! *skribe-dest* file)
+ (let* ((s (file-suffix file))
+ (c (assoc s *skribe-auto-mode-alist*)))
+ (if (and (pair? c) (symbol? (cdr c)))
+ (set! *skribe-engine* (cdr c)))))
+
+ ;;"Misc:"
+ (("help" :alternate "h" :help "provides help for the command")
+ (arg-usage (current-error-port))
+ (exit 0))
+ (("options" :help "display the skribe options and exit")
+ (arg-usage (current-output-port) #t)
+ (exit 0))
+ (("version" :alternate "V" :help "displays the version of Skribe")
+ (version)
+ (exit 0))
+ (("query" :alternate "q"
+ :help "displays informations about Skribe conf.")
+ (query)
+ (exit 0))
+ (("verbose" :alternate "v" :arg level
+ :help "sets the verbosity to <level>. Use -v0 for crystal silence")
+ (let ((val (string->number level)))
+ (if (integer? val)
+ (set! *skribe-verbose* val))))
+ (("warning" :alternate "w" :arg level
+ :help "sets the verbosity to <level>. Use -w0 for crystal silence")
+ (let ((val (string->number level)))
+ (if (integer? val)
+ (set! *skribe-warning* val))))
+ (("debug" :alternate "g" :arg level :help "sets the debug <level>")
+ (let ((val (string->number level)))
+ (if (integer? val)
+ (set-skribe-debug! val)
+ (begin
+ ;; Use the symbol for debug
+ (set-skribe-debug! 1)
+ (add-skribe-debug-symbol (string->symbol level))))))
+ (("no-color" :help "disable coloring for output")
+ (no-debug-color))
+ (("custom" :alternate "c" :arg key=val :help "Preset custom value")
+ (let ((args (string-split key=val "=")))
+ (if (and (list args) (= (length args) 2))
+ (let ((key (car args))
+ (val (cadr args)))
+ (set! *skribe-precustom* (cons (cons (string->symbol key) val)
+ *skribe-precustom*)))
+ (error 'parse-arguments "Bad custom ~S" key=val))))
+ (("eval" :alternate "e" :arg expr :help "evaluate expression <expr>")
+ (with-input-from-string expr
+ (lambda () (eval (read))))))
+
+; (define skribilo-options
+; ;; Skribilo options in getopt-long's format, as computed by
+; ;; `raw-options->getopt-long'.
+; `((target (single-char #\t) (value #f))
+; (I (value #f))
+; (B (value #f))
+; (S (value #f))
+; (P (value #f))
+; (split-chapters (single-char #\C) (value #f))
+; (preload (value #f))
+; (use-variant (single-char #\u) (value #f))
+; (base (single-char #\b) (value #f))
+; (rc-dir (single-char #\d) (value #f))
+; (no-init-file (value #f))
+; (output (single-char #\o) (value #f))
+; (help (single-char #\h) (value #f))
+; (options (value #f))
+; (version (single-char #\V) (value #f))
+; (query (single-char #\q) (value #f))
+; (verbose (single-char #\v) (value #f))
+; (warning (single-char #\w) (value #f))
+; (debug (single-char #\g) (value #f))
+; (no-color (value #f))
+; (custom (single-char #\c) (value #f))
+; (eval (single-char #\e) (value #f))))
+
+(define (skribilo-show-help)
+ (format #t "Usage: skribilo [OPTIONS] [INPUT]
+
+Processes a Skribilo/Skribe source file and produces its output.
+
+ --target=ENGINE Use ENGINE as the underlying engine
+
+ --help Give this help list
+ --version Print program version
+"))
+
+(define (skribilo-show-version)
+ (format #t "skribilo ~a~%" (skribe-release)))
;;;; ======================================================================
;;;;
@@ -160,7 +306,7 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
(set! *skribe-dest* file)
(let* ((s (file-suffix file))
(c (assoc s *skribe-auto-mode-alist*)))
- (when (and (pair? c) (symbol? (cdr c)))
+ (if (and (pair? c) (symbol? (cdr c)))
(set! *skribe-engine* (cdr c)))))
"Misc:"
@@ -180,12 +326,12 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
(("verbose" :alternate "v" :arg level
:help "sets the verbosity to <level>. Use -v0 for crystal silence")
(let ((val (string->number level)))
- (when (integer? val)
+ (if (integer? val)
(set! *skribe-verbose* val))))
(("warning" :alternate "w" :arg level
:help "sets the verbosity to <level>. Use -w0 for crystal silence")
(let ((val (string->number level)))
- (when (integer? val)
+ (if (integer? val)
(set! *skribe-warning* val))))
(("debug" :alternate "g" :arg level :help "sets the debug <level>")
(let ((val (string->number level)))
@@ -219,7 +365,7 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
(reverse! paths)
(skribe-default-path)))
;; Final initializations
- (when engine
+ (if engine
(set! *skribe-engine* engine))))
;;;; ======================================================================
@@ -227,13 +373,14 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
;;;; L O A D - R C
;;;;
;;;; ======================================================================
+(define *load-rc* #f) ;; FIXME: This should go somewhere else.
+
(define (load-rc)
- (when *load-rc*
+ (if *load-rc*
(let ((file (make-path *skribe-rc-directory* *skribe-rc-file*)))
- (when (and file (file-exists? file))
+ (if (and file (file-exists? file))
(load file)))))
-
;;;; ======================================================================
;;;;
@@ -254,35 +401,45 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
;;;; ======================================================================
;;;;
-;;;; M A I N
+;;;; M A I N
;;;;
;;;; ======================================================================
(define (skribilo . args)
- ;; Load the user rc file
- (load-rc)
-
- ;; Parse command line
- (parse-args args)
-
- ;; Load the base file to bootstrap the system as well as the files
- ;; that are in the *skribe-preload* variable
- (skribe-load "base.skr" :engine 'base)
- (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) *skribe-preload*)
-
- ;; Load the specified variants
- (for-each (lambda (x) (skribe-load (format "~a.skr" x) :engine *skribe-engine*))
- (reverse! *skribe-variants*))
-
-;; (if (string? *skribe-dest*)
-;; (with-handler (lambda (kind loc msg)
-;; (remove-file *skribe-dest*)
-;; (error loc msg))
-;; (with-output-to-file *skribe-dest* doskribe))
-;; (doskribe))
-(if (string? *skribe-dest*)
- (with-output-to-file *skribe-dest* doskribe)
- (doskribe))
+ (let* ((options (getopt-long (cons "skribilo" args) skribilo-options))
+ (target (option-ref options 'target #f))
+ (help-wanted (option-ref options 'help #f))
+ (version-wanted (option-ref options 'version #f)))
+
+ (cond (help-wanted (begin (skribilo-show-help) (exit 1)))
+ (version-wanted (begin (skribilo-show-version) (exit 1)))
+ (target (format #t "target set to `~a'~%" target)))
+
+ ;; Load the user rc file
+ (load-rc)
+
+ ;; Load the base file to bootstrap the system as well as the files
+ ;; that are in the *skribe-preload* variable
+ (skribe-load "base.skr" :engine 'base)
+ (for-each (lambda (f)
+ (skribe-load f :engine *skribe-engine*))
+ *skribe-preload*)
+
+ ;; Load the specified variants
+ (for-each (lambda (x)
+ (skribe-load (format #f "~a.skr" x) :engine *skribe-engine*))
+ (reverse! *skribe-variants*))
+
+ ;; (if (string? *skribe-dest*)
+ ;; (with-handler (lambda (kind loc msg)
+ ;; (remove-file *skribe-dest*)
+ ;; (error loc msg))
+ ;; (with-output-to-file *skribe-dest* doskribe))
+ ;; (doskribe))
+ (if (string? *skribe-dest*)
+ (with-output-to-file *skribe-dest* doskribe)
+ (doskribe))))
+(display "skribilo loaded\n")
(define main skribilo)
--
cgit v1.2.3