Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
why3
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
125
Issues
125
List
Boards
Labels
Service Desk
Milestones
Merge Requests
15
Merge Requests
15
Operations
Operations
Incidents
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
Why3
why3
Commits
e9992947
Commit
e9992947
authored
Apr 03, 2011
by
MARCHE Claude
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
more robust XML loading
parent
2506cf61
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
240 additions
and
141 deletions
+240
-141
src/ide/newmain.ml
src/ide/newmain.ml
+16
-19
src/ide/session.ml
src/ide/session.ml
+150
-79
src/ide/session.mli
src/ide/session.mli
+4
-1
src/ide/xml.mli
src/ide/xml.mli
+14
-1
src/ide/xml.mll
src/ide/xml.mll
+56
-41
No files found.
src/ide/newmain.ml
View file @
e9992947
...
...
@@ -491,7 +491,8 @@ let () =
let
dbfname
=
Filename
.
concat
project_dir
"project.xml"
in
try
eprintf
"Opening session...@?"
;
M
.
open_session
~
provers
:
gconfig
.
provers
~
init
~
notify
dbfname
;
M
.
open_session
~
env
:
gconfig
.
env
~
provers
:
gconfig
.
provers
~
init
~
notify
dbfname
;
M
.
maximum_running_proofs
:=
gconfig
.
max_running_processes
;
eprintf
" done@."
with
e
->
...
...
@@ -1074,26 +1075,22 @@ and color_t_locs () t =
Term
.
t_fold
color_t_locs
color_f_locs
()
t
let
scroll_to_source_goal
g
=
try
let
t
=
M
.
get_task
g
in
let
id
=
(
Task
.
task_goal
t
)
.
Decl
.
pr_name
in
scroll_to_id
id
;
match
t
with
|
Some
{
Task
.
task_decl
=
{
Theory
.
td_node
=
Theory
.
Decl
{
Decl
.
d_node
=
Decl
.
Dprop
(
Decl
.
Pgoal
,
_
,
f
)}}}
->
color_f_locs
()
f
|
_
->
assert
false
with
Not_found
->
()
let
t
=
M
.
get_task
g
in
let
id
=
(
Task
.
task_goal
t
)
.
Decl
.
pr_name
in
scroll_to_id
id
;
match
t
with
|
Some
{
Task
.
task_decl
=
{
Theory
.
td_node
=
Theory
.
Decl
{
Decl
.
d_node
=
Decl
.
Dprop
(
Decl
.
Pgoal
,
_
,
f
)}}}
->
color_f_locs
()
f
|
_
->
assert
false
let
scroll_to_theory
th
=
try
let
t
=
M
.
get_theory
th
in
let
id
=
t
.
Theory
.
th_name
in
scroll_to_id
id
with
Not_found
->
()
let
t
=
M
.
get_theory
th
in
let
id
=
t
.
Theory
.
th_name
in
scroll_to_id
id
(* to be run when a row in the tree view is selected *)
let
select_row
p
=
...
...
src/ide/session.ml
View file @
e9992947
...
...
@@ -174,12 +174,16 @@ type any =
let
get_theory
t
=
match
t
.
theory
with
|
None
->
raise
Not_found
|
None
->
eprintf
"Session: theory not yet reimported, this should not happen@."
;
assert
false
|
Some
t
->
t
let
get_task
g
=
match
g
.
task
with
|
None
->
raise
Not_found
|
None
->
(* TODO: recompute the task from the parent transformation *)
assert
false
|
Some
t
->
t
let
all_files
:
file
list
ref
=
ref
[]
...
...
@@ -191,7 +195,7 @@ let get_all_files () = !all_files
(************************)
let
save_result
fmt
r
=
fprintf
fmt
"
<result status=
\"
%s
\"
time=
\"
%.2f
\"
/>@
\n
"
fprintf
fmt
"
@
\n
<result status=
\"
%s
\"
time=
\"
%.2f
\"
/>
"
(
match
r
.
Call_provers
.
pr_answer
with
|
Call_provers
.
Valid
->
"valid"
|
Call_provers
.
Failure
_
->
"failure"
...
...
@@ -207,51 +211,49 @@ let save_status fmt s =
|
Done
r
->
save_result
fmt
r
let
save_proof_attempt
fmt
_key
a
=
fprintf
fmt
"@
[<v 1><proof prover=
\"
%s
\"
edited=
\"
%s
\"
>@
\n
"
fprintf
fmt
"@
\n
@[<v 1><proof prover=
\"
%s
\"
edited=
\"
%s
\"
>
"
a
.
prover
.
prover_id
a
.
edited_as
;
save_status
fmt
a
.
proof_state
;
fprintf
fmt
"
</proof>@]@
\n
"
fprintf
fmt
"
@]@
\n
</proof>
"
let
opt
lab
fmt
=
function
|
None
->
()
|
Some
s
->
fprintf
fmt
"%s=
\"
%s
\"
"
lab
s
let
rec
save_goal
fmt
g
=
fprintf
fmt
"@
[<v 1><goal name=
\"
%s
\"
%aproved=
\"
%b
\"
>@
\n
"
fprintf
fmt
"@
\n
@[<v 1><goal name=
\"
%s
\"
%aproved=
\"
%b
\"
>
"
g
.
goal_name
(
opt
"expl"
)
g
.
goal_expl
g
.
proved
;
Hashtbl
.
iter
(
save_proof_attempt
fmt
)
g
.
external_proofs
;
Hashtbl
.
iter
(
save_trans
fmt
)
g
.
transformations
;
fprintf
fmt
"
</goal>@]@
\n
"
fprintf
fmt
"
@]@
\n
</goal>
"
and
save_trans
fmt
_
t
=
fprintf
fmt
"
<transf name=
\"
%s
\"
proved=
\"
%b
\"
>@
\n
"
fprintf
fmt
"
@
\n
@[<v 1><transf name=
\"
%s
\"
proved=
\"
%b
\"
>
"
t
.
transf
.
transformation_name
t
.
transf_proved
;
List
.
iter
(
save_goal
fmt
)
t
.
subgoals
;
fprintf
fmt
"
</transf>@
\n
"
fprintf
fmt
"
@]@
\n
</transf>
"
let
save_theory
fmt
t
=
fprintf
fmt
"@
[<v 1><theory name=
\"
%s
\"
verified=
\"
%b
\"
>@
\n
"
fprintf
fmt
"@
\n
@[<v 1><theory name=
\"
%s
\"
verified=
\"
%b
\"
>
"
t
.
theory_name
t
.
verified
;
List
.
iter
(
save_goal
fmt
)
t
.
goals
;
fprintf
fmt
"
</theory>@]@
\n
"
fprintf
fmt
"
@]@
\n
</theory>
"
let
save_file
fmt
f
=
fprintf
fmt
"@
[<v 1><file name=
\"
%s
\"
verified=
\"
%b
\"
>@
\n
"
f
.
file_name
f
.
file_verified
;
fprintf
fmt
"@
\n
@[<v 1><file name=
\"
%s
\"
verified=
\"
%b
\"
>
"
f
.
file_name
f
.
file_verified
;
List
.
iter
(
save_theory
fmt
)
f
.
theories
;
fprintf
fmt
"
</file>@]@
\n
"
fprintf
fmt
"
@]@
\n
</file>
"
let
save
fname
=
let
ch
=
open_out
fname
in
let
fmt
=
formatter_of_out_channel
ch
in
fprintf
fmt
"<?xml version=
\"
1.0
\"
encoding=
\"
UTF-8
\"
?>@
\n
"
;
(*
fprintf fmt "@[<v 1><project name=\"%s\">@\n" (Filename.basename fname);
*)
fprintf
fmt
"<!DOCTYPE why3session SYSTEM
\"
why3session.dtd
\"
>@
\n
"
;
fprintf
fmt
"@[<v 1><why3session name=
\"
%s
\"
>"
fname
;
List
.
iter
(
save_file
fmt
)
(
get_all_files
()
);
(*
fprintf fmt "</project>@]@.";
*)
fprintf
fmt
"@]@
\n
</why3session>"
;
fprintf
fmt
"@."
;
close_out
ch
let
test_save
()
=
save
"essai.xml"
...
...
@@ -924,7 +926,9 @@ let load_result r =
|
"timeout"
->
Call_provers
.
Timeout
|
"failure"
->
Call_provers
.
Failure
""
|
"highfailure"
->
Call_provers
.
Failure
""
|
_
->
assert
false
|
s
->
eprintf
"Session.load_result: unexpected status '%s'@."
s
;
assert
false
in
let
time
=
try
float_of_string
(
List
.
assoc
"time"
r
.
Xml
.
attributes
)
...
...
@@ -935,24 +939,30 @@ let load_result r =
Call_provers
.
pr_output
=
""
;
}
|
s
->
failwith
(
"Session.load_result: unexpected element "
^
s
)
eprintf
"Session.load_result: unexpected element '%s'@."
s
;
assert
false
let
rec
load_goal
~
provers
mth
acc
g
=
assert
(
g
.
Xml
.
name
=
"goal"
);
let
gname
=
try
List
.
assoc
"name"
g
.
Xml
.
attributes
with
Not_found
->
assert
false
in
let
expl
=
try
Some
(
List
.
assoc
"expl"
g
.
Xml
.
attributes
)
with
Not_found
->
None
in
let
mg
=
raw_add_goal
(
Parent_theory
mth
)
gname
expl
None
in
List
.
iter
(
load_proof_or_transf
~
provers
mg
)
g
.
Xml
.
elements
;
mg
::
acc
let
rec
load_goal
~
env
~
provers
parent
acc
g
=
match
g
.
Xml
.
name
with
|
"goal"
->
let
gname
=
try
List
.
assoc
"name"
g
.
Xml
.
attributes
with
Not_found
->
assert
false
in
let
expl
=
try
Some
(
List
.
assoc
"expl"
g
.
Xml
.
attributes
)
with
Not_found
->
None
in
let
mg
=
raw_add_goal
parent
gname
expl
None
in
List
.
iter
(
load_proof_or_transf
~
env
~
provers
mg
)
g
.
Xml
.
elements
;
mg
::
acc
|
s
->
eprintf
"Session.load_goal: unexpected element '%s'@."
s
;
assert
false
and
load_proof_or_transf
~
provers
mg
a
=
and
load_proof_or_transf
~
env
~
provers
mg
a
=
match
a
.
Xml
.
name
with
|
"proof"
->
let
prover
=
...
...
@@ -969,54 +979,115 @@ and load_proof_or_transf ~provers mg a =
|
[]
->
Undone
|
_
->
assert
false
in
let
pa
=
raw_add_external_proof
~
obsolete
:
false
~
edit
:
""
(* TODO *)
mg
p
res
let
edit
=
try
List
.
assoc
"edited"
a
.
Xml
.
attributes
with
Not_found
->
assert
false
in
let
_pa
=
raw_add_external_proof
~
obsolete
:
false
~
edit
mg
p
res
in
Hashtbl
.
add
mg
.
external_proofs
prover
pa
(* already done by raw_add_external_proof
Hashtbl.add mg.external_proofs prover pa *)
()
|
"transf"
->
let
trname
=
try
List
.
assoc
"name"
a
.
Xml
.
attributes
with
Not_found
->
assert
false
in
let
tr
=
try
lookup_transformation
env
trname
with
Not_found
->
assert
false
(* TODO *)
in
let
_proved
=
try
List
.
assoc
"proved"
a
.
Xml
.
attributes
with
Not_found
->
assert
false
in
let
mtr
=
raw_add_transformation
mg
tr
in
mtr
.
subgoals
<-
List
.
rev
(
List
.
fold_left
(
load_goal
~
env
~
provers
(
Parent_transf
mtr
))
[]
a
.
Xml
.
elements
);
(* already done by raw_add_transformation
Hashtbl.add mg.transformations trname mtr *)
()
(* TODO *)
(*
Hashtbl.add mg.transformations tr_name tr
*)
|
_
->
assert
false
let
load_theory
~
provers
mf
acc
th
=
assert
(
th
.
Xml
.
name
=
"theory"
);
let
thname
=
try
List
.
assoc
"name"
th
.
Xml
.
attributes
with
Not_found
->
assert
false
in
let
mth
=
raw_add_theory
mf
None
thname
in
mth
.
goals
<-
List
.
rev
(
List
.
fold_left
(
load_goal
~
provers
mth
)
[]
th
.
Xml
.
elements
);
mth
::
acc
let
load_file
~
provers
f
=
assert
(
f
.
Xml
.
name
=
"file"
);
let
fn
=
try
List
.
assoc
"name"
f
.
Xml
.
attributes
with
Not_found
->
assert
false
in
let
mf
=
raw_add_file
fn
in
mf
.
theories
<-
List
.
rev
(
List
.
fold_left
(
load_theory
~
provers
mf
)
[]
f
.
Xml
.
elements
)
|
s
->
eprintf
"Session.load_proof_or_transf: unexpected element '%s'@."
s
;
assert
false
let
load_theory
~
env
~
provers
mf
acc
th
=
match
th
.
Xml
.
name
with
|
"theory"
->
let
thname
=
try
List
.
assoc
"name"
th
.
Xml
.
attributes
with
Not_found
->
assert
false
in
let
mth
=
raw_add_theory
mf
None
thname
in
mth
.
goals
<-
List
.
rev
(
List
.
fold_left
(
load_goal
~
env
~
provers
(
Parent_theory
mth
))
[]
th
.
Xml
.
elements
);
mth
::
acc
|
s
->
eprintf
"Session.load_theory: unexpected element '%s'@."
s
;
assert
false
let
load_file
~
env
~
provers
f
=
match
f
.
Xml
.
name
with
|
"file"
->
let
fn
=
try
List
.
assoc
"name"
f
.
Xml
.
attributes
with
Not_found
->
assert
false
in
let
mf
=
raw_add_file
fn
in
mf
.
theories
<-
List
.
rev
(
List
.
fold_left
(
load_theory
~
env
~
provers
mf
)
[]
f
.
Xml
.
elements
)
|
s
->
eprintf
"Session.load_file: unexpected element '%s'@."
s
;
assert
false
let
load_session
~
env
~
provers
xml
=
let
cont
=
xml
.
Xml
.
content
in
match
cont
.
Xml
.
name
with
|
"why3session"
->
List
.
iter
(
load_file
~
env
~
provers
)
cont
.
Xml
.
elements
|
s
->
eprintf
"Session.load_session: unexpected element '%s'@."
s
;
assert
false
let
db_file
=
ref
""
let
open_session
~
provers
~
init
~
notify
file
=
init_fun
:=
init
;
notify_fun
:=
notify
;
db_file
:=
file
;
try
let
l
=
Xml
.
from_file
file
in
List
.
iter
(
load_file
~
provers
)
l
;
(* TODO reload the files *)
()
with
Sys_error
_
->
(* xml does not exist yet *)
()
let
save_session
()
=
save
!
db_file
let
db_file
=
ref
None
let
open_session
~
env
~
provers
~
init
~
notify
file
=
match
!
db_file
with
|
None
->
init_fun
:=
init
;
notify_fun
:=
notify
;
db_file
:=
Some
file
;
begin
try
let
xml
=
Xml
.
from_file
file
in
load_session
~
env
~
provers
xml
;
(* TODO reload the files *)
()
with
|
Sys_error
_
->
(* xml does not exist yet *)
()
|
Xml
.
Parse_error
s
->
Format
.
eprintf
"XML database corrupted, ignored (%s)@."
s
;
()
end
|
_
->
eprintf
"Session.open_session: session already opened@."
;
assert
false
let
save_session
()
=
match
!
db_file
with
|
Some
f
->
save
f
|
None
->
eprintf
"Session.save_session: no session opened@."
;
assert
false
(*****************************************************)
(* method: run a given prover on each unproved goals *)
...
...
src/ide/session.mli
View file @
e9992947
...
...
@@ -134,6 +134,7 @@ module Make(O: OBSERVER) : sig
(*****************************)
val
open_session
:
env
:
Env
.
env
->
provers
:
prover_data
Util
.
Mstr
.
t
->
init
:
(
O
.
key
->
any
->
unit
)
->
notify
:
(
any
->
unit
)
->
string
->
unit
...
...
@@ -152,8 +153,10 @@ module Make(O: OBSERVER) : sig
val
maximum_running_proofs
:
int
ref
(*
val test_save : unit -> unit
val
test_load
:
unit
->
Xml
.
element
list
val test_load : unit -> Xml.t
*)
val
save_session
:
unit
->
unit
(** enforces to save the session state on disk.
...
...
src/ide/xml.mli
View file @
e9992947
...
...
@@ -6,6 +6,19 @@ type element =
elements
:
element
list
;
}
val
from_file
:
string
->
element
list
type
t
=
{
version
:
string
;
encoding
:
string
;
doctype
:
string
;
dtd
:
string
;
content
:
element
;
}
exception
Parse_error
of
string
val
from_file
:
string
->
t
(** returns the list of XML elements from the given file.
raise [Sys_error] if the file cannot be opened.
raise [Parse_error] if the file does not follow XML syntax
*)
src/ide/xml.mll
View file @
e9992947
...
...
@@ -10,6 +10,14 @@
elements
:
element
list
;
}
type
t
=
{
version
:
string
;
encoding
:
string
;
doctype
:
string
;
dtd
:
string
;
content
:
element
;
}
let
buf
=
Buffer
.
create
17
let
rec
pop_all
group_stack
element_stack
=
...
...
@@ -22,6 +30,11 @@
elements
=
List
.
rev
element_stack
;
}
in
pop_all
g
(
e
::
elems
)
exception
Parse_error
of
string
let
parse_error
s
=
raise
(
Parse_error
s
)
}
let
space
=
[
'
'
'\t'
'\r'
'\n'
]
...
...
@@ -34,11 +47,35 @@ let mantissa = ['e''E'] sign? digit+
let
real
=
sign
?
digit
*
'.'
digit
*
mantissa
?
let
escape
=
[
'\\'
'
"''n''t''r']
rule xml_header = parse
| "
<?
xml
version
=
\
"1.0
\"
encoding=
\"
UTF-8
\"
?>"
{
elements
[]
[]
lexbuf
}
rule xml_prolog = parse
| space+
{ xml_prolog lexbuf }
| "
<?
xml
" space+ "
version
=
\
"1.0
\"
"
space
+
"?>"
{
xml_doctype
"1.0"
""
lexbuf
}
|
"<?xml"
space
+
"version=
\"
1.0
\"
"
space
+
"encoding=
\"
UTF-8
\"
"
space
+
"?>"
{
xml_doctype
"1.0"
""
lexbuf
}
|
"<?xml"
([
^
'
?
'
]
|
'
?
'
[
^
'
>
'
])
*
"?>"
{
Format
.
eprintf
"[Xml warning] prolog ignored@."
;
xml_doctype
"1.0"
""
lexbuf
}
|
_
{
failwith
"[Xml error] wrong header"
}
{
parse_error
"wrong prolog"
}
and
xml_doctype
version
encoding
=
parse
|
space
+
{
xml_doctype
version
encoding
lexbuf
}
|
"<!DOCTYPE"
space
+
(
ident
as
doctype
)
space
+
[
^
'
>
'
]
*
">"
{
match
elements
[]
[]
lexbuf
with
|
[
x
]
->
{
version
=
version
;
encoding
=
encoding
;
doctype
=
doctype
;
dtd
=
""
;
content
=
x
;
}
|
_
->
parse_error
"there should be exactly one root element"
}
|
_
{
parse_error
"wrong DOCTYPE"
}
and
elements
group_stack
element_stack
=
parse
|
space
+
...
...
@@ -48,11 +85,15 @@ and elements group_stack element_stack = parse
|
"</"
(
ident
as
celem
)
space
*
'
>
'
{
match
group_stack
with
|
[]
->
Format
.
eprintf
"[Xml warning] unexpected closing Xml element `%s'@."
celem
;
Format
.
eprintf
"[Xml warning] unexpected closing Xml element `%s'@."
celem
;
elements
group_stack
element_stack
lexbuf
|
(
elem
,
att
,
stack
)
::
g
->
if
celem
<>
elem
then
Format
.
eprintf
"[Xml warning] Xml element `%s' closed by `%s'@."
elem
celem
;
Format
.
eprintf
"[Xml warning] Xml element `%s' closed by `%s'@."
elem
celem
;
let
e
=
{
name
=
elem
;
attributes
=
att
;
...
...
@@ -71,7 +112,7 @@ and elements group_stack element_stack = parse
pop_all
group_stack
element_stack
}
|
_
as
c
{
failwith
(
"[Xml error]
invalid element starting with "
^
String
.
make
1
c
)
}
{
parse_error
(
"
invalid element starting with "
^
String
.
make
1
c
)
}
and
attributes
groupe_stack
element_stack
elem
acc
=
parse
|
space
+
...
...
@@ -88,35 +129,20 @@ and attributes groupe_stack element_stack elem acc = parse
in
elements
groupe_stack
(
e
::
element_stack
)
lexbuf
}
|
_
as
c
{
failwith
(
"[Xml error] `
>' expected, got "
^
String
.
make
1
c
)
}
{
parse_error
(
"'
>' expected, got "
^
String
.
make
1
c
)
}
|
eof
{
failwith
(
"[Xml error] unclosed element, `>' expected"
)
}
{
parse_error
"unclosed element, `>' expected"
}
and
value
=
parse
|
space
+
{
value
lexbuf
}
(*
| integer as i
{ RCint (int_of_string i) }
| real as r
{ RCfloat (float_of_string r) }
*)
|
'
"'
{ Buffer.clear buf;
string_val lexbuf }
(*
| "
true
"
{ RCbool true }
| "
false
"
{ RCbool false }
| ident as id
{ RCident id }
*)
| _ as c
{ failwith ("
[
Xml
error
]
invalid
value
starting
with
"
^ String.make 1 c) }
{ parse_error ("
invalid
value
starting
with
" ^ String.make 1 c) }
| eof
{
failwith "
[
Xml
error
]
unterminated
keyval
pair
" }
{
parse_error "
unterminated
keyval
pair
" }
and string_val = parse
| '"
'
...
...
@@ -135,26 +161,15 @@ and string_val = parse
Buffer.add_char buf c;
string_val lexbuf }
| eof
{ failwith "
[
Xml
error
]
unterminated
string
" }
{ parse_error "
unterminated
string
" }
{
let from_file f =
let c =
(*
try
*)
open_in f
(*
with Sys_error _ ->
Format.eprintf "
Cannot
open
file
%
s
@.
" f;
exit 1
*)
in
let c = open_in f in
let lb = Lexing.from_channel c in
let
l = xml_header
lb in
let
t = xml_prolog
lb in
close_in c;
List.rev l
t
}
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment