scm/markup.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2003--2015 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   (fold-right
  52    (lambda (m prev)
  53      (if (markup-command-list? m)
  54          (append (apply (car m) layout props (cdr m)) prev)
  55          (cons (interpret-markup layout props m) prev)))
  56    '()
  57    markup-list))
  58
  59 (define-public (prepend-alist-chain key val chain)
  60   (cons (acons key val (car chain)) (cdr chain)))
  61
  62 (define-public (stack-stencil-line space stencils)
  63   "Adjoin a list of @var{stencils} along the X axis, leaving
  64 @var{space} between the end of each stencil and the beginning of the
  65 following stencil.  Stencils with empty Y extent are not given
  66 @var{space} before them and don't avoid overlapping other stencils."
  67   (stack-stencils X RIGHT space (filter ly:stencil? stencils)))
  68
  69 ;;;; convert a full markup object to an approximate pure string representation
  70
  71 ;; We ignore `page-ref-markup', because we don't want to get the
  72 ;; `gauge'- and `default'-string
  73 ;;
  74 ;; TODO:
  75 ;; - we would be interested in the computed result of `replace-markup' and
  76 ;;   `first-visible-markup', don't know how to get this, though
  77 ;;   For now all (not computed) arguments are caught.
  78 ;; - Other markup-commands to ignore?
  79 (define markup-commands-to-ignore
  80   '(page-ref-markup))
  81
  82 (define-public (markup->string m . argscopes)
  83   (let* ((scopes (if (pair? argscopes) (car argscopes) '())))
  84
  85     (define all-relevant-markup-commands
  86       ;; Returns a list containing the names of all markup-commands and
  87       ;; markup-list-commands with predicate @code{cheap-markup?} or
  88       ;; @code{markup-list?} in their @code{markup-command-signature}.
  89       ;; @code{table-of-contents} is not caught, same for user-defined commands.
  90       ;; markup-commands from @code{markup-commands-to-ignore} are removed.
  91       (lset-difference eq?
  92         (map car
  93           (filter
  94             (lambda (x)
  95               (let* ((predicates (markup-command-signature (cdr x))))
  96                 (and predicates
  97                      (not
  98                        (null?
  99                          (lset-intersection eq?
 100                            '(cheap-markup? markup-list?)
 101                            (map procedure-name predicates)))))))
 102             (ly:module->alist (resolve-module '(lily)))))
 103         markup-commands-to-ignore))
 104
 105     ;; helper functions to handle string cons like string lists
 106     (define (markup-cons->string-cons c scopes)
 107       (if (not (pair? c)) (markup->string c scopes)
 108           (cons
 109             (markup->string (car c) scopes)
 110             (markup-cons->string-cons (cdr c) scopes))))
 111     (define (string-cons-join c)
 112       (if (not (pair? c)) c
 113           (string-join (list (car c) (string-cons-join (cdr c))) "")))
 114
 115     ;; We let the following line in for future debugging
 116     ;; (display-scheme-music (sort all-relevant-markup-commands symbol<?))
 117
 118
 119     ;;;; Remark: below only works, if markup?- or markup-list? arguments are the
 120     ;;;;         last listed arguments in the commands definition
 121     ;;;; TODO: which other markup-(list)-commands should be special cased or
 122     ;;;;       completely excluded?
 123     (cond
 124      ((string? m) m)
 125      ((null? m) "")
 126      ((not (pair? m)) "")
 127
 128      ;;;; special cases: \concat, \put-adjacent, \fill-with-pattern and
 129      ;;;;                \fromproperty-markup
 130      ;;;;
 131      ;;;; TODO do we really want a string-joined return-value for \concat and
 132      ;;;; \put-adjacent?
 133      ;;;; \overlay or \combine will return a string with spaces
 134
 135      ;; handle \concat (string-join without spaces)
 136      ((and (pair? m) (equal? (car m) concat-markup))
 137       (string-cons-join (markup-cons->string-cons (cadr m) scopes)))
 138
 139      ;; handle \put-adjacent (string-join without spaces)
 140      ((and (pair? m) (equal? (car m) put-adjacent-markup))
 141       (string-cons-join (markup-cons->string-cons (take-right m 2) scopes)))
 142
 143      ;; handle \fill-with-pattern (ignore the filling markup)
 144      ((and (pair? m) (equal? (car m) fill-with-pattern-markup))
 145       (markup->string (take-right m 2) scopes))
 146
 147      ;; fromproperty-markup reads property values from the header block:
 148      ((equal? (car m) fromproperty-markup)
 149       (let* ((varname (symbol->string (cadr m)))
 150              ;; cut off the header: prefix from the variable name:
 151              (newvarname (if (string-prefix? "header:" varname)
 152                              (substring varname 7)
 153                              varname))
 154              (var (string->symbol newvarname))
 155              (mod (make-module 1)))
 156         ;; Prevent loops by temporarily clearing the variable we have just looked up
 157         (module-define! mod var "")
 158         (markup->string (ly:modules-lookup scopes var) (cons mod scopes))))
 159
 160      ((member (car m)
 161               (primitive-eval (cons 'list all-relevant-markup-commands)))
 162       (markup->string
 163         (if (> (length (last-pair m)) 1)
 164             (last-pair m)
 165             (car (last-pair m)))
 166         scopes))
 167
 168      ;; ignore all other markup functions
 169      ((markup-function? (car m)) "")
 170
 171      ;; handle markup lists
 172      ((list? m)
 173       (string-join (map (lambda (mm) (markup->string mm scopes)) m) " "))
 174
 175      (else "ERROR, unable to extract string from markup"))))