1(***********************************************************************) 2(* *) 3(* HEVEA *) 4(* *) 5(* Luc Maranget, projet PARA, INRIA Rocquencourt *) 6(* *) 7(* Copyright 1998 Institut National de Recherche en Informatique et *) 8(* Automatique. Distributed only by permission. *) 9(* *) 10(***********************************************************************) 11 12(* Output function for a strange html model : 13 - Text elements can occur anywhere and are given as in latex 14 - A new grouping construct is given (open_group () ; close_group ()) 15*) 16 17open Misc 18open HtmlCommon 19open Printf 20 21exception Error of string 22 23 24let addvsize x = flags.vsize <- flags.vsize + x 25 26(* Calls to other modules that are in the interface *) 27 28let 29 over, 30 erase_display, 31 _begin_item_display, 32 _end_item_display, 33 force_item_display, 34 item_display, 35 do_close_display, 36 do_open_display_varg, 37 do_open_display, 38 do_close_maths, 39 do_open_maths, 40 put_in_math, 41 math_put, 42 math_put_char, 43 left, 44 right 45 = 46 if !Parse_opts.mathml then begin 47 MathML.over, 48 MathML.erase_display, 49 MathML.begin_item_display, 50 MathML.end_item_display, 51 MathML.force_item_display, 52 MathML.item_display, 53 MathML.close_display, 54 MathML.open_display_varg, 55 MathML.open_display, 56 MathML.close_maths, 57 MathML.open_maths, 58 MathML.put_in_math, 59 MathML.put, 60 MathML.put_char, 61 MathML.left, 62 MathML.right 63 end else begin 64 HtmlMath.over, 65 HtmlMath.erase_display, 66 HtmlMath.begin_item_display, 67 HtmlMath.end_item_display, 68 HtmlMath.force_item_display, 69 HtmlMath.item_display, 70 (fun () -> HtmlMath.close_display false), 71 (HtmlMath.open_display_varg false), 72 (fun () -> HtmlMath.open_display false), 73 HtmlMath.close_maths, 74 HtmlMath.open_maths, 75 HtmlMath.put_in_math, 76 HtmlMath.put, 77 HtmlMath.put_char, 78 HtmlMath.left, 79 HtmlMath.right 80 end 81 82let 83 int_sup_sub, 84 limit_sup_sub, 85 standard_sup_sub 86 = 87 if !Parse_opts.mathml then 88 MathML.int_sup_sub, 89 MathML.limit_sup_sub, 90 MathML.standard_sup_sub 91 else 92 HtmlMath.int_sup_sub, 93 HtmlMath.limit_sup_sub, 94 HtmlMath.standard_sup_sub 95 96 97 98let set_out out = !cur_out.out <- out 99 100and stop () = 101 MyStack.push stacks.s_active !cur_out.out ; 102 !cur_out.out <- Out.create_null () 103 104and restart () = 105 !cur_out.out <- MyStack.pop stacks.s_active 106 107 108(* acces to flags *) 109let is_empty () = flags.empty 110 111 112 113let put s = 114 if flags.in_math then math_put s 115 else HtmlCommon.put s 116 117 118let put_char c = 119 if flags.in_math then math_put_char c 120 else HtmlCommon.put_char c 121 122let put_unicode i = OutUnicode.html_put put put_char i 123 124let loc_name _ = () 125 126 127(* freeze everyting and change output file *) 128 129let open_chan chan = 130 open_group "" ; 131 !cur_out.out <- Out.create_chan chan 132 133let close_chan () = 134 Out.close !cur_out.out ; 135 !cur_out.out <- Out.create_buff () ; 136 close_group () 137 138 139let to_style f = 140 let old_flags = copy_flags flags in 141 open_block INTERN "" ; 142 (* clearstyle () ; *) 143 f () ; 144 let r = to_pending !cur_out.pending !cur_out.active in 145 erase_block INTERN ; 146 set_flags flags old_flags ; 147 r 148 149let get_current_output () = Out.to_string !cur_out.out 150 151 152let finalize check = 153 if check then begin 154 check_stacks () 155 end else begin 156 (* Flush output in case of fatal error *) 157 let rec close_rec () = 158 if not (MyStack.empty out_stack) then begin 159 match MyStack.pop out_stack with 160 | Freeze _ -> close_rec () 161 | Normal (_,_,pout) -> 162 Out.copy !cur_out.out pout.out ; 163 cur_out := pout ; 164 close_rec () 165 end in 166 close_rec () 167 end ; 168 Out.close !cur_out.out ; 169 !cur_out.out <- Out.create_null () 170 171 172let put_separator () = put "\n" 173 174let unskip () = 175 Out.unskip !cur_out.out; 176 if flags.blank then 177 flags.empty <- true 178 179let put_tag tag = put tag 180 181let put_nbsp () = 182 if !Lexstate.whitepre || (flags.in_math && !Parse_opts.mathml) then begin 183 put_char ' ' 184 end else 185 put_unicode OutUnicode.nbsp 186 187let put_open_group () = 188 put_char '{' 189 190let put_close_group () = 191 put_char '}' 192 193 194let infomenu _ = () 195and infonode _opt _num _arg = () 196and infoextranode _num _arg _text = () 197 198 199let image arg n = 200 if flags.in_pre && !Parse_opts.pedantic then begin 201 warning "Image tag inside preformatted block, ignored" 202 end else begin 203 put "<img " ; 204 if arg <> "" then begin 205 put arg; 206 put_char ' ' 207 end ; 208 put "src=\"" ; 209 put n ; 210 if !Parse_opts.pedantic then begin 211 put "\" alt=\"" ; 212 put n 213 end ; 214 put "\">" 215 end 216 217type saved = HtmlCommon.saved 218 219let check = HtmlCommon.check 220and hot = HtmlCommon.hot 221 222let forget_par () = None 223 224let rec do_open_par () = match pblock () with 225 | GROUP -> 226 let pending = to_pending !cur_out.pending !cur_out.active in 227 let a,b,_ = top_out out_stack in 228 ignore (close_block_loc check_empty GROUP) ; 229 do_open_par () ; 230 open_block a b ; 231 !cur_out.pending <- pending 232 | P -> 233 Misc.warning "Opening P twice" (* An error in fact ! *) 234 | s -> 235 if !verbose > 2 then 236 Printf.eprintf "Opening par below: '%s'\n" (string_of_block s) ; 237 open_block P "" 238 239let open_par () = do_open_par () 240 241let rec do_close_par () = match pblock () with 242 | GROUP -> 243 let pending = to_pending !cur_out.pending !cur_out.active in 244 let a,b,_ = top_out out_stack in 245 ignore (close_block_loc check_empty GROUP) ; 246 let r = do_close_par () in 247 open_block a b ; 248 !cur_out.pending <- pending ; 249 r 250 | P -> 251 ignore (close_flow_loc check_blank P) ; 252 true 253 | _ -> 254 false 255 256 257let close_par () = do_close_par () 258 259(* Find P, maybe above groups *) 260let rec find_prev_par () = match pblock () with 261 | P -> true 262 | GROUP -> 263 let x = pop_out out_stack in 264 let r = find_prev_par () in 265 push_out out_stack x ; 266 r 267 | _ -> false 268 269let rec do_close_prev_par () = match pblock () with 270 | P -> 271 ignore (close_flow_loc check_blank P) 272 | GROUP -> 273 let pending = to_pending !cur_out.pending !cur_out.active in 274 let b,a,_ = top_out out_stack in 275 ignore (close_block_loc check_empty GROUP) ; 276 do_close_prev_par () ; 277 open_block b a ; 278 !cur_out.pending <- pending 279 | _ -> assert false 280 281let close_prev_par () = 282 do_close_prev_par () ; 283 flags.saw_par <- true 284 285let rec do_par () = match pblock () with 286 | P -> 287 ignore (close_flow_loc check_blank P) ; open_block P "" 288 | GROUP -> 289 let pending = to_pending !cur_out.pending !cur_out.active in 290 let b,a,_ = top_out out_stack in 291 ignore (close_block_loc check_empty GROUP) ; 292 do_par () ; 293 open_block b a ; 294 !cur_out.pending <- pending 295 | s -> 296 if !verbose > 2 then 297 Printf.eprintf "Opening par below: '%s'\n" (string_of_block s) ; 298 open_block P "" 299 300let par _ = do_par () 301 302(* Interface open block: manage par above *) 303let open_block_loc = open_block (* save a reference to basic open_block *) 304 305let open_block_with_par ss s a = 306 if transmit_par s && find_prev_par () then begin 307 if !verbose > 2 then begin 308 Printf.eprintf "OPEN: %s, closing par\n" ss ; 309 Printf.eprintf "BEFORE: " ; 310 pretty_stack out_stack 311 end ; 312 close_prev_par () ; 313 if !verbose > 2 then begin 314 Printf.eprintf "AFTER: " ; 315 pretty_stack out_stack 316 end 317 end ; 318 open_block_loc s a 319 320let open_block ss a = open_block_with_par ss (find_block ss) a 321 322let open_display () = 323 if find_prev_par () then begin 324 close_prev_par () 325 end ; 326 do_open_display () 327 328and open_display_varg a = 329 if find_prev_par () then begin 330 close_prev_par () 331 end ; 332 do_open_display_varg a 333 334and close_display () = 335 do_close_display () ; 336 if flags.saw_par then begin 337 flags.saw_par <- false ; 338 open_par () 339 end 340 341let open_maths display = 342 if display && find_prev_par () then begin 343 close_prev_par () 344 end ; 345 do_open_maths display 346 347and close_maths display = 348 do_close_maths display ; 349 if flags.saw_par then begin 350 flags.saw_par <- false ; 351 open_par () 352 end 353 354 355let wrap_close close_block s = 356 let s = find_block s in 357 begin match s with GROUP -> () | _ -> ignore (close_par ()) end ; 358 begin match s with 359 | UL|OL -> 360 if flags.nitems > 0 then 361 close_block LI 362 else 363 warning "List with no item" 364 | DL -> 365 if flags.nitems > 0 then 366 close_block DD 367 else 368 warning "List with no item" 369 | _ -> () 370 end ; 371 close_block s ; 372 if flags.saw_par then begin 373 flags.saw_par <- false ; 374 if !verbose > 2 then begin 375 Misc.warning "RE-OPEN PAR:" ; 376 Printf.eprintf "BEFORE: " ; 377 pretty_stack out_stack 378 end ; 379 open_par () ; 380 if !verbose > 2 then begin 381 Printf.eprintf "AFTER: " ; 382 pretty_stack out_stack 383 end 384 end 385 386let force_block_with_par s content = 387 ignore (close_par ()) ; 388 force_block s content 389 390and close_block_with_par s = 391 ignore (close_par ()) ; 392 close_block s 393 394and erase_block_with_par s = 395 ignore (close_par ()) ; 396 erase_block s 397 398and force_block s content = wrap_close (fun s -> force_block s content) s 399and close_block s = wrap_close close_block s 400and erase_block s = wrap_close erase_block s 401and close_flow s = 402 prerr_endline ("FLOW: "^s) ; 403 wrap_close close_flow s 404 405let skip_line = skip_line 406and flush_out = flush_out 407and close_group = close_group 408and open_aftergroup = open_aftergroup 409and open_group = open_group 410and insert_block s attr = 411 if find_prev_par () then 412 warning "Ignoring \\centering or \\ragged..." 413 else 414 insert_block (find_block s) attr 415and insert_attr s = insert_attr (find_block s) 416and erase_mods = erase_mods 417and open_mod = open_mod 418and has_mod = has_mod 419and clearstyle = clearstyle 420and nostyle = nostyle 421and get_fontsize = get_fontsize 422and to_string = to_string 423 424(****************************************) 425(* Table stuff, must take P into acount *) 426(****************************************) 427 428let open_table border htmlargs = 429 let _,arg_b, arg = 430 if flags.in_math && !Parse_opts.mathml then 431 "mtable","frame = \"solid\"","" 432 else "table","border=1",htmlargs 433 in 434 (* open_block will close P (and record that) if appropriate *) 435 if border then open_block_with_par "table" TABLE (arg_b^" "^arg) 436 else open_block_with_par "table" TABLE arg 437 438let new_row () = 439 if flags.in_math && !Parse_opts.mathml then 440 open_block_loc (OTHER "mtr") "" 441 else open_block_loc TR "" 442 443 444let attribut name = function 445 | "" -> "" 446 | s -> " "^name^"="^s 447and as_colspan = function 448 | 1 -> "" 449 | n -> " colspan="^string_of_int n 450and as_colspan_mathml = function 451 | 1 -> "" 452 | n -> " columnspan= \""^string_of_int n^"\"" 453and style param value = 454 if value = "" then "" 455 else sprintf "%s:%s;" param value 456 457let as_align f span border = match f with 458 Tabular.Align 459 {Tabular.vert=v ; Tabular.hor=h ; 460 Tabular.wrap=w ; Tabular.width=_} -> 461 sprintf "style=\"%s%s%s%s\" %s" 462 (style "vertical-align" v) 463 (style "text-align" h) 464 (if border then "border:solid 1px;" else "") 465 (if w then "" else "white-space:nowrap") 466 (as_colspan span) 467 | _ -> raise (Misc.Fatal ("as_align")) 468 469let as_align_mathml f span = match f with 470 Tabular.Align 471 {Tabular.vert=v ; Tabular.hor=h } -> 472 attribut "rowalign" ("\""^v^"\"")^ 473 attribut "columnalign" ("\""^h^"\"")^ 474 as_colspan_mathml span 475 | _ -> raise (Misc.Fatal ("as_align_mathml")) 476 477let open_direct_cell attrs span = 478 if flags.in_math && !Parse_opts.mathml then begin 479 open_block_loc (OTHER "mtd") (attrs^as_colspan_mathml span); 480 do_open_display () 481 end else open_block_loc TD (attrs^as_colspan span) 482 483let open_cell format span _ border = 484 if flags.in_math && !Parse_opts.mathml then begin 485 open_block_loc (OTHER "mtd") (as_align_mathml format span); 486 do_open_display () 487 end else open_block_loc TD (as_align format span border) 488 489(* By contrast closing/erasing TD, may in some occasions 490 implies closing some internal P => use wrapped close functions *) 491let erase_cell () = 492 if flags.in_math && !Parse_opts.mathml then begin 493 erase_display (); 494 erase_block_with_par (OTHER "mtd") 495 end else erase_block_with_par TD 496 497and close_cell content = 498 if flags.in_math && !Parse_opts.mathml then begin 499 do_close_display (); 500 force_block_with_par (OTHER "mtd") "" 501 end else force_block_with_par TD content 502 503and do_close_cell () = 504 if flags.in_math && !Parse_opts.mathml then begin 505 do_close_display (); 506 close_block_with_par (OTHER "mtd") 507 end else close_block_with_par TD 508 509and open_cell_group () = open_group "" 510and close_cell_group () = close_group () 511and erase_cell_group () = erase_group () 512 513 514let erase_row () = 515 if flags.in_math && !Parse_opts.mathml then 516 HtmlCommon.erase_block (OTHER "mtr") 517 else HtmlCommon.erase_block TR 518 519and close_row () = 520 if flags.in_math && !Parse_opts.mathml then 521 HtmlCommon.close_block (OTHER "mtr") 522 else HtmlCommon.close_block TR 523 524let close_table () = 525 begin if flags.in_math && !Parse_opts.mathml then 526 HtmlCommon.close_block (OTHER "mtable") 527 else HtmlCommon.close_block TABLE 528 end ; 529 if flags.saw_par then begin 530 flags.saw_par <- false ; 531 open_par () 532 end 533 534let make_border _ = () 535 536 537let inside_format = 538 Tabular.Align {Tabular.hor="center" ; Tabular.vert = "" ; 539 Tabular.wrap = false ; Tabular.pre = "" ; 540 Tabular.post = "" ; Tabular.width = Length.Default} 541and hline_format = 542 Tabular.Align {Tabular.hor="center" ; Tabular.vert = "top" ; 543 Tabular.wrap = false ; Tabular.pre = "" ; 544 Tabular.post = "" ; Tabular.width = Length.Default} 545 546let make_inside s multi = 547 if not (multi) then begin 548 if pblock ()=TD || pblock() = (OTHER "mtd") then begin 549 close_cell " "; 550 open_cell inside_format 1 0 false; 551 put s; 552 end else begin 553 open_cell inside_format 1 0 false; 554 put s; 555 close_cell " " 556 end; 557 end 558 559 560let make_hline w noborder = 561 if noborder then begin 562 new_row (); 563 if not (flags.in_math && !Parse_opts.mathml) then begin 564 open_direct_cell "class=\"hbar\"" w ; 565 close_cell "" 566 end else begin 567 open_cell hline_format w 0 false; 568 close_mods () ; 569 put "<mo stretchy=\"true\" > ― </mo>"; 570 force_item_display (); 571 close_cell "" 572 end; 573 close_row (); 574 end 575 576(* HR is not correct inside P *) 577let horizontal_line attr width height = 578 if find_prev_par () then begin 579 close_prev_par () 580 end ; 581 horizontal_line attr width height ; 582 if flags.saw_par then begin 583 flags.saw_par <- false ; 584 open_par () 585 end 586 587(* Lists also have to take P into account *) 588let rec do_li s = match pblock () with 589 | P -> 590 let pend = to_pending !cur_out.pending !cur_out.active in 591 ignore (close_flow_loc check_blank P) ; 592 do_li s ; 593 !cur_out.pending <- pend 594 | LI -> 595 ignore (close_flow_loc no_check LI) ; 596 open_block_loc LI s 597 | GROUP -> 598 let pend = to_pending !cur_out.pending !cur_out.active in 599 let a,b,_ = top_out out_stack in 600 ignore (close_block_loc check_empty GROUP) ; 601 do_li s ; 602 open_block_loc a b ; 603 !cur_out.pending <- pend 604 | _ -> assert false 605 606 607 608let item s = 609 if !verbose > 2 then begin 610 prerr_string "=> item: stack=" ; 611 pretty_stack out_stack 612 end ; 613 if flags.nitems > 0 then begin 614 do_li s 615 end else begin 616 let saved = 617 let pending = to_pending !cur_out.pending !cur_out.active in 618 do_close_mods () ; 619 ignore (close_par ()) ; (* in case some par opened before first \item *) 620 let r = Out.to_string !cur_out.out in 621 !cur_out.pending <- pending ; 622 r in 623 open_block_loc LI s ; 624 do_put saved 625 end ; 626 if !verbose > 2 then begin 627 prerr_string "<= item: stack=" ; 628 pretty_stack out_stack 629 end ; 630 flags.nitems <- flags.nitems+1 631 632let nitem = item 633 634and set_dcount s = flags.dcount <- s 635 636(*********************************************) 637(* s1 and s2 below are attributes to DR/DD *) 638(*********************************************) 639 640let emit_dt_dd scan true_scan arg s1 s2 = 641 open_block_loc DT s1 ; 642 if flags.dcount <> "" then scan ("\\refstepcounter{"^ flags.dcount^"}") ; 643 true_scan ("\\makelabel{"^arg^"}") ; 644 ignore (close_block_loc no_check DT) ; 645 open_block_loc DD s2 646 647 648let rec do_dt_dd scan true_scan arg s1 s2 = match pblock () with 649 | P -> 650 let pend = to_pending !cur_out.pending !cur_out.active in 651 ignore (close_flow_loc check_blank P) ; 652 do_dt_dd scan true_scan arg s1 s2 ; 653 !cur_out.pending <- pend 654 | DD -> 655 ignore (close_flow_loc no_check DD) ; 656 emit_dt_dd scan true_scan arg s1 s2 657 | GROUP -> 658 let pend = to_pending !cur_out.pending !cur_out.active in 659 let a,b,_ = top_out out_stack in 660 ignore (close_block_loc check_empty GROUP) ; 661 do_dt_dd scan true_scan arg s1 s2 ; 662 open_block_loc a b ; 663 !cur_out.pending <- pend 664 | _ -> assert false 665 666let ditem scan arg s1 s2 = 667 if !verbose > 2 then begin 668 Printf.eprintf "=> DITEM: �%s� �%s� �%s�\n" arg s1 s2 ; 669 prerr_string "ditem: stack=" ; 670 pretty_stack out_stack 671 end ; 672 let true_scan = 673 if flags.nitems = 0 then begin 674 let pending = to_pending !cur_out.pending !cur_out.active in 675 do_close_mods () ; 676 ignore (close_par ()) ; (* in case some par opened before first \item *) 677 let saved = Out.to_string !cur_out.out in 678 !cur_out.pending <- pending ; 679 (fun arg -> do_put saved ; scan arg) 680 end 681 else scan in 682 begin if flags.nitems > 0 then 683 do_dt_dd scan true_scan arg s1 s2 684 else 685 emit_dt_dd scan true_scan arg s1 s2 686 end ; 687 flags.nitems <- flags.nitems+1 ; 688 if !verbose > 2 then begin 689 Printf.eprintf "<= DITEM: �%s� �%s� �%s�\n" arg s1 s2 ; 690 prerr_string "ditem: stack=" ; 691 pretty_stack out_stack 692 end ; 693