Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Why3
why3
Commits
c2dc9cb2
Commit
c2dc9cb2
authored
Apr 03, 2011
by
MARCHE Claude
Browse files
partial reloading of files
parent
1f4102c3
Changes
7
Hide whitespace changes
Inline
Side-by-side
misc/header.txt
View file @
c2dc9cb2
Copyright (C) 2010
Copyright (C) 2010
-2011
François Bobot
Jean-Christophe Filliâtre
Claude Marché
...
...
share/images/undone32.png
0 → 100644
View file @
c2dc9cb2
1.88 KB
src/ide/gconfig.ml
View file @
c2dc9cb2
...
...
@@ -180,7 +180,8 @@ let image ?size f =
|
Some
s
->
GdkPixbuf
.
from_file_at_size
~
width
:
s
~
height
:
s
n
let
iconname_default
=
"pausehalf32"
let
iconname_default
=
"undone32"
let
iconname_undone
=
"undone32"
let
iconname_scheduled
=
"pausehalf32"
let
iconname_running
=
"play32"
let
iconname_valid
=
"accept32"
...
...
@@ -205,6 +206,7 @@ let iconname_remove = "deletefile32"
let
iconname_cleaning
=
"trashb32"
let
image_default
=
ref
(
image
~
size
:
20
iconname_default
)
let
image_undone
=
ref
!
image_default
let
image_scheduled
=
ref
!
image_default
let
image_running
=
ref
!
image_default
let
image_valid
=
ref
!
image_default
...
...
@@ -230,6 +232,7 @@ let image_cleaning = ref !image_default
let
resize_images
size
=
image_default
:=
image
~
size
iconname_default
;
image_undone
:=
image
~
size
iconname_undone
;
image_scheduled
:=
image
~
size
iconname_scheduled
;
image_running
:=
image
~
size
iconname_running
;
image_valid
:=
image
~
size
iconname_valid
;
...
...
@@ -278,7 +281,7 @@ let show_legend_window () =
ib
image_prover
;
i
" External prover
\n
"
;
ib
image_transf
;
i
"
Split t
ransformation
\n
"
;
i
"
T
ransformation
\n
"
;
it
"Status column
\n
"
;
ib
image_scheduled
;
i
" Scheduled external proof attempt
\n
"
;
...
...
@@ -306,13 +309,13 @@ let show_legend_window () =
let
show_about_window
()
=
let
about_dialog
=
GWindow
.
about_dialog
~
name
:
"Why"
~
name
:
"Why
3
"
~
authors
:
[
"François Bobot"
;
"Jean-Christophe Filliâtre"
;
"Claude Marché"
;
"Andrei Paskevich"
]
~
copyright
:
"Copyright 2010 Univ Paris-Sud, CNRS, INRIA"
~
copyright
:
"Copyright 2010
-2011
Univ Paris-Sud, CNRS, INRIA"
~
license
:
"GNU Lesser General Public License"
~
website
:
"https://gforge.inria.fr/projects/why3"
~
website_label
:
"Project web site"
...
...
src/ide/gconfig.mli
View file @
c2dc9cb2
...
...
@@ -76,6 +76,7 @@ val image_remove : GdkPixbuf.pixbuf ref
val
image_cleaning
:
GdkPixbuf
.
pixbuf
ref
(* status icons *)
val
image_undone
:
GdkPixbuf
.
pixbuf
ref
val
image_scheduled
:
GdkPixbuf
.
pixbuf
ref
val
image_running
:
GdkPixbuf
.
pixbuf
ref
val
image_valid
:
GdkPixbuf
.
pixbuf
ref
...
...
src/ide/newmain.ml
View file @
c2dc9cb2
...
...
@@ -338,7 +338,7 @@ let clear model = model#clear ()
let
image_of_result
~
obsolete
result
=
match
result
with
|
Session
.
Undone
->
!
image_
scheduled
(* TODO *)
|
Session
.
Undone
->
!
image_
undone
|
Session
.
Scheduled
->
!
image_scheduled
|
Session
.
Running
->
!
image_running
|
Session
.
InternalFailure
_
->
!
image_failure
...
...
@@ -424,14 +424,8 @@ let init =
|
M
.
Transformation
_
->
!
image_transf
);
goals_model
#
set
~
row
~
column
:
name_column
(
match
any
with
|
M
.
Goal
g
->
(
match
g
.
M
.
goal_expl
with
|
None
->
g
.
M
.
goal_name
|
Some
s
->
s
)
|
M
.
Theory
th
->
th
.
M
.
theory_name
(*
th.M.theory.Theory.th_name.Ident.id_string
*)
|
M
.
Goal
g
->
M
.
goal_expl
g
|
M
.
Theory
th
->
M
.
theory_name
th
|
M
.
File
f
->
Filename
.
basename
f
.
M
.
file_name
|
M
.
Proof_attempt
a
->
let
p
=
a
.
M
.
prover
in
p
.
Session
.
prover_name
^
" "
^
p
.
Session
.
prover_version
...
...
@@ -440,9 +434,9 @@ let init =
let
notify
any
=
match
any
with
|
M
.
Goal
g
->
set_row_status
g
.
M
.
goal_key
g
.
M
.
proved
set_row_status
(
M
.
goal_key
g
)
(
M
.
goal_
proved
g
)
|
M
.
Theory
th
->
set_row_status
th
.
M
.
theory_key
th
.
M
.
verified
set_row_status
(
M
.
theory_key
th
)
(
M
.
verified
th
)
|
M
.
File
file
->
set_row_status
file
.
M
.
file_key
file
.
M
.
file_verified
|
M
.
Proof_attempt
a
->
...
...
@@ -488,22 +482,18 @@ let () =
let
()
=
let
dbfname
=
Filename
.
concat
project_dir
"project.xml"
in
try
eprintf
"Opening session...@?"
;
M
.
open_session
~
env
:
gconfig
.
env
~
provers
:
gconfig
.
provers
~
init
~
notify
dbfname
;
~
init
~
notify
project_dir
;
M
.
maximum_running_proofs
:=
gconfig
.
max_running_processes
;
eprintf
" done@."
with
e
->
eprintf
"Error while opening session with database '%s'@."
dbfname
;
eprintf
"Error while opening session with database '%s'@."
project_dir
;
eprintf
"Aborting...@."
;
raise
e
let
read_file
fn
=
let
fn
=
Filename
.
concat
project_dir
fn
in
Env
.
read_file
gconfig
.
env
fn
...
...
@@ -541,7 +531,7 @@ let () =
eprintf
"Info: file %s already in database@."
fn
else
try
M
.
add_file
fn
(
read_file
fn
)
M
.
add_file
fn
with
e
->
eprintf
"@[Error while reading file@ '%s':@ %a@.@]"
fn
Exn_printer
.
exn_printer
e
;
...
...
@@ -629,7 +619,7 @@ let select_file () =
let
f
=
Sysutil
.
relativize_filename
project_dir
f
in
eprintf
"Adding file '%s'@."
f
;
try
M
.
add_file
f
(
read_file
f
)
M
.
add_file
f
with
e
->
fprintf
str_formatter
"@[Error while reading file@ '%s':@ %a@]"
f
...
...
@@ -719,24 +709,24 @@ let (_ : GMenu.image_menu_item) =
let
rec
collapse_proved_goal
g
=
if
g
.
M
.
proved
then
if
M
.
goal_
proved
g
then
begin
let
row
=
g
.
M
.
goal_key
in
let
row
=
M
.
goal_key
g
in
goals_view
#
collapse_row
(
goals_model
#
get_path
row
);
end
else
Hashtbl
.
iter
(
fun
_
t
->
List
.
iter
collapse_proved_goal
t
.
M
.
subgoals
)
g
.
M
.
transformations
(
M
.
transformations
g
)
let
collapse_verified_theory
th
=
if
th
.
M
.
verified
then
if
M
.
verified
th
then
begin
let
row
=
th
.
M
.
theory_key
in
let
row
=
M
.
theory_key
th
in
goals_view
#
collapse_row
(
goals_model
#
get_path
row
);
end
else
List
.
iter
collapse_proved_goal
th
.
M
.
goals
List
.
iter
collapse_proved_goal
(
M
.
goals
th
)
let
collapse_verified_file
f
=
if
f
.
M
.
file_verified
then
...
...
src/ide/session.ml
View file @
c2dc9cb2
...
...
@@ -151,7 +151,7 @@ and transf =
and
theory
=
{
theory_name
:
string
;
theory
:
Theory
.
theory
option
;
mutable
theory
:
Theory
.
theory
option
;
theory_key
:
O
.
key
;
theory_parent
:
file
;
mutable
goals
:
goal
list
;
...
...
@@ -172,6 +172,11 @@ type any =
|
Proof_attempt
of
proof_attempt
|
Transformation
of
transf
let
theory_name
t
=
t
.
theory_name
let
theory_key
t
=
t
.
theory_key
let
verified
t
=
t
.
verified
let
goals
t
=
t
.
goals
let
get_theory
t
=
match
t
.
theory
with
|
None
->
...
...
@@ -179,6 +184,15 @@ let get_theory t =
assert
false
|
Some
t
->
t
let
goal_name
g
=
g
.
goal_name
let
goal_expl
g
=
match
g
.
goal_expl
with
|
None
->
g
.
goal_name
|
Some
s
->
s
let
goal_key
g
=
g
.
goal_key
let
goal_proved
g
=
g
.
proved
let
transformations
g
=
g
.
transformations
let
get_task
g
=
match
g
.
task
with
|
None
->
...
...
@@ -256,11 +270,6 @@ let save fname =
fprintf
fmt
"@."
;
close_out
ch
let
test_save
()
=
save
"essai.xml"
let
test_load
()
=
Xml
.
from_file
"essai.xml"
(************************)
(* actions *)
(************************)
...
...
@@ -314,38 +323,14 @@ and check_transf_proved t =
check_goal_proved
t
.
parent_goal
end
let
set_file_verified
f
=
f
.
file_verified
<-
true
;
!
notify_fun
(
File
f
)
let
set_theory_proved
~
propagate
t
=
t
.
verified
<-
true
;
!
notify_fun
(
Theory
t
);
let
f
=
t
.
theory_parent
in
if
propagate
then
if
List
.
for_all
(
fun
t
->
t
.
verified
)
f
.
theories
then
set_file_verified
f
let
rec
set_proved
~
propagate
g
=
g
.
proved
<-
true
;
!
notify_fun
(
Goal
g
);
if
propagate
then
match
g
.
parent
with
|
Parent_theory
t
->
if
List
.
for_all
(
fun
g
->
g
.
proved
)
t
.
goals
then
set_theory_proved
~
propagate
t
|
Parent_transf
t
->
if
List
.
for_all
(
fun
g
->
g
.
proved
)
t
.
subgoals
then
begin
set_proved
~
propagate
t
.
parent_goal
;
end
let
set_proof_state
~
obsolete
a
res
=
a
.
proof_state
<-
res
;
a
.
proof_obsolete
<-
obsolete
;
!
notify_fun
(
Proof_attempt
a
)
!
notify_fun
(
Proof_attempt
a
);
match
res
with
|
Done
_
->
check_goal_proved
a
.
proof_goal
|
_
->
()
(*************************)
(* Scheduler *)
...
...
@@ -645,7 +630,7 @@ let add_theory mfile name th =
tasks
in
mth
.
goals
<-
List
.
rev
goals
;
if
goals
=
[]
then
set_theory_proved
~
propagate
:
false
mth
;
check_theory_proved
mth
;
mth
let
raw_add_file
f
=
...
...
@@ -661,7 +646,15 @@ let raw_add_file f =
!
notify_fun
any
;
mfile
let
add_file
f
theories
=
let
current_env
=
ref
None
let
project_dir
=
ref
""
let
read_file
fn
=
let
fn
=
Filename
.
concat
!
project_dir
fn
in
let
env
=
match
!
current_env
with
|
None
->
assert
false
|
Some
e
->
e
in
let
theories
=
Env
.
read_file
env
fn
in
let
theories
=
Theory
.
Mnm
.
fold
(
fun
name
th
acc
->
...
...
@@ -670,10 +663,12 @@ let add_file f theories =
|
_
->
(
Loc
.
dummy_position
,
name
,
th
)
::
acc
)
theories
[]
in
let
theories
=
List
.
sort
List
.
sort
(
fun
(
l1
,_,_
)
(
l2
,_,_
)
->
Loc
.
compare
l1
l2
)
theories
in
let
add_file
f
=
let
theories
=
read_file
f
in
let
mfile
=
raw_add_file
f
in
let
mths
=
List
.
fold_left
...
...
@@ -683,7 +678,7 @@ let add_file f theories =
[]
theories
in
mfile
.
theories
<-
List
.
rev
mths
;
if
theories
=
[]
then
set
_file_verified
mfile
check
_file_verified
mfile
let
file_exists
fn
=
...
...
@@ -855,57 +850,63 @@ let reimport_root_goal mth tname goals t : Model.goal * bool =
in
reimport_any_goal (Model.Theory mth) id gname t db_goal goal_obsolete
(* reimports all files *)
let files_in_db = Db.files ()
*)
let () =
List.iter
(fun (f,fn) ->
eprintf "Reimporting file '%s'@." fn;
let mfile = Helpers.add_file_row fn f in
try
let theories = read_file fn in
let ths = Db.theories f in
let (mths,file_proved) =
List.fold_left
(fun (acc,file_proved) (_,tname,th) ->
eprintf "Reimporting theory '%s'@."tname;
let db_th =
try
Util.Mstr.find tname ths
with Not_found -> Db.add_theory f tname
in
let mth = Helpers.add_theory_row mfile th db_th in
let goals = Db.goals db_th in
let tasks = List.rev (Task.split_theory th None None) in
let goals,proved = List.fold_left
(fun (acc,proved) t ->
let (g,p) = reimport_root_goal mth tname goals t in
(g::acc,proved && p))
([],true) tasks
in
mth.Model.goals <- List.rev goals;
(* TODO: what to do with remaining tasks in Db ???
for the moment they remain in the db, but they are not shown
*)
if proved then Helpers.set_theory_proved ~propagate:false mth;
(mth::acc,file_proved && proved))
([],true) theories
in
(* TODO: detecter d'eventuelles vieilles theories, qui seraient donc
dans [ths] mais pas dans [theories]
*)
mfile.Model.theories <- List.rev mths;
if file_proved then Helpers.set_file_verified mfile
with e ->
eprintf "@[Error while reading file@ '%s':@ %a@.@]" fn
Exn_printer.exn_printer e;
exit 1
)
files_in_db
(* reloads a file *)
let
reload_file
mf
=
eprintf
"[Reload] file '%s'@."
mf
.
file_name
;
try
let
theories
=
read_file
mf
.
file_name
in
let
old_theories
=
List
.
fold_left
(
fun
acc
t
->
Util
.
Mstr
.
add
t
.
theory_name
t
acc
)
Util
.
Mstr
.
empty
mf
.
theories
in
let
mths
=
List
.
fold_left
(
fun
acc
(
_
,
tname
,
th
)
->
eprintf
"[Reload] theory '%s'@."
tname
;
let
mth
=
try
let
mth
=
Util
.
Mstr
.
find
tname
old_theories
in
mth
.
theory
<-
Some
th
;
mth
with
Not_found
->
raw_add_theory
mf
(
Some
th
)
tname
in
(*
let goals = Db.goals db_th in
let tasks = List.rev (Task.split_theory th None None) in
let goals,proved = List.fold_left
(fun (acc,proved) t ->
let (g,p) = reimport_root_goal mth tname goals t in
(g::acc,proved && p))
([],true) tasks
in
mth.Model.goals <- List.rev goals;
*)
(* TODO: what to do with remaining old theories?
for the moment they remain in the session
*)
check_theory_proved
mth
;
mth
::
acc
)
[]
theories
in
(* TODO: detecter d'eventuelles vieilles theories, qui seraient donc
dans [old_theories] mais pas dans [theories]
*)
mf
.
theories
<-
List
.
rev
mths
;
check_file_verified
mf
with
e
->
eprintf
"@[Error while reading file@ '%s':@ %a@.@]"
mf
.
file_name
Exn_printer
.
exn_printer
e
;
exit
1
(* reloads all files *)
let
reload_all
()
=
List
.
iter
reload_file
!
all_files
(****************************)
(* session opening *)
...
...
@@ -1058,18 +1059,17 @@ let load_session ~env ~provers xml =
eprintf
"Session.load_session: unexpected element '%s'@."
s
;
assert
false
let
db_file
=
ref
None
let
db_file
name
=
"why3session.xml"
let
open_session
~
env
~
provers
~
init
~
notify
file
=
match
!
db_file
with
let
open_session
~
env
~
provers
~
init
~
notify
dir
=
match
!
current_env
with
|
None
->
init_fun
:=
init
;
notify_fun
:=
notify
;
db_file
:=
Some
file
;
project_dir
:=
dir
;
current_env
:=
Some
env
;
begin
try
let
xml
=
Xml
.
from_file
file
in
let
xml
=
Xml
.
from_file
(
Filename
.
concat
dir
db_filename
)
in
load_session
~
env
~
provers
xml
;
(* TODO reload the files *)
()
reload_all
()
with
|
Sys_error
_
->
(* xml does not exist yet *)
...
...
@@ -1083,8 +1083,8 @@ let open_session ~env ~provers ~init ~notify file =
assert
false
let
save_session
()
=
match
!
db_file
with
|
Some
f
->
save
f
match
!
current_env
with
|
Some
_
->
save
(
Filename
.
concat
!
project_dir
db_filename
)
|
None
->
eprintf
"Session.save_session: no session opened@."
;
assert
false
...
...
@@ -1105,11 +1105,6 @@ let redo_external_proof g a =
let
p
=
a
.
prover
in
let
callback
result
=
set_proof_state
~
obsolete
:
false
a
result
;
match
result
with
|
Done
r
->
if
r
.
Call_provers
.
pr_answer
=
Call_provers
.
Valid
then
set_proved
~
propagate
:
true
a
.
proof_goal
|
_
->
()
in
let
old
=
if
a
.
edited_as
=
""
then
None
else
begin
...
...
@@ -1364,11 +1359,10 @@ let edit_proof ~default_editor ~project_dir a =
file
|
f
->
f
in
let
old_status
=
a
.
proof_state
in
let
callback
res
=
match
res
with
|
Done
_
->
set_proof_state
~
obsolete
:
false
a
old_status
set_proof_state
~
obsolete
:
false
a
Undone
|
_
->
set_proof_state
~
obsolete
:
false
a
res
in
...
...
src/ide/session.mli
View file @
c2dc9cb2
...
...
@@ -20,6 +20,7 @@
open
Why
(** {Prover's data} *)
type
prover_data
=
private
{
prover_id
:
string
;
prover_name
:
string
;
...
...
@@ -29,18 +30,24 @@ type prover_data = private
driver
:
Driver
.
driver
;
mutable
editor
:
string
;
}
(** record of necessary data for a given external prover *)
val
get_prover_data
:
Env
.
env
->
Util
.
Mstr
.
key
->
Whyconf
.
config_prover
->
prover_data
Util
.
Mstr
.
t
->
prover_data
Util
.
Mstr
.
t
(** loads all provers from the current configuration *)
(*
t
ransformation
s
*)
(*
* {T
ransformation
's data}
*)
type
transformation_data
(** record data for transformations *)
val
transformation_id
:
transformation_data
->
string
(** Why3 name of a transformation *)
val
lookup_transformation
:
Env
.
env
->
string
->
transformation_data
(** returns a transformation from its Why3 name *)
(** {Proof attempts} *)
type
proof_attempt_status
=
private
|
Undone
|
Scheduled
(** external proof attempt is scheduled *)
...
...
@@ -48,24 +55,55 @@ type proof_attempt_status = private
|
Done
of
Call_provers
.
prover_result
(** external proof done *)
|
InternalFailure
of
exn
(** external proof aborted by internal error *)
(** {Observers signature} *)
module
type
OBSERVER
=
sig
type
key
(** type key allowing to uniquely identify an element of
of session: a goal, a transformation, a proof attempt,
a theory or a file. See type [any] below *)
val
create
:
?
parent
:
key
->
unit
->
key
(** returns a fresh key, a new child of the given parent if any *)
val
remove
:
key
->
unit
(** removes a key *)
val
timeout
:
ms
:
int
->
(
unit
->
bool
)
->
unit
(** a handler for functions that must be called after a given time
elapsed, in milliseconds. When the given function returns
true, it must be rescheduled *)
val
idle
:
(
unit
->
bool
)
->
unit
(** a handler for a delayed function, that can be called when
there is nothing else to do. When the given function returns
true, it must be rescheduled *)
end
(** {Main functor} *)
module
Make
(
O
:
OBSERVER
)
:
sig
(*****************************)
(* *)
(* static state of a session *)
(* *)
(*****************************)
(** {static state of a session} *)
type
goal
(** a goal *)
type
transf
=
private
{
transf
:
transformation_data
;
parent_goal
:
goal
;
mutable
transf_proved
:
bool
;
transf_key
:
O
.
key
;
mutable
subgoals
:
goal
list
;
}
(** a transformation of a given goal *)
val
goal_name
:
goal
->
string
val
goal_expl
:
goal
->
string
val
get_task
:
goal
->
Task
.
task
val
goal_key
:
goal
->
O
.
key
val
goal_proved
:
goal
->
bool
val
transformations
:
goal
->
(
string
,
transf
)
Hashtbl
.
t
type
proof_attempt
=
private
{
prover
:
prover_data
;
...
...
@@ -75,40 +113,18 @@ module Make(O: OBSERVER) : sig
mutable
proof_obsolete
:
bool
;
mutable
edited_as
:
string
;
}
(** a proof attempt for a given goal *)
and
goal_parent
=
|
Parent_theory
of
theory
|
Parent_transf
of
transf
and
goal
=
private
{
goal_name
:
string
;
goal_expl
:
string
option
;
parent
:
goal_parent
;
task
:
Task
.
task
option
;
goal_key
:
O
.
key
;
mutable
proved
:
bool
;
external_proofs
:
(
string
,
proof_attempt
)
Hashtbl
.
t
;
transformations
:
(
string
,
transf
)
Hashtbl
.
t
;
}
type
theory
(** a theory, holding a collection of goals *)
and
transf
=
private
{
transf
:
transformation_data
;
parent_goal
:
goal
;
mutable
transf_proved
:
bool
;
transf_key
:
O
.
key
;
mutable
subgoals
:
goal
list
;
}
and
theory
=
private
{
theory_name
:
string
;
theory
:
Theory
.
theory
option
;
theory_key
:
O
.
key
;
theory_parent
:
file
;
mutable
goals
:
goal
list
;
mutable
verified
:
bool
;
}
val
theory_name
:
theory
->
string
val
get_theory
:
theory
->
Theory
.
theory
val
theory_key
:
theory
->
O
.
key
val
verified
:
theory
->
bool
val
goals
:
theory
->
goal
list
and
file
=
private
type
file
=
private
{
file_name
:
string
;
file_key
:
O
.
key
;
mutable
theories
:
theory
list
;
...
...
@@ -123,10 +139,6 @@ module Make(O: OBSERVER) : sig
|
Transformation
of
transf