;;
let output_html outputhtml msg =
- htmlheader_and_content := !htmlheader_and_content ^ msg ;
- outputhtml#source (!htmlheader_and_content ^ htmlfooter) ;
- outputhtml#set_topline (-1)
+ outputhtml#log msg
;;
(* UTILITY FUNCTIONS TO DISAMBIGUATE AN URI *)
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T (Printexc.to_string e)))
)
) uris
in
let (xml, bodyxml) = ProofEngine.get_current_status_as_xml () in
Xml.pp ~quiet:true xml (Some prooffiletype) ;
output_html outputhtml
- ("<h1 color=\"Green\">Current proof type saved to " ^
- prooffiletype ^ "</h1>") ;
+ (`Msg (`T ("Current proof type saved to " ^ prooffiletype))) ;
Xml.pp ~quiet:true bodyxml (Some prooffile) ;
output_html outputhtml
- ("<h1 color=\"Green\">Current proof body saved to " ^
- prooffile ^ "</h1>")
+ (`Msg (`T ("Current proof body saved to " ^ prooffile)))
;;
(* Used to typecheck the loaded proofs *)
let decompose_uris_choice_callback = decompose_uris_choice_callback
let mk_fresh_name_callback = mk_fresh_name_callback
- let output_html msg = output_html (outputhtml ()) msg
+ let output_html msg = output_html (outputhtml ()) (`Msg (`T msg))
end
;;
module InvokeTactics' = InvokeTactics.Make (InvokeTacticsCallbacks);;
) ;
refresh_goals notebook ;
output_html outputhtml
- ("<h1 color=\"Green\">Current proof type loaded from " ^
- prooffiletype ^ "</h1>") ;
+ (`Msg (`T ("Current proof type loaded from " ^
+ prooffiletype))) ;
output_html outputhtml
- ("<h1 color=\"Green\">Current proof body loaded from " ^
- prooffile ^ "</h1>") ;
+ (`Msg (`T ("Current proof body loaded from " ^
+ prooffile))) ;
!save_set_sensitive true;
| _ -> assert false
with
InvokeTactics.RefreshSequentException e ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T ("Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e)))
| InvokeTactics.RefreshProofException e ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "proof: " ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T ("Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e)))
| e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
;;
let edit_aliases () =
with
InvokeTactics.RefreshSequentException e ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T ("Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e)))
| InvokeTactics.RefreshProofException e ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "proof: " ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T ("Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e)))
| e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T (Printexc.to_string e)))
;;
let focus () =
with
InvokeTactics.RefreshSequentException e ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T ("Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e)))
| InvokeTactics.RefreshProofException e ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "proof: " ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T ("Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e)))
| e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T (Printexc.to_string e)))
;;
exception NoPrevGoal;;
let module L = LogicalOperations in
let module G = Gdome in
let notebook = (rendering_window ())#notebook in
- let outputhtml = ((rendering_window ())#outputhtml(* : GHtml.xmhtml*)) in
+ let output = (rendering_window ())#output in
+ let outputhtml = (rendering_window ())#outputhtml in
let metasenv =
match ProofEngine.get_proof () with
None -> assert false
with
InvokeTactics.RefreshSequentException e ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T ("Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e)))
| e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T (Printexc.to_string e)))
;;
let
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
in
let show_in_show_window_uri uri =
let obj = CicEnvironment.get_obj uri in
(function uri,_ ->
MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' uri)
result in
- out "<h1>Locate Query: </h1><pre>";
- MQueryUtil.text_of_query out "" query;
- out "<h1>Result:</h1>";
- MQueryUtil.text_of_result out "<br>" result;
+ out (`Msg (`T "Locate Query:")) ;
+ MQueryUtil.text_of_query (fun m -> out (`Msg (`T m))) "" query;
+ out (`Msg (`T "Result:")) ;
+ MQueryUtil.text_of_result (fun m -> out (`Msg (`T m))) "" result;
user_uri_choice ~title:"Ambiguous input."
~msg:
("Ambiguous input \"" ^ id ^
let uri = "cic:" ^ manual_input#text in
try
ignore (Getter.resolve (UriManager.uri_of_string uri)) ;
- output_html outputhtml "<h1 color=\"Green\">OK</h1>" ;
+ output_html outputhtml (`Msg (`T "OK")) ;
true
with
Getter.Unresolved ->
output_html outputhtml
- ("<h1 color=\"Red\">URI " ^ uri ^
- " does not correspond to any object.</h1>") ;
+ (`Error (`T ("URI " ^ uri ^
+ " does not correspond to any object."))) ;
false
| UriManager.IllFormedUri _ ->
output_html outputhtml
- ("<h1 color=\"Red\">URI " ^ uri ^ " is not well-formed.</h1>") ;
+ (`Error (`T ("URI " ^ uri ^ " is not well-formed."))) ;
false
| e ->
output_html outputhtml
- ("<h1 color=\"Red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e))) ;
false
in
ignore
let get_metasenv () = !ChosenTextualParser0.metasenv
let set_metasenv metasenv = ChosenTextualParser0.metasenv := metasenv
- let output_html msg = output_html (outputhtml ()) msg;;
+ let output_html msg = output_html (outputhtml ()) (`Msg (`T msg));;
let interactive_user_uri_choice =
fun ~selection_mode ?ok ?enable_button_for_non_vars ~title ~msg ~id ->
interactive_user_uri_choice ~selection_mode ?ok
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T (Printexc.to_string e)))
;;
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
))
(* Second phase *)
and phase2 () =
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
))
(* Third phase *)
and phase3 name cons =
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
)) ;
window2#show () ;
GtkThread.main ();
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
;;
let new_proof () =
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
)) ;
window#show () ;
GtkThread.main ();
with
InvokeTactics.RefreshSequentException e ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T ("Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e)))
| InvokeTactics.RefreshProofException e ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "proof: " ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T ("Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e)))
| e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
;;
let check_term_in_scratch scratch_window metasenv context expr =
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
;;
let show () =
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
;;
exception NotADefinition;;
with
InvokeTactics.RefreshSequentException e ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T ("Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e)))
| InvokeTactics.RefreshProofException e ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "proof: " ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T ("Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e)))
| e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
;;
let show_query_results results =
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
;;
let insertQuery () =
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T (Printexc.to_string e)))
;;
let choose_must list_of_must only =
let uris' =
TacticChaser.matchConclusion
mqi_handle
- ~output_html:(output_html outputhtml) ~choose_must ()
- ~status:(proof, metano)
+ ~output_html:(fun m -> output_html outputhtml (`Msg (`T m)))
+ ~choose_must () ~status:(proof, metano)
in
let uri' =
user_uri_choice ~title:"Ambiguous input."
with
e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+ (`Error (`T (Printexc.to_string e)))
;;
let choose_selection mmlwidget (element : Gdome.element option) =
let dump_environment () =
try
let oc = open_out environmentfile in
- output_html (outputhtml ()) "<b>Dumping environment ... </b><br />";
+ output_html (outputhtml ()) (`Msg (`T "Dumping environment ..."));
CicEnvironment.dump_to_channel
- ~callback:(fun uri -> output_html (outputhtml ()) (uri ^ "<br />"))
+ ~callback:(fun uri -> output_html (outputhtml ()) (`Msg (`T uri)))
oc;
- output_html (outputhtml ()) "<b>... done!</b><br />";
+ output_html (outputhtml ()) (`Msg (`T "... done!")) ;
close_out oc
with exc ->
output_html (outputhtml ())
- (Printf.sprintf
+ (`Error (`T (Printf.sprintf
"<h1 color=\"red\">Dump failure, uncaught exception:%s</h1>"
- (Printexc.to_string exc))
+ (Printexc.to_string exc))))
;;
let restore_environment () =
try
let ic = open_in environmentfile in
- output_html (outputhtml ()) "<b>Restoring environment ... </b><br />";
+ output_html (outputhtml ()) (`Msg (`L [`T "Restoring environment ... " ; `BR]));
CicEnvironment.restore_from_channel
- ~callback:(fun uri -> output_html (outputhtml ()) (uri ^ "<br />"))
+ ~callback:(fun uri -> output_html (outputhtml ()) (`Msg (`L [`T uri ; `BR])))
ic;
- output_html (outputhtml ()) "<b>... done!</b><br />";
+ output_html (outputhtml ()) (`Msg (`T "... done!"));
close_in ic
with exc ->
output_html (outputhtml ())
- (Printf.sprintf
+ (`Error (`T (Printf.sprintf
"<h1 color=\"red\">Restore failure, uncaught exception:%s</h1>"
- (Printexc.to_string exc))
+ (Printexc.to_string exc))))
;;
(* HTML simulator (first in its kind) *)
-class fake_xmhtml ~source ~width ~height ~border_width ~packing ~show () =
- let tv = GText.view ~width ~height ~border_width ~packing ~show () in
+type log_msg =
+ [ `T of string
+ | `L of log_msg list
+ | `BR
+ ]
+;;
+
+class logger ~width ~height ~packing ~show () =
+ let scrolled_window =
+ GBin.scrolled_window ~packing ~show () in
+ let vadj = scrolled_window#vadjustment in
+ let tv =
+ GText.view ~editable:false ~cursor_visible:false
+ ~width ~height ~packing:(scrolled_window#add) () in
+ let green =
+ tv#buffer#create_tag
+ [`FOREGROUND_SET true ;
+ `FOREGROUND_GDK
+ (Gdk.Color.alloc (Gdk.Color.get_system_colormap ()) (`NAME "green"))] in
+ let red =
+ tv#buffer#create_tag
+ [`FOREGROUND_SET true ;
+ `FOREGROUND_GDK
+ (Gdk.Color.alloc (Gdk.Color.get_system_colormap ()) (`NAME "red"))] in
object
- method set_topline (_:int) = ()
- method source s = tv#buffer#insert s
+ method log (m : [`Msg of log_msg | `Error of log_msg]) =
+ let process_msg tags =
+ let rec aux =
+ function
+ `T s -> tv#buffer#insert ~tags s
+ | `L l -> List.iter aux l
+ | `BR -> tv#buffer#insert ~tags "\n"
+ in
+ aux
+ in
+ begin
+ match m with
+ `Msg m -> process_msg [green] m
+ | `Error m -> process_msg [red] m
+ end ;
+ vadj#set_value (vadj#upper)
end
;;
with
InvokeTactics.RefreshSequentException e ->
output_html (outputhtml ())
- ("<h1 color=\"red\">An error occurred while refreshing the " ^
- "sequent: " ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T ("An error occurred while refreshing the " ^
+ "sequent: " ^ Printexc.to_string e))) ;
(*notebook#remove_all_pages ~skip_switch_page_event:false ;*)
notebook#set_empty_page
| InvokeTactics.RefreshProofException e ->
output_html (outputhtml ())
- ("<h1 color=\"red\">An error occurred while refreshing the proof: " ^ Printexc.to_string e ^ "</h1>") ;
+ (`Error (`T ("An error occurred while refreshing the proof: " ^ Printexc.to_string e))) ;
output#unload
) in
(* accel group *)
GBin.frame ~shadow_type:`IN ~packing:(vboxl#pack ~expand:true ~padding:5) ()
in
let outputhtml =
- new fake_xmhtml
- (*
- GHtml.xmhtml
- *)
- ~source:"<html><body bgColor=\"white\"></body></html>"
+ new logger
~width:400 ~height: 100
- ~border_width:20
~packing:frame#add
~show:true () in
object
set_outputhtml outputhtml ;
ignore(window#event#connect#delete (fun _ -> GMain.Main.quit () ; true )) ;
Logger.log_callback :=
- (Logger.log_to_html ~print_and_flush:(output_html outputhtml))
+ (Logger.log_to_html
+ ~print_and_flush:(fun m -> (output_html outputhtml (`Msg (`T m)))))
end;;
(* MAIN *)
let rendering_window' = new rendering_window output notebook in
set_rendering_window rendering_window' ;
let print_error_as_html prefix msg =
- output_html (outputhtml ())
- ("<h1 color=\"red\">" ^ prefix ^ msg ^ "</h1>")
+ output_html (outputhtml ()) (`Error (`T (prefix ^ msg)))
in
Gdome_xslt.setErrorCallback (Some (print_error_as_html "XSLT Error: "));
Gdome_xslt.setDebugCallback
projects / helm.git / commitdiff