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
|
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
(* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(* $Id: pp.ml,v 1.5 2005/06/24 08:32:21 maranget Exp $ *)
(***********************************************************************)
open Printf
open Lexeme
open Tree
let potag chan ({txt=txt} as s)= output_string chan txt ; s
let rec pctag chan {ctxt=txt} = output_string chan txt
let rec tree po pc chan = function
| Text txt -> output_string chan txt
| Blanks txt ->
output_string chan txt
| Node (styles, ts) ->
let styles = po chan styles in
trees po pc chan ts ;
pc chan styles
| ONode (so,sc,ts) ->
output_string chan so ;
trees po pc chan ts ;
output_string chan sc
and trees po pc chan = function
| [] -> ()
| t::rem -> tree po pc chan t ; trees po pc chan rem
let ptree chan t = tree potag pctag chan t
and ptrees chan ts = trees potag pctag chan ts
open Htmltext
let rec sep_font = function
| [] -> [],[]
| {nat=(Size (Int _)|Face _|Color _)} as s::rem ->
let fs,os = sep_font rem in
s::fs,os
| s::rem ->
let fs,os = sep_font rem in
fs,s::os
let rec do_potags chan = function
| [] -> ()
| {txt=txt}::rem ->
output_string chan txt ;
do_potags chan rem
let rec do_pctags chan = function
| [] -> ()
| {ctxt=txt}::rem ->
do_pctags chan rem ;
output_string chan txt
let potags chan x =
let fs,os = sep_font x in
let styles = match fs with
| [] -> os
| {ctxt=ctxt}::_ ->
let txt =
"<" ^ String.sub ctxt 2 4 ^
List.fold_right
(fun {txt=atxt} r -> atxt ^ r)
fs ">" in
{nat=Other ; txt=txt ; ctxt=ctxt}::os in
(* output_char chan '[' ; *)
do_potags chan styles ;
(* output_char chan ']' ; *)
styles
and pctags chan x = do_pctags chan x
let tree chan t = tree potags pctags chan t
and trees chan ts = trees potags pctags chan ts
open Css
let style chan = function
| Other txt -> output_string chan txt
| Class (name,txt) ->
output_char chan '.' ; output_string chan name ;
output_string chan txt
let styles chan ids =
List.iter
(fun id ->
style chan id ;
output_char chan '\n')
ids
|
