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