X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmarkup.scm;h=14a007a95bb27f8a89da2aeb51a607695af40068;hb=HEAD;hp=45652c0a5c8c1a63b67ea4b0ca6b944c2dd747e9;hpb=010656e27a58cc47feb2bd267e157f69f58cb74d;p=lilypond.git diff --git a/scm/markup.scm b/scm/markup.scm index 45652c0a5c..14a007a95b 100644 --- a/scm/markup.scm +++ b/scm/markup.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2003--2012 Han-Wen Nienhuys +;;;; Copyright (C) 2003--2015 Han-Wen Nienhuys ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -48,16 +48,13 @@ Example: (define-public interpret-markup ly:text-interface::interpret-markup) (define-public (interpret-markup-list layout props markup-list) - ;; This relies on the markup list returned by a markup list command - ;; to be modifiable - (reverse! - (fold - (lambda (m prev) - (if (markup-command-list? m) - (reverse! (apply (car m) layout props (cdr m)) prev) - (cons (interpret-markup layout props m) prev))) - '() - markup-list))) + (fold-right + (lambda (m prev) + (if (markup-command-list? m) + (append (apply (car m) layout props (cdr m)) prev) + (cons (interpret-markup layout props m) prev))) + '() + markup-list)) (define-public (prepend-alist-chain key val chain) (cons (acons key val (car chain)) (cdr chain))) @@ -69,75 +66,110 @@ following stencil. Stencils with empty Y extent are not given @var{space} before them and don't avoid overlapping other stencils." (stack-stencils X RIGHT space (filter ly:stencil? stencils))) -;;; convert a full markup object to an approximate pure string representation +;;;; convert a full markup object to an approximate pure string representation + +;; We ignore `page-ref-markup', because we don't want to get the +;; `gauge'- and `default'-string +;; +;; TODO: +;; - we would be interested in the computed result of `replace-markup' and +;; `first-visible-markup', don't know how to get this, though +;; For now all (not computed) arguments are caught. +;; - Other markup-commands to ignore? +(define markup-commands-to-ignore + '(page-ref-markup)) (define-public (markup->string m . argscopes) -(let* ((scopes (if (pair? argscopes) (car argscopes) '()))) - ;; markup commands with one markup argument, formatting ignored - (define markups-first-argument '(list - bold-markup box-markup caps-markup dynamic-markup finger-markup - fontCaps-markup huge-markup italic-markup large-markup larger-markup - medium-markup normal-size-sub-markup normal-size-super-markup - normal-text-markup normalsize-markup number-markup roman-markup - sans-markup simple-markup small-markup smallCaps-markup smaller-markup - sub-markup super-markup teeny-markup text-markup tiny-markup - typewriter-markup underline-markup upright-markup bracket-markup - circle-markup hbracket-markup parenthesize-markup rounded-box-markup - - center-align-markup center-column-markup column-markup dir-column-markup - fill-line-markup justify-markup justify-string-markup left-align-markup - left-column-markup line-markup right-align-markup right-column-markup - vcenter-markup wordwrap-markup wordwrap-string-markup )) - - ;; markup commands with markup as second argument, first argument - ;; specifies some formatting and is ignored - (define markups-second-argument '(list - abs-fontsize-markup fontsize-markup magnify-markup lower-markup - pad-around-markup pad-markup-markup pad-x-markup raise-markup - halign-markup hcenter-in-markup rotate-markup translate-markup - translate-scaled-markup with-url-markup scale-markup )) - - ;; helper functions to handle string cons like string lists - (define (markup-cons->string-cons c scopes) - (if (not (pair? c)) (markup->string c scopes) - (cons (markup->string (car c) scopes) (markup-cons->string-cons (cdr c) scopes)))) - (define (string-cons-join c) - (if (not (pair? c)) c - (string-join (list (car c) (string-cons-join (cdr c))) ""))) - - (cond - ((string? m) m) - ((null? m) "") - ((not (pair? m)) "") - - ;; handle \concat (string-join without spaces) - ((and (pair? m) (equal? (car m) concat-markup)) - (string-cons-join (markup-cons->string-cons (cadr m) scopes)) ) - - ;; markup functions with the markup as first arg - ((member (car m) (primitive-eval markups-first-argument)) - (markup->string (cadr m) scopes)) - - ;; markup functions with markup as second arg - ((member (car m) (primitive-eval markups-second-argument)) - (markup->string (cddr m) scopes)) - - ;; fromproperty-markup reads property values from the header block: - ((equal? (car m) fromproperty-markup) - (let* ((varname (symbol->string (cadr m))) - ;; cut off the header: prefix from the variable name: - (newvarname (if (string-prefix? "header:" varname) (substring varname 7) varname)) - (var (string->symbol newvarname)) - (mod (make-module 1))) - ;; Prevent loops by temporarily clearing the variable we have just looked up - (module-define! mod var "") - (markup->string (ly:modules-lookup scopes var) (cons mod scopes)))) - - ;; ignore all other markup functions - ((markup-function? (car m)) "") - - ;; handle markup lists - ((list? m) - (string-join (map (lambda (mm) (markup->string mm scopes)) m) " ")) - - (else "ERROR, unable to extract string from markup")))) + (let* ((scopes (if (pair? argscopes) (car argscopes) '()))) + + (define all-relevant-markup-commands + ;; Returns a list containing the names of all markup-commands and + ;; markup-list-commands with predicate @code{cheap-markup?} or + ;; @code{markup-list?} in their @code{markup-command-signature}. + ;; @code{table-of-contents} is not caught, same for user-defined commands. + ;; markup-commands from @code{markup-commands-to-ignore} are removed. + (lset-difference eq? + (map car + (filter + (lambda (x) + (let* ((predicates (markup-command-signature (cdr x)))) + (and predicates + (not + (null? + (lset-intersection eq? + '(cheap-markup? markup-list?) + (map procedure-name predicates))))))) + (ly:module->alist (resolve-module '(lily))))) + markup-commands-to-ignore)) + + ;; helper functions to handle string cons like string lists + (define (markup-cons->string-cons c scopes) + (if (not (pair? c)) (markup->string c scopes) + (cons + (markup->string (car c) scopes) + (markup-cons->string-cons (cdr c) scopes)))) + (define (string-cons-join c) + (if (not (pair? c)) c + (string-join (list (car c) (string-cons-join (cdr c))) ""))) + + ;; We let the following line in for future debugging + ;; (display-scheme-music (sort all-relevant-markup-commands symbolstring-cons (cadr m) scopes))) + + ;; handle \put-adjacent (string-join without spaces) + ((and (pair? m) (equal? (car m) put-adjacent-markup)) + (string-cons-join (markup-cons->string-cons (take-right m 2) scopes))) + + ;; handle \fill-with-pattern (ignore the filling markup) + ((and (pair? m) (equal? (car m) fill-with-pattern-markup)) + (markup->string (take-right m 2) scopes)) + + ;; fromproperty-markup reads property values from the header block: + ((equal? (car m) fromproperty-markup) + (let* ((varname (symbol->string (cadr m))) + ;; cut off the header: prefix from the variable name: + (newvarname (if (string-prefix? "header:" varname) + (substring varname 7) + varname)) + (var (string->symbol newvarname)) + (mod (make-module 1))) + ;; Prevent loops by temporarily clearing the variable we have just looked up + (module-define! mod var "") + (markup->string (ly:modules-lookup scopes var) (cons mod scopes)))) + + ((member (car m) + (primitive-eval (cons 'list all-relevant-markup-commands))) + (markup->string + (if (> (length (last-pair m)) 1) + (last-pair m) + (car (last-pair m))) + scopes)) + + ;; ignore all other markup functions + ((markup-function? (car m)) "") + + ;; handle markup lists + ((list? m) + (string-join (map (lambda (mm) (markup->string mm scopes)) m) " ")) + + (else "ERROR, unable to extract string from markup"))))