]> git.donarmstrong.com Git - lilypond.git/blob - scm/markup.scm
Merge branch 'translation' of ssh://git.sv.gnu.org/srv/git/lilypond into translation
[lilypond.git] / scm / markup.scm
1 ;;;; This file is part of LilyPond, the GNU music typesetter.
2 ;;;;
3 ;;;; Copyright (C) 2003--2012 Han-Wen Nienhuys <hanwen@xs4all.nl>
4 ;;;;
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
7 ;;;; the Free Software Foundation, either version 3 of the License, or
8 ;;;; (at your option) any later version.
9 ;;;;
10 ;;;; LilyPond is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 ;;;; GNU General Public License for more details.
14 ;;;;
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
17
18 (defmacro*-public markup (#:rest body)
19   "The `markup' macro provides a lilypond-like syntax for building markups.
20
21  - #:COMMAND is used instead of \\COMMAND
22  - #:line ( ... ) is used instead of \\line { ... }
23  - etc.
24
25 Example:
26   \\markup { foo
27             \\raise #0.2 \\hbracket \\bold bar
28             \\override #'(baseline-skip . 4)
29             \\bracket \\column { baz bazr bla }
30   }
31          <==>
32   (markup \"foo\"
33           #:raise 0.2 #:hbracket #:bold \"bar\"
34           #:override '(baseline-skip . 4)
35           #:bracket #:column (\"baz\" \"bazr\" \"bla\"))"
36
37   (car (compile-all-markup-expressions `(#:line ,body))))
38
39 ;; utility
40
41 (define (markup-join markups sep)
42   "Return line-markup of MARKUPS, joining them with markup SEP"
43   (if (pair? markups)
44       (make-line-markup (list-insert-separator markups sep))
45       empty-markup))
46
47
48 (define-public interpret-markup ly:text-interface::interpret-markup)
49
50 (define-public (interpret-markup-list layout props markup-list)
51   (let ((stencils (list)))
52     (for-each (lambda (m)
53                 (set! stencils
54                       (if (markup-command-list? m)
55                           (append! (reverse! (apply (car m) layout props (cdr m)))
56                                    stencils)
57                           (cons (interpret-markup layout props m) stencils))))
58               markup-list)
59     (reverse! stencils)))
60
61 (define-public (prepend-alist-chain key val chain)
62   (cons (acons key val (car chain)) (cdr chain)))
63
64 (define-public (stack-stencil-line space stencils)
65   "DOCME"
66   (if (and (pair? stencils)
67            (ly:stencil? (car stencils)))
68
69       (if (and (pair? (cdr stencils))
70                (ly:stencil? (cadr stencils)))
71           (let* ((tail (stack-stencil-line space (cdr stencils)))
72                  (head (car stencils))
73                  (xoff (+ space (interval-length (ly:stencil-extent head X)))))
74             (ly:stencil-add head
75                             (ly:stencil-translate-axis tail xoff X)))
76           (car stencils))
77       (ly:make-stencil '() '(0 . 0) '(0 . 0))))
78
79
80 ;;; convert a full markup object to an approximate pure string representation
81
82 (define-public (markup->string m . argscopes)
83 (let* ((scopes (if (pair? argscopes) (car argscopes) '())))
84   ;; markup commands with one markup argument, formatting ignored
85   (define markups-first-argument '(list
86                                    bold-markup box-markup caps-markup dynamic-markup finger-markup
87                                    fontCaps-markup huge-markup italic-markup large-markup larger-markup
88                                    medium-markup normal-size-sub-markup normal-size-super-markup
89                                    normal-text-markup normalsize-markup number-markup roman-markup
90                                    sans-markup simple-markup small-markup smallCaps-markup smaller-markup
91                                    sub-markup super-markup teeny-markup text-markup tiny-markup
92                                    typewriter-markup underline-markup upright-markup bracket-markup
93                                    circle-markup hbracket-markup parenthesize-markup rounded-box-markup
94
95                                    center-align-markup center-column-markup column-markup dir-column-markup
96                                    fill-line-markup justify-markup justify-string-markup left-align-markup
97                                    left-column-markup line-markup right-align-markup right-column-markup
98                                    vcenter-markup wordwrap-markup wordwrap-string-markup ))
99
100   ;; markup commands with markup as second argument, first argument
101   ;; specifies some formatting and is ignored
102   (define markups-second-argument '(list
103                                     abs-fontsize-markup fontsize-markup magnify-markup lower-markup
104                                     pad-around-markup pad-markup-markup pad-x-markup raise-markup
105                                     halign-markup hcenter-in-markup rotate-markup translate-markup
106                                     translate-scaled-markup with-url-markup scale-markup ))
107
108   ;; helper functions to handle string cons like string lists
109   (define (markup-cons->string-cons c scopes)
110     (if (not (pair? c)) (markup->string c scopes)
111         (cons (markup->string (car c) scopes) (markup-cons->string-cons (cdr c) scopes))))
112   (define (string-cons-join c)
113     (if (not (pair? c)) c
114         (string-join (list (car c) (string-cons-join (cdr c))) "")))
115
116   (cond
117    ((string? m) m)
118    ((null? m) "")
119    ((not (pair? m)) "")
120
121    ;; handle \concat (string-join without spaces)
122    ((and (pair? m) (equal? (car m) concat-markup))
123     (string-cons-join (markup-cons->string-cons (cadr m) scopes)) )
124
125    ;; markup functions with the markup as first arg
126    ((member (car m) (primitive-eval markups-first-argument))
127     (markup->string (cadr m) scopes))
128
129    ;; markup functions with markup as second arg
130    ((member (car m) (primitive-eval markups-second-argument))
131     (markup->string (cddr m) scopes))
132
133    ;; fromproperty-markup reads property values from the header block:
134    ((equal? (car m) fromproperty-markup)
135     (let* ((varname (symbol->string (cadr m)))
136            ;; cut off the header: prefix from the variable name:
137            (newvarname (if (string-prefix? "header:" varname) (substring varname 7) varname))
138            (var (string->symbol newvarname))
139            (mod (make-module 1)))
140       ;; Prevent loops by temporarily clearing the variable we have just looked up
141       (module-define! mod var "")
142       (markup->string (ly:modules-lookup scopes var) (cons mod scopes))))
143
144    ;; ignore all other markup functions
145    ((markup-function? (car m)) "")
146
147    ;; handle markup lists
148    ((list? m)
149     (string-join (map (lambda (mm) (markup->string mm scopes)) m) " "))
150
151    (else "ERROR, unable to extract string from markup"))))