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 (define-public (note-markup paper props . rest)
 259   "Syntax: \\note #LOG #DOTS #DIR.  By using fractional values
 260 for DIR, you can obtain longer or shorter stems."
 261
 262   (let*
 263       (
 264        (log (car rest))
 265        (dot-count (cadr rest))
 266        (dir (caddr rest))
 267        (font (ly:paper-get-font paper (cons '((font-family .  music)) props)))
 268        (stemlen (max 3 (- log 1)))
 269        (headgl
 270         (ly:find-glyph-by-name font (string-append "noteheads-" (number->string (min log 2)))))
 271
 272        (stemth 0.13)
 273        (stemy (* dir stemlen))
 274        (attachx (if (> dir 0) (- (cdr (ly:molecule-get-extent headgl X)) stemth)
 275                     0))
 276        (attachy (* dir 0.28))
 277        (stemgl (if (> log 0)
 278                    (ly:round-filled-box
 279                                      (cons attachx (+ attachx  stemth))
 280                                      (cons (min stemy attachy)
 281                                            (max stemy attachy))
 282                                     (/ stemth 3)
 283                                     ) #f))
 284        (dot (ly:find-glyph-by-name font "dots-dot"))
 285        (dotwid  (interval-length (ly:molecule-get-extent dot X)))
 286        (dots (if (> dot-count 0)
 287                  (apply ly:molecule-add
 288                   (map (lambda (x)
 289                          (ly:molecule-translate-axis
 290                           dot  (* (+ 1 (* 2 x)) dotwid) X) )
 291                        (iota dot-count 1)))
 292                  #f))
 293
 294        (flaggl (if (> log 2)
 295                    (ly:molecule-translate
 296                     (ly:find-glyph-by-name
 297                      font
 298                      (string-append "flags-"
 299                                     (if (> dir 0) "u" "d")
 300                                     (number->string log)
 301                                     ))
 302                     (cons (+ attachx (/ stemth 2)) stemy))
 303
 304                     #f)))
 305
 306     (if flaggl
 307         (set! stemgl (ly:molecule-add flaggl stemgl)))
 308
 309     (if (ly:molecule? stemgl)
 310         (set! stemgl (ly:molecule-add stemgl headgl))
 311         (set! stemgl headgl)
 312         )
 313
 314     (if (ly:molecule? dots)
 315         (set! stemgl
 316               (ly:molecule-add
 317                (ly:molecule-translate-axis
 318                 dots
 319                 (+
 320                  (if (and (> dir 0) (> log 2))
 321                      (* 1.5 dotwid) 0)
 322                  ;; huh ? why not necessary?
 323                 ;(cdr (ly:molecule-get-extent headgl X))
 324                       dotwid
 325                  )
 326                 X)
 327                stemgl
 328                )
 329               ))
 330
 331     stemgl
 332     ))
 333
 334 (define-public (normal-size-super-markup paper props . rest)
 335   (ly:molecule-translate-axis (interpret-markup
 336                                paper
 337                                props (car rest))
 338                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 339                               Y)
 340   )
 341
 342 (define-public (super-markup paper props  . rest)
 343   "Syntax: \\super MARKUP. "
 344   (ly:molecule-translate-axis (interpret-markup
 345                                paper
 346                                (cons '((font-size . -3)) props) (car rest))
 347                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 348                               Y)
 349   )
 350
 351 (define-public (translate-markup paper props . rest)
 352   "Syntax: \\translate OFFSET MARKUP. "
 353   (ly:molecule-translate (interpret-markup  paper props (cadr rest))
 354                          (car rest))
 355
 356   )
 357
 358 (define-public (sub-markup paper props  . rest)
 359   "Syntax: \\sub MARKUP."
 360   (ly:molecule-translate-axis (interpret-markup
 361                                paper
 362                                (cons '((font-size . -3)) props)
 363                                (car rest))
 364                               (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 365                               Y)
 366   )
 367
 368 (define-public (normal-size-sub-markup paper props . rest)
 369   (ly:molecule-translate-axis (interpret-markup
 370                                paper
 371                                props (car rest))
 372                               (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 373                               Y)
 374   )
 375
 376 (define-public (hbracket-markup paper props . rest)
 377   "Horizontal brackets around its single argument. Syntax \\hbracket MARKUP."
 378
 379   (let*
 380       ((th 0.1) ;; todo: take from GROB.
 381        (m (interpret-markup paper props (car rest))) )
 382
 383     (bracketify-molecule m X th (* 2.5 th) th)
 384 ))
 385
 386 (define-public (bracket-markup paper props . rest)
 387   "Vertical brackets around its single argument. Syntax \\bracket MARKUP."
 388   (let*
 389       ((th 0.1) ;; todo: take from GROB.
 390        (m (interpret-markup paper props (car rest))) )
 391
 392     (bracketify-molecule m Y th (* 2.5 th) th)
 393 ))
 394
 395 ;; todo: fix negative space
 396 (define (hspace-markup paper props . rest)
 397   "Syntax: \\hspace NUMBER."
 398   (let*
 399       ((amount (car rest)))
 400     (if (> amount 0)
 401         (ly:make-molecule "" (cons 0 amount) '(-1 . 1) )
 402         (ly:make-molecule "" (cons amount amount) '(-1 . 1)))
 403   ))
 404
 405 (define-public (override-markup paper props . rest)
 406
 407   "Add the first argument in to the property list.  Properties may be
 408 any sort of property supported by @ref{font-interface} and
 409 @ref{text-interface}, for example
 410
 411 \\override #'(font-family . married) \"bla\"
 412
 413 "
 414
 415   (interpret-markup paper (cons (list (car rest)) props)
 416                     (cadr rest)))
 417
 418 (define-public (smaller-markup  paper props . rest)
 419   "Syntax: \\smaller MARKUP"
 420   (let*
 421       ((fs (chain-assoc-get 'font-size props 0))
 422        (entry (cons 'font-size (- fs 1)))
 423        )
 424     (interpret-markup
 425      paper (cons (list entry) props)
 426      (car rest))
 427     ))
 428
 429
 430 (define-public (bigger-markup  paper props . rest)
 431   "Syntax: \\bigger MARKUP"
 432   (let*
 433       ((fs (chain-assoc-get 'font-size props 0))
 434        (entry (cons 'font-size (+ fs 1)))
 435        )
 436   (interpret-markup
 437    paper (cons (list entry) props)
 438    (car rest))
 439   ))
 440
 441 (define-public larger-markup bigger-markup)
 442
 443
 444 (define-public (box-markup paper props . rest)
 445   "Syntax: \\box MARKUP"
 446   (let*
 447       ((th 0.1)
 448        (pad 0.2)
 449        (m (interpret-markup paper props (car rest)))
 450        )
 451     (box-molecule m th pad)
 452   ))
 453
 454
 455 ;; TODO: fix this .
 456 (define-public (strut-markup paper props . rest)
 457   "Syntax: \\strut
 458
 459  A box of the same height as the space.
 460 "
 461
 462   (let*
 463       ((m (Text_item::interpret_markup paper props " ")))
 464
 465     (ly:molecule-set-extent! m 0 '(1000 . -1000))
 466     m))
 467
 468 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 469
 470
 471 (define (markup-signature-to-keyword sig)
 472   " (A B C) -> a0-b1-c2 "
 473
 474   (let* ((count  0))
 475     (string->symbol (string-join
 476
 477      (map
 478      (lambda (func)
 479        (set! count (+ count 1))
 480        (string-append
 481
 482         ;; for reasons I don't get,
 483         ;; (case func ((markup?) .. )
 484         ;; doesn't work.
 485         (cond
 486           ((eq? func markup?) "markup")
 487           ((eq? func markup-list?) "markup-list")
 488           (else "scheme")
 489           )
 490         (number->string (- count 1))
 491         ))
 492
 493      sig)
 494      "-"))
 495
 496   ))
 497
 498
 499 (define (markup-function? x)
 500   (object-property x 'markup-signature)
 501   )
 502
 503 (define (markup-list? arg)
 504   (define (markup-list-inner? l)
 505     (if (null? l)
 506         #t
 507         (and (markup? (car l)) (markup-list-inner? (cdr l)))
 508     )
 509   )
 510   (and (list? arg) (markup-list-inner? arg)))
 511
 512 (define (markup-argument-list? signature arguments)
 513   "Typecheck argument list."
 514   (if (and (pair? signature) (pair? arguments))
 515       (and ((car signature) (car arguments))
 516            (markup-argument-list? (cdr signature) (cdr arguments)))
 517       (and (null? signature) (null? arguments)))
 518   )
 519
 520
 521 (define (markup-argument-list-error signature arguments number)
 522   "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
 523 #f is no error found.
 524 "
 525   (if (and (pair? signature) (pair? arguments))
 526       (if (not ((car signature) (car arguments)))
 527           (list number (type-name (car signature)) (car arguments))
 528           (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
 529       #f
 530   ))
 531
 532 ;;
 533 ;; full recursive typecheck.
 534 ;;
 535 (define (markup-typecheck? arg)
 536   (or (string? arg)
 537       (and (pair? arg)
 538        (markup-function? (car arg))
 539        (markup-argument-list?
 540         (object-property (car arg) 'markup-signature)
 541         (cdr arg))
 542   ))
 543 )
 544
 545 ;;
 546 ;; typecheck, and throw an error when something amiss.
 547 ;;
 548 (define (markup-thrower-typecheck arg)
 549   (cond
 550    ((string? arg) #t)
 551    ((not (pair? arg))
 552     (throw 'markup-format "Not a pair" arg)
 553     )
 554    ((not (markup-function? (car arg)))
 555     (throw 'markup-format "Not a markup function " (car arg)))
 556
 557
 558    ((not (markup-argument-list?
 559           (object-property (car arg) 'markup-signature)
 560           (cdr arg)))
 561     (throw 'markup-format "Arguments failed  typecheck for " arg)))
 562    #t
 563   )
 564
 565 ;;
 566 ;; good enough if you only  use make-XXX-markup functions.
 567 ;;
 568 (define (cheap-markup? x)
 569   (or (string? x)
 570       (and (pair? x)
 571            (markup-function? (car x))))
 572 )
 573
 574 ;;
 575 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
 576 ;;
 577 (define markup?  cheap-markup?)
 578
 579 (define markup-functions-and-signatures
 580   (list
 581
 582    ;; abs size
 583    (cons teeny-markup (list markup?))
 584    (cons tiny-markup (list markup?))
 585    (cons small-markup (list markup?))
 586    (cons dynamic-markup (list markup?))
 587    (cons large-markup (list markup?))
 588    (cons normalsize-markup (list markup?))
 589
 590    (cons huge-markup (list markup?))
 591
 592    ;; size
 593    (cons smaller-markup (list markup?))
 594    (cons bigger-markup (list markup?))
 595    (cons larger-markup (list markup?))
 596 ;   (cons char-number-markup (list string?))
 597
 598    ;;
 599    (cons sub-markup (list markup?))
 600    (cons normal-size-sub-markup (list markup?))
 601
 602    (cons super-markup (list markup?))
 603    (cons normal-size-super-markup (list markup?))
 604
 605    (cons finger-markup (list markup?))
 606    (cons bold-markup (list markup?))
 607    (cons italic-markup (list markup?))
 608    (cons typewriter-markup (list markup?))
 609    (cons roman-markup (list markup?))
 610    (cons number-markup (list markup?))
 611    (cons hbracket-markup  (list markup?))
 612    (cons bracket-markup  (list markup?))
 613    (cons note-markup (list integer? integer? ly:dir?))
 614    (cons fraction-markup (list markup? markup?))
 615
 616    (cons column-markup (list markup-list?))
 617    (cons dir-column-markup (list markup-list?))
 618    (cons center-markup (list markup-list?))
 619    (cons line-markup  (list markup-list?))
 620
 621    (cons right-align-markup (list markup?))
 622    (cons left-align-markup (list markup?))
 623    (cons halign-markup (list number? markup?))
 624
 625    (cons combine-markup (list markup? markup?))
 626    (cons simple-markup (list string?))
 627    (cons musicglyph-markup (list string?))
 628    (cons translate-markup (list number-pair? markup?))
 629    (cons override-markup (list pair? markup?))
 630    (cons char-markup (list integer?))
 631    (cons lookup-markup (list string?))
 632
 633    (cons hspace-markup (list number?))
 634
 635    (cons raise-markup (list number? markup?))
 636    (cons magnify-markup (list number? markup?))
 637    (cons fontsize-markup (list number? markup?))
 638
 639    (cons box-markup  (list markup?))
 640    ))
 641
 642
 643 (define markup-module (current-module))
 644
 645 (map (lambda (x)
 646        (set-object-property! (car x) 'markup-signature (cdr x))
 647        (set-object-property! (car x) 'markup-keyword (markup-signature-to-keyword (cdr x)))
 648        )
 649      markup-functions-and-signatures)
 650
 651 (define-public markup-function-list (map car markup-functions-and-signatures))
 652
 653
 654 ;; construct a
 655 ;;
 656 ;; make-FOO-markup function that typechecks its arguments.
 657 ;;
 658 ;; TODO: should construct a message says
 659 ;; Invalid argument 4 : expecting a BLADIBLA, found: (list-ref 4 args)
 660 ;;
 661 ;; right now, you get the entire argument list.
 662
 663
 664 (define (make-markup-maker  entry)
 665   (let*
 666         ((foo-markup (car entry))
 667          (signature (cons 'list (cdr entry)))
 668          (name (symbol->string (procedure-name foo-markup)))
 669          (make-name  (string-append "make-" name))
 670          )
 671
 672       `(define (,(string->symbol make-name) . args)
 673          (let*
 674              (
 675               (arglen (length  args))
 676               (siglen (length ,signature))
 677               (error-msg
 678                (if (and (> 0 siglen) (> 0 arglen))
 679                    (markup-argument-list-error ,signature args 1)))
 680
 681               )
 682
 683          (if (or (not (= arglen siglen)) (< siglen 0) (< 0 arglen))
 684              (scm-error 'markup-format ,make-name "Expect ~A arguments for ~A. Found ~A: ~S"
 685                         (list (length ,signature)
 686                               ,make-name
 687                               (length args)
 688                               args) #f))
 689          (if error-msg
 690              (scm-error 'markup-format ,make-name "Invalid argument in position ~A\n Expect: ~A\nFound: ~S." error-msg #f)
 691
 692              (cons ,foo-markup args)
 693              )))
 694     )
 695 )
 696
 697
 698
 699 (define (make-markup markup-function make-name signature args)
 700
 701   " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
 702 against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
 703 "
 704
 705   (let*
 706       ((arglen (length args))
 707        (siglen (length signature))
 708        (error-msg
 709         (if (and (> siglen 0) (> arglen 0))
 710             (markup-argument-list-error signature args 1)
 711             #f)))
 712
 713
 714     (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
 715         (scm-error 'markup-format make-name "Expect ~A arguments for ~A. Found ~A: ~S"
 716                    (list siglen
 717                          make-name
 718                          arglen
 719                          args) #f))
 720
 721     (if error-msg
 722         (scm-error 'markup-format make-name "Invalid argument in position ~A\nExpect: ~A\nFound: ~S." error-msg #f)
 723
 724         (cons markup-function  args)
 725         )))
 726
 727 (define (make-markup-maker entry)
 728   (let* (
 729          (name (symbol->string (procedure-name (car entry))))
 730          (make-name  (string-append "make-" name))
 731          (signature (object-property (car entry) 'markup-signature))
 732          )
 733
 734     `(define-public (,(string->symbol make-name) . args)
 735        (make-markup ,(car entry) ,make-name ,(cons 'list signature)  args)
 736        ))
 737   )
 738
 739 (eval
 740  (cons 'begin (map make-markup-maker markup-functions-and-signatures))
 741  markup-module
 742  )
 743
 744 ;;
 745 ;; TODO: add module argument so user-defined markups can also be
 746 ;; processed.
 747 ;;
 748 (define-public (lookup-markup-command code)
 749   (let*
 750       ((sym (string->symbol (string-append code "-markup")))
 751        (var (module-local-variable markup-module sym))
 752        )
 753     (if (eq? var #f)
 754         #f
 755         (cons (variable-ref var) (object-property  (variable-ref var) 'markup-keyword))
 756     )
 757   ))
 758
 759
 760 (define-public brew-new-markup-molecule Text_item::brew_molecule)
 761
 762 (define-public empty-markup (make-simple-markup ""))
 763
 764 (define-public interpret-markup Text_item::interpret_markup)
 765
 766
 767 ;;;;;;;;;;;;;;;;
 768 ;; utility
 769
 770 (define (markup-join markups sep)
 771   "Return line-markup of MARKUPS, joining them with markup SEP"
 772   (if (pair? markups)
 773       (make-line-markup (list-insert-separator markups sep))
 774       empty-markup))
 775
 776
 777 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 778
 779 (if #f
 780    (define (typecheck-with-error x)
 781      (catch
 782       'markup-format
 783       (lambda () (markup? x))
 784       (lambda (key message arg)
 785         (display "\nERROR: markup format error: \n")
 786         (display message)
 787         (newline)
 788         (write arg (current-output-port))
 789         )
 790       )))
 791
 792 ;; test make-foo-markup functions
 793 (if #f
 794     (begin
 795       (newline)
 796       (newline)
 797       (display (make-line-markup (list (make-simple-markup "FOO"))))
 798
 799       (make-line-markup (make-simple-markup "FOO"))
 800       (make-line-markup (make-simple-markup "FOO") (make-simple-markup "foo"))
 801       (make-raise-markup "foo" (make-simple-markup "foo"))
 802       )
 803     )
 804
 805
 806 ;;
 807 ;; test typecheckers. Not wholly useful, because errors are detected
 808 ;; in other places than they're made.
 809 ;;
 810 (if #f
 811  (begin
 812
 813    ;; To get error messages, see above to install the alternate
 814    ;; typecheck routine for markup?.
 815
 816
 817
 818    (display (typecheck-with-error `(,simple-markup "foobar")))
 819    (display (typecheck-with-error `(,simple-markup "foobar")))
 820    (display (typecheck-with-error `(,simple-markup 1)))
 821    (display
 822     (typecheck-with-error  `(,line-markup ((,simple-markup "foobar"))
 823                                           (,simple-markup 1))))
 824    (display
 825     (typecheck-with-error  `(,line-markup (,simple-markup "foobar")
 826                                          (,simple-markup "bla"))))
 827
 828    ))