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