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 "&lt;"
      | '{' -> 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>.&ensp;" 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>&ensp;"
  | Gui -> Format.fprintf fmt "<span class=\"kernel\">[Gui]</span>&ensp;"
  | Service s | Plugin(_,Some s) -> Format.fprintf fmt "<span class=\"kernel\">[%s]</span>&ensp;" 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 ()