Newer
Older
open Lexer
let html = ref None
let output = ref "Changelog.prehtml"
let set_output f = output := f
let set_html l = html := Some l
let set_plugin p = Lexer.plugin_mode := Some p
(* -------------------------------------------------------------------------- *)
(* --- Main HTML --- *)
(* -------------------------------------------------------------------------- *)
let print_head fmt = Format.fprintf fmt "---\nlayout: changelog\ntitle: Changelog\ncss: changelog\n---\n"
let print_text fmt s =
for i=0 to String.length s - 1 do
match s.[i] with
| '&' -> Format.pp_print_string fmt "&"
| '"' -> Format.pp_print_string fmt """
| ' ' -> Format.pp_print_string fmt " "
| '>' -> Format.pp_print_string fmt ">"
| '<' -> Format.pp_print_string fmt "<"
| '{' -> Format.pp_print_string fmt "{{ \"{\" }}"
| c -> Format.pp_print_char fmt c
done
(* -------------------------------------------------------------------------- *)
(* --- Entries --- *)
(* -------------------------------------------------------------------------- *)
let print_word fmt = function
| Space -> Format.pp_print_char fmt ' '
| Newline -> Format.pp_print_string fmt "<br/><br/>"
| Word s -> print_text fmt s
| Quoted s -> Format.fprintf fmt "<code>%a</code>" print_text s
| Item k -> Format.fprintf fmt "<br/><i>%c</i>. " k
| PublicBts n ->
Format.fprintf fmt "<a class=\"public\" href=\"%s%d\">#%d</a>"
"http://bts.frama-c.com/view.php?id=" n n
| PrivateBts n ->
Format.fprintf fmt "<a class=\"private\" href=\"%s%d\">#%d</a>"
"http://bts.frama-c.com/view.php?id=" n n
| Gitlab n ->
Format.fprintf fmt "<a class=\"private\" href=\"%s%d\">#%d</a>"
"https://git.frama-c.com/frama-c/frama-c/issues/" n n
| OldBts n ->
Format.fprintf fmt "<code>'%d'</code>" n
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
type category =
| UserFeature
| UserBugfix
| DeveloperTopics
let category e =
if List.mem Developer e.tags then DeveloperTopics
else
if List.mem Bugfix e.tags
then UserBugfix
else UserFeature
let category_compare k1 k2 =
let rank = function
| UserFeature -> 1
| UserBugfix -> 2
| DeveloperTopics -> 3
in
rank k1 - rank k2
let category_title n = function
| UserFeature -> if n > 1 then "New Features" else "New Feature"
| UserBugfix -> if n > 1 then "Bug Fixes" else "Bug Fix"
| DeveloperTopics -> "Developers Only"
let print_service fmt = function
| Main | Plugin(_,None) -> ()
| Cmd -> Format.fprintf fmt "<span class=\"kernel\">[Cmd]</span> "
| Gui -> Format.fprintf fmt "<span class=\"kernel\">[Gui]</span> "
| Service s | Plugin(_,Some s) -> Format.fprintf fmt "<span class=\"kernel\">[%s]</span> " s
let print_entry fmt e =
let kind =
let break = List.mem Break e.tags in
match category e with
| UserFeature -> if break then "user-break" else "user"
| UserBugfix -> if break then "bug-break" else "bugfix"
| DeveloperTopics -> if break then "dev-break" else "dev"
in
Format.fprintf fmt "<li class=\"%s\">" kind ;
print_service fmt e.service ;
List.iter (print_word fmt) (List.rev e.descr) ;
Format.fprintf fmt "</li>@\n"
(* -------------------------------------------------------------------------- *)
(* --- Entries --- *)
(* -------------------------------------------------------------------------- *)
let by_service e1 e2 = service_compare e1.service e2.service
let by_category e1 e2 = category_compare (category e1) (category e2)
let by_break e1 e2 =
match List.mem Break e1.tags , List.mem Break e2.tags with
| true , false -> 1
| false , true -> -1
| _ -> 0
let compare_entry e1 e2 =
let rec cmp x y = function
| [] -> 0
| f :: fs ->
let c = f x y in
if c=0 then cmp x y fs
else c
in
cmp e1 e2 [by_service;by_category;by_break]
let print_entries fmt es =
begin
Format.fprintf fmt "<ul class=\"entries\">@\n" ;
List.iter (print_entry fmt) (List.sort compare_entry es) ;
Format.fprintf fmt "</ul>@." ;
end
let print_category_entries fmt (c,es) =
let n = List.length es in
if n > 0 then
begin
Format.fprintf fmt "<h4>%s</h4>@\n" (category_title n c) ;
print_entries fmt es ;
end
let sort_by f cmp es =
let es = List.sort (fun e1 e2 -> cmp (f e2) (f e1)) es in
let rec acc sorted item content = function
| [] -> (item,content) :: sorted
| e :: es ->
let k = f e in
if cmp k item = 0
then acc sorted item (e::content) es
else acc ((item,content)::sorted) k [e] es
in match es with
| [] -> []
| e::es -> acc [] (f e) [e] es
let print_entries fmt es =
if List.length es >= 5 then
match sort_by category category_compare es with
| [_,es] -> print_entries fmt es
| ces ->
if List.exists (fun (_,es) -> List.length es > 2) ces
then List.iter (print_category_entries fmt) ces
else print_entries fmt es
else
print_entries fmt es
(* -------------------------------------------------------------------------- *)
(* --- Entries by Service --- *)
(* -------------------------------------------------------------------------- *)
module Title = struct type t = string let compare = compare_string end
module Smap = Map.Make(Title)
type sections = {
mutable s_main : entry list ;
mutable s_cmd : entry list ;
mutable s_gui : entry list ;
mutable s_plugin : entry list Smap.t ;
mutable s_service : entry list Smap.t ;
}
let sections () = {
s_main = [] ;
s_cmd = [] ;
s_gui = [] ;
s_plugin = Smap.empty ;
s_service = Smap.empty ;
}
let smap_add (a:string) (e:entry) (s:entry list Smap.t) =
let es = try Smap.find a s with Not_found -> [] in
Smap.add a (e::es) s
let framac_sections s e =
match e.service with
| Main | Cmd -> s.s_main <- e :: s.s_main
| Gui -> s.s_gui <- e :: s.s_gui
| Plugin(p,_) -> s.s_plugin <- smap_add p e s.s_plugin
| Service _ -> s.s_main <- e :: s.s_main
let plugin_sections s e =
match e.service with
| Main -> s.s_main <- e :: s.s_main
| Cmd -> s.s_cmd <- e :: s.s_cmd
| Gui -> s.s_gui <- e :: s.s_gui
| Plugin(p,_) -> s.s_plugin <- smap_add p e s.s_plugin
| Service a -> s.s_service <- smap_add a e s.s_service
let print_sections fmt es =
let s = sections () in
let entity,dispatch = match !plugin_mode with
| None -> "Frama-C" , framac_sections
| Some p -> p , plugin_sections
in
begin
List.iter (dispatch s) es ;
if s.s_main <> [] then
( Format.fprintf fmt "<h2>%s General</h2>@\n" entity ;
print_entries fmt s.s_main ) ;
if s.s_cmd <> [] then
( Format.fprintf fmt "<h2>%s Command Line</h2>@\n" entity ;
print_entries fmt s.s_cmd ) ;
if s.s_gui <> [] then
( Format.fprintf fmt "<h2>%s GUI</h2>@\n" entity ;
print_entries fmt s.s_gui ) ;
Smap.iter
(fun s es ->
Format.fprintf fmt "<h2>%s - %s</h2>@\n" entity s ;
print_entries fmt es )
s.s_service ;
Smap.iter
(fun p es ->
Format.fprintf fmt "<h2>Plugin %s</h2>@\n" p ;
print_entries fmt es )
s.s_plugin ;
end
(* -------------------------------------------------------------------------- *)
(* --- Release Printing --- *)
(* -------------------------------------------------------------------------- *)
let print_release fmt = function
| Current ->
Format.fprintf fmt
"<h3 class=\"release\">Future Release <span class=\"hversion\">[git]</span></h3>@\n"
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
| Release(a,v) ->
Format.fprintf fmt
"<hr><div><a id=\"%s-%s\" href=\"#%s-%s\"></a></div>\
<h3 class=\"release\">%s Release <span class=\"hversion\">[%s]</span></h3>@ \n"
a v a v a v
| ToolRelease(a,v) ->
Format.fprintf fmt
"<hr><div><a id=\"%s-%s\" href=\"#%s-%s\"></a></div>\
<h3 class=\"release\">Release %s %s</h3>@ \n"
a v a v a v
| CurrentPlugin(a,v) ->
Format.fprintf fmt
"<div><a id=\"%s-%s\" href=\"#%s-%s\"></a></div>\
<h3 class=\"release\">Future Release %s %s</h3>@ \n"
a v a v a v
| PluginRelease(a,v,kernel,framac) ->
Format.fprintf fmt
"<hr><div><a id=\"%s-%s-%s-%s\" href=\"#%s-%s-%s-%s\"></a></div>\
<h3 class=\"release\">Release %s %s<span class=\"hversion\">[%s %s]</span></h3>@ \n"
a v kernel framac a v kernel framac a v kernel framac
let print_releases fmt releases =
List.iter
(fun (release, entries) ->
if entries <> [] then
begin
print_release fmt release ;
Format.fprintf fmt "<div class=\"release\">@." ;
print_sections fmt entries ;
Format.fprintf fmt "</div>@." ;
end)
(Lexer.releases ())
(* -------------------------------------------------------------------------- *)
(* --- HTML Generation & Command Line --- *)
(* -------------------------------------------------------------------------- *)
let generate () =
let cout = open_out !output in
let fmt = Format.formatter_of_out_channel cout in
print_head fmt ;
print_releases fmt releases
let () =
Arg.parse [
"-html" , Arg.String set_html , "<css> generate html (resources directory <css>)" ;
"-plugin" , Arg.String set_plugin , "<name> generate changelog for plugin" ;
"-o" , Arg.String set_output , "<file> output file" ;
] Lexer.process "changelog [options] files..." ;
generate ()