Commit a465e9b2 authored by MARCHE Claude's avatar MARCHE Claude

restored why3session html

parent 420977e1
...@@ -822,9 +822,10 @@ install_local:: bin/why3webserver ...@@ -822,9 +822,10 @@ install_local:: bin/why3webserver
############### ###############
SESSION_FILES = why3session_lib why3session_info \ SESSION_FILES = why3session_lib why3session_info \
why3session_html \
why3session_main why3session_main
# TODO: why3session_copy why3session_rm why3session_csv why3session_run # TODO: why3session_copy why3session_rm why3session_csv why3session_run
# why3session_latex why3session_html why3session_output # why3session_latex why3session_output
SESSIONMODULES = $(addprefix src/why3session/, $(SESSION_FILES)) SESSIONMODULES = $(addprefix src/why3session/, $(SESSION_FILES))
......
This diff is collapsed.
...@@ -65,12 +65,12 @@ open Session_itp ...@@ -65,12 +65,12 @@ open Session_itp
type context = type context =
(string -> (string ->
(formatter -> unit session -> unit) -> unit session (formatter -> session -> unit) -> session
-> unit, formatter, unit) format -> unit, formatter, unit) format
let run_file (context : context) print_session fname = let run_file (context : context) print_session fname =
let project_dir = S.get_project_dir fname in let ses,_ = read_session fname in
let session,_use_shapes = S.read_session project_dir in let project_dir = get_dir ses in
let output_dir = let output_dir =
if !output_dir = "" then project_dir else !output_dir if !output_dir = "" then project_dir else !output_dir
in in
...@@ -81,8 +81,8 @@ let run_file (context : context) print_session fname = ...@@ -81,8 +81,8 @@ let run_file (context : context) print_session fname =
in in
let fmt = formatter_of_out_channel cout in let fmt = formatter_of_out_channel cout in
if !opt_context if !opt_context
then fprintf fmt context basename (print_session basename) session then fprintf fmt context basename (print_session basename) ses
else print_session basename fmt session; else print_session basename fmt ses;
pp_print_flush fmt (); pp_print_flush fmt ();
if output_dir <> "-" then close_out cout if output_dir <> "-" then close_out cout
...@@ -91,21 +91,21 @@ module Table = ...@@ -91,21 +91,21 @@ module Table =
struct struct
let rec transf_depth tr = let rec transf_depth s tr =
List.fold_left List.fold_left
(fun depth g -> max depth (goal_depth g)) 0 tr.S.transf_goals (fun depth g -> max depth (goal_depth s g)) 0 (get_sub_tasks s tr)
and goal_depth g = and goal_depth s g =
S.PHstr.fold List.fold_left
(fun _st tr depth -> max depth (1 + transf_depth tr)) (fun depth tr -> max depth (1 + transf_depth s tr))
(S.goal_transformations g) 1 1 (get_transformations s g)
let theory_depth t = let theory_depth s t =
List.fold_left List.fold_left
(fun depth g -> max depth (goal_depth g)) 0 t.S.theory_goals (fun depth g -> max depth (goal_depth s g)) 0 (theory_goals t)
let provers_stats provers theory = let provers_stats s provers theory =
S.theory_iter_proof_attempt (fun a -> theory_iter_proof_attempt s (fun a ->
Hprover.replace provers a.S.proof_prover a.S.proof_prover) theory Hprover.replace provers a.prover a.prover) theory
let print_prover = Whyconf.print_prover let print_prover = Whyconf.print_prover
...@@ -115,16 +115,16 @@ struct ...@@ -115,16 +115,16 @@ struct
if dark then "008000" else "C0FFC0" if dark then "008000" else "C0FFC0"
else "FF0000") else "FF0000")
let print_results fmt provers proofs = let print_results fmt s provers proofs =
List.iter (fun p -> List.iter (fun p ->
fprintf fmt "<td bgcolor=\"#"; fprintf fmt "<td bgcolor=\"#";
begin begin
try try
let pr = S.PHprover.find proofs p in let pr = get_proof_attempt_node s (Hprover.find proofs p) in
let s = pr.S.proof_state in let s = pr.proof_state in
begin begin
match s with match s with
| S.Done res -> | Some res ->
begin begin
match res.Call_provers.pr_answer with match res.Call_provers.pr_answer with
| Call_provers.Valid -> | Call_provers.Valid ->
...@@ -133,10 +133,10 @@ let print_results fmt provers proofs = ...@@ -133,10 +133,10 @@ let print_results fmt provers proofs =
fprintf fmt "FF0000\">Invalid" fprintf fmt "FF0000\">Invalid"
| Call_provers.Timeout -> | Call_provers.Timeout ->
fprintf fmt "FF8000\">Timeout (%ds)" fprintf fmt "FF8000\">Timeout (%ds)"
pr.S.proof_limit.Call_provers.limit_time pr.limit.Call_provers.limit_time
| Call_provers.OutOfMemory -> | Call_provers.OutOfMemory ->
fprintf fmt "FF8000\">Out Of Memory (%dM)" fprintf fmt "FF8000\">Out Of Memory (%dM)"
pr.S.proof_limit.Call_provers.limit_mem pr.limit.Call_provers.limit_mem
| Call_provers.StepLimitExceeded -> | Call_provers.StepLimitExceeded ->
fprintf fmt "FF8000\">Step limit exceeded" fprintf fmt "FF8000\">Step limit exceeded"
| Call_provers.Unknown _ -> | Call_provers.Unknown _ ->
...@@ -146,81 +146,78 @@ let print_results fmt provers proofs = ...@@ -146,81 +146,78 @@ let print_results fmt provers proofs =
| Call_provers.HighFailure -> | Call_provers.HighFailure ->
fprintf fmt "FF8000\">High Failure" fprintf fmt "FF8000\">High Failure"
end end
| S.InternalFailure _ -> fprintf fmt "E0E0E0\">Internal Failure" | None -> fprintf fmt "E0E0E0\">result missing"
| S.Interrupted -> fprintf fmt "E0E0E0\">Not yet run"
| S.Unedited -> fprintf fmt "E0E0E0\">Not yet edited"
| S.Scheduled | S.Running
| S.JustEdited -> assert false
end; end;
if pr.S.proof_obsolete then fprintf fmt " (obsolete)" if pr.S.proof_obsolete then fprintf fmt " (obsolete)"
with Not_found -> fprintf fmt "E0E0E0\">---" with Not_found -> fprintf fmt "E0E0E0\">---"
end; end;
fprintf fmt "</td>") provers fprintf fmt "</td>") provers
let rec num_lines acc tr = let rec num_lines s acc tr =
List.fold_left List.fold_left
(fun acc g -> 1 + (fun acc g -> 1 +
PHstr.fold (fun _ tr acc -> 1 + num_lines acc tr) List.fold_left (fun acc tr -> 1 + num_lines s acc tr)
(goal_transformations g) acc) acc (get_transformations s g))
acc tr.transf_goals acc (get_sub_tasks s tr)
let rec print_transf fmt depth max_depth provers tr = let rec print_transf fmt s depth max_depth provers tr =
fprintf fmt "<tr>"; fprintf fmt "<tr>";
for _i=1 to 0 (* depth-1 *) do fprintf fmt "<td></td>" done; for _i=1 to 0 (* depth-1 *) do fprintf fmt "<td></td>" done;
fprintf fmt "<td bgcolor=\"#%a\" colspan=\"%d\">" fprintf fmt "<td bgcolor=\"#%a\" colspan=\"%d\">"
(color_of_status ~dark:false) (Opt.inhabited tr.S.transf_verified) (color_of_status ~dark:false) (tn_proved s tr)
(max_depth - depth + 1); (max_depth - depth + 1);
(* for i=1 to depth-1 do fprintf fmt "&nbsp;&nbsp;&nbsp;&nbsp;" done; *) (* for i=1 to depth-1 do fprintf fmt "&nbsp;&nbsp;&nbsp;&nbsp;" done; *)
fprintf fmt "%s</td>" tr.transf_name ; let name = (get_transf_name s tr) ^
(String.concat "" (get_transf_args s tr)) in
fprintf fmt "%s</td>" name ;
for _i=1 (* depth *) to (*max_depth - 1 + *) List.length provers do for _i=1 (* depth *) to (*max_depth - 1 + *) List.length provers do
fprintf fmt "<td bgcolor=\"#E0E0E0\"></td>" fprintf fmt "<td bgcolor=\"#E0E0E0\"></td>"
done; done;
fprintf fmt "</tr>@\n"; fprintf fmt "</tr>@\n";
fprintf fmt "<td rowspan=\"%d\">&nbsp;&nbsp;</td>" (num_lines 0 tr); fprintf fmt "<td rowspan=\"%d\">&nbsp;&nbsp;</td>" (num_lines s 0 tr);
let (_:bool) = List.fold_left let (_:bool) = List.fold_left
(fun is_first g -> (fun is_first g ->
print_goal fmt is_first (depth+1) max_depth provers g; print_goal fmt s is_first (depth+1) max_depth provers g;
false) false)
true tr.transf_goals true (get_sub_tasks s tr)
in () in ()
and print_goal fmt is_first depth max_depth provers g = and print_goal fmt s is_first depth max_depth provers g =
if not is_first then fprintf fmt "<tr>"; if not is_first then fprintf fmt "<tr>";
(* for i=1 to 0 (\* depth-1 *\) do fprintf fmt "<td></td>" done; *) (* for i=1 to 0 (\* depth-1 *\) do fprintf fmt "<td></td>" done; *)
fprintf fmt "<td bgcolor=\"#%a\" colspan=\"%d\">" fprintf fmt "<td bgcolor=\"#%a\" colspan=\"%d\">"
(color_of_status ~dark:false) (Opt.inhabited (S.goal_verified g)) (color_of_status ~dark:false) (pn_proved s g)
(max_depth - depth + 1); (max_depth - depth + 1);
(* for i=1 to depth-1 do fprintf fmt "&nbsp;&nbsp;&nbsp;&nbsp;" done; *) (* for i=1 to depth-1 do fprintf fmt "&nbsp;&nbsp;&nbsp;&nbsp;" done; *)
fprintf fmt "%s</td>" (S.goal_user_name g); fprintf fmt "%s</td>" (get_proof_name s g).Ident.id_string;
(* for i=depth to max_depth-1 do fprintf fmt "<td></td>" done; *) (* for i=depth to max_depth-1 do fprintf fmt "<td></td>" done; *)
print_results fmt provers (goal_external_proofs g); print_results fmt s provers (get_proof_attempt_ids s g);
fprintf fmt "</tr>@\n"; fprintf fmt "</tr>@\n";
PHstr.iter List.iter
(fun _ tr -> print_transf fmt depth max_depth provers tr) (print_transf fmt s depth max_depth provers)
(goal_transformations g) (get_transformations s g)
let print_theory fn fmt th = let print_theory s fn fmt th =
let depth = theory_depth th in let depth = theory_depth s th in
if depth > 0 then if depth > 0 then
let provers = Hprover.create 9 in let provers = Hprover.create 9 in
provers_stats provers th; provers_stats s provers th;
let provers = let provers =
Hprover.fold (fun _ pr acc -> pr :: acc) provers [] Hprover.fold (fun _ pr acc -> pr :: acc) provers []
in in
let provers = List.sort Whyconf.Prover.compare provers in let provers = List.sort Whyconf.Prover.compare provers in
let name = let name =
try try
let (l,t,_) = Theory.restore_path th.theory_name in let (l,t,_) = Theory.restore_path (theory_name th) in
String.concat "." ([fn]@l@[t]) String.concat "." ([fn]@l@[t])
with Not_found -> fn ^ "." ^ th.theory_name.Ident.id_string with Not_found -> fn ^ "." ^ (theory_name th).Ident.id_string
in in
fprintf fmt "<h2><font color=\"#%a\">Theory \"%s\": " fprintf fmt "<h2><font color=\"#%a\">Theory \"%s\": "
(color_of_status ~dark:true) (Opt.inhabited th.S.theory_verified) (color_of_status ~dark:true) (th_proved s th)
name; name;
begin match th.S.theory_verified with if th_proved s th then
| Some t -> fprintf fmt "fully verified in %.02f s" t fprintf fmt "fully verified in %%.02f s"
| None -> fprintf fmt "not fully verified" else fprintf fmt "not fully verified";
end;
fprintf fmt "</font></h2>@\n"; fprintf fmt "</font></h2>@\n";
fprintf fmt "<table border=\"1\"><tr><td colspan=\"%d\">Obligations</td>" depth; fprintf fmt "<table border=\"1\"><tr><td colspan=\"%d\">Obligations</td>" depth;
...@@ -229,21 +226,21 @@ let rec num_lines acc tr = ...@@ -229,21 +226,21 @@ let rec num_lines acc tr =
(fun pr -> fprintf fmt "<td text-rotation=\"90\">%a</td>" print_prover pr) (fun pr -> fprintf fmt "<td text-rotation=\"90\">%a</td>" print_prover pr)
provers; provers;
fprintf fmt "</td></tr>@\n"; fprintf fmt "</td></tr>@\n";
List.iter (print_goal fmt true 1 depth provers) th.theory_goals; List.iter (print_goal fmt s true 1 depth provers) (theory_goals th);
fprintf fmt "</table>@\n" fprintf fmt "</table>@\n"
let print_file fmt f = let print_file s fmt f =
(* fprintf fmt "<h1>File %s</h1>@\n" f.file_name; *) (* fprintf fmt "<h1>File %s</h1>@\n" f.file_name; *)
let fn = Filename.basename f.file_name in let fn = Filename.basename (file_name f) in
let fn = Filename.chop_extension fn in let fn = Filename.chop_extension fn in
fprintf fmt "%a" fprintf fmt "%a"
(Pp.print_list Pp.newline (print_theory fn)) f.file_theories (Pp.print_list Pp.newline (print_theory s fn)) (file_theories f)
let print_session name fmt s = let print_session name fmt s =
fprintf fmt "<h1>Why3 Proof Results for Project \"%s\"</h1>@\n" name; fprintf fmt "<h1>Why3 Proof Results for Project \"%s\"</h1>@\n" name;
fprintf fmt "%a" fprintf fmt "%a"
(Pp.print_iter2 PHstr.iter Pp.newline Pp.nothing Pp.nothing (Pp.print_iter2 Stdlib.Hstr.iter Pp.newline Pp.nothing Pp.nothing
print_file) s.session_files (print_file s)) (get_files s)
let context : context = "<!DOCTYPE html\ let context : context = "<!DOCTYPE html\
...@@ -271,47 +268,45 @@ struct ...@@ -271,47 +268,45 @@ struct
let print_prover = Whyconf.print_prover let print_prover = Whyconf.print_prover
let print_proof_status fmt = function let print_proof_status fmt = function
| Interrupted -> fprintf fmt "Not yet run" | None -> fprintf fmt "No result"
| Unedited -> fprintf fmt "Not yet edited" | Some res -> fprintf fmt "Done: %a" Call_provers.print_prover_result res
| JustEdited | Scheduled | Running -> assert false
| Done pr -> fprintf fmt "Done: %a" Call_provers.print_prover_result pr let print_proof_attempt s fmt pa =
| InternalFailure exn -> let pa = get_proof_attempt_node s pa in
fprintf fmt "Failure: %a"Exn_printer.exn_printer exn
let print_proof_attempt fmt pa =
fprintf fmt "<li>%a : %a</li>" fprintf fmt "<li>%a : %a</li>"
print_prover pa.proof_prover print_prover pa.prover
print_proof_status pa.proof_state print_proof_status pa.proof_state
let rec print_transf fmt tr = let rec print_transf s fmt tr =
let name = (get_transf_name s tr) ^
(String.concat "" (get_transf_args s tr)) in
fprintf fmt "<li>%s : <ul>%a</ul></li>" fprintf fmt "<li>%s : <ul>%a</ul></li>"
tr.transf_name name
(Pp.print_list Pp.newline print_goal) tr.transf_goals (Pp.print_list Pp.newline (print_goal s)) (get_sub_tasks s tr)
and print_goal fmt g = and print_goal s fmt g =
fprintf fmt "<li>%s : <ul>%a%a</ul></li>" fprintf fmt "<li>%s : <ul>%a%a</ul></li>"
(goal_name g).Ident.id_string (get_proof_name s g).Ident.id_string
(Pp.print_iter2 PHprover.iter Pp.newline Pp.nothing (Pp.print_iter2 Hprover.iter Pp.newline Pp.nothing
Pp.nothing print_proof_attempt) Pp.nothing (print_proof_attempt s))
(goal_external_proofs g) (get_proof_attempt_ids s g)
(Pp.print_iter2 PHstr.iter Pp.newline Pp.nothing (Pp.print_iter1 List.iter Pp.newline (print_transf s))
Pp.nothing print_transf) (get_transformations s g)
(goal_transformations g)
let print_theory s fmt th =
let print_theory fmt th =
fprintf fmt "<li>%s : <ul>%a</ul></li>" fprintf fmt "<li>%s : <ul>%a</ul></li>"
th.theory_name.Ident.id_string (theory_name th).Ident.id_string
(Pp.print_list Pp.newline print_goal) th.theory_goals (Pp.print_list Pp.newline (print_goal s)) (theory_goals th)
let print_file fmt f = let print_file s fmt f =
fprintf fmt "<li>%s : <ul>%a</ul></li>" fprintf fmt "<li>%s : <ul>%a</ul></li>"
f.file_name (file_name f)
(Pp.print_list Pp.newline print_theory) f.file_theories (Pp.print_list Pp.newline (print_theory s)) (file_theories f)
let print_session _name fmt s = let print_session _name fmt s =
fprintf fmt "<ul>%a</ul>" fprintf fmt "<ul>%a</ul>"
(Pp.print_iter2 PHstr.iter Pp.newline Pp.nothing Pp.nothing (Pp.print_iter2 Stdlib.Hstr.iter Pp.newline Pp.nothing Pp.nothing
print_file) s.session_files (print_file s)) (get_files s)
let context : context = "<!DOCTYPE html\ let context : context = "<!DOCTYPE html\
......
...@@ -16,9 +16,9 @@ open Why3session_lib ...@@ -16,9 +16,9 @@ open Why3session_lib
let cmds = let cmds =
[| [|
Why3session_info.cmd; Why3session_info.cmd;
Why3session_html.cmd;
(* (*
Why3session_latex.cmd; Why3session_latex.cmd;
Why3session_html.cmd;
Why3session_csv.cmd; Why3session_csv.cmd;
Why3session_copy.cmd_mod; Why3session_copy.cmd_mod;
Why3session_copy.cmd_copy; Why3session_copy.cmd_copy;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment