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-name . ()) (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.  By using fractional values
 247 for DIR, you can obtain longer or shorter stems."
 248
 249   (let*
 250       (
 251        (log (car rest))
 252        (dot-count (cadr rest))
 253        (dir (caddr rest))
 254        (font (ly:get-font grob (cons '((font-family .  music)) props)))
 255        (stemlen (max 3 (- log 1)))
 256        (headgl
 257         (ly:find-glyph-by-name font (string-append "noteheads-" (number->string (min log 2)))))
 258
 259        (stemth 0.13)
 260        (stemy (* dir stemlen))
 261        (attachx (if (> dir 0) (- (cdr (ly:molecule-get-extent headgl X)) stemth)
 262                     0))
 263        (attachy (* dir 0.28))
 264        (stemgl (if (> log 0)
 265                    (ly:round-filled-box
 266                                      (cons attachx (+ attachx  stemth))
 267                                      (cons (min stemy attachy)
 268                                            (max stemy attachy))
 269                                     (/ stemth 3)
 270                                     ) #f))
 271        (dot (ly:find-glyph-by-name font "dots-dot"))
 272        (dotwid  (interval-length (ly:molecule-get-extent dot X)))
 273        (dots (if (> dot-count 0)
 274                  (apply ly:molecule-add
 275                   (map (lambda (x)
 276                          (ly:molecule-translate-axis
 277                           dot  (* (+ 1 (* 2 x)) dotwid) X) )
 278                        (iota dot-count 1)))
 279                  #f))
 280
 281        (flaggl (if (> log 2)
 282                    (ly:molecule-translate
 283                     (ly:find-glyph-by-name
 284                      font
 285                      (string-append "flags-"
 286                                     (if (> dir 0) "u" "d")
 287                                     (number->string log)
 288                                     ))
 289                     (cons (+ attachx (/ stemth 2)) stemy))
 290
 291                     #f)))
 292
 293     (if flaggl
 294         (set! stemgl (ly:molecule-add flaggl stemgl)))
 295
 296     (if (ly:molecule? stemgl)
 297         (set! stemgl (ly:molecule-add stemgl headgl))
 298         (set! stemgl headgl)
 299         )
 300
 301     (if (ly:molecule? dots)
 302         (set! stemgl
 303               (ly:molecule-add
 304                (ly:molecule-translate-axis
 305                 dots
 306                 (+
 307                  (if (and (> dir 0) (> log 2))
 308                      (* 1.5 dotwid) 0)
 309                  ;; huh ? why not necessary?
 310                 ;(cdr (ly:molecule-get-extent headgl X))
 311                       dotwid
 312                  )
 313                 X)
 314                stemgl
 315                )
 316               ))
 317
 318     stemgl
 319     ))
 320
 321 (define-public (normal-size-super-markup grob props . rest)
 322   (ly:molecule-translate-axis (interpret-markup
 323                                grob
 324                                props (car rest))
 325                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 326                               Y)
 327   )
 328
 329 (define-public (super-markup grob props  . rest)
 330   "Syntax: \\super MARKUP. "
 331   (ly:molecule-translate-axis (interpret-markup
 332                                grob
 333                                (cons '((font-relative-size . -2)) props) (car rest))
 334                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 335                               Y)
 336   )
 337
 338 (define-public (translate-markup grob props . rest)
 339   "Syntax: \\translate OFFSET MARKUP. "
 340   (ly:molecule-translate (interpret-markup  grob props (cadr rest))
 341                          (car rest))
 342
 343   )
 344
 345 (define-public (sub-markup grob props  . rest)
 346   "Syntax: \\sub MARKUP."
 347   (ly:molecule-translate-axis (interpret-markup
 348                                grob
 349                                (cons '((font-relative-size . -2)) props)
 350                                (car rest))
 351                               (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 352                               Y)
 353   )
 354
 355 (define-public (normal-size-sub-markup grob props . rest)
 356   (ly:molecule-translate-axis (interpret-markup
 357                                grob
 358                                props (car rest))
 359                               (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 360                               Y)
 361   )
 362
 363 (define-public (hbracket-markup grob props . rest)
 364   "Horizontal brackets around its single argument. Syntax \\hbracket MARKUP."
 365
 366   (let*
 367       (
 368        (th 0.1) ;; todo: take from GROB.
 369        (m (interpret-markup grob props (car rest)))
 370        )
 371
 372     (bracketify-molecule m X th (* 2.5 th) th)
 373 ))
 374
 375 (define-public (bracket-markup grob props . rest)
 376   "Vertical brackets around its single argument. Syntax \\bracket MARKUP."
 377   (let*
 378       (
 379        (th 0.1) ;; todo: take from GROB.
 380        (m (interpret-markup grob props (car rest)))
 381        )
 382
 383     (bracketify-molecule m Y th (* 2.5 th) th)
 384 ))
 385
 386 ;; todo: fix negative space
 387 (define (hspace-markup grob props . rest)
 388   "Syntax: \\hspace NUMBER."
 389   (let*
 390       ((amount (car rest)))
 391     (if (> amount 0)
 392         (ly:make-molecule "" (cons 0 amount) '(-1 . 1) )
 393         (ly:make-molecule "" (cons amount amount) '(-1 . 1)))
 394   ))
 395
 396 (define-public (override-markup grob props . rest)
 397   "Tack the 1st arg in REST onto PROPS, e.g.
 398
 399 \override #'(font-family . married) \"bla\"
 400
 401 "
 402
 403   (interpret-markup grob (cons (list (car rest)) props)
 404                     (cadr rest)))
 405
 406 (define-public (smaller-markup  grob props . rest)
 407   "Syntax: \\smaller MARKUP"
 408   (let*
 409       (
 410        (fs (cdr (chain-assoc 'font-relative-size props)))
 411        (entry (cons 'font-relative-size (- fs 1)))
 412        )
 413     (interpret-markup
 414      grob (cons (list entry) props)
 415      (car rest))
 416     ))
 417
 418 (define-public (bigger-markup  grob props . rest)
 419   "Syntax: \\bigger MARKUP"
 420   (let*
 421       (
 422        (fs (cdr (chain-assoc 'font-relative-size props)))
 423        (entry (cons 'font-relative-size (+ fs 1)))
 424        )
 425   (interpret-markup
 426    grob (cons (list entry) props)
 427    (car rest))
 428   ))
 429
 430 (define-public (box-markup grob props . rest)
 431   "Syntax: \\box MARKUP"
 432   (let*
 433       (
 434        (th 0.1)
 435        (pad 0.2)
 436        (m (interpret-markup grob props (car rest)))
 437        )
 438     (box-molecule m th pad)
 439   ))
 440
 441
 442 (define-public (strut-markup grob props . rest)
 443   "Syntax: \strut
 444
 445  A box of the same height as the space.
 446 "
 447
 448   (let*
 449       ((m (Text_item::interpret_markup grob props " ")))
 450
 451     (ly:molecule-set-extent! m 0 '(1000 . -1000))
 452     m))
 453
 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    ))