music subtypes.
* scm/documentation-lib.scm: complete revision.
Use GOOPS objects to store document tree explicitly. Cleanedup and
sped up doco generation a lot.
--- /dev/null
+#include "translator.hh"
+
+#include "translator-group.hh"
+#include "lily-guile.hh"
+
+LY_DEFINE(ly_get_context_property,
+ "ly-get-context-property", 2, 0, 0,
+ (SCM context, SCM name),
+ "retrieve the value of @var{name} from context @var{context}")
+{
+ Translator *t = unsmob_translator (context);
+ Translator_group* tr= dynamic_cast<Translator_group*> (t);
+ SCM_ASSERT_TYPE(tr, context, SCM_ARG1, __FUNCTION__, "Translator group");
+ SCM_ASSERT_TYPE(gh_symbol_p (name), name, SCM_ARG2, __FUNCTION__, "symbol");
+
+ return tr->internal_get_property (name);
+
+}
+
+LY_DEFINE(ly_set_context_property,
+ "ly-set-context-property", 3, 0, 0,
+ (SCM context, SCM name, SCM val),
+ "set value of property @var{name} in context @var{context} to @var{val}.
+")
+{
+ Translator *t = unsmob_translator (context);
+ Translator_group* tr= dynamic_cast<Translator_group*> (t);
+
+ SCM_ASSERT_TYPE(tr, context, SCM_ARG1, __FUNCTION__, "Context");
+ tr->internal_set_property (name, val);
+
+ return SCM_UNSPECIFIED;
+}
;;;;;; TODO: use flatten write iso. string-append; might be possible to fold
;;;;;; in symbol->string integrally.
-(define (backend-property->texi sym)
- (let* ((name (symbol->string sym))
- (type (object-property sym 'backend-type?))
- (typename (type-name type))
- (desc (object-property sym 'backend-doc)))
-
-
- (if (equal? desc #f)
- (error "Unknown property " sym)
-
- (cons (string-append "@code{" name "} "
- "(" typename ")"
- ": "
-
-; index gets too messy
-; "@vindex " name "\n"
- )
- desc))))
-
-(define (document-grob-property sym grob-description )
- "Document SYM, filling in default values."
- (let* ((handle (assoc sym grob-description))
- (defval (if (eq? handle #f)
- "(unset)"
- (scm->texi (cdr handle))))
- (propdoc (backend-property->texi sym)))
-
- (cons (car propdoc) (string-append (cdr propdoc)
- "\nDefault value: "
- defval)))
- )
-
-(define (document-interface where interface grob-description)
-
- (let* ((level (if (eq? where 'grob) 3 2))
- (name (car interface))
+(define (interface-doc-string interface grob-description)
+ (let* ((name (car interface))
(desc (cadr interface))
(props (sort (caddr interface) symbol<?))
(docfunc (lambda (pr)
- (document-grob-property
- pr grob-description )))
- (docs (map docfunc props)))
-
- (string-append
- (texi-section level
- (string-append (interface-name (symbol->string name)))
- (eq? where 'grob)) ;gur.
+ (document-property
+ pr 'backend grob-description )))
+ (propdocs (map docfunc props)))
+
desc
- (description-list->texi docs))))
+ (description-list->texi propdocs)))
;; First level Interface description
-(define (document-separate-interface interface)
+(define (interface-doc interface)
(let ((name (symbol->string (car interface))))
- (processing name)
- (string-append
- (node (interface-name name))
- (document-interface 'self interface '()))))
-
+ (make <texi-node>
+ #:name name
+ #:text (interface-doc-string (cdr interface) #f))))
;; First level grob description
-(define (document-grob iname description)
- (processing iname)
- (let* ((metah (assoc 'meta description))
-
- (meta (cdr metah))
- (name (cdr (assoc 'name meta)))
- (ifaces (map lookup-interface (cdr (assoc 'interfaces meta))))
- (ifacedoc (map (lambda (iface)
- (document-interface 'grob iface description))
- (reverse ifaces)))
- )
-
-
- (string-append
- (node (grob-name name))
- (texi-section 2 (grob-name name) #f)
- "\n"
- (let* ((grob name)
- (engravers (filter-list
- (lambda (x) (engraver-makes-grob? name x)) all-engravers-list))
- (engraver-names (map ly-translator-name engravers))
- )
-
- (string-append
- (symbol->string name) " grobs are created by: "
- (human-listify (map ref-ify
- (map engraver-name engraver-names)))))
-
- (apply string-append ifacedoc))))
-
+(define (grob-doc description)
+ (let*
+ (
+ (metah (assoc 'meta description))
+
+ (meta (cdr metah))
+ (name (cdr (assoc 'name meta)))
+ (ifaces (map lookup-interface (cdr (assoc 'interfaces meta))))
+ (ifacedoc (map (lambda (iface)
+ (interface-doc-string iface description))
+ (reverse ifaces)))
+ (engravers (filter-list
+ (lambda (x) (engraver-makes-grob? name x)) all-engravers-list))
+ (namestr (symbol->string name))
+ (engraver-names (map ly-translator-name engravers))
+ )
+ (make <texi-node>
+ #:name namestr
+ #:text
+ (string-append
+ namestr " grobs are created by: "
+ (human-listify (map ref-ify
+ (map engraver-name engraver-names)))
+ (apply string-append ifacedoc)
+ ))
+ ))
(define (engraver-makes-grob? name-symbol grav)
(memq name-symbol (assoc 'grobs-created (ly-translator-description grav)))
)
-(define (document-all-grobs name)
- (let* ((doc (apply string-append
- (map (lambda (x)
- (document-grob (symbol->string (car x)) (cdr x)))
- all-grob-descriptions)))
- (names (map symbol->string (map car all-grob-descriptions))))
-
- (string-append
- (texi-node-menu name (map (lambda (x) (cons (grob-name x) ""))
- names))
- doc)))
-
-;; ugh, this works standalone, but not anymore with lily
-(if (not (defined? 'standalone))
- (begin
-
- (load "standalone.scm")
-
- (define (number-pair? x)
- (and (pair? x) (number? (car x)) (number? (cdr x))))
- (define (ly-grob? x) #f)
- (define (ly-input-location? x) #f)
- (define (dir? x) #f)
- (define (moment? x) #f)
- ))
-
-(use-modules (ice-9 string-fun))
-
-(if standalone
- (begin
- (display "(define (list-interface-names) '")
- (write (ugh-standalone-list-interface-names))
- (display ")")
- (exit 0)))
-
+(define (all-grobs-doc)
+ (make <texi-node>
+ #:name "All Graphical objects"
+ #:desc "Description and defaults for all Grobs"
+ #:children
+ (map (lambda (x) (grob-doc (cdr x))) all-grob-descriptions)))
(define interface-description-alist
(hash-fold
(define (check-dangling-properties prop)
(if (not (object-property prop 'iface-marked))
- (error "\nDangling property: " prop))
+ (error "\nDangling property: " prop))
)
(map check-dangling-properties all-backend-properties)
entry
))
-;(write (map car interface-description-alist) (current-error-port))
-;(display (lookup-interface 'accidental-placement-interface))
-;(display (document-all-grobs "OO" ))
-
-(define (document-all-interfaces name)
- (string-append
- (texi-node-menu name (map (lambda (x)
- (cons (interface-name (symbol->string x)) ""))
- (map cadr interface-description-alist)))
- (apply string-append
- (map document-separate-interface
- (map cdr interface-description-alist)))))
+(define (all-interfaces-doc)
+ (make <texi-node>
+ #:name "Graphical Object Interfaces"
+ #:desc "Building blocks of graphical objects"
+ #:children
+ (map interface-doc interface-description-alist)
+ ))
-(define (document-all-backend-properties name)
+(define (all-backend-properties-doc)
(let*
(
(ps (sort (map symbol->string all-backend-properties) string<?))
(descs (map (lambda (prop)
- (backend-property->texi (string->symbol prop)))
+ (document-property (string->symbol prop) 'backend #f))
ps))
(texi (description-list->texi descs))
)
-
- texi
- )
- )
-
-;;;;;;;;;;;;;;;;
-
+ (make <texi-node>
+ #:name "backend properties"
+ #:desc "all the properties in use as grob properties"
+ #:text texi)
+ ))
+
+;(dump-node (grob-doc (cdadr all-grob-descriptions)) (current-output-port) 0 )
+(define (backend-doc-node)
+ (make <texi-node>
+ #:name "Backend"
+ #:desc "Reference for the layout engine"
+ #:children
+ (list
+ (all-grobs-doc)
+ (all-interfaces-doc)
+ (all-backend-properties-doc)
+ )
+ ))
;;; (c) 2000--2001 Han-Wen Nienhuys <hanwen@cs.uu.nl>
;;; Jan Nieuwenhuizen <janneke@gnu.org>
+(use-modules (oop goops))
+
+(define-class <texi-node> ()
+ (children #:init-value '() #:accessor node-children #:init-keyword #:children)
+ (text #:init-value "" #:accessor node-text #:init-keyword #:text)
+ (name #:init-value "" #:accessor node-name #:init-keyword #:name)
+ (description #:init-value "" #:accessor node-desc #:init-keyword #:desc)
+ )
+
+(define (menu-entry x)
+ (cons
+ (node-name x)
+ (node-desc x))
+ )
+
+(define (dump-node node port level)
+ (display
+ (string-append
+ "\n@html"
+ "\n<hr>"
+ "\n@end html\n@node "
+ (node-name node)
+ "\n\n"
+ (texi-section-command level) " "
+ (node-name node)
+ "\n\n"
+ (node-text node)
+ "\n\n"
+ (if (pair? (node-children node))
+ (texi-menu
+ (map (lambda (x) (menu-entry x) )
+ (node-children node)))
+ ""))
+ port)
+ (map (lambda (x) (dump-node x port (+ 1 level)))
+ (node-children node))
+ )
+
(define (processing name)
(display (string-append "\nProcessing " name " ... ") (current-error-port)))
(define (texify x)
x)
-;; (let*
-;; ((x1 (regexp-substitute/global #f "\([^@]\){" x 'pre "\1@{" 'post))
-;; ((x2 (regexp-substitute/global #f "\([^@]\){" x 'pre "\1@{" 'post))
-;; ((x3 (regexp-substitute/global #f "\([^@]\)@" x 'pre "\1@@" 'post))
-;; )
-;; x2))
-
-
(define (scm->texi x)
(string-append "@code{" (texify (scm->string x)) "}")
(call-with-output-string (lambda (port) (display val port)))
)))
-(define (node name)
- (string-append
- "\n@html"
- "\n<hr>"
- "\n@end html"
- "\n@node " name))
-(define texi-section-alist
- '(
+(define (texi-section-command level)
+ (cdr (assoc level '(
;; Hmm, texinfo doesn't have ``part''
(0 . "@top")
(1 . "@unnumbered")
(3 . "@unnumberedsubsec")
(4 . "@unnumberedsubsubsec")
(5 . "@unnumberedsubsubsec")
- ))
-
-(define (texi-section level name ref)
- "texi sectioning command (lower LEVEL means more significant).
-Add a ref if REF is set
-"
-
- (string-append
- "\n" (cdr (assoc level texi-section-alist)) " "
- (if ref
- (ref-ify name)
- name)
- "\n"))
-
+ ))))
(define (one-item->texi label-desc-pair)
"Document one (LABEL . DESC); return empty string if LABEL is empty string.
(define (description-list->texi items-alist)
- "Document ITEMS-ALIST in a table. entries contain (item-label . string-to-use)
+ "Document ITEMS-ALIST in a table. entries contain (item-label
+. string-to-use)
"
(string-append
"\n@table @samp\n"
"\n@end table\n"))
(define (texi-menu items-alist)
+ "Generate what is between @menu and @end menu."
(let
(
(maxwid (apply max (map (lambda (x) (string-length (car x)))
"\n@end ignore\n")))
-(define (texi-node-menu name items-alist)
- (string-append
- (node name)
- (texi-section 1 name #f)
- (texi-menu items-alist)))
-
-(define (texi-file-head name file-name top items-alist)
-
-
+(define (texi-file-head name file-name top)
(string-append
"\\input texinfo @c -*-texinfo-*-"
"\n@setfilename " file-name ".info"
;; prepend GNU for dir, must be unique
"\n* GNU " name ": (" file-name "). " name "."
"\n@end direntry"
- ;; ugh, prev and next should be settable, of course
- (node "Top") ",(lilypond)Index,(lilypond)Full Grob interface list," top
- "\n@top"
- (texi-section 1 name #f)
- (texi-menu items-alist)
- "\n@contents"
- ))
-
-(define (itexi-file-head name file-name top items-alist)
- (string-append
- "@c -*-texinfo-*-"
- (node name) ",,," top
- (texi-section 1 name #f)
- (texi-menu items-alist)
- "\n@contents"
))
name)
(define (ref-ify x)
+ "Add ref to X"
(string-append "@ref{" x "}"))
(define (human-listify l)
(define (writing-wip x)
(display (string-append "\nWriting " x " ... ") (current-error-port)))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; property stuff.
+
+(define (property->texi where sym)
+ "Document SYM for WHERE (which can be translation, backend, music)"
+ (let* (
+ (name (symbol->string sym))
+ (type?-name (string->symbol
+ (string-append (symbol->string where) "-type?")))
+ (doc-name (string->symbol
+ (string-append (symbol->string where) "-doc")))
+ (type (object-property sym type?-name))
+ (typename (type-name type))
+ (desc (object-property sym doc-name)))
+
+ (if (eq? desc #f)
+ (error "No description for property ~S" sym)
+ )
+ (cons
+ (string-append "@code{" name "} "
+ "(" typename ")")
+ desc)
+
+ ))
+
+(define (document-property-value sym alist)
+ "Extract value for SYM from ALIST, return as texi string"
+ (let* ((handle (assoc sym alist)))
+ (if (eq? handle #f)
+ "(unset)"
+ (scm->texi (cdr handle)))))
+
+
+(define (backend-property->texi sym)
+ (property->texi 'backend sym))
+
+(define (document-property sym where alist)
+ "Document SYM. If GROB-DESCRIPTION is not #f, it's an alist
+containing default values."
+ (let*
+ ((without (property->texi where sym))
+ (rv
+
+ (cons (car without)
+ (if (eq? alist #f)
+ (cdr without)
+ (string-append
+ (cdr without)
+ "\nDefault value: "
+ (document-property-value sym alist)))))
+
+ )
+; (display rv)
+ rv ))
-;; alist of translater descriptions
-(define (document-translator-property sym)
- (cons
- (string-append
- "@code{" (symbol->string sym) "} "
- "(" (type-name (object-property sym 'translation-type?)) "):")
- (object-property sym 'translation-doc)))
;; First level Engraver description and
;; second level Context description
-(define (document-engraver where engraver)
-
+(define (engraver-doc-string engraver)
(let* (
- (level (if (eq? where 'context) 3 2))
(propsr (cdr (assoc 'properties-read (ly-translator-description engraver))))
- (propsw (cdr (assoc 'properties-written (ly-translator-description engraver))))
+ (propsw (cdr (assoc 'properties-written (ly-translator-description engraver))))
+ (accepted (cdr (assoc 'events-accepted (ly-translator-description engraver))))
(name (ly-translator-name engraver))
(name-sym (string->symbol name))
(desc (cdr (assoc 'description (ly-translator-description engraver))))
)
(string-append
- (texi-section level (engraver-name name) (eq? where 'context))
desc
"\n\n"
- (if (null? propsr)
- ""
+ (if (pair? accepted)
(string-append
- (texi-section (+ level 1) "Properties (read)" #f)
+ "Music types accepted:\n\n"
+ (human-listify
+ (map (lambda (x)
+ (string-append
+ "@ref{"
+ (symbol->string x)
+ "}")) accepted)
+ ))
+ "")
+ "\n\n"
+ (if (pair? propsr)
+ (string-append
+ "Properties (read)"
(description-list->texi
- (map (lambda (x) (document-translator-property x)) propsr))))
+ (map (lambda (x) (document-property x 'translation #f)) propsr)))
+ "")
+
(if (null? propsw)
""
(string-append
- (texi-section (+ level 1) "Properties (write)" #f)
+ "Properties (write)"
(description-list->texi
- (map (lambda (x) (document-translator-property x)) propsw))))
+ (map (lambda (x) (document-property x 'translation #f)) propsw))))
(if (null? grobs)
""
(string-append
(human-listify (map ref-ify (map context-name contexts))))))))
+
+
;; First level Engraver description
-(define (document-separate-engraver top grav)
- (let ((name (ly-translator-name grav)))
- (processing name)
- (string-append
- (node (engraver-name name))
- (document-engraver 'self grav))))
+(define (engraver-doc grav)
+ (make <texi-node>
+ #:name (ly-translator-name grav)
+ #:text (engraver-doc-string grav)
+ ))
;; Second level, part of Context description
-(define (find-engraver-by-name name list)
- (if (null? list)
- #f
- (if (equal? name (ly-translator-name (car list)))
- (car list)
- (find-engraver-by-name name (cdr list)))))
+
+(define name->engraver-table (make-vector 61 '()))
+(map
+ (lambda (x)
+ (hash-set! name->engraver-table (ly-translator-name x) x))
+ (ly-get-all-translators))
+
+(define (find-engraver-by-name name)
+ (hash-ref name->engraver-table name #f))
(define (document-engraver-by-name name)
(let*
(
- (eg (find-engraver-by-name name all-engravers-list))
+ (eg (find-engraver-by-name name ))
)
(if (eq? eg #f)
(string-append "Engraver " name ", not documented.\n")
- (document-engraver 'context eg)
+ (engraver-doc-string eg)
)
))
))
-
-(define (context-doc-string context-desc)
+(define (context-doc context-desc)
(let*
(
(name (cdr (assoc 'type-name context-desc)))
(grobs (context-grobs context-desc))
(grob-refs (map (lambda (x) (ref-ify x)) grobs))
)
-
- (string-append
- desc
- "\n\nThis context creates the following grobs: \n\n"
- (human-listify (uniq-list (sort grob-refs string<? )))
- "."
- (if (pair? props)
- (string-append
- "\n\nThis context sets the following properties:\n"
- "@itemize @bullet\n"
- (apply string-append (map document-property-operation props))
- "@end itemize\n"
- )
- ""
- )
-
- (if (null? accepts)
- "\n\nThis context is a `bottom' context; it can not contain other contexts."
- (string-append
- "\n\nContext "
- name " can contain \n"
- (human-listify (map ref-ify (map context-name accepts)))))
-
- "\n\nThis context is built from the following engravers: "
- (if no-copies
- (human-listify (map ref-ify (map engraver-name consists)))
- (apply string-append
- (map document-engraver-by-name consists))))))
+ (make <texi-node>
+ #:name name
+ #:text
+ (string-append
+ desc
+ "\n\nThis context creates the following grobs: \n\n"
+ (human-listify (uniq-list (sort grob-refs string<? )))
+ "."
+ (if (pair? props)
+ (string-append
+ "\n\nThis context sets the following properties:\n"
+ "@itemize @bullet\n"
+ (apply string-append (map document-property-operation props))
+ "@end itemize\n"
+ )
+ ""
+ )
+
+ (if (null? accepts)
+ "\n\nThis context is a `bottom' context; it can not contain other contexts."
+ (string-append
+ "\n\nContext "
+ name " can contain \n"
+ (human-listify (map ref-ify (map context-name accepts)))))
+
+ "\n\nThis context is built from the following engravers: "
+ (apply string-append
+ (map document-engraver-by-name consists)))
+ )))
(define (engraver-grobs grav)
(let* (
(eg (if (string? grav)
- (find-engraver-by-name grav all-engravers-list)
+ (find-engraver-by-name grav)
grav))
)
grobs
))
-
-;; First level Context description
-(define (document-context top context-desc)
- (let ((name (cdr (assoc 'type-name context-desc)))
- (doc (context-doc-string context-desc)))
- (processing name)
- (string-append
- (node (context-name name))
- (texi-section 2 (context-name name) #f)
- doc)))
-
(define (symbol<? l r)
(string<? (symbol->string l) (symbol->string r)))
-(define (document-paper name)
- (let* ((paper-alist
+(define (all-contexts-doc)
+ (let* (
+ (paper-alist
(sort (My_lily_parser::paper_description)
(lambda (x y) (symbol<? (car x) (car y)))))
(names (sort (map symbol->string (map car paper-alist)) string<?))
(contexts (map cdr paper-alist))
- (doc (apply string-append
- (map (lambda (x) (document-context name x)) contexts))))
-
- (string-append
- (texi-node-menu name (map (lambda (x) (cons (context-name x) ""))
- names))
- doc)))
+ )
+
+ (make <texi-node>
+ #:name "Contexts"
+ #:desc "Complete descriptions of all contexts"
+ #:children
+ (map context-doc contexts)
+ )
+ ))
+
+(define (all-engravers-doc)
+ (make <texi-node>
+ #:name "Engravers"
+ #:desc "All separate engravers"
+ #:children
+ (map engraver-doc (ly-get-all-translators))))
(define all-engravers-list (ly-get-all-translators))
-(define (document-all-engravers name)
- (let* ((gravs all-engravers-list)
- (names (map ly-translator-name gravs))
- (doc (apply string-append
- (map (lambda (x) (document-separate-engraver name x))
- gravs))))
- (string-append
- (texi-node-menu name (map (lambda (x) (cons (engraver-name x) ""))
- names))
- doc)))
-
-(define (document-all-engraver-properties name)
- (let* ((ps (sort (map symbol->string all-translation-properties) string<?))
- (sortedsyms (map string->symbol ps))
- (propdescs (map document-translator-property sortedsyms))
- (texi (description-list->texi propdescs)))
-
- (string-append
- (node name)
- (texi-section 1 name #f)
- texi)))
+(define (all-translation-properties-doc)
+
+ (let*
+ (
+ (ps (sort (map symbol->string all-translation-properties) string<?))
+ (sortedsyms (map string->symbol ps))
+ (propdescs
+ (map
+ (lambda (x) (document-property x 'translation #f))
+ sortedsyms))
+ (texi (description-list->texi propdescs))
+ )
+
+ (make <texi-node>
+ #:name "Translation properties"
+ #:desc "All translation properties"
+ #:text texi)
+ ))
+
+
+;(dump-node (all-contexts-doc) (current-output-port) 0 )
+
+(define (translation-doc-node)
+ (make <texi-node>
+ #:name "Translation"
+ #:desc "From music to layout"
+ #:children
+ (list
+ (all-contexts-doc)
+ (all-engravers-doc)
+ (all-translation-properties-doc)
+ )
+ ))
'() (ly-get-all-function-documentation))
)
-(define (document-all-scheme-functions)
+(define (all-scheme-functions-doc)
(let*
(
(sfdocs (sort fdocs string<?))
)
- (apply string-append sfdocs)
-
+
+ (make <texi-node>
+ #:name "Scheme functions"
+ #:desc "Primitive functions exported by LilyPond"
+ #:text
+ (apply string-append sfdocs)
+ )
))
+; (dump-node (all-scheme-functions-doc) (current-output-port) 0 )
"music-documentation-lib.scm"
"backend-documentation-lib.scm"
))
-(map load-from-path load-files)
+(map ly-load load-files)
;;(define no-copies #t) ; from 490 to 410K, but doesn't look nice yet
;; are described...
(define no-copies #f)
-(let* ((doc (string-append
- (document-music "Music properties")
- (document-paper "Contexts")
- (document-all-engravers "Engravers")
- (document-all-engraver-properties "Context properties")
- (document-all-grobs "Grob overview")
- (document-all-interfaces "Interfaces")
-
- (node "Backend properties")
- (texi-section 1 "Backend properties" #f)
-
- (document-all-backend-properties "Backend properties")
-
- (node "Function documentation")
- (texi-section 1 "Function documentation" #f)
-
- (document-all-scheme-functions)
-
- )
- )
- (name "lilypond-internals")
- (outname (string-append name ".texi"))
- (out (open-output-file outname)))
-
- (writing-wip outname)
- (display
- (string-append
- (texi-file-head
-
- ;; we can't use (dir) and top if we're included by lilypond.tely
- "LilyPond internals" name "(lilypond.info)"
- '(
- ("Music properties" . "properties for Music representation")
- ("Contexts" . "Hierarchy and grouping of Engravers")
- ("Engravers" . "Engravers create Grobs")
- ("Context properties" . "context properties")
- ("Grob overview" . "Detailed description of all Grobs")
- ("Interfaces" . "Grob Interfaces")
- ("Backend properties" . "Grob properties")
- ("Function documentation" . "All embedded functions")
- ("Index" . "index")
- ))
-
-
-
- doc
-
- "@node Index
+(define file-name "lilypond-internals")
+(define outname (string-append file-name ".texi"))
+(define out-port (open-output-file outname))
+
+(writing-wip outname)
+
+(display
+ (string-append
+ "@c -*-texinfo-*-"
+ (texi-file-head "LilyPond internals" outname "(lilypond.info)")) out-port)
+
+(define top-node
+ (make <texi-node>
+ #:name "Top"
+ #:children
+ (list
+ (music-doc-node)
+ (translation-doc-node)
+ (backend-doc-node)
+ (all-scheme-functions-doc)
+ (make <texi-node>
+ #:name "Index"
+ #:text "
@unnumbered Concept index
@printindex cp
@printindex fn
-"
+\n@bye"
-
- "\n@bye")
- out))
+
+ )
+ )))
+
+(dump-node top-node out-port 0)
(newline (current-error-port))
;;; General settings
;; debugging evaluator is slower.
-;(debug-enable 'debug)
+(debug-enable 'debug)
;(debug-enable 'backtrace)
-;(read-enable 'positions)
+(read-enable 'positions)
(define-public (line-column-location line col file)
(string-append str (make-string (max (- wid (string-length str)) 0) #\ ))
)
-(define (ly-load x)
+(define-public (ly-load x)
(let* ((fn (%search-load-path x)))
(if (ly-verbose)
(format (current-error-port) "[~A]" fn))
-(define (music-property->texi sym)
- (let* ((name (symbol->string sym))
- (type (object-property sym 'music-type?))
- (typename (type-name type))
- (desc (object-property sym 'music-doc)))
-
- (cons (string-append "@code{" name "} "
- "(" typename ")"
- ": "
- )
- desc)))
-
-(define (document-music name)
+
+(define (music-props-doc)
+ (make <texi-node>
+ #:name "Music properties"
+ #:desc "All music properties, including descriptions"
+ #:text
(let* (
- (ps (sort (map symbol->string all-music-properties) string<?))
- (descs (map (lambda (prop)
- (music-property->texi (string->symbol prop)))
- ps))
- (texi (description-list->texi descs))
- )
-
+ (ps (sort (map symbol->string all-music-properties) string<?))
+ (descs (map (lambda (prop)
+ (property->texi 'music (string->symbol prop)))
+ ps))
+ (texi (description-list->texi descs))
+ )
+ texi)
+ ))
+
+(define music-types->names (make-vector 61 '()))
+(map (lambda (entry)
+ (let*
+ (
+ (types (assoc 'types (cdr entry) ))
+ )
+ (map (lambda (type)
+ (hashq-set! music-types->names type
+ (cons (car entry)
+ (hashq-ref music-types->names type '())))
+
+ ) types)
+
+ ))
+ music-descriptions)
+
+
+(define (hash-table->alist t)
+ "Convert table t to list"
+ (apply append
+ (vector->list t)
+
+ ))
+
+(define (strip-description x)
+ (cons (symbol->string (car x))
+ ""))
+
+(define (music-type-doc entry)
+ (make <texi-node>
+ #:name (symbol->string (car entry))
+ #:text
(string-append
- (node name)
- (texi-section 1 name #f)
- texi)
+ "\nMusic event type @code{"
+ (symbol->string (car entry))
+ "} is in Music objects of type "
+ (human-listify
+ (sort
+ (map (lambda (x) (ref-ify (symbol->string x)))
+ (cdr entry)) string<?))
+ "\n\n"
+ )))
+
+(define (music-types-doc)
+ (make <texi-node>
+ #:name "Music classes"
+ #:children
+ (map music-type-doc
+ (sort
+ (hash-table->alist music-types->names) alist<?))
+ ))
+
+(define (music-object-doc obj)
+ (make <texi-node>
+ #:name (symbol->string (car obj))
+ #:text (string-append
+ (object-property (car obj) 'music-description)
+ "\n\nProperties: \n"
+ (description-list->texi
+ (map
+ (lambda (x) (document-property x 'music (cdr obj)))
+ (map car (cdr obj))))
+ ))
+)
+
+(define (music-expressions-doc)
+ (make <texi-node>
+ #:name "Music expressions"
+ #:desc "Objects that represent music."
+ #:children
+ (map music-object-doc music-descriptions)
))
+
+(define (music-doc-node)
+ (make <texi-node>
+ #:name "Music definitions"
+ #:desc "Definition of the Input data structures"
+ #:children
+ (list
+ (music-expressions-doc)
+ (music-types-doc)
+ (music-props-doc))
+ ))
+
+
+
`(
(AbortEvent
. (
+ (description . "Abort currently running spanners.")
(internal-class-name . "Span_req")
(span-type . "abort")
(types . (general-music event abort-event))
))
(ArpeggioEvent
. (
+ (description . "Make an arpeggio on this note.")
(internal-class-name . "Request")
(types . (general-music arpeggio-event event))
))
(ArticulationEvent
. (
+ (description . "")
+
(internal-class-name . "Articulation_req")
(types . (general-music event articulation-event script-event))
))
(BassFigureEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(compress-procedure . ,music-duration-compress)
(length . ,music-duration-length)
))
(BeamEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music event beam-event span-event))
))
(BreakEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music break-event event))
))
(BreathingSignEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music event breathing-event))
))
(BusyPlayingEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music event busy-playing-event))
))
(ExtenderEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music extender-event event))
))
(GlissandoEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music glissando-event event))
))
(GraceMusic
. (
+ (description . "")
+
(internal-class-name . "Grace_music")
(iterator-ctor . ,Grace_iterator::constructor)
(types . (grace-music music-wrapper-music general-music))
))
(HyphenEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music hyphen-event event))
))
(KeyChangeEvent
. (
+ (description . "")
+
(internal-class-name . "Key_change_req")
(types . (general-music key-change-event event))
))
(LyricEvent
. (
+ (description . "")
+
(internal-class-name . "Lyric_req")
(types . (general-music rhythmic-event event))
))
(LigatureEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(span-type . ligature)
(types . (general-music event span-event ligature-event))
))
(MarkEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music mark-event event))
))
(MelismaEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music span-event melisma-playing-event event))
))
(MelismaPlayingEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music event))
))
(Music
. (
+ (description . "")
+
(internal-class-name . "Music")
(types . (general-music))
))
(NoteEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(length . ,music-duration-length)
(compress-procedure . ,music-duration-compress)
))
(PorrectusEvent
. (
+ (description . "")
+
(internal-class-name . "Porrectus_req")
(types . (general-music event))
))
(RepeatedMusic
. (
+ (description . "")
+
(internal-class-name . "Repeated_music")
(type . repeated-music)
(types . (general-music repeat-music))
))
(Request
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music event))
))
(RestEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(length . ,music-duration-length)
(compress-procedure . ,music-duration-compress)
))
(RhythmicEvent
. (
+ (description . "")
+
(internal-class-name . "Rhythmic_req")
(length . ,music-duration-length)
(compress-procedure . ,music-duration-compress)
))
(SequentialMusic
. (
+ (description . "")
+
(internal-class-name . "Sequential_music")
(iterator-ctor . ,Sequential_music_iterator::constructor)
(types . (general-music sequential-music))
))
(SimultaneousMusic
. (
+ (description . "")
+
(internal-class-name . "Simultaneous_music")
(iterator-ctor . ,Simultaneous_music_iterator::constructor)
))
(PropertySet
. (
+ (description . "")
+
(internal-class-name . "Music")
(types . (layout-instruction general-music))
(iterator-ctor . ,Property_iterator::constructor)
)
(PropertyUnset
. (
+ (description . "")
+
(internal-class-name . "Music")
(types . (layout-instruction general-music))
(iterator-ctor . ,Property_unset_iterator::constructor)
)
(VoiceSeparator
. (
+ (description . "")
+
(internal-class-name . "Music")
(types . (separator general-music))
))
(BarCheck
. (
+ (description . "")
+
(internal-class-name . "Music")
(types . (general-music bar-check))
(iterator-ctor . ,Bar_check_iterator::constructor)
))
(OverrideProperty
. (
+ (description . "")
+
(internal-class-name . "Music")
(types . (general-music layout-instruction))
(iterator-ctor . , Push_property_iterator::constructor)
))
(RevertProperty
. (
+ (description . "")
+
(internal-class-name . "Music")
(types . (general-music layout-instruction))
(iterator-ctor . , Pop_property_iterator::constructor)
(OutputPropertySetMusic
. (
+ (description . "")
+
(internal-class-name . "Music")
(iterator-ctor . ,Output_property_music_iterator::constructor)
(types . (general-music layout-instruction))
))
(ContextSpeccedMusic
. (
+ (description . "")
+
(internal-class-name . "Context_specced_music")
(types . (context-specification general-music music-wrapper-music))
))
(AutoChangeMusic
. (
+ (description . "")
+
(internal-class-name . "Music_wrapper")
(iterator-ctor . ,Auto_change_iterator::constructor)
(types . (general-music music-wrapper-music auto-change-instruction))
))
(TranslatorChange
. (
+ (description . "")
+
(internal-class-name . "Music")
(iterator-ctor . , Change_iterator::constructor)
(types . (general-music translator-change-instruction))
))
(TimeScaledMusic
. (
+ (description . "")
+
(internal-class-name . "Time_scaled_music")
(iterator-ctor . ,Time_scaled_music_iterator::constructor)
(types . (time-scaled-music music-wrapper-music general-music))
))
(TransposedMusic
. (
+ (description . "")
+
(internal-class-name . "Transposed_music")
(types . (music-wrapper-music general-music transposed-music))
))
(UntransposableMusic
. (
+ (description . "")
+
(internal-class-name . "Untransposable_music")
(types . (music-wrapper-music general-music untransposable-music))
))
(UnrelativableMusic
. (
+ (description . "")
+
(internal-class-name . "Un_relativable_music")
(types . (music-wrapper-music general-music unrelativable-music))
))
(RelativeOctaveMusic
. (
+ (description . "")
+
(internal-class-name . "Relative_octave_music")
(types . (music-wrapper-music general-music relative-octave-music))
))
(LyricCombineMusic
. (
+ (description . "")
+
(internal-class-name . "Lyric_combine_music")
(types . (general-music lyric-combine-music))
(iterator-ctor . ,Lyric_combine_music_iterator::constructor)
(PartCombineMusic
. (
+ (description . "")
+
(internal-class-name . "Part_combine_music")
(types . (general-music part-combine-music))
(iterator-ctor . ,Part_combine_music_iterator::constructor)
))
(RequestChord
. (
+ (description . "")
+
(internal-class-name . "Request_chord")
(iterator-ctor . ,Request_chord_iterator::constructor)
(types . (general-music simultaneous-music))
(ScriptEvent
. (
+ (description . "")
+
(internal-class-name . "Script_req")
(types . (general-music event))
))
(SkipEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(length . ,music-duration-length)
(compress-procedure . ,music-duration-compress)
))
(SpanEvent
. (
+ (description . "")
+
(internal-class-name . "Span_req")
(types . (general-music event))
))
(DecrescendoEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music dynamic-event decrescendo-event event))
))
(CrescendoEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music dynamic-event crescendo-event event))
))
(StringNumberEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
- (types . (general-music event))
+ (types . (general-music string-number-event event))
))
(TempoEvent
. (
+ (description . "")
+
(internal-class-name . "Request")
(types . (general-music tempo-event event))
))
(TextScriptEvent
. (
+ (description . "")
(internal-class-name . "Text_script_req")
(types . (general-music script-event text-script-event event))
))
(TieEvent
. (
+ (description . "A tie. Entered as ~.")
(internal-class-name . "Request")
(types . (general-music tie-event event))
))
))
-
+(set! music-descriptions
+ (sort music-descriptions alist<?))
(define music-name-to-property-table (make-vector 59 '()))
-(map (lambda (x)
- (hashq-set! music-name-to-property-table (car x)
- (assoc-set! (cdr x) 'name (car x)))
- )
- music-descriptions)
+
+;; init hash table,
+;; transport description to an object property.
+(set!
+ music-descriptions
+ (map (lambda (x)
+ (set-object-property! (car x)
+ 'music-description
+ (cdr (assq 'description (cdr x))))
+ (let
+ ((l (cdr x)))
+ (set! l (assoc-set! l 'name (car x)))
+ (set! l (assq-remove! l 'description))
+ (hashq-set! music-name-to-property-table (car x) l)
+ (cons (car x) l)
+ ))
+ music-descriptions))
projects / lilypond.git / commitdiff