]> git.donarmstrong.com Git - lilypond.git/blob - scm/document-translation.scm
*** empty log message ***
[lilypond.git] / scm / document-translation.scm
1 ;;;; document-translation.scm -- Functions for engraver documentation
2 ;;;;
3 ;;;; source file of the GNU LilyPond music typesetter
4 ;;;; 
5 ;;;; (c) 2000--2005 Han-Wen Nienhuys <hanwen@cs.uu.nl>
6 ;;;;                 Jan Nieuwenhuizen <janneke@gnu.org>
7
8 (define (engraver-makes-grob? name-symbol grav)
9   (memq name-symbol (assoc 'grobs-created (ly:translator-description grav))))
10
11 (define (engraver-accepts-music-type? name-symbol grav)
12   (memq name-symbol (assoc 'events-accepted (ly:translator-description grav))))
13
14 (define (engraver-accepts-music-types? types grav)
15   (if (null? types)
16       #f
17       (or
18        (engraver-accepts-music-type? (car types) grav)
19        (engraver-accepts-music-types? (cdr types) grav))))
20
21 (define (engraver-doc-string engraver in-which-contexts)
22   (let* ((propsr (cdr (assoc 'properties-read (ly:translator-description engraver))))
23          (propsw (cdr (assoc 'properties-written (ly:translator-description engraver))))
24          (accepted  (cdr (assoc 'events-accepted (ly:translator-description engraver)))) 
25          (name-sym  (ly:translator-name engraver))
26          (name-str (symbol->string name-sym))
27          (desc (cdr (assoc 'description (ly:translator-description engraver))))
28          (grobs (engraver-grobs engraver)))
29
30     (string-append
31      desc
32      "\n\n"
33      (if (pair? accepted)
34          (string-append
35           "Music types accepted:\n\n"
36           (human-listify
37            (map (lambda (x)
38                   (string-append
39                    "@ref{"
40                    (symbol->string x)
41                    "}")) accepted)))
42          "")
43      "\n\n"
44      (if (pair? propsr)
45          (string-append
46           "Properties (read)"
47           (description-list->texi
48            (map (lambda (x) (property->texi 'translation  x '())) propsr)))
49          "")
50      
51      (if (null? propsw)
52          ""
53          (string-append
54           "Properties (write)" 
55           (description-list->texi
56            (map (lambda (x) (property->texi 'translation  x '())) propsw))))
57      (if  (null? grobs)
58           ""
59           (string-append
60            "This engraver creates the following layout objects: \n "
61            (human-listify (map ref-ify (uniq-list (sort grobs string<? ))))
62            "."))
63
64      "\n\n"
65
66      (if in-which-contexts
67          (let* ((layout-alist (ly:output-description $defaultlayout))
68                 (context-description-alist (map cdr layout-alist))
69                 (contexts
70                  (apply append
71                         (map
72                          (lambda (x)
73                            (let* ((context (cdr (assoc 'context-name x)))
74                                   (group (assq-ref x 'group-type))
75                                   (consists (append
76                                              (if group
77                                                  (list group)
78                                                  '())
79                                              (cdr (assoc 'consists x)))))
80                              (if (member name-sym consists)
81                                  (list context)
82                                  '())))
83                          context-description-alist))))
84            (string-append
85             "@code{" name-str "} is part of contexts: "
86             (human-listify (map ref-ify
87                                 (sort
88                                  (map symbol->string contexts) string<?)))))
89          ""))))
90
91 ;; First level Engraver description
92 (define (engraver-doc grav)
93   (make <texi-node>
94     #:name (symbol->string (ly:translator-name grav))
95     #:text (engraver-doc-string grav #t)))
96
97 ;; Second level, part of Context description
98 (define name->engraver-table (make-vector 61 '()))
99 (map
100  (lambda (x)
101    (hash-set! name->engraver-table (ly:translator-name x) x))
102  (ly:get-all-translators))
103
104 (define (find-engraver-by-name name)
105   "NAME is a symbol." 
106   (hash-ref name->engraver-table name #f))
107
108 (define (document-engraver-by-name name)
109   "NAME is a symbol."
110   
111   (let* ((eg (find-engraver-by-name name)))
112
113     (cons (string-append "@code{" (ref-ify (symbol->string name)) "}")
114           (engraver-doc-string eg #f))))
115
116 (define (document-property-operation op)
117   (let ((tag (car op))
118         (context-sym (cadr op))
119         (args (cddr op))
120         )
121
122     (cond
123      ((equal?  tag 'push)
124       (let*
125           ((value (car args))
126            (path (cdr args)))
127
128       (string-append
129        "@item Set "
130        (format "grob-property @code{~a} " (string-join path " "))
131        (format " in @ref{~a} " context-sym)
132        (if (not (null? (cddr body)))
133            (format " to @code{~a}" (scm->texi value))
134            "")
135        
136        "\n")))
137      ((equal? (object-property context-sym 'is-grob?) #t) "")
138      ((equal? tag 'assign)
139       (format "@item Set translator property @code{~a} to @code{~a}"
140               context-sym
141               (scm->texi (car args))))
142      )))
143      
144
145 (define (context-doc context-desc)
146   (let* ((name-sym (cdr (assoc 'context-name context-desc)))
147          (name (symbol->string name-sym))
148          (aliases (map symbol->string (cdr (assoc 'aliases context-desc))))
149          (desc-handle (assoc 'description context-desc))
150          (desc (if (and  (pair? desc-handle) (string? (cdr desc-handle)))
151                    (cdr desc-handle) "(not documented)"))
152          
153          (accepts (cdr (assoc 'accepts context-desc)))
154          (consists (cdr (assoc 'consists context-desc)))
155          (props (cdr (assoc 'property-ops context-desc)))
156          (grobs  (context-grobs context-desc))
157          (grob-refs (map (lambda (x) (ref-ify x)) grobs)))
158
159     (make <texi-node>
160       #:name name
161       #:text
162       (string-append 
163        desc
164        (if (pair? aliases)
165            (string-append "\n\n This context is also known as: \n\n"
166                           (human-listify aliases))
167            "")
168        "\n\nThis context creates the following layout objects: \n\n"
169        (human-listify (uniq-list (sort grob-refs string<? )))
170        "."
171        (if (pair? props)
172            (string-append
173             "\n\nThis context sets the following properties:\n"
174             "@itemize @bullet\n"
175             (apply string-append (map document-property-operation props))
176             "@end itemize\n")
177            "")
178        
179        (if (null? accepts)
180            "\n\nThis context is a `bottom' context; it can not contain other contexts."
181            (string-append
182             "\n\nContext "
183             name " can contain \n"
184             (human-listify (map ref-ify (map symbol->string accepts)))))
185        
186        "\n\nThis context is built from the following engravers: "
187        (description-list->texi
188         (map document-engraver-by-name consists))))))
189
190 (define (engraver-grobs grav)
191   (let* ((eg (if (symbol? grav)
192                  (find-engraver-by-name grav)
193                  grav)))
194     (if (eq? eg #f)
195         '()
196         (map symbol->string (cdr (assoc 'grobs-created (ly:translator-description eg)))))))
197
198 (define (context-grobs context-desc)
199   (let* ((group (assq-ref context-desc 'group-type))
200          (consists (append
201                     (if group
202                         (list group)
203                         '())
204                     (cdr (assoc 'consists context-desc))))
205          (grobs  (apply append
206                         (map engraver-grobs consists))))
207     grobs))
208
209 (define (all-contexts-doc)
210   (let* ((layout-alist
211           (sort (ly:output-description $defaultlayout)
212                 (lambda (x y) (symbol<? (car x) (car y)))))
213          (names (sort (map symbol->string (map car layout-alist)) string<?))
214          (contexts (map cdr layout-alist)))
215
216     (make <texi-node>
217       #:name "Contexts"
218       #:desc "Complete descriptions of all contexts"
219       #:children
220       (map context-doc contexts))))
221
222 (define all-engravers-list  (ly:get-all-translators))
223 (set! all-engravers-list
224       (sort all-engravers-list
225             (lambda (a b) (string<? (symbol->string (ly:translator-name a))
226                                     (symbol->string (ly:translator-name b))))))
227
228 (define (all-engravers-doc)
229   (make <texi-node>
230     #:name "Engravers"
231     #:desc "All separate engravers"
232     #:text "See @usermanref{Modifying context plug-ins}."
233     #:children
234     (map engraver-doc all-engravers-list)))
235
236 (define (translation-properties-doc-string lst)
237   (let* ((ps (sort (map symbol->string lst) string<?))
238          (sortedsyms (map string->symbol ps))
239          (propdescs
240           (map
241            (lambda (x) (property->texi 'translation  x '()))
242            sortedsyms))
243          (texi (description-list->texi propdescs)))
244     texi))
245
246 (define (translation-doc-node)
247   (make <texi-node>
248     #:name "Translation"
249     #:desc "From music to layout"
250     #:children
251     (list
252      (all-contexts-doc)
253      (all-engravers-doc)
254      (make <texi-node>
255        #:name "Tunable context properties"
256        #:desc "All tunable context properties"
257        #:text (translation-properties-doc-string
258                all-user-translation-properties))
259
260      (make <texi-node>
261        #:name "Internal context properties"
262        #:desc "All internal context properties"
263        #:text (translation-properties-doc-string
264                all-internal-translation-properties)))))