File: output.ml

package info (click to toggle)
caml2html 1.4.3-1
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd, stretch
  • size: 300 kB
  • sloc: ml: 1,996; makefile: 162
file content (530 lines) | stat: -rw-r--r-- 14,892 bytes parent folder | download | duplicates (2)
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
(* $Id$ *)
(* 
   Copyright 2002-2004 S´┐Żbastien Ailleret
   Copyright 2004 Martin Jambon
   
   This file is distributed under the terms of the GNU Public License
   http://www.gnu.org/licenses/gpl.txt
*)

(*
   This module provides functions that parse OCaml source code and return
   a list of tokens which are suitable for automatic syntax highlighting.
   Any input is accepted. Only a lexical analysis is performed and thus can
   be used to highlight incorrect programs as well as derivatives
   of OCaml (.ml .mli .mll .mly).
*)

open Printf

let version = "caml2html " ^ Version.version

type class_definition = (string list * (string * string) list)

(* This will be come before the token-specific color definitions *)
let default_default_style : class_definition list = 
  [ ["code"; "pre"], [ "color", "black";
		       "background-color", "white" ];
    ["a.Cannot"], [ "color", "black";
		    "text-decoration", "none" ] ]

let key_color1 = Some "green"
let key_color2 = Some "#77aaaa"
let key_color3 = Some "#cc9900"
let key_color4 = Some "#990099"
let key_color5 = Some "#808080"

let construct_color = (Some "#0033cc", None, "Cconstructor")
let comment_color = (Some "#990000", None, "Ccomment")
let string_color = (Some "#aa4444", None, "Cstring")
let quotation_color = (None, None, "Cquotation")
let annot_color = (None, Some "#b4eeb4", "Cannot:hover")
let background_color = (None, Some "white", "Cbackground")
let linenum_color = (Some "black", Some "silver", "Clinenum")

let alpha_keyword_color = (key_color5, None, "Calphakeyword")
let nonalpha_keyword_color = (None, None, "Cnonalphakeyword")

let default_keyword_color_list =
  [
    "and", (key_color1, None, "Cand");
    "as", (key_color1, None, "Cas");
    "class", (key_color1, None, "Cclass");
    "constraint", (key_color1, None, "Cconstraint");
    "exception", (key_color1, None, "Cexception");
    "external", (key_color1, None, "Cexternal");
    "fun", (key_color1, None, "Cfun");
    "function", (key_color1, None, "Cfunction");
    "functor", (key_color1, None, "Cfunctor");
    "in", (key_color1, None, "Cin");
    "inherit", (key_color1, None, "Cinherit");
    "initializer", (key_color1, None, "Cinitializer");
    "let", (key_color1, None, "Clet");
    "method", (key_color1, None, "Cmethod");
    "module", (key_color1, None, "Cmodule");
    "mutable", (key_color1, None, "Cmutable");
    "of", (key_color1, None, "Cof");
    "private", (key_color1, None, "Cprivate");
    "rec", (key_color1, None, "Crec");
    "type", (key_color1, None, "Ctype");
    "val", (key_color1, None, "Cval");
    "virtual", (key_color1, None, "Cvirtual");
    
    "do", (key_color2, None, "Cdo");
    "done", (key_color2, None, "Cdone");
    "downto", (key_color2, None, "Cdownto");
    "else", (key_color2, None, "Celse");
    "for", (key_color2, None, "Cfor");
    "if", (key_color2, None, "Cif");
    "lazy", (key_color2, None, "Clazy");
    "match", (key_color2, None, "Cmatch");
    "new", (key_color2, None, "Cnew");
    "or", (key_color2, None, "Cor");
    "then", (key_color2, None, "Cthen");
    "to", (key_color2, None, "Cto");
    "try", (key_color2, None, "Ctry");
    "when", (key_color2, None, "Cwhen");
    "while", (key_color2, None, "Cwhile");
    "with", (key_color2, None, "Cwith");
    
    "assert", (key_color3, None, "Cassert");
    "include", (key_color3, None, "Cinclude");
    "open", (key_color3, None, "Copen");
    
    "begin", (key_color4, None, "Cbegin");
    "end", (key_color4, None, "Cend");
    "object", (key_color4, None, "Cobject");
    "sig", (key_color4, None, "Csig");
    "struct", (key_color4, None, "Cstruct");
    
    "raise", (Some "red", None, "Craise");

    "asr", (key_color5, None, "Casr");
    "land", (key_color5, None, "Cland");
    "lor", (key_color5, None, "Clor");
    "lsl", (key_color5, None, "Clsl");
    "lsr", (key_color5, None, "Clsr");
    "lxor", (key_color5, None, "Clxor");
    "mod", (key_color5, None, "Cmod");
    
    "false", (None, None, "Cfalse");
    "true", (None, None, "Ctrue");

    "|", (key_color2, None, "Cbar");
  ]

