X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fmatita%2FmatitaScript.ml;h=965969a217855a611cdb309518744553aedff1cf;hb=646ade789430669f4a6be3ecbf47d89fe865f132;hp=c64653c798bde6e90382880bd5070e060657e260;hpb=b8fbccc3b4e92586d5fc704d2d8ca27fdc729adf;p=helm.git diff --git a/helm/matita/matitaScript.ml b/helm/matita/matitaScript.ml index c64653c79..965969a21 100644 --- a/helm/matita/matitaScript.ml +++ b/helm/matita/matitaScript.ml @@ -24,9 +24,11 @@ *) open Printf - open MatitaTypes +let debug = true +let debug_print = if debug then prerr_endline else ignore + (** raised when one of the script margins (top or bottom) is reached *) exception Margin @@ -34,8 +36,16 @@ let safe_substring s i j = try String.sub s i j with Invalid_argument _ -> assert false let heading_nl_RE = Pcre.regexp "^\\s*\n\\s*" -let blanks_RE = Pcre.regexp "^\\s*$" - +let only_dust_RE = Pcre.regexp "^(\\s|\n|%%[^\n]*\n)*$" +let multiline_RE = Pcre.regexp "^\n[^\n]+$" +let newline_RE = Pcre.regexp "\n" + +let comment str = + if Pcre.pmatch ~rex:multiline_RE str then + "\n(** " ^ (Pcre.replace ~rex:newline_RE str) ^ " **)" + else + "\n(**\n" ^ str ^ "\n**)" + let first_line s = let s = Pcre.replace ~rex:heading_nl_RE s in try @@ -53,111 +63,278 @@ let prepend_text header base = let goal_ast n = let module A = TacticAst in let loc = CicAst.dummy_floc in - A.Tactical (loc, A.Tactic (loc, A.Goal (loc, n))) - -let eval_statement status mathviewer user_goal s = - let st = CicTextualParser2.parse_statement (Stream.of_string s) in - match st with - | TacticAst.Command (loc, _) | TacticAst.Tactical (loc, _) -> - let parsed_text_length = snd (CicAst.loc_of_floc loc) in - let parsed_text = safe_substring s 0 parsed_text_length in - let goal_changed = ref false in - let status = - match status.proof_status with - | Incomplete_proof (_, goal) when goal <> user_goal -> - goal_changed := true; - MatitaEngine.eval_ast status (goal_ast user_goal) - | _ -> status - in - let new_status = MatitaEngine.eval_ast status st in - let new_aliases = - match st with - | TacticAst.Command (_, TacticAst.Alias _) -> - DisambiguateTypes.Environment.empty - | _ -> MatitaSync.alias_diff ~from:status new_status - in - let new_text = - if DisambiguateTypes.Environment.is_empty new_aliases then - parsed_text - else - prepend_text (CicTextualParser2.EnvironmentP3.to_string new_aliases) - parsed_text - in - let new_text = - if !goal_changed then - prepend_text - (TacticAstPp.pp_tactic (TacticAst.Goal (loc, user_goal))(* ^ "\n"*)) - new_text + A.Executable (loc, A.Tactical (loc, A.Tactic (loc, A.Goal (loc, n)))) + +let eval_with_engine status user_goal parsed_text st = + let module TA = TacticAst in + let module TAPp = TacticAstPp in + let parsed_text_length = String.length parsed_text in + let loc, ex = + match st with TA.Executable (loc,ex) -> loc, ex | _ -> assert false + in + let goal_changed = ref false in + let status = + match status.proof_status with + | Incomplete_proof (_, goal) when goal <> user_goal -> + goal_changed := true; + MatitaEngine.eval_ast status (goal_ast user_goal) + | _ -> status + in + let new_status = MatitaEngine.eval_ast status st in + let new_aliases = + match ex with + | TA.Command (_, TA.Alias _) + | TA.Command (_, TA.Include _) -> DisambiguateTypes.Environment.empty + | _ -> MatitaSync.alias_diff ~from:status new_status + in + (* we remove the defined object since we consider them "automathic aliases" *) + let new_aliases = + let module DTE = DisambiguateTypes.Environment in + let module UM = UriManager in + DTE.fold ( + fun k ((v,_) as value) acc -> + let b = + try + let v = UM.strip_xpointer (UM.uri_of_string v) in + List.exists (fun (s,_) -> s = v) new_status.objects + with UM.IllFormedUri _ -> false + in + if b then + acc else - new_text + DTE.add k value acc + ) new_aliases DTE.empty + in + let new_text = + if DisambiguateTypes.Environment.is_empty new_aliases then + parsed_text + else + prepend_text (CicTextualParser2.EnvironmentP3.to_string new_aliases) + parsed_text + in + let new_text = + if !goal_changed then + prepend_text + (TAPp.pp_tactic (TA.Goal (loc, user_goal))(* ^ "\n"*)) + new_text + else + new_text + in + [ new_status, new_text ], parsed_text_length + +let disambiguate term status = + let module MD = MatitaDisambiguator in + let dbd = MatitaDb.instance () in + let metasenv = MatitaMisc.get_proof_metasenv status in + let context = MatitaMisc.get_proof_context status in + let aliases = MatitaMisc.get_proof_aliases status in + let interps = MD.disambiguate_term dbd context metasenv aliases term in + match interps with + | [_,_,x,_] -> x + | _ -> assert false + +let eval_macro status (mathviewer:MatitaTypes.mathViewer) urichooser + parsed_text script mac += + let module TA = TacticAst in + let module TAPp = TacticAstPp in + let module MQ = MetadataQuery in + let module MDB = MatitaDb in + let module CTC = CicTypeChecker in + let module CU = CicUniv in + (* no idea why ocaml wants this *) + let advance ?statement () = script#advance ?statement () in + let parsed_text_length = String.length parsed_text in + let dbd = MatitaDb.instance () in + match mac with + (* WHELP's stuff *) + | TA.WMatch (loc, term) -> + let term = disambiguate term status in + let l = MQ.match_term ~dbd term in + let entry = `Whelp (TAPp.pp_macro_cic (TA.WMatch (loc, term)), l) in + mathviewer#show_uri_list ~reuse:true ~entry l; + [], parsed_text_length + | TA.WInstance (loc, term) -> + let term = disambiguate term status in + let l = MQ.instance ~dbd term in + let entry = `Whelp (TAPp.pp_macro_cic (TA.WInstance (loc, term)), l) in + mathviewer#show_uri_list ~reuse:true ~entry l; + [], parsed_text_length + | TA.WLocate (loc, s) -> + let l = MQ.locate ~dbd s in + let entry = `Whelp (TAPp.pp_macro_cic (TA.WLocate (loc, s)), l) in + mathviewer#show_uri_list ~reuse:true ~entry l; + [], parsed_text_length + | TA.WElim (loc, term) -> + let term = disambiguate term status in + let uri = + match term with + | Cic.MutInd (uri,n,_) -> UriManager.uri_of_uriref uri n None + | _ -> failwith "Not a MutInd" in - [ new_status, new_text ], parsed_text_length - | TacticAst.Macro (loc, mac) -> - let parsed_text_length = snd (CicAst.loc_of_floc loc) in - (match mac with (* TODO *) - | TacticAst.Hint _ -> - let s = MatitaMisc.get_proof_status status in - let l = List.map fst - (MetadataQuery.experimental_hint ~dbd:(MatitaDb.instance ()) s) - in - List.iter prerr_endline l; - prerr_endline "FINITA LA HINT"; assert false - | TacticAst.Match (_,term) -> - let dbd = MatitaDb.instance () in - let metasenv = MatitaMisc.get_proof_metasenv status in - let context = MatitaMisc.get_proof_context status in - let aliases = MatitaMisc.get_proof_aliases status in - let (_env,_metasenv,term,_graph) = - let interps = - MatitaDisambiguator.disambiguate_term dbd context metasenv aliases term - in - match interps with - | [x] -> x - | _ -> assert false + let l = MQ.elim ~dbd uri in + let entry = `Whelp (TAPp.pp_macro_cic (TA.WElim (loc, term)), l) in + mathviewer#show_uri_list ~reuse:true ~entry l; + [], parsed_text_length + | TA.WHint (loc, term) -> + let term = disambiguate term status in + let s = ((None,[0,[],term], Cic.Meta (0,[]) ,term),0) in + let l = List.map fst (MQ.experimental_hint ~dbd s) in + let entry = `Whelp (TAPp.pp_macro_cic (TA.WHint (loc, term)), l) in + mathviewer#show_uri_list ~reuse:true ~entry l; + [], parsed_text_length + (* REAL macro *) + | TA.Hint loc -> + let s = MatitaMisc.get_proof_status status in + let l = List.map fst (MQ.experimental_hint ~dbd s) in + let selected = urichooser l in + (match selected with + | [] -> [], parsed_text_length + | [uri] -> + let ast = + TA.Executable (loc, + (TA.Tactical (loc, + TA.Tactic (loc, + TA.Apply (loc, CicAst.Uri (UriManager.string_of_uri uri,None)))))) in - List.iter prerr_endline (MetadataQuery.match_term ~dbd:dbd term); - assert false; - | TacticAst.Instance (_,term) -> - let dbd = MatitaDb.instance () in - let metasenv = MatitaMisc.get_proof_metasenv status in - let context = MatitaMisc.get_proof_context status in - let aliases = MatitaMisc.get_proof_aliases status in - let (_env,_metasenv,term,_graph) = - let interps = - MatitaDisambiguator.disambiguate_term dbd context metasenv aliases term - in - match interps with - | [x] -> x - | _ -> assert false + let new_status = MatitaEngine.eval_ast status ast in + let extra_text = + comment parsed_text ^ + "\n" ^ TAPp.pp_statement ast in - List.iter prerr_endline (MetadataQuery.instance ~dbd term); - assert false - - | TacticAst.Check (_,t) -> - let metasenv = MatitaMisc.get_proof_metasenv status in - let context = MatitaMisc.get_proof_context status in - let aliases = MatitaMisc.get_proof_aliases status in - let db = MatitaDb.instance () in - let (_env,_metasenv,term,_graph) = - let interps = - MatitaDisambiguator.disambiguate_term db context metasenv aliases t - in - match interps with - | [x] -> x - | _ -> assert false - in - let ty,_ = - CicTypeChecker.type_of_aux' metasenv context term - CicUniv.empty_ugraph - in - mathviewer # show_term (`Cic (ty,metasenv) ); - [ status, "" ] , parsed_text_length - | _ -> failwith "not implemented") + [ new_status , extra_text ], parsed_text_length + | _ -> + MatitaLog.error + "The result of the urichooser should be only 1 uri, not:\n"; + List.iter ( + fun u -> MatitaLog.error (UriManager.string_of_uri u ^ "\n") + ) selected; + assert false) + | TA.Check (_,term) -> + let metasenv = MatitaMisc.get_proof_metasenv status in + let context = MatitaMisc.get_proof_context status in + let aliases = MatitaMisc.get_proof_aliases status in + let interps = + MatitaDisambiguator.disambiguate_term + dbd context metasenv aliases term + in + let _, metasenv , term, ugraph = + match interps with + | [x] -> x + | _ -> assert false + in + let ty,_ = CTC.type_of_aux' metasenv context term ugraph in + let t_and_ty = Cic.Cast (term,ty) in + mathviewer#show_entry (`Cic (t_and_ty,metasenv)); + [], parsed_text_length +(* | TA.Abort _ -> + let rec go_back () = + let status = script#status.proof_status in + match status with + | No_proof -> () + | _ -> script#retract ();go_back() + in + [], parsed_text_length, Some go_back + | TA.Redo (_, Some i) -> [], parsed_text_length, + Some (fun () -> for j = 1 to i do advance () done) + | TA.Redo (_, None) -> [], parsed_text_length, + Some (fun () -> advance ()) + | TA.Undo (_, Some i) -> [], parsed_text_length, + Some (fun () -> for j = 1 to i do script#retract () done) + | TA.Undo (_, None) -> [], parsed_text_length, + Some (fun () -> script#retract ()) *) + (* TODO *) + | TA.Quit _ -> failwith "not implemented" + | TA.Print (_,kind) -> failwith "not implemented" + | TA.Search_pat (_, search_kind, str) -> failwith "not implemented" + | TA.Search_term (_, search_kind, term) -> failwith "not implemented" + + +let eval_executable status (mathviewer:MatitaTypes.mathViewer) urichooser +ask_confirmation user_goal parsed_text script ex = + let module TA = TacticAst in + let module TAPp = TacticAstPp in + let module MD = MatitaDisambiguator in + let module ML = MatitacleanLib in + let parsed_text_length = String.length parsed_text in + match ex with + | TA.Command (loc, _) | TA.Tactical (loc, _) -> + (try + (match ML.baseuri_of_baseuri_decl (TA.Executable (loc,ex)) with + | None -> () + | Some u -> + if not (MatitacleanLib.is_empty u) then + match + ask_confirmation + ~title:"Baseuri redefinition" + ~message:( + "Baseuri " ^ u ^ " already exists.\n" ^ + "Do you want to redefine the corresponding "^ + "part of the library?") + with + | `YES -> MatitacleanLib.clean_baseuris [u] + | `NO -> () + | `CANCEL -> raise MatitaTypes.Cancel); + eval_with_engine status user_goal parsed_text (TA.Executable (loc, ex)) + with MatitaTypes.Cancel -> [], 0) + | TA.Macro (_,mac) -> + eval_macro status mathviewer urichooser parsed_text script mac + +let rec eval_statement status (mathviewer:MatitaTypes.mathViewer) urichooser +ask_confirmation user_goal script s = + if Pcre.pmatch ~rex:only_dust_RE s then raise Margin; + let st = CicTextualParser2.parse_statement (Stream.of_string s) in + let text_of_loc loc = + let parsed_text_length = snd (CicAst.loc_of_floc loc) in + let parsed_text = safe_substring s 0 parsed_text_length in + parsed_text, parsed_text_length + in + match st with + | TacticAst.Comment (loc,_)-> + let parsed_text, parsed_text_length = text_of_loc loc in + let remain_len = String.length s - parsed_text_length in + let s = String.sub s parsed_text_length remain_len in + let s,len = + eval_statement status + mathviewer urichooser ask_confirmation user_goal script s + in + (match s with + | (status, text) :: tl -> + ((status, parsed_text ^ text)::tl), (parsed_text_length + len) + | [] -> [], 0) + | TacticAst.Executable (loc, ex) -> + let parsed_text, parsed_text_length = text_of_loc loc in + eval_executable + status mathviewer urichooser ask_confirmation + user_goal parsed_text script ex + +let fresh_script_id = + let i = ref 0 in + fun () -> incr i; !i class script ~(buffer: GText.buffer) ~(init: MatitaTypes.status) - ~(mathviewer: MatitaTypes.mathViewer) () = + ~(mathviewer: MatitaTypes.mathViewer) + ~set_star + ~ask_confirmation + ~urichooser () = object (self) - initializer self#reset () + val mutable filename = None + val scriptId = fresh_script_id () + method private getFilename = + match filename with Some f -> f | _ -> assert false + method private ppFilename = + match filename with Some f -> f | None -> sprintf ".unnamed%d.ma" scriptId + + initializer + ignore(GMain.Timeout.add ~ms:30000 + ~callback:(fun _ -> self#_saveToBackuptFile ();true)); + set_star self#ppFilename false; + ignore(buffer#connect#modified_changed + (fun _ -> if buffer#modified then + set_star self#ppFilename true + else + set_star self#ppFilename false)); + self#reset () val mutable statements = []; (** executed statements *) val mutable history = [ init ]; @@ -169,6 +346,7 @@ object (self) (** goal as seen by the user (i.e. metano corresponding to current tab) *) val mutable userGoal = ~-1 + (** text mark and tag representing locked part of a script *) val locked_mark = buffer#create_mark ~name:"locked" ~left_gravity:true buffer#start_iter @@ -180,10 +358,11 @@ object (self) method private _advance ?statement () = let s = match statement with Some s -> s | None -> self#getFuture in - if Pcre.pmatch ~rex:blanks_RE s then raise Margin; MatitaLog.debug ("evaluating: " ^ first_line s ^ " ..."); let (entries, parsed_len) = - eval_statement self#status mathviewer userGoal s in + eval_statement self#status + mathviewer urichooser ask_confirmation userGoal self s + in let (new_statuses, new_statements) = List.split entries in (* prerr_endline "evalStatement returned"; @@ -192,13 +371,17 @@ List.iter (fun s -> prerr_endline ("'" ^ s ^ "'")) new_statements; history <- List.rev new_statuses @ history; statements <- List.rev new_statements @ statements; let start = buffer#get_iter_at_mark (`MARK locked_mark) in - if statement = None then begin - let stop = start#copy#forward_chars parsed_len in - buffer#delete ~start ~stop - end; let new_text = String.concat "" new_statements in - buffer#insert ~iter:start new_text; - self#moveMark (String.length new_text); + if new_text <> String.sub s 0 parsed_len then + begin +(* prerr_endline ("new:" ^ new_text); *) +(* prerr_endline ("s:" ^ String.sub s 0 parsed_len); *) + let stop = start#copy#forward_chars parsed_len in + buffer#delete ~start ~stop; + buffer#insert ~iter:start new_text; +(* prerr_endline "AUTOMATICALLY MODIFIED!!!!!" *) + end; + self#moveMark (String.length new_text) method private _retract () = match statements, history with @@ -206,15 +389,20 @@ List.iter (fun s -> prerr_endline ("'" ^ s ^ "'")) new_statements; MatitaSync.time_travel ~present:cur_status ~past:prev_status; statements <- List.tl statements; history <- List.tl history; - self#moveMark (- (String.length last_statement)) + self#moveMark (- (String.length last_statement)); | _ -> raise Margin method advance ?statement () = try - self#_advance ?statement () + self#_advance ?statement (); + self#notify with Margin -> () - method retract () = try self#_retract () with Margin -> () + method retract () = + try + self#_retract (); + self#notify + with Margin -> () method private getFuture = buffer#get_text ~start:(buffer#get_iter_at_mark (`MARK locked_mark)) @@ -223,6 +411,7 @@ List.iter (fun s -> prerr_endline ("'" ^ s ^ "'")) new_statements; (** @param rel_offset relative offset from current position of locked_mark *) method private moveMark rel_offset = let mark = `MARK locked_mark in + let old_insert = buffer#get_iter_at_mark `INSERT in buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter; let current_mark_pos = buffer#get_iter_at_mark mark in let new_mark_pos = @@ -233,7 +422,13 @@ List.iter (fun s -> prerr_endline ("'" ^ s ^ "'")) new_statements; in buffer#move_mark mark ~where:new_mark_pos; buffer#apply_tag locked_tag ~start:buffer#start_iter ~stop:new_mark_pos; - self#notify + buffer#move_mark `INSERT old_insert; + begin + match self#status.proof_status with + Incomplete_proof (_,goal) -> self#setGoal goal + | _ -> () + end ; + while Glib.Main.pending () do ignore(Glib.Main.iteration false); done val mutable observers = [] @@ -244,34 +439,59 @@ List.iter (fun s -> prerr_endline ("'" ^ s ^ "'")) new_statements; let status = self#status in List.iter (fun o -> o status) observers - method loadFrom fname = - buffer#set_text (MatitaMisc.input_file fname); - self#goto_top - - method saveTo fname = - let oc = open_out fname in + method loadFromFile () = + buffer#set_text (MatitaMisc.input_file self#getFilename); + self#goto_top; + buffer#set_modified false + + method assignFileName file = + filename <- Some file; + + method saveToFile () = + let oc = open_out self#getFilename in output_string oc (buffer#get_text ~start:buffer#start_iter ~stop:buffer#end_iter ()); - close_out oc - + close_out oc; + buffer#set_modified false + + method private _saveToBackuptFile () = + if buffer#modified then + begin + let f = self#ppFilename ^ "~" in + let oc = open_out f in + output_string oc (buffer#get_text ~start:buffer#start_iter + ~stop:buffer#end_iter ()); + close_out oc; + MatitaLog.debug ("backup " ^ f ^ " saved") + end + method private goto_top = MatitaSync.time_travel ~present:self#status ~past:init; statements <- []; history <- [ init ]; userGoal <- ~-1; - self#notify; buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter; buffer#move_mark (`MARK locked_mark) ~where:buffer#start_iter method reset () = self#goto_top; - buffer#delete ~start:buffer#start_iter ~stop:buffer#end_iter + buffer#delete ~start:buffer#start_iter ~stop:buffer#end_iter; + self#notify method goto (pos: [`Top | `Bottom | `Cursor]) () = match pos with - | `Top -> self#goto_top + | `Top -> self#goto_top; self#notify | `Bottom -> - (try while true do self#_advance () done with Margin -> ()) + (try + let getpos _ = buffer#get_iter_at_mark (`MARK locked_mark) in + let rec dowhile pos = + self#_advance (); + if pos#compare (getpos ()) < 0 then + dowhile (getpos ()) + in + dowhile (getpos ()); + self#notify + with Margin -> ()) | `Cursor -> let locked_iter () = buffer#get_iter_at_mark (`NAME "locked") in let cursor_iter () = buffer#get_iter_at_mark `INSERT in @@ -288,9 +508,9 @@ List.iter (fun s -> prerr_endline ("'" ^ s ^ "'")) new_statements; let cmp = (locked_iter ())#compare (cursor_iter ()) in (try if cmp < 0 then (* locked < cursor *) - forward_until_cursor () + (forward_until_cursor (); self#notify) else if cmp > 0 then (* locked > cursor *) - back_until_cursor () + (back_until_cursor (); self#notify) else (* cursor = locked *) () with Margin -> ()) @@ -306,19 +526,45 @@ List.iter (fun s -> prerr_endline ("'" ^ s ^ "'")) new_statements; method proofContext = MatitaMisc.get_proof_context self#status method setGoal n = userGoal <- n + method eos = + let s = self#getFuture in + let rec is_there_and_executable s = + if Pcre.pmatch ~rex:only_dust_RE s then raise Margin; + let st = CicTextualParser2.parse_statement (Stream.of_string s) in + match st with + | TacticAst.Comment (loc,_)-> + let parsed_text_length = snd (CicAst.loc_of_floc loc) in + let remain_len = String.length s - parsed_text_length in + let next = String.sub s parsed_text_length remain_len in + is_there_and_executable next + | TacticAst.Executable (loc, ex) -> false + in + try + is_there_and_executable s + with + | CicTextualParser2.Parse_error _ -> false + | Margin -> true + + + (* debug *) method dump () = MatitaLog.debug "script status:"; MatitaLog.debug ("history size: " ^ string_of_int (List.length history)); MatitaLog.debug (sprintf "%d statements:" (List.length statements)); List.iter MatitaLog.debug statements; + MatitaLog.debug ("Current file name: " ^ + (match filename with None -> "[ no name ]" | Some f -> f)); end let _script = ref None -let script ~buffer ~init ~mathviewer () = - let s = new script ~buffer ~init ~mathviewer () in +let script ~buffer ~init ~mathviewer ~urichooser ~ask_confirmation ~set_star () += + let s = new script + ~buffer ~init ~mathviewer ~ask_confirmation ~urichooser ~set_star () + in _script := Some s; s