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