diff options
Diffstat (limited to 'src/guile')
| -rw-r--r-- | src/guile/skribilo/package/base.scm | 253 |
1 files changed, 117 insertions, 136 deletions
diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm index a5d8318..082f33a 100644 --- a/src/guile/skribilo/package/base.scm +++ b/src/guile/skribilo/package/base.scm @@ -1,7 +1,7 @@ ;;; base.scm -- The base markup package of Skribe/Skribilo. ;;; -*- coding: iso-8859-1 -*- ;;; -;;; Copyright 2005, 2006, 2007, 2008, 2009, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright 2005, 2006, 2007, 2008, 2009, 2013, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright 2003, 2004 Manuel Serrano ;;; ;;; @@ -28,6 +28,7 @@ :use-module (skribilo ast) :use-module (skribilo resolve) :use-module (skribilo location) + :use-module (skribilo condition) :use-module (skribilo utils keywords) :autoload (srfi srfi-1) (every any filter) :autoload (skribilo evaluator) (include-document) @@ -63,9 +64,9 @@ ;* include ... */ ;*---------------------------------------------------------------------*/ (define-public (include file) - (if (not (string? file)) - (skribe-error 'include "Invalid file (string expected)" file) - (include-document file))) + (unless (string? file) + (invalid-argument-error 'include file 'file)) + (include-document file)) ;*---------------------------------------------------------------------*/ ;* document ... */ @@ -122,18 +123,18 @@ (phone #f) (photo #f) (align 'center)) - (if (not (memq align '(center left right))) - (skribe-error 'author "Invalid align value" align) - (new container - (markup 'author) - (ident (or ident (symbol->string (gensym "author")))) - (class class) - (loc &invocation-location) - (required-options '(:name :title :affiliation :email :url :address :phone :photo :align)) - (options `((:name ,name) - (:align ,align) - ,@(the-options opts :ident :class))) - (body #f)))) + (unless (memq align '(center left right)) + (invalid-argument-error 'author align 'align)) + (new container + (markup 'author) + (ident (or ident (symbol->string (gensym "author")))) + (class class) + (loc &invocation-location) + (required-options '(:name :title :affiliation :email :url :address :phone :photo :align)) + (options `((:name ,name) + (:align ,align) + ,@(the-options opts :ident :class))) + (body #f))) ;*---------------------------------------------------------------------*/ ;* handle ... */ @@ -158,7 +159,7 @@ (loc &invocation-location) (ast (car body)))) (else - (skribe-error 'handle "Invalid handle" opts))))) + (invalid-argument-error 'handle opts))))) ;*---------------------------------------------------------------------*/ ;* toc ... */ @@ -191,13 +192,9 @@ ((null? (cdr body)) (if (handle? (car body)) (car body) - (skribe-error 'toc - "Invalid argument (handle expected)" - (if (markup? (car body)) - (markup-markup (car body)) - "???")))) + (invalid-argument-error 'toc (car body)))) (else - (skribe-error 'toc "Invalid argument" body))))))) + (invalid-argument-error 'toc body))))))) ;*---------------------------------------------------------------------*/ ;* section-number ... */ @@ -382,9 +379,9 @@ ((null? num) ln) ((not (null? (cdr num))) - (skribe-error 'linebreak "Invalid arguments" num)) + (invalid-argument-error 'linebreak num)) ((not (and (integer? (car num)) (positive? (car num)))) - (skribe-error 'linebreak "Invalid argument" (car num))) + (invalid-argument-error 'linebreak (car num))) (else (vector->list (make-vector (car num) ln)))))) @@ -484,7 +481,7 @@ (options (the-options opts :ident :class)) (body (the-body opts)))) (else - (skribe-error 'flush "Invalid side" side)))) + (invalid-argument-error 'flush side 'side)))) ;*---------------------------------------------------------------------*/ ;* center ... */ @@ -509,16 +506,16 @@ :key (ident #f) (class "prog") (line 1) (linedigit #f) (mark ";!")) - (if (not (or (string? mark) (eq? mark #f))) - (skribe-error 'prog "Invalid mark" mark) - (new container - (markup 'prog) - (ident (or ident (symbol->string (gensym "prog")))) - (class class) - (loc &invocation-location) - (required-options '(:line :mark)) - (options (the-options opts :ident :class :linedigit)) - (body (make-prog-body (the-body opts) line linedigit mark))))) + (unless (or (string? mark) (eq? mark #f)) + (invalid-argument-error 'prog mark 'mark)) + (new container + (markup 'prog) + (ident (or ident (symbol->string (gensym "prog")))) + (class class) + (loc &invocation-location) + (required-options '(:line :mark)) + (options (the-options opts :ident :class :linedigit)) + (body (make-prog-body (the-body opts) line linedigit mark)))) ;*---------------------------------------------------------------------*/ ;* source ... */ @@ -553,19 +550,19 @@ "definition requires a language specification" definition)) ((and file (not (string? file))) - (skribe-error 'source "Invalid file" file)) + (invalid-argument-error 'source file 'file)) ((and start (not (or (integer? start) (string? start)))) - (skribe-error 'source "Invalid start" start)) + (invalid-argument-error 'source start 'start)) ((and stop (not (or (integer? stop) (string? stop)))) - (skribe-error 'source "Invalid start" stop)) + (invalid-argument-error 'source stop 'stop)) ((and (integer? start) (integer? stop) (> start stop)) (skribe-error 'source "start line > stop line" (format #f "~a/~a" start stop))) ((and language (not (language? language))) - (skribe-error 'source "invalid language" language)) + (invalid-argument-error 'source language 'language)) ((and tab (not (integer? tab))) - (skribe-error 'source "invalid tab" tab)) + (invalid-argument-error 'source tab 'tab)) (file (let ((s (if (not definition) (source-read-lines file start stop tab) @@ -702,19 +699,19 @@ ;* item ... */ ;*---------------------------------------------------------------------*/ (define-markup (item :rest opts :key (ident #f) (class #f) key) - (if (and key (not (or (string? key) - (number? key) - (markup? key) - (pair? key)))) - (skribe-type-error 'item "Invalid key:" key "node") - (new container - (markup 'item) - (ident (or ident (symbol->string (gensym "item")))) - (class class) - (loc &invocation-location) - (required-options '(:key)) - (options `((:key ,key) ,@(the-options opts :ident :class :key))) - (body (the-body opts))))) + (when (and key (not (or (string? key) + (number? key) + (markup? key) + (pair? key)))) + (invalid-argument-error 'item key 'key)) + (new container + (markup 'item) + (ident (or ident (symbol->string (gensym "item")))) + (class class) + (loc &invocation-location) + (required-options '(:key)) + (options `((:key ,key) ,@(the-options opts :ident :class :key))) + (body (the-body opts)))) ;*---------------------------------------------------------------------*/ ;* table */ @@ -807,19 +804,13 @@ valign))) (cond ((not (integer? colspan)) - (skribe-type-error 'tc "Invalid colspan, " colspan "integer")) + (invalid-argument-error 'tc colspan 'colspan)) ((not (symbol? align)) - (skribe-type-error 'tc "Invalid align, " align "align")) + (invalid-argument-error 'tc align 'align)) ((not (memq align '(#f center left right))) - (skribe-error - 'tc - "align should be one of 'left', 'center', or 'right'" - align)) + (invalid-argument-error 'tc align 'align)) ((not (memq valign '(#f top middle center bottom))) - (skribe-error - 'tc - "valign should be one of 'top', 'middle', 'center', or 'bottom'" - valign)) + (invalid-argument-error 'tc valign 'valign)) (else (new container (markup 'tc) @@ -924,7 +915,7 @@ ((and (string? char) (= (string-length char) 1)) char) (else - (skribe-error 'char "Invalid char" char)))) + (invalid-argument-error 'char char)))) ;*---------------------------------------------------------------------*/ ;* symbol ... */ @@ -936,9 +927,7 @@ ((string? symbol) symbol) (else - (skribe-error 'symbol - "Invalid argument (symbol expected)" - symbol))))) + (invalid-argument-error 'symbol symbol))))) (new markup (markup 'symbol) (loc &invocation-location) @@ -948,12 +937,12 @@ ;* ! ... */ ;*---------------------------------------------------------------------*/ (define-markup (! format :rest node) - (if (not (string? format)) - (skribe-type-error '! "Invalid format:" format "string") - (new command - (loc &invocation-location) - (fmt format) - (body node)))) + (unless (string? format) + (invalid-argument-error '! format)) + (new command + (loc &invocation-location) + (fmt format) + (body node))) ;*---------------------------------------------------------------------*/ ;* processor ... */ @@ -962,9 +951,9 @@ :key (combinator #f) (engine #f) (procedure #f)) (cond ((and combinator (not (procedure? combinator))) - (skribe-error 'processor "Combinator not a procedure" combinator)) + (invalid-argument-error 'processor combinator 'combinator)) ((and engine (not (engine? engine))) - (skribe-error 'processor "Invalid engine" engine)) + (invalid-argument-error 'processor engine 'engine)) ((and procedure (or (not (procedure? procedure)) (not (let ((a (procedure-property procedure 'arity))) @@ -974,7 +963,7 @@ (rest? (caddr a))) (or rest? (>= (+ compulsory optional) 2)))))))) - (skribe-error 'processor "Invalid procedure" procedure)) + (invalid-argument-error 'processor procedure 'procedure)) (else (new processor (loc &invocation-location) @@ -1023,9 +1012,9 @@ ((null? bd) (skribe-error 'mark "Missing argument" '())) ((not (string? (car bd))) - (skribe-type-error 'mark "Invalid ident:" (car bd) "string")) + (invalid-argument-error 'mark (car bd))) (ident - (skribe-error 'mark "Invalid 'ident:' option" ident)) + (invalid-argument-error 'mark ident 'ident)) (else (let* ((bs (ast->string bd)) (n (new markup @@ -1121,25 +1110,25 @@ (ast s)))) (unref title (or kind 'title))))))))) (define (do-ident-ref text kind) - (if (not (string? text)) - (skribe-type-error 'ref "Invalid reference" text "string") - (new unresolved - (loc &invocation-location) - (proc (lambda (n e env) - (let ((s (resolve-ident text kind n env))) - (if s - (new markup - (markup 'ref) - (ident (symbol->string (gensym "ident-ref"))) - (class class) - (loc &invocation-location) - (required-options '(:text)) - (options `((kind ,kind) - (mark ,text) - ,@(the-options opts :ident :class))) - (body (new handle + (unless (string? text) + (invalid-argument-error 'ref text)) + (new unresolved + (loc &invocation-location) + (proc (lambda (n e env) + (let ((s (resolve-ident text kind n env))) + (if s + (new markup + (markup 'ref) + (ident (symbol->string (gensym "ident-ref"))) + (class class) + (loc &invocation-location) + (required-options '(:text)) + (options `((kind ,kind) + (mark ,text) + ,@(the-options opts :ident :class))) + (body (new handle (ast s)))) - (unref text (or kind 'ident))))))))) + (unref text (or kind 'ident)))))))) (define (mark-ref mark) (do-ident-ref mark 'mark)) (define (make-bib-ref v) @@ -1210,7 +1199,7 @@ (bib (bib-ref bib)) (url (url-ref)) (line (line-ref line)) - (else (skribe-error 'ref "invalid reference" opts))))) + (else (invalid-argument-error 'ref opts))))) ;*---------------------------------------------------------------------*/ @@ -1279,7 +1268,7 @@ ((pair? f) (bib-add! bib-table f)) (else - (skribe-error "bibliography" "Invalid entry" f)))) + (invalid-argument-error 'bibliography f)))) (the-body files))) ;*---------------------------------------------------------------------*/ @@ -1297,27 +1286,25 @@ (sort bib-sort/authors) (count 'partial) (labels 'number)) - (if (not (memq count '(partial full))) - (skribe-error 'the-bibliography - "count must be either 'partial' or 'full'" - count) - (let ((label-proc (case labels - ((number) assign-entries-numbers!) - ((name+year) assign-entries-name+years!) - (else - (skribe-error - 'the-bibliography - "invalid label type" labels))))) - (new unresolved - (loc &invocation-location) - (proc (lambda (n e env) - (resolve-the-bib bib-table - (new handle (ast n)) - sort - pred - count - (the-options opts) - label-proc))))))) + (unless (memq count '(partial full)) + (invalid-argument-error 'the-bibliography count 'count)) + + (let ((label-proc (case labels + ((number) assign-entries-numbers!) + ((name+year) assign-entries-name+years!) + (else + (invalid-argument-error 'the-bibliography + labels 'labels))))) + (new unresolved + (loc &invocation-location) + (proc (lambda (n e env) + (resolve-the-bib bib-table + (new handle (ast n)) + sort + pred + count + (the-options opts) + label-proc)))))) ;*---------------------------------------------------------------------*/ ;* noabbrev ... */ @@ -1352,17 +1339,12 @@ ((and (pair? entry-name) (every string? entry-name)) (string-concatenate entry-name)) (else - (skribe-error - 'index - "entry-name must be either a string or a list of strings" - entry-name)))) + (invalid-argument-error 'index entry-name)))) (table (cond ((not index) (default-index)) ((index? index) index) - (else (skribe-type-error 'index - "Invalid index table, " - index - "index")))) + (else + (invalid-argument-error 'index index 'index)))) (m (mark (symbol->string (gensym "mark")))) (h (new handle (ast m))) (new (new markup @@ -1406,13 +1388,12 @@ (let ((bd (the-body opts))) (cond ((not (and (integer? char-offset) (>= char-offset 0))) - (skribe-error 'the-index "Invalid char offset" char-offset)) + (invalid-argument-error 'the-index char-offset 'char-offset)) ((not (integer? column)) - (skribe-error 'the-index "Invalid column number" column)) + (invalid-argument-error 'the-index column 'column)) ((not (every index? bd)) - (skribe-error 'the-index - "Invalid indexes" - (filter (lambda (o) (not (index? o))) bd))) + (invalid-argument-error 'the-index + (filter (lambda (o) (not (index? o))) bd))) (else (new unresolved (loc &invocation-location) @@ -1473,9 +1454,9 @@ ((roman) the-roman-number) ((arabic) the-arabic-number) ((alpha) the-alpha-number) - (else (skribe-error 'counter - "Invalid numbering" - numbering))))) + (else + (invalid-argument-error 'counter + numbering 'numbering))))) (let loop ((num 1) (items items) (res '())) |