File: html.ml

package info (click to toggle)
hevea 1.10-12
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 2,128 kB
  • ctags: 2,379
  • sloc: ml: 19,637; sh: 264; makefile: 197
file content (732 lines) | stat: -rw-r--r-- 18,030 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
(***********************************************************************)
(*                                                                     *)
(*                          HEVEA                                      *)
(*                                                                     *)
(*  Luc Maranget, projet PARA, INRIA Rocquencourt                      *)
(*                                                                     *)
(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

let header = "$Id: html.ml,v 1.114 2007/03/09 13:23:52 maranget Exp $" 

(* Output function for a strange html model :
     - Text elements can occur anywhere and are given as in latex
     - A new grouping construct is given (open_group () ; close_group ())
*)

open Misc
open Parse_opts
open Latexmacros
open HtmlCommon

exception Error of string

type block = HtmlCommon.block

let addvsize x = flags.vsize <- flags.vsize + x 

(* Calls to other modules that are in the interface *)

let 
  over,
  erase_display,
  begin_item_display,
  end_item_display,
  force_item_display,
  item_display,
  do_close_display,
  do_open_display_varg,
  do_open_display,
  do_close_maths,
  do_open_maths, 
  put_in_math,
  math_put,
  math_put_char,
  left,
  right
    =
  if !Parse_opts.mathml then begin
    MathML.over,
    MathML.erase_display,
    MathML.begin_item_display,
    MathML.end_item_display,
    MathML.force_item_display,
    MathML.item_display,
    MathML.close_display,
    MathML.open_display_varg,
    MathML.open_display,
    MathML.close_maths,
    MathML.open_maths,
    MathML.put_in_math,
    MathML.put,
    MathML.put_char,
    MathML.left,
    MathML.right
  end else begin
    HtmlMath.over,
    HtmlMath.erase_display,
    HtmlMath.begin_item_display,
    HtmlMath.end_item_display,
    HtmlMath.force_item_display,
    HtmlMath.item_display,
    (fun () -> HtmlMath.close_display false),
    (HtmlMath.open_display_varg false),
    (fun () -> HtmlMath.open_display false),
    HtmlMath.close_maths,
    HtmlMath.open_maths,
    HtmlMath.put_in_math,
    HtmlMath.put,
    HtmlMath.put_char,
    HtmlMath.left,
    HtmlMath.right
  end
;;

let
  int_sup_sub,
  limit_sup_sub,
  standard_sup_sub
    =
  if !Parse_opts.mathml then
    MathML.int_sup_sub,
    MathML.limit_sup_sub,
    MathML.standard_sup_sub
  else
    HtmlMath.int_sup_sub,
    HtmlMath.limit_sup_sub,
    HtmlMath.standard_sup_sub
;;



let set_out out =  !cur_out.out <- out

and stop () =
  MyStack.push stacks.s_active !cur_out.out ;
  !cur_out.out <- Out.create_null ()

and restart () =
  !cur_out.out <- MyStack.pop stacks.s_active
;;


(* acces to flags *)
let is_empty () = flags.empty
;;

    

let debug m =
  Printf.fprintf stderr
    "%s : table_vsize=%d vsize=%d" m flags.table_vsize flags.vsize ;
  prerr_newline ()
;;

let debug_empty f =
  prerr_string (if f.empty then "empty=true" else "empty=false")
;;

let put s = 
  if flags.in_math then math_put s
  else HtmlCommon.put s
;;

let put_char c =
  if flags.in_math then math_put_char c
  else HtmlCommon.put_char c
;;

let put_unicode i = OutUnicode.html_put put put_char i

let loc_name _ = ()

  
(* freeze everyting and change output file *)

let open_chan chan =
  open_group "" ;
  free !cur_out ;
  !cur_out.out <- Out.create_chan chan ;
;;

let close_chan () =
  Out.close !cur_out.out ;
  !cur_out.out <- Out.create_buff () ;
  close_group ()
;;


let to_style f =
  let old_flags = copy_flags flags in
  open_block INTERN "" ;
(*  clearstyle () ; *)
  f () ;
  let r = to_pending !cur_out.pending !cur_out.active in
  erase_block INTERN ;
  set_flags flags old_flags ;
  r
;;

let get_current_output () = Out.to_string !cur_out.out


let finalize check =
  if check then begin
    check_stacks ()
  end else begin
    (* Flush output in case of fatal error *)
    let rec close_rec () =
      if not (MyStack.empty out_stack) then begin
        match MyStack.pop out_stack with
        | Freeze _ -> close_rec ()
        | Normal (_,_,pout) ->
            Out.copy !cur_out.out pout.out ;
            cur_out := pout ;
            close_rec ()
      end in
    close_rec ()
  end ;
  Out.close !cur_out.out ;
  !cur_out.out <- Out.create_null ()
;;


let put_separator () = put "\n"
;;

let unskip () = 
  Out.unskip !cur_out.out;
  if flags.blank then
    flags.empty <- true;
;;
  
let put_tag tag = put tag
;;

let put_nbsp () =
  if !Lexstate.whitepre || (flags.in_math && !Parse_opts.mathml) then begin
    put_char ' '
  end else
    put_unicode OutUnicode.nbsp
;;

let put_open_group () =
  put_char '{'
;;

let put_close_group () =
  put_char '}'
;;


let infomenu _ = ()
and infonode _opt _num _arg = ()
and infoextranode _num _arg _text = ()
;;


let image arg n = 
  if flags.in_pre && !Parse_opts.pedantic then begin
    warning "Image tag inside preformatted block, ignored"
  end else begin
    put "<IMG " ;
    if arg <> "" then begin
      put arg;
      put_char ' '
    end ;
    put "SRC=\"" ;
    put n ;
    if !Parse_opts.pedantic then begin
      put "\" ALT=\"" ;
      put n
    end ;
    put "\">"
  end
;;

type saved = HtmlCommon.saved

let check = HtmlCommon.check
and hot = HtmlCommon.hot

let forget_par () = None

let rec do_open_par () = match pblock () with
| GROUP ->
    let pending = to_pending !cur_out.pending !cur_out.active in
    let a,b,_ = top_out out_stack in
    ignore (close_block_loc check_empty GROUP) ;
    do_open_par () ;
    open_block a b ;
    !cur_out.pending <- pending
| P ->
    Misc.warning "Opening P twice" (* An error in fact ! *)
| s ->
    if !verbose > 2 then
      Printf.eprintf "Opening par below: '%s'\n" (string_of_block s) ;
    open_block P ""
    
let open_par () = do_open_par ()

let rec do_close_par () = match pblock () with
| GROUP ->
    let pending = to_pending !cur_out.pending !cur_out.active in
    let a,b,_ = top_out out_stack in
    ignore (close_block_loc check_empty GROUP) ;
    let r = do_close_par () in
    open_block a b ;
    !cur_out.pending <- pending ;
    r
| P ->
    ignore (close_flow_loc check_blank P) ;
    true
| _ ->
    false


let close_par () = do_close_par ()

(* Find P, maybe above groups *)
let rec find_prev_par () = match pblock () with
| P -> true
| GROUP ->
    let x = pop_out out_stack in
    let r = find_prev_par () in
    push_out out_stack x ;
    r
| _ -> false

let rec do_close_prev_par () = match pblock () with
| P ->
    ignore (close_flow_loc check_blank P)
| GROUP ->
    let pending = to_pending !cur_out.pending !cur_out.active in
    let b,a,_ = top_out out_stack in
    ignore (close_block_loc check_empty GROUP) ;
    do_close_prev_par () ;
    open_block b a ;
    !cur_out.pending <- pending
| _ -> assert false

let close_prev_par () =
  do_close_prev_par () ;
  flags.saw_par <- true

let rec do_par () = match pblock () with
| P ->
    ignore (close_flow_loc check_blank P) ; open_block P ""
| GROUP ->
    let pending = to_pending !cur_out.pending !cur_out.active in
    let b,a,_ = top_out out_stack in
    ignore (close_block_loc check_empty GROUP) ;
    do_par () ;
    open_block b a ;
    !cur_out.pending <- pending
| s ->
    if !verbose > 2 then
      Printf.eprintf "Opening par below: '%s'\n" (string_of_block s) ;
    open_block P ""
    
let par _ = do_par ()

(* Interface open block: manage par above *)    
let open_block_loc = open_block (* save a reference to basic open_block *)

let open_block_with_par ss s a =
  if transmit_par s && find_prev_par () then begin
    if !verbose > 2 then begin
      Printf.eprintf "OPEN: %s, closing par\n" ss ;
      Printf.eprintf "BEFORE: " ;
      pretty_stack out_stack
    end ;
    close_prev_par () ;
    if !verbose > 2 then begin
      Printf.eprintf "AFTER: " ;
      pretty_stack out_stack
    end
  end ;  
  open_block_loc s a

let open_block ss a = open_block_with_par ss (find_block ss) a

let open_display () =
  if find_prev_par () then begin
    close_prev_par ()
  end ;
  do_open_display ()

and open_display_varg a =
  if find_prev_par () then begin
    close_prev_par ()
  end ;
  do_open_display_varg a

and close_display () =
  do_close_display () ;
  if flags.saw_par then begin
    flags.saw_par <- false ;
    open_par () 
  end

let open_maths display =
  if display && find_prev_par () then begin
    close_prev_par ()
  end ;
  do_open_maths display

and close_maths display =
  do_close_maths display ;
  if flags.saw_par then begin
    flags.saw_par <- false ;
    open_par ()
  end


let wrap_close close_block s =
  let s = find_block s in
  begin match s with GROUP -> () | _ -> ignore (close_par ()) end ;
  begin match s with
  | UL|OL ->
      if flags.nitems > 0 then
	close_block LI	
      else
	warning "List with no item"
  | DL ->
      if flags.nitems > 0 then
	close_block DD
      else
	warning "List with no item"
  | _ -> ()
  end ;
  close_block s ;
  if flags.saw_par then begin
    flags.saw_par <- false ;
    if !verbose > 2 then begin
      Misc.warning "RE-OPEN PAR:" ;
      Printf.eprintf "BEFORE: " ;
      pretty_stack out_stack
    end ;
    open_par () ;
    if !verbose > 2 then begin
      Printf.eprintf "AFTER: " ;
      pretty_stack out_stack
    end
  end

let force_block_with_par s content =
  ignore (close_par ()) ;
  force_block s content

and close_block_with_par s =
  ignore (close_par ()) ;
  close_block s

and erase_block_with_par s =
  ignore (close_par ()) ;
  erase_block s

and force_block s content = wrap_close (fun s -> force_block s content) s
and close_block s = wrap_close close_block s
and erase_block s = wrap_close erase_block s
and close_flow s =
  prerr_endline ("FLOW: "^s) ;
  wrap_close close_flow s

let skip_line = skip_line
and flush_out = flush_out
and close_group = close_group
and open_aftergroup = open_aftergroup
and open_group = open_group
and insert_block s attr =
  if find_prev_par () then
    warning "Ignoring \\centering or \\ragged..."
  else
    insert_block (find_block s) attr
and insert_attr s = insert_attr (find_block s)
and erase_mods = erase_mods
and open_mod = open_mod
and has_mod = has_mod
and clearstyle = clearstyle
and nostyle = nostyle
and get_fontsize = get_fontsize
and to_string = to_string
;;

(****************************************)
(* Table stuff, must take P into acount *)
(****************************************)

let open_table border htmlargs =
  let _,arg_b, arg =
    if flags.in_math && !Parse_opts.mathml then
      "mtable","frame = \"solid\"",""
    else "TABLE","BORDER=1",htmlargs
  in
  (* open_block will close P (and record that) if appropriate *)
  if border then open_block_with_par "TABLE" TABLE (arg_b^" "^arg)
  else open_block_with_par "TABLE" TABLE arg
;;

let new_row () =
  if flags.in_math && !Parse_opts.mathml then
    open_block_loc (OTHER "mtr") ""
  else open_block_loc TR ""
;;


let attribut name = function
  | "" -> ""
  | s  -> " "^name^"="^s
and as_colspan = function
  |  1  -> ""
  |  n -> " COLSPAN="^string_of_int n
and as_colspan_mathml = function
  |  1  -> ""
  |  n -> " columnspan= \""^string_of_int n^"\""

let as_align f span = match f with
  Tabular.Align
    {Tabular.vert=v ; Tabular.hor=h ;
     Tabular.wrap=w ; Tabular.width=_} ->
    attribut "VALIGN" v^
    attribut "ALIGN" h^
    (if w then "" else " NOWRAP")^
    as_colspan span
| _       ->  raise (Misc.Fatal ("as_align"))
;;

let as_align_mathml f span = match f with
  Tabular.Align
    {Tabular.vert=v ; Tabular.hor=h } ->
    attribut "rowalign" ("\""^v^"\"")^
    attribut "columnalign" ("\""^h^"\"")^
    as_colspan_mathml span
| _       ->  raise (Misc.Fatal ("as_align_mathml"))
;;

let open_direct_cell attrs span =
  if flags.in_math && !Parse_opts.mathml then begin
    open_block_loc (OTHER "mtd") (attrs^as_colspan_mathml span);
    do_open_display ()
  end else open_block_loc TD (attrs^as_colspan span)

let open_cell format span _= 
  if flags.in_math && !Parse_opts.mathml then begin
    open_block_loc (OTHER "mtd") (as_align_mathml format span);
    do_open_display ()
  end else open_block_loc TD (as_align format span)
;;

(* By contrast closing/erasing TD, may in some occasions
   implies closing some internal P => use wrapped close functions *)
let erase_cell () =  
  if flags.in_math && !Parse_opts.mathml then begin
    erase_display ();
    erase_block_with_par (OTHER "mtd")
  end else erase_block_with_par TD

and close_cell content = 
  if flags.in_math && !Parse_opts.mathml then begin
    do_close_display ();
    force_block_with_par (OTHER "mtd") ""
  end else force_block_with_par TD content

and do_close_cell () = 
    if flags.in_math && !Parse_opts.mathml then begin
      do_close_display ();
      close_block_with_par (OTHER "mtd")
    end else close_block_with_par TD

and open_cell_group () = open_group ""
and close_cell_group () = close_group ()
and erase_cell_group () = erase_group ()
;;


let erase_row () = 
  if flags.in_math && !Parse_opts.mathml then
    HtmlCommon.erase_block (OTHER "mtr")
  else HtmlCommon.erase_block TR

and close_row () = 
  if flags.in_math && !Parse_opts.mathml then
    HtmlCommon.close_block (OTHER "mtr")
  else HtmlCommon.close_block TR
;;

let close_table () = 
  begin if flags.in_math && !Parse_opts.mathml then
    HtmlCommon.close_block (OTHER "mtable")
  else HtmlCommon.close_block TABLE
  end ;
  if flags.saw_par then begin
    flags.saw_par <- false ;
    open_par ()
  end
;;

let make_border _ = ()
;;


let center_format =
  Tabular.Align  {Tabular.hor="center" ; Tabular.vert = "top" ;
		   Tabular.wrap = false ; Tabular.pre = "" ; 
		   Tabular.post = "" ; Tabular.width = Length.Default} 
;;

let make_inside s multi =
  if not (multi) then begin
    if pblock ()=TD || pblock() = (OTHER "mtd") then begin
      close_cell "&nbsp;";
      open_cell center_format 1 0;
      put s;
    end else begin
      open_cell center_format 1 0;
      put s;
      close_cell "&nbsp;"
    end;
  end
;;


let make_hline w noborder =
  if noborder then begin
    new_row ();
    if not (flags.in_math && !Parse_opts.mathml) then begin
      open_direct_cell "CLASS=\"hbar\"" w ;
      close_cell ""
    end else begin
      open_cell center_format w 0;
      close_mods () ;
      put "<mo stretchy=\"true\" > &horbar; </mo>";
      force_item_display ();
      close_cell ""
    end;
    close_row ();
  end
;;

(* HR is not correct inside P *)
let horizontal_line attr width height =
  if find_prev_par () then begin
    close_prev_par ()
  end ;
  horizontal_line attr width height ;
  if flags.saw_par then begin
    flags.saw_par <- false ;
    open_par ()
  end

(* Lists also have to take P into account *)
let rec do_li s = match pblock () with
| P ->
    let pend = to_pending !cur_out.pending !cur_out.active in
    ignore (close_flow_loc check_blank P) ;
    do_li s ;
    !cur_out.pending <- pend
| LI ->
    ignore (close_flow_loc no_check LI) ;
    open_block_loc LI s
| GROUP ->
    let pend = to_pending !cur_out.pending !cur_out.active in
    let a,b,_ = top_out out_stack in
    ignore (close_block_loc check_empty GROUP) ;
    do_li s ;
    open_block_loc a b ;
    !cur_out.pending <- pend
| _ -> assert false    
    
    
  
let item s =
  if !verbose > 2 then begin
    prerr_string "=> item: stack=" ;
    pretty_stack out_stack
  end ;
  if flags.nitems > 0 then begin
    do_li s
  end else begin
    let saved =
      let pending = to_pending !cur_out.pending !cur_out.active in
      do_close_mods () ;
      ignore (close_par ()) ; (* in case some par opened before first \item *)
      let r = Out.to_string !cur_out.out in
      !cur_out.pending <- pending ;
      r in
    open_block_loc LI s ;
    do_put saved
  end ;
  if !verbose > 2 then begin
    prerr_string "<= item: stack=" ;
    pretty_stack out_stack
  end ;  
  flags.nitems <- flags.nitems+1

let nitem = item

let set_dt s = flags.dt <- s
and set_dcount s = flags.dcount <- s
;;

(*********************************************)
(*  s1 and s2 below are attributes to DR/DD  *)
(*********************************************)

let emit_dt_dd scan true_scan arg s1 s2 =
  open_block_loc DT s1 ;
  if flags.dcount <> "" then scan ("\\refstepcounter{"^ flags.dcount^"}") ;
  true_scan ("\\makelabel{"^arg^"}") ;
  ignore (close_block_loc no_check DT) ;
  open_block_loc DD s2
    
  
let rec do_dt_dd scan true_scan arg s1 s2 = match pblock () with
| P ->
    let pend = to_pending !cur_out.pending !cur_out.active in
    ignore (close_flow_loc check_blank P) ;
    do_dt_dd scan true_scan arg s1 s2  ;
    !cur_out.pending <- pend
| DD ->
    ignore (close_flow_loc no_check DD) ;
    emit_dt_dd scan true_scan arg s1 s2
| GROUP ->
    let pend = to_pending !cur_out.pending !cur_out.active in
    let a,b,_ = top_out out_stack in
    ignore (close_block_loc check_empty GROUP) ;
    do_dt_dd scan true_scan arg s1 s2 ;
    open_block_loc a b ;
    !cur_out.pending <- pend
| _ -> assert false    
    
let ditem scan arg s1 s2 =
  if !verbose > 2 then begin
    Printf.eprintf "=> DITEM: %s %s %s\n" arg s1 s2 ;
    prerr_string "ditem: stack=" ;
    pretty_stack out_stack
  end ;
  let true_scan =
    if flags.nitems = 0 then begin
      let pending = to_pending !cur_out.pending !cur_out.active in
      do_close_mods () ;
      ignore (close_par ()) ; (* in case some par opened before first \item *)
      let saved = Out.to_string !cur_out.out in
      !cur_out.pending <- pending ;
      (fun arg -> do_put saved ; scan arg)
    end
    else scan in
  begin if flags.nitems > 0 then
    do_dt_dd scan true_scan arg s1 s2
  else
    emit_dt_dd scan true_scan arg s1 s2
  end ;
  flags.nitems <- flags.nitems+1 ;
  if !verbose > 2 then begin
    Printf.eprintf "<= DITEM: %s %s %s\n" arg s1 s2 ;
    prerr_string "ditem: stack=" ;
    pretty_stack out_stack
  end ;