X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmarkup.scm;h=d323ad3b4235f27f2eff9332b33e4eca7e720ebb;hb=9e781b7dc83b60a543ce218aa1a5f139f74c760f;hp=45652c0a5c8c1a63b67ea4b0ca6b944c2dd747e9;hpb=010656e27a58cc47feb2bd267e157f69f58cb74d;p=lilypond.git diff --git a/scm/markup.scm b/scm/markup.scm index 45652c0a5c..d323ad3b42 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--2014 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))) @@ -72,72 +69,72 @@ following stencil. Stencils with empty Y extent are not given ;;; convert a full markup object to an approximate pure string representation (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) '()))) + ;; 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"))))