scm/new-markup.scm

   1 "
   2 Internally markup is stored as lists, whose head is a function.
   3
   4   (FUNCTION ARG1 ARG2 ... )
   5
   6 When the markup is formatted, then FUNCTION is called as follows
   7
   8   (FUNCTION GROB PROPS ARG1 ARG2 ... )
   9
  10 GROB is the current grob, PROPS is a list of alists, and ARG1.. are
  11 the rest of the arguments.
  12
  13 The function should return a molecule (i.e. a formatted, ready to
  14 print object).
  15
  16
  17
  18 To add a function,
  19
  20 1. It should be named  COMMAND-markup
  21
  22 2. It should have an object property set that describes it's
  23 signature. This is to allow the parser to figure out how many
  24 arguments to expect:
  25
  26   (set-object-property! COMMAND-markup  scm0-markup1)
  27
  28 (insert in the list below).
  29
  30 3. The command is now available in markup mode, e.g.
  31
  32
  33   \\markup { .... \\COMMAND #1 argument ... }
  34
  35
  36 BUGS:
  37
  38 At present, markup functions must be defined in this
  39 file. Implementing user-access for markup functions is an excercise
  40 for the reader.
  41
  42
  43
  44
  45 " ; "
  46
  47
  48 ;;;;;;;;;;;;;;;;;
  49 ;; TODO:
  50 ;; each markup function should have a doc string with
  51 ;; syntax, description and example.
  52 ;;
  53
  54 (define-public (simple-markup paper props . rest)
  55   "A simple text-string; @code{\\markup @{ foo @}} is equivalent with
  56 @code{\\markup @{ \\simple #\"foo\" @}}.
  57 "
  58
  59   (Text_item::interpret_markup paper props (car rest)))
  60
  61 (define-public (stack-molecule-line space molecules)
  62   (if (pair? molecules)
  63       (if (pair? (cdr molecules))
  64           (let* (
  65                  (tail (stack-molecule-line  space (cdr molecules)))
  66                  (head (car molecules))
  67                  (xoff (+ space (cdr (ly:molecule-get-extent head X))))
  68                  )
  69
  70             (ly:molecule-add
  71              head
  72              (ly:molecule-translate-axis tail xoff X))
  73           )
  74           (car molecules))
  75       '())
  76   )
  77
  78 (define-public (line-markup paper props . rest)
  79   "A horizontal line of markups. Syntax:
  80 \\line << MARKUPS >>
  81 "
  82
  83   (stack-molecule-line
  84    (cdr (chain-assoc 'word-space props))
  85    (map (lambda (x) (interpret-markup paper props x)) (car rest)))
  86   )
  87
  88
  89 (define-public (combine-markup paper props . rest)
  90   "Overstrike two markups."
  91   (ly:molecule-add
  92    (interpret-markup paper props (car rest))
  93    (interpret-markup paper props (cadr rest))))
  94
  95 (define (font-markup qualifier value)
  96   (lambda (paper props . rest)
  97     (interpret-markup paper (cons (cons `(,qualifier . ,value) (car props)) (cdr props)) (car rest))
  98
  99   ))
 100
 101
 102 (define-public (set-property-markup qualifier)
 103   (lambda (paper props . rest  )
 104     (interpret-markup paper
 105                       (cons (cons `(,qualifier . ,(car rest))
 106                                   (car props)) (cdr props))
 107                       (cadr rest))
 108     ))
 109
 110 (define-public (finger-markup paper props . rest)
 111   (interpret-markup paper
 112                     (cons (list '(font-size . -4)
 113                                 '(font-family . number))
 114                                 props)
 115                     (car rest)))
 116
 117 (define-public fontsize-markup (set-property-markup 'font-size))
 118 (define-public magnify-markup (set-property-markup 'font-magnification))
 119
 120 (define-public bold-markup
 121   (font-markup 'font-series 'bold))
 122 (define-public sans-markup
 123   (font-markup 'font-family 'sans))
 124 (define-public number-markup
 125   (font-markup 'font-family 'number))
 126 (define-public roman-markup
 127   (font-markup 'font-family 'roman))
 128
 129
 130 (define-public huge-markup
 131   (font-markup 'font-size 2))
 132 (define-public large-markup
 133   (font-markup 'font-size 1))
 134 (define-public normalsize-markup
 135   (font-markup 'font-size 0))
 136 (define-public small-markup
 137   (font-markup 'font-size -1))
 138 (define-public tiny-markup
 139   (font-markup 'font-size -2))
 140 (define-public teeny-markup
 141   (font-markup 'font-size -3))
 142 (define-public dynamic-markup
 143   (font-markup 'font-family 'dynamic))
 144 (define-public italic-markup
 145   (font-markup 'font-shape 'italic))
 146 (define-public typewriter-markup
 147   (font-markup 'font-family 'typewriter))
 148
 149
 150 ;; TODO: baseline-skip should come from the font.
 151 (define-public (column-markup paper props . rest)
 152   (stack-lines
 153    -1 0.0 (cdr (chain-assoc 'baseline-skip props))
 154    (map (lambda (x) (interpret-markup paper props x)) (car rest)))
 155   )
 156
 157 (define-public (dir-column-markup paper props . rest)
 158   "Make a column of args, going up or down, depending on the setting
 159 of the #'direction layout property."
 160
 161   (let*
 162       (
 163        (dir (cdr (chain-assoc 'direction props)))
 164        )
 165     (stack-lines
 166      (if (number? dir) dir -1)
 167      0.0 (cdr (chain-assoc 'baseline-skip props))
 168      (map (lambda (x) (interpret-markup paper props x)) (car rest)))
 169     ))
 170
 171 (define-public (center-markup paper props . rest)
 172   (let*
 173     (
 174      (mols (map (lambda (x) (interpret-markup paper props x)) (car rest)))
 175      (cmols (map (lambda (x) (ly:molecule-align-to! x X CENTER)) mols))
 176      )
 177
 178     (stack-lines
 179      -1 0.0 (cdr (chain-assoc 'baseline-skip props))
 180      mols)
 181     ))
 182
 183 (define-public (right-align-markup paper props . rest)
 184   (let* ((m (interpret-markup paper props (car rest))))
 185     (ly:molecule-align-to! m X RIGHT)
 186     m))
 187 (define-public (left-align-markup paper props . rest)
 188   (let* ((m (interpret-markup paper props (car rest))))
 189     (ly:molecule-align-to! m X LEFT)
 190     m))
 191 (define-public (halign-markup paper props . rest)
 192   "Set horizontal alignment. Syntax: halign A MARKUP. A=-1 is LEFT,
 193 A=1 is right, values in between vary alignment accordingly."
 194   (let* ((m (interpret-markup paper props (cadr rest))))
 195     (ly:molecule-align-to! m X (car rest))
 196     m))
 197
 198
 199
 200 (define-public (musicglyph-markup paper props . rest)
 201   (ly:find-glyph-by-name
 202    (ly:paper-get-font paper (cons '((font-name . ())
 203                                     (font-shape . *)
 204                                     (font-series . *)
 205                                     (font-family . music)) props))
 206    (car rest)))
 207
 208
 209 (define-public (lookup-markup paper props . rest)
 210   "Lookup a glyph by name."
 211   (ly:find-glyph-by-name
 212    (ly:paper-get-font paper  props)
 213    (car rest))
 214   )
 215
 216 (define-public (char-markup paper props . rest)
 217   "Syntax: \\char NUMBER. "
 218   (ly:get-glyph  (ly:paper-get-font paper props) (car rest))
 219   )
 220
 221 (define-public (raise-markup paper props  . rest)
 222   "Syntax: \\raise AMOUNT MARKUP. "
 223   (ly:molecule-translate-axis (interpret-markup
 224                                paper
 225                                props
 226                                (cadr rest))
 227                               (car rest) Y))
 228
 229 (define-public (fraction-markup paper props . rest)
 230   "Make a fraction of two markups.
 231
 232 Syntax: \\fraction MARKUP1 MARKUP2."
 233
 234   (let*
 235       ((m1 (interpret-markup paper props (car rest)))
 236        (m2 (interpret-markup paper props (cadr rest))))
 237
 238     (ly:molecule-align-to! m1 X CENTER)
 239     (ly:molecule-align-to! m2 X CENTER)
 240
 241     (let*
 242         ((x1 (ly:molecule-get-extent m1 X))
 243          (x2 (ly:molecule-get-extent m2 X))
 244          (line (ly:round-filled-box (interval-union x1 x2) '(-0.05 . 0.05) 0.0))
 245
 246          ;; should stack mols separately, to maintain LINE on baseline
 247          (stack (stack-lines -1 0.2 0.6 (list m1 line m2))))
 248
 249       (ly:molecule-align-to! stack Y CENTER)
 250       (ly:molecule-align-to! stack X LEFT)
 251       ;; should have EX dimension
 252       ;; empirical anyway
 253       (ly:molecule-translate-axis stack 0.75 Y)
 254       )))
 255
 256
 257 ;; TODO: better syntax.
 258
 259
 260 (use-modules (ice-9 optargs)
 261              (ice-9 regex))
 262
 263 (define-public log2
 264   (let ((divisor (log 2)))
 265     (lambda (z) (inexact->exact (/ (log z) divisor)))))
 266
 267 (define (parse-simple-duration duration-string)
 268   "Parse the `duration-string', eg ''4..'' or ''breve.'', and return a (log dots) list."
 269   (let ((match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)") duration-string)))
 270     (if (and match (string=? duration-string (match:substring match 0)))
 271         (let ((len  (match:substring match 1))
 272               (dots (match:substring match 2)))
 273           (list (cond ((string=? len "breve")  -1)
 274                       ((string=? len "longa")  -2)
 275                       ((string=? len "maxima") -3)
 276                       (else (log2 (string->number len))))
 277                 (if dots (string-length dots) 0)))
 278         (error "This is not a valid duration string:" duration-string))))
 279
 280
 281 (define-public (note-markup paper props . rest)
 282   "This produces a note with a stem pointing in @var{dir} direction, with
 283 the @var{duration} for the note head type and augmentation dots. For
 284 example, @code{\note #\"4.\" #-0.75} creates a dotted quarter note, with
 285 a shortened down stem."
 286
 287   (let*
 288       ((parsed (parse-simple-duration (car rest)))
 289        (dir (cadr rest)))
 290     (note-by-number-markup paper props (car parsed) (cadr parsed) dir)
 291   ))
 292
 293 (define-public (note-by-number-markup paper props . rest )
 294   "Syntax: \\note #LOG #DOTS #DIR.  By using fractional values
 295 for DIR, you can obtain longer or shorter stems."
 296
 297   (let*
 298       (
 299        (log (car rest))
 300        (dot-count (cadr  rest))
 301        (dir (caddr rest))
 302        (font (ly:paper-get-font paper (cons '((font-family .  music)) props)))
 303        (stemlen (max 3 (- log 1)))
 304        (headgl
 305         (ly:find-glyph-by-name font (string-append "noteheads-" (number->string (min log 2)))))
 306
 307        (stemth 0.13)
 308        (stemy (* dir stemlen))
 309        (attachx (if (> dir 0) (- (cdr (ly:molecule-get-extent headgl X)) stemth)
 310                     0))
 311        (attachy (* dir 0.28))
 312        (stemgl (if (> log 0)
 313                    (ly:round-filled-box
 314                                      (cons attachx (+ attachx  stemth))
 315                                      (cons (min stemy attachy)
 316                                            (max stemy attachy))
 317                                     (/ stemth 3)
 318                                     ) #f))
 319        (dot (ly:find-glyph-by-name font "dots-dot"))
 320        (dotwid  (interval-length (ly:molecule-get-extent dot X)))
 321        (dots (if (> dot-count 0)
 322                  (apply ly:molecule-add
 323                   (map (lambda (x)
 324                          (ly:molecule-translate-axis
 325                           dot  (* (+ 1 (* 2 x)) dotwid) X) )
 326                        (iota dot-count 1)))
 327                  #f))
 328
 329        (flaggl (if (> log 2)
 330                    (ly:molecule-translate
 331                     (ly:find-glyph-by-name
 332                      font
 333                      (string-append "flags-"
 334                                     (if (> dir 0) "u" "d")
 335                                     (number->string log)
 336                                     ))
 337                     (cons (+ attachx (/ stemth 2)) stemy))
 338
 339                     #f)))
 340
 341     (if flaggl
 342         (set! stemgl (ly:molecule-add flaggl stemgl)))
 343
 344     (if (ly:molecule? stemgl)
 345         (set! stemgl (ly:molecule-add stemgl headgl))
 346         (set! stemgl headgl)
 347         )
 348
 349     (if (ly:molecule? dots)
 350         (set! stemgl
 351               (ly:molecule-add
 352                (ly:molecule-translate-axis
 353                 dots
 354                 (+
 355                  (if (and (> dir 0) (> log 2))
 356                      (* 1.5 dotwid) 0)
 357                  ;; huh ? why not necessary?
 358                 ;(cdr (ly:molecule-get-extent headgl X))
 359                       dotwid
 360                  )
 361                 X)
 362                stemgl
 363                )
 364               ))
 365
 366     stemgl
 367     ))
 368
 369 (define-public (normal-size-super-markup paper props . rest)
 370   (ly:molecule-translate-axis (interpret-markup
 371                                paper
 372                                props (car rest))
 373                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 374                               Y)
 375   )
 376
 377 (define-public (super-markup paper props  . rest)
 378   "Syntax: \\super MARKUP. "
 379   (ly:molecule-translate-axis (interpret-markup
 380                                paper
 381                                (cons `((font-size .
 382                                                   ,(- (chain-assoc-get 'font-size props 0) 3))) props) (car rest))
 383                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 384                               Y)
 385   )
 386
 387 (define-public (translate-markup paper props . rest)
 388   "Syntax: \\translate OFFSET MARKUP. "
 389   (ly:molecule-translate (interpret-markup  paper props (cadr rest))
 390                          (car rest))
 391
 392   )
 393
 394 (define-public (sub-markup paper props  . rest)
 395   "Syntax: \\sub MARKUP."
 396   (ly:molecule-translate-axis
 397    (interpret-markup
 398     paper
 399     (cons `((font-size .
 400                        ,(- (chain-assoc-get 'font-size props 0) 3))) props)
 401     (car rest))
 402    (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 403    Y) )
 404
 405 (define-public (normal-size-sub-markup paper props . rest)
 406   (ly:molecule-translate-axis
 407    (interpret-markup
 408     paper
 409     props (car rest))
 410    (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 411    Y) )
 412
 413 (define-public (hbracket-markup paper props . rest)
 414   "Horizontal brackets around its single argument. Syntax \\hbracket MARKUP."
 415
 416   (let*
 417       ((th 0.1) ;; todo: take from GROB.
 418        (m (interpret-markup paper props (car rest))) )
 419
 420     (bracketify-molecule m X th (* 2.5 th) th)
 421 ))
 422
 423 (define-public (bracket-markup paper props . rest)
 424   "Vertical brackets around its single argument. Syntax \\bracket MARKUP."
 425   (let*
 426       ((th 0.1) ;; todo: take from GROB.
 427        (m (interpret-markup paper props (car rest))) )
 428
 429     (bracketify-molecule m Y th (* 2.5 th) th)
 430 ))
 431
 432 ;; todo: fix negative space
 433 (define (hspace-markup paper props . rest)
 434   "Syntax: \\hspace NUMBER."
 435   (let*
 436       ((amount (car rest)))
 437     (if (> amount 0)
 438         (ly:make-molecule "" (cons 0 amount) '(-1 . 1) )
 439         (ly:make-molecule "" (cons amount amount) '(-1 . 1)))
 440   ))
 441
 442 (define-public (override-markup paper props . rest)
 443
 444   "Add the first argument in to the property list.  Properties may be
 445 any sort of property supported by @ref{font-interface} and
 446 @ref{text-interface}, for example
 447
 448 \\override #'(font-family . married) \"bla\"
 449
 450 "
 451
 452   (interpret-markup paper (cons (list (car rest)) props)
 453                     (cadr rest)))
 454
 455 (define-public (smaller-markup  paper props . rest)
 456   "Syntax: \\smaller MARKUP"
 457   (let*
 458       ((fs (chain-assoc-get 'font-size props 0))
 459        (entry (cons 'font-size (- fs 1)))
 460        )
 461     (interpret-markup
 462      paper (cons (list entry) props)
 463      (car rest))
 464     ))
 465
 466
 467 (define-public (bigger-markup  paper props . rest)
 468   "Syntax: \\bigger MARKUP"
 469   (let*
 470       ((fs (chain-assoc-get 'font-size props 0))
 471        (entry (cons 'font-size (+ fs 1)))
 472        )
 473   (interpret-markup
 474    paper (cons (list entry) props)
 475    (car rest))
 476   ))
 477
 478 (define-public larger-markup bigger-markup)
 479
 480
 481 (define-public (box-markup paper props . rest)
 482   "Syntax: \\box MARKUP"
 483   (let*
 484       ((th 0.1)
 485        (pad 0.2)
 486        (m (interpret-markup paper props (car rest)))
 487        )
 488     (box-molecule m th pad)
 489   ))
 490
 491
 492 (define-public (strut-markup paper props . rest)
 493   "Syntax: \\strut
 494
 495  A box of the same height as the space.
 496 "
 497
 498   (let*
 499       ((m (Text_item::interpret_markup paper props " ")))
 500
 501     (ly:molecule-set-extent! m X '(1000 . -1000))
 502     m))
 503
 504
 505 (define number->mark-letter-vector (make-vector 25 #\A))
 506
 507 (do ((i 0 (1+ i))
 508      (j 0 (1+ j)) )
 509     ((>= i 26))
 510   (if (= i (- (char->integer #\I) (char->integer #\A)))
 511       (set! i (1+ i)))
 512   (vector-set! number->mark-letter-vector j
 513                (integer->char (+ i (char->integer #\A))))  )
 514
 515 (define (number->markletter-string n)
 516   "Double letters for big marks."
 517   (let*
 518       ((l (vector-length number->mark-letter-vector)))
 519
 520   (if (>= n l)
 521       (string-append (number->markletter-string (1- (quotient n l)))
 522                      (number->markletter-string (remainder n l)))
 523       (make-string 1 (vector-ref number->mark-letter-vector n)))))
 524
 525
 526 (define-public (markletter-markup paper props . rest)
 527   "Markup letters: skip I and do double letters for big marks.
 528 Syntax: \\markletter #25"
 529
 530   (Text_item::interpret_markup paper props
 531                                (number->markletter-string (car rest))
 532                                ))
 533
 534 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 535
 536
 537 (define (markup-signature-to-keyword sig)
 538   " (A B C) -> a0-b1-c2 "
 539   (if (equal? sig '())
 540       'empty
 541       (let* ((count  0))
 542         (string->symbol (string-join
 543
 544                          (map
 545                           (lambda (func)
 546                             (set! count (+ count 1))
 547                             (string-append
 548
 549                              ;; for reasons I don't get,
 550                              ;; (case func ((markup?) .. )
 551                              ;; doesn't work.
 552                              (cond
 553                               ((eq? func markup?) "markup")
 554                               ((eq? func markup-list?) "markup-list")
 555                               (else "scheme")
 556                               )
 557                              (number->string (- count 1))
 558                              ))
 559
 560                           sig)
 561                          "-"))
 562
 563         )))
 564
 565 (define (markup-function? x)
 566   (object-property x 'markup-signature) )
 567
 568 (define (markup-list? arg)
 569   (define (markup-list-inner? l)
 570     (if (null? l)
 571         #t
 572         (and (markup? (car l)) (markup-list-inner? (cdr l))) ) )
 573   (and (list? arg) (markup-list-inner? arg)))
 574
 575 (define (markup-argument-list? signature arguments)
 576   "Typecheck argument list."
 577   (if (and (pair? signature) (pair? arguments))
 578       (and ((car signature) (car arguments))
 579            (markup-argument-list? (cdr signature) (cdr arguments)))
 580       (and (null? signature) (null? arguments)))
 581   )
 582
 583
 584 (define (markup-argument-list-error signature arguments number)
 585   "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
 586 #f is no error found.
 587 "
 588   (if (and (pair? signature) (pair? arguments))
 589       (if (not ((car signature) (car arguments)))
 590           (list number (type-name (car signature)) (car arguments))
 591           (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
 592       #f
 593   ))
 594
 595 ;;
 596 ;; full recursive typecheck.
 597 ;;
 598 (define (markup-typecheck? arg)
 599   (or (string? arg)
 600       (and (pair? arg)
 601        (markup-function? (car arg))
 602        (markup-argument-list?
 603         (object-property (car arg) 'markup-signature)
 604         (cdr arg))
 605   ))
 606 )
 607
 608 ;;
 609 ;; typecheck, and throw an error when something amiss.
 610 ;;
 611 (define (markup-thrower-typecheck arg)
 612   (cond
 613    ((string? arg) #t)
 614    ((not (pair? arg))
 615     (throw 'markup-format "Not a pair" arg)
 616     )
 617    ((not (markup-function? (car arg)))
 618     (throw 'markup-format "Not a markup function " (car arg)))
 619
 620
 621    ((not (markup-argument-list?
 622           (object-property (car arg) 'markup-signature)
 623           (cdr arg)))
 624     (throw 'markup-format "Arguments failed  typecheck for " arg)))
 625    #t
 626   )
 627
 628 ;;
 629 ;; good enough if you only  use make-XXX-markup functions.
 630 ;;
 631 (define (cheap-markup? x)
 632   (or (string? x)
 633       (and (pair? x)
 634            (markup-function? (car x))))
 635 )
 636
 637 ;;
 638 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
 639 ;;
 640 (define markup?  cheap-markup?)
 641
 642 (define markup-functions-and-signatures
 643   (list
 644
 645    ;; abs size
 646    (cons teeny-markup (list markup?))
 647    (cons tiny-markup (list markup?))
 648    (cons small-markup (list markup?))
 649    (cons dynamic-markup (list markup?))
 650    (cons large-markup (list markup?))
 651    (cons normalsize-markup (list markup?))
 652
 653    (cons huge-markup (list markup?))
 654
 655    ;; size
 656    (cons smaller-markup (list markup?))
 657    (cons bigger-markup (list markup?))
 658    (cons larger-markup (list markup?))
 659 ;   (cons char-number-markup (list string?))
 660
 661    ;;
 662    (cons sub-markup (list markup?))
 663    (cons normal-size-sub-markup (list markup?))
 664
 665    (cons super-markup (list markup?))
 666    (cons normal-size-super-markup (list markup?))
 667
 668    (cons finger-markup (list markup?))
 669    (cons bold-markup (list markup?))
 670    (cons italic-markup (list markup?))
 671    (cons typewriter-markup (list markup?))
 672    (cons roman-markup (list markup?))
 673    (cons number-markup (list markup?))
 674    (cons hbracket-markup  (list markup?))
 675    (cons bracket-markup  (list markup?))
 676    (cons note-markup (list string? number?))
 677    (cons note-by-number-markup (list number? number? number?))
 678    (cons fraction-markup (list markup? markup?))
 679    (cons markletter-markup (list number?))
 680    (cons column-markup (list markup-list?))
 681    (cons dir-column-markup (list markup-list?))
 682    (cons center-markup (list markup-list?))
 683    (cons line-markup  (list markup-list?))
 684
 685    (cons right-align-markup (list markup?))
 686    (cons left-align-markup (list markup?))
 687    (cons halign-markup (list number? markup?))
 688
 689    (cons combine-markup (list markup? markup?))
 690    (cons simple-markup (list string?))
 691    (cons musicglyph-markup (list string?))
 692    (cons translate-markup (list number-pair? markup?))
 693    (cons override-markup (list pair? markup?))
 694    (cons char-markup (list integer?))
 695    (cons lookup-markup (list string?))
 696
 697    (cons hspace-markup (list number?))
 698
 699    (cons raise-markup (list number? markup?))
 700    (cons magnify-markup (list number? markup?))
 701    (cons fontsize-markup (list number? markup?))
 702
 703    (cons box-markup  (list markup?))
 704    (cons strut-markup '())
 705    ))
 706
 707
 708 (define markup-module (current-module))
 709
 710 (map (lambda (x)
 711        (set-object-property! (car x) 'markup-signature (cdr x))
 712        (set-object-property! (car x) 'markup-keyword (markup-signature-to-keyword (cdr x)))
 713        )
 714      markup-functions-and-signatures)
 715
 716 (define-public markup-function-list (map car markup-functions-and-signatures))
 717
 718
 719 ;; construct a
 720 ;;
 721 ;; make-FOO-markup function that typechecks its arguments.
 722 ;;
 723 ;; TODO: should construct a message says
 724 ;; Invalid argument 4 : expecting a BLADIBLA, found: (list-ref 4 args)
 725 ;;
 726 ;; right now, you get the entire argument list.
 727
 728
 729 (define (make-markup-maker  entry)
 730   (let*
 731         ((foo-markup (car entry))
 732          (signature (cons 'list (cdr entry)))
 733          (name (symbol->string (procedure-name foo-markup)))
 734          (make-name  (string-append "make-" name))
 735          )
 736
 737       `(define (,(string->symbol make-name) . args)
 738          (let*
 739              (
 740               (arglen (length  args))
 741               (siglen (length ,signature))
 742               (error-msg
 743                (if (and (> 0 siglen) (> 0 arglen))
 744                    (markup-argument-list-error ,signature args 1)))
 745
 746               )
 747
 748          (if (or (not (= arglen siglen)) (< siglen 0) (< 0 arglen))
 749              (scm-error 'markup-format ,make-name "Expect ~A arguments for ~A. Found ~A: ~S"
 750                         (list (length ,signature)
 751                               ,make-name
 752                               (length args)
 753                               args) #f))
 754          (if error-msg
 755              (scm-error 'markup-format ,make-name "Invalid argument in position ~A\n Expect: ~A\nFound: ~S." error-msg #f)
 756
 757              (cons ,foo-markup args)
 758              )))
 759     )
 760 )
 761
 762
 763
 764 (define (make-markup markup-function make-name signature args)
 765
 766   " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
 767 against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
 768 "
 769
 770   (let*
 771       ((arglen (length args))
 772        (siglen (length signature))
 773        (error-msg
 774         (if (and (> siglen 0) (> arglen 0))
 775             (markup-argument-list-error signature args 1)
 776             #f)))
 777
 778
 779     (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
 780         (scm-error 'markup-format make-name "Expect ~A arguments for ~A. Found ~A: ~S"
 781                    (list siglen
 782                          make-name
 783                          arglen
 784                          args) #f))
 785
 786     (if error-msg
 787         (scm-error 'markup-format make-name "Invalid argument in position ~A\nExpect: ~A\nFound: ~S." error-msg #f)
 788
 789         (cons markup-function  args)
 790         )))
 791
 792 (define (make-markup-maker entry)
 793   (let* (
 794          (name (symbol->string (procedure-name (car entry))))
 795          (make-name  (string-append "make-" name))
 796          (signature (object-property (car entry) 'markup-signature))
 797          )
 798
 799     `(define-public (,(string->symbol make-name) . args)
 800        (make-markup ,(car entry) ,make-name ,(cons 'list signature)  args)
 801        ))
 802   )
 803
 804 (eval
 805  (cons 'begin (map make-markup-maker markup-functions-and-signatures))
 806  markup-module
 807  )
 808
 809 ;;
 810 ;; TODO: add module argument so user-defined markups can also be
 811 ;; processed.
 812 ;;
 813 (define-public (lookup-markup-command code)
 814   (let*
 815       ((sym (string->symbol (string-append code "-markup")))
 816        (var (module-local-variable markup-module sym))
 817        )
 818     (if (eq? var #f)
 819         #f
 820         (cons (variable-ref var) (object-property  (variable-ref var) 'markup-keyword))
 821     )
 822   ))
 823
 824
 825 (define-public brew-new-markup-molecule Text_item::brew_molecule)
 826
 827 (define-public empty-markup (make-simple-markup ""))
 828
 829 (define-public interpret-markup Text_item::interpret_markup)
 830
 831
 832 ;;;;;;;;;;;;;;;;
 833 ;; utility
 834
 835 (define (markup-join markups sep)
 836   "Return line-markup of MARKUPS, joining them with markup SEP"
 837   (if (pair? markups)
 838       (make-line-markup (list-insert-separator markups sep))
 839       empty-markup))
 840
 841
 842 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 843
 844 (if #f
 845    (define (typecheck-with-error x)
 846      (catch
 847       'markup-format
 848       (lambda () (markup? x))
 849       (lambda (key message arg)
 850         (display "\nERROR: markup format error: \n")
 851         (display message)
 852         (newline)
 853         (write arg (current-output-port))
 854         )
 855       )))
 856
 857 ;; test make-foo-markup functions
 858 (if #f
 859     (begin
 860       (newline)
 861       (newline)
 862       (display (make-line-markup (list (make-simple-markup "FOO"))))
 863
 864       (make-line-markup (make-simple-markup "FOO"))
 865       (make-line-markup (make-simple-markup "FOO") (make-simple-markup "foo"))
 866       (make-raise-markup "foo" (make-simple-markup "foo"))
 867       )
 868     )
 869
 870
 871 ;;
 872 ;; test typecheckers. Not wholly useful, because errors are detected
 873 ;; in other places than they're made.
 874 ;;
 875 (if #f
 876  (begin
 877
 878    ;; To get error messages, see above to install the alternate
 879    ;; typecheck routine for markup?.
 880
 881
 882
 883    (display (typecheck-with-error `(,simple-markup "foobar")))
 884    (display (typecheck-with-error `(,simple-markup "foobar")))
 885    (display (typecheck-with-error `(,simple-markup 1)))
 886    (display
 887     (typecheck-with-error  `(,line-markup ((,simple-markup "foobar"))
 888                                           (,simple-markup 1))))
 889    (display
 890     (typecheck-with-error  `(,line-markup (,simple-markup "foobar")
 891                                          (,simple-markup "bla"))))
 892
 893    ))