let default_keyword_colors =
  let tbl = Hashtbl.create 100 in
  List.iter
    (fun (s, (color, bgcolor, css_class)) -> 
       Hashtbl.add tbl s (color, bgcolor, css_class))
    default_keyword_color_list;
  tbl

let all_colors =
  linenum_color ::
  background_color ::
  construct_color ::
    comment_color ::
    annot_color ::
    string_color ::
    quotation_color ::
    alpha_keyword_color ::
    nonalpha_keyword_color ::
    (List.map snd default_keyword_color_list)

let make_style l =
  String.concat ";" (List.map (fun (name, value) -> name ^ ":" ^ value) l)

let inline_style (fg, bg, _class) =
  let colors = [] in
  let colors =
    match fg with 
	None -> colors
      | Some color -> ("color:" ^ color) :: colors in
  let colors =
    match bg with
	None -> colors
      | Some color -> ("background-color:" ^ color) :: colors in
  String.concat ";" colors

let make_classes
  ?(default = default_default_style)
  ?(colors = all_colors) () =
  let buf = Buffer.create 2000 in

  List.iter 
    (fun (classnames, style) ->
       if classnames <> [] then
	 bprintf buf "%s { %s }" 
	   (String.concat "," classnames) (make_style style))
    default;

  let color_groups = 
    Hashtbl2.list_all (Hashtbl2.of_list 50
			 (List.map (fun (a,b,c) -> ((a,b),c)) colors)) in
  List.iter 
    (fun ((fg, bg), l) -> 
       let color =
	 match fg with 
	     None -> ""
	   | Some color -> " color: " ^ color ^ ";" in
       let background_color =
	 match bg with
	     None -> ""
	   | Some color -> " background-color: " ^ color ^ ";" in
       bprintf buf ".%s {%s%s }\n" 
	 (String.concat ",\n." (List.sort String.compare l)) 
	 color background_color)
    color_groups;
  Buffer.contents buf
  
let make_css 
  ?(default = default_default_style)
  ?(colors = all_colors)
  file =
  let oc = open_out file in
  output_string oc (make_classes ~default ~colors ());
  close_out oc

let default_style = make_classes ()

