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 12let header = "$Id: mathML.ml,v 1.29 2012-06-05 14:55:39 maranget Exp $" 13 14 15open Misc 16open Parse_opts 17open Element 18open HtmlCommon 19open MyStack 20 21(*----------*) 22(* DISPLAYS *) 23(*----------*) 24 25let begin_item_display f is_freeze = 26 if !verbose > 2 then begin 27 Printf.fprintf stderr "begin_item_display: ncols=%d empty=%s" flags.ncols (sbool flags.empty) ; 28 prerr_newline () 29 end ; 30 open_block (OTHER "mrow") ""; 31 open_block INTERN "" ; 32 if is_freeze then(* push out_stack (Freeze f) ;*)freeze f; 33 34 35and end_item_display () = 36 let f,is_freeze = pop_freeze () in 37 let _ = close_flow_loc check_empty INTERN in 38 if close_flow_loc check_empty (OTHER "mrow") then 39 flags.ncols <- flags.ncols + 1; 40 if !verbose > 2 then begin 41 Printf.fprintf stderr "end_item_display: ncols=%d stck: " flags.ncols; 42 pretty_stack out_stack 43 end; 44 flags.vsize,f,is_freeze 45 46 47and open_display () = 48 if !verbose > 2 then begin 49 Printf.fprintf stderr "open_display: " 50 end ; 51 try_open_display () ; 52 open_block (OTHER "mrow") ""; 53 do_put_char '\n'; 54 open_block INTERN "" ; 55 if !verbose > 2 then begin 56 pretty_cur !cur_out ; 57 prerr_endline "" 58 end 59 60 61and close_display () = 62 if !verbose > 2 then begin 63 prerr_flags "=> close_display" 64 end ; 65 if not (flush_freeze ()) then begin 66 close_flow INTERN ; 67 let n = flags.ncols in 68 if (n = 0 && not flags.blank) then begin 69 if !verbose > 2 then begin 70 prerr_string "No Display n=0" ; 71 (Out.debug stderr !cur_out.out); 72 prerr_endline "" 73 end; 74 let active = !cur_out.active and pending = !cur_out.pending in 75 do_close_mods () ; 76 let ps,_,ppout = pop_out out_stack in 77 if ps <> (OTHER "mrow") then 78 failclose "close_display" ps (OTHER "mrow") ; 79 try_close_block (OTHER "mrow"); 80 let old_out = !cur_out in 81 cur_out := ppout ; 82 do_close_mods () ; 83 Out.copy old_out.out !cur_out.out ; 84 flags.empty <- false ; flags.blank <- false ; 85 !cur_out.pending <- to_pending pending active 86 end else if (n=1 (*&& flags.blank*)) then begin 87 if !verbose > 2 then begin 88 prerr_string "No display n=1"; 89 (Out.debug stderr !cur_out.out); 90 prerr_endline "" ; 91 end; 92 let active = !cur_out.active and pending = !cur_out.pending in 93 let ps,_,pout = pop_out out_stack in 94 if ps<> (OTHER "mrow") then 95 failclose "close_display" ps (OTHER "mrow"); 96 try_close_block (OTHER "mrow") ; 97 let old_out = !cur_out in 98 cur_out := pout ; 99 do_close_mods () ; 100 if flags.blank then Out.copy_no_tag old_out.out !cur_out.out 101 else Out.copy old_out.out !cur_out.out; 102 flags.empty <- false ; flags.blank <- false ; 103 !cur_out.pending <- to_pending pending active 104 end else begin 105 if !verbose > 2 then begin 106 prerr_string ("One Display n="^string_of_int n) ; 107 (Out.debug stderr !cur_out.out); 108 prerr_endline "" 109 end; 110 flags.empty <- flags.blank ; 111 close_flow (OTHER "mrow") ; 112 do_put_char '\n'; 113 end ; 114 try_close_display () 115 end ; 116 if !verbose > 2 then 117 prerr_flags ("<= close_display") 118;; 119 120let open_display_varg _ = open_display () 121 122 123let do_item_display _force = 124 if !verbose > 2 then begin 125 prerr_endline ("Item Display in mathML ncols="^string_of_int flags.ncols^" table_inside="^sbool flags.table_inside) 126 end ; 127 let f,is_freeze = pop_freeze () in 128 if ((*force && *)not flags.empty) || flags.table_inside then 129 flags.ncols <- flags.ncols + 1 ; 130 let active = !cur_out.active 131 and pending = !cur_out.pending in 132 close_flow INTERN ; 133 open_block INTERN ""; 134 !cur_out.pending <- to_pending pending active; 135 !cur_out.active <- [] ; 136 if is_freeze then freeze f; 137 if !verbose > 2 then begin 138 prerr_string ("out item_display -> ncols="^string_of_int flags.ncols^" ") ; 139 pretty_stack out_stack 140 end ; 141;; 142 143let item_display () = do_item_display false 144and force_item_display () = do_item_display true 145;; 146 147let erase_display () = 148 erase_block INTERN ; 149 erase_block (OTHER "mrow"); 150 try_close_display () 151;; 152 153let open_maths display = 154 if !verbose > 1 then prerr_endline "=> open_maths"; 155 push stacks.s_in_math flags.in_math; 156 if display then do_put "<BR>\n"; 157 if not flags.in_math then open_block (OTHER "math") "align=\"center\"" 158 else erase_mods [Style "mtext"]; 159 do_put_char '\n'; 160 flags.in_math <- true; 161 open_display (); 162 open_display (); 163;; 164 165let close_maths _display = 166 if !verbose >1 then prerr_endline "=> close_maths"; 167 close_display (); 168 close_display (); 169 flags.in_math <- pop stacks.s_in_math ; 170 do_put_char '\n'; 171 if not flags.in_math then begin 172 close_block (OTHER "math") end 173 else open_mod (Style "mtext"); 174;; 175 176 177 178 179let insert_vdisplay open_fun = 180 if !verbose > 2 then begin 181 prerr_flags "=> insert_vdisplay" ; 182 end ; 183 try 184 let mods = to_pending !cur_out.pending !cur_out.active in 185 let bs,bargs,bout = pop_out out_stack in 186 if bs <> INTERN then 187 failclose "insert_vdisplay" bs INTERN ; 188 let ps,pargs,pout = pop_out out_stack in 189 if ps <> (OTHER "mrow") then 190 failclose "insert_vdisplay" ps (OTHER "mrow"); 191 let new_out = create_status_from_scratch false [] in 192 push_out out_stack (ps,pargs,new_out) ; 193 push_out out_stack (bs,bargs,bout) ; 194 close_display () ; 195 cur_out := pout ; 196 open_fun () ; 197 do_put (Out.to_string new_out.out) ; 198 flags.empty <- false ; flags.blank <- false ; 199 if !verbose > 2 then begin 200 prerr_string "insert_vdisplay -> " ; 201 pretty_mods stderr mods ; 202 prerr_newline () 203 end ; 204 if !verbose > 2 then 205 prerr_flags "<= insert_vdisplay" ; 206 mods 207 with PopFreeze -> 208 raise (UserError "wrong parenthesization"); 209;; 210 211 212(* delaying output .... *) 213(* 214let delay f = 215 if !verbose > 2 then 216 prerr_flags "=> delay" ; 217 push vsize_stack flags.vsize ; 218 flags.vsize <- 0; 219 push delay_stack f ; 220 open_block "DELAY" "" ; 221 if !verbose > 2 then 222 prerr_flags "<= delay" 223;; 224 225let flush x = 226 if !verbose > 2 then 227 prerr_flags ("=> flush arg is ``"^string_of_int x^"''"); 228 try_close_block "DELAY" ; 229 let ps,_,pout = pop_out out_stack in 230 if ps <> "DELAY" then 231 raise (Misc.Fatal ("html: Flush attempt on: "^ps)) ; 232 let mods = !cur_out.active @ !cur_out.pending in 233 do_close_mods () ; 234 let old_out = !cur_out in 235 cur_out := pout ; 236 let f = pop "delay" delay_stack in 237 f x ; 238 Out.copy old_out.out !cur_out.out ; 239 flags.empty <- false ; flags.blank <- false ; 240 free old_out ; 241 !cur_out.pending <- mods ; 242 flags.vsize <- max (pop "vsive" vsize_stack) flags.vsize ; 243 if !verbose > 2 then 244 prerr_flags "<= flush" 245;; 246*) 247 248(* put functions *) 249 250let is_digit = function 251 '1'|'2'|'3'|'4'|'5'|'6'|'7'|'8'|'9'|'0'|'.'|',' -> true 252 | _ -> false 253;; 254 255let is_number s = 256 let r = ref true in 257 for i = 0 to String.length s -1 do 258 r := !r && is_digit s.[i] 259 done; 260 !r 261;; 262 263 264let is_op = function 265 "+" | "-"|"/"|"*"|"%"|"<"|">"|"="|"("|")"|"{"|"}"|"["|"]"|","|";"|":"|"|"|"&"|"#"|"!"|"~"|"$" -> true 266| _ -> false 267;; 268 269let is_letter = function 270 | 'a'..'Z'|'A'..'Z' -> true 271 | _ -> false 272 273let is_ident s = 274 let r = ref true in 275 for i = 0 to String.length s-1 do 276 r := !r && is_letter s.[i] 277 done ; 278 !r 279 280let is_open_delim = function 281 | "(" | "[" | "{" | "<" -> true 282 | _ -> false 283and is_close_delim = function 284 | ")" | "]" | "}" | ">" -> true 285 | _ -> false 286;; 287 288let open_delim () = 289 open_display (); 290 freeze 291 ( fun () -> 292 close_display (); 293 close_display ();); 294 295and is_close () = 296 let f, is_freeze = pop_freeze () in 297 if is_freeze then begin 298 freeze f; 299 false 300 end else 301 true 302 303and close_delim () = 304 let _, is_freeze = pop_freeze () in 305 if is_freeze then begin 306 close_display (); 307 end else begin 308 close_display (); 309 open_display (); 310 warning "Math expression improperly parenthesized"; 311 end 312;; 313 314 315 316let put s = 317 if !verbose > 1 then 318 Printf.eprintf "MATH PUT: �%s�\n" s ; 319 let s_blank = 320 let r = ref true in 321 for i = 0 to String.length s - 1 do 322 r := !r && is_blank (String.get s i) 323 done ; 324 !r in 325 if not s_blank then begin 326 let s_op = is_op s 327 and s_number = is_number s in 328 if is_open_delim s then open_delim (); 329 let s_text = if is_close_delim s then is_close () else false in 330 if (s_op || s_number) && !Lexstate.display then force_item_display (); 331 do_pending () ; 332 flags.empty <- false; 333 flags.blank <- s_blank && flags.blank ; 334 if s_number then begin 335 do_put ("<mn> "^s^" </mn>\n") 336 end else if is_ident s then begin 337 do_put ("<mi> "^s^" </mi>\n") 338 end else if s_text then begin 339 do_put ("<mtext>"^s^"</mtext>") 340 end else if s_op then begin 341 do_put ("<mo> "^s^" </mo>\n"); 342 end else begin 343 do_put s 344 end; 345 if is_close_delim s then close_delim () 346 end 347;; 348 349let put_char c = 350 let c_blank = is_blank c in 351 if c <> ' ' then begin 352 let s = String.make 1 c in 353 let c_op = is_op s in 354 let c_digit = is_digit c in 355 if is_open_delim s then open_delim (); 356 let c_text = if is_close_delim s then is_close () else false in 357 if (c_op || c_digit) && !Lexstate.display then force_item_display (); 358 do_pending () ; 359 flags.empty <- false; 360 flags.blank <- c_blank && flags.blank ; 361 if c_digit then begin 362 do_put ("<mn> "^s^" </mn>\n") 363 end else if c_text then begin 364 do_put ("<mtext>"^s^"</mtext>") 365 end else if c_op then begin 366 do_put ("<mo> "^s^" </mo>\n"); 367 end else begin 368 do_put_char c; 369 end; 370 if is_close_delim s then close_delim (); 371 end 372;; 373 374let put_in_math s = 375 if flags.in_pre && !pedantic then 376 put s 377 else begin 378 if !Lexstate.display then force_item_display (); 379 do_pending () ; 380 do_put "<mi> "; 381 do_put s; 382 do_put " </mi>\n"; 383 flags.empty <- false; flags.blank <- false; 384 end 385;; 386 387 388 389(* Sup/Sub stuff *) 390let put_sup_sub display scanner (arg : string Lexstate.arg) = 391 if display then open_display () else open_block INTERN "" ; 392 scanner arg ; 393 if display then close_display () else close_block INTERN ; 394;; 395 396(* 397let insert_sub_sup tag s t = 398 let f, is_freeze = pop_freeze () in 399 let ps,pargs,pout = pop_out out_stack in 400 if ps <> INTERN then failclose "sup_sub" ps INTERN ; 401 let new_out = create_status_from_scratch false [] in 402 push_out out_stack (ps,pargs,new_out); 403 close_block INTERN; 404 cur_out := pout; 405 open_block tag ""; 406 open_display (); 407 let texte = Out.to_string new_out.out in 408 do_put (if texte = "" then "<mo> ⁢ </mo>" else texte); 409 flags.empty <- false; flags.blank <- false; 410 free new_out; 411 close_display (); 412 put_sub_sup s; 413 if t<>"" then put_sub_sup t; 414 close_block tag; 415 open_block INTERN ""; 416 if is_freeze then freeze f 417;; 418*) 419 420 421let standard_sup_sub scanner what sup sub display = 422 if !verbose > 1 then 423 Printf.eprintf "STANDARD �%s, %s� display=%B\n" 424 sup.Lexstate.arg sub.Lexstate.arg display ; 425 let sup, _ = 426 hidden_to_string (fun () -> put_sup_sub display scanner sup) in 427 let sub,_ = 428 hidden_to_string (fun () -> put_sup_sub display scanner sub) in 429 if !verbose > 1 then 430 Printf.eprintf "STANDARD FORMAT �%s, %s�\n" sup sub ; 431 match sub,sup with 432 | "","" -> what () 433 | a,"" -> 434 open_block (OTHER "msub") ""; 435 if display then open_display (); 436 what (); 437 if flags.empty then do_put "<mo> ⁢ </mo>" ; 438 if display then close_display (); 439 put a ; 440 close_block (OTHER "msub") ; 441 | "",b -> 442 open_block (OTHER "msup") ""; 443 if display then open_display (); 444 what (); 445 if flags.empty then do_put "<mo> ⁢ </mo>" ; 446 if display then close_display (); 447 put b ; 448 close_block (OTHER "msup") ; 449 | a,b -> 450 open_block (OTHER "msubsup") ""; 451 if display then open_display (); 452 what (); 453 if flags.empty then do_put "<mo> ⁢ </mo>" ; 454 if display then close_display (); 455 put a ; put "\n" ; put b ; 456 close_block (OTHER "msubsup") ; 457;; 458 459 460 461let limit_sup_sub scanner what sup sub display = 462 if !verbose > 1 then 463 Printf.eprintf "STANDARD �%s, %s�\n" sup.Lexstate.arg sub.Lexstate.arg ; 464 let sup, _ = 465 hidden_to_string (fun () -> put_sup_sub display scanner sup) in 466 let sub, _ = 467 hidden_to_string (fun () -> put_sup_sub display scanner sub) in 468 match sub,sup with 469 | "","" -> what () 470 | a,"" -> 471 open_block (OTHER "munder") ""; 472 if display then open_display (); 473 what (); 474 if flags.empty then do_put "<mo> ⁢ </mo>" ; 475 if display then close_display (); 476 do_put a ; 477 close_block (OTHER "munder") ; 478 | "",b -> 479 open_block (OTHER "mover") ""; 480 if display then open_display (); 481 what (); 482 if flags.empty then do_put "<mo> ⁢ </mo>" ; 483 if display then close_display (); 484 do_put b ; 485 close_block (OTHER "mover") ; 486 | a,b -> 487 open_block (OTHER "munderover") ""; 488 if display then open_display (); 489 what (); 490 if flags.empty then do_put "<mo> ⁢ </mo>" ; 491 if display then close_display (); 492 do_put a ; do_put "\n" ; do_put b ; 493 close_block (OTHER "munderover") ; 494;; 495 496let int_sup_sub _something _vsize scanner what sup sub display = 497 standard_sup_sub scanner what sup sub display 498;; 499 500 501let over _lexbuf = 502 force_item_display (); 503 let _mods = insert_vdisplay 504 (fun () -> 505 open_block (OTHER "mfrac") ""; 506 open_display ()) in 507 force_item_display (); 508 flags.ncols <- flags.ncols +1; 509 close_display () ; 510 open_display () ; 511 freeze 512 (fun () -> 513 force_item_display (); 514 flags.ncols <- flags.ncols +1; 515 close_display () ; 516 close_block (OTHER "mfrac")) 517;; 518 519let box_around_display _scanner _arg = ();; 520 521let over_align _align1 _align2 _display lexbuf = over lexbuf 522;; 523 524let tr = function 525 "<" -> "<" 526| ">" -> ">" 527| "\\{" -> "{" 528| "\\}" -> "}" 529| s -> s 530;; 531 532let left delim _ k = 533 force_item_display (); 534 open_display (); 535 if delim <>"." then put ("<mo> "^ tr delim^" </mo>"); 536 k 0 ; 537 force_item_display (); 538 freeze 539 ( fun () -> 540 force_item_display (); 541 close_display (); 542 warning "Left delimitor not matched with a right one."; 543 force_item_display (); 544 close_display ();) 545;; 546 547let right delim _ = 548 if !Lexstate.display then force_item_display (); 549 if delim <> "." then put ("<mo> "^tr delim^" </mo>"); 550 if !Lexstate.display then force_item_display (); 551 let f,is_freeze = pop_freeze () in 552 if not is_freeze then begin 553 warning "Right delimitor alone"; 554 close_display (); 555 open_display (); 556 end else begin 557 try 558 let ps,parg,pout = pop_out out_stack in 559 let pps,pparg,ppout = pop_out out_stack in 560 if pblock() = (OTHER "mfrac") then begin 561 warning "Right delimitor not matched with a left one."; 562 push_out out_stack (pps,pparg,ppout); 563 push_out out_stack (ps,parg,pout); 564 freeze f; 565 close_display (); 566 open_display (); 567 end else begin 568 push_out out_stack (pps,pparg,ppout); 569 push_out out_stack (ps,parg,pout); 570 close_display (); 571 end; 572 with PopFreeze -> raise (UserError ("Bad placement of right delimitor")); 573 end; 574 3 575;; 576