Commit 861c6c77 authored by Sylvain Dailler's avatar Sylvain Dailler

New incomplete why3shell.

Factor debug protocol functions.
Remade printing work for why3shell.
The Zipper was removed.
parent 7e478a08
......@@ -167,7 +167,7 @@ LIBGENERATED = src/util/config.ml \
LIB_UTIL = config bigInt util opt lists strings \
extmap extset exthtbl weakhtbl \
hashcons stdlib exn_printer pp json debug loc lexlib print_tree \
cmdline warning sysutil rc plugin bigInt number pqueue unix_scheduler
cmdline warning sysutil rc plugin bigInt number pqueue
LIB_CORE = ident ty term pattern decl theory \
task pretty dterm env trans printer model_parser
......@@ -835,7 +835,7 @@ install_local:: bin/why3session
# Why3 Shell
###############
SHELL_FILES = why3shell
SHELL_FILES = unix_scheduler why3shell
SHELLMODULES = $(addprefix src/why3shell/, $(SHELL_FILES))
......
......@@ -19,34 +19,15 @@ module Protocol_why3ide = struct
let print_request_debug r =
Debug.dprintf debug_proto "[request]";
Debug.dprintf debug_proto "%a" print_request r
let print_msg_debug m = match m with
| Proof_error (_ids, s) -> Debug.dprintf debug_proto "proof error %s" s
| Transf_error (_ids, s) -> Debug.dprintf debug_proto "transf error %s" s
| Strat_error (_ids, s) -> Debug.dprintf debug_proto "start error %s" s
| Replay_Info s -> Debug.dprintf debug_proto "replay info %s" s
| Query_Info (_ids, s) -> Debug.dprintf debug_proto "query info %s" s
| Query_Error (_ids, s) -> Debug.dprintf debug_proto "query error %s" s
| Help _s -> Debug.dprintf debug_proto "help"
| Information s -> Debug.dprintf debug_proto "info %s" s
| Task_Monitor _ -> Debug.dprintf debug_proto "task montor"
| Error s -> Debug.dprintf debug_proto "%s" s
Debug.dprintf debug_proto "%a@." print_request r
let print_msg_debug m =
Debug.dprintf debug_proto "[message]";
Debug.dprintf debug_proto "%a@." print_msg m
let print_notify_debug n =
Debug.dprintf debug_proto "[notification]";
match n with
| Node_change (_ni, _nf) -> Debug.dprintf debug_proto "node change"
| New_node (_ni, _pni, _nt, _nf) -> Debug.dprintf debug_proto "new node"
| Remove _ni -> Debug.dprintf debug_proto "remove"
| Initialized _gi -> Debug.dprintf debug_proto "initialized"
| Saved -> Debug.dprintf debug_proto "saved"
| Message msg ->
Debug.dprintf debug_proto "[message] ";
print_msg_debug msg
| Dead s -> Debug.dprintf debug_proto "dead :%s" s
| Proof_update (_ni, _pas) -> Debug.dprintf debug_proto "proof update"
| Task (_ni, _s) -> Debug.dprintf debug_proto "task"
Debug.dprintf debug_proto "%a@." print_notify n
let list_requests: ide_request list ref = ref []
......
......@@ -75,6 +75,7 @@ type request_type =
| Replay_req
| Exit_req
(* Debugging functions *)
let print_request fmt r =
match r with
| Command_req s -> fprintf fmt "command \"%s\"" s
......@@ -90,6 +91,32 @@ let print_request fmt r =
| Replay_req -> fprintf fmt "replay"
| Exit_req -> fprintf fmt "exit"
let print_msg fmt m =
match m with
| Proof_error (_ids, s) -> fprintf fmt "proof error %s" s
| Transf_error (_ids, s) -> fprintf fmt "transf error %s" s
| Strat_error (_ids, s) -> fprintf fmt "start error %s" s
| Replay_Info s -> fprintf fmt "replay info %s" s
| Query_Info (_ids, s) -> fprintf fmt "query info %s" s
| Query_Error (_ids, s) -> fprintf fmt "query error %s" s
| Help _s -> fprintf fmt "help"
| Information s -> fprintf fmt "info %s" s
| Task_Monitor _ -> fprintf fmt "task montor"
| Error s -> fprintf fmt "%s" s
let print_notify fmt n =
match n with
| Node_change (_ni, _nf) -> fprintf fmt "node change"
| New_node (_ni, _pni, _nt, _nf) -> fprintf fmt "new node"
| Remove _ni -> fprintf fmt "remove"
| Initialized _gi -> fprintf fmt "initialized"
| Saved -> fprintf fmt "saved"
| Message msg ->
print_msg fmt msg
| Dead s -> fprintf fmt "dead :%s" s
| Proof_update (_ni, _pas) -> fprintf fmt "proof update"
| Task (_ni, _s) -> fprintf fmt "task"
type ide_request = request_type * node_ID
open Session_itp
......@@ -525,20 +552,24 @@ exception Bad_prover_name of prover
| Replay_req -> replay_session (); resend_the_tree ()
| Command_req cmd ->
begin
match any_from_node_ID nid with
| APn pn_id ->
begin
match (interp config cont (Some pn_id) cmd) with
| Transform (s, _t, args) -> treat_request (Transform_req (s, args), nid)
| Query s -> P.notify (Message (Query_Info (nid, s)))
| Prove (p, limit) -> schedule_proof_attempt nid p limit
| Strategies st -> run_strategy_on_task nid st
| Help_message s -> P.notify (Message (Help s))
| QError s -> P.notify (Message (Query_Error (nid, s)))
| Other (s, _args) ->
if nid = 0 then
(* root_node is not in any_from_node_ID table *)
P.notify (Message (Information "Should be done on a proof node"))
else
match any_from_node_ID nid with
| APn pn_id ->
begin
match (interp config cont (Some pn_id) cmd) with
| Transform (s, _t, args) -> treat_request (Transform_req (s, args), nid)
| Query s -> P.notify (Message (Query_Info (nid, s)))
| Prove (p, limit) -> schedule_proof_attempt nid p limit
| Strategies st -> run_strategy_on_task nid st
| Help_message s -> P.notify (Message (Help s))
| QError s -> P.notify (Message (Query_Error (nid, s)))
| Other (s, _args) ->
P.notify (Message (Information ("Unknown command"^s)))
end
| _ ->
end
| _ ->
P.notify (Message (Information "Should be done on a proof node"))
(* TODO make it an error *)
end
......
......@@ -87,6 +87,8 @@ type request_type =
| Exit_req
val print_request: Format.formatter -> request_type -> unit
val print_msg: Format.formatter -> message_notification -> unit
val print_notify: Format.formatter -> notification -> unit
(* TODO: change to request_type * node_ID list ? *)
type ide_request = request_type * node_ID
......
......@@ -55,7 +55,7 @@ module Unix_scheduler = struct
while true do
if !print_prompt then begin
prompt_delay := !prompt_delay + 1;
if !prompt_delay = 2 then begin
if !prompt_delay = 1 then begin
Format.printf "%s@?" !prompt;
prompt_delay := 0;
print_prompt := false;
......
......@@ -15,4 +15,6 @@ module Unix_scheduler : sig
registered at the same time. Functions registered with higher
priority will be called first. *)
val main_loop: (string -> 'a) -> unit
end
This diff is collapsed.
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