type style = [ `Inline | `Inhead of string | `Url of string ]

type param = 
    { line_numbers : bool; 
      title : bool;
      body_only : bool;
      tab_size : int;
      footnote : bool;
      style : style;
      html_comments : bool;
      charset : string;
      annot_filter : Annot.filter;
      no_annot : bool;
      ie7 : bool (* if true, type annotations will not work 
		    on versions of Internet Explorer prior to IE 7
		    (but rendering is better) *) }

let default_param =
  { line_numbers = false; 
    title = false;
    body_only = false;
    tab_size = 8;
    footnote = true;
    style = `Inhead default_style;
    html_comments = false;
    charset = "iso-8859-1";
    annot_filter = `Innermost;
    no_annot = false;
    ie7 = false }


let add_string buf nbsp s = 
  String.iter
    (function
	 '<' -> Buffer.add_string buf "&lt;"
       | '>' -> Buffer.add_string buf "&gt;"
       | '&' -> Buffer.add_string buf "&amp;"
       | ' ' when nbsp -> Buffer.add_string buf "&nbsp;"
       | c -> Buffer.add_char buf c)
    s


let line_comment p buf i =
  if p.line_numbers then
    match p.style with
	`Inline -> (* should use color parameters *)
	  bprintf buf
	  "<span style=\"%s\">%4d:</span>\
           <span style=\"%s\"> </span>" 
	  (inline_style linenum_color) i (inline_style background_color)
      | `Inhead _ 
      | `Url _ ->
	  bprintf buf 
	    "<span class=\"Clinenum\">%4d:</span>\
             <span class=\"Cbackground\"> </span>" i

 
let colorize ?(comment = false) p buf nbsp style s =
  let add =
    if comment && p.html_comments then Buffer.add_string buf
    else add_string buf nbsp in
  match p.style with
      `Inhead _ | `Url _ ->
	let _, _, clas = style in
	bprintf buf "<span class=\"%s\">" clas;
	add s;
	Buffer.add_string buf "</span>"
    | `Inline ->
	match inline_style style with
	    "" -> add s
	  | sty ->
	      bprintf buf "<span style=\"%s\">" sty;
	      add s;
	      Buffer.add_string buf "</span>"

let compact_annot s =
  let space = ref true in
  let buf = Buffer.create 200 in
  String.iter (function
		   ' ' | '\n' | '\t' | '\r' ->
		     if !space then ()
		     else (space := true;
			   Buffer.add_char buf ' ')
		 | c ->
		     space := false;
		     Buffer.add_char buf c)
    s;
  Buffer.contents buf


let ignore_annot p info =
  p.no_annot || 
  p.annot_filter = `Innermost && not info.Annot.innermost ||
  p.annot_filter = `Outermost && not info.Annot.outermost

let hover_start p =
  if p.ie7 then "span"
  else "a href=\"javascript:;\""

let hover_stop p =
  if p.ie7 then "span"
  else "a"

let start_annot p buf info annot =
  if ignore_annot p info then ()
  else 
    ((* We use "a href" and not "span" 
	in order to make the hover work in IE 6. *)
      match p.style with
	  `Inline ->
	    bprintf buf 
	    "<%s style=\"text-decoration:none;%s\" \
                title=\"\"" 
	      (hover_start p)
	      (inline_style annot_color);
	    add_string buf false (compact_annot annot);
	    Buffer.add_string buf "\">"
	| `Inhead _ | `Url _ ->
	    bprintf buf 
	      "<%s style=\"text-decoration:none\" \
                  class=\"Cannot\" title=\""
	      (hover_start p);
	    add_string buf false (compact_annot annot);
	    Buffer.add_string buf "\">")

let stop_annot p buf info =
  if ignore_annot p info then () 
  else
    bprintf buf "</%s>" (hover_stop p)


let rec fold_left f accu l =
  match l with
      [] -> accu
    | a :: rest -> fold_left f (f accu a rest) rest

