scm/document-translation.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2000--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
   4 ;;;;                 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;;
   6 ;;;; LilyPond is free software: you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation, either version 3 of the License, or
   9 ;;;; (at your option) any later version.
  10 ;;;;
  11 ;;;; LilyPond is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define (engraver-makes-grob? name-symbol grav)
  20   (memq name-symbol (assoc 'grobs-created (ly:translator-description grav))))
  21
  22 (define (engraver-accepts-music-type? name-symbol grav)
  23   (memq name-symbol (assoc 'events-accepted (ly:translator-description grav))))
  24
  25 (define (engraver-accepts-music-types? types grav)
  26   (if (null? types)
  27       #f
  28       (or
  29        (engraver-accepts-music-type? (car types) grav)
  30        (engraver-accepts-music-types? (cdr types) grav))))
  31
  32 (define (engraver-doc-string engraver in-which-contexts)
  33   (let* ((propsr (assoc-get 'properties-read (ly:translator-description engraver)))
  34          (propsw (assoc-get 'properties-written (ly:translator-description engraver)))
  35          (accepted  (assoc-get 'events-accepted (ly:translator-description engraver)))
  36          (name-sym  (ly:translator-name engraver))
  37          (name-str (symbol->string name-sym))
  38          (desc (assoc-get 'description (ly:translator-description engraver)))
  39          (grobs (engraver-grobs engraver)))
  40
  41     (string-append
  42      desc
  43      "\n\n"
  44      (if (pair? accepted)
  45          (string-append
  46           "Music types accepted:\n\n"
  47           (human-listify
  48            (map ref-ify (sort (map symbol->string accepted) ly:string-ci<?))))
  49          "")
  50      "\n\n"
  51      (if (pair? propsr)
  52          (string-append
  53           "Properties (read)"
  54           (description-list->texi
  55            (map (lambda (x) (property->texi 'translation x '()))
  56                 (sort propsr ly:symbol-ci<?))
  57            #t))
  58          "")
  59
  60      (if (null? propsw)
  61          ""
  62          (string-append
  63           "Properties (write)"
  64           (description-list->texi
  65            (map (lambda (x) (property->texi 'translation x '()))
  66                 (sort propsw ly:symbol-ci<?))
  67            #t)))
  68      (if  (null? grobs)
  69           ""
  70           (string-append
  71            "\n\nThis engraver creates the following layout object(s):\n\n"
  72            (human-listify (map ref-ify (uniq-list (sort grobs ly:string-ci<?))))
  73            "."))
  74
  75      "\n\n"
  76
  77      (if in-which-contexts
  78          (let* ((layout-alist (ly:output-description $defaultlayout))
  79                 (context-description-alist (map cdr layout-alist))
  80                 (contexts
  81                  (append-map
  82                   (lambda (x)
  83                     (let* ((context (assoc-get 'context-name x))
  84                            (group (assq-ref x 'group-type))
  85                            (consists (append
  86                                       (if group
  87                                           (list group)
  88                                           '())
  89                                       (assoc-get 'consists x))))
  90                       (if (member name-sym consists)
  91                           (list context)
  92                           '())))
  93                   context-description-alist))
  94                 (context-list (human-listify (map ref-ify
  95                                                   (sort
  96                                                    (map symbol->string contexts)
  97                                                    ly:string-ci<?)))))
  98            (string-append
  99             "@code{" name-str "} "
 100             (if (equal? context-list "none")
 101                 "is not part of any context"
 102                 (string-append
 103                  "is part of the following context(s): "
 104                  context-list))
 105             "."))
 106          ""))))
 107
 108 ;; First level Engraver description
 109 (define (engraver-doc grav)
 110   (make <texi-node>
 111     #:name (symbol->string (ly:translator-name grav))
 112     #:text (engraver-doc-string grav #t)))
 113
 114 ;; Second level, part of Context description
 115 (define name->engraver-table (make-hash-table 61))
 116 (for-each
 117  (lambda (x)
 118    (hash-set! name->engraver-table (ly:translator-name x) x))
 119  (ly:get-all-translators))
 120
 121 (define (find-engraver-by-name name)
 122   "NAME is a symbol."
 123   (hash-ref name->engraver-table name #f))
 124
 125 (define (document-engraver-by-name name)
 126   "NAME is a symbol."
 127
 128   (let* ((eg (find-engraver-by-name name)))
 129
 130     (cons (string-append "@code{" (ref-ify (symbol->string name)) "}")
 131           (engraver-doc-string eg #f))))
 132
 133 (define (document-property-operation op)
 134   (let ((tag (car op))
 135         (context-sym (cadr op))
 136         (args (cddr op))
 137         )
 138
 139     (cond
 140      ((equal?  tag 'push)
 141       (let*
 142           ((value (car args))
 143            (path (cdr args)))
 144
 145         (string-append
 146          (format #f "@item Set grob-property @code{~{~a~^.~}} " path)
 147          (format #f "in @ref{~a} to" context-sym)
 148          (if (pretty-printable? value)
 149            (format #f ":~a\n" (scm->texi value))
 150            (format #f " ~a.\n" (scm->texi value))))))
 151      ((equal? (object-property context-sym 'is-grob?) #t) "")
 152      ((equal? tag 'assign)
 153       (string-append
 154         (format #f "@item Set translator property @code{~a} to" context-sym)
 155         (if (pretty-printable? (car args))
 156           (format #f ":~a\n" (scm->texi (car args)))
 157           (format #f " ~a.\n" (scm->texi (car args)))))))))
 158
 159
 160 (define (context-doc context-desc)
 161   (let* ((name-sym (assoc-get 'context-name context-desc))
 162          (name (symbol->string name-sym))
 163          (aliases (map symbol->string (assoc-get 'aliases context-desc)))
 164          (desc (assoc-get 'description context-desc "(not documented"))
 165          (accepts (assoc-get 'accepts context-desc))
 166          (consists (assoc-get 'consists context-desc))
 167          (props (assoc-get 'property-ops context-desc))
 168          (defaultchild (assoc-get 'default-child context-desc))
 169          (grobs  (context-grobs context-desc))
 170          (grob-refs (map ref-ify (sort grobs ly:string-ci<?))))
 171
 172     (make <texi-node>
 173       #:name name
 174       #:text
 175       (string-append
 176        desc
 177        (if (pair? aliases)
 178            (string-append
 179             "\n\nThis context also accepts commands for the following context(s):\n\n"
 180             (human-listify (sort aliases ly:string-ci<?))
 181             ".")
 182            "")
 183
 184        "\n\nThis context creates the following layout object(s):\n\n"
 185        (human-listify (uniq-list grob-refs))
 186        "."
 187
 188        (if (and (pair? props) (not (null? props)))
 189            (let ((str (string-concatenate
 190                        (sort (map document-property-operation props)
 191                              ly:string-ci<?))))
 192              (if (string-null? str)
 193                  ""
 194                  (string-append
 195                   "\n\nThis context sets the following properties:\n\n"
 196                   "@itemize @bullet\n"
 197                   str
 198                   "@end itemize\n")))
 199            "")
 200
 201        (if defaultchild
 202            (format #f "\n\nThis is not a `Bottom' context; search for such a one will commence after creating an implicit context of type @ref{~a}."
 203                    defaultchild)
 204            "\n\nThis is a `Bottom' context; no contexts will be created implicitly from it.")
 205
 206        (if (null? accepts)
 207            "\n\nThis context cannot contain other contexts."
 208            (string-append
 209             "\n\nContext "
 210             name
 211             " can contain\n"
 212             (human-listify (map ref-ify (sort (map symbol->string accepts)
 213                                               ly:string-ci<?)))
 214             "."))
 215
 216        (if (null? consists)
 217            ""
 218            (string-append
 219             "\n\nThis context is built from the following engraver(s):"
 220             (description-list->texi
 221              (map document-engraver-by-name (sort consists ly:symbol-ci<?))
 222              #t)))))))
 223
 224 (define (engraver-grobs grav)
 225   (let* ((eg (if (symbol? grav)
 226                  (find-engraver-by-name grav)
 227                  grav)))
 228     (if (eq? eg #f)
 229         '()
 230         (map symbol->string (assoc-get 'grobs-created (ly:translator-description eg))))))
 231
 232 (define (context-grobs context-desc)
 233   (let* ((group (assq-ref context-desc 'group-type))
 234          (consists (append
 235                     (if group
 236                         (list group)
 237                         '())
 238                     (assoc-get 'consists context-desc)))
 239          (grobs (append-map engraver-grobs consists)))
 240     grobs))
 241
 242 (define (all-contexts-doc)
 243   (let* ((layout-alist
 244           (sort (ly:output-description $defaultlayout)
 245                 (lambda (x y) (ly:symbol-ci<? (car x) (car y)))))
 246          (names (sort (map symbol->string (map car layout-alist)) ly:string-ci<?))
 247          (contexts (map cdr layout-alist)))
 248
 249     (make <texi-node>
 250       #:name "Contexts"
 251       #:desc "Complete descriptions of all contexts."
 252       #:children
 253       (map context-doc contexts))))
 254
 255 (define all-engravers-list  (ly:get-all-translators))
 256 (set! all-engravers-list
 257       (sort all-engravers-list
 258             (lambda (a b) (ly:string-ci<? (symbol->string (ly:translator-name a))
 259                                           (symbol->string (ly:translator-name b))))))
 260
 261 (define (all-engravers-doc)
 262   (make <texi-node>
 263     #:name "Engravers and Performers"
 264     #:desc "All separate engravers and performers."
 265     #:text "See @ruser{Modifying context plug-ins}."
 266     #:children
 267     (map engraver-doc all-engravers-list)))
 268
 269 (define (translation-properties-doc-string lst)
 270   (let* ((ps (sort (map symbol->string lst) ly:string-ci<?))
 271          (sortedsyms (map string->symbol ps))
 272          (propdescs
 273           (map
 274            (lambda (x) (property->texi 'translation  x '()))
 275            sortedsyms))
 276          (texi (description-list->texi propdescs #f)))
 277     texi))
 278
 279 (define (translation-doc-node)
 280   (make <texi-node>
 281     #:name "Translation"
 282     #:desc "From music to layout."
 283     #:children
 284     (list
 285      (all-contexts-doc)
 286      (all-engravers-doc)
 287      (make <texi-node>
 288        #:name "Tunable context properties"
 289        #:desc "All tunable context properties."
 290        #:text (translation-properties-doc-string
 291                all-user-translation-properties))
 292
 293      (make <texi-node>
 294        #:name "Internal context properties"
 295        #:desc "All internal context properties."
 296        #:text (translation-properties-doc-string
 297                all-internal-translation-properties)))))