Source file `printers.ml`

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
(*********************************************************************************)
(*                Higlo                                                          *)
(*                                                                               *)
(*    Copyright (C) 2014-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU Library General Public License for more details.                       *)
(*                                                                               *)
(*    You should have received a copy of the GNU Lesser General Public           *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*                                                                               *)
(*********************************************************************************)

(** *)

open Lang

type classes =
  {
    bcomment : string ;
    constant : string ;
    directive : string ;
    escape : string ;
    id : string ;
    keyword : int -> string ;
    lcomment : string ;
    numeric : string ;
    string : string ;
    symbol : int -> string ;
    text : string ;
    title : int -> string ;
  }

let default_classes = {
    bcomment = "comment" ;
    constant = "constant" ;
    directive = "directive" ;
    escape = "escape" ;
    id = "id" ;
    keyword = (function 0 -> "kw" | n -> Printf.sprintf "kw%d" n) ;
    lcomment = "comment" ;
    numeric = "numeric" ;
    string = "string" ;
    symbol = (function 0 -> "sym" | n -> Printf.sprintf "sym%d" n) ;
    text = "text" ;
    title = (function 0 -> "title" | n -> Printf.sprintf "title%d" n) ;
  }
;;

let token_to node =
  fun ?(classes=default_classes) ->
    function
    | Bcomment (s,_) -> node classes.bcomment s
    | Constant (s,_) -> node classes.constant s
    | Directive (s,_) -> node classes.directive s
    | Escape (s,_) -> node classes.escape s
    | Id (s,_) -> node classes.id s
    | Keyword (n, (s, _)) -> node (classes.keyword n) s
    | Lcomment (s,_) -> node classes.lcomment s
    | Numeric (s,_) -> node classes.numeric s
    | String (s,_) -> node classes.string s
    | Symbol (n, (s, _)) -> node (classes.symbol n) s
    | Text (s,_) -> node classes.text s
    | Title (n, (s,_)) -> node (classes.title n) s

let token_to_xml =
  let module X = Xtmpl.Xml in
  let node cl cdata =
    let atts = X.atts_one ("","class") (cl, None) in
    X.node ("","span") ~atts [X.cdata cdata]
  in
  token_to node
;;

let token_to_xml_rewrite =
  let module X = Xtmpl.Rewrite in
  let node cl cdata =
    let atts = X.atts_one ("","class") [X.cdata cl] in
    X.node ("","span") ~atts [X.cdata cdata]
  in
  token_to node
;;

let to_xml ?classes ~lang s =
  List.map (token_to_xml ?classes) (parse ~lang s)
;;

let to_xml_rewrite ?classes ~lang s =
  List.map (token_to_xml_rewrite ?classes) (parse ~lang s)
;;


type printer = Lang.token list -> unit

module SMap = Map.Make(String);;

let printers = ref SMap.empty ;;

let get_printer name =
  try SMap.find name !printers
  with Not_found -> failwith (Printf.sprintf "Unknown printer %S" name)
;;

let register_printer name f = printers := SMap.add name f !printers;;

let xml_printer tokens =
  let xmls = List.map token_to_xml tokens in
  print_string (Xtmpl.Xml.to_string xmls)
;;

let html_printer tokens =
  print_string "<html>
  <head>
    <meta content=\"text/html; charset=utf-8\" http-equiv=\"Content-Type\"/>
    <link href=\"style.css\" rel=\"stylesheet\" type=\"text/css\"/>
  </head>
  <body><pre>";
  xml_printer tokens;
  print_string "</pre></body></html>"
;;

let token_printer ?(with_len=false) tokens =
  let f = if with_len
    then Lang.string_of_token_with_length
    else Lang.string_of_token
  in
  List.iter (fun t -> print_string (f t)) tokens
;;

let () =
  List.iter (fun (name, f) -> register_printer name f)
    [ "xml", xml_printer ;
      "html", html_printer ;
      "tokens", token_printer ~with_len:false;
      "tokens-length", token_printer ~with_len:true ;
    ]
;;