summaryrefslogtreecommitdiff
path: root/skribe/src/common/api.scm
diff options
context:
space:
mode:
authorLudovic Court`es2005-06-15 13:00:39 +0000
committerLudovic Court`es2005-06-15 13:00:39 +0000
commitfc42fe56a57eace2dbdb31574c2e161f0eacf839 (patch)
tree18111570156cb0e3df0d81c8d104517a2263fd2c /skribe/src/common/api.scm
downloadskribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.tar.gz
skribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.tar.lz
skribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.zip
Initial import of Skribe 1.2d.
Initial import of Skribe 1.2d. git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0
Diffstat (limited to 'skribe/src/common/api.scm')
-rw-r--r--skribe/src/common/api.scm1243
1 files changed, 1243 insertions, 0 deletions
diff --git a/skribe/src/common/api.scm b/skribe/src/common/api.scm
new file mode 100644
index 0000000..397ba09
--- /dev/null
+++ b/skribe/src/common/api.scm
@@ -0,0 +1,1243 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/src/common/api.scm */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Mon Jul 21 18:11:56 2003 */
+;* Last change : Mon Dec 20 10:38:23 2004 (serrano) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The Scribe API */
+;* ------------------------------------------------------------- */
+;* Implementation: @label api@ */
+;* bigloo: @path ../bigloo/api.bgl@ */
+;* Documentation: */
+;* @path ../../doc/user/markup.skb@ */
+;* @path ../../doc/user/document.skb@ */
+;* @path ../../doc/user/sectioning.skb@ */
+;* @path ../../doc/user/toc.skb@ */
+;* @path ../../doc/user/ornament.skb@ */
+;* @path ../../doc/user/line.skb@ */
+;* @path ../../doc/user/font.skb@ */
+;* @path ../../doc/user/justify.skb@ */
+;* @path ../../doc/user/enumeration.skb@ */
+;* @path ../../doc/user/colframe.skb@ */
+;* @path ../../doc/user/figure.skb@ */
+;* @path ../../doc/user/image.skb@ */
+;* @path ../../doc/user/table.skb@ */
+;* @path ../../doc/user/footnote.skb@ */
+;* @path ../../doc/user/char.skb@ */
+;* @path ../../doc/user/links.skb@ */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* include ... */
+;*---------------------------------------------------------------------*/
+(define-markup (include file)
+ (if (not (string? file))
+ (skribe-error 'include "Illegal file (string expected)" file)
+ (skribe-include file)))
+
+;*---------------------------------------------------------------------*/
+;* document ... */
+;*---------------------------------------------------------------------*/
+(define-markup (document #!rest
+ opts
+ #!key
+ (ident #f) (class "document")
+ (title #f) (html-title #f) (author #f)
+ (ending #f) (env '()))
+ (new document
+ (markup 'document)
+ (ident (or ident
+ (ast->string title)
+ (symbol->string (gensym 'document))))
+ (class class)
+ (required-options '(:title :author :ending))
+ (options (the-options opts :ident :class :env))
+ (body (the-body opts))
+ (env (append env
+ (list (list 'chapter-counter 0) (list 'chapter-env '())
+ (list 'section-counter 0) (list 'section-env '())
+ (list 'footnote-counter 0) (list 'footnote-env '())
+ (list 'figure-counter 0) (list 'figure-env '()))))))
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(define-markup (author #!rest
+ opts
+ #!key
+ (ident #f) (class "author")
+ name
+ (title #f)
+ (affiliation #f)
+ (email #f)
+ (url #f)
+ (address #f)
+ (phone #f)
+ (photo #f)
+ (align 'center))
+ (if (not (memq align '(center left right)))
+ (skribe-error 'author "Illegal align value" align)
+ (new container
+ (markup 'author)
+ (ident (or ident (symbol->string (gensym 'author))))
+ (class class)
+ (required-options '(:name :title :affiliation :email :url :address :phone :photo :align))
+ (options `((:name ,name)
+ (:align ,align)
+ ,@(the-options opts :ident :class)))
+ (body #f))))
+
+;*---------------------------------------------------------------------*/
+;* toc ... */
+;*---------------------------------------------------------------------*/
+(define-markup (toc #!rest
+ opts
+ #!key
+ (ident #f) (class "toc")
+ (chapter #t) (section #t) (subsection #f))
+ (let ((body (the-body opts)))
+ (new container
+ (markup 'toc)
+ (ident (or ident (symbol->string (gensym 'toc))))
+ (class class)
+ (required-options '())
+ (options `((:chapter ,chapter)
+ (:section ,section)
+ (:subsection ,subsection)
+ ,@(the-options opts :ident :class)))
+ (body (cond
+ ((null? body)
+ (new unresolved
+ (proc (lambda (n e env)
+ (handle
+ (resolve-search-parent n env document?))))))
+ ((null? (cdr body))
+ (if (handle? (car body))
+ (car body)
+ (skribe-error 'toc
+ "Illegal argument (handle expected)"
+ (if (markup? (car body))
+ (markup-markup (car body))
+ "???"))))
+ (else
+ (skribe-error 'toc "Illegal argument" body)))))))
+
+;*---------------------------------------------------------------------*/
+;* chapter ... ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/sectioning.skb:chapter@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:chapter@ */
+;*---------------------------------------------------------------------*/
+(define-markup (chapter #!rest
+ opts
+ #!key
+ (ident #f) (class "chapter")
+ title (html-title #f) (file #f) (toc #t) (number #t))
+ (new container
+ (markup 'chapter)
+ (ident (or ident (ast->string title)))
+ (class class)
+ (required-options '(:title :file :toc :number))
+ (options `((:toc ,toc)
+ (:number ,(and number
+ (new unresolved
+ (proc (lambda (n e env)
+ (resolve-counter n
+ env
+ 'chapter
+ number))))))
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))
+ (env (list (list 'section-counter 0) (list 'section-env '())
+ (list 'footnote-counter 0) (list 'footnote-env '())))))
+
+;*---------------------------------------------------------------------*/
+;* section-number ... */
+;*---------------------------------------------------------------------*/
+(define (section-number number markup)
+ (and number
+ (new unresolved
+ (proc (lambda (n e env)
+ (resolve-counter n env markup number))))))
+
+;*---------------------------------------------------------------------*/
+;* section ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/sectioning.skb:section@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:sectionr@ */
+;*---------------------------------------------------------------------*/
+(define-markup (section #!rest
+ opts
+ #!key
+ (ident #f) (class "section")
+ title (file #f) (toc #t) (number #t))
+ (new container
+ (markup 'section)
+ (ident (or ident (ast->string title)))
+ (class class)
+ (required-options '(:title :toc :file :toc :number))
+ (options `((:number ,(section-number number 'section))
+ (:toc ,toc)
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))
+ (env (if file
+ (list (list 'subsection-counter 0) (list 'subsection-env '())
+ (list 'footnote-counter 0) (list 'footnote-env '()))
+ (list (list 'subsection-counter 0) (list 'subsection-env '()))))))
+
+;*---------------------------------------------------------------------*/
+;* subsection ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/sectioning.skb:subsection@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:subsectionr@ */
+;*---------------------------------------------------------------------*/
+(define-markup (subsection #!rest
+ opts
+ #!key
+ (ident #f) (class "subsection")
+ title (file #f) (toc #t) (number #t))
+ (new container
+ (markup 'subsection)
+ (ident (or ident (ast->string title)))
+ (class class)
+ (required-options '(:title :toc :file :number))
+ (options `((:number ,(section-number number 'subsection))
+ (:toc ,toc)
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))
+ (env (list (list 'subsubsection-counter 0) (list 'subsubsection-env '())))))
+
+;*---------------------------------------------------------------------*/
+;* subsubsection ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/sectioning.skb:subsubsection@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:subsubsectionr@ */
+;*---------------------------------------------------------------------*/
+(define-markup (subsubsection #!rest
+ opts
+ #!key
+ (ident #f) (class "subsubsection")
+ title (file #f) (toc #f) (number #t))
+ (new container
+ (markup 'subsubsection)
+ (ident (or ident (ast->string title)))
+ (class class)
+ (required-options '(:title :toc :number :file))
+ (options `((:number ,(section-number number 'subsubsection))
+ (:toc ,toc)
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* paragraph ... */
+;*---------------------------------------------------------------------*/
+(define-simple-markup paragraph)
+
+;*---------------------------------------------------------------------*/
+;* footnote ... */
+;*---------------------------------------------------------------------*/
+(define-markup (footnote #!rest opts
+ #!key (ident #f) (class "footnote") (number #f))
+ (new container
+ (markup 'footnote)
+ (ident (symbol->string (gensym 'footnote)))
+ (class class)
+ (required-options '())
+ (options `((:number
+ ,(new unresolved
+ (proc (lambda (n e env)
+ (resolve-counter n env 'footnote #t)))))
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* linebreak ... */
+;*---------------------------------------------------------------------*/
+(define-markup (linebreak #!rest opts #!key (ident #f) (class #f))
+ (let ((ln (new markup
+ (ident (or ident (symbol->string (gensym 'linebreak))))
+ (class class)
+ (markup 'linebreak)))
+ (num (the-body opts)))
+ (cond
+ ((null? num)
+ ln)
+ ((not (null? (cdr num)))
+ (skribe-error 'linebreak "Illegal arguments" num))
+ ((not (and (integer? (car num)) (positive? (car num))))
+ (skribe-error 'linebreak "Illegal argument" (car num)))
+ (else
+ (vector->list (make-vector (car num) ln))))))
+
+;*---------------------------------------------------------------------*/
+;* hrule ... */
+;*---------------------------------------------------------------------*/
+(define-markup (hrule #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (width 100.) (height 1))
+ (new markup
+ (markup 'hrule)
+ (ident (or ident (symbol->string (gensym 'hrule))))
+ (class class)
+ (required-options '())
+ (options `((:width ,width)
+ (:height ,height)
+ ,@(the-options opts :ident :class)))
+ (body #f)))
+
+;*---------------------------------------------------------------------*/
+;* color ... */
+;*---------------------------------------------------------------------*/
+(define-markup (color #!rest
+ opts
+ #!key
+ (ident #f) (class "color")
+ (bg #f) (fg #f) (width #f) (margin #f))
+ (new container
+ (markup 'color)
+ (ident (or ident (symbol->string (gensym 'color))))
+ (class class)
+ (required-options '(:bg :fg :width))
+ (options `((:bg ,(if bg (skribe-use-color! bg) bg))
+ (:fg ,(if fg (skribe-use-color! fg) fg))
+ ,@(the-options opts :ident :class :bg :fg)))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* frame ... */
+;*---------------------------------------------------------------------*/
+(define-markup (frame #!rest
+ opts
+ #!key
+ (ident #f) (class "frame")
+ (width #f) (margin 2) (border 1))
+ (new container
+ (markup 'frame)
+ (ident (or ident (symbol->string (gensym 'frame))))
+ (class class)
+ (required-options '(:width :border :margin))
+ (options `((:margin ,margin)
+ (:border ,(cond
+ ((integer? border) border)
+ (border 1)
+ (else #f)))
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* font ... */
+;*---------------------------------------------------------------------*/
+(define-markup (font #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (size #f) (face #f))
+ (new container
+ (markup 'font)
+ (ident (or ident (symbol->string (gensym 'font))))
+ (class class)
+ (required-options '(:size))
+ (options (the-options opts :ident :class))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* flush ... */
+;*---------------------------------------------------------------------*/
+(define-markup (flush #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ side)
+ (case side
+ ((center left right)
+ (new container
+ (markup 'flush)
+ (ident (or ident (symbol->string (gensym 'flush))))
+ (class class)
+ (required-options '(:side))
+ (options (the-options opts :ident :class))
+ (body (the-body opts))))
+ (else
+ (skribe-error 'flush "Illegal side" side))))
+
+;*---------------------------------------------------------------------*/
+;* center ... */
+;*---------------------------------------------------------------------*/
+(define-simple-container center)
+
+;*---------------------------------------------------------------------*/
+;* pre ... */
+;*---------------------------------------------------------------------*/
+(define-simple-container pre)
+
+;*---------------------------------------------------------------------*/
+;* prog ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/prgm.skb:prog@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:prog@ */
+;*---------------------------------------------------------------------*/
+(define-markup (prog #!rest
+ opts
+ #!key
+ (ident #f) (class "prog")
+ (line 1) (linedigit #f) (mark ";!"))
+ (if (not (or (string? mark) (eq? mark #f)))
+ (skribe-error 'prog "Illegal mark" mark)
+ (new container
+ (markup 'prog)
+ (ident (or ident (symbol->string (gensym 'prog))))
+ (class class)
+ (required-options '(:line :mark))
+ (options (the-options opts :ident :class :linedigit))
+ (body (make-prog-body (the-body opts) line linedigit mark)))))
+
+;*---------------------------------------------------------------------*/
+;* source ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/prgm.skb:source@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:source@ */
+;*---------------------------------------------------------------------*/
+(define-markup (source #!rest
+ opts
+ #!key
+ language
+ (file #f) (start #f) (stop #f)
+ (definition #f) (tab 8))
+ (let ((body (the-body opts)))
+ (cond
+ ((and (not (null? body)) (or file start stop definition))
+ (skribe-error 'source
+ "file, start/stop, and definition are exclusive with body"
+ body))
+ ((and start stop definition)
+ (skribe-error 'source
+ "start/stop are exclusive with a definition"
+ body))
+ ((and (or start stop definition) (not file))
+ (skribe-error 'source
+ "start/stop and definition require a file specification"
+ file))
+ ((and definition (not language))
+ (skribe-error 'source
+ "definition requires a language specification"
+ definition))
+ ((and file (not (string? file)))
+ (skribe-error 'source "Illegal file" file))
+ ((and start (not (or (integer? start) (string? start))))
+ (skribe-error 'source "Illegal start" start))
+ ((and stop (not (or (integer? stop) (string? stop))))
+ (skribe-error 'source "Illegal start" stop))
+ ((and (integer? start) (integer? stop) (> start stop))
+ (skribe-error 'source
+ "start line > stop line"
+ (format "~a/~a" start stop)))
+ ((and language (not (language? language)))
+ (skribe-error 'source "Illegal language" language))
+ ((and tab (not (integer? tab)))
+ (skribe-error 'source "Illegal tab" tab))
+ (file
+ (let ((s (if (not definition)
+ (source-read-lines file start stop tab)
+ (source-read-definition file definition tab language))))
+ (if language
+ (source-fontify s language)
+ s)))
+ (language
+ (source-fontify body language))
+ (else
+ body))))
+
+;*---------------------------------------------------------------------*/
+;* language ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/prgm.skb:language@ */
+;*---------------------------------------------------------------------*/
+(define-markup (language #!key name (fontifier #f) (extractor #f))
+ (if (not (string? name))
+ (skribe-type-error 'language "Illegal name, " name "string")
+ (new language
+ (name name)
+ (fontifier fontifier)
+ (extractor extractor))))
+
+;*---------------------------------------------------------------------*/
+;* figure ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/figure.skb:figure@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:figure@ */
+;*---------------------------------------------------------------------*/
+(define-markup (figure #!rest
+ opts
+ #!key
+ (ident #f) (class "figure")
+ (legend #f) (number #t) (multicolumns #f))
+ (new container
+ (markup 'figure)
+ (ident (or ident
+ (let ((s (ast->string legend)))
+ (if (not (string=? s ""))
+ s
+ (symbol->string (gensym 'figure))))))
+ (class class)
+ (required-options '(:legend :number :multicolumns))
+ (options `((:number
+ ,(new unresolved
+ (proc (lambda (n e env)
+ (resolve-counter n env 'figure number)))))
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* parse-list-of ... */
+;* ------------------------------------------------------------- */
+;* The function table accepts two different prototypes. It */
+;* may receive its N elements in a list of N elements or in */
+;* a list of one element which is a list of N elements. This */
+;* gets rid of APPLY when calling container markup such as ITEMIZE */
+;* or TABLE. */
+;*---------------------------------------------------------------------*/
+(define (parse-list-of for markup lst)
+ (cond
+ ((null? lst)
+ '())
+ ((and (pair? lst)
+ (or (pair? (car lst)) (null? (car lst)))
+ (null? (cdr lst)))
+ (parse-list-of for markup (car lst)))
+ (else
+ (let loop ((lst lst))
+ (cond
+ ((null? lst)
+ '())
+ ((pair? (car lst))
+ (loop (car lst)))
+ (else
+ (let ((r (car lst)))
+ (if (not (is-markup? r markup))
+ (skribe-warning 2
+ for
+ (format "Illegal `~a' element, `~a' expected"
+ (if (markup? r)
+ (markup-markup r)
+ (find-runtime-type r))
+ markup)))
+ (cons r (loop (cdr lst))))))))))
+
+;*---------------------------------------------------------------------*/
+;* itemize ... */
+;*---------------------------------------------------------------------*/
+(define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol)
+ (new container
+ (markup 'itemize)
+ (ident (or ident (symbol->string (gensym 'itemize))))
+ (class class)
+ (required-options '(:symbol))
+ (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
+ (body (parse-list-of 'itemize 'item (the-body opts)))))
+
+;*---------------------------------------------------------------------*/
+;* enumerate ... */
+;*---------------------------------------------------------------------*/
+(define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol)
+ (new container
+ (markup 'enumerate)
+ (ident (or ident (symbol->string (gensym 'enumerate))))
+ (class class)
+ (required-options '(:symbol))
+ (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
+ (body (parse-list-of 'enumerate 'item (the-body opts)))))
+
+;*---------------------------------------------------------------------*/
+;* description ... */
+;*---------------------------------------------------------------------*/
+(define-markup (description #!rest opts #!key (ident #f) (class "description") symbol)
+ (new container
+ (markup 'description)
+ (ident (or ident (symbol->string (gensym 'description))))
+ (class class)
+ (required-options '(:symbol))
+ (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
+ (body (parse-list-of 'description 'item (the-body opts)))))
+
+;*---------------------------------------------------------------------*/
+;* 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 "Illegal key:" key "node")
+ (new container
+ (markup 'item)
+ (ident (or ident (symbol->string (gensym 'item))))
+ (class class)
+ (required-options '(:key))
+ (options `((:key ,key) ,@(the-options opts :ident :class :key)))
+ (body (the-body opts)))))
+
+;*---------------------------------------------------------------------*/
+;* table */
+;*---------------------------------------------------------------------*/
+(define-markup (table #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (border #f) (width #f)
+ (frame 'none) (rules 'none)
+ (cellstyle 'collapse) (cellpadding #f) (cellspacing #f))
+ (let ((frame (cond
+ ((string? frame)
+ (string->symbol frame))
+ ((not frame)
+ #f)
+ (else
+ frame)))
+ (rules (cond
+ ((string? rules)
+ (string->symbol rules))
+ ((not rules)
+ #f)
+ (else
+ rules)))
+ (frame-vals '(none above below hsides vsides lhs rhs box border))
+ (rules-vals '(none rows cols all header))
+ (cells-vals '(collapse separate)))
+ (cond
+ ((and frame (not (memq frame frame-vals)))
+ (skribe-error 'table
+ (format "frame should be one of \"~a\"" frame-vals)
+ frame))
+ ((and rules (not (memq rules rules-vals)))
+ (skribe-error 'table
+ (format "rules should be one of \"~a\"" rules-vals)
+ rules))
+ ((not (or (memq cellstyle cells-vals)
+ (string? cellstyle)
+ (number? cellstyle)))
+ (skribe-error 'table
+ (format "cellstyle should be one of \"~a\", or a number, or a string" cells-vals)
+ cellstyle))
+ (else
+ (new container
+ (markup 'table)
+ (ident (or ident (symbol->string (gensym 'table))))
+ (class class)
+ (required-options '(:width :frame :rules))
+ (options `((:frame ,frame)
+ (:rules ,rules)
+ (:cellstyle ,cellstyle)
+ ,@(the-options opts :ident :class)))
+ (body (parse-list-of 'table 'tr (the-body opts))))))))
+
+;*---------------------------------------------------------------------*/
+;* tr ... */
+;*---------------------------------------------------------------------*/
+(define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f))
+ (new container
+ (markup 'tr)
+ (ident (or ident (symbol->string (gensym 'tr))))
+ (class class)
+ (required-options '())
+ (options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '())
+ ,@(the-options opts :ident :class :bg)))
+ (body (parse-list-of 'tr 'tc (the-body opts)))))
+
+;*---------------------------------------------------------------------*/
+;* tc... */
+;*---------------------------------------------------------------------*/
+(define-markup (tc m
+ #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (width #f) (align 'center) (valign #f)
+ (colspan 1) (bg #f))
+ (let ((align (if (string? align)
+ (string->symbol align)
+ align))
+ (valign (if (string? valign)
+ (string->symbol valign)
+ valign)))
+ (cond
+ ((not (integer? colspan))
+ (skribe-type-error 'tc "Illegal colspan, " colspan "integer"))
+ ((not (symbol? align))
+ (skribe-type-error 'tc "Illegal align, " align "align"))
+ ((not (memq align '(#f center left right)))
+ (skribe-error
+ 'tc
+ "align should be one of 'left', `center', or `right'"
+ align))
+ ((not (memq valign '(#f top middle center bottom)))
+ (skribe-error
+ 'tc
+ "valign should be one of 'top', `middle', `center', or `bottom'"
+ valign))
+ (else
+ (new container
+ (markup 'tc)
+ (ident (or ident (symbol->string (gensym 'tc))))
+ (class class)
+ (required-options '(:width :align :valign :colspan))
+ (options `((markup ,m)
+ (:align ,align)
+ (:valign ,valign)
+ (:colspan ,colspan)
+ ,@(if bg
+ `((:bg ,(if bg (skribe-use-color! bg) bg)))
+ '())
+ ,@(the-options opts :ident :class :bg :align :valign)))
+ (body (the-body opts)))))))
+
+;*---------------------------------------------------------------------*/
+;* th ... */
+;*---------------------------------------------------------------------*/
+(define-markup (th #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (width #f) (align 'center) (valign #f)
+ (colspan 1) (bg #f))
+ (apply tc 'th opts))
+
+;*---------------------------------------------------------------------*/
+;* td ... */
+;*---------------------------------------------------------------------*/
+(define-markup (td #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (width #f) (align 'center) (valign #f)
+ (colspan 1) (bg #f))
+ (apply tc 'td opts))
+
+;*---------------------------------------------------------------------*/
+;* image ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/image.skb:image@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:image@ */
+;* latex: @ref ../../skr/latex.skr:image@ */
+;*---------------------------------------------------------------------*/
+(define-markup (image #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ file (url #f) (width #f) (height #f) (zoom #f))
+ (cond
+ ((not (or (string? file) (string? url)))
+ (skribe-error 'image "No file or url provided" file))
+ ((and (string? file) (string? url))
+ (skribe-error 'image "Both file and url provided" (list file url)))
+ (else
+ (new markup
+ (markup 'image)
+ (ident (or ident (symbol->string (gensym 'image))))
+ (class class)
+ (required-options '(:file :url :width :height))
+ (options (the-options opts :ident :class))
+ (body (the-body opts))))))
+
+;*---------------------------------------------------------------------*/
+;* blockquote */
+;*---------------------------------------------------------------------*/
+(define-simple-markup blockquote)
+
+;*---------------------------------------------------------------------*/
+;* Ornaments ... */
+;*---------------------------------------------------------------------*/
+(define-simple-markup roman)
+(define-simple-markup bold)
+(define-simple-markup underline)
+(define-simple-markup strike)
+(define-simple-markup emph)
+(define-simple-markup kbd)
+(define-simple-markup it)
+(define-simple-markup tt)
+(define-simple-markup code)
+(define-simple-markup var)
+(define-simple-markup samp)
+(define-simple-markup sf)
+(define-simple-markup sc)
+(define-simple-markup sub)
+(define-simple-markup sup)
+
+;*---------------------------------------------------------------------*/
+;* char ... */
+;*---------------------------------------------------------------------*/
+(define-markup (char char)
+ (cond
+ ((char? char)
+ (string char))
+ ((integer? char)
+ (string (integer->char char)))
+ ((and (string? char) (= (string-length char) 1))
+ char)
+ (else
+ (skribe-error 'char "Illegal char" char))))
+
+;*---------------------------------------------------------------------*/
+;* symbol ... */
+;*---------------------------------------------------------------------*/
+(define-markup (symbol symbol)
+ (let ((v (cond
+ ((symbol? symbol)
+ (symbol->string symbol))
+ ((string? symbol)
+ symbol)
+ (else
+ (skribe-error 'symbol
+ "Illegal argument (symbol expected)"
+ symbol)))))
+ (new markup
+ (markup 'symbol)
+ (body v))))
+
+;*---------------------------------------------------------------------*/
+;* ! ... */
+;*---------------------------------------------------------------------*/
+(define-markup (! format #!rest node)
+ (if (not (string? format))
+ (skribe-type-error '! "Illegal format:" format "string")
+ (new command
+ (fmt format)
+ (body node))))
+
+;*---------------------------------------------------------------------*/
+;* processor ... */
+;*---------------------------------------------------------------------*/
+(define-markup (processor #!rest opts
+ #!key (combinator #f) (engine #f) (procedure #f))
+ (cond
+ ((and combinator (not (procedure? combinator)))
+ (skribe-error 'processor "Combinator not a procedure" combinator))
+ ((and engine (not (engine? engine)))
+ (skribe-error 'processor "Illegal engine" engine))
+ ((and procedure
+ (or (not (procedure? procedure))
+ (not (correct-arity? procedure 2))))
+ (skribe-error 'processor "Illegal procedure" procedure))
+ (else
+ (new processor
+ (combinator combinator)
+ (engine engine)
+ (procedure (or procedure (lambda (n e) n)))
+ (body (the-body opts))))))
+
+;*---------------------------------------------------------------------*/
+;* Processors ... */
+;*---------------------------------------------------------------------*/
+(define-processor-markup html-processor)
+(define-processor-markup tex-processor)
+
+;*---------------------------------------------------------------------*/
+;* handle ... */
+;*---------------------------------------------------------------------*/
+(define-markup (handle #!rest opts
+ #!key (ident #f) (class "handle") value section)
+ (let ((body (the-body opts)))
+ (cond
+ (section
+ (error 'handle "Illegal handle `section' option" section)
+ (new unresolved
+ (proc (lambda (n e env)
+ (let ((s (resolve-ident section 'section n env)))
+ (new handle
+ (ast s)))))))
+ ((and (pair? body)
+ (null? (cdr body))
+ (markup? (car body)))
+ (new handle
+ (ast (car body))))
+ (else
+ (skribe-error 'handle "Illegal handle" opts)))))
+
+;*---------------------------------------------------------------------*/
+;* mailto ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/links.skb:mailto@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:mailto@ */
+;*---------------------------------------------------------------------*/
+(define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text)
+ (new markup
+ (markup 'mailto)
+ (ident (or ident (symbol->string (gensym 'ident))))
+ (class class)
+ (required-options '(:text))
+ (options (the-options opts :ident :class))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* *mark-table* ... */
+;*---------------------------------------------------------------------*/
+(define *mark-table* (make-hashtable))
+
+;*---------------------------------------------------------------------*/
+;* mark ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/links.skb:mark@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:mark@ */
+;*---------------------------------------------------------------------*/
+(define-markup (mark #!rest opts #!key (ident #f) (class "mark") (text #f))
+ (let ((bd (the-body opts)))
+ (cond
+ ((and (pair? bd) (not (null? (cdr bd))))
+ (skribe-error 'mark "Too many argument provided" bd))
+ ((null? bd)
+ (skribe-error 'mark "Missing argument" '()))
+ ((not (string? (car bd)))
+ (skribe-type-error 'mark "Illegal ident:" (car bd) "string"))
+ (ident
+ (skribe-error 'mark "Illegal `ident:' option" ident))
+ (else
+ (let* ((bs (ast->string bd))
+ (n (new markup
+ (markup 'mark)
+ (ident bs)
+ (class class)
+ (options (the-options opts :ident :class :text))
+ (body text))))
+ (hashtable-put! *mark-table* bs n)
+ n)))))
+
+;*---------------------------------------------------------------------*/
+;* ref ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/links.skb:ref@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:ref@ */
+;* latex: @ref ../../skr/latex.skr:ref@ */
+;*---------------------------------------------------------------------*/
+(define-markup (ref #!rest
+ opts
+ #!key
+ (class #f)
+ (ident #f)
+ (text #f)
+ (chapter #f)
+ (section #f)
+ (subsection #f)
+ (subsubsection #f)
+ (bib #f)
+ (bib-table (default-bib-table))
+ (url #f)
+ (figure #f)
+ (mark #f)
+ (handle #f)
+ (line #f)
+ (skribe #f)
+ (page #f))
+ (define (unref ast text kind)
+ (let ((msg (format "Can't find `~a': " kind)))
+ (if (ast? ast)
+ (begin
+ (skribe-warning/ast 1 ast 'ref msg text)
+ (new markup
+ (markup 'unref)
+ (ident (symbol->string 'unref))
+ (class class)
+ (required-options '(:text))
+ (options `((kind ,kind) ,@(the-options opts :ident :class)))
+ (body (list text ": " (ast->file-location ast)))))
+ (begin
+ (skribe-warning 1 'ref msg text)
+ (new markup
+ (markup 'unref)
+ (ident (symbol->string 'unref))
+ (class class)
+ (required-options '(:text))
+ (options `((kind ,kind) ,@(the-options opts :ident :class)))
+ (body text))))))
+ (define (skribe-ref skribe)
+ (let ((path (find-file/path skribe (skribe-path))))
+ (if (not path)
+ (unref #f skribe 'sui-file)
+ (let* ((sui (load-sui path))
+ (os (the-options opts :skribe :class :text))
+ (u (sui-ref->url (dirname path) sui ident os)))
+ (if (not u)
+ (unref #f os 'sui-ref)
+ (ref :url u :text text :ident ident :class class))))))
+ (define (handle-ref text)
+ (new markup
+ (markup 'ref)
+ (ident (symbol->string 'ref))
+ (class class)
+ (required-options '(:text))
+ (options `((kind handle) ,@(the-options opts :ident :class)))
+ (body text)))
+ (define (doref text kind)
+ (if (not (string? text))
+ (skribe-type-error 'ref "Illegal reference" text "string")
+ (new unresolved
+ (proc (lambda (n e env)
+ (let ((s (resolve-ident text kind n env)))
+ (if s
+ (new markup
+ (markup 'ref)
+ (ident (symbol->string 'ref))
+ (class class)
+ (required-options '(:text))
+ (options `((kind ,kind)
+ (mark ,text)
+ ,@(the-options opts :ident :class)))
+ (body (new handle
+ (ast s))))
+ (unref n text (or kind 'ident)))))))))
+ (define (mark-ref mark)
+ (if (not (string? mark))
+ (skribe-type-error 'mark "Illegal mark, " mark "string")
+ (new unresolved
+ (proc (lambda (n e env)
+ (let ((s (hashtable-get *mark-table* mark)))
+ (if s
+ (new markup
+ (markup 'ref)
+ (ident (symbol->string 'ref))
+ (class class)
+ (required-options '(:text))
+ (options `((kind mark)
+ (mark ,mark)
+ ,@(the-options opts :ident :class)))
+ (body (new handle
+ (ast s))))
+ (unref n mark 'mark))))))))
+ (define (make-bib-ref v)
+ (let ((s (resolve-bib bib-table v)))
+ (if s
+ (let* ((n (new markup
+ (markup 'bib-ref)
+ (ident (symbol->string 'bib-ref))
+ (class class)
+ (required-options '(:text))
+ (options (the-options opts :ident :class))
+ (body (new handle
+ (ast s)))))
+ (h (new handle (ast n)))
+ (o (markup-option s 'used)))
+ (markup-option-add! s 'used (if (pair? o) (cons h o) (list h)))
+ n)
+ (unref #f v 'bib))))
+ (define (bib-ref text)
+ (if (pair? text)
+ (new markup
+ (markup 'bib-ref+)
+ (ident (symbol->string 'bib-ref+))
+ (class class)
+ (options (the-options opts :ident :class))
+ (body (map make-bib-ref text)))
+ (make-bib-ref text)))
+ (define (url-ref)
+ (new markup
+ (markup 'url-ref)
+ (ident (symbol->string 'url-ref))
+ (class class)
+ (required-options '(:url :text))
+ (options (the-options opts :ident :class))))
+ (define (line-ref line)
+ (new unresolved
+ (proc (lambda (n e env)
+ (let ((l (resolve-line line)))
+ (if (pair? l)
+ (new markup
+ (markup 'line-ref)
+ (ident (symbol->string 'line-ref))
+ (class class)
+ (options `((:text ,(markup-ident (car l)))
+ ,@(the-options opts :ident :class)))
+ (body (new handle
+ (ast (car l)))))
+ (unref n line 'line)))))))
+ (let ((b (the-body opts)))
+ (if (not (null? b))
+ (skribe-warning 1 'ref "Arguments ignored " b))
+ (cond
+ (skribe (skribe-ref skribe))
+ (handle (handle-ref handle))
+ (ident (doref ident #f))
+ (chapter (doref chapter 'chapter))
+ (section (doref section 'section))
+ (subsection (doref subsection 'subsection))
+ (subsubsection (doref subsubsection 'subsubsection))
+ (figure (doref figure 'figure))
+ (mark (mark-ref mark))
+ (bib (bib-ref bib))
+ (url (url-ref))
+ (line (line-ref line))
+ (else (skribe-error 'ref "Illegal reference" opts)))))
+
+;*---------------------------------------------------------------------*/
+;* resolve ... */
+;*---------------------------------------------------------------------*/
+(define-markup (resolve fun)
+ (new unresolved
+ (proc fun)))
+
+;*---------------------------------------------------------------------*/
+;* bibliography ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/bib.skb:bibliography@ */
+;*---------------------------------------------------------------------*/
+(define-markup (bibliography #!rest files
+ #!key
+ (command #f) (bib-table (default-bib-table)))
+ (for-each (lambda (f)
+ (cond
+ ((string? f)
+ (bib-load! bib-table f command))
+ ((pair? f)
+ (bib-add! bib-table f))
+ (else
+ (skribe-error "bibliography" "Illegal entry" f))))
+ (the-body files)))
+
+;*---------------------------------------------------------------------*/
+;* the-bibliography ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/bib.skb:the-bibliography@ */
+;* writer: */
+;* base: @ref ../../skr/base.skr:the-bibliography@ */
+;*---------------------------------------------------------------------*/
+(define-markup (the-bibliography #!rest opts
+ #!key
+ pred
+ (bib-table (default-bib-table))
+ (sort bib-sort/authors)
+ (count 'partial))
+ (if (not (memq count '(partial full)))
+ (skribe-error 'the-bibliography
+ "Cound must be either `partial' or `full'"
+ count)
+ (new unresolved
+ (proc (lambda (n e env)
+ (resolve-the-bib bib-table
+ (new handle (ast n))
+ sort
+ pred
+ count
+ (the-options opts)))))))
+
+;*---------------------------------------------------------------------*/
+;* make-index ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/index.skb:make-index@ */
+;*---------------------------------------------------------------------*/
+(define-markup (make-index ident)
+ (make-index-table ident))
+
+;*---------------------------------------------------------------------*/
+;* index ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/index.skb:index@ */
+;*---------------------------------------------------------------------*/
+(define-markup (index #!rest
+ opts
+ #!key
+ (ident #f) (class "index")
+ (note #f) (index #f) (shape #f)
+ (url #f))
+ (let* ((entry-name (the-body opts))
+ (ename (cond
+ ((string? entry-name)
+ entry-name)
+ ((and (pair? entry-name) (every string? entry-name))
+ (apply string-append entry-name))
+ (else
+ (skribe-error
+ 'index
+ "entry-name must be either a string or a list of strings"
+ entry-name))))
+ (table (cond
+ ((not index) (default-index))
+ ((index? index) index)
+ (else (skribe-type-error 'index
+ "Illegal index table, "
+ index
+ "index"))))
+ (m (mark (symbol->string (gensym))))
+ (h (new handle (ast m)))
+ (new (new markup
+ (markup '&index-entry)
+ (ident (or ident (symbol->string (gensym 'index))))
+ (class class)
+ (options `((name ,ename) ,@(the-options opts :ident :class)))
+ (body (if url
+ (ref :url url :text (or shape ename))
+ (ref :handle h :text (or shape ename)))))))
+ ;; New is bound to a dummy option of the mark in order
+ ;; to make new options verified.
+ (markup-option-add! m 'to-verify new)
+ (hashtable-update! table
+ ename
+ (lambda (cur) (cons new cur))
+ (list new))
+ m))
+
+;*---------------------------------------------------------------------*/
+;* the-index ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/index.skb:the-index@ */
+;* writer: */
+;* base: @ref ../../skr/base.skr:the-index@ */
+;* html: @ref ../../skr/html.skr:the-index-header@ */
+;*---------------------------------------------------------------------*/
+(define-markup (the-index #!rest
+ opts
+ #!key
+ (ident #f)
+ (class "the-index")
+ (split #f)
+ (char-offset 0)
+ (header-limit 50)
+ (column 1))
+ (let ((bd (the-body opts)))
+ (cond
+ ((not (and (integer? char-offset) (>= char-offset 0)))
+ (skribe-error 'the-index "Illegal char offset" char-offset))
+ ((not (integer? column))
+ (skribe-error 'the-index "Illegal column number" column))
+ ((not (every? index? bd))
+ (skribe-error 'the-index
+ "Illegal indexes"
+ (filter (lambda (o) (not (index? o))) bd)))
+ (else
+ (new unresolved
+ (proc (lambda (n e env)
+ (resolve-the-index (ast-loc n)
+ ident class
+ bd
+ split
+ char-offset
+ header-limit
+ column))))))))