Hi,
May I apply this patch?
Nicolas Sceaux <[EMAIL PROTECTED]> writes:
> Nicolas Sceaux <[EMAIL PROTECTED]> writes:
>
>> Hi,
>>
>> While thinking about an automatic way to build tables of contents (with
>> a few \header variables, a \table-of-contents command, et voilà), I
>> realized that an other problem needs to be solved first. Indeed, if the
>> table of contents is too long for a single page, then it should be split
>> to fill several pages. Hence the need of breakable markups.
>
> Here is a patch implementing this feature.
>
> - \markuplist is a new keyword for entering text that is not
> interpreted as a single markup of several lines, but as several
> one-line markups. The parser is modified to allow this, and
> define-(builtin-)markup-list-command macros are defined.
the keyword is named \markuplines in this patch.
> - texts are collected into books as list of props. When
> Paper_book::get_system_specs finds a list of more than one props (ie
> a markuplist, a list of a single prop being the result of a toplevel
> \markup), it sets their next-space and next-padding properties to
> (almost) zero so that the lines of a paragraph are not stretched on a
> page
with the zero-spacing problem fix, the spacing is fine now.
diff --git a/input/regression/markup-lines.ly b/input/regression/markup-lines.ly
new file mode 100644
index 0000000..752dcf3
--- /dev/null
+++ b/input/regression/markup-lines.ly
@@ -0,0 +1,38 @@
+\version "2.11.25"
+
+\header {
+ texidoc = "Text that can spread over pages is entered with the
[EMAIL PROTECTED] command."
+}
+
+#(set-default-paper-size "a6")
+
+#(define-markup-list-command (paragraph layout props args) (markup-list?)
+ (interpret-markup-list layout props
+ (make-justified-lines-markup-list (cons (make-hspace-markup 2) args))))
+
+%% Candide, Voltaire
+\markuplines \override-lines #'(baseline-skip . 2.5) {
+ \paragraph {
+ Il y avait en Westphalie, dans le château de M. le baron de
+ Thunder-ten-tronckh, un jeune garçon à qui la nature avait donné
+ les mœurs les plus douces. Sa physionomie annonçait son âme.
+ Il avait le jugement assez droit, avec l'esprit le plus simple ;
+ c'est, je crois, pour cette raison qu'on le nommait Candide. Les
+ anciens domestiques de la maison soupçonnaient qu'il était fils
+ de la sœur de monsieur le baron et d'un bon et honnête
+ gentilhomme du voisinage, que cette demoiselle ne voulut jamais
+ épouser parce qu'il n'avait pu prouver que soixante et onze
+ quartiers, et que le reste de son arbre généalogique avait été
+ perdu par l'injure du temps.
+ }
+ \paragraph {
+ Monsieur le baron était un des plus puissants seigneurs de la
+ Westphalie, car son château avait une porte et des fenêtres. Sa
+ grande salle même était ornée d'une tapisserie. Tous les chiens
+ de ses basses-cours composaient une meute dans le besoin ; ses
+ palefreniers étaient ses piqueurs; le vicaire du village était
+ son grand-aumônier. Ils l'appelaient tous monseigneur, et ils
+ riaient quand il faisait des contes.
+ }
+}
diff --git a/lily/book.cc b/lily/book.cc
index 265632a..2a10389 100644
--- a/lily/book.cc
+++ b/lily/book.cc
@@ -154,7 +154,7 @@ Book::process (Output_def *default_paper
outputs = scm_cdr (outputs);
}
}
- else if (Text_interface::is_markup (scm_car (s))
+ else if (Text_interface::is_markup_list (scm_car (s))
|| unsmob_page_marker (scm_car (s)))
paper_book->add_score (scm_car (s));
else
diff --git a/lily/include/text-interface.hh b/lily/include/text-interface.hh
index 3f8685b..4a0fdb7 100644
--- a/lily/include/text-interface.hh
+++ b/lily/include/text-interface.hh
@@ -22,6 +22,7 @@ public:
DECLARE_SCHEME_CALLBACK (interpret_string, (SCM, SCM, SCM));
DECLARE_GROB_INTERFACE();
static bool is_markup (SCM);
+ static bool is_markup_list (SCM);
};
#endif /* TEXT_ITEM */
diff --git a/lily/lexer.ll b/lily/lexer.ll
index ec17fb3..71fb56b 100644
--- a/lily/lexer.ll
+++ b/lily/lexer.ll
@@ -62,6 +62,7 @@ void strip_trailing_white (string&);
void strip_leading_white (string&);
string lyric_fudge (string s);
SCM lookup_markup_command (string s);
+SCM lookup_markup_list_command (string s);
bool is_valid_version (string s);
@@ -516,7 +517,7 @@ BOM_UTF8 \357\273\277
{MARKUPCOMMAND} {
string str (YYText () + 1);
SCM s = lookup_markup_command (str);
-
+ SCM s2 = lookup_markup_list_command (str);
if (scm_is_pair (s) && scm_is_symbol (scm_cdr (s)) ) {
yylval.scm = scm_car(s);
SCM tag = scm_cdr(s);
@@ -545,6 +546,22 @@ BOM_UTF8 \357\273\277
ly_display_scm (s);
assert(false);
}
+ } else if (scm_is_pair (s2) && scm_is_symbol (scm_cdr (s2))) {
+ yylval.scm = scm_car(s2);
+ SCM tag = scm_cdr(s2);
+ if (tag == ly_symbol2scm("empty"))
+ return MARKUP_LIST_HEAD_EMPTY;
+ else if (tag == ly_symbol2scm ("markup-list0"))
+ return MARKUP_LIST_HEAD_LIST0;
+ else if (tag == ly_symbol2scm ("scheme0-markup-list1"))
+ return MARKUP_LIST_HEAD_SCM0_LIST1;
+ else if (tag == ly_symbol2scm ("scheme0-scheme1-markup-list2"))
+ return MARKUP_LIST_HEAD_SCM0_SCM1_LIST2;
+ else {
+ programming_error ("no parser tag defined for this markup signature");
+ ly_display_scm (s);
+ assert(false);
+ }
} else
return scan_escaped_word (str);
}
@@ -946,6 +963,13 @@ lookup_markup_command (string s)
return scm_call_1 (proc, ly_string2scm (s));
}
+SCM
+lookup_markup_list_command (string s)
+{
+ SCM proc = ly_lily_module_constant ("lookup-markup-list-command");
+ return scm_call_1 (proc, ly_string2scm (s));
+}
+
/* Shut up lexer warnings. */
#if YY_STACK_USED
diff --git a/lily/lily-lexer.cc b/lily/lily-lexer.cc
index 4eaa441..7b77d58 100644
--- a/lily/lily-lexer.cc
+++ b/lily/lily-lexer.cc
@@ -53,6 +53,7 @@ static Keyword_ent the_key_tab[]
{"lyricsto", LYRICSTO},
{"mark", MARK},
{"markup", MARKUP},
+ {"markuplines", MARKUPLINES},
{"midi", MIDI},
{"name", NAME},
{"new", NEWCONTEXT},
diff --git a/lily/paper-book.cc b/lily/paper-book.cc
index 84191b7..72648b6 100644
--- a/lily/paper-book.cc
+++ b/lily/paper-book.cc
@@ -331,6 +331,7 @@ Paper_book::get_system_specs ()
= scm_call_1 (ly_lily_module_constant ("layout-extract-page-properties"),
paper_->self_scm ());
+ SCM interpret_markup_list = ly_lily_module_constant ("interpret-markup-list");
SCM header = SCM_EOL;
for (SCM s = scm_reverse (scores_); scm_is_pair (s); s = scm_cdr (s))
{
@@ -384,24 +385,37 @@ Paper_book::get_system_specs ()
*/
}
}
- else if (Text_interface::is_markup (scm_car (s)))
+ else if (Text_interface::is_markup_list (scm_car (s)))
{
- SCM t = Text_interface::interpret_markup (paper_->self_scm (),
- page_properties,
- scm_car (s));
-
- // TODO: init props
- Prob *ps = make_paper_system (SCM_EOL);
- ps->set_property ("page-break-permission", ly_symbol2scm ("allow"));
- ps->set_property ("page-turn-permission", ly_symbol2scm ("allow"));
-
- paper_system_set_stencil (ps, *unsmob_stencil (t));
- ps->set_property ("is-title", SCM_BOOL_T);
- system_specs = scm_cons (ps->self_scm (), system_specs);
- ps->unprotect ();
-
- // FIXME: figure out penalty.
- //set_system_penalty (ps, scores_[i].header_);
+ SCM texts = scm_call_3 (interpret_markup_list,
+ paper_->self_scm (),
+ page_properties,
+ scm_car (s));
+ for (SCM list = texts ; scm_is_pair (list) ; list = scm_cdr (list))
+ {
+ SCM t = scm_car (list);
+ // TODO: init props
+ Prob *ps = make_paper_system (SCM_EOL);
+ ps->set_property ("page-break-permission", ly_symbol2scm ("allow"));
+ ps->set_property ("page-turn-permission", ly_symbol2scm ("allow"));
+
+ paper_system_set_stencil (ps, *unsmob_stencil (t));
+ ps->set_property ("is-title", SCM_BOOL_T);
+ if (scm_is_pair (scm_cdr (list)))
+ {
+ /* If an other markup is following, set this markup
+ * next padding and next space to 0, so that baseline-skip
+ * only should be taken into account for lines vertical
+ * spacing. */
+ ps->set_property ("next-padding", scm_double2num (0.0));
+ ps->set_property ("next-space", scm_double2num (0.0));
+ }
+ system_specs = scm_cons (ps->self_scm (), system_specs);
+ ps->unprotect ();
+
+ // FIXME: figure out penalty.
+ //set_system_penalty (ps, scores_[i].header_);
+ }
}
else
assert (0);
diff --git a/lily/parser.yy b/lily/parser.yy
index 18668de..7ded9b7 100644
--- a/lily/parser.yy
+++ b/lily/parser.yy
@@ -182,6 +182,7 @@ void set_music_properties (Music *p, SCM
%token LYRICSTO "\\lyricsto"
%token MARK "\\mark"
%token MARKUP "\\markup"
+%token MARKUPLINES "\\markuplines"
%token MIDI "\\midi"
%token NAME "\\name"
%token NOTEMODE "\\notemode"
@@ -281,6 +282,10 @@ If we give names, Bison complains.
%token <scm> MARKUP_HEAD_SCM0_SCM1_MARKUP2
%token <scm> MARKUP_HEAD_SCM0_MARKUP1_MARKUP2
%token <scm> MARKUP_HEAD_SCM0_SCM1_SCM2
+%token <scm> MARKUP_LIST_HEAD_EMPTY
+%token <scm> MARKUP_LIST_HEAD_LIST0
+%token <scm> MARKUP_LIST_HEAD_SCM0_LIST1
+%token <scm> MARKUP_LIST_HEAD_SCM0_SCM1_LIST2
%token <scm> MARKUP_IDENTIFIER
%token <scm> MUSIC_FUNCTION
%token <scm> MUSIC_IDENTIFIER
@@ -373,6 +378,7 @@ If we give names, Bison complains.
%type <scm> figure_spec
%type <scm> fraction
%type <scm> full_markup
+%type <scm> full_markup_list
%type <scm> function_scm_argument
%type <scm> function_arglist
%type <scm> function_arglist_music_last
@@ -387,6 +393,7 @@ If we give names, Bison complains.
%type <scm> markup_braced_list
%type <scm> markup_braced_list_body
%type <scm> markup_composed_list
+%type <scm> markup_command_list
%type <scm> markup_head_1_item
%type <scm> markup_head_1_list
%type <scm> markup_list
@@ -479,6 +486,10 @@ toplevel_expression:
}
| full_markup {
SCM proc = PARSER->lexer_->lookup_identifier ("toplevel-text-handler");
+ scm_call_2 (proc, PARSER->self_scm (), scm_list_1 ($1));
+ }
+ | full_markup_list {
+ SCM proc = PARSER->lexer_->lookup_identifier ("toplevel-text-handler");
scm_call_2 (proc, PARSER->self_scm (), $1);
}
| output_def {
@@ -664,6 +675,10 @@ book_body:
}
| book_body full_markup {
SCM proc = PARSER->lexer_->lookup_identifier ("book-text-handler");
+ scm_call_2 (proc, $$->self_scm (), scm_list_1 ($2));
+ }
+ | book_body full_markup_list {
+ SCM proc = PARSER->lexer_->lookup_identifier ("book-text-handler");
scm_call_2 (proc, $$->self_scm (), $2);
}
| book_body lilypond_header {
@@ -2186,6 +2201,15 @@ lyric_markup:
}
;
+full_markup_list:
+ MARKUPLINES
+ { PARSER->lexer_->push_markup_state (); }
+ markup_list {
+ $$ = $3;
+ PARSER->lexer_->pop_state ();
+ }
+ ;
+
full_markup:
MARKUP_IDENTIFIER {
$$ = $1;
@@ -2217,6 +2241,9 @@ markup_list:
| markup_braced_list {
$$ = $1;
}
+ | markup_command_list {
+ $$ = scm_list_1 ($1);
+ }
;
markup_composed_list:
@@ -2242,6 +2269,21 @@ markup_braced_list_body:
}
;
+markup_command_list:
+ MARKUP_LIST_HEAD_EMPTY {
+ $$ = scm_list_1 ($1);
+ }
+ | MARKUP_LIST_HEAD_LIST0 markup_list {
+ $$ = scm_list_2 ($1, $2);
+ }
+ | MARKUP_LIST_HEAD_SCM0_LIST1 embedded_scm markup_list {
+ $$ = scm_list_3 ($1, $2, $3);
+ }
+ | MARKUP_LIST_HEAD_SCM0_SCM1_LIST2 embedded_scm embedded_scm markup_list {
+ $$ = scm_list_4 ($1, $2, $3, $4);
+ }
+ ;
+
markup_head_1_item:
MARKUP_HEAD_MARKUP0 {
$$ = scm_list_1 ($1);
diff --git a/lily/text-interface.cc b/lily/text-interface.cc
index 55e7bb7..0c514a3 100644
--- a/lily/text-interface.cc
+++ b/lily/text-interface.cc
@@ -96,6 +96,14 @@ Text_interface::is_markup (SCM x)
ly_symbol2scm ("markup-signature"))));
}
+bool
+Text_interface::is_markup_list (SCM x)
+{
+ SCM music_list_p = ly_lily_module_constant ("markup-list?");
+ return scm_is_true (scm_call_1 (music_list_p, x));
+}
+
+
ADD_INTERFACE (Text_interface,
"A scheme markup text, see @usermanref{Text markup} and "
"@usermanref{New markup command definition}. "
diff --git a/ly/markup-init.ly b/ly/markup-init.ly
index c40bd88..49c155c 100644
--- a/ly/markup-init.ly
+++ b/ly/markup-init.ly
@@ -85,3 +85,36 @@ or:
,(symbol->string make-markup-name)
(list ,@signature)
args))))))
+
+#(defmacro-public define-markup-list-command (command-and-args signature . body)
+ "Same as `define-markup-command', but defines a command that, when interpreted,
+returns a list of stencils, instead of a single one."
+ (let* ((command (if (pair? command-and-args)
+ (car command-and-args)
+ command-and-args))
+ (command-name (string->symbol (format #f "~a-markup-list" command)))
+ (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
+ `(begin
+ ;; define the COMMAND-markup-list procedure in toplevel module
+ ,(if (pair? command-and-args)
+ ;; 1/ (define (COMMAND-markup-list layout props arg1 arg2 ...)
+ ;; ..command body))
+ `(define-public-toplevel (,command-name ,@(cdr command-and-args))
+ ,@body)
+ ;; 2/ (define (COMMAND-markup-list . args) (apply function args))
+ (let ((args (gensym "args"))
+ (command (car body)))
+ `(define-public-toplevel (,command-name . ,args)
+ (apply ,command ,args))))
+ (let ((command-proc (toplevel-module-ref ',command-name)))
+ ;; register its command signature
+ (set! (markup-command-signature command-proc)
+ (list ,@signature))
+ ;; it's a markup-list command:
+ (set-object-property! command-proc 'markup-list-command #t)
+ ;; define the make-COMMAND-markup-list procedure in the toplevel module
+ (define-public-toplevel (,make-markup-name . args)
+ (list (make-markup command-proc
+ ,(symbol->string make-markup-name)
+ (list ,@signature)
+ args)))))))
diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm
index d1f5dd0..035a469 100644
--- a/scm/define-markup-commands.scm
+++ b/scm/define-markup-commands.scm
@@ -346,9 +346,7 @@ grestore
The markups are spaced or flushed to fill the entire line.
If there are no arguments, return an empty stencil."
- (let* ((orig-stencils
- (map (lambda (x) (interpret-markup layout props x))
- markups))
+ (let* ((orig-stencils (interpret-markup-list layout props markups))
(stencils
(map (lambda (stc)
(if (ly:stencil-empty? stc)
@@ -404,7 +402,7 @@ If there are no arguments, return an emp
"Put @var{args} in a horizontal line. The property @code{word-space}
determines the space between each markup in @var{args}."
(let*
- ((stencils (map (lambda (m) (interpret-markup layout props m)) args))
+ ((stencils (interpret-markup-list layout props args))
(space (chain-assoc-get 'word-space props))
(text-dir (chain-assoc-get 'text-direction props RIGHT))
)
@@ -438,7 +436,9 @@ equivalent to @code{\"fi\"}."
(interpret-markup layout
(prepend-alist-chain 'word-space 0 props)
- (make-line-markup (concat-string-args args))))
+ (make-line-markup (if (markup-command-list? args)
+ args
+ (concat-string-args args)))))
(define (wordwrap-stencils stencils
justify base-space line-width text-dir)
@@ -520,32 +520,28 @@ equivalent to @code{\"fi\"}."
(define (wordwrap-markups layout props args justify)
(let*
- ((baseline-skip (chain-assoc-get 'baseline-skip props))
- (prop-line-width (chain-assoc-get 'line-width props #f))
+ ((prop-line-width (chain-assoc-get 'line-width props #f))
(line-width (if prop-line-width prop-line-width
(ly:output-def-lookup layout 'line-width)))
(word-space (chain-assoc-get 'word-space props))
- (text-dir (chain-assoc-get 'text-direction props RIGHT))
- (lines (wordwrap-stencils
- (remove ly:stencil-empty?
- (map (lambda (m) (interpret-markup layout props m)) args))
- justify word-space line-width
- text-dir)
- ))
-
- (stack-lines DOWN 0.0 baseline-skip lines)))
+ (text-dir (chain-assoc-get 'text-direction props RIGHT)))
+ (wordwrap-stencils (remove ly:stencil-empty?
+ (interpret-markup-list layout props args))
+ justify word-space line-width
+ text-dir)))
(define-builtin-markup-command (justify layout props args) (markup-list?)
"Like wordwrap, but with lines stretched to justify the margins.
Use @code{\\override #'(line-width . @var{X})} to set the line width;
@[EMAIL PROTECTED] the number of staff spaces."
- (wordwrap-markups layout props args #t))
+ (stack-lines DOWN 0.0 (chain-assoc-get 'baseline-skip props)
+ (wordwrap-markups layout props args #t)))
(define-builtin-markup-command (wordwrap layout props args) (markup-list?)
"Simple wordwrap. Use @code{\\override #'(line-width . @var{X})} to set
the line width, where @var{X} is the number of staff spaces."
-
- (wordwrap-markups layout props args #f))
+ (stack-lines DOWN 0.0 (chain-assoc-get 'baseline-skip props)
+ (wordwrap-markups layout props args #f)))
(define (wordwrap-string layout props justify arg)
(let*
@@ -623,7 +619,7 @@ the line width, where @var{X} is the num
@code{baseline-skip} determines the space between each markup in @var{args}."
(let*
- ((arg-stencils (map (lambda (m) (interpret-markup layout props m)) args))
+ ((arg-stencils (interpret-markup-list layout props args))
(skip (chain-assoc-get 'baseline-skip props)))
@@ -640,11 +636,11 @@ of the @code{#'direction} layout propert
(if (number? dir) dir -1)
0.0
(chain-assoc-get 'baseline-skip props)
- (map (lambda (x) (interpret-markup layout props x)) args))))
+ (interpret-markup-list layout props args))))
(define-builtin-markup-command (center-align layout props args) (markup-list?)
"Put @code{args} in a centered column."
- (let* ((mols (map (lambda (x) (interpret-markup layout props x)) args))
+ (let* ((mols (interpret-markup-list layout props args))
(cmols (map (lambda (x) (ly:stencil-aligned-to x X CENTER)) mols)))
(stack-lines -1 0.0 (chain-assoc-get 'baseline-skip props) cmols)))
@@ -1490,3 +1486,40 @@ when @var{label} is not found."
(markup #:concat (#:hspace gap page-markup)))))))
x-ext
y-ext)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Markup list commands
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (space-lines baseline-skip lines)
+ (map (lambda (line)
+ (stack-lines DOWN 0.0 baseline-skip
+ (list (ly:make-stencil "" (cons 0 0) (cons 0 0))
+ line)))
+ lines))
+
+(define-builtin-markup-list-command (justified-lines layout props args) (markup-list?)
+ "Like @code{\\justify}, but return a list of lines instead of a single markup.
+Use @code{\\override #'(line-width . @var{X})} to set the line width;
[EMAIL PROTECTED]@tie{}is the number of staff spaces."
+ (space-lines (chain-assoc-get 'baseline-skip props)
+ (wordwrap-markups layout props args #t)))
+
+(define-builtin-markup-list-command (wordwrap-lines layout props args) (markup-list?)
+ "Like @code{\\wordwrap}, but return a list of lines instead of a single markup.
+Use @code{\\override #'(line-width . @var{X})} to set the line width,
+where @var{X} is the number of staff spaces."
+ (space-lines (chain-assoc-get 'baseline-skip props)
+ (wordwrap-markups layout props args #f)))
+
+(define-builtin-markup-list-command (column-lines layout props args) (markup-list?)
+ "Like @code{\\column}, but return a list of lines instead of a single markup.
[EMAIL PROTECTED] determines the space between each markup in @var{args}."
+ (space-lines (chain-assoc-get 'baseline-skip props)
+ (interpret-markup-list layout props args)))
+
+(define-builtin-markup-list-command (override-lines layout props new-prop args)
+ (pair? markup-list?)
+ "Like @code{\\override}, for markup lists."
+ (interpret-markup-list layout (cons (list new-prop) props) args))
diff --git a/scm/document-markup.scm b/scm/document-markup.scm
index 27d1229..4d8feb1 100644
--- a/scm/document-markup.scm
+++ b/scm/document-markup.scm
@@ -8,7 +8,7 @@
(define (doc-markup-function func)
(let* ((doc-str (procedure-documentation func))
(f-name (symbol->string (procedure-name func)))
- (c-name (regexp-substitute/global #f "-markup$" f-name 'pre "" 'post))
+ (c-name (regexp-substitute/global #f "-markup(-list)?$" f-name 'pre "" 'post))
(sig (object-property func 'markup-signature))
(arg-names (let ((arg-list (cadr (procedure-source func))))
(if (list? arg-list)
@@ -43,6 +43,12 @@
(map doc-markup-function
(sort markup-function-list markup-function<?)))
+ "[EMAIL PROTECTED] table"
+ "[EMAIL PROTECTED] @asis"
+ (apply string-append
+
+ (map doc-markup-function
+ (sort markup-list-function-list markup-function<?)))
"[EMAIL PROTECTED] table"))
(define (markup-doc-node)
diff --git a/scm/markup.scm b/scm/markup.scm
index f1d0863..70baeaa 100644
--- a/scm/markup.scm
+++ b/scm/markup.scm
@@ -80,6 +80,36 @@ Syntax:
(let ((sig (list ,@signature)))
(make-markup ,command-name ,(symbol->string make-markup-name) sig args))))))
+(define-macro (define-builtin-markup-list-command command-and-args signature . body)
+ "Same as `define-builtin-markup-command, but defines a command that, when
+interpreted, returns a list of stencils instead os a single one"
+ (let* ((command (if (pair? command-and-args) (car command-and-args) command-and-args))
+ (args (if (pair? command-and-args) (cdr command-and-args) '()))
+ (command-name (string->symbol (format #f "~a-markup-list" command)))
+ (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
+ `(begin
+ ;; define the COMMAND-markup-list function
+ ,(if (pair? args)
+ `(define-public (,command-name ,@args)
+ ,@body)
+ (let ((args (gensym "args"))
+ (markup-command (car body)))
+ `(define-public (,command-name . ,args)
+ ,(format #f "Copy of the ~a command." markup-command)
+ (apply ,markup-command ,args))))
+ (set! (markup-command-signature ,command-name) (list ,@signature))
+ ;; add the command to markup-list-function-list, for markup documentation
+ (if (not (member ,command-name markup-list-function-list))
+ (set! markup-list-function-list (cons ,command-name
+ markup-list-function-list)))
+ ;; it's a markup-list command:
+ (set-object-property! ,command-name 'markup-list-command #t)
+ ;; define the make-COMMAND-markup-list function
+ (define-public (,make-markup-name . args)
+ (let ((sig (list ,@signature)))
+ (list (make-markup ,command-name
+ ,(symbol->string make-markup-name) sig args)))))))
+
(define-public (make-markup markup-function make-name signature args)
" Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
@@ -261,6 +291,7 @@ Use `markup*' in a \\notemode context."
;; For documentation purposes
(define-public markup-function-list (list))
+(define-public markup-list-function-list (list))
(define-public (markup-signature-to-keyword sig)
" (A B C) -> a0-b1-c2 "
@@ -282,14 +313,24 @@ Use `markup*' in a \\notemode context."
sig)
"-"))))
-(define-public (lookup-markup-command code)
+(define (lookup-markup-command-aux symbol)
(let ((proc (catch 'misc-error
(lambda ()
- (module-ref (current-module)
- (string->symbol (format #f "~a-markup" code))))
+ (module-ref (current-module) symbol))
(lambda (key . args) #f))))
- (and (procedure? proc)
- (cons proc (markup-command-keyword proc)))))
+ (and (procedure? proc) proc)))
+
+(define-public (lookup-markup-command code)
+ (let ((proc (lookup-markup-command-aux
+ (string->symbol (format #f "~a-markup" code)))))
+ (and proc (markup-function? proc)
+ (cons proc (markup-command-keyword proc)))))
+
+(define-public (lookup-markup-list-command code)
+ (let ((proc (lookup-markup-command-aux
+ (string->symbol (format #f "~a-markup-list" code)))))
+ (and proc (markup-list-function? proc)
+ (cons proc (markup-command-keyword proc)))))
;;;;;;;;;;;;;;;;;;;;;;
;;; used in parser.yy to map a list of markup commands on markup arguments
@@ -313,13 +354,25 @@ eg: ((italic) (raise 4) (bold)), maps th
;;; markup type predicates
(define (markup-function? x)
- (not (not (markup-command-signature x))))
+ (and (markup-command-signature x)
+ (not (object-property x 'markup-list-command))))
+
+(define (markup-list-function? x)
+ (and (markup-command-signature x)
+ (object-property x 'markup-list-command)))
+
+(define-public (markup-command-list? x)
+ "Determine if `x' is a markup command list, ie. a list composed of
+a markup list function and its arguments."
+ (and (pair? x) (markup-list-function? (car x))))
(define-public (markup-list? arg)
+ "Return a true value if `x' is a list of markups or markup command lists."
(define (markup-list-inner? lst)
(or (null? lst)
- (and (markup? (car lst)) (markup-list-inner? (cdr lst)))))
- (and (list? arg) (markup-list-inner? arg)))
+ (and (or (markup? (car lst)) (markup-command-list? (car lst)))
+ (markup-list-inner? (cdr lst)))))
+ (not (not (and (list? arg) (markup-list-inner? arg)))))
(define (markup-argument-list? signature arguments)
"Typecheck argument list."
@@ -391,6 +444,18 @@ Uncovered - cheap-markup? is used."
(define-public interpret-markup ly:text-interface::interpret-markup)
+
+(define-public (interpret-markup-list layout props markup-list)
+ (let ((stencils (list)))
+ (for-each (lambda (m)
+ (set! stencils
+ (if (markup-command-list? m)
+ (append! (reverse! (apply (car m) layout props (cdr m)))
+ stencils)
+ (cons (interpret-markup layout props m) stencils))))
+ markup-list)
+ (reverse! stencils)))
+
(define-public (prepend-alist-chain key val chain)
(cons (acons key val (car chain)) (cdr chain)))
_______________________________________________
lilypond-devel mailing list
[email protected]
http://lists.gnu.org/mailman/listinfo/lilypond-devel
