LilyPond-Ruby 0.1.1 → 0.1.2

data/share/lilypond/2.24.1/scm/lily/markup-macros.scm

@@ -0,0 +1,493 @@
+;;;; This file is part of LilyPond, the GNU music typesetter.
+;;;;
+;;;; Copyright (C) 2003--2022 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;;
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
+
+"
+Internally markup is stored as lists, whose head is a function.
+
+  (FUNCTION ARG1 ARG2 ... )
+
+When the markup is formatted, then FUNCTION is called as follows
+
+  (FUNCTION GROB PROPS ARG1 ARG2 ... )
+
+GROB is the current grob, PROPS is a list of alists, and ARG1.. are
+the rest of the arguments.
+
+The function should return a stencil (i.e., a formatted, ready to
+print object).
+
+
+To add a markup command, use the define-markup-command utility.
+
+  (define-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
+    \"my command usage and description\"
+    ...function body...)
+
+The command is now available in markup mode, e.g.
+
+  \\markup { .... \\MYCOMMAND #1 argument ... }
+
+" ; "
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; markup definer utilities
+
+;; For documentation purposes
+;; markup function -> categories
+(define-public markup-function-category (make-object-property))
+;; markup function -> used properties
+(define-public markup-function-properties (make-object-property))
+;; markup function -> procedure used to convert markup into string (lossily)
+(define-public markup-function-as-string-method (make-object-property))
+
+(use-modules (ice-9 optargs))
+
+(defmacro-public define-markup-command (command-and-args . definition)
+  "Define a markup function.  Syntax:
+
+@example
+(define-markup-command (@var{command} layout props @var{arg1} @var{arg2} @dots{})
+                       (@var{type1?} @var{type2?} @dots{})
+                       [ #:properties ((@var{property1} @var{default1})
+                                       (@var{property2} @var{default2})
+                                       @dots{}) ]
+    [ #:category @var{category} ]
+    [ #:as-string @var{expression} ]
+    [ \"@var{doc-string}\" ]
+    @var{command-body})
+@end example
+
+This macro defines the markup function @code{@var{command}-markup}.
+When this function is applied as
+
+@example
+(@var{command}-@/markup layout props @var{arg1} @var{arg2} @dots{})
+@end example
+
+@noindent it executes @var{command-body}, a sequence of S-expression
+similar to the body of a @code{define} form.  The body should return a
+stencil.
+
+@var{type1?}, @var{type2?}, etc., are type predicates for the
+arguments @var{arg1}, @var{arg2}, etc.  @var{doc-string} is an
+optional description of the command; this can be retrieved using
+@code{procedure-documentation} on @code{@var{command}-markup}, and is
+used for built-in markup commands to generate the documentation.
+
+Moreover, this macro defines a helper function
+@code{make-@var{command}-markup}, which can be applied as
+
+@example
+(make-@var{command}-markup @var{arg1} @var{arg2} @dots{})
+@end example
+
+@noindent
+(without @code{layout} and @code{props} arguments).  This yields a
+markup.  Interpreting it, using @code{(interpret-markup @var{markup}
+layout props)}, invokes @code{@var{command}-markup} as above.
+
+The specified properties are available as @code{let}-bound variables
+in the command body, using the respective default value as fallback in
+case the property is not found in @code{props}, or @code{#f} if no
+default was given.  @code{props} itself is left unchanged: if you want
+defaults specified in that manner passed down into other markup
+functions, you need to adjust @code{props} yourself.
+
+If the @code{as-string} named argument is given, it should be an
+expression, which is evaluated by @code{markup->string} when lossily
+converting markups to strings.  The expression can use all variables
+available in the main body, namely @code{layout}, @code{props}, the
+arguments, and the properties.  However, in many cases @code{layout}
+will be @code{#f} because such an output definition is not
+available (such as for MIDI output).  This case must be accounted for.
+The expression can recursively call @code{markup->string}, passing it
+@code{#:layout layout #:props props}.
+
+The autogenerated documentation makes use of some optional
+specifications that are otherwise ignored:
+
+@itemize
+@item
+@var{category} is either a symbol or a symbol list specifying the
+categories for this markup command in the docs.
+
+@item
+As an element of the @q{properties} list, you may directly use
+@code{@var{command}-markup} instead of a @code{(@var{property
+default})} to indicate that this markup command is called by the newly
+defined command, adding its properties to the documented properties of
+the new command.  There is no protection against circular definitions.
+@end itemize
+
+Some object properties are attached to the resulting
+@code{@var{command}-markup} function according to the parameters of
+the definition: @code{markup-command-signature},
+@code{markup-function-category}, @code{markup-function-properties}.
+"
+  ;; DOCME/obscure
+  (let* ((command (if (pair? command-and-args)
+                      (car command-and-args)
+                      command-and-args))
+         (args (and (pair? command-and-args) (cdr command-and-args))))
+    (if args
+        `(define-markup-command-internal
+           ',command (markup-lambda ,args ,@definition) #f)
+        `(define-markup-command-internal
+           ',command ,@definition #f))))
+
+(define-public (markup-lambda-worker command signature properties category as-string)
+  (set! (markup-command-signature command) signature)
+  ;; Register the new function, for markup documentation
+  (set! (markup-function-category command) category)
+  ;; Used properties, for markup documentation
+  (set! (markup-function-properties command) properties)
+  ;; For markup->string
+  (set! (markup-function-as-string-method command) as-string)
+  command)
+
+(defmacro*-public markup-lambda
+  (args signature
+        #:key (category '()) (properties '()) (as-string #f)
+        #:rest body)
+  "Defines and returns an anonymous markup command.  Other than not
+registering the markup command, this is identical to
+@code{define-markup-command}."
+  ;; In Guile's optional argument handling, named arguments
+  ;; remain in the "rest" argument.
+  (while (and (pair? body) (keyword? (car body)))
+         (set! body (cddr body)))
+  ;; define the COMMAND-markup function
+  (let* ((documentation
+          (format #f "~a\n~a" (cddr args)
+                  (if (string? (car body)) (car body) "")))
+         ;; We are going to wrap everything in a let.  If there
+         ;; is a docstring, we have to move it out or it will not
+         ;; be recognized.
+         (real-body (if (or (not (string? (car body)))
+                            (null? (cdr body)))
+                        body (cdr body)))
+         (let-bindings
+          (map (lambda (prop-spec)
+                 (let ((prop (car prop-spec))
+                       (default-value (and (pair? (cdr prop-spec))
+                                           (cadr prop-spec)))
+                       (props (cadr args)))
+                   `(,prop (chain-assoc-get ',prop ,props ,default-value))))
+               (filter pair? properties)))
+         (result
+          `(lambda ,args
+             ,documentation
+             (let ,let-bindings
+               ,@real-body)))
+         (wrapped-method
+          (and as-string
+               `(lambda ,args
+                  (let ,let-bindings
+                    ,as-string)))))
+    `(markup-lambda-worker
+      ,result
+      (list ,@signature)
+      (list ,@(map (lambda (prop-spec)
+                     (cond ((symbol? prop-spec)
+                            prop-spec)
+                           ((not (null? (cdr prop-spec)))
+                            `(list ',(car prop-spec) ,(cadr prop-spec)))
+                           (else
+                            `(list ',(car prop-spec)))))
+                   properties))
+      ',category
+      ,wrapped-method)))
+
+(defmacro-public define-markup-list-command
+  (command-and-args . definition)
+  "Same as @code{define-markup-command}, but defines a command that,
+when interpreted, returns a list of stencils instead of a single one.
+
+Markup list commands are recognizable programmatically by having the
+@code{markup-list-function?}  object property to @code{#t}."
+  (let* ((command (if (pair? command-and-args)
+                      (car command-and-args)
+                      command-and-args))
+         (args (and (pair? command-and-args) (cdr command-and-args))))
+    (if args
+        `(define-markup-command-internal
+           ',command (markup-list-lambda ,args ,@definition) #t)
+        `(define-markup-command-internal
+           ',command ,@definition #t))))
+
+(define-public (define-markup-command-internal command definition is-list)
+  (let* ((suffix (if is-list "-list" ""))
+         (command-name (string->symbol (format #f "~a-markup~a" command suffix)))
+         (make-markup-name (string->symbol (format #f "make-~a-markup~a" command suffix))))
+    (if (not (procedure-name definition))
+        (set-procedure-property! definition 'name command-name))
+    (module-define! (current-module) command-name definition)
+    (module-define! (current-module) make-markup-name
+                    (lambda args
+                      (if is-list
+                          (list (make-markup definition make-markup-name args))
+                          (make-markup definition make-markup-name args))))
+    (module-export! (current-module)
+                    (list command-name make-markup-name))))
+
+(define-public (markup-lambda-listify fun)
+  (set! (markup-list-function? fun) #t)
+  fun)
+
+(defmacro*-public markup-list-lambda
+  (arg signature #:key (properties '()) #:rest body)
+  "Same as @code{markup-lambda} but defines a markup list command
+that, when interpreted, returns a list of stencils instead of a single
+one."
+  (list 'markup-lambda-listify (cons* 'markup-lambda arg signature body)))
+
+;;;;;;;;;;;;;;;
+;;; Utilities for storing and accessing markup commands signature
+;;; Examples:
+;;;
+;;; (set! (markup-command-signature raise-markup) (list number? markup?))
+;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
+;;;
+;;; (markup-command-signature raise-markup)
+;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
+;;;
+
+(define-public markup-command-signature (make-object-property))
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; markup type predicates
+
+(define-public (markup-function? x)
+  (and (markup-command-signature x)
+       (not (markup-list-function? x))))
+
+(define-public markup-list-function? (make-object-property))
+
+(define-public (markup-command-list? x)
+  "Check whether @var{x} is a markup command list, i.e., 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 @var{x} is a list of markups or markup command
+lists."
+  (define (markup-list-inner? lst)
+    (or (null? lst)
+        (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."
+  (if (and (pair? signature) (pair? arguments))
+      (and ((car signature) (car arguments))
+           (markup-argument-list? (cdr signature) (cdr arguments)))
+      (and (null? signature) (null? arguments))))
+
+
+(define (markup-argument-list-error signature arguments number)
+  "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
+#f is no error found.
+"
+  (if (and (pair? signature) (pair? arguments))
+      (if (not ((car signature) (car arguments)))
+          (list number (type-name (car signature)) (car arguments))
+          (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
+      #f))
+
+;;
+;; full recursive typecheck.
+;;
+(define (markup-typecheck? arg)
+  (or (string? arg)
+      (and (pair? arg)
+           (markup-function? (car arg))
+           (markup-argument-list? (markup-command-signature (car arg))
+                                  (cdr arg)))))
+
+;;
+;;
+;;
+;;
+(define (markup-thrower-typecheck arg)
+  "typecheck, and throw an error when something amiss.
+
+Uncovered - cheap-markup? is used."
+
+  (cond ((string? arg) #t)
+        ((not (pair? arg))
+         (throw 'markup-format "Not a pair" arg))
+        ((not (markup-function? (car arg)))
+         (throw 'markup-format "Not a markup function " (car arg)))
+        ((not (markup-argument-list? (markup-command-signature (car arg))
+                                     (cdr arg)))
+         (throw 'markup-format "Arguments failed  typecheck for " arg)))
+  #t)
+
+;;
+;; good enough if you only  use make-XXX-markup functions.
+;;
+(define (cheap-markup? x)
+  (or (string? x)
+      (and (pair? x)
+           (markup-function? (car x)))))
+
+;;
+;; replace by markup-thrower-typecheck for more detailed diagnostics.
+;;
+(define-public markup? cheap-markup?)
+
+(define (make-markup markup-function make-name args)
+  " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
+against signature, reporting MAKE-NAME as the user-invoked function.
+"
+  (let* ((arglen (length args))
+         (signature (or (markup-command-signature markup-function)
+                        (ly:error (G_ "~A: Not a markup (list) function: ~S")
+                                  make-name markup-function)))
+         (siglen (length signature))
+         (error-msg (if (and (> siglen 0) (> arglen 0))
+                        (markup-argument-list-error signature args 1)
+                        #f)))
+    (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
+        (ly:error (G_ "~A: Wrong number of arguments.  Expect: ~A, found ~A: ~S")
+                  make-name siglen arglen args))
+    (if error-msg
+        (ly:error
+         (G_ "~A: Invalid argument in position ~A.  Expect: ~A, found: ~S.")
+         make-name (car error-msg) (cadr error-msg)(caddr error-msg))
+        (cons markup-function args))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; markup constructors
+;;; lilypond-like syntax for markup construction in scheme.
+
+(use-modules (ice-9 receive))
+
+(define (compile-all-markup-expressions expr)
+  "Return a list of canonical markups expressions, e.g.:
+  (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23)
+  ===>
+  ((make-COMMAND1-markup arg11 arg12)
+   (make-COMMAND2-markup arg21 arg22 arg23) ...)"
+  (do ((rest expr rest)
+       (markps '() markps))
+      ((null? rest) (reverse markps))
+    (receive (m r) (compile-markup-expression rest)
+      (set! markps (cons m markps))
+      (set! rest r))))
+
+(define (keyword->make-markup key)
+  "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol."
+  (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup")))
+
+(define (compile-markup-expression expr)
+  "Return two values: the first complete canonical markup expression
+   found in `expr', e.g. (make-COMMAND-markup arg1 arg2 ...),
+   and the rest expression."
+  (cond ((and (pair? expr)
+              (keyword? (car expr)))
+         ;; expr === (#:COMMAND arg1 ...)
+         (let ((command (symbol->string (keyword->symbol (car expr)))))
+           (if (not (pair? (lookup-markup-command command)))
+               (ly:error (G_ "Not a markup command: ~A") command))
+           (let* ((sig (markup-command-signature
+                        (car (lookup-markup-command command))))
+                  (sig-len (length sig)))
+             (do ((i 0 (1+ i))
+                  (args '() args)
+                  (rest (cdr expr) rest))
+                 ((>= i sig-len)
+                  (values (cons (keyword->make-markup (car expr)) (reverse args)) rest))
+               (cond ((eqv? (list-ref sig i) markup-list?)
+                      ;; (car rest) is a markup list
+                      (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args))
+                      (set! rest (cdr rest)))
+                     (else
+                      ;; pick up one arg in `rest'
+                      (receive (a r) (compile-markup-arg rest)
+                        (set! args (cons a args))
+                        (set! rest r))))))))
+        ((and (pair? expr)
+              (pair? (car expr))
+              (keyword? (caar expr)))
+         ;; expr === ((#:COMMAND arg1 ...) ...)
+         (receive (m r) (compile-markup-expression (car expr))
+           (values m (cdr expr))))
+        ((and (pair? expr)
+              (string? (car expr))) ;; expr === ("string" ...)
+         (values `(make-simple-markup ,(car expr)) (cdr expr)))
+        (else
+         ;; expr === (symbol ...) or ((funcall ...) ...)
+         (values (car expr)
+                 (cdr expr)))))
+
+(define (compile-all-markup-args expr)
+  "Transform `expr' into markup arguments"
+  (do ((rest expr rest)
+       (args '() args))
+      ((null? rest) (reverse args))
+    (receive (a r) (compile-markup-arg rest)
+      (set! args (cons a args))
+      (set! rest r))))
+
+(define (compile-markup-arg expr)
+  "Return two values: the desired markup argument, and the rest arguments"
+  (cond ((null? expr)
+         ;; no more args
+         (values '() '()))
+        ((keyword? (car expr))
+         ;; expr === (#:COMMAND ...)
+         ;; ==> build and return the whole markup expression
+         (compile-markup-expression expr))
+        ((and (pair? (car expr))
+              (keyword? (caar expr)))
+         ;; expr === ((#:COMMAND ...) ...)
+         ;; ==> build and return the whole markup expression(s)
+         ;; found in (car expr)
+         (receive (markup-expr rest-expr) (compile-markup-expression (car expr))
+           (if (null? rest-expr)
+               (values markup-expr (cdr expr))
+               (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr))
+                       (cdr expr)))))
+        ((and (pair? (car expr))
+              (pair? (caar expr)))
+         ;; expr === (((foo ...) ...) ...)
+         (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
+        (else (values (car expr) (cdr expr)))))
+
+(define (lookup-markup-command-aux symbol)
+  "Look up procedure in the current module, or return @code{#f}."
+  (let ((proc (catch 'misc-error
+                     (lambda ()
+                       (module-ref (current-module) symbol))
+                     (lambda (key . args) #f))))
+    (and (procedure? proc) proc)))
+
+(define-public (lookup-markup-command code)
+  "Return @code{(@var{function} . @var{signature})} for a markup command
+   @var{code}, or return @code{#f}."
+  (let ((proc (lookup-markup-command-aux
+               (string->symbol (format #f "~a-markup" code)))))
+    (and proc (markup-function? proc)
+         (cons proc (markup-command-signature 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-signature proc)))))

data/share/lilypond/2.24.1/scm/lily/markup.scm

@@ -0,0 +1,126 @@
+;;;; This file is part of LilyPond, the GNU music typesetter.
+;;;;
+;;;; Copyright (C) 2003--2022 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;;
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
+
+(defmacro*-public markup (#:rest body)
+  "The @code{markup} macro provides a LilyPond-like syntax for building
+markups using Scheme keywords, replacing @code{\\@var{command}} with
+@code{#:@var{command}}.  For example, this:
+
+@example
+\\markup @{ foo
+          \\raise #0.2 \\hbracket \\bold bar
+          \\override #'(baseline-skip . 4)
+          \\bracket \\column @{ baz bazr bla @}
+@}
+@end example
+
+@noindent
+translates to this:
+
+@example
+(markup \"foo\"
+        #:raise 0.2 #:hbracket #:bold \"bar\"
+        #:override '(baseline-skip . 4)
+        #:bracket #:column (\"baz\" \"bazr\" \"bla\"))
+@end example
+"
+
+  (car (compile-all-markup-expressions `(#:line ,body))))
+
+;; utility
+
+(define (markup-join markups sep)
+  "Return line-markup of MARKUPS, joining them with markup SEP"
+  (if (pair? markups)
+      (make-line-markup (list-insert-separator markups sep))
+      empty-markup))
+
+
+(define-public interpret-markup ly:text-interface::interpret-markup)
+
+(define-public (interpret-markup-list layout props 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)
+  "Convenience to make a new alist chain from @var{chain} by
+prepending a binding of @var{key} to @var{val}.  This is similar to
+@code{acons}, for alist chains (lists of alists)."
+  `(((,key . ,val)) . ,chain))
+
+(define-public (stack-stencil-line space stencils)
+  "Adjoin a list of @var{stencils} along the x@tie{}axis, leaving
+@var{space} between the end of each stencil and the beginning of the
+following stencil.  Stencils with empty y@tie{}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
+
+(define-public (markup-default-to-string-method layout props . args)
+  "The default @code{markup->string} handler for markups, used when
+@code{markup->string} encounters a markup that has no special
+@code{as-string} expression defined.  This applies
+@code{markup->string} on all markup arguments and joins the results,
+separating them with spaces."
+  (string-join
+   ;; Don't add extra spaces for arguments not giving
+   ;; a representation.
+   (remove
+    string-null?
+    (map
+     (lambda (arg)
+       (markup->string arg #:layout layout #:props props))
+     args))
+   " "))
+
+(define*-public (markup->string m #:key (layout #f) (props '()))
+  "Convert a markup or markup list to an approximate string
+representation.  This is useful for, e.g., PDF metadata and MIDI
+markers.
+
+The optional named @var{layout} and @var{props} argument are an output
+definition and a property alist chain, like the ones that are used
+when interpreting markups."
+  (cond
+   ((string? m)
+    m)
+   ((pair? m)
+    (let ((first-elt (car m)))
+      (cond
+       ((or (markup-function? first-elt)
+            (markup-list-function? first-elt))
+        ;; m is a markup, or the application of a markup list command.
+        ;; Look up the as-string handler of a command.
+        (let ((handler (or (markup-function-as-string-method first-elt)
+                           markup-default-to-string-method)))
+          (apply handler layout props (cdr m))))
+       ((markup-list? m)
+        ;; A markup list that is not the result of a markup list
+        ;; command.  This must be a list of markups or markup lists.
+        ;; Join results by spaces.
+        (apply markup-default-to-string-method layout props m))
+       (else
+        ;; Can occur if one argument to a markup function is a
+        ;; list of anything.
+        ""))))
+   (else "")))