lexer.mll

{

  type release =
    | Current
    | Release of string * string
        (* codename, version *)
    | CurrentPlugin of string * string
	(* plugin-name, plugin-version *)
    | PluginRelease of string * string * string * string
	(* plugin-name, plugin-version, kernel-name, kernel-version *)
    | ToolRelease of string * string
	(* tool-name, tool-version *)

  type service =
    | Cmd
    | Main
    | Gui
    | Plugin of string * string option
    | Service of string

  type tag = Break | Bugfix | User | Developer | Commits

  type text =
    | Word of string
    | Quoted of string
    | PublicBts of int
    | PrivateBts of int
    | OldBts of int
    | Gitlab of bool * string * int
    | Item of char
    | Space
    | Newline

  type entry = {
    mutable service: service;
    mutable tags: tag list;
    mutable descr: text list;
  }

  let plugin_mode : string option ref = ref None
  let current_plugin = ref None
  let framac_services = [
    "ACSL";
    "Cil";
    "Configure";
    "Dev";
    "Doc";
    "Journal";
    "Kernel";
    "Logic";
    "Lib";
    "Libc";
    "Makefile";
    "Project";
    "Ptests";
    "Typing"
  ]

  let releases : (release * entry list) list ref = ref [ Current, [] ]

  let file = ref "Changelog"
  let line = ref 1

  let error msg =
    Format.eprintf "%s:%d: " !file !line;
    Format.kfprintf
      (fun fmt ->
	 Format.pp_print_newline fmt () ;
	 exit 2)
      Format.err_formatter msg

  let set_release cp r =
    let entries = try List.assoc r !releases with Not_found -> [] in
    let others = List.filter (fun (r',_) -> r<>r') !releases in
    current_plugin := cp ;
    releases := (r, entries) :: others

  let add_entry e = function
    | ( r , es ) :: olders -> ( r , e::es ) :: olders
    | _ -> assert false

  let set_name e a =
    e.service <-
      match !plugin_mode , !current_plugin , a with
	| None , None , ("Cmd"|"CMD") -> Cmd
	| None , None , ("Gui"|"GUI") -> Gui
	| None , None , _ -> if List.mem a framac_services then Service a else Plugin(a,None)
	| None , Some p , ("Cmd"|"CMD") -> Plugin(p,Some "Cmd")
	| None , Some p , ("Gui"|"GUI") -> Plugin(p,Some "GUI")
	| None , Some p , s -> Plugin(p,Some s)
	| Some _ , None , s -> Service s
	| Some _ , Some p , s ->
	    if (String.uppercase_ascii p)=(String.uppercase_ascii s) then Main else Service a

  let set_tag e t = e.tags <- t :: e.tags

  let mk_entry mark =
    let entry = { service = Main; tags = []; descr = [] } in
    String.iter
      (function
	 | '-' -> set_tag entry User
	 | 'o' -> set_tag entry Developer
	 | '*' -> set_tag entry Bugfix
	 | '!' -> set_tag entry Break
	 | '+' -> set_tag entry Commits
	 | _ -> ())
      mark ;
    releases := add_entry entry !releases ;
    entry

  let add_word e w = match e.descr , w with
    | Space :: _ , Space -> ()
    | d , _ -> e.descr <- w :: d

}

let space   = [' ' '\t']
let newline = ['\n' '\r']+
let upper   = ['A'-'Z']
let letter  = ['a'-'z' 'A'-'Z' '_' '-']
let ident   = ['a'-'z' 'A'-'Z' '_' '0'-'9']
let file    = ['a'-'z' 'A'-'Z' '_' '-' '0'-'9']
let digit   = ['0'-'9']
let word    = [^ ' ' '\t' '\n' '\r']
let mark    = ['-' 'o' '*' '!' '+']

let vdigit = [ '0'-'9' '.' ]

(* ce is the current entry. None means no-entry at the beginning of line. *)
rule main ce = parse
  | (mark+) as mark    { entry (mk_entry mark) lexbuf }
  | '#' [^ '\n']* '\n' { incr line; main None lexbuf }
  | newline            { incr line; main None lexbuf }
  | eof                { }
  (* new Frama-C version name (major.minor (Element)) *)
  | space* (("Open Source"|"Binary") space+)+ "Release" space+
     ((digit+) '.' (digit+) ('.' (digit+))? as version) space+
     '(' ( (file+) as codename ) ')'
      {
        set_release None (Release(codename,version)) ;
        main None lexbuf
      }
  | space* ("Plugin") space+ ((file+) as pname) space+
    ((digit+) '.' (digit+) ('.' (digit+))? as version) space+ '(' ( (file+) as codename ) ')'
      {
        set_release (Some pname) (Release(codename,version)) ;
        main None lexbuf
      }

  | space* ("Plugin") space+ ((file+) as pname) space+ '<'[^'>']+'>'
      {
        set_release (Some pname) (Current) ;
        main None lexbuf
      }

  | ( letter+ space+)* '<'[^'>']+'>'
    {
        set_release None (Current) ;
        main None lexbuf
    }
  | space
      {
	match ce with
	| None -> main ce lexbuf
	| Some e -> text e lexbuf
      }
  | _
      {
	error "Misformed entry (%S)" (Lexing.lexeme lexbuf)
      }

(* e is just created *)
and entry e = parse
  | space              { entry e lexbuf }
  | (letter+ space+ letter+) as a     { set_name e a ; text e lexbuf }
  | (letter+) as a     { set_name e a ; text e lexbuf }
  | _ { error "Missing plugin or service name (at %S)" (Lexing.lexeme lexbuf) }

(* text of entry *)
and text e = parse
  | '[' digit + '-' digit+ ('-' digit+)? ']' { (* date *) text e lexbuf }
  | newline newline { incr line ; add_word e Newline ; main (Some e) lexbuf }
  | newline        { incr line ; main (Some e) lexbuf }
  | space          { add_word e Space ; text e lexbuf }
  | eof            { }

  (* | space+ (digit as k) ')' { add_word e (Item k) ; text e lexbuf } *)

  | "frama-c/" ((letter+) as sub) '#' ((digit+) as bug)
      { add_word e (Gitlab(false, sub, int_of_string bug)) ; text e lexbuf }

  | '#' ((digit+) as bug)
      { add_word e (PublicBts(int_of_string bug)) ; text e lexbuf }

  | "#!" ((digit+) as bug)
      { add_word e (PrivateBts(int_of_string bug)) ; text e lexbuf }

  | "#?" ((digit+) as bug)
      { add_word e (OldBts(int_of_string bug)) ; text e lexbuf }

  | "#@" ((digit+) as bug)
      { add_word e (Gitlab(false, "frama-c", int_of_string bug)) ; text e lexbuf }

  | "##" ((digit+) as bug)
      { add_word e (Gitlab(true, "frama-c", int_of_string bug)) ; text e lexbuf }

  | '-' (letter | '-')+
  | '!'? (upper ident* '.')+ ident+
  | '~' ident+
  | '"' [^ '"' '\n']* '"'
  | ( (file+ | '.' | "..") '/' ) * file+ '.' file+
  | ( (file+ | '.' | "..") '/' ) + file+ '/'?
  | '\\' ident+
      { add_word e (Quoted(Lexing.lexeme lexbuf)) ; text e lexbuf }
  | letter+ ('-' letter+)*
      { add_word e (Word (Lexing.lexeme lexbuf)) ; text e lexbuf }

  | _ { add_word e (Word (Lexing.lexeme lexbuf)) ; text e lexbuf }

{

  let process filename =
    let cin = open_in filename in
    let lexbuf = Lexing.from_channel cin in
    file := filename ;
    line := 1 ;
    main None lexbuf

  let compare_string s1 s2 =
    let cmp = String.compare (String.uppercase_ascii s1) (String.uppercase_ascii s2) in
    if cmp = 0 then String.compare s1 s2 else cmp

  let rec compare_strings s1 s2 =
    match s1 , s2 with
      | [] , _ -> (-1)
      | _ , [] -> 1
      | x::s1 , y::s2 ->
	  let cmp = compare_string x y in
	  if cmp = 0 then compare_strings s1 s2 else cmp

  let service_compare s1 s2 =
    let rank = function
      | Main -> (0,[])
      | Cmd -> (1,[])
      | Gui -> (2,[])
      | Service a -> (3,[a])
      | Plugin(p,None) -> (4,[p])
      | Plugin(p,Some a) -> (4,[p;a])
    in
    let (r1,a1) = rank s1 in
    let (r2,a2) = rank s2 in
    if r1=r2 then compare_strings a1 a2 else r1-r2

  type version = {
    major : int;
    minor : int;
    patch : int;
  }

  let extract_version s =
    let re_version = Str.regexp "^\\([0-9]+\\)\\.\\([0-9]+\\)\\(\\.\\([0-9]+\\)\\)?$" in
    assert (Str.string_match re_version s 0);
    let major = int_of_string (Str.matched_group 1 s) in
    let minor = int_of_string (Str.matched_group 2 s) in
    let patch =
      try
        int_of_string (Str.matched_group 4 s)
      with _ -> 0
    in
    { major; minor; patch }

  (* compares both old-style (YYYYMMDD) and new-style numbering (MAJOR.MINOR)
     note: codenames are only used for old versions or in case of equality
   *)
  let compare_version v1 v2 cn1 cn2 =
    let re_old_numbering = Str.regexp ".*\\([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]\\)" in
    let is_old_numbering v = Str.string_match re_old_numbering v 0 in
    let get_old_version v =
      let v = String.map (fun c -> if c = '_' then '-' else c) v in
      assert(Str.string_match re_old_numbering v 0) ;
      Str.matched_group 1 v
    in
    match is_old_numbering cn1, is_old_numbering cn2 with
    | true, true ->
      let r = String.compare (get_old_version cn2) (get_old_version cn1) in
      if r = 0 then String.compare v2 v1 else r
    | false, true -> (* new numbering is always newer *) -1
    | true, false -> (* old numbering is always older *) 1
    | false, false -> (* compare new-style versions *)
      let v1 = extract_version v1 in
      let v2 = extract_version v2 in
      let v = if v1.major = v2.major then if v1.minor = v2.minor then v2.patch - v1.patch
          else v2.minor - v1.minor
          else v2.major - v1.major
      in
      if v = 0 then (* same version number (1.0?); use lexicographic order *)
         String.compare cn2 cn1
      else v

  let compare_release (r1,_) (r2,_) =
    match r1 , r2 with
      | Current , Current -> 0
      | Current , _ -> -1
      | _ , Current -> 1
      | CurrentPlugin (_,v1), CurrentPlugin (_,v2) -> String.compare v2 v1
      | CurrentPlugin _, _ -> -1
      | _ , CurrentPlugin _-> 1
      | Release(cn1,v1) , Release(cn2,v2) -> compare_version v1 v2 cn1 cn2
      | Release _ , _ -> -1
      | _ , Release _ -> 1
      | PluginRelease(_,v1,_,a1) , PluginRelease(_,v2,_,a2) ->
	  String.compare (a2 ^ v2) (a1 ^ v1)
      | PluginRelease _ , _ -> -1
      | _, PluginRelease _ -> 1
      | ToolRelease(_,v1) , ToolRelease(_,v2) ->
	  String.compare v2 v1

  let releases () =
    List.map
      (fun (r,es) -> r , List.filter (fun e -> not (List.mem Commits e.tags)) es)
      (List.sort compare_release !releases)

}