Commit 3e20cfe5 authored by François Bobot's avatar François Bobot

session: metas can be added

  - the symbols that appear in the metas are identified in the xml by
    their position in the task:
    - in which declaration
    - in which definition (if that apply otherwise -1)
    - in which constructor(or case in inductive predicate) (if that apply otherwise -1)
    - in which field (if that apply otherwise -1)

  - the md5sum of the prefix of the task that end with the declaration is used to know if the
    symbol have been changed, and if it is obsolete.

  - currently metas that contains obsolete symbol are removed.
parent 068ddc7b
......@@ -109,6 +109,8 @@ session
- the filenames in the location inside a session should be relative
to the session_dir.
- use the new restore_path for the metas in session?
tools
-----
......@@ -136,4 +138,3 @@ provers
- PVS: use a better name for PVS theory when printing a task, e.g.
file_theory_goal. Solution: do that when we have idents with origin
information (necessary for parsing a task).
......@@ -23,6 +23,8 @@ theory = "folder32"
goal = "file32"
prover = "wizard32"
transf = "configure32"
#TODO change metas
metas = "movefile32"
editor = "edit32"
replay = "refresh32"
cancel = "cut32"
......@@ -55,6 +57,8 @@ theory = "folder"
goal = "script"
prover = "magic_wand_2"
transf = "multitool"
#TODO change metas
metas = "ddr_memory"
editor = "pencil"
replay = "update"
cancel = "cancel"
......
......@@ -20,7 +20,7 @@
<!ATTLIST theory loccnumb CDATA #IMPLIED>
<!ATTLIST theory loccnume CDATA #IMPLIED>
<!ELEMENT goal (label*, proof*, transf*)>
<!ELEMENT goal (label*, proof*, transf*, metas*)>
<!ATTLIST goal name CDATA #REQUIRED>
<!ATTLIST goal expl CDATA #IMPLIED>
<!ATTLIST goal proved CDATA #REQUIRED>
......@@ -53,3 +53,61 @@
<!ELEMENT label EMPTY>
<!ATTLIST label name CDATA #REQUIRED>
<!ELEMENT metas (ts_pos*, ls_pos*, pr_pos*, meta_args*,goal)>
<!ATTLIST metas proved CDATA #REQUIRED>
<!ATTLIST metas expanded CDATA #IMPLIED>
<!ELEMENT ts_pos EMPTY>
<!ATTLIST ts_pos name CDATA #REQUIRED>
<!ATTLIST ts_pos arity CDATA #REQUIRED>
<!ATTLIST ts_pos id CDATA #REQUIRED>
<!ATTLIST ts_pos decl CDATA #REQUIRED>
<!ATTLIST ts_pos def CDATA #REQUIRED>
<!ATTLIST ts_pos const CDATA #REQUIRED>
<!ATTLIST ts_pos proj CDATA #REQUIRED>
<!ATTLIST ts_pos sum CDATA #REQUIRED>
<!ELEMENT ls_pos EMPTY>
<!ATTLIST ls_pos name CDATA #REQUIRED>
<!ATTLIST ls_pos id CDATA #REQUIRED>
<!ATTLIST ls_pos decl CDATA #REQUIRED>
<!ATTLIST ls_pos def CDATA #REQUIRED>
<!ATTLIST ls_pos const CDATA #REQUIRED>
<!ATTLIST ls_pos proj CDATA #REQUIRED>
<!ATTLIST ls_pos sum CDATA #REQUIRED>
<!ELEMENT pr_pos EMPTY>
<!ATTLIST pr_pos name CDATA #REQUIRED>
<!ATTLIST pr_pos id CDATA #REQUIRED>
<!ATTLIST pr_pos decl CDATA #REQUIRED>
<!ATTLIST pr_pos def CDATA #REQUIRED>
<!ATTLIST pr_pos const CDATA #REQUIRED>
<!ATTLIST pr_pos proj CDATA #REQUIRED>
<!ATTLIST pr_pos sum CDATA #REQUIRED>
<!ELEMENT meta (meta_arg_ty*, meta_arg_ts*, meta_arg_ls*, meta_arg_pr*, meta_arg_str*, meta_arg_int*)>
<!ATTLIST meta name CDATA #REQUIRED>
<!ELEMENT meta_args_ty (ty_var|ty_app)>
<!ELEMENT ty_var EMPTY>
<!ATTLIST ty_var id CDATA #REQUIRED>
<!ELEMENT ty_app (ty_var*,ty_app*)>
<!ATTLIST ty_app id CDATA #REQUIRED>
<!ELEMENT meta_args_ts EMPTY>
<!ATTLIST meta_args_ts id CDATA #REQUIRED>
<!ELEMENT meta_args_ls EMPTY>
<!ATTLIST meta_args_ls id CDATA #REQUIRED>
<!ELEMENT meta_args_pr EMPTY>
<!ATTLIST meta_args_pr id CDATA #REQUIRED>
<!ELEMENT meta_args_str EMPTY>
<!ATTLIST meta_args_str val CDATA #REQUIRED>
<!ELEMENT meta_args_int EMPTY>
<!ATTLIST meta_args_int val CDATA #REQUIRED>
......@@ -216,6 +216,12 @@ let meta_remove_prop = register_meta "remove_prop" [MTprsymbol]
~desc:"Specify@ the@ logical@ propositions@ to@ remove.@ \
Can@ be@ specified@ in@ the@ driver@ with@ the@ remove@ prop@ rule."
let meta_remove_type_symbol = register_meta "remove_type_symbol" [MTtysymbol]
~desc:"Specify@ the@ type@ symbol@ to@ remove."
let meta_remove_logic = register_meta "remove_logic" [MTlsymbol]
~desc:"Specify@ the@ logic@ symbol@ propositions@ to@ remove."
let meta_realized = register_meta "realized" [MTstring; MTstring]
~desc:"TODO??"
......
......@@ -50,6 +50,8 @@ val print_prelude_for_theory : theory -> prelude_map pp
val meta_syntax_type : meta
val meta_syntax_logic : meta
val meta_remove_prop : meta
val meta_remove_logic : meta
val meta_remove_type_symbol : meta
val meta_realized : meta
val syntax_type : tysymbol -> string -> tdecl
......
......@@ -51,6 +51,8 @@ let tds_singleton td = mk_tds (Stdecl.singleton td)
let tds_equal : tdecl_set -> tdecl_set -> bool = (==)
let tds_hash tds = Hashweak.tag_hash tds.tds_tag
let tds_compare tds1 tds2 = compare
(Hashweak.tag_hash tds1.tds_tag) (Hashweak.tag_hash tds2.tds_tag)
type clone_map = tdecl_set Mid.t
type meta_map = tdecl_set Mmeta.t
......@@ -141,6 +143,13 @@ let task_goal_fmla task = match find_goal task with
| Some (_,f) -> f
| None -> raise GoalNotFound
let task_separate_goal = function
| Some {task_decl = {td_node = Decl {d_node = Dprop (Pgoal,_,_)}} as goal;
task_prev = task} ->
goal,task
| _ -> raise GoalNotFound
let check_task task = match find_goal task with
| Some _ -> raise GoalFound
| None -> task
......@@ -369,6 +378,13 @@ let rec split i l acc = match i,l with
let merge task l = List.fold_left add_tdecl task l
type bisect_step =
| BSdone of task
| BSstep of task * (bool -> bisect_step)
(*
Simple version
let rec bisect_aux f task lt i lk =
if i < 2 then
if try f (merge task lk) with UnknownIdent _ -> false then [] else
......@@ -402,3 +418,55 @@ let bisect f task =
let task = merge None tacc in
let lt = bisect_aux f task lt i [goal] in
add_tdecl (merge task lt) goal
*)
let rec bisect_aux cont task lt i lk =
if i < 2 then
let res0 b =
if b then cont [] else
(assert (List.length lt = 1); cont lt) in
try BSstep (merge task lk, res0) with UnknownIdent _ -> res0 false
else
let i1 = i/2 in
let i2 = i/2 + i mod 2 in
let lt1,lt2 = split i1 lt [] in
let task1 = merge task lt1 in (** Can't fail *)
(** These "if then else" allow to remove big chunck with one call to f *)
let res1 b =
if b
then bisect_aux cont task lt1 i1 lk
else
let res2 b =
if b
then bisect_aux cont task lt2 i2 lk
else
let c1 lt2 =
let lk2 = List.append lt2 lk in
let c2 lt1 = cont (List.append lt1 lt2) in
bisect_aux c2 task lt1 i1 lk2 in
bisect_aux c1 task1 lt2 i2 lk in
try BSstep (merge (merge task lt2) lk, res2)
with UnknownIdent _ -> res2 false in
try BSstep (merge task1 lk,res1) with UnknownIdent _ -> res1 false
let bisect_step task =
let task,goal = match task with
| Some {task_decl = {td_node = Decl {d_node = Dprop (Pgoal,_,_)}} as td;
task_prev = task} -> task,td
| _ -> raise GoalNotFound in
let lt,i,tacc = task_fold (fun (acc,i,tacc) td ->
match td.td_node with
| Decl _ -> (td::acc,succ i,tacc)
| _ -> (acc,i,td::tacc)) ([],0,[]) task in
let task = merge None tacc in
let c1 lt =
BSdone (add_tdecl (merge task lt) goal) in
bisect_aux c1 task lt i [goal]
let bisect f task =
let rec run = function
| BSdone r -> r
| BSstep (t,c) -> run (c (f t)) in
run (bisect_step task)
......@@ -34,8 +34,11 @@ type tdecl_set = private {
val tds_equal : tdecl_set -> tdecl_set -> bool
val tds_hash : tdecl_set -> int
val tds_compare : tdecl_set -> tdecl_set -> int
val tds_empty : tdecl_set
val mk_tds : Stdecl.t -> tdecl_set
type clone_map = tdecl_set Mid.t
type meta_map = tdecl_set Mmeta.t
......@@ -96,6 +99,13 @@ val bisect : (task -> bool) -> task -> task
included in [task] and if any declarations are removed from it the
task doesn't verify test anymore *)
type bisect_step =
| BSdone of task
| BSstep of task * (bool -> bisect_step)
val bisect_step : task -> bisect_step
(** Same as before but doing it step by step *)
(** {2 realization utilities} *)
val used_theories : task -> theory Mid.t
......@@ -120,6 +130,7 @@ val task_decls : task -> decl list
val task_goal : task -> prsymbol
val task_goal_fmla : task -> term
val task_separate_goal : task -> tdecl * task
(** {2 selectors} *)
......
......@@ -175,6 +175,8 @@ let loadpath m =
let timelimit m = m.timelimit
let memlimit m = m.memlimit
let running_provers_max m = m.running_provers_max
let get_complete_command pc =
String.concat " " (pc.command :: pc.extra_options)
let set_limits m time mem running =
{ m with timelimit = time; memlimit = mem; running_provers_max = running }
......
......@@ -119,6 +119,9 @@ type config_prover = {
extra_drivers : string list;
}
val get_complete_command : config_prover -> string
(** add the extra_options to the command *)
val get_provers : config -> config_prover Mprover.t
(** [get_provers config] get the prover family stored in the Rc file. The
keys are the unique ids of the prover (argument of the family) *)
......
......@@ -343,6 +343,7 @@ let image_theory = ref !image_default
let image_goal = ref !image_default
let image_prover = ref !image_default
let image_transf = ref !image_default
let image_metas = ref !image_default
let image_editor = ref !image_default
let image_replay = ref !image_default
let image_cancel = ref !image_default
......@@ -387,6 +388,7 @@ let iconname_theory = ref ""
let iconname_goal = ref ""
let iconname_prover = ref ""
let iconname_transf = ref ""
let iconname_metas = ref ""
let iconname_editor = ref ""
let iconname_replay = ref ""
let iconname_cancel = ref ""
......@@ -430,6 +432,7 @@ let load_icon_names () =
iconname_goal := get_icon_name "goal";
iconname_prover := get_icon_name "prover";
iconname_transf := get_icon_name "transf";
iconname_metas := get_icon_name "metas";
iconname_editor := get_icon_name "editor";
iconname_replay := get_icon_name "replay";
iconname_cancel := get_icon_name "cancel";
......@@ -462,6 +465,7 @@ let resize_images size =
image_goal := image ~size !iconname_goal;
image_prover := image ~size !iconname_prover;
image_transf := image ~size !iconname_transf;
image_metas := image ~size !iconname_metas;
image_editor := image ~size !iconname_editor;
image_replay := image ~size !iconname_replay;
image_cancel := image ~size !iconname_cancel;
......
......@@ -72,6 +72,7 @@ val image_theory : GdkPixbuf.pixbuf ref
val image_goal : GdkPixbuf.pixbuf ref
val image_prover : GdkPixbuf.pixbuf ref
val image_transf : GdkPixbuf.pixbuf ref
val image_metas : GdkPixbuf.pixbuf ref
val image_editor : GdkPixbuf.pixbuf ref
val image_replay : GdkPixbuf.pixbuf ref
val image_cancel : GdkPixbuf.pixbuf ref
......
......@@ -25,6 +25,7 @@ open Why3
open Whyconf
open Gconfig
open Util
open Debug
module C = Whyconf
let debug = Debug.lookup_flag "ide_info"
......@@ -530,6 +531,9 @@ let row_expanded b iter _path =
| S.Transf tr ->
S.set_transf_expanded tr b
| S.Proof_attempt _ -> ()
| S.Metas m ->
S.set_metas_expanded m b
let (_:GtkSignal.id) =
......@@ -591,9 +595,21 @@ let update_task_view a =
task_view#source_buffer#set_text o
| S.Transf _tr ->
task_view#source_buffer#set_text ""
| S.Metas m ->
let print_meta_args =
Pp.hov 2 (Pp.print_list Pp.space Pretty.print_meta_arg) in
let print =
Pp.print_iter2 Mstr.iter Pp.newline2 Pp.newline Pp.string
(Pp.indent 2
(Pp.print_iter1 S.Smeta_args.iter Pp.newline print_meta_args))
in
task_view#source_buffer#set_text
(Pp.string_of (Pp.hov 2 print) m.S.metas_added)
module M = Session_scheduler.Make
(struct
module MA = struct
type key = GTree.row_reference
let create ?parent () =
......@@ -606,6 +622,7 @@ module M = Session_scheduler.Make
goals_model#set ~row:iter ~column:index_column (-1);
goals_model#get_row_reference (goals_model#get_path iter)
let keygen = create
let remove row =
session_needs_saving := true;
......@@ -641,6 +658,7 @@ let notify any =
| S.File f -> f.S.file_key, f.S.file_expanded
| S.Proof_attempt a -> a.S.proof_key,false
| S.Transf tr -> tr.S.transf_key,tr.S.transf_expanded
| S.Metas m -> m.S.metas_key,m.S.metas_expanded
in
(* name is set by notify since upgrade policy may update the prover name *)
goals_model#set ~row:row#iter ~column:name_column
......@@ -651,7 +669,9 @@ let notify any =
| S.Proof_attempt a ->
let p = a.S.proof_prover in
Pp.string_of_wnl C.print_prover p
| S.Transf tr -> tr.S.transf_name);
| S.Transf tr -> tr.S.transf_name
| S.Metas _m -> "Metas..."
);
let ind = goals_model#get ~row:row#iter ~column:index_column in
begin
match !current_selected_row with
......@@ -672,6 +692,8 @@ let notify any =
set_proof_state a
| S.Transf tr ->
set_row_status row tr.S.transf_verified
| S.Metas m ->
set_row_status row m.S.metas_verified
let init =
let cpt = ref (-1) in
......@@ -694,9 +716,15 @@ let init =
| S.Theory _ -> !image_theory
| S.File _ -> !image_file
| S.Proof_attempt _ -> !image_prover
| S.Transf _ -> !image_transf);
| S.Transf _ -> !image_transf
| S.Metas _ -> !image_metas);
notify any
let rec init_any any =
init (S.key_any any) any;
S.iter init_any any
(*
let unknown_prover = Gconfig.unknown_prover gconfig
......@@ -705,7 +733,10 @@ let replace_prover _ _ = false (* Gconfig.replace_prover gconfig *)
let uninstalled_prover = Gconfig.uninstalled_prover gconfig
end)
end
module M = Session_scheduler.Make(MA)
(********************)
......@@ -794,6 +825,7 @@ let sched =
M.update_session ~allow_obsolete:true session gconfig.env
gconfig.Gconfig.config
in
Debug.dprintf debug "@]@\n[Info] Opening session: update done@. @[<hov 2>";
let sched = M.init (Whyconf.running_provers_max
(Whyconf.get_main gconfig.config))
in
......@@ -898,6 +930,111 @@ let apply_trans_on_selection tr =
a)
(get_selected_row_references ())
(*****************************************************)
(* method: bisect goal *)
(*****************************************************)
let bisect_proof_attempt pa =
let eS = env_session () in
let timelimit = ref (-1) in
let set_timelimit res =
timelimit := 1 + (int_of_float (floor res.Call_provers.pr_time)) in
let rec callback lp pa c = function
| S.Undone (S.Running | S.Scheduled) -> ()
| S.Undone S.Interrupted ->
dprintf debug "Bisecting interrupted.@."
| S.Undone (S.Unedited | S.JustEdited) -> assert false
| S.InternalFailure exn ->
(** Perhaps the test can be considered false in this case? *)
dprintf debug "Bisecting interrupted by an error %a.@."
Exn_printer.exn_printer exn
| S.Done res ->
let b = res.Call_provers.pr_answer = Call_provers.Valid in
dprintf debug "Bisecting: %a.@."
Call_provers.print_prover_result res;
if b then set_timelimit res;
let r = c b in
match r with
| Task.BSdone t2 ->
dprintf debug "Bisecting done.@.";
let t1 = S.goal_task pa.S.proof_parent in
if Task.task_equal t2 t1 then
dprintf debug "But doesn't reduced the task.@."
else
begin try
let keygen = MA.keygen in
let notify = MA.notify in
let diff =
Trans.apply (Trans.apply Eliminate_definition.compute_diff t1) t2 in
(* we know that this metas are registered *)
let diff = List.map (fun (m,l) -> m.Theory.meta_name,l) diff in
let metas = S.add_registered_metas ~keygen eS diff pa.S.proof_parent in
let trans = S.add_registered_transformation ~keygen
eS "eliminate_builtin" metas.S.metas_goal in
let goal = List.hd trans.S.transf_goals in (* only one *)
let npa = S.copy_external_proof ~notify ~keygen ~obsolete:true
~goal ~env_session:eS pa in
MA.init_any (S.Metas metas);
M.run_external_proof eS sched npa
with e ->
dprintf debug "Bisecting error:@\n%a@."
Exn_printer.exn_printer e end
| Task.BSstep (t,c) ->
M.schedule_proof_attempt
~timelimit:!timelimit
~memlimit:pa.S.proof_memlimit
?old:(S.get_edited_as_abs eS.S.session pa)
~inplace:lp.S.prover_config.C.in_place
~command:(C.get_complete_command lp.S.prover_config)
~driver:lp.S.prover_driver
~callback:(callback lp pa c) sched t
in
(** Run once the complete goal in order to verify its validity and
update the proof attempt *)
let first_callback pa = function
(** this pa can be different than the first pa *)
| S.Undone (S.Running | S.Scheduled) -> ()
| S.Undone S.Interrupted ->
dprintf debug "Bisecting interrupted.@."
| S.Undone (S.Unedited | S.JustEdited) -> assert false
| S.InternalFailure exn ->
dprintf debug "proof of the initial task interrupted by an error %a.@."
Exn_printer.exn_printer exn
| S.Done res ->
if res.Call_provers.pr_answer <> Call_provers.Valid
then dprintf debug "Initial task can't be proved.@."
else
let t = S.goal_task pa.S.proof_parent in
let r = Task.bisect_step t in
match r with
| Task.BSdone res ->
assert (Task.task_equal res t);
dprintf debug "Task can't be reduced.@."
| Task.BSstep (t,c) ->
set_timelimit res;
match S.load_prover eS pa.S.proof_prover with
| None -> (* No prover so we do nothing *)
dprintf debug "Prover can't be loaded.@."
| Some lp ->
M.schedule_proof_attempt
~timelimit:!timelimit
~memlimit:pa.S.proof_memlimit
?old:(S.get_edited_as_abs eS.S.session pa)
~inplace:lp.S.prover_config.C.in_place
~command:(C.get_complete_command lp.S.prover_config)
~driver:lp.S.prover_driver
~callback:(callback lp pa c) sched t in
dprintf debug "Bisecting with %a started.@."
C.print_prover pa.S.proof_prover;
M.run_external_proof eS sched ~callback:first_callback pa
let apply_bisect_on_selection () =
List.iter
(fun r ->
let a = get_any_from_row_reference r in
S.iter_proof_attempt bisect_proof_attempt a
) (get_selected_row_references ())
(*********************************)
(* add a new file in the project *)
......@@ -1288,6 +1425,12 @@ let () =
let trans = List.sort (fun (x,_) (y,_) -> String.compare x y) trans in
List.iter iter trans in
let add_item_bisect () =
ignore(tools_factory#add_image_item
~label:"Bisect in selection"
~callback:apply_bisect_on_selection
() : GMenu.image_menu_item) in
add_refresh_provers add_separator "add separator in tools menu";
add_refresh_provers add_item_split "add split in tools menu";
add_refresh_provers add_item_inline "add inline in tools menu";
......@@ -1295,12 +1438,16 @@ let () =
"add non splitting transformations in tools menu";
add_refresh_provers (add_submenu_transform false)
"add splitting transformations in tools menu";
add_refresh_provers add_separator "add separator for metas in tools menu";
add_refresh_provers add_item_bisect "add bisect in tools menu";
(** execute them *)
add_separator ();
add_item_split ();
add_item_inline ();
add_submenu_transform true ();
add_submenu_transform false ()
add_submenu_transform false ();
add_separator ();
add_item_bisect ()
let () =
let b = GButton.button ~packing:transf_box#add ~label:"Split" () in
......@@ -1589,6 +1736,7 @@ let edit_selected_row r =
*)
M.edit_proof e sched ~default_editor:gconfig.default_editor a
| S.Transf _ -> ()
| S.Metas _ -> ()
let edit_current_proof () =
match get_selected_row_references () with
......@@ -1687,6 +1835,12 @@ let confirm_remove_row r =
`QUESTION
"Do you really want to remove the selected transformation\n\
and all its subgoals?"
| S.Metas m ->
info_window
~callback:(fun () -> M.remove_metas m)
`QUESTION
"Do you really want to remove the selected addition of metas\n\
and all its subgoals?"
let remove_proof r =
match get_any_from_row_reference r with
......@@ -1695,6 +1849,7 @@ let remove_proof r =
| S.File _file -> ()
| S.Proof_attempt a -> M.remove_proof_attempt a
| S.Transf _tr -> ()
| S.Metas _m -> ()
let confirm_remove_selection () =
match get_selected_row_references () with
......@@ -1788,6 +1943,8 @@ let select_row r =
scroll_to_source_goal a.S.proof_parent
| S.Transf tr ->
scroll_to_source_goal tr.S.transf_parent
| S.Metas m ->
scroll_to_source_goal m.S.metas_parent
(* row selection on tree view on the left *)
let (_ : GtkSignal.id) =
......
This diff is collapsed.
......@@ -25,6 +25,8 @@
Use session_scheduler if you want to queue the operations
*)
open Stdlib
val debug : Debug.flag
(** The debug flag "session" *)
......@@ -58,6 +60,27 @@ type task_option
(** Currently just an option on a task, but later perhaps
we should be able to release a task and rebuild it when needed *)
type pos_task =
{ pos_decl : int; (* nth decl in the task from top *)
pos_def : int; (* nth def in the decl *)