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--2004 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   (let* ((eg (find-engraver-by-name name )))
 111
 112     (cons (string-append "@code{" (ref-ify (symbol->string name)) "}")
 113           (engraver-doc-string eg #f))))
 114
 115 (define (document-property-operation op)
 116   (let ((tag (car op))
 117         (body (cdr op))
 118         (sym (cadr op)))
 119
 120     (cond
 121      ((equal?  tag 'push)
 122       (string-append
 123        "@item "
 124        (if (null? (cddr body))
 125            "Revert "
 126            "Set ")
 127        "grob-property @code{"
 128        (symbol->string (cadr body))
 129        "} in @ref{" (symbol->string sym)
 130        "}"
 131        (if (not (null? (cddr body)))
 132            (string-append " to @code{" (scm->texi (cadr (cdr body))) "}" ))
 133        "\n"))
 134      ((equal? (object-property sym 'is-grob?) #t) "")
 135      ((equal? (car op) 'assign)
 136       (string-append
 137        "@item Set translator property @code{"
 138        (symbol->string (car body))
 139        "} to @code{"
 140        (scm->texi (cadr body))
 141        "}\n")))))
 142
 143 (define (context-doc context-desc)
 144   (let* ((name-sym (cdr (assoc 'context-name context-desc)))
 145          (name (symbol->string name-sym))
 146          (aliases (map symbol->string (cdr (assoc 'aliases context-desc))))
 147          (desc-handle (assoc 'description context-desc))
 148          (desc (if (and  (pair? desc-handle) (string? (cdr desc-handle)))
 149                    (cdr desc-handle) "(not documented)"))
 150
 151          (accepts (cdr (assoc 'accepts context-desc)))
 152          (group (assq-ref context-desc 'group-type))
 153
 154          (consists (append
 155                     (if group (list group)
 156                         '())
 157                     (cdr (assoc 'consists context-desc))))
 158          (props (cdr (assoc 'property-ops context-desc)))
 159          (grobs  (context-grobs context-desc))
 160          (grob-refs (map (lambda (x) (ref-ify x)) grobs)))
 161
 162     (make <texi-node>
 163       #:name name
 164       #:text
 165       (string-append
 166        desc
 167        (if (pair? aliases)
 168            (string-append "\n\n This context is also known as: \n\n"
 169                           (human-listify aliases))
 170            "")
 171        "\n\nThis context creates the following layout objects: \n\n"
 172        (human-listify (uniq-list (sort grob-refs string<? )))
 173        "."
 174        (if (pair? props)
 175            (string-append
 176             "\n\nThis context sets the following properties:\n"
 177             "@itemize @bullet\n"
 178             (apply string-append (map document-property-operation props))
 179             "@end itemize\n")
 180            "")
 181
 182        (if (null? accepts)
 183            "\n\nThis context is a `bottom' context; it can not contain other contexts."
 184            (string-append
 185             "\n\nContext "
 186             name " can contain \n"
 187             (human-listify (map ref-ify (map symbol->string accepts)))))
 188
 189        "\n\nThis context is built from the following engravers: "
 190        (description-list->texi
 191         (map document-engraver-by-name consists))))))
 192
 193 (define (engraver-grobs grav)
 194   (let* ((eg (if (symbol? grav)
 195                  (find-engraver-by-name grav)
 196                  grav)))
 197     (if (eq? eg #f)
 198         '()
 199         (map symbol->string (cdr (assoc 'grobs-created (ly:translator-description eg)))))))
 200
 201 (define (context-grobs context-desc)
 202   (let* ((group (assq-ref context-desc 'group-type))
 203          (consists (append
 204                     (if group
 205                         (list group)
 206                         '())
 207                     (cdr (assoc 'consists context-desc))))
 208          (grobs  (apply append
 209                         (map engraver-grobs consists))))
 210     grobs))
 211
 212 (define (all-contexts-doc)
 213   (let* ((layout-alist
 214           (sort (ly:output-description $defaultlayout)
 215                 (lambda (x y) (symbol<? (car x) (car y)))))
 216          (names (sort (map symbol->string (map car layout-alist)) string<?))
 217          (contexts (map cdr layout-alist)))
 218
 219     (make <texi-node>
 220       #:name "Contexts"
 221       #:desc "Complete descriptions of all contexts"
 222       #:children
 223       (map context-doc contexts))))
 224
 225 (define all-engravers-list  (ly:get-all-translators))
 226 (set! all-engravers-list
 227       (sort all-engravers-list
 228             (lambda (a b) (string<? (symbol->string (ly:translator-name a))
 229                                     (symbol->string (ly:translator-name b))))))
 230
 231 (define (all-engravers-doc)
 232   (make <texi-node>
 233     #:name "Engravers"
 234     #:desc "All separate engravers"
 235     #:text "See @usermanref{Modifying context plug-ins}."
 236     #:children
 237     (map engraver-doc all-engravers-list)))
 238
 239 (define (translation-properties-doc-string lst)
 240   (let* ((ps (sort (map symbol->string lst) string<?))
 241          (sortedsyms (map string->symbol ps))
 242          (propdescs
 243           (map
 244            (lambda (x) (property->texi 'translation  x '()))
 245            sortedsyms))
 246          (texi (description-list->texi propdescs)))
 247     texi))
 248
 249 (define (translation-doc-node)
 250   (make <texi-node>
 251     #:name "Translation"
 252     #:desc "From music to layout"
 253     #:children
 254     (list
 255      (all-contexts-doc)
 256      (all-engravers-doc)
 257      (make <texi-node>
 258        #:name "Tunable context properties"
 259        #:desc "All tunable context properties"
 260        #:text (translation-properties-doc-string
 261                all-user-translation-properties))
 262
 263      (make <texi-node>
 264        #:name "Internal context properties"
 265        #:desc "All internal context properties"
 266        #:text (translation-properties-doc-string
 267                all-internal-translation-properties)))))