-
Andre Maroneze authoredAndre Maroneze authored
html_generator.ml 9.33 KiB
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
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"
| 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 ()