let ocaml
  ?(nbsp = false)
  ?(keyword_colors = default_keyword_colors)
  ?(param = default_param)
  buf l =
  
  let _last_line =
    fold_left
      (fun line token rest ->
	 match token with
	     `String s ->
	       colorize param buf nbsp string_color s;
	       line
	   | `Quotation s ->
	       colorize param buf nbsp quotation_color s;
	       line
	   | `Token s ->
	       add_string buf nbsp s;
	       line
	   | `Comment s ->
	       colorize ~comment:true param buf nbsp comment_color s;
	       line
	   | `Special_comment (handler_name, s0) ->
	       let html = 
		 match Plugin.expand handler_name s0 with
		     None -> 
		       failwith (
			 sprintf "Handler %s failed on line %i with input %s"
			   handler_name line s0
		       )
		   | Some s -> s
	       in
	       bprintf buf "</pre>%s<pre>" html;
	       line + (Plugin.count_newlines s0)
	   | `Construct s ->
	       colorize param buf nbsp construct_color s;
	       line
	   | `Keyword k ->
	       (try 
		  let color = Hashtbl.find keyword_colors k in
		  colorize param buf nbsp color k;
		with Not_found -> 
		  let color =
		    match k.[0] with
			'a' .. 'z' -> alpha_keyword_color
		      | _ -> nonalpha_keyword_color in
		  colorize param buf nbsp color k);
	       line
	   | `Newline ->
	       Buffer.add_char buf '\n';
	       (match rest with
                    []
                  | `Special_comment _ :: _ -> ()
                  | _ ->
		      line_comment param buf line
               );
	       line + 1
	   | `Tab ->
	       if param.tab_size < 0 then Buffer.add_char buf '\t'
	       else add_string buf nbsp (String.make param.tab_size ' ');
	       line
	   | `Start_annot (info, annot) -> (start_annot param buf info annot; 
					    line)
	   | `Stop_annot info -> stop_annot param buf info; line)
      2 l in
  ()

let ocamlcode
  ?annot
  ?keyword_colors
  ?(param = default_param)
  ?(tag_open = "<code>")
  ?(tag_close = "</code>")
  s =
  let buf = Buffer.create (10 * String.length s) in
  Buffer.add_string buf tag_open;
  line_comment param buf 1;
  ocaml ?keyword_colors ~param ~nbsp:true buf (Input.string ?annot s);
  Buffer.add_string buf tag_close;
  Buffer.contents buf

let ocamlpre
  ?annot
  ?keyword_colors
  ?(param = default_param)
  ?(tag_open = "<pre>")
  ?(tag_close = "</pre>")
  s =
  let buf = Buffer.create (10 * String.length s) in
  Buffer.add_string buf tag_open;
  line_comment param buf 1;
  ocaml ?keyword_colors ~param ~nbsp:false buf (Input.string ?annot s);
  Buffer.add_string buf tag_close;
  Buffer.contents buf


let is_valid_anchor =
  let re = Str.regexp "[A-Za-z][-A-Za-z0-9_:.]*$" in
  fun s -> Str.string_match re s 0
    
let ocaml_file
  ?(filename = "") 
  ?keyword_colors
  ~param
  buf l =
  
  let anchor = 
    if is_valid_anchor filename then 
      sprintf "<a name=\"%s\"></a>" filename
    else "" in

  if param.title then
    (bprintf buf "<h1>%s<code>%s</code></h1>\n" anchor filename;
     Buffer.add_string buf "\n<pre>")
  else
    bprintf buf "\n<pre>%s" anchor;

  line_comment param buf 1;
  ocaml ?keyword_colors ~param buf l;
  Buffer.add_string buf "</pre>\n"



let begin_document 
  ?(param = default_param)
  buf files =
  let rec make_title = function
    | [] -> ()
    | [a] -> Buffer.add_string buf a
    | a :: l -> Printf.bprintf buf "%s, " a; make_title l in
  bprintf buf "\
<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \
\"http://www.w3.org/TR/html4/strict.dtd\">
<html>
<head>
  <meta http-equiv=\"content-type\" content=\"text/html; charset=%s\">
  <title>
" param.charset;
  make_title files;
  Printf.bprintf buf
    "</title>\n  <meta name=\"GENERATOR\" content=\"caml2html %s\">\n" 
    Version.version;
  (match param.style with
       `Url url ->
	 Printf.bprintf buf
	 "  <link rel=\"stylesheet\" href=\"%s\" type=\"text/css\">\n" 
	url
     | `Inhead s ->
	 Printf.bprintf buf "<style type=\"text/css\">\n%s</style>\n" s
     | `Inline -> ());
  Buffer.add_string buf "</head>\n<body>\n"


let end_document ?(param = default_param) buf =
  if param.footnote then
    Buffer.add_string buf "
<hr>
<p>
<em>This document was generated using 
<a href=\"http://martin.jambon.free.fr/caml2html.html\">caml2html</a></em>
";
  Buffer.add_string buf "</body>\n</html>\n"


let handle_file ?keyword_colors ?(param = default_param) buf filename =
  let annot =
    match Annot.guess_annot_file filename with
	None -> None
      | Some annot_file ->
	  Annot.from_file 
	    ~impl_file:filename ~annot_file in
  let l = Input.file ?annot filename in
  ocaml_file ?keyword_colors ~param ~filename buf l

let rec mkdir_p dir =
  if Sys.file_exists dir then ()
  else
    (mkdir_p (Filename.dirname dir);
     Unix.mkdir dir 0o777)

let save_file ?(dir = "") buf file =
  let dir_res_name =
    if dir = "" then file
    else
      (mkdir_p dir;
       Filename.concat dir file) in
  let chan_out = open_out dir_res_name in
  Buffer.output_buffer chan_out buf;
  close_out chan_out

let ocaml_document ?dir ?keyword_colors ?param files outfile =
  let buf = Buffer.create 50_000 in
  begin_document ?param buf files;
  let rec tmp = function
    | [] -> ()
    | [x] -> handle_file ?keyword_colors ?param buf x
    | x :: l ->
	handle_file ?keyword_colors ?param buf x;
        Buffer.add_string buf "\n<hr>\n";
        tmp l in
  tmp files;
  end_document ?param buf;
  save_file ?dir buf outfile