summaryrefslogtreecommitdiff
path: root/doc/skr
diff options
context:
space:
mode:
Diffstat (limited to 'doc/skr')
-rw-r--r--doc/skr/api.skr575
-rw-r--r--doc/skr/env.skr32
-rw-r--r--doc/skr/extension.skr95
-rw-r--r--doc/skr/manual.skr281
4 files changed, 0 insertions, 983 deletions
diff --git a/doc/skr/api.skr b/doc/skr/api.skr
deleted file mode 100644
index a27c3a4..0000000
--- a/doc/skr/api.skr
+++ /dev/null
@@ -1,575 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/doc/skr/api.skr */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Sep 3 07:45:33 2003 */
-;* Last change : Tue Apr 6 06:51:34 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Skribe style for documenting Lisp APIs. */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* Html configuration */
-;*---------------------------------------------------------------------*/
-(let* ((he (find-engine 'html))
- (tro (markup-writer-get 'tr he)))
- (markup-writer 'tr he
- :class 'api-table-header
- :options '(:width :bg)
- :action (lambda (n e)
- (let ((c (engine-custom e 'section-title-background)))
- (markup-option-add! n :bg c)
- (output n e tro))))
- (markup-writer 'tr he
- :class 'api-table-prototype
- :options '(:width :bg)
- :action (lambda (n e)
- (let ((c (engine-custom e 'title-background)))
- (markup-option-add! n :bg c)
- (output n e tro))))
- (markup-writer 'tr he
- :class 'api-symbol-prototype
- :options '(:width :bg)
- :action (lambda (n e)
- (let ((c (engine-custom e 'title-background)))
- (markup-option-add! n :bg c)
- (output n e tro)))))
-
-;*---------------------------------------------------------------------*/
-;* LaTeX configuration */
-;*---------------------------------------------------------------------*/
-(let* ((le (find-engine 'latex))
- (tro (markup-writer-get 'tr le)))
- (markup-writer 'tr le
- :class 'api-table-prototype
- :options '(:width :bg)
- :action #f)
- (markup-writer 'tr le
- :class 'api-table-header
- :options '(:width :bg)
- :action (lambda (n e)
- (let ((c (engine-custom e 'section-title-background)))
- (markup-option-add! n :bg c)
- (output n e tro)))))
-
-;*---------------------------------------------------------------------*/
-;* api-search-definition ... */
-;* ------------------------------------------------------------- */
-;* Find a definition inside a source file. */
-;*---------------------------------------------------------------------*/
-(define (api-search-definition id file pred)
- (let ((f (find-file/path file *skribe-source-path*)))
- (if (not (string? f))
- (skribe-error 'api-search-definition
- (format "Can't find source file `~a' in path" file)
- *skribe-source-path*)
- (with-input-from-file f
- (lambda ()
- (let loop ((exp (read)))
- (if (eof-object? exp)
- (skribe-error 'api-search-definition
- (format "Can't find `~a' definition" id)
- file)
- (or (pred id exp) (loop (read))))))))))
-
-;*---------------------------------------------------------------------*/
-;* api-compare-set ... */
-;* ------------------------------------------------------------- */
-;* This function compares two sets. It returns either #t */
-;* is they are equal, or two subsets which contain elements */
-;* not present in the arguments. For instance: */
-;* (api-compare-set '(foo bar) '(bar foo)) ==> #t */
-;* (api-compare-set '(foo gee) '(gee bar)) ==> '((foo) (bar)) */
-;*---------------------------------------------------------------------*/
-(define (api-compare-set s1 s2)
- (let ((d1 (filter (lambda (x) (not (memq x s2))) s1))
- (d2 (filter (lambda (x) (not (memq x s1))) s2)))
- (or (and (null? d1) (null? d2))
- (list d1 d2))))
-
-;*---------------------------------------------------------------------*/
-;* keyword->symbol ... */
-;*---------------------------------------------------------------------*/
-(define (keyword->symbol kwd)
- (let ((s (keyword->string kwd)))
- (if (char=? #\: (string-ref s 0))
- ;; Bigloo
- (string->symbol (substring s 1 (string-length s)))
- ;; STklos
- (string->symbol s))))
-
-;*---------------------------------------------------------------------*/
-;* define-markup? ... */
-;*---------------------------------------------------------------------*/
-(define (define-markup? id o)
- (match-case o
- (((or define-markup define define-inline)
- ((? (lambda (x) (eq? x id))) . (? (lambda (x) (or (pair? x) (null? x))))) . ?-)
- o)
- ((define-simple-markup (? (lambda (x) (eq? x id))))
- o)
- ((define-simple-container (? (lambda (x) (eq? x id))))
- o)
- (else
- #f)))
-
-;*---------------------------------------------------------------------*/
-;* make-engine? ... */
-;*---------------------------------------------------------------------*/
-(define (make-engine? id o)
- (match-case o
- (((or make-engine copy-engine) (quote (? (lambda (x) (eq? x id)))) . ?-)
- o)
- ((quasiquote . ?-)
- #f)
- ((quote . ?-)
- #f)
- ((?a . ?d)
- (or (make-engine? id a) (make-engine? id d)))
- (else
- #f)))
-
-;*---------------------------------------------------------------------*/
-;* make-engine-custom ... */
-;*---------------------------------------------------------------------*/
-(define (make-engine-custom def)
- (match-case (memq :custom def)
- ((:custom (quote ?custom) . ?-)
- custom)
- ((:custom ?custom . ?-)
- (eval custom))
- (else
- '())))
-
-;*---------------------------------------------------------------------*/
-;* define-markup-formals ... */
-;* ------------------------------------------------------------- */
-;* Returns the formal parameters of a define-markup (not the */
-;* options). */
-;*---------------------------------------------------------------------*/
-(define (define-markup-formals def)
- (match-case def
- ((?- (?- . ?args) . ?-)
- (if (symbol? args)
- (list args)
- (let loop ((args args)
- (res '()))
- (cond
- ((null? args)
- (reverse! res))
- ((symbol? args)
- (reverse! (cons args res)))
- ((not (symbol? (car args)))
- (reverse! res))
- (else
- (loop (cdr args) (cons (car args) res)))))))
- ((define-simple-markup ?-)
- '())
- ((define-simple-container ?-)
- '())
- (else
- (skribe-error 'define-markup-formals
- "Illegal `define-markup' form"
- def))))
-
-;*---------------------------------------------------------------------*/
-;* define-markup-options ... */
-;* ------------------------------------------------------------- */
-;* Returns the options parameters of a define-markup. */
-;*---------------------------------------------------------------------*/
-(define (define-markup-options def)
- (match-case def
- ((?- (?- . ?args) . ?-)
- (if (not (list? args))
- '()
- (let ((keys (memq #!key args)))
- (if (pair? keys)
- (cdr keys)
- '()))))
- ((define-simple-markup ?-)
- '((ident #f) (class #f)))
- ((define-simple-container ?-)
- '((ident #f) (class #f)))
- (else
- (skribe-error 'define-markup-formals
- "Illegal `define-markup' form"
- def))))
-
-;*---------------------------------------------------------------------*/
-;* define-markup-rest ... */
-;* ------------------------------------------------------------- */
-;* Returns the rest parameter of a define-markup. */
-;*---------------------------------------------------------------------*/
-(define (define-markup-rest def)
- (match-case def
- ((?- (?- . ?args) . ?-)
- (if (not (pair? args))
- args
- (let ((l (last-pair args)))
- (if (symbol? (cdr l))
- (cdr l)
- (let ((rest (memq #!rest args)))
- (if (pair? rest)
- (if (or (not (pair? (cdr rest)))
- (not (symbol? (cadr rest))))
- (skribe-error 'define-markup-rest
- "Illegal `define-markup' form"
- def)
- (cadr rest))
- #f))))))
- ((define-simple-markup ?-)
- 'node)
- ((define-simple-container ?-)
- 'node)
- (else
- (skribe-error 'define-markup-formals
- "Illegal `define-markup' form"
- def))))
-
-;*---------------------------------------------------------------------*/
-;* doc-check-arguments ... */
-;*---------------------------------------------------------------------*/
-(define (doc-check-arguments id args dargs)
- (if (not args)
- (skribe-error 'doc-check-arguments id args))
- (if (not dargs)
- (skribe-error 'doc-check-arguments id dargs))
- (let* ((s1 (map (lambda (x) (if (pair? x) (car x) x)) args))
- (s2 (map (lambda (x)
- (let ((i (car x)))
- (if (keyword? i)
- (keyword->symbol i)
- i)))
- dargs))
- (d (api-compare-set s1 s2)))
- (if (pair? d)
- (let ((d1 (car d))
- (d2 (cadr d)))
- (if (pair? d1)
- (skribe-error 'doc-markup
- (format "~a: missing descriptions" id)
- d1)
- (skribe-error 'doc-markup
- (format "~a: extra descriptions" id)
- d2))))))
-
-;*---------------------------------------------------------------------*/
-;* exp->skribe ... */
-;*---------------------------------------------------------------------*/
-(define (exp->skribe exp)
- (cond
- ((number? exp) exp)
- ((string? exp) (string-append "\"" exp "\""))
- ((eq? exp #f) "#f")
- ((eq? exp #t) "#t")
- ((symbol? exp) (symbol->string exp))
- ((equal? exp '(quote ())) "'()")
- ((ast? exp)
- (table :cellpadding 0 :cellspacing 0
- (tr (td :align 'left exp))))
- (else
- (match-case exp
- ((quote (and ?sym (? symbol?)))
- (string-append "'" (symbol->string sym)))
- (else
- (with-output-to-string (lambda () (write exp))))))))
-
-;*---------------------------------------------------------------------*/
-;* doc-markup-proto ... */
-;*---------------------------------------------------------------------*/
-(define (doc-markup-proto id options formals rest)
- (define (option opt)
- (if (pair? opt)
- (if (eq? (cadr opt) #f)
- (list " [" (keyword (car opt)) "]")
- (list " [" (keyword (car opt)) " "
- (code (exp->skribe (cadr opt))) "]"))
- (list " " (keyword opt))))
- (define (formal f)
- (list " " (param f)))
- (code (list (bold "(") (bold :class 'api-proto-ident (format "~a" id)))
- (map option (sort options
- (lambda (s1 s2)
- (cond
- ((and (pair? s1) (not (pair? s2)))
- #f)
- ((and (pair? s2) (not (pair? s1)))
- #t)
- (else
- #t)))))
- (if (pair? formals)
- (map formal formals))
- (if rest (list " " (param rest)))
- (bold ")")))
-
-;*---------------------------------------------------------------------*/
-;* doc-markup ... */
-;*---------------------------------------------------------------------*/
-(define-markup (doc-markup id args
- #!rest
- opts
- #!key
- (writer-id #f)
- (common-args '((:ident "The node identifier.")
- (:class "The node class.")))
- (ignore-args '(&skribe-eval-location))
- (force-args '())
- (idx *markup-index*)
- (idx-note "definition")
- (idx-suffix #f)
- (source "src/common/api.scm")
- (def #f)
- (see-also '())
- (others '())
- (force-engines '())
- (engines *api-engines*)
- (sui #f)
- &skribe-eval-location)
- (define (opt-engine-support opt)
- ;; find the engines providing a writer for id
- (map (lambda (e)
- (let* ((id (engine-ident e))
- (s (symbol->string id)))
- (if (engine-format? "latex")
- (list s " ")
- (list (if sui
- (ref :skribe sui
- :mark (string-append s "-engine")
- :text s)
- (ref :mark (string-append s "-engine")
- :text s))
- " "))))
- (if (pair? force-engines)
- force-engines
- (filter (lambda (e)
- (or (memq opt '(:ident :class))
- (memq opt force-args)
- (let ((w (markup-writer-get (or writer-id id)
- e)))
- (cond
- ((not (writer? w))
- #f)
- (else
- (let ((o (writer-options w)))
- (cond
- ((eq? o 'all)
- #t)
- ((not (pair? o))
- #f)
- (else
- (memq opt o)))))))))
- engines))))
- (cond
- ((and def source)
- (skribe-error 'doc-markup "source and def both specified" id))
- ((and (not def) (not source))
- (skribe-error 'doc-markup "source or def must be specified" id))
- (else
- (let* ((d (or def (api-search-definition id source define-markup?)))
- (od (map (lambda (o)
- (api-search-definition o source define-markup?))
- others))
- (args (append common-args args))
- (formals (define-markup-formals d))
- (fformals (filter (lambda (s)
- (let ((c (assq s args)))
- (not
- (and (pair? c)
- (eq? (cadr c) 'ignore)))))
- formals))
- (options (filter (lambda (s)
- (not (memq s ignore-args)))
- (define-markup-options d)))
- (dformals (filter (lambda (x)
- (symbol? (car x)))
- args))
- (doptions (filter (lambda (x)
- (and (keyword? (car x))
- ;; useful for STklos only
- (not (eq? (car x) #!rest))))
- args))
- (drest (filter (lambda (x)
- (eq? #!rest (car x)))
- args))
- (dargs (and (pair? drest) (cadr (car drest))))
- (p+ (cons (doc-markup-proto id options fformals dargs)
- (map (lambda (id def)
- (doc-markup-proto
- id
- (define-markup-options def)
- (define-markup-formals def)
- dargs))
- others od))))
- ;; doc table
- (define (doc-markup.html)
- (let ((df (map (lambda (f)
- (tr :bg *prgm-skribe-color*
- (td :colspan 2 :width 20. :align 'left
- (param (car f)) )
- (td :align 'left :width 80. (cadr f))))
- dformals))
- (dr (and (pair? drest)
- (tr :bg *prgm-skribe-color*
- (td :align 'left
- :valign 'top
- :colspan 2
- :width 20.
- (param (cadr (car drest))))
- (td :align 'left :width 80.
- (caddr (car drest))))))
- (do (map (lambda (f)
- (tr :bg *prgm-skribe-color*
- (td :align 'left
- :valign 'top
- :width 10.
- (param (car f)))
- (td :align 'left
- :valign 'top
- :width 20.
- (opt-engine-support (car f)))
- (td :align 'left :width 70. (cadr f))))
- doptions))
- (so (map (lambda (x)
- (let ((s (symbol->string x)))
- (list
- (ref :mark s :text (code s))
- " ")))
- see-also)))
- (table :border (if (engine-format? "latex") 1 0)
- :width (if (engine-format? "latex") #f *prgm-width*)
- `(,(tr :class 'api-table-prototype
- (th :colspan 3 :align 'left :width *prgm-width*
- "prototype"))
- ,@(map (lambda (p)
- (tr :bg *prgm-skribe-color*
- (td :colspan 3 :width *prgm-width*
- :align 'left p)))
- p+)
- ,@(if (pair? do)
- `(,(tr :class 'api-table-header
- (th :align 'left "option"
- :width 10.)
- (th :align 'center "engines"
- :width 20.)
- (th "description"))
- ,@do)
- '())
- ,@(if (or (pair? df) dr)
- `(,(tr :class 'api-table-header
- (th :colspan 2
- :align 'left
- :width 30.
- "argument")
- (th "description"))
- ,@(if (pair? df) df '())
- ,@(if dr (list dr) '()))
- '())
- ,@(if (pair? so)
- `(,(tr :class 'api-table-header
- (th :colspan 3 :align 'left
- (it "See also")))
- ,(tr :bg *prgm-skribe-color*
- (td :colspan 3 :align 'left so)))
- '())))))
- ;; doc enumerate
- (define (doc-markup.latex)
- (let ((df (map (lambda (f)
- (item :key (param (car f)) (cadr f)))
- dformals))
- (dr (if (pair? drest)
- (list (item :key (param (cadr (car drest)))
- (caddr (car drest))))
- '()))
- (do (map (lambda (f)
- (item :key (param (car f))
- (list (opt-engine-support (car f))
- (cadr f))))
- doptions))
- (so (map (lambda (x)
- (let ((s (symbol->string x)))
- (list
- (ref :mark s :page #t
- :text [,(code s), p.])
- " ")))
- see-also)))
- (list (center
- (frame :margin 5 :border 0 :width *prgm-width*
- (color :class 'api-table-prototype
- :margin 5 :width 100. :bg "#ccccff"
- p+)))
- (when (pair? do)
- (subsubsection :title "Options" :number #f :toc #f
- (description do)))
- (when (or (pair? df) (pair? dr))
- (subsubsection :title "Parameters" :number #f :toc #f
- (description (append df dr))))
- (when (pair? so)
- (subsubsection :title "See also" :number #f :toc #f
- (p so)
- (! "\\noindent"))))))
- ;; check all the descriptions
- (doc-check-arguments id formals dformals)
- (doc-check-arguments id options doptions)
- (if (and (pair? drest) (not (define-markup-rest d)))
- (skribe-error 'doc-markup "No rest argument for" id)
- options)
- (list (mark :class "public-definition" (symbol->string id))
- (map (lambda (i) (mark (symbol->string i))) others)
- (map (lambda (i)
- (let ((is (symbol->string i)))
- (index (if (string? idx-suffix)
- (string-append is idx-suffix)
- is)
- :index idx
- :note idx-note)))
- (cons id others))
- (cond
- ((engine-format? "latex")
- (doc-markup.latex))
- (else
- (center (doc-markup.html)))))))))
-
-;*---------------------------------------------------------------------*/
-;* doc-engine ... */
-;*---------------------------------------------------------------------*/
-(define-markup (doc-engine id args
- #!rest
- opts
- #!key
- (idx *custom-index*)
- source
- (def #f))
- (cond
- ((and def source)
- (skribe-error 'doc-engine "source and def both specified" id))
- ((and (not def) (not source))
- (skribe-error 'doc-engine "source or def must be specified" id))
- (else
- (let* ((d (or def (api-search-definition id source make-engine?)))
- (c (make-engine-custom d)))
- (doc-check-arguments id c args)
- (cond
- ((engine-format? "latex")
- #f)
- (else
- (center
- (apply table
- :width *prgm-width*
- (tr :class 'api-table-header
- (th :align 'left :width 20. "custom")
- (th :width 10. "default")
- (th "description"))
- (map (lambda (r)
- (tr :bg *prgm-skribe-color*
- (td :align 'left :valign 'top
- (list (index (symbol->string (car r))
- :index idx
- :note (format "~a custom" id))
- (symbol->string (car r))))
- (let ((def (assq (car r) c)))
- (td :valign 'top
- (code (exp->skribe (cadr def)))))
- (td :align 'left :valign 'top (cadr r))))
- (filter cadr args))))))))))
-
diff --git a/doc/skr/env.skr b/doc/skr/env.skr
deleted file mode 100644
index 09d5146..0000000
--- a/doc/skr/env.skr
+++ /dev/null
@@ -1,32 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/doc/skr/env.skr */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Mon Sep 1 10:22:42 2003 */
-;* Last change : Thu Jan 29 06:48:54 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The environment variables for the documentation. */
-;*=====================================================================*/
-
-(define *serrano-url* "http://www.inria.fr/mimosa/Manuel.Serrano")
-(define *serrano-mail* "Manuel.Serrano@sophia.inria.fr")
-(define *html-url* "http://www.w3.org/TR/html4")
-(define *html-form* "interact/forms.html")
-(define *emacs-url* "http://www.gnu.org/software/emacs")
-(define *xemacs-url* "http://www.xemacs.org")
-(define *texinfo-url* "http://www.texinfo.org")
-(define *r5rs-url* "http://www.inria.fr/mimosa/fp/Bigloo/doc/r5rs.html")
-(define *bigloo-url* "http://www.inria.fr/mimosa/fp/Bigloo")
-(define *skribe-user-doc-url* (string-append (skribe-doc-dir) "/user.html"))
-(define *skribe-dir-doc-url* (string-append (skribe-doc-dir) "/dir.html"))
-
-(define *prgm-width* 97.)
-(define *prgm-skribe-color* "#ffffcc")
-(define *prgm-default-color* "#ffffcc")
-(define *prgm-xml-color* "#ffcccc")
-(define *prgm-example-color* "#ccccff")
-(define *disp-color* "#ccffcc")
-(define *header-color* "#cccccc")
-
-(define *api-engines* (map find-engine '(html latex xml)))
diff --git a/doc/skr/extension.skr b/doc/skr/extension.skr
deleted file mode 100644
index ce10ce7..0000000
--- a/doc/skr/extension.skr
+++ /dev/null
@@ -1,95 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/doc/skr/extension.skr */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Tue Dec 23 07:18:36 2003 */
-;* Last change : Fri Jan 2 21:25:49 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Skribe package for documenting extensions */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* extension */
-;*---------------------------------------------------------------------*/
-(define-markup (extension #!rest opt
- #!key (ident (symbol->string (gensym 'extension)))
- (class "extension")
- title html-title ending author description
- (env '()))
- (new document
- (markup 'extension)
- (ident ident)
- (class class)
- (options (the-options opt))
- (body (the-body opt))
- (env (append env
- (list (list 'example-counter 0) (list 'example-env '())
- (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 '()))))))
-
-;*---------------------------------------------------------------------*/
-;* html engine */
-;*---------------------------------------------------------------------*/
-(let ((he (find-engine 'html)))
- (engine-custom-set! he 'web-book-main-browsing-extra
- (lambda (n e)
- (let ((i (let ((m (find-markup-ident "Index")))
- (and (pair? m) (car m)))))
- (if (not i)
- (table :width 100. :border 0 :cellspacing 0 :cellpadding 0
- (tr (td :align 'left :valign 'top (bold "Skribe: "))
- (td :align 'right :valign 'top
- (ref :url *skribe-dir-doc-url*
- :text "Directory")))
- (tr (td)
- (td :align 'right :valign 'top
- (ref :url *skribe-user-doc-url*
- :text "User Manual"))))
- (table :width 100. :border 0 :cellspacing 0 :cellpadding 0
- (tr (td :align 'left :valign 'top (bold "index:"))
- (td :align 'right (ref :handle (handle i))))
- (tr (td :align 'left :valign 'top (bold "Skribe: "))
- (td :align 'right :valign 'top
- (ref :url *skribe-dir-doc-url*
- :text "Directory")))
- (tr (td)
- (td :align 'right :valign 'top
- (ref :url *skribe-user-doc-url*
- :text "User Manual"))))))))
- (default-engine-set! he))
-
-;*---------------------------------------------------------------------*/
-;* extension-sui ... */
-;*---------------------------------------------------------------------*/
-(define (extension-sui n e)
- (define (sui)
- (display "(sui \"")
- (skribe-eval (markup-option n :title) html-title-engine)
- (display "\"\n")
- (printf " :file ~s\n" (sui-referenced-file n e))
- (printf " :description ~s\n" (markup-option n :description))
- (sui-marks n e)
- (display " )\n"))
- (if (string? *skribe-dest*)
- (let ((f (format "~a.sui" (prefix *skribe-dest*))))
- (with-output-to-file f sui))
- (sui)))
-
-;*---------------------------------------------------------------------*/
-;* project ... */
-;*---------------------------------------------------------------------*/
-(markup-writer 'extension
- :options '(:title :html-title :ending :author :description)
- :action (lambda (n e)
- (output n e (markup-writer-get 'document he)))
- :after (lambda (n e)
- (if (engine-custom e 'emit-sui)
- (extension-sui n e))))
-
-;*---------------------------------------------------------------------*/
-;* Restore the base engine */
-;*---------------------------------------------------------------------*/
-(default-engine-set! (find-engine 'base))
diff --git a/doc/skr/manual.skr b/doc/skr/manual.skr
deleted file mode 100644
index 1982237..0000000
--- a/doc/skr/manual.skr
+++ /dev/null
@@ -1,281 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/doc/skr/manual.skr */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Mon Sep 1 11:24:19 2003 */
-;* Last change : Mon Sep 13 19:18:48 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Skribe manuals and documentation pages style */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* Base configuration */
-;*---------------------------------------------------------------------*/
-(let ((be (find-engine 'base)))
- (markup-writer 'example be
- :options '(:legend :number)
- :action (lambda (n e)
- (let ((ident (markup-ident n))
- (number (markup-option n :number))
- (legend (markup-option n :legend)))
- (skribe-eval (mark ident) e)
- (skribe-eval (center
- (markup-body n)
- (if number (bold (format "Ex. ~a: " number)))
- legend)
- e)))))
-
-;*---------------------------------------------------------------------*/
-;* html-browsing-extra ... */
-;*---------------------------------------------------------------------*/
-(define (html-browsing-extra n e)
- (let ((i1 (let ((m (find-markup-ident "Index")))
- (and (pair? m) (car m))))
- (i2 (let ((m (find-markup-ident "markups-index")))
- (and (pair? m) (car m)))))
- (cond
- ((not i1)
- (skribe-error 'left-margin "Can't find section" "Index"))
- ((not i2)
- (skribe-error 'left-margin "Can't find chapter" "Standard Markups"))
- (else
- (table :width 100.
- :border 0
- :cellspacing 0 :cellpadding 0
- (tr (td :align 'left :valign 'top (bold "index:"))
- (td :align 'right (ref :handle (handle i1) :text "Global")))
- (tr (td :align 'left :valign 'top (bold "markups:"))
- (td :align 'right (ref :handle (handle i2) :text "Index")))
- (tr (td :align 'left :valign 'top (bold "extensions:"))
- (td :align 'right (ref :url *skribe-dir-doc-url*
- :text "Directory"))))))))
-
-;*---------------------------------------------------------------------*/
-;* Html configuration */
-;*---------------------------------------------------------------------*/
-(let* ((he (find-engine 'html))
- (bd (markup-writer-get 'bold he)))
- (markup-writer 'bold he
- :class 'api-proto-ident
- :before "<font color=\"red\">"
- :action (lambda (n e) (output n e bd))
- :after "</font>")
- (engine-custom-set! he 'web-book-main-browsing-extra html-browsing-extra)
- (engine-custom-set! he 'favicon "lambda.gif"))
-
-;*---------------------------------------------------------------------*/
-;* LaTeX */
-;*---------------------------------------------------------------------*/
-(let* ((le (find-engine 'latex))
- (opckg (engine-custom le 'usepackage))
- (lpckg "\\usepackage{fullpage}\n\\usepackage{eurosym}\n")
- (npckg (if (string? opckg)
- (string-append lpckg opckg)
- lpckg)))
- (engine-custom-set! le 'documentclass "\\documentclass{book}")
- (engine-custom-set! le 'usepackage npckg))
-
-;*---------------------------------------------------------------------*/
-;* prgm ... */
-;*---------------------------------------------------------------------*/
-(define-markup (prgm #!rest opts #!key (language skribe) (line #f) (file #f) (definition #f))
- (let* ((c (cond
- ((eq? language skribe) *prgm-skribe-color*)
- ((eq? language xml) *prgm-xml-color*)
- (else *prgm-default-color*)))
- (sc (cond
- ((and file definition)
- (source :language language :file file :definition definition))
- (file
- (source :language language :file file))
- (else
- (source :language language (the-body opts)))))
- (pr (cond
- (line
- (prog :line line sc))
- (else
- (pre sc)))))
- (center
- (frame :margin 5 :border 0 :width *prgm-width*
- (color :margin 5 :width 100. :bg c pr)))))
-
-;*---------------------------------------------------------------------*/
-;* disp ... */
-;*---------------------------------------------------------------------*/
-(define-markup (disp #!rest opts #!key (verb #f) (line #f) (bg *disp-color*))
- (if (engine-format? "latex")
- (if verb
- (pre (the-body opts))
- (the-body opts))
- (center
- (frame :margin 5 :border 0 :width *prgm-width*
- (color :margin 5 :width 100. :bg bg
- (if verb
- (pre (the-body opts))
- (the-body opts)))))))
-
-;*---------------------------------------------------------------------*/
-;* keyword ... */
-;*---------------------------------------------------------------------*/
-(define-markup (keyword arg)
- (new markup
- (markup '&source-key)
- (body (cond
- ((keyword? arg)
- (keyword->string arg))
- ((symbol? arg)
- (string-append ":" (symbol->string arg)))
- (else
- arg)))))
-
-;*---------------------------------------------------------------------*/
-;* param ... */
-;*---------------------------------------------------------------------*/
-(define-markup (param arg)
- (cond
- ((keyword? arg)
- (keyword arg))
- ((symbol? arg)
- (code (symbol->string arg)))
- (else
- arg)))
-
-;*---------------------------------------------------------------------*/
-;* example ... */
-;*---------------------------------------------------------------------*/
-(define-markup (example #!rest opts #!key legend class)
- (new container
- (markup 'example)
- (ident (symbol->string (gensym 'example)))
- (class class)
- (required-options '(:legend :number))
- (options `((:number
- ,(new unresolved
- (proc (lambda (n e env)
- (resolve-counter n env 'example #t)))))
- ,@(the-options opts :ident :class)))
- (body (the-body opts))))
-
-;*---------------------------------------------------------------------*/
-;* example-produce ... */
-;*---------------------------------------------------------------------*/
-(define-markup (example-produce example . produce)
- (list (it "Example:")
- example
- (if (pair? produce)
- (list (paragraph "Produces:") (car produce)))))
-
-;*---------------------------------------------------------------------*/
-;* markup-ref ... */
-;*---------------------------------------------------------------------*/
-(define-markup (markup-ref mk)
- (ref :mark mk :text (code mk)))
-
-;*---------------------------------------------------------------------*/
-;* &the-index ... */
-;*---------------------------------------------------------------------*/
-(markup-writer '&the-index
- :class 'markup-index
- :options '(:column)
- :before (lambda (n e)
- (output (markup-option n 'header) e))
- :action (lambda (n e)
- (define (make-mark-entry n fst)
- (let ((l (tr :class 'index-mark-entry
- (td :colspan 2 :align 'left
- (bold (it (sf n)))))))
- (if fst
- (list l)
- (list (tr (td :colspan 2)) l))))
- (define (make-primary-entry n p)
- (let* ((note (markup-option n :note))
- (b (markup-body n)))
- (when p
- (markup-option-add! b :text
- (list (markup-option b :text)
- ", p."))
- (markup-option-add! b :page #t))
- (tr :class 'index-primary-entry
- (td :colspan 2 :valign 'top :align 'left b))))
- (define (make-column ie p)
- (let loop ((ie ie)
- (f #t))
- (cond
- ((null? ie)
- '())
- ((not (pair? (car ie)))
- (append (make-mark-entry (car ie) f)
- (loop (cdr ie) #f)))
- (else
- (cons (make-primary-entry (caar ie) p)
- (loop (cdr ie) #f))))))
- (define (make-sub-tables ie nc p)
- (define (split-list l num)
- (let loop ((l l)
- (i 0)
- (acc '())
- (res '()))
- (cond
- ((null? l)
- (reverse! (cons (reverse! acc) res)))
- ((= i num)
- (loop l
- 0
- '()
- (cons (reverse! acc) res)))
- (else
- (loop (cdr l)
- (+ i 1)
- (cons (car l) acc)
- res)))))
- (let* ((l (length ie))
- (w (/ 100. nc))
- (iepc (let ((d (/ l nc)))
- (if (integer? d)
- (inexact->exact d)
- (+ 1 (inexact->exact (truncate d))))))
- (split (split-list ie iepc)))
- (tr (map (lambda (ies)
- (td :valign 'top :width w
- (if (pair? ies)
- (table :width 100. (make-column ies p))
- "")))
- split))))
- (let* ((ie (markup-body n))
- (nc (markup-option n :column))
- (pref (eq? (engine-custom e 'index-page-ref) #t))
- (loc (ast-loc n))
- (t (cond
- ((null? ie)
- "")
- ((or (not (integer? nc)) (= nc 1))
- (table :width 100. :&skribe-eval-location loc
- (make-column ie pref)))
- (else
- (table :width 100. :&skribe-eval-location loc
- (make-sub-tables ie nc pref))))))
- (output (skribe-eval t e) e))))
-
-;*---------------------------------------------------------------------*/
-;* compiler-command ... */
-;*---------------------------------------------------------------------*/
-(define-markup (compiler-command bin . opts)
- (disp :verb #t
- (color :fg "red" (bold bin))
- (map (lambda (o)
- (list " [" (it o) "]"))
- opts)
- "..."))
-
-;*---------------------------------------------------------------------*/
-;* compiler-options ... */
-;*---------------------------------------------------------------------*/
-(define-markup (compiler-options bin)
- (skribe-message " [executing: ~a --options]\n" bin)
- (let ((port (open-input-file (format "| ~a --options" bin))))
- (let ((opts (read port)))
- (close-input-port port)
- (apply description (map (lambda (opt) (item :key (bold (car opt))
- (cadr opt) "."))
- opts)))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-01 06:13:19 +0000