define-markup-commands.scm: Fix bad parameter type for \on-the-fly

[lilypond.git] / scm / define-markup-commands.scm

diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm
index cdfaf1f9f87d20687d0b0769857c32b5f8c39389..aa022974e38adaa9637d5d1c512d12bb3e54b6f7 100644 (file)
--- a/scm/define-markup-commands.scm
+++ b/scm/define-markup-commands.scm
@@ -937,25 +937,45 @@ the use of @code{\\simple} is unnecessary.
 Like simple-markup, but use tie characters for @q{~} tilde symbols.
 
 @lilypond[verbatim,quote]
-\\markup {
-  \\tied-lyric #\"Lasciate~i monti\"
-}
-@end lilypond"
-  (if (string-contains str "~")
-      (let*
-         ((half-space (/ word-space 2))
-          (parts (string-split str #\~))
-          (tie-str (markup #:hspace half-space
-                           #:musicglyph "ties.lyric"
-                           #:hspace half-space))
-          (joined  (list-join parts tie-str))
-          (join-stencil (interpret-markup layout props tie-str))
-          )
+\\markup \\column {
+  \\tied-lyric #\"Siam navi~all'onde~algenti Lasciate~in abbandono\"
+  \\tied-lyric #\"Impetuosi venti I nostri~affetti sono\"
+  \\tied-lyric #\"Ogni diletto~e scoglio Tutta la vita~e~un mar.\"
+}
+@end lilypond"
+  (define (replace-ties tie str)
+    (if (string-contains str "~")
+        (let*
+          ((half-space (/ word-space 2))
+           (parts (string-split str #\~))
+           (tie-str (markup #:hspace half-space
+                            #:musicglyph tie
+                            #:hspace half-space))
+           (joined  (list-join parts tie-str)))
+          (make-concat-markup joined))
+        str))
+
+  (define short-tie-regexp (make-regexp "~[^.]~"))
+  (define (match-short str) (regexp-exec short-tie-regexp str))
+
+  (define (replace-short str mkp)
+    (let ((match (match-short str)))
+      (if (not match)
+          (make-concat-markup (list
+            mkp
+            (replace-ties "ties.lyric.default" str)))
+          (let ((new-str (match:suffix match))
+                (new-mkp (make-concat-markup (list
+                          mkp
+                          (replace-ties "ties.lyric.default"
+                                        (match:prefix match))
+                          (replace-ties "ties.lyric.short"
+                                        (match:substring match))))))
+              (replace-short new-str new-mkp)))))
 
-       (interpret-markup layout
-                         props
-                         (make-concat-markup joined)))
-      (interpret-markup layout props str)))
+  (interpret-markup layout
+                    props
+                    (replace-short str (markup))))
 
 (define-public empty-markup
   (make-simple-markup ""))
@@ -1863,6 +1883,14 @@ Add padding @var{amount} around @var{arg} in the X@tie{}direction.
 ;; property
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define-markup-command (property-recursive layout props symbol)
+  (symbol?)
+  #:category other
+  "Print out a warning when a header field markup contains some recursive
+markup definition."
+  (ly:warning "Recursive definition of property ~a detected!" symbol)
+  empty-stencil)
+
 (define-markup-command (fromproperty layout props symbol)
   (symbol?)
   #:category other
@@ -1885,11 +1913,12 @@ returns an empty markup.
 @end lilypond"
   (let ((m (chain-assoc-get symbol props)))
     (if (markup? m)
-        (interpret-markup layout props m)
+        ;; prevent infinite loops by clearing the interpreted property:
+        (interpret-markup layout (cons (list (cons symbol `(,property-recursive-markup ,symbol))) props) m)
         empty-stencil)))
 
 (define-markup-command (on-the-fly layout props procedure arg)
-  (symbol? markup?)
+  (procedure? markup?)
   #:category other
   "Apply the @var{procedure} markup command to @var{arg}.
 @var{procedure} should take a single argument."
@@ -1900,6 +1929,29 @@ returns an empty markup.
     (interpret-markup layout props (list anonymous-with-signature arg))))
 
 (define-markup-command (footnote layout props mkup note)
+  (markup? markup?)
+  #:category other
+  "Have footnote @var{note} act as an annotation to the markup @var{mkup}.
+
+@lilypond[verbatim,quote]
+\\markup {
+  \\auto-footnote a b
+  \\override #'(padding . 0.2)
+  \\auto-footnote c d
+}
+@end lilypond
+The footnote will not be annotated automatically."
+  (ly:stencil-combine-at-edge
+    (interpret-markup layout props mkup)
+    X
+    RIGHT
+    (ly:make-stencil
+      `(footnote (gensym "footnote") #f ,(interpret-markup layout props note))
+      '(0 . 0)
+      '(0 . 0))
+    0.0))
+
+(define-markup-command (auto-footnote layout props mkup note)
   (markup? markup?)
   #:category other
   #:properties ((raise 0.5)
@@ -1908,11 +1960,12 @@ returns an empty markup.
 
 @lilypond[verbatim,quote]
 \\markup {
-  \\footnote a b
+  \\auto-footnote a b
   \\override #'(padding . 0.2)
-  \\footnote c d
+  \\auto-footnote c d
 }
-@end lilypond"
+@end lilypond
+The footnote will be annotated automatically."
   (let* ((markup-stencil (interpret-markup layout props mkup))
          (auto-numbering (ly:output-def-lookup layout
                                                'footnote-auto-numbering))
@@ -1970,7 +2023,7 @@ returns an empty markup.
   (ly:stencil-add
     main-stencil
     (ly:make-stencil
-      `(footnote ,footnote-hash ,(interpret-markup layout props note))
+      `(footnote ,footnote-hash #t ,(interpret-markup layout props note))
       '(0 . 0)
       '(0 . 0)))))