(* $Id: fl_metascanner.src 115 2007-11-11 21:52:44Z gerd $ -*- tuareg -*-
 * ----------------------------------------------------------------------
 *
 *)

open Fl_metatoken;;
open Printf

type formal_pred =
    [ `Pred of string
    | `NegPred of string
    ]

type flavour =
    [ `BaseDef 
    | `Appendix 
    ]

type pkg_definition =
    { def_var : string;
      def_flav : flavour;
      def_preds : formal_pred list;
      def_value : string;
    }

type pkg_expr =
    { pkg_defs : pkg_definition list;
      pkg_children : (string * pkg_expr) list;
    }


let string_of_preds pl =
  let print = 
    function 
	`Pred n -> n
      | `NegPred n -> "-" ^ n
  in
  if pl = [] then
    ""
  else
    "(" ^ String.concat "," (List.map print pl) ^ ")"
;;


let scan ch =
  (* transform an in_channel to a token stream; 'Space' tokens are left
   * out.
   *)
  let buf = Lexing.from_channel ch in
  let rec next line pos0 =
    let t = Fl_meta.token buf in
    match t with
      Space   -> next line pos0
    | Newline -> next (line+1) (Lexing.lexeme_end buf)
    | Eof     -> let pos = Lexing.lexeme_start buf - pos0 in
                 [< '(line, pos, Eof) >]
    | _       -> let pos = Lexing.lexeme_start buf - pos0 in
                 [< '(line, pos, t); next line pos0 >]
  in
  next 1 0
;;


let parse ch =

  let rec mk_set l =
    match l with
      x :: l' ->
	if List.mem x l' then mk_set l' else x :: (mk_set l')
    | [] ->
	[]
  in

  let error_msg m line col =
    m ^ " at line " ^ string_of_int line ^ " position " ^ string_of_int col
  in

  let rec parse_all need_rparen stream =
    match stream with parser
      [< '(line, col, Name "package");
	 '(l, c, String n) ?? (error_msg "String literal expected after 'package'" line col);
	 '(l, c, LParen)   ?? (error_msg "'(' expected after string" l c);
	 subpkg = parse_all true
	  ?? (error_msg "Error in subpackage definition" line col);
	 rest = parse_all need_rparen;
      >]
	-> { pkg_defs = rest.pkg_defs;
	     pkg_children = (n, subpkg) :: rest.pkg_children
	   }

    | [< '(line, col, Name n);
         props = parse_properties
	  ?? (error_msg "Error in 'name = value' clause" line col);
	 rest = parse_all need_rparen
       >]
	-> 
	  let (args, flav, value) = props in
	  (* TODO: Check args *)
	  let args' = Sort.list ( <= ) (mk_set args) in
	  let def = { def_var = n;
		      def_flav = flav;
		      def_preds = args';
		      def_value = value } in
	  { pkg_defs = def :: rest.pkg_defs;
	    pkg_children = rest.pkg_children;
	  }

    | [< '(line,col,Eof) >]
	-> 
	  if need_rparen then
	    raise(Stream.Error("Unexpected end of file in line " ^
			       string_of_int line ^ " position " ^
			       string_of_int col));
	  { pkg_defs = [];
	    pkg_children = []
	  }

    | [< '(line,col,RParen) >]
	-> 
	  if not need_rparen then
	    raise(Stream.Error("Unexpected ')' in line " ^
			       string_of_int line ^ " position " ^
			       string_of_int col));
	  { pkg_defs = [];
	    pkg_children = []
	  }

    | [< '(line,col,_) >]
	-> raise(Stream.Error(error_msg "Expected 'name = value' clause" line col))

  and parse_properties stream =
    match stream with parser
      [< '(line,col,LParen);
	 arg1 = parse_argument;
	 args = parse_arguments;
	 flav = parse_flavour;
         '(line3,col3,String s)
	  ?? (error_msg "Expected string constant after '='" line col)
      >]
	-> arg1::args, flav, s

    | [< '(line,col,Equal); '(_,_,String s)
	 ?? (error_msg "'=' must be followed by a string constant in line "
	       line col)
      >]
	-> [], `BaseDef, s

    | [< '(line,col,PlusEqual); '(_,_,String s)
	 ?? (error_msg "'+=' must be followed by a string constant in line "
	       line col)
      >]
	-> [], `Appendix, s

    | [< '(line,col,_) >]
	-> raise(Stream.Error(error_msg 
				"Expected a '=' or a '(arguments,...)=' clause"
				line col))

  and parse_arguments stream =
    match stream with parser
      [< '(line,col,Comma);
	 arg = parse_argument;
	 args = parse_arguments
      >]
	-> arg :: args
    | [< '(_,_,RParen) >]
	-> []
    | [< '(line,col,_) >]
	-> raise(Stream.Error(error_msg 
				"Another predicate or a ')' expected"
				line col))

  and parse_argument stream =
    match stream with parser
	[< '(line,col,Name n) >] -> `Pred n
      | [< '(line,col,Minus);
	   '(l,c,Name n) ?? (error_msg "Name expected after '-'" line col) >]
	                 -> `NegPred n
      | [< '(line,col,_) >] ->
	  raise(Stream.Error(error_msg "Name or -Name expected" line col))
	     

  and parse_flavour stream =
    match stream with parser
	[< '(line,col,Equal) >]     -> `BaseDef
      | [< '(line,col,PlusEqual) >] -> `Appendix
      | [< '(line,col,_) >] ->
	  raise(Stream.Error(error_msg "'+' or '+=' expected" line col))
  in

  let rec check_defs p l =
    match l with
      [] -> ()
    | def :: l' ->
	List.iter
	  (fun def' ->
	    if def.def_var = def'.def_var && 
	       def.def_preds = def'.def_preds &&
	       def.def_flav = `BaseDef &&
	       def'.def_flav = `BaseDef
	    then
	      let prefix = 
		if p = "" then "" else "In subpackage " ^ p ^ ": " in
	      let args =
		string_of_preds def.def_preds in
	      raise(Stream.Error (prefix ^ "Double definition of '" ^ 
				  def.def_var ^ args ^ "'"))
	  )
	  l';
	check_defs p l'
  in

  let rec check_pkg p pkg =
    check_defs p pkg.pkg_defs;
    let l = ref [] in
    List.iter
      (fun (n, subpkg) -> 
	 let p' = if p = "" then n else p ^ "." ^ n in
	 if List.mem n !l then
	   raise(Stream.Error("Double definition for subpackage " ^ p'));
	 if String.contains n '.' then
	   raise(Stream.Error("Subpackage name must not contain '.': \"" ^ n ^ "\""));
	 check_pkg p' subpkg;
	 l := n :: !l
      )
      pkg.pkg_children;
  in

  try
    let pkg = parse_all false (scan ch) in
    check_pkg "" pkg;
    pkg
  with
      Stream.Error "" ->
	raise(Stream.Error "Syntax Error")
;;


let rec print f pkg =
  let escape s = (* no Str available :-( *)
    let b = Buffer.create (String.length s) in
    for k = 0 to String.length s - 1 do
      match s.[k] with
	| '\\' -> Buffer.add_string b "\\\\"
	| '"'  -> Buffer.add_string b "\\\""
	| c    -> Buffer.add_char b c
    done;
    Buffer.contents b in
  let format_pred =
    function
      | `Pred s -> s
      | `NegPred s -> "-" ^ s in
  let print_def def =
    fprintf f "%s%s %s \"%s\"\n"
      def.def_var
      (match def.def_preds with
	 | [] -> ""
	 | l -> "(" ^ String.concat "," (List.map format_pred l) ^ ")"
      )
      (match def.def_flav with
	 | `BaseDef -> "="
	 | `Appendix -> "+="
      )
      (escape def.def_value) in
  List.iter print_def pkg.pkg_defs;
  List.iter
    (fun (name,child) ->
       fprintf f "\npackage \"%s\" (\n" (escape name);
       print f child;
       fprintf f ")\n"
    )
    pkg.pkg_children
;;


let lookup name predicate_list def =
  let fulfills actual_preds formal_preds =
    List.for_all
      (function
	   `Pred n    -> List.mem n predicate_list
	 | `NegPred n -> not(List.mem n predicate_list)
      )
      formal_preds
  in

  let rec search_base best_n best_value l =
    match l with
      [] ->
	if best_n >= 0 then
	  best_value
	else
	  raise Not_found
    | def :: l' ->
	if name = def.def_var &&
	   def.def_flav = `BaseDef &&
	   fulfills predicate_list def.def_preds &&
	   (List.length def.def_preds > best_n) 
	then
	  search_base (List.length def.def_preds) def.def_value l'
	else
	  search_base best_n best_value l'
  in

  let rec search_appdx l =
    match l with
	[] -> []
      | def :: l' ->
	  if name = def.def_var && 
	     def.def_flav = `Appendix &&
	     fulfills predicate_list def.def_preds
	  then
	    def.def_value :: search_appdx l'
	  else
	    search_appdx l'
  in

  let step_a = search_base (-1) "" def in
  let step_b = search_appdx def in

  String.concat " " (step_a :: step_b)
;;
