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