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 . ())
 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-relative-size . -2)) 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-relative-size . -2)) 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       (
 369        (th 0.1) ;; todo: take from GROB.
 370        (m (interpret-markup paper props (car rest)))
 371        )
 372
 373     (bracketify-molecule m X th (* 2.5 th) th)
 374 ))
 375
 376 (define-public (bracket-markup paper props . rest)
 377   "Vertical brackets around its single argument. Syntax \\bracket MARKUP."
 378   (let*
 379       (
 380        (th 0.1) ;; todo: take from GROB.
 381        (m (interpret-markup paper props (car rest)))
 382        )
 383
 384     (bracketify-molecule m Y th (* 2.5 th) th)
 385 ))
 386
 387 ;; todo: fix negative space
 388 (define (hspace-markup paper props . rest)
 389   "Syntax: \\hspace NUMBER."
 390   (let*
 391       ((amount (car rest)))
 392     (if (> amount 0)
 393         (ly:make-molecule "" (cons 0 amount) '(-1 . 1) )
 394         (ly:make-molecule "" (cons amount amount) '(-1 . 1)))
 395   ))
 396
 397 (define-public (override-markup paper props . rest)
 398   "Tack the 1st arg in REST onto PROPS, e.g.
 399
 400 \override #'(font-family . married) \"bla\"
 401
 402 "
 403
 404   (interpret-markup paper (cons (list (car rest)) props)
 405                     (cadr rest)))
 406
 407 (define-public (smaller-markup  paper props . rest)
 408   "Syntax: \\smaller MARKUP"
 409   (let*
 410       (
 411        (fs (cdr (chain-assoc 'font-relative-size props)))
 412        (entry (cons 'font-relative-size (- fs 1)))
 413        )
 414     (interpret-markup
 415      paper (cons (list entry) props)
 416      (car rest))
 417     ))
 418
 419 (define-public (bigger-markup  paper props . rest)
 420   "Syntax: \\bigger MARKUP"
 421   (let*
 422       (
 423        (fs (cdr (chain-assoc 'font-relative-size props)))
 424        (entry (cons 'font-relative-size (+ fs 1)))
 425        )
 426   (interpret-markup
 427    paper (cons (list entry) props)
 428    (car rest))
 429   ))
 430
 431 (define-public (box-markup paper props . rest)
 432   "Syntax: \\box MARKUP"
 433   (let*
 434       (
 435        (th 0.1)
 436        (pad 0.2)
 437        (m (interpret-markup paper props (car rest)))
 438        )
 439     (box-molecule m th pad)
 440   ))
 441
 442
 443 (define-public (strut-markup paper props . rest)
 444   "Syntax: \strut
 445
 446  A box of the same height as the space.
 447 "
 448
 449   (let*
 450       ((m (Text_item::interpret_markup paper props " ")))
 451
 452     (ly:molecule-set-extent! m 0 '(1000 . -1000))
 453     m))
 454
 455 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 456
 457
 458 (define (markup-signature-to-keyword sig)
 459   " (A B C) -> a0-b1-c2 "
 460
 461   (let* ((count  0))
 462     (string->symbol (string-join
 463
 464      (map
 465      (lambda (func)
 466        (set! count (+ count 1))
 467        (string-append
 468
 469         ;; for reasons I don't get,
 470         ;; (case func ((markup?) .. )
 471         ;; doesn't work.
 472         (cond
 473           ((eq? func markup?) "markup")
 474           ((eq? func markup-list?) "markup-list")
 475           (else "scheme")
 476           )
 477         (number->string (- count 1))
 478         ))
 479
 480      sig)
 481      "-"))
 482
 483   ))
 484
 485
 486 (define (markup-function? x)
 487   (object-property x 'markup-signature)
 488   )
 489
 490 (define (markup-list? arg)
 491   (define (markup-list-inner? l)
 492     (if (null? l)
 493         #t
 494         (and (markup? (car l)) (markup-list-inner? (cdr l)))
 495     )
 496   )
 497   (and (list? arg) (markup-list-inner? arg)))
 498
 499 (define (markup-argument-list? signature arguments)
 500   "Typecheck argument list."
 501   (if (and (pair? signature) (pair? arguments))
 502       (and ((car signature) (car arguments))
 503            (markup-argument-list? (cdr signature) (cdr arguments)))
 504       (and (null? signature) (null? arguments)))
 505   )
 506
 507
 508 (define (markup-argument-list-error signature arguments number)
 509   "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
 510 #f is no error found.
 511 "
 512   (if (and (pair? signature) (pair? arguments))
 513       (if (not ((car signature) (car arguments)))
 514           (list number (type-name (car signature)) (car arguments))
 515           (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
 516       #f
 517   ))
 518
 519 ;;
 520 ;; full recursive typecheck.
 521 ;;
 522 (define (markup-typecheck? arg)
 523   (or (string? arg)
 524       (and (pair? arg)
 525        (markup-function? (car arg))
 526        (markup-argument-list?
 527         (object-property (car arg) 'markup-signature)
 528         (cdr arg))
 529   ))
 530 )
 531
 532 ;;
 533 ;; typecheck, and throw an error when something amiss.
 534 ;;
 535 (define (markup-thrower-typecheck arg)
 536   (cond
 537    ((string? arg) #t)
 538    ((not (pair? arg))
 539     (throw 'markup-format "Not a pair" arg)
 540     )
 541    ((not (markup-function? (car arg)))
 542     (throw 'markup-format "Not a markup function " (car arg)))
 543
 544
 545    ((not (markup-argument-list?
 546           (object-property (car arg) 'markup-signature)
 547           (cdr arg)))
 548     (throw 'markup-format "Arguments failed  typecheck for " arg)))
 549    #t
 550   )
 551
 552 ;;
 553 ;; good enough if you only  use make-XXX-markup functions.
 554 ;;
 555 (define (cheap-markup? x)
 556   (or (string? x)
 557       (and (pair? x)
 558            (markup-function? (car x))))
 559 )
 560
 561 ;;
 562 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
 563 ;;
 564 (define markup?  cheap-markup?)
 565
 566 (define markup-functions-and-signatures
 567   (list
 568
 569    ;; abs size
 570    (cons teeny-markup (list markup?))
 571    (cons tiny-markup (list markup?))
 572    (cons small-markup (list markup?))
 573    (cons dynamic-markup (list markup?))
 574    (cons large-markup (list markup?))
 575
 576    (cons huge-markup (list markup?))
 577
 578    ;; size
 579    (cons smaller-markup (list markup?))
 580    (cons bigger-markup (list markup?))
 581 ;   (cons char-number-markup (list string?))
 582
 583    ;;
 584    (cons sub-markup (list markup?))
 585    (cons normal-size-sub-markup (list markup?))
 586
 587    (cons super-markup (list markup?))
 588    (cons normal-size-super-markup (list markup?))
 589
 590    (cons finger-markup (list markup?))
 591    (cons bold-markup (list markup?))
 592    (cons italic-markup (list markup?))
 593    (cons typewriter-markup (list markup?))
 594    (cons roman-markup (list markup?))
 595    (cons number-markup (list markup?))
 596    (cons hbracket-markup  (list markup?))
 597    (cons bracket-markup  (list markup?))
 598    (cons note-markup (list integer? integer? ly:dir?))
 599    (cons fraction-markup (list markup? markup?))
 600
 601    (cons column-markup (list markup-list?))
 602    (cons dir-column-markup (list markup-list?))
 603    (cons center-markup (list markup-list?))
 604    (cons line-markup  (list markup-list?))
 605
 606    (cons right-align-markup (list markup?))
 607    (cons left-align-markup (list markup?))
 608    (cons halign-markup (list number? markup?))
 609
 610    (cons combine-markup (list markup? markup?))
 611    (cons simple-markup (list string?))
 612    (cons musicglyph-markup (list scheme?))
 613    (cons translate-markup (list number-pair? markup?))
 614    (cons override-markup (list pair? markup?))
 615    (cons char-markup (list integer?))
 616    (cons lookup-markup (list string?))
 617
 618    (cons hspace-markup (list number?))
 619
 620    (cons raise-markup (list number? markup?))
 621    (cons magnify-markup (list number? markup?))
 622    (cons fontsize-markup (list number? markup?))
 623
 624    (cons box-markup  (list markup?))
 625    (cons strut-markup '())
 626    ))
 627
 628
 629 (define markup-module (current-module))
 630
 631 (map (lambda (x)
 632        (set-object-property! (car x) 'markup-signature (cdr x))
 633        (set-object-property! (car x) 'markup-keyword (markup-signature-to-keyword (cdr x)))
 634        )
 635      markup-functions-and-signatures)
 636
 637 (define-public markup-function-list (map car markup-functions-and-signatures))
 638
 639
 640 ;; construct a
 641 ;;
 642 ;; make-FOO-markup function that typechecks its arguments.
 643 ;;
 644 ;; TODO: should construct a message says
 645 ;; Invalid argument 4 : expecting a BLADIBLA, found: (list-ref 4 args)
 646 ;;
 647 ;; right now, you get the entire argument list.
 648
 649
 650 (define (make-markup-maker  entry)
 651   (let*
 652         ((foo-markup (car entry))
 653          (signature (cons 'list (cdr entry)))
 654          (name (symbol->string (procedure-name foo-markup)))
 655          (make-name  (string-append "make-" name))
 656          )
 657
 658       `(define (,(string->symbol make-name) . args)
 659          (let*
 660              (
 661               (arglen (length  args))
 662               (siglen (length ,signature))
 663               (error-msg
 664                (if (and (> 0 siglen) (> 0 arglen))
 665                    (markup-argument-list-error ,signature args 1)))
 666
 667               )
 668
 669          (if (or (not (= arglen siglen)) (< siglen 0) (< 0 arglen))
 670              (scm-error 'markup-format ,make-name "Expect ~A arguments for ~A. Found ~A: ~S"
 671                         (list (length ,signature)
 672                               ,make-name
 673                               (length args)
 674                               args) #f))
 675          (if error-msg
 676              (scm-error 'markup-format ,make-name "Invalid argument in position ~A\n Expect: ~A\nFound: ~S." error-msg #f)
 677
 678              (cons ,foo-markup args)
 679              )))
 680     )
 681 )
 682
 683
 684
 685 (define (make-markup markup-function make-name signature args)
 686
 687   " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
 688 against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
 689 "
 690
 691   (let*
 692       ((arglen (length args))
 693        (siglen (length signature))
 694        (error-msg
 695         (if (and (> siglen 0) (> arglen 0))
 696             (markup-argument-list-error signature args 1)
 697             #f)))
 698
 699
 700     (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
 701         (scm-error 'markup-format make-name "Expect ~A arguments for ~A. Found ~A: ~S"
 702                    (list siglen
 703                          make-name
 704                          arglen
 705                          args) #f))
 706
 707     (if error-msg
 708         (scm-error 'markup-format make-name "Invalid argument in position ~A\nExpect: ~A\nFound: ~S." error-msg #f)
 709
 710         (cons markup-function  args)
 711         )))
 712
 713 (define (make-markup-maker entry)
 714   (let* (
 715          (name (symbol->string (procedure-name (car entry))))
 716          (make-name  (string-append "make-" name))
 717          (signature (object-property (car entry) 'markup-signature))
 718          )
 719
 720     `(define-public (,(string->symbol make-name) . args)
 721        (make-markup ,(car entry) ,make-name ,(cons 'list signature)  args)
 722        ))
 723   )
 724
 725 (eval
 726  (cons 'begin (map make-markup-maker markup-functions-and-signatures))
 727  markup-module
 728  )
 729
 730 ;;
 731 ;; TODO: add module argument so user-defined markups can also be
 732 ;; processed.
 733 ;;
 734 (define-public (lookup-markup-command code)
 735   (let*
 736       ((sym (string->symbol (string-append code "-markup")))
 737        (var (module-local-variable markup-module sym))
 738        )
 739     (if (eq? var #f)
 740         #f
 741         (cons (variable-ref var) (object-property  (variable-ref var) 'markup-keyword))
 742     )
 743   ))
 744
 745
 746 (define-public brew-new-markup-molecule Text_item::brew_molecule)
 747
 748 (define-public empty-markup (make-simple-markup ""))
 749
 750 (define-public interpret-markup Text_item::interpret_markup)
 751
 752
 753 ;;;;;;;;;;;;;;;;
 754 ;; utility
 755
 756 (define (markup-join markups sep)
 757   "Return line-markup of MARKUPS, joining them with markup SEP"
 758   (if (pair? markups)
 759       (make-line-markup (list-insert-separator markups sep))
 760       empty-markup))
 761
 762
 763 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 764
 765 (if #f
 766    (define (typecheck-with-error x)
 767      (catch
 768       'markup-format
 769       (lambda () (markup? x))
 770       (lambda (key message arg)
 771         (display "\nERROR: markup format error: \n")
 772         (display message)
 773         (newline)
 774         (write arg (current-output-port))
 775         )
 776       )))
 777
 778 ;; test make-foo-markup functions
 779 (if #f
 780     (begin
 781       (newline)
 782       (newline)
 783       (display (make-line-markup (list (make-simple-markup "FOO"))))
 784
 785       (make-line-markup (make-simple-markup "FOO"))
 786       (make-line-markup (make-simple-markup "FOO") (make-simple-markup "foo"))
 787       (make-raise-markup "foo" (make-simple-markup "foo"))
 788       )
 789     )
 790
 791
 792 ;;
 793 ;; test typecheckers. Not wholly useful, because errors are detected
 794 ;; in other places than they're made.
 795 ;;
 796 (if #f
 797  (begin
 798
 799    ;; To get error messages, see above to install the alternate
 800    ;; typecheck routine for markup?.
 801
 802
 803
 804    (display (typecheck-with-error `(,simple-markup "foobar")))
 805    (display (typecheck-with-error `(,simple-markup "foobar")))
 806    (display (typecheck-with-error `(,simple-markup 1)))
 807    (display
 808     (typecheck-with-error  `(,line-markup ((,simple-markup "foobar"))
 809                                           (,simple-markup 1))))
 810    (display
 811     (typecheck-with-error  `(,line-markup (,simple-markup "foobar")
 812                                          (,simple-markup "bla"))))
 813
 814    ))