compiledDataDump.ml

open CompiledData
open Printf
open Lxm



let (long : Ident.long -> string) = 
  fun id -> 
    let str = Ident.string_of_long id in
      Str.global_replace (Str.regexp "::") "__" str

let rec string_of_const_eff = (
  function
    | Bool_const_eff true -> "true"
    | Bool_const_eff false -> "false"
    | Int_const_eff i -> sprintf "%d" i
    | Real_const_eff r -> sprintf "%f" r
    | Extern_const_eff (s,t) -> (long s)
    | Enum_const_eff   (s,t) -> (long s)
    | Struct_const_eff (fl, t) -> (
	let string_of_field = 
	  function (id, veff) -> 
	    (Ident.to_string id)^" = "^(string_of_const_eff veff)
	in
	let flst = List.map string_of_field fl in
	  (string_of_type_eff t)^"{"^(String.concat "; " flst)^"}"
      )
    | Array_const_eff (ctab, t) -> (
	let vl = Array.to_list(Array.map string_of_const_eff ctab) in
	  "["^(String.concat ", " vl)^"]"
      )
)

and string_of_type_eff = function
  | Bool_type_eff -> "bool"
  | Int_type_eff  -> "int"
  | Real_type_eff -> "real"
  | External_type_eff i -> long i
  | Enum_type_eff (i, sl) -> 
      assert (sl <>[]);
      let f sep acc s  = acc ^ sep ^ (long s) in
	(List.fold_left (f ", ")  (f "" "enum {" (List.hd sl)) (List.tl sl)) ^ "}"
  | Array_type_eff (ty, sz) -> sprintf "%s^%d" (string_of_type_eff ty) sz
  | Struct_type_eff (i, fl) -> 
      assert (fl <>[]);
      let f sep acc (id, (type_eff, const_eff_opt))  = 
	acc ^ sep ^ (Ident.to_string id) ^ " : " ^
	  (string_of_type_eff type_eff) ^
	  match const_eff_opt with
	      None -> ""
	    | Some ce -> " (" ^ (string_of_const_eff ce) ^ ")"
      in
	(List.fold_left (f "; ")  (f "" " {" (List.hd fl)) (List.tl fl)) ^ "}"
	
and string_of_type_eff_list = function
  | []  -> ""
  | [x] -> string_of_type_eff x
  | l   -> String.concat " * " (List.map string_of_type_eff l)



let rec string_of_node_key (nkey: node_key) = (
  let arg2string (sa : static_arg_eff) =
    match sa with
      | ConstStaticArgEff (id, ceff) -> sprintf "const %s" (string_of_const_eff ceff)
      | TypeStaticArgEff  (id, teff) -> sprintf "type %s" (string_of_type_eff teff)
      | NodeStaticArgEff  (id, opeff) ->
	  sprintf "node %s" (string_of_node_key opeff.node_key_eff)
  in
    match nkey with
      | (ik, []) -> long ik
      | (ik, salst) ->
	  let astrings = List.map arg2string salst in
	    sprintf "%s<<%s>>" (long ik) (String.concat ", " astrings)
)


let (string_of_var_info_eff: var_info_eff -> string) =
  fun x -> 
    (Ident.to_string x.var_name_eff) ^ ":"^(string_of_type_eff x.var_type_eff)

let string_of_decl (id,teff) = 
  (Ident.to_string id) ^ ":" ^ (string_of_type_eff teff)

let (string_of_type_decl_list : (Ident.t * type_eff) list -> string -> string) =
  fun tel sep -> 
    let str = String.concat sep (List.map string_of_decl tel) in
      str

let string_of_slice_info_eff si_eff =
  "[" ^ (string_of_int si_eff.se_first) ^ ".." ^ (string_of_int si_eff.se_last) ^
    (if si_eff.se_step = 1 then "" else " step " ^ (string_of_int si_eff.se_step)) ^
    "]"

let rec (string_of_leff : left_eff -> string) =
  function
  | LeftVarEff  (vi_eff,_) -> Ident.to_string vi_eff.var_name_eff  
  | LeftFieldEff(leff,id,_) -> (string_of_leff leff) ^ "."
  | LeftArrayEff(leff,i,_)  -> (string_of_leff leff) ^ "[" ^ (string_of_int i) ^ "]"
  | LeftSliceEff(leff,si,_) -> (string_of_leff leff) ^ (string_of_slice_info_eff si)

