;;;; 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)))))