LEFT | RIGHT |
1 ;;;; This file is part of LilyPond, the GNU music typesetter. | 1 ;;;; This file is part of LilyPond, the GNU music typesetter. |
2 ;;;; | 2 ;;;; |
3 ;;;; Copyright (C) 2003--2020 Han-Wen Nienhuys <hanwen@xs4all.nl> | 3 ;;;; Copyright (C) 2003--2020 Han-Wen Nienhuys <hanwen@xs4all.nl> |
4 ;;;; | 4 ;;;; |
5 ;;;; LilyPond is free software: you can redistribute it and/or modify | 5 ;;;; LilyPond is free software: you can redistribute it and/or modify |
6 ;;;; it under the terms of the GNU General Public License as published by | 6 ;;;; it under the terms of the GNU General Public License as published by |
7 ;;;; the Free Software Foundation, either version 3 of the License, or | 7 ;;;; the Free Software Foundation, either version 3 of the License, or |
8 ;;;; (at your option) any later version. | 8 ;;;; (at your option) any later version. |
9 ;;;; | 9 ;;;; |
10 ;;;; LilyPond is distributed in the hope that it will be useful, | 10 ;;;; LilyPond is distributed in the hope that it will be useful, |
(...skipping 78 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
89 where: | 89 where: |
90 `category' is either a symbol or a symbol list specifying the | 90 `category' is either a symbol or a symbol list specifying the |
91 categories for this markup command in the docs. | 91 categories for this markup command in the docs. |
92 | 92 |
93 As an element of the `properties' list, you may directly use a | 93 As an element of the `properties' list, you may directly use a |
94 COMMANDx-markup symbol instead of a `(prop value)' list to indicate | 94 COMMANDx-markup symbol instead of a `(prop value)' list to indicate |
95 that this markup command is called by the newly defined command, | 95 that this markup command is called by the newly defined command, |
96 adding its properties to the documented properties of the new | 96 adding its properties to the documented properties of the new |
97 command. There is no protection against circular definitions. | 97 command. There is no protection against circular definitions. |
98 " | 98 " |
| 99 (let* ((command (if (pair? command-and-args) |
| 100 (car command-and-args) |
| 101 command-and-args)) |
| 102 (args (and (pair? command-and-args) (cdr command-and-args)))) |
| 103 (if args |
| 104 `(,define-markup-command-internal |
| 105 ',command (markup-lambda ,args ,@definition) #f) |
| 106 `(,define-markup-command-internal |
| 107 - ',command ,@definition #f)))) |
| 108 |
| 109 (defmacro-public define-markup-command-compilable (command-and-args . definition
) |
| 110 "Like define-markup-command, but for use in LilyPond .scm files. We |
| 111 generate define-public statements, so the .scm files can be compiled" |
99 (let* | 112 (let* |
100 ((command (car command-and-args)) | 113 ((command (car command-and-args)) |
101 (args (cdr command-and-args)) | 114 (args (cdr command-and-args)) |
102 (command-name (string->symbol (format #f "~a-markup" command))) | 115 (command-name (string->symbol (format #f "~a-markup" command))) |
103 (make-markup-name-str (format #f "make-~a" command-name)) | 116 (make-markup-name-str (format #f "make-~a" command-name)) |
104 (make-markup-name (string->symbol make-markup-name-str))) | 117 (make-markup-name (string->symbol make-markup-name-str))) |
105 | 118 |
106 `(begin | 119 `(begin |
107 (define-public ,command-name | 120 (define-public ,command-name |
108 (markup-lambda ,args ,@definition)) | 121 (markup-lambda ,args ,@definition)) |
(...skipping 48 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
157 `(list ',(car prop-spec) ,(cadr prop-spec))) | 170 `(list ',(car prop-spec) ,(cadr prop-spec))) |
158 (else | 171 (else |
159 `(list ',(car prop-spec))))) | 172 `(list ',(car prop-spec))))) |
160 properties)) | 173 properties)) |
161 ',category))) | 174 ',category))) |
162 | 175 |
163 (defmacro-public define-markup-list-command | 176 (defmacro-public define-markup-list-command |
164 (command-and-args . definition) | 177 (command-and-args . definition) |
165 "Same as `define-markup-command', but defines a command that, when | 178 "Same as `define-markup-command', but defines a command that, when |
166 interpreted, returns a list of stencils instead of a single one" | 179 interpreted, returns a list of stencils instead of a single one" |
| 180 (let* ((command (if (pair? command-and-args) |
| 181 (car command-and-args) |
| 182 command-and-args)) |
| 183 (args (and (pair? command-and-args) (cdr command-and-args)))) |
| 184 (if args |
| 185 `(,define-markup-command-internal |
| 186 ',command (markup-list-lambda ,args ,@definition) #t) |
| 187 `(,define-markup-command-internal |
| 188 ',command ,@definition #t)))) |
| 189 |
| 190 (defmacro-public define-markup-list-command-compilable |
| 191 (command-and-args . definition) |
| 192 "Like `define-markup-list-command`, but using define-public, so it |
| 193 can be compiled." |
167 (let* ((command (car command-and-args)) | 194 (let* ((command (car command-and-args)) |
168 (args (cdr command-and-args)) | 195 (args (cdr command-and-args)) |
169 (command-name-str (format #f "~a-markup-list" command)) | 196 (command-name-str (format #f "~a-markup-list" command)) |
170 (command-name (string->symbol command-name-str)) | 197 (command-name (string->symbol command-name-str)) |
171 (make-markup-name-str (format #f "make-~a-markup-list" command)) | 198 (make-markup-name-str (format #f "make-~a-markup-list" command)) |
172 (make-markup-name (string->symbol make-markup-name-str))) | 199 (make-markup-name (string->symbol make-markup-name-str))) |
173 | 200 |
174 `(begin | 201 `(begin |
175 (define-public ,command-name | 202 (define-public ,command-name |
176 (markup-list-lambda ,args ,@definition)) | 203 (markup-list-lambda ,args ,@definition)) |
177 (define-public ,make-markup-name | 204 (define-public ,make-markup-name |
178 (lambda markup-args | 205 (lambda markup-args |
179 (list (make-markup ,command-name ,make-markup-name-str markup-args)) | 206 (list (make-markup ,command-name ,make-markup-name-str markup-args)) |
180 ))) | 207 ))) |
181 )) | 208 )) |
182 | 209 |
183 (define (define-markup-command-internal command definition) | 210 (define (define-markup-command-internal command definition is-list) |
184 """Define a markup command at runtime. Called from the parser.""" | 211 """Define a markup command at runtime. Called from the parser.""" |
185 (let* ( | 212 (let* ( |
186 (command-name (string->symbol (format #f "~a-markup" command))) | 213 (suffix (if is-list "-list" "")) |
187 (make-markup-name (string->symbol (format #f "make-~a-markup" command))
)) | 214 (command-name (string->symbol (format #f "~a-markup~a" command suffix))
) |
| 215 (make-markup-name (string->symbol (format #f "make-~a-markup~a" command
suffix)))) |
| 216 |
188 (if (not (procedure-name definition)) | 217 (if (not (procedure-name definition)) |
189 (set-procedure-property! definition 'name command-name)) | 218 (set-procedure-property! definition 'name command-name)) |
190 (module-define! (current-module) command-name definition) | 219 (module-define! (current-module) command-name definition) |
191 (module-define! (current-module) make-markup-name | 220 (module-define! (current-module) make-markup-name |
192 (lambda args (make-markup definition make-markup-name args))
) | 221 (lambda args |
193 (module-export! (current-module) (list command-name make-markup-name)))) | 222 (if is-list |
| 223 (list (make-markup definition make-markup-name args)) |
| 224 (make-markup definition make-markup-name args)))) |
| 225 (module-export! (current-module) |
| 226 (list command-name make-markup-name)))) |
194 | 227 |
195 (defmacro*-public markup-list-lambda | 228 (defmacro*-public markup-list-lambda |
196 (arg signature #:key (properties '()) #:rest body) | 229 (arg signature #:key (properties '()) #:rest body) |
197 "Same as `markup-lambda' but defines a markup list command that, when | 230 "Same as `markup-lambda' but defines a markup list command that, when |
198 interpreted, returns a list of stencils instead of a single one" | 231 interpreted, returns a list of stencils instead of a single one" |
199 (let () ; Guile 1.8 defmacro* workaround | 232 (let () ; Guile 1.8 defmacro* workaround |
200 (define (markup-lambda-listify fun) | 233 (define (markup-lambda-listify fun) |
201 (set! (markup-list-function? fun) #t) | 234 (set! (markup-list-function? fun) #t) |
202 fun) | 235 fun) |
203 (list markup-lambda-listify (cons* 'markup-lambda arg signature body)))) | 236 (list markup-lambda-listify (cons* 'markup-lambda arg signature body)))) |
(...skipping 86 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
290 (define (cheap-markup? x) | 323 (define (cheap-markup? x) |
291 (or (string? x) | 324 (or (string? x) |
292 (and (pair? x) | 325 (and (pair? x) |
293 (markup-function? (car x))))) | 326 (markup-function? (car x))))) |
294 | 327 |
295 ;; | 328 ;; |
296 ;; replace by markup-thrower-typecheck for more detailed diagnostics. | 329 ;; replace by markup-thrower-typecheck for more detailed diagnostics. |
297 ;; | 330 ;; |
298 (define-public markup? cheap-markup?) | 331 (define-public markup? cheap-markup?) |
299 | 332 |
300 (define-public (make-markup markup-function make-name args) | 333 (define (make-markup markup-function make-name args) |
301 " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck | 334 " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck |
302 against signature, reporting MAKE-NAME as the user-invoked function. | 335 against signature, reporting MAKE-NAME as the user-invoked function. |
303 " | 336 " |
304 (let* ((arglen (length args)) | 337 (let* ((arglen (length args)) |
305 (signature (or (markup-command-signature markup-function) | 338 (signature (or (markup-command-signature markup-function) |
306 (ly:error (_ "~A: Not a markup (list) function: ~S") | 339 (ly:error (_ "~A: Not a markup (list) function: ~S") |
307 make-name markup-function))) | 340 make-name markup-function))) |
308 (siglen (length signature)) | 341 (siglen (length signature)) |
309 (error-msg (if (and (> siglen 0) (> arglen 0)) | 342 (error-msg (if (and (> siglen 0) (> arglen 0)) |
310 (markup-argument-list-error signature args 1) | 343 (markup-argument-list-error signature args 1) |
(...skipping 118 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
429 (let ((proc (lookup-markup-command-aux | 462 (let ((proc (lookup-markup-command-aux |
430 (string->symbol (format #f "~a-markup" code))))) | 463 (string->symbol (format #f "~a-markup" code))))) |
431 (and proc (markup-function? proc) | 464 (and proc (markup-function? proc) |
432 (cons proc (markup-command-signature proc))))) | 465 (cons proc (markup-command-signature proc))))) |
433 | 466 |
434 (define-public (lookup-markup-list-command code) | 467 (define-public (lookup-markup-list-command code) |
435 (let ((proc (lookup-markup-command-aux | 468 (let ((proc (lookup-markup-command-aux |
436 (string->symbol (format #f "~a-markup-list" code))))) | 469 (string->symbol (format #f "~a-markup-list" code))))) |
437 (and proc (markup-list-function? proc) | 470 (and proc (markup-list-function? proc) |
438 (cons proc (markup-command-signature proc))))) | 471 (cons proc (markup-command-signature proc))))) |
LEFT | RIGHT |