let (string_of_leff_list : left_eff list -> string) =
  fun l -> 
    (if List.length l = 1 then "" else "(") ^ 
      (String.concat ", " (List.map string_of_leff l)) ^ 
      (if List.length l = 1 then "" else ")") 




let rec (string_of_by_pos_op_eff : by_pos_op_eff -> val_exp_eff list -> string) =
  fun posop vel -> 
    let tuple vel = 
      if vel = [] then "" else
	"(" ^ (String.concat ", " (List.map string_of_val_exp_eff vel)) ^ ")"
    in
    let tuple_square vel = 
      if vel = [] then "" else
	"[" ^ (String.concat ", " (List.map string_of_val_exp_eff vel)) ^ "]"
    in
      match posop,vel with
	| Predef_eff Predef.IF_n, [ve1; ve2; ve3] ->
	    " if (" ^ (string_of_val_exp_eff ve1) ^ 
	    ") then (" ^ (string_of_val_exp_eff ve2) ^ 
	    ") else (" ^ (string_of_val_exp_eff ve3) ^ ")"

	| Predef_eff op, [ve1; ve2] -> 
	    if Predef.is_infix op then ("("^
	      (string_of_val_exp_eff ve1) ^ " " ^ (Predef.op2string op) ^ " " ^
		(string_of_val_exp_eff ve2) ^ ")"
	    ) else (
	      (Predef.op2string op) ^ (tuple vel)
	     )
	| Predef_eff op, _ -> (Predef.op2string op) ^ (tuple vel)

	| CALL_eff nee, _  -> (
	    string_of_node_key nee.it.node_key_eff) ^ (tuple vel)
	| IDENT_eff idref, _ -> Ident.string_of_idref idref
	| PRE_eff, _ -> "pre"  ^ (tuple vel)
	| ARROW_eff, [ve1; ve2] -> 
	    (string_of_val_exp_eff ve1) ^ " -> " ^ (string_of_val_exp_eff ve2)
	| FBY_eff, [ve1; ve2] -> 
	    (string_of_val_exp_eff ve1) ^ " fby " ^ (string_of_val_exp_eff ve2)
	| WHEN_eff, [ve1; ve2] -> 
	    (string_of_val_exp_eff ve1) ^ " when " ^ (string_of_val_exp_eff ve2)
	| CURRENT_eff,_ -> "current " ^ (tuple vel)
	| TUPLE_eff,_ -> (tuple vel)
	| WITH_eff,_ -> "with " ^ (tuple vel)
	| CONCAT_eff, [ve1; ve2] ->  
	    (string_of_val_exp_eff ve1) ^ " | " ^ (string_of_val_exp_eff ve2)
	| HAT_eff (i, teff), _ -> (string_of_type_eff teff) ^ "^" ^ (string_of_int i)
	| ARRAY_eff, _ -> tuple_square vel
	| STRUCT_ACCESS_eff(id), [ve1] ->
	    (string_of_val_exp_eff ve1) ^ "." ^ (Ident.to_string id)

	| ARRAY_ACCES_eff(i, type_eff), [ve1] ->
	    (string_of_val_exp_eff ve1) ^ "[" ^ (string_of_int i) ^ "]"

	| ARRAY_SLICE_eff(si_eff, type_eff), [ve1] -> 
	    (string_of_val_exp_eff ve1) ^ (string_of_slice_info_eff si_eff)

	| ARRAY_SLICE_eff(_,_), _ -> assert false (* todo *)
	| MERGE_eff _, _ -> assert false (* todo *)
	| ITERATOR_eff _, _ -> assert false (* todo *)

(* Cannot happen *)
	| WHEN_eff, _ -> assert false
	| ARROW_eff, _ -> assert false
	| FBY_eff, _ -> assert false
	| CONCAT_eff, _ -> assert false
	| STRUCT_ACCESS_eff(_), _ -> assert false
	| ARRAY_ACCES_eff(i, type_eff), _ -> assert false


and string_of_val_exp_eff = function
  | CallByPosEff (by_pos_op_eff, OperEff vel) ->
      (string_of_by_pos_op_eff by_pos_op_eff.it vel) 

  | CallByNameEff(by_name_op_eff, l) -> "xxx todo "


let wrap_long_line str = 
  if String.length str < 75 then str else
    let str_list = Str.split (Str.regexp " ") str in
    let new_str, reste =
      List.fold_left
	(fun (accl, acc_str) str ->
	   let new_acc_str = acc_str ^ " " ^ str in
	     if 
	       String.length new_acc_str > 75
	     then
	       (accl ^ acc_str ^ "\n\t" , str)
	     else
	       (accl, new_acc_str)
	)
	("","")
	str_list
    in
      new_str ^ " " ^ reste

let string_of_eq_info_eff (leff_list, vee) =
  wrap_long_line (
    (string_of_leff_list leff_list) ^ " = " ^ (string_of_val_exp_eff vee) ^ ";")

let (string_of_assert : val_exp_eff srcflagged -> string ) =
  fun eq_eff -> 
  wrap_long_line (
    "assert(" ^ string_of_val_exp_eff eq_eff.it ^ ");")

let (string_of_eq : eq_info_eff srcflagged -> string) =
  fun eq_eff ->
    string_of_eq_info_eff eq_eff.it



let wrap_long_profile str = 
  if String.length str < 75 then str else
    "\n"^(
      Str.global_replace (Str.regexp "returns") "\nreturns"
	(Str.global_replace (Str.regexp "(") "(\n\t"
	   (Str.global_replace (Str.regexp "; ") ";\n\t" str)))  

let (profile_of_node_exp_eff: node_exp_eff -> string) =
  fun neff ->
    wrap_long_profile 
      ((if neff.def_eff = ExternEff then "extern " else "") ^
	 (if neff.has_mem_eff then "node " else "function ") ^
	 (string_of_node_key neff.node_key_eff) ^
	 "(" ^ (string_of_type_decl_list neff.inlist_eff "; ") ^ ") returns (" ^
	 (string_of_type_decl_list neff.outlist_eff"; ") ^ ");\n")

let (string_of_node_def : node_def_eff -> string list) =
  function
    | ExternEff
    | AbstractEff -> []
    | BodyEff node_body_eff -> 
	List.append
	  (List.map string_of_assert node_body_eff.asserts_eff)
	  (List.map string_of_eq node_body_eff.eqs_eff)

    


let (type_decl: Ident.long -> type_eff -> string) =
  fun tname teff -> 
    "type " ^ (long tname) ^ 
      (match teff with 
	 | External_type_eff _ -> ";\n"
	 | _ -> " = " ^ (string_of_type_eff teff) ^ ";\n"
      )
      
let (const_decl: Ident.long -> const_eff -> string) =
  fun tname ceff -> 
    "const " ^ (long tname) ^ 
      (match ceff with 
	 | Extern_const_eff _ -> ""
	 | _ -> " = " ^ (string_of_const_eff ceff)
      ) ^ ":" ^ (string_of_type_eff (type_of_const_eff ceff)) ^ ";\n"
      
let (node_of_node_exp_eff: node_exp_eff -> string) =
  fun neff -> 
    (profile_of_node_exp_eff neff) ^ 
      (match neff.def_eff with
	 | ExternEff ->  ""
	 | AbstractEff -> ""
	 | BodyEff _ ->  
	     ((match neff.loclist_eff with None -> "" | Some [] -> ""
		 | Some l ->
		     "var\n   " ^ (string_of_type_decl_list l ";\n   ") ^ ";\n") ^
		"let\n   " ^
		 (String.concat "\n   " (string_of_node_def neff.def_eff)) ^
		 "\ntel\n-- end of node " ^
		 (string_of_node_key neff.node_key_eff) ^ "\n"
	     )
      )
      

let string_of_clock (ck : clock_eff) = (
  match ck with
      BaseClockEff -> "<base>"
   |  VarClockEff veff -> (Ident.to_string veff.var_name_eff)
)



(*---------------------------------------------------------------------
Formatage standard des erreurs de compil
----------------------------------------------------------------------*)
let node_error_string nkey = (
   Printf.sprintf "While checking %s" (string_of_node_key nkey)
)

(*---------------------------------------------------------------------
Message d'erreur (associé à un lexeme) sur stderr
----------------------------------------------------------------------*)
let print_compile_node_error nkey lxm msg = (
   Printf.eprintf "%s\n" (node_error_string nkey);
  Errors.print_compile_error lxm msg ;
   flush stderr
)

let print_global_node_error nkey msg = (
   Printf.eprintf "%s\n" (node_error_string nkey);
  Errors.print_global_error msg ;
   flush stderr
)