scm/new-markup.scm

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