X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=matita%2Fcomponents%2Fgrafite_engine%2FgrafiteEngine.ml;h=f2876d2a9b6fb977cd0a42e5103ed85dbd657545;hb=489639a3c319d0349a9c864fd0eeaf659daa3d3f;hp=ad90b2b2e1db3c66c735fc0c7fbb93d8094d9485;hpb=28b5d3d14776fe5ce47b0da09edaf4c505872d1e;p=helm.git diff --git a/matita/components/grafite_engine/grafiteEngine.ml b/matita/components/grafite_engine/grafiteEngine.ml index ad90b2b2e..f2876d2a9 100644 --- a/matita/components/grafite_engine/grafiteEngine.ml +++ b/matita/components/grafite_engine/grafiteEngine.ml @@ -25,14 +25,7 @@ (* $Id$ *) -module PEH = ProofEngineHelpers - -exception Drop (* mo file name, ma file name *) -exception IncludedFileNotCompiled of string * string -exception Macro of - GrafiteAst.loc * - (Cic.context -> GrafiteTypes.status * (Cic.term,Cic.lazy_term) GrafiteAst.macro) exception NMacro of GrafiteAst.loc * GrafiteAst.nmacro type 'a disambiguator_input = string * int * 'a @@ -41,470 +34,35 @@ type options = { do_heavy_checks: bool ; } -let concat_nuris uris nuris = - match uris,nuris with - | `New uris, `New nuris -> `New (nuris@uris) - | _ -> assert false -;; -(** create a ProofEngineTypes.mk_fresh_name_type function which uses given - * names as long as they are available, then it fallbacks to name generation - * using FreshNamesGenerator module *) -let namer_of names = - let len = List.length names in - let count = ref 0 in - fun metasenv context name ~typ -> - if !count < len then begin - let name = match List.nth names !count with - | Some s -> Cic.Name s - | None -> Cic.Anonymous - in - incr count; - name - end else - FreshNamesGenerator.mk_fresh_name ~subst:[] metasenv context name ~typ - -let rec tactic_of_ast status ast = - let module PET = ProofEngineTypes in - match ast with - (* Higher order tactics *) - | GrafiteAst.Do (loc, n, tactic) -> - Tacticals.do_tactic n (tactic_of_ast status tactic) - | GrafiteAst.Seq (loc, tactics) -> (* tac1; tac2; ... *) - Tacticals.seq (List.map (tactic_of_ast status) tactics) - | GrafiteAst.Repeat (loc, tactic) -> - Tacticals.repeat_tactic (tactic_of_ast status tactic) - | GrafiteAst.Then (loc, tactic, tactics) -> (* tac; [ tac1 | ... ] *) - Tacticals.thens - (tactic_of_ast status tactic) - (List.map (tactic_of_ast status) tactics) - | GrafiteAst.First (loc, tactics) -> - Tacticals.first (List.map (tactic_of_ast status) tactics) - | GrafiteAst.Try (loc, tactic) -> - Tacticals.try_tactic (tactic_of_ast status tactic) - | GrafiteAst.Solve (loc, tactics) -> - Tacticals.solve_tactics (List.map (tactic_of_ast status) tactics) - | GrafiteAst.Progress (loc, tactic) -> - Tacticals.progress_tactic (tactic_of_ast status tactic) - (* First order tactics *) - | GrafiteAst.Absurd (_, term) -> Tactics.absurd term - | GrafiteAst.Apply (_, term) -> Tactics.apply term - | GrafiteAst.ApplyRule (_, term) -> Tactics.apply term - | GrafiteAst.ApplyP (_, term) -> Tactics.applyP term - | GrafiteAst.ApplyS (_, term, params) -> - Tactics.applyS ~term ~params ~dbd:(LibraryDb.instance ()) - ~automation_cache:status#automation_cache - | GrafiteAst.Assumption _ -> Tactics.assumption - | GrafiteAst.AutoBatch (_,params) -> - Tactics.auto ~params ~dbd:(LibraryDb.instance ()) - ~automation_cache:status#automation_cache - | GrafiteAst.Cases (_, what, pattern, (howmany, names)) -> - Tactics.cases_intros ?howmany ~mk_fresh_name_callback:(namer_of names) - ~pattern what - | GrafiteAst.Change (_, pattern, with_what) -> - Tactics.change ~pattern with_what - | GrafiteAst.Clear (_,id) -> Tactics.clear id - | GrafiteAst.ClearBody (_,id) -> Tactics.clearbody id - | GrafiteAst.Compose (_,t1,t2,times,(howmany, names)) -> - Tactics.compose times t1 t2 ?howmany - ~mk_fresh_name_callback:(namer_of names) - | GrafiteAst.Contradiction _ -> Tactics.contradiction - | GrafiteAst.Constructor (_, n) -> Tactics.constructor n - | GrafiteAst.Cut (_, ident, term) -> - let names = match ident with None -> [] | Some id -> [Some id] in - Tactics.cut ~mk_fresh_name_callback:(namer_of names) term - | GrafiteAst.Decompose (_, names) -> - let mk_fresh_name_callback = namer_of names in - Tactics.decompose ~mk_fresh_name_callback () - | GrafiteAst.Demodulate (_, params) -> - Tactics.demodulate - ~dbd:(LibraryDb.instance ()) ~params - ~automation_cache:status#automation_cache - | GrafiteAst.Destruct (_,xterms) -> Tactics.destruct xterms - | GrafiteAst.Elim (_, what, using, pattern, (depth, names)) -> - Tactics.elim_intros ?using ?depth ~mk_fresh_name_callback:(namer_of names) - ~pattern what - | GrafiteAst.ElimType (_, what, using, (depth, names)) -> - Tactics.elim_type ?using ?depth ~mk_fresh_name_callback:(namer_of names) - what - | GrafiteAst.Exact (_, term) -> Tactics.exact term - | GrafiteAst.Exists _ -> Tactics.exists - | GrafiteAst.Fail _ -> Tactics.fail - | GrafiteAst.Fold (_, reduction_kind, term, pattern) -> - let reduction = - match reduction_kind with - | `Normalize -> - PET.const_lazy_reduction - (CicReduction.normalize ~delta:false ~subst:[]) - | `Simpl -> PET.const_lazy_reduction ProofEngineReduction.simpl - | `Unfold None -> - PET.const_lazy_reduction (ProofEngineReduction.unfold ?what:None) - | `Unfold (Some lazy_term) -> - (fun context metasenv ugraph -> - let what, metasenv, ugraph = lazy_term context metasenv ugraph in - ProofEngineReduction.unfold ~what, metasenv, ugraph) - | `Whd -> - PET.const_lazy_reduction (CicReduction.whd ~delta:false ~subst:[]) - in - Tactics.fold ~reduction ~term ~pattern - | GrafiteAst.Fourier _ -> Tactics.fourier - | GrafiteAst.FwdSimpl (_, hyp, names) -> - Tactics.fwd_simpl ~mk_fresh_name_callback:(namer_of names) - ~dbd:(LibraryDb.instance ()) hyp - | GrafiteAst.Generalize (_,pattern,ident) -> - let names = match ident with None -> [] | Some id -> [Some id] in - Tactics.generalize ~mk_fresh_name_callback:(namer_of names) pattern - | GrafiteAst.IdTac _ -> Tactics.id - | GrafiteAst.Intros (_, (howmany, names)) -> - PrimitiveTactics.intros_tac ?howmany - ~mk_fresh_name_callback:(namer_of names) () - | GrafiteAst.Inversion (_, term) -> - Tactics.inversion term - | GrafiteAst.LApply (_, linear, how_many, to_what, what, ident) -> - let names = match ident with None -> [] | Some id -> [Some id] in - Tactics.lapply ~mk_fresh_name_callback:(namer_of names) - ~linear ?how_many ~to_what what - | GrafiteAst.Left _ -> Tactics.left - | GrafiteAst.LetIn (loc,term,name) -> - Tactics.letin term ~mk_fresh_name_callback:(namer_of [Some name]) - | GrafiteAst.Reduce (_, reduction_kind, pattern) -> - (match reduction_kind with - | `Normalize -> Tactics.normalize ~pattern - | `Simpl -> Tactics.simpl ~pattern - | `Unfold what -> Tactics.unfold ~pattern what - | `Whd -> Tactics.whd ~pattern) - | GrafiteAst.Reflexivity _ -> Tactics.reflexivity - | GrafiteAst.Replace (_, pattern, with_what) -> - Tactics.replace ~pattern ~with_what - | GrafiteAst.Rewrite (_, direction, t, pattern, names) -> - EqualityTactics.rewrite_tac ~direction ~pattern t -(* to be replaced with ~mk_fresh_name_callback:(namer_of names) *) - (List.map (function Some s -> s | None -> assert false) names) - | GrafiteAst.Right _ -> Tactics.right - | GrafiteAst.Ring _ -> Tactics.ring - | GrafiteAst.Split _ -> Tactics.split - | GrafiteAst.Symmetry _ -> Tactics.symmetry - | GrafiteAst.Transitivity (_, term) -> Tactics.transitivity term - (* Implementazioni Aggiunte *) - | GrafiteAst.Assume (_, id, t) -> Declarative.assume id t - | GrafiteAst.Suppose (_, t, id, t1) -> Declarative.suppose t id t1 - | GrafiteAst.By_just_we_proved (_, just, ty, id, t1) -> - Declarative.by_just_we_proved ~dbd:(LibraryDb.instance()) - ~automation_cache:status#automation_cache just ty id t1 - | GrafiteAst.We_need_to_prove (_, t, id, t2) -> - Declarative.we_need_to_prove t id t2 - | GrafiteAst.Bydone (_, t) -> - Declarative.bydone ~dbd:(LibraryDb.instance()) - ~automation_cache:status#automation_cache t - | GrafiteAst.We_proceed_by_cases_on (_, t, t1) -> - Declarative.we_proceed_by_cases_on t t1 - | GrafiteAst.We_proceed_by_induction_on (_, t, t1) -> - Declarative.we_proceed_by_induction_on t t1 - | GrafiteAst.Byinduction (_, t, id) -> Declarative.byinduction t id - | GrafiteAst.Thesisbecomes (_, t) -> Declarative.thesisbecomes t - | GrafiteAst.ExistsElim (_, just, id1, t1, id2, t2) -> - Declarative.existselim ~dbd:(LibraryDb.instance()) - ~automation_cache:status#automation_cache just id1 t1 id2 t2 - | GrafiteAst.Case (_,id,params) -> Declarative.case id params - | GrafiteAst.AndElim(_,just,id1,t1,id2,t2) -> - Declarative.andelim ~dbd:(LibraryDb.instance ()) - ~automation_cache:status#automation_cache just id1 t1 id2 t2 - | GrafiteAst.RewritingStep (_,termine,t1,t2,cont) -> - Declarative.rewritingstep ~dbd:(LibraryDb.instance ()) - ~automation_cache:status#automation_cache termine t1 t2 cont - -let classify_tactic tactic = - match tactic with - (* tactics that can't close the goal (return a goal we want to "select") *) - | GrafiteAst.Rewrite _ - | GrafiteAst.Split _ - | GrafiteAst.Replace _ - | GrafiteAst.Reduce _ - | GrafiteAst.IdTac _ - | GrafiteAst.Generalize _ - | GrafiteAst.Elim _ - | GrafiteAst.Cut _ - | GrafiteAst.Decompose _ -> true - (* tactics like apply *) - | _ -> false - -let reorder_metasenv start refine tactic goals current_goal always_opens_a_goal= -(* let print_m name metasenv = - prerr_endline (">>>>> " ^ name); - prerr_endline (CicMetaSubst.ppmetasenv [] metasenv) - in *) - (* phase one calculates: - * new_goals_from_refine: goals added by refine - * head_goal: the first goal opened by ythe tactic - * other_goals: other goals opened by the tactic - *) - let new_goals_from_refine = PEH.compare_metasenvs start refine in - let new_goals_from_tactic = PEH.compare_metasenvs refine tactic in - let head_goal, other_goals, goals = - match goals with - | [] -> None,[],goals - | hd::tl -> - (* assert (List.mem hd new_goals_from_tactic); - * invalidato dalla goal_tac - * *) - Some hd, List.filter ((<>) hd) new_goals_from_tactic, List.filter ((<>) - hd) goals - in - let produced_goals = - match head_goal with - | None -> new_goals_from_refine @ other_goals - | Some x -> x :: new_goals_from_refine @ other_goals - in - (* extract the metas generated by refine and tactic *) - let metas_for_tactic_head = - match head_goal with - | None -> [] - | Some head_goal -> List.filter (fun (n,_,_) -> n = head_goal) tactic in - let metas_for_tactic_goals = - List.map - (fun x -> List.find (fun (metano,_,_) -> metano = x) tactic) - goals - in - let metas_for_refine_goals = - List.filter (fun (n,_,_) -> List.mem n new_goals_from_refine) tactic in - let produced_metas, goals = - let produced_metas = - if always_opens_a_goal then - metas_for_tactic_head @ metas_for_refine_goals @ - metas_for_tactic_goals - else begin -(* print_m "metas_for_refine_goals" metas_for_refine_goals; - print_m "metas_for_tactic_head" metas_for_tactic_head; - print_m "metas_for_tactic_goals" metas_for_tactic_goals; *) - metas_for_refine_goals @ metas_for_tactic_head @ - metas_for_tactic_goals - end - in - let goals = List.map (fun (metano, _, _) -> metano) produced_metas in - produced_metas, goals - in - (* residual metas, preserving the original order *) - let before, after = - let rec split e = - function - | [] -> [],[] - | (metano, _, _) :: tl when metano = e -> - [], List.map (fun (x,_,_) -> x) tl - | (metano, _, _) :: tl -> let b, a = split e tl in metano :: b, a - in - let find n metasenv = - try - Some (List.find (fun (metano, _, _) -> metano = n) metasenv) - with Not_found -> None - in - let extract l = - List.fold_right - (fun n acc -> - match find n tactic with - | Some x -> x::acc - | None -> acc - ) l [] in - let before_l, after_l = split current_goal start in - let before_l = - List.filter (fun x -> not (List.mem x produced_goals)) before_l in - let after_l = - List.filter (fun x -> not (List.mem x produced_goals)) after_l in - let before = extract before_l in - let after = extract after_l in - before, after - in -(* |+ DEBUG CODE +| - print_m "BEGIN" start; - prerr_endline ("goal was: " ^ string_of_int current_goal); - prerr_endline ("and metas from refine are:"); - List.iter - (fun t -> prerr_string (" " ^ string_of_int t)) - new_goals_from_refine; - prerr_endline ""; - print_m "before" before; - print_m "metas_for_tactic_head" metas_for_tactic_head; - print_m "metas_for_refine_goals" metas_for_refine_goals; - print_m "metas_for_tactic_goals" metas_for_tactic_goals; - print_m "produced_metas" produced_metas; - print_m "after" after; -|+ FINE DEBUG CODE +| *) - before @ produced_metas @ after, goals - -let apply_tactic ~disambiguate_tactic (text,prefix_len,tactic) (status, goal) = - let starting_metasenv = GrafiteTypes.get_proof_metasenv status in - let before = List.map (fun g, _, _ -> g) starting_metasenv in - let status, tactic = disambiguate_tactic status goal (text,prefix_len,tactic) in - let metasenv_after_refinement = GrafiteTypes.get_proof_metasenv status in - let proof = GrafiteTypes.get_current_proof status in - let proof_status = proof, goal in - let always_opens_a_goal = classify_tactic tactic in - let tactic = tactic_of_ast status tactic in - let (proof, opened) = ProofEngineTypes.apply_tactic tactic proof_status in - let after = ProofEngineTypes.goals_of_proof proof in - let opened_goals, closed_goals = Tacticals.goals_diff ~before ~after ~opened in - let proof, opened_goals = - let uri, metasenv_after_tactic, subst, t, ty, attrs = proof in - let reordered_metasenv, opened_goals = - reorder_metasenv - starting_metasenv - metasenv_after_refinement metasenv_after_tactic - opened goal always_opens_a_goal - in - let proof' = uri, reordered_metasenv, [], t, ty, attrs in - proof', opened_goals - in - let incomplete_proof = - match status#proof_status with - | GrafiteTypes.Incomplete_proof p -> p - | _ -> assert false - in - status#set_proof_status - (GrafiteTypes.Incomplete_proof - { incomplete_proof with GrafiteTypes.proof = proof }), - opened_goals, closed_goals - -let apply_atomic_tactical ~disambiguate_tactic ~patch (text,prefix_len,tactic) (status, goal) = - let starting_metasenv = GrafiteTypes.get_proof_metasenv status in - let before = List.map (fun g, _, _ -> g) starting_metasenv in - let status, tactic = disambiguate_tactic status goal (text,prefix_len,tactic) in - let metasenv_after_refinement = GrafiteTypes.get_proof_metasenv status in - let proof = GrafiteTypes.get_current_proof status in - let proof_status = proof, goal in - let always_opens_a_goal = classify_tactic tactic in - let tactic = tactic_of_ast status tactic in - let tactic = patch tactic in - let (proof, opened) = ProofEngineTypes.apply_tactic tactic proof_status in - let after = ProofEngineTypes.goals_of_proof proof in - let opened_goals, closed_goals = Tacticals.goals_diff ~before ~after ~opened in - let proof, opened_goals = - let uri, metasenv_after_tactic, _subst, t, ty, attrs = proof in - let reordered_metasenv, opened_goals = - reorder_metasenv - starting_metasenv - metasenv_after_refinement metasenv_after_tactic - opened goal always_opens_a_goal - in - let proof' = uri, reordered_metasenv, _subst, t, ty, attrs in - proof', opened_goals - in - let incomplete_proof = - match status#proof_status with - | GrafiteTypes.Incomplete_proof p -> p - | _ -> assert false - in - status#set_proof_status - (GrafiteTypes.Incomplete_proof - { incomplete_proof with GrafiteTypes.proof = proof }), - opened_goals, closed_goals -type eval_ast = - {ea_go: - 'term 'lazy_term 'reduction 'obj 'ident. - disambiguate_tactic: - (GrafiteTypes.status -> - ProofEngineTypes.goal -> - (('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic) - disambiguator_input -> - GrafiteTypes.status * - (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) -> - - disambiguate_command: - (GrafiteTypes.status -> - (('term,'obj) GrafiteAst.command) disambiguator_input -> - GrafiteTypes.status * (Cic.term,Cic.obj) GrafiteAst.command) -> - - disambiguate_macro: - (GrafiteTypes.status -> - (('term,'lazy_term) GrafiteAst.macro) disambiguator_input -> - Cic.context -> GrafiteTypes.status * (Cic.term,Cic.lazy_term) GrafiteAst.macro) -> - - ?do_heavy_checks:bool -> - GrafiteTypes.status -> - (('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.statement) - disambiguator_input -> - GrafiteTypes.status * [`Old of UriManager.uri list | `New of NUri.uri list] - } - -type 'a eval_command = - {ec_go: 'term 'obj. - disambiguate_command: - (GrafiteTypes.status -> (('term,'obj) GrafiteAst.command) disambiguator_input -> - GrafiteTypes.status * (Cic.term,Cic.obj) GrafiteAst.command) -> - options -> GrafiteTypes.status -> - (('term,'obj) GrafiteAst.command) disambiguator_input -> - GrafiteTypes.status * [`Old of UriManager.uri list | `New of NUri.uri list] - } - -type 'a eval_comment = - {ecm_go: 'term 'lazy_term 'reduction_kind 'obj 'ident. - disambiguate_command: - (GrafiteTypes.status -> (('term,'obj) GrafiteAst.command) disambiguator_input -> - GrafiteTypes.status * (Cic.term,Cic.obj) GrafiteAst.command) -> - options -> GrafiteTypes.status -> - (('term,'lazy_term,'reduction_kind,'obj,'ident) GrafiteAst.comment) disambiguator_input -> - GrafiteTypes.status * [`Old of UriManager.uri list | `New of NUri.uri list] - } - -type 'a eval_executable = - {ee_go: 'term 'lazy_term 'reduction 'obj 'ident. - disambiguate_tactic: - (GrafiteTypes.status -> - ProofEngineTypes.goal -> - (('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic) - disambiguator_input -> - GrafiteTypes.status * - (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) -> - - disambiguate_command: - (GrafiteTypes.status -> - (('term,'obj) GrafiteAst.command) disambiguator_input -> - GrafiteTypes.status * (Cic.term,Cic.obj) GrafiteAst.command) -> - - disambiguate_macro: - (GrafiteTypes.status -> - (('term,'lazy_term) GrafiteAst.macro) disambiguator_input -> - Cic.context -> GrafiteTypes.status * (Cic.term,Cic.lazy_term) GrafiteAst.macro) -> - - options -> - GrafiteTypes.status -> - (('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.code) disambiguator_input -> - GrafiteTypes.status * [`Old of UriManager.uri list | `New of NUri.uri list] - } - -type 'a eval_from_moo = - { efm_go: GrafiteTypes.status -> string -> GrafiteTypes.status } - -let coercion_moo_statement_of (uri,arity, saturations,_) = - GrafiteAst.Coercion - (HExtlib.dummy_floc, CicUtil.term_of_uri uri, false, arity, saturations) - let basic_eval_unification_hint (t,n) status = NCicUnifHint.add_user_provided_hint status t n ;; let inject_unification_hint = let basic_eval_unification_hint (t,n) - ~refresh_uri_in_universe - ~refresh_uri_in_term + ~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference + ~alias_only status = - let t = refresh_uri_in_term t in basic_eval_unification_hint (t,n) + if not alias_only then + let t = refresh_uri_in_term (status :> NCic.status) t in + basic_eval_unification_hint (t,n) status + else + status in - NCicLibrary.Serializer.register#run "unification_hints" - object(_ : 'a NCicLibrary.register_type) - method run = basic_eval_unification_hint - end + GrafiteTypes.Serializer.register#run "unification_hints" + basic_eval_unification_hint ;; let eval_unification_hint status t n = let metasenv,subst,status,t = - GrafiteDisambiguate.disambiguate_nterm None status [] [] [] ("",0,t) in + GrafiteDisambiguate.disambiguate_nterm status `XTSort [] [] [] ("",0,t) in assert (metasenv=[]); - let t = NCicUntrusted.apply_subst subst [] t in + let t = NCicUntrusted.apply_subst status subst [] t in let status = basic_eval_unification_hint (t,n) status in - let dump = inject_unification_hint (t,n)::status#dump in - let status = status#set_dump dump in - status,`New [] + NCicLibrary.dump_obj status (inject_unification_hint (t,n)) ;; -let basic_index_obj l status = +let basic_index_obj l (status:#NCic.status) = status#set_auto_cache (List.fold_left (fun t (ks,v) -> @@ -514,20 +72,142 @@ let basic_index_obj l status = status#auto_cache l) ;; +let basic_eval_interpretation ~alias_only (dsc, (symbol, args), cic_appl_pattern) status = + let status = + if not alias_only then + Interpretations.add_interpretation status dsc (symbol, args) cic_appl_pattern + else + status + in + let mode = GrafiteAst.WithPreferences (*assert false*) in (* MATITA 1.0 VEDI SOTTO *) + let diff = + [DisambiguateTypes.Symbol (symbol, 0), GrafiteAst.Symbol_alias (symbol,0,dsc)] + in + GrafiteDisambiguate.set_proof_aliases status ~implicit_aliases:false mode diff +;; + +let inject_interpretation = + let basic_eval_interpretation (dsc, (symbol, args), cic_appl_pattern) + ~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference + ~alias_only + = + let rec refresh = + function + NotationPt.NRefPattern (NReference.Ref (uri,spec)) -> + NotationPt.NRefPattern + (NReference.reference_of_spec (NCicLibrary.refresh_uri uri) spec) + | NotationPt.VarPattern _ + | NotationPt.ImplicitPattern as x -> x + | NotationPt.ApplPattern l -> NotationPt.ApplPattern (List.map refresh l) + in + let cic_appl_pattern = refresh cic_appl_pattern in + basic_eval_interpretation ~alias_only (dsc, (symbol, args), cic_appl_pattern) + in + GrafiteTypes.Serializer.register#run "interpretation" + basic_eval_interpretation +;; + +let eval_interpretation status data= + let status = basic_eval_interpretation ~alias_only:false data status in + NCicLibrary.dump_obj status (inject_interpretation data) +;; + +let basic_eval_alias (mode,diff) status = + GrafiteDisambiguate.set_proof_aliases status ~implicit_aliases:false mode diff +;; + +let inject_alias = + let basic_eval_alias (mode,diff) ~refresh_uri_in_universe ~refresh_uri_in_term + ~refresh_uri_in_reference ~alias_only = + basic_eval_alias (mode,diff) + in + GrafiteTypes.Serializer.register#run "alias" basic_eval_alias +;; + +let eval_alias status data= + let status = basic_eval_alias data status in + NCicLibrary.dump_obj status (inject_alias data) +;; + +let basic_eval_input_notation (l1,l2) status = + GrafiteParser.extend status l1 + (fun env loc -> + NotationPt.AttributedTerm + (`Loc loc,TermContentPres.instantiate_level2 status env l2)) +;; + +let inject_input_notation = + let basic_eval_input_notation (l1,l2) + ~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference + ~alias_only status + = + if not alias_only then + let l1 = + CicNotationParser.refresh_uri_in_checked_l1_pattern + ~refresh_uri_in_term:(refresh_uri_in_term (status:>NCic.status)) + ~refresh_uri_in_reference l1 in + let l2 = NotationUtil.refresh_uri_in_term + ~refresh_uri_in_term:(refresh_uri_in_term (status:>NCic.status)) + ~refresh_uri_in_reference l2 + in + basic_eval_input_notation (l1,l2) status + else + status + in + GrafiteTypes.Serializer.register#run "input_notation" + basic_eval_input_notation +;; + +let eval_input_notation status data= + let status = basic_eval_input_notation data status in + NCicLibrary.dump_obj status (inject_input_notation data) +;; + +let basic_eval_output_notation (l1,l2) status = + TermContentPres.add_pretty_printer status l2 l1 +;; + +let inject_output_notation = + let basic_eval_output_notation (l1,l2) + ~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference + ~alias_only status + = + if not alias_only then + let l1 = + CicNotationParser.refresh_uri_in_checked_l1_pattern + ~refresh_uri_in_term:(refresh_uri_in_term (status:>NCic.status)) + ~refresh_uri_in_reference l1 in + let l2 = NotationUtil.refresh_uri_in_term + ~refresh_uri_in_term:(refresh_uri_in_term (status:>NCic.status)) + ~refresh_uri_in_reference l2 + in + basic_eval_output_notation (l1,l2) status + else + status + in + GrafiteTypes.Serializer.register#run "output_notation" + basic_eval_output_notation +;; + +let eval_output_notation status data= + let status = basic_eval_output_notation data status in + NCicLibrary.dump_obj status (inject_output_notation data) +;; + let record_index_obj = - let aux l - ~refresh_uri_in_universe - ~refresh_uri_in_term + let aux l ~refresh_uri_in_universe + ~refresh_uri_in_term ~refresh_uri_in_reference ~alias_only status = + let refresh_uri_in_term = refresh_uri_in_term (status:>NCic.status) in + if not alias_only then basic_index_obj (List.map (fun ks,v -> List.map refresh_uri_in_term ks, refresh_uri_in_term v) - l) + l) status + else + status in - NCicLibrary.Serializer.register#run "index_obj" - object(_ : 'a NCicLibrary.register_type) - method run = aux - end + GrafiteTypes.Serializer.register#run "index_obj" aux ;; let compute_keys status uri height kind = @@ -574,15 +254,15 @@ let compute_keys status uri height kind = if keys <> [] then begin HLog.debug ("Indexing:" ^ - NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t); + status#ppterm ~metasenv:[] ~subst:[] ~context:[] t); HLog.debug ("With keys:" ^ String.concat "\n" (List.map (fun t -> - NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t) keys)); + status#ppterm ~metasenv:[] ~subst:[] ~context:[] t) keys)); Some (keys,t) end else begin HLog.debug ("Not indexing:" ^ - NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t); + status#ppterm ~metasenv:[] ~subst:[] ~context:[] t); None end) data @@ -592,175 +272,149 @@ let index_obj_for_auto status (uri, height, _, _, kind) = (*prerr_endline (string_of_int height);*) let data = compute_keys status uri height kind in let status = basic_index_obj data status in - let dump = record_index_obj data :: status#dump in - status#set_dump dump + NCicLibrary.dump_obj status (record_index_obj data) ;; -let index_eq uri status = +let basic_extract_obj obj status = + try + ignore (Helm_registry.get "extract_haskell"); + let status,(msg,infos) = NCicExtraction.haskell_of_obj status obj in + prerr_endline msg; + status,infos + with + Helm_registry.Key_not_found _ -> status,NCicExtraction.empty_info + | exn -> prerr_endline ("EXTRACTION FAILURE: " ^ Printexc.to_string exn); assert false +;; + +let basic_extract_ocaml_obj obj status = + try + let status = OcamlExtraction.print_ocaml_of_obj status obj in + let infos,status = status#get_info in + status,infos + with + exn -> prerr_endline ("EXTRACTION FAILURE: " ^ Printexc.to_string exn); assert false +;; + +let inject_extract_obj = + let basic_extract_obj info + ~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference + ~alias_only status + = + let info= NCicExtraction.refresh_uri_in_info ~refresh_uri_in_reference info in + status#set_extraction_db + (NCicExtraction.register_infos status#extraction_db info) + in + GrafiteTypes.Serializer.register#run "extraction" basic_extract_obj +;; + +let inject_extract_ocaml_obj = + let basic_extract_ocaml_obj info + ~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference + ~alias_only status + = + let info= OcamlExtractionTable.refresh_uri_in_info ~refresh_uri_in_reference ~refresh_uri:NCicLibrary.refresh_uri info in + status#set_ocaml_extraction_db + (OcamlExtractionTable.register_infos status#ocaml_extraction_db info) + in + GrafiteTypes.Serializer.register#run "ocaml_extraction" basic_extract_ocaml_obj +;; + +let eval_extract_obj status obj = + let status,infos = basic_extract_obj obj status in + NCicLibrary.dump_obj status (inject_extract_obj infos) +;; + +let eval_extract_ocaml_obj status obj = + let status,infos = basic_extract_ocaml_obj obj status in + NCicLibrary.dump_obj status (inject_extract_ocaml_obj infos) +;; + +(* +module EmptyC = + struct + let metasenv = [] + let subst = [] + let context = [] + end +*) + +let index_eq print uri (status:#NCic.status) = let eq_status = status#eq_cache in - let eq_status1 = NCicParamod.index_obj eq_status uri in - status#set_eq_cache eq_status1 + let eq_status,clause = NCicParamod.index_obj status eq_status uri in + if print then + ((*let module NCicBlob = + struct + include NCicBlob.NCicBlob(EmptyC) + let pp t = status#ppterm ~metasenv:[] ~subst:[] ~context:[] t + end in + let module Pp = Pp.Pp(NCicBlob) in*) + (match clause with + | Some (*clause*) (_,Terms.Equation (_,_,_,o),_,_) -> + HLog.debug ("Indexed with orientation: " ^ Pp.string_of_comparison o); + (*HLog.debug ("Indexed as:" ^ Pp.pp_unit_clause clause)*) + | _ -> HLog.debug "Not indexed (i.e. pruned)")) ; + status#set_eq_cache eq_status ;; let record_index_eq = let basic_index_eq uri - ~refresh_uri_in_universe - ~refresh_uri_in_term - = index_eq (NCicLibrary.refresh_uri uri) + ~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference + ~alias_only status + = if not alias_only then index_eq false (NCicLibrary.refresh_uri uri) status + else + status in - NCicLibrary.Serializer.register#run "index_eq" - object(_ : 'a NCicLibrary.register_type) - method run = basic_index_eq - end + GrafiteTypes.Serializer.register#run "index_eq" basic_index_eq ;; let index_eq_for_auto status uri = if NnAuto.is_a_fact_obj status uri then - let newstatus = index_eq uri status in + let newstatus = index_eq true uri status in if newstatus#eq_cache == status#eq_cache then status else ((*prerr_endline ("recording " ^ (NUri.string_of_uri uri));*) - let dump = record_index_eq uri :: newstatus#dump - in newstatus#set_dump dump) + NCicLibrary.dump_obj newstatus (record_index_eq uri)) else ((*prerr_endline "Not a fact";*) status) ;; -let basic_eval_add_constraint (u1,u2) status = - NCicLibrary.add_constraint status u1 u2 -;; - let inject_constraint = - let basic_eval_add_constraint (u1,u2) - ~refresh_uri_in_universe - ~refresh_uri_in_term + let basic_eval_add_constraint (acyclic,u1,u2) + ~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference + ~alias_only status = - let u1 = refresh_uri_in_universe u1 in - let u2 = refresh_uri_in_universe u2 in - basic_eval_add_constraint (u1,u2) + if not alias_only then + let u1 = refresh_uri_in_universe u1 in + let u2 = refresh_uri_in_universe u2 in + (* NCicLibrary.add_constraint adds the constraint to the NCicEnvironment + * and also to the storage (for undo/redo). During inclusion of compiled + * files the storage must not be touched. *) + NCicEnvironment.add_lt_constraint acyclic u1 u2; + status + else + status in - NCicLibrary.Serializer.register#run "constraints" - object(_:'a NCicLibrary.register_type) - method run = basic_eval_add_constraint - end + GrafiteTypes.Serializer.register#run "constraints" basic_eval_add_constraint ;; -let eval_add_constraint status u1 u2 = - let status = basic_eval_add_constraint (u1,u2) status in - let dump = inject_constraint (u1,u2)::status#dump in - let status = status#set_dump dump in - status,`Old [] -;; - -let add_coercions_of_lemmas lemmas status = - let moo_content = - HExtlib.filter_map - (fun uri -> - match CoercDb.is_a_coercion (Cic.Const (uri,[])) with - | None -> None - | Some (_,tgt,_,sat,_) -> - let arity = match tgt with CoercDb.Fun n -> n | _ -> 0 in - Some (coercion_moo_statement_of (uri,arity,sat,0))) - lemmas - in - let status = GrafiteTypes.add_moo_content moo_content status in - status#set_coercions (CoercDb.dump ()), - lemmas - -let eval_coercion status ~add_composites uri arity saturations = - let uri = - try CicUtil.uri_of_term uri - with Invalid_argument _ -> - raise (Invalid_argument "coercion can only be constants/constructors") - in - let status, lemmas = - GrafiteSync.add_coercion ~add_composites - ~pack_coercion_obj:CicRefine.pack_coercion_obj - status uri arity saturations status#baseuri in - let moo_content = coercion_moo_statement_of (uri,arity,saturations,0) in - let status = GrafiteTypes.add_moo_content [moo_content] status in - add_coercions_of_lemmas lemmas status - -let eval_prefer_coercion status c = - let uri = - try CicUtil.uri_of_term c - with Invalid_argument _ -> - raise (Invalid_argument "coercion can only be constants/constructors") - in - let status = GrafiteSync.prefer_coercion status uri in - let moo_content = GrafiteAst.PreferCoercion (HExtlib.dummy_floc,c) in - let status = GrafiteTypes.add_moo_content [moo_content] status in - status, `Old [] - -module MatitaStatus = - struct - type input_status = GrafiteTypes.status * ProofEngineTypes.goal - - type output_status = - GrafiteTypes.status * ProofEngineTypes.goal list * ProofEngineTypes.goal list - - type tactic = input_status -> output_status - - let mk_tactic tac = tac - let apply_tactic tac = tac - let goals (_, opened, closed) = opened, closed - let get_stack (status, _) = GrafiteTypes.get_stack status - - let set_stack stack (status, opened, closed) = - GrafiteTypes.set_stack stack status, opened, closed - - let inject (status, _) = (status, [], []) - let focus goal (status, _, _) = (status, goal) - end - -module MatitaTacticals = Continuationals.Make(MatitaStatus) - -let tactic_of_ast' tac = - MatitaTacticals.Tactical (MatitaTacticals.Tactic (MatitaStatus.mk_tactic tac)) - -let punctuation_tactical_of_ast (text,prefix_len,punct) = - match punct with - | GrafiteAst.Dot _loc -> MatitaTacticals.Dot - | GrafiteAst.Semicolon _loc -> MatitaTacticals.Semicolon - | GrafiteAst.Branch _loc -> MatitaTacticals.Branch - | GrafiteAst.Shift _loc -> MatitaTacticals.Shift - | GrafiteAst.Pos (_loc, i) -> MatitaTacticals.Pos i - | GrafiteAst.Merge _loc -> MatitaTacticals.Merge - | GrafiteAst.Wildcard _loc -> MatitaTacticals.Wildcard - -let non_punctuation_tactical_of_ast (text,prefix_len,punct) = - match punct with - | GrafiteAst.Focus (_loc,goals) -> MatitaTacticals.Focus goals - | GrafiteAst.Unfocus _loc -> MatitaTacticals.Unfocus - | GrafiteAst.Skip _loc -> MatitaTacticals.Tactical MatitaTacticals.Skip - -let eval_tactical status tac = - let status, _, _ = MatitaTacticals.eval tac (status, ~-1) in - let status = (* is proof completed? *) - match status#proof_status with - | GrafiteTypes.Incomplete_proof - { GrafiteTypes.stack = stack; proof = proof } - when Continuationals.Stack.is_empty stack -> - status#set_proof_status (GrafiteTypes.Proof proof) - | _ -> status - in - status - -let add_obj = GrafiteSync.add_obj ~pack_coercion_obj:CicRefine.pack_coercion_obj - -let eval_ng_punct (_text, _prefix_len, punct) = - match punct with - | GrafiteAst.Dot _ -> NTactics.dot_tac - | GrafiteAst.Semicolon _ -> fun x -> x - | GrafiteAst.Branch _ -> NTactics.branch_tac ~force:false - | GrafiteAst.Shift _ -> NTactics.shift_tac - | GrafiteAst.Pos (_,l) -> NTactics.pos_tac l - | GrafiteAst.Wildcard _ -> NTactics.wildcard_tac - | GrafiteAst.Merge _ -> NTactics.merge_tac +let eval_add_constraint status acyclic u1 u2 = + let status = NCicLibrary.add_constraint status acyclic u1 u2 in + NCicLibrary.dump_obj status (inject_constraint (acyclic,u1,u2)) ;; let eval_ng_tac tac = + let just_to_tacstatus_just just text prefix_len = + match just with + | `Term t -> `Term (text,prefix_len,t) + | `Auto (l,params) -> + ( + match l with + | None -> `Auto (None,params) + | Some l -> `Auto (Some (List.map (fun t -> (text,prefix_len,t)) l),params) + ) + | _ -> assert false + in let rec aux f (text, prefix_len, tac) = match tac with | GrafiteAst.NApply (_loc, t) -> NTactics.apply_tac (text,prefix_len,t) @@ -797,6 +451,7 @@ let eval_ng_tac tac = | GrafiteAst.NCut (_loc, t) -> NTactics.cut_tac (text,prefix_len,t) (*| GrafiteAst.NDiscriminate (_,what) -> NDestructTac.discriminate_tac ~what:(text,prefix_len,what) | GrafiteAst.NSubst (_,what) -> NDestructTac.subst_tac ~what:(text,prefix_len,what)*) + | GrafiteAst.NClear (_loc, l) -> NTactics.clear_tac l | GrafiteAst.NDestruct (_,dom,skip) -> NDestructTac.destruct_tac dom skip | GrafiteAst.NDot _ -> NTactics.dot_tac | GrafiteAst.NElim (_loc, what, where) -> @@ -831,12 +486,49 @@ let eval_ng_tac tac = | GrafiteAst.NUnfocus _ -> NTactics.unfocus_tac | GrafiteAst.NWildcard _ -> NTactics.wildcard_tac | GrafiteAst.NTry (_,tac) -> NTactics.try_tac - (aux f (text, prefix_len, tac)) + (f f (text, prefix_len, tac)) | GrafiteAst.NAssumption _ -> NTactics.assumption_tac | GrafiteAst.NBlock (_,l) -> NTactics.block_tac (List.map (fun x -> aux f (text,prefix_len,x)) l) |GrafiteAst.NRepeat (_,tac) -> NTactics.repeat_tac (f f (text, prefix_len, tac)) + |GrafiteAst.Assume (_,id,t,t1) -> Declarative.assume id (text,prefix_len,t) (match t1 with None -> + None | Some t1 -> (Some (text,prefix_len,t1))) + |GrafiteAst.Suppose (_,t,id,t1) -> Declarative.suppose (text,prefix_len,t) id (match t1 with None + -> None | Some t1 -> (Some (text,prefix_len,t1))) + |GrafiteAst.By_just_we_proved (_,j,t1,s,t2) -> Declarative.by_just_we_proved + (just_to_tacstatus_just j text prefix_len) (text,prefix_len,t1) s (match t2 with None -> None | + Some t2 -> (Some (text,prefix_len,t2))) + |GrafiteAst.We_need_to_prove (_, t, id, t2) -> Declarative.we_need_to_prove (text,prefix_len,t) id + (match t2 with None -> None | Some t2 -> Some (text,prefix_len,t2)) + | GrafiteAst.Bydone (_, j) -> Declarative.bydone (just_to_tacstatus_just j text prefix_len) + | GrafiteAst.ExistsElim (_, just, id1, t1, t2, id2) -> + Declarative.existselim (just_to_tacstatus_just just text prefix_len) id1 (text,prefix_len,t1) + (text,prefix_len,t2) id2 + | GrafiteAst.AndElim(_,just,t1,id1,t2,id2) -> Declarative.andelim (just_to_tacstatus_just just + text prefix_len) (text,prefix_len,t1) id1 (text,prefix_len,t2) id2 + | GrafiteAst.Thesisbecomes (_, t1, t2) -> Declarative.thesisbecomes (text,prefix_len,t1) + (match t2 with None -> None | Some t2 -> (Some (text,prefix_len,t2))) + | GrafiteAst.RewritingStep (_,rhs,just,cont) -> + Declarative.rewritingstep (text,prefix_len,rhs) + (match just with + `Term t -> just_to_tacstatus_just just text prefix_len + | `Auto params -> just_to_tacstatus_just just text prefix_len + |`Proof -> `Proof + |`SolveWith t -> `SolveWith (text,prefix_len,t) + ) + cont + | GrafiteAst.Obtain (_,id,t1) -> + Declarative.obtain id (text,prefix_len,t1) + | GrafiteAst.Conclude (_,t1) -> + Declarative.conclude (text,prefix_len,t1) + | GrafiteAst.We_proceed_by_cases_on (_, t, t1) -> + Declarative.we_proceed_by_cases_on (text,prefix_len,t) (text,prefix_len,t1) + | GrafiteAst.We_proceed_by_induction_on (_, t, t1) -> + Declarative.we_proceed_by_induction_on (text,prefix_len,t) (text,prefix_len,t1) + | GrafiteAst.Byinduction (_, t, id) -> Declarative.byinduction (text,prefix_len,t) id + | GrafiteAst.Case (_,id,params) -> Declarative.case id params + | GrafiteAst.PrintStack (_) -> Declarative.print_stack in aux aux tac (* trick for non uniform recursion call *) ;; @@ -845,18 +537,128 @@ let subst_metasenv_and_fix_names status = let u,h,metasenv, subst,o = status#obj in let o = NCicUntrusted.map_obj_kind ~skip_body:true - (NCicUntrusted.apply_subst subst []) o + (NCicUntrusted.apply_subst status subst []) o in - status#set_obj(u,h,NCicUntrusted.apply_subst_metasenv subst metasenv,subst,o) + status#set_obj(u,h,NCicUntrusted.apply_subst_metasenv status subst metasenv,subst,o) +;; + +let is_proof_irrelevant status context ty = + match + NCicReduction.whd status ~subst:[] context + (NCicTypeChecker.typeof status ~subst:[] ~metasenv:[] context ty) + with + NCic.Sort NCic.Prop -> true + | NCic.Sort _ -> false + | _ -> assert false ;; +let rec relevance_of status ?(context=[]) ty = + match NCicReduction.whd status ~subst:[] context ty with + NCic.Prod (n,s,t) -> + not (is_proof_irrelevant status context s) :: + relevance_of status ~context:((n,NCic.Decl s)::context) t + | _ -> [] +;; -let rec eval_ncommand opts status (text,prefix_len,cmd) = +let compute_relevance status uri = + function + NCic.Constant (_,name,bo,ty,attrs) -> + let relevance = relevance_of status ty in + NCic.Constant (relevance,name,bo,ty,attrs) + | NCic.Fixpoint (ind,funs,attrs) -> + let funs = + List.map + (fun (_,name,recno,ty,bo) -> + let relevance = relevance_of status ty in + relevance,name,recno,ty,bo + ) funs + in + NCic.Fixpoint (ind,funs,attrs) + | NCic.Inductive (ind,leftno,tys,attrs) -> + let context = + List.rev_map (fun (_,name,arity,_) -> name,NCic.Decl arity) tys in + let tysno = List.length tys in + let tys = + List.map + (fun (_,name,arity,cons) -> + let relevance = relevance_of status arity in + let cons = + List.map + (fun (_,name,ty) -> + let dety = + NCicTypeChecker.debruijn status uri tysno ~subst:[] [] ty in + let relevance = relevance_of status ~context dety in + relevance,name,ty + ) cons + in + (relevance,name,arity,cons) + ) tys + in + NCic.Inductive (ind,leftno,tys,attrs) +;; + +let extract_uris status uris = + List.fold_left + (fun status uri -> + let obj = NCicEnvironment.get_checked_obj status uri in + let status = eval_extract_obj status obj in + eval_extract_ocaml_obj status obj + ) status uris +;; + +let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = match cmd with + | GrafiteAst.Include (loc, mode, fname) -> + let _root, baseuri, fullpath, _rrelpath = + Librarian.baseuri_of_script ~include_paths fname in + let baseuri = NUri.uri_of_string baseuri in + (* MATITA 1.0: keep WithoutPreferences? *) + let alias_only = (mode = GrafiteAst.OnlyPreferences) in + let status = + GrafiteTypes.Serializer.require + ~alias_only ~baseuri ~fname:fullpath status in + OcamlExtraction.print_open status + (NCicLibrary.get_transitively_included status) | GrafiteAst.UnificationHint (loc, t, n) -> eval_unification_hint status t n - | GrafiteAst.NCoercion (loc, name, t, ty, source, target) -> - NCicCoercDeclaration.eval_ncoercion status name t ty source target - | GrafiteAst.NQed loc -> + | GrafiteAst.NCoercion (loc, name, compose, None) -> + let status, t, ty, source, target = + let o_t = NotationPt.Ident (name,None) in + let metasenv,subst, status,t = + GrafiteDisambiguate.disambiguate_nterm + status `XTNone [] [] [] ("",0,o_t) in + assert( metasenv = [] && subst = []); + let ty = NCicTypeChecker.typeof status [] [] [] t in + let source, target = + let clean = function + | NCic.Appl (NCic.Const _ as r :: l) -> + NotationPt.Appl (NotationPt.NCic r :: + List.map (fun _ -> NotationPt.Implicit `JustOne)l) + | NCic.Const _ as r -> NotationPt.NCic r + | NCic.Sort _ as r -> NotationPt.NCic r (* FG: missing case *) + | _ -> assert false + in + let rec aux = function + | NCic.Prod (_,_, (NCic.Prod _ as rest)) -> aux rest + | NCic.Prod (name, src, tgt) -> (name, clean src), clean tgt + | _ -> assert false + in + aux ty + in + status, o_t, NotationPt.NCic ty, source, target + in + let cmd = + GrafiteAst.NCoercion (loc, name, compose, Some (t, ty, source, target)) + in + eval_ncommand ~include_paths opts status (text,prefix_len,cmd) + | GrafiteAst.NCoercion (loc, name, compose, Some (t, ty, source, target)) -> + let status, composites = + NCicCoercDeclaration.eval_ncoercion status name compose t ty source + target in + let status = extract_uris status composites in + let mode = GrafiteAst.WithPreferences in (* MATITA 1.0: fixme *) + let aliases = GrafiteDisambiguate.aliases_for_objs status composites in + eval_alias status (mode,aliases) + | GrafiteAst.NQed (loc,index) -> if status#ng_mode <> `ProofMode then raise (GrafiteTypes.Command_error "Not in proof mode") else @@ -867,8 +669,8 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = else let obj_kind = NCicUntrusted.map_obj_kind - (NCicUntrusted.apply_subst subst []) obj_kind in - let height = NCicTypeChecker.height_of_obj_kind uri [] obj_kind in + (NCicUntrusted.apply_subst status subst []) obj_kind in + let height = NCicTypeChecker.height_of_obj_kind status uri [] obj_kind in (* fix the height inside the object *) let rec fix () = function | NCic.Const (NReference.Ref (u,spec)) when NUri.eq u uri -> @@ -876,10 +678,10 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = (match spec with | NReference.Def _ -> NReference.Def height | NReference.Fix (i,j,_) -> NReference.Fix(i,j,height) - | NReference.CoFix _ -> NReference.CoFix height + | NReference.CoFix i -> NReference.CoFix i | NReference.Ind _ | NReference.Con _ | NReference.Decl as s -> s)) - | t -> NCicUtils.map (fun _ () -> ()) () fix t + | t -> NCicUtils.map status (fun _ () -> ()) () fix t in let obj_kind = match obj_kind with @@ -887,11 +689,14 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = NCicUntrusted.map_obj_kind (fix ()) obj_kind | _ -> obj_kind in + let obj_kind = compute_relevance status uri obj_kind in let obj = uri,height,[],[],obj_kind in - prerr_endline ("pp new obj \n"^NCicPp.ppobj obj); let old_status = status in let status = NCicLibrary.add_obj status obj in - let index_obj = + let status = eval_extract_obj status obj in + let status = eval_extract_ocaml_obj status obj in + (try + let index_obj = index && match obj_kind with NCic.Constant (_,_,_,_,(_,`Example,_)) | NCic.Fixpoint (_,_,(_,`Example,_)) -> false @@ -901,58 +706,67 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = if index_obj then let status = index_obj_for_auto status obj in (try index_eq_for_auto status uri - with _ -> status) + with + Sys.Break as exn -> raise exn + | _ -> status) else status in + (* purge tinycals stack *) + let ninitial_stack = Continuationals.Stack.of_nmetasenv [] in + let status = status#set_stack ninitial_stack in (* try index_eq uri status with _ -> prerr_endline "got an exception"; status in *) -(* prerr_endline (NCicPp.ppobj obj); *) +(* prerr_endline (status#ppobj obj); *) HLog.message ("New object: " ^ NUri.string_of_uri uri); - (try - (*prerr_endline (NCicPp.ppobj obj);*) - let boxml = NCicElim.mk_elims obj in - let boxml = boxml @ NCicElim.mk_projections obj in -(* - let objs = [] in - let timestamp,uris_rev = - List.fold_left - (fun (status,uris_rev) (uri,_,_,_,_) as obj -> - let status = NCicLibrary.add_obj status obj in - status,uri::uris_rev - ) (status,[]) objs in - let uris = uri::List.rev uris_rev in -*) - let status = status#set_ng_mode `CommandMode in - let status = LexiconSync.add_aliases_for_objs status (`New [uri]) in - let status,uris = + (*prerr_endline (status#ppobj obj);*) + let boxml = NCicElim.mk_elims status obj in + let boxml = boxml @ NCicElim.mk_projections status obj in + let status = status#set_ng_mode `CommandMode in + let xxaliases = GrafiteDisambiguate.aliases_for_objs status [uri] in + let mode = GrafiteAst.WithPreferences in (* MATITA 1.0: fixme *) + let status = eval_alias status (mode,xxaliases) in + let status = List.fold_left - (fun (status,uris) boxml -> + (fun status boxml -> try - let nstatus,nuris = - eval_ncommand opts status - ("",0,GrafiteAst.NObj (HExtlib.dummy_floc,boxml)) + let nstatus = + eval_ncommand ~include_paths opts status + ("",0,GrafiteAst.NObj (HExtlib.dummy_floc,boxml,true)) in if nstatus#ng_mode <> `CommandMode then begin (*HLog.warn "error in generating projection/eliminator";*) - status, uris + assert(status#ng_mode = `CommandMode); + status end else - nstatus, concat_nuris uris nuris + nstatus with - | MultiPassDisambiguator.DisambiguationError _ + | MultiPassDisambiguator.DisambiguationError _ -> + HLog.warn "error in disambiguating projection/eliminator"; + status | NCicTypeChecker.TypeCheckerFailure _ -> - (*HLog.warn "error in generating projection/eliminator";*) - status,uris - ) (status,`New [] (* uris *)) boxml in - let _,_,_,_,nobj = obj in + HLog.warn "error in typechecking projection/eliminator"; + status + ) status boxml in + let _,_,_,_,nobj = obj in + (* attempting to generate an inversion principle on the maximum + * universe can take a long time to fail: this code removes maximal + * sorts from the universe list *) + let universes = NCicEnvironment.get_universes () in + let max_univ = List.fold_left max [] universes in + let universes = + List.filter (fun x -> NCicEnvironment.universe_lt x max_univ) + universes + in let status = match nobj with - NCic.Inductive (is_ind,leftno,[it],_) -> - let _,ind_name,ty,cl = it in - List.fold_left + NCic.Inductive (is_ind,leftno,itl,_) -> + List.fold_left (fun status it -> + (let _,ind_name,ty,cl = it in + List.fold_left (fun status outsort -> let status = status#set_ng_mode `ProofMode in try @@ -962,15 +776,71 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = (snd (NCicElim.ast_of_sort outsort))) is_ind it leftno outsort status status#baseuri in let _,_,menv,_,_ = invobj in - fst (match menv with - [] -> eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) - | _ -> status,`New [])) + (match menv with + [] -> eval_ncommand ~include_paths opts status + ("",0,GrafiteAst.NQed (Stdpp.dummy_loc,false)) + | _ -> status)) (* XXX *) - with _ -> (*HLog.warn "error in generating inversion principle"; *) + with + Sys.Break as exn -> raise exn + | _ -> (*HLog.warn "error in generating inversion principle"; *) let status = status#set_ng_mode `CommandMode in status) status (NCic.Prop:: - List.map (fun s -> NCic.Type s) (NCicEnvironment.get_universes ())) + List.map (fun s -> NCic.Type s) universes))) status itl + | _ -> status + in + let status = match nobj with + NCic.Inductive (is_ind,leftno,itl,_) -> + (* first leibniz *) + let status' = List.fold_left + (fun status it -> + let _,ind_name,ty,cl = it in + let status = status#set_ng_mode `ProofMode in + try + (let status,invobj = + NDestructTac.mk_discriminator ~use_jmeq:false + (ind_name ^ "_discr") + it leftno status status#baseuri in + let _,_,menv,_,_ = invobj in + (match menv with + [] -> eval_ncommand ~include_paths opts status + ("",0,GrafiteAst.NQed(Stdpp.dummy_loc,false)) + | _ -> status)) + (* XXX *) + with + | NDestructTac.ConstructorTooBig k -> + HLog.warn (Printf.sprintf + "unable to generate leibniz discrimination principle (constructor %s too big)" + k); + let status = status#set_ng_mode `CommandMode in status + | _ -> (*HLog.warn "error in generating discrimination principle"; *) + let status = status#set_ng_mode `CommandMode in + status) + status itl + in + (* then JMeq *) + List.fold_left + (fun status it -> + let _,ind_name,ty,cl = it in + let status = status#set_ng_mode `ProofMode in + try + (let status,invobj = + NDestructTac.mk_discriminator ~use_jmeq:true + (ind_name ^ "_jmdiscr") + it leftno status status#baseuri in + let _,_,menv,_,_ = invobj in + (match menv with + [] -> eval_ncommand ~include_paths opts status + ("",0,GrafiteAst.NQed(Stdpp.dummy_loc,false)) + | _ -> status)) + (* XXX *) + with + Sys.Break as exn -> raise exn + | _ -> (*HLog.warn "error in generating discrimination principle"; *) + let status = status#set_ng_mode `CommandMode in + status) + status' itl | _ -> status in let coercions = @@ -982,27 +852,27 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = (fun (name,is_coercion,arity) -> if is_coercion then Some(name,leftno,arity) else None) fields | _ -> [] in - let status,uris = + let status = List.fold_left - (fun (status,uris) (name,cpos,arity) -> + (fun status (name,cpos,arity) -> try let metasenv,subst,status,t = - GrafiteDisambiguate.disambiguate_nterm None status [] [] [] - ("",0,CicNotationPt.Ident (name,None)) in + GrafiteDisambiguate.disambiguate_nterm status `XTNone [] [] [] + ("",0,NotationPt.Ident (name,None)) in assert (metasenv = [] && subst = []); let status, nuris = NCicCoercDeclaration. basic_eval_and_record_ncoercion_from_t_cpos_arity - status (name,t,cpos,arity) - in - let uris = concat_nuris nuris uris in - status, uris + status (name,true,t,cpos,arity) in + let aliases = GrafiteDisambiguate.aliases_for_objs status nuris in + let status = extract_uris status nuris in + eval_alias status (mode,aliases) with MultiPassDisambiguator.DisambiguationError _-> HLog.warn ("error in generating coercion: "^name); - status, uris) - (status,uris) coercions + status) + status coercions in - status,uris + status with exn -> NCicLibrary.time_travel old_status; @@ -1012,7 +882,7 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = raise (GrafiteTypes.Command_error "Not in command mode") else let tgt_uri_ext, old_ok = - match NCicEnvironment.get_checked_obj src_uri with + match NCicEnvironment.get_checked_obj status src_uri with | _,_,[],[], (NCic.Inductive _ as ok) -> ".ind", ok | _,_,[],[], (NCic.Fixpoint _ as ok) -> ".con", ok | _,_,[],[], (NCic.Constant _ as ok) -> ".con", ok @@ -1027,18 +897,18 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = (try NCic.Const (NReference.reference_of_spec (List.assoc u map)spec) with Not_found -> t) - | t -> NCicUtils.map (fun _ _ -> ()) () subst t + | t -> NCicUtils.map status (fun _ _ -> ()) () subst t in NCicUntrusted.map_obj_kind ~skip_body:false (subst ()) old_ok in let ninitial_stack = Continuationals.Stack.of_nmetasenv [] in let status = status#set_obj (tgt_uri,0,[],[],ok) in - (*prerr_endline (NCicPp.ppobj (tgt_uri,0,[],[],ok));*) + (*prerr_endline (status#ppobj (tgt_uri,0,[],[],ok));*) let status = status#set_stack ninitial_stack in let status = subst_metasenv_and_fix_names status in let status = status#set_ng_mode `ProofMode in - eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) - | GrafiteAst.NObj (loc,obj) -> + eval_ncommand ~include_paths opts status ("",0,GrafiteAst.NQed(Stdpp.dummy_loc,false)) + | GrafiteAst.NObj (loc,obj,index) -> if status#ng_mode <> `CommandMode then raise (GrafiteTypes.Command_error "Not in command mode") else @@ -1053,211 +923,110 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = let status = status#set_ng_mode `ProofMode in (match nmenv with [] -> - eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) - | _ -> status,`New []) - | GrafiteAst.NDiscriminator (_,_) -> assert false (*(loc, indty) -> + eval_ncommand ~include_paths opts status + ("",0,GrafiteAst.NQed(Stdpp.dummy_loc,index)) + | _ -> status) + | GrafiteAst.NDiscriminator (loc, indty) -> if status#ng_mode <> `CommandMode then raise (GrafiteTypes.Command_error "Not in command mode") else let status = status#set_ng_mode `ProofMode in let metasenv,subst,status,indty = - GrafiteDisambiguate.disambiguate_nterm None status [] [] [] (text,prefix_len,indty) in - let indtyno, (_,_,tys,_,_) = match indty with - NCic.Const ((NReference.Ref (_,NReference.Ind (_,indtyno,_))) as r) -> - indtyno, NCicEnvironment.get_checked_indtys r + GrafiteDisambiguate.disambiguate_nterm status `XTNone [] [] [] (text,prefix_len,indty) in + let indtyno, (_,_,tys,_,_),leftno = match indty with + NCic.Const ((NReference.Ref (_,NReference.Ind (_,indtyno,leftno))) as r) -> + indtyno, NCicEnvironment.get_checked_indtys status r, leftno | _ -> prerr_endline ("engine: indty expected... (fix this error message)"); assert false in - let it = List.nth tys indtyno in - let status,obj = NDestructTac.mk_discriminator it status in + let (_,ind_name,_,_ as it) = List.nth tys indtyno in + let status,obj = + NDestructTac.mk_discriminator ~use_jmeq:true ~force:true (ind_name ^ "_jmdiscr") + it leftno status status#baseuri in let _,_,menv,_,_ = obj in (match menv with - [] -> eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) + [] -> eval_ncommand ~include_paths opts status ("",0,GrafiteAst.NQed(Stdpp.dummy_loc,false)) | _ -> prerr_endline ("Discriminator: non empty metasenv"); - status, `New []) *) + status) | GrafiteAst.NInverter (loc, name, indty, selection, sort) -> if status#ng_mode <> `CommandMode then raise (GrafiteTypes.Command_error "Not in command mode") else let metasenv,subst,status,sort = match sort with | None -> [],[],status,NCic.Sort NCic.Prop - | Some s -> GrafiteDisambiguate.disambiguate_nterm None status [] [] [] - (text,prefix_len,s) + | Some s -> + GrafiteDisambiguate.disambiguate_nterm status `XTSort [] [] [] + (text,prefix_len,s) in assert (metasenv = []); - let sort = NCicReduction.whd ~subst [] sort in - let sort = match sort with + let sort = NCicReduction.whd status ~subst [] sort in + let sort = + match sort with NCic.Sort s -> s - | _ -> raise (Invalid_argument (Printf.sprintf "ninverter: found target %s, which is not a sort" - (NCicPp.ppterm ~metasenv ~subst ~context:[] sort))) - in + | _ -> + raise (Invalid_argument (Printf.sprintf + "ninverter: found target %s, which is not a sort" + (status#ppterm ~metasenv ~subst ~context:[] sort))) in let status = status#set_ng_mode `ProofMode in let metasenv,subst,status,indty = - GrafiteDisambiguate.disambiguate_nterm None status [] [] subst (text,prefix_len,indty) in - let indtyno,(_,leftno,tys,_,_) = match indty with - NCic.Const ((NReference.Ref (_,NReference.Ind (_,indtyno,_))) as r) -> - indtyno, NCicEnvironment.get_checked_indtys r - | _ -> prerr_endline ("engine: indty =" ^ NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] indty) ; assert false in + GrafiteDisambiguate.disambiguate_nterm status `XTNone [] [] subst + (text,prefix_len,indty) in + let indtyno,(_,leftno,tys,_,_) = + match indty with + NCic.Const ((NReference.Ref (_,NReference.Ind (_,indtyno,_))) as r) -> + indtyno, NCicEnvironment.get_checked_indtys status r + | _ -> + prerr_endline ("engine: indty =" ^ status#ppterm ~metasenv:[] + ~subst:[] ~context:[] indty); + assert false in let it = List.nth tys indtyno in - let status,obj = NInversion.mk_inverter name true it leftno ?selection sort - status status#baseuri in - let _,_,menv,_,_ = obj in - (match menv with - [] -> - eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) - | _ -> assert false) - | GrafiteAst.NUnivConstraint (loc,u1,u2) -> - eval_add_constraint status [`Type,u1] [`Type,u2] -;; - -let rec eval_command = {ec_go = fun ~disambiguate_command opts status -(text,prefix_len,cmd) -> - let status,cmd = disambiguate_command status (text,prefix_len,cmd) in - let status,uris = - match cmd with - | GrafiteAst.Index (loc,None,uri) -> - assert false (* TODO: for user input *) - | GrafiteAst.Index (loc,Some key,uri) -> - let universe = - status#automation_cache.AutomationCache.univ - in - let universe = Universe.index universe key (CicUtil.term_of_uri uri) in - let cache = { - status#automation_cache with AutomationCache.univ = universe } - in - let status = status#set_automation_cache cache in -(* debug - let msg = - let candidates = Universe.get_candidates status.GrafiteTypes.universe key in - ("candidates for " ^ (CicPp.ppterm key) ^ " = " ^ - (String.concat "\n" (List.map CicPp.ppterm candidates))) + let status,obj = + NInversion.mk_inverter name true it leftno ?selection sort + status status#baseuri in + let _,_,menv,_,_ = obj in + (match menv with + [] -> + eval_ncommand ~include_paths opts status + ("",0,GrafiteAst.NQed(Stdpp.dummy_loc,false)) + | _ -> assert false) + | GrafiteAst.NUnivConstraint (loc,acyclic,u1,u2) -> + eval_add_constraint status acyclic [`Type,u1] [`Type,u2] + (* ex lexicon commands *) + | GrafiteAst.Interpretation (loc, dsc, (symbol, args), cic_appl_pattern) -> + let cic_appl_pattern = + GrafiteDisambiguate.disambiguate_cic_appl_pattern status args + cic_appl_pattern in - prerr_endline msg; -*) - let status = GrafiteTypes.add_moo_content [cmd] status in - status,`Old [] - | GrafiteAst.Select (_,uri) as cmd -> - if List.mem cmd status#moo_content_rev then status, `Old [] - else - let cache = - AutomationCache.add_term_to_active status#automation_cache - [] [] [] (CicUtil.term_of_uri uri) None - in - let status = status#set_automation_cache cache in - let status = GrafiteTypes.add_moo_content [cmd] status in - status, `Old [] - | GrafiteAst.Pump (_,steps) -> - let cache = - AutomationCache.pump status#automation_cache steps + eval_interpretation status (dsc,(symbol, args),cic_appl_pattern) + | GrafiteAst.Notation (loc, dir, l1, associativity, precedence, l2) -> + let l1 = + CicNotationParser.check_l1_pattern + l1 (dir = Some `RightToLeft) precedence associativity in - let status = status#set_automation_cache cache in - status, `Old [] - | GrafiteAst.PreferCoercion (loc, coercion) -> - eval_prefer_coercion status coercion - | GrafiteAst.Coercion (loc, uri, add_composites, arity, saturations) -> - let res,uris = - eval_coercion status ~add_composites uri arity saturations - in - res,`Old uris - | GrafiteAst.Inverter (loc, name, indty, params) -> - let buri = status#baseuri in - let uri = UriManager.uri_of_string (buri ^ "/" ^ name ^ ".con") in - let indty_uri = - try CicUtil.uri_of_term indty - with Invalid_argument _ -> - raise (Invalid_argument "not an inductive type to invert") in - let res,uris = - Inversion_principle.build_inverter ~add_obj status uri indty_uri params - in - res,`Old uris - | GrafiteAst.Default (loc, what, uris) as cmd -> - LibraryObjects.set_default what uris; - GrafiteTypes.add_moo_content [cmd] status,`Old [] - | GrafiteAst.Drop loc -> raise Drop - | GrafiteAst.Include (loc, mode, new_or_old, baseuri) -> - (* Old Include command is not recursive; new one is *) - let status = - if new_or_old = `OldAndNew then - let moopath_rw, moopath_r = - LibraryMisc.obj_file_of_baseuri - ~must_exist:false ~baseuri ~writable:true, - LibraryMisc.obj_file_of_baseuri - ~must_exist:false ~baseuri ~writable:false in - let moopath = - if Sys.file_exists moopath_r then moopath_r else - if Sys.file_exists moopath_rw then moopath_rw else - raise (IncludedFileNotCompiled (moopath_rw,baseuri)) - in - eval_from_moo.efm_go status moopath - else - status - in - let status = - NCicLibrary.Serializer.require ~baseuri:(NUri.uri_of_string baseuri) - status in let status = - GrafiteTypes.add_moo_content - [GrafiteAst.Include (loc,mode,`New,baseuri)] status - in - status,`Old [] - | GrafiteAst.Print (_,"proofterm") -> - let _,_,_,p,_, _ = GrafiteTypes.get_current_proof status in - prerr_endline (Auto.pp_proofterm (Lazy.force p)); - status,`Old [] - | GrafiteAst.Print (_,_) -> status,`Old [] - | GrafiteAst.Qed loc -> - let uri, metasenv, _subst, bo, ty, attrs = - match status#proof_status with - | GrafiteTypes.Proof (Some uri, metasenv, subst, body, ty, attrs) -> - uri, metasenv, subst, body, ty, attrs - | GrafiteTypes.Proof (None, metasenv, subst, body, ty, attrs) -> - raise (GrafiteTypes.Command_error - ("Someone allows to start a theorem without giving the "^ - "name/uri. This should be fixed!")) - | _-> - raise - (GrafiteTypes.Command_error "You can't Qed an incomplete theorem") + if dir <> Some `RightToLeft then eval_input_notation status (l1,l2) + else status in - if metasenv <> [] then - raise - (GrafiteTypes.Command_error - "Proof not completed! metasenv is not empty!"); - let name = UriManager.name_of_uri uri in - let obj = Cic.Constant (name,Some (Lazy.force bo),ty,[],attrs) in - let status, lemmas = add_obj uri obj status in - status#set_proof_status GrafiteTypes.No_proof, - (*CSC: I throw away the arities *) - `Old (uri::lemmas) - | GrafiteAst.Relation (loc, id, a, aeq, refl, sym, trans) -> - Setoids.add_relation id a aeq refl sym trans; - status, `Old [] (*CSC: TO BE FIXED *) - | GrafiteAst.Set (loc, name, value) -> status, `Old [] -(* GrafiteTypes.set_option status name value,[] *) - | GrafiteAst.Obj (loc,obj) -> (* MATITA 1.0 *) assert false - in - match status#proof_status with - GrafiteTypes.Intermediate _ -> - status#set_proof_status GrafiteTypes.No_proof,uris - | _ -> status,uris + if dir <> Some `LeftToRight then eval_output_notation status (l1,l2) + else status + | GrafiteAst.Alias (loc, spec) -> + let diff = + (*CSC: Warning: this code should be factorized with the corresponding + code in DisambiguatePp *) + match spec with + | GrafiteAst.Ident_alias (id,uri) -> + [DisambiguateTypes.Id id,spec] + | GrafiteAst.Symbol_alias (symb, instance, desc) -> + [DisambiguateTypes.Symbol (symb,instance),spec] + | GrafiteAst.Number_alias (instance,desc) -> + [DisambiguateTypes.Num instance,spec] + in + let mode = GrafiteAst.WithPreferences in(*assert false in (* VEDI SOPRA *) MATITA 1.0*) + eval_alias status (mode,diff) +;; + +let eval_comment opts status (text,prefix_len,c) = status -} and eval_executable = {ee_go = fun ~disambiguate_tactic ~disambiguate_command -~disambiguate_macro opts status (text,prefix_len,ex) -> +let rec eval_executable ~include_paths opts status (text,prefix_len,ex) = match ex with - | GrafiteAst.Tactic (_(*loc*), Some tac, punct) -> - let tac = apply_tactic ~disambiguate_tactic (text,prefix_len,tac) in - let status = eval_tactical status (tactic_of_ast' tac) in - (* CALL auto on every goal, easy way of testing it - let auto = - GrafiteAst.AutoBatch - (loc, ([],["depth","2";"timeout","1";"type","1"])) in - (try - let auto = apply_tactic ~disambiguate_tactic ("",0,auto) in - let _ = eval_tactical status (tactic_of_ast' auto) in - print_endline "GOOD"; () - with ProofEngineTypes.Fail _ -> print_endline "BAD" | _ -> ());*) - eval_tactical status - (punctuation_tactical_of_ast (text,prefix_len,punct)),`Old [] - | GrafiteAst.Tactic (_, None, punct) -> - eval_tactical status - (punctuation_tactical_of_ast (text,prefix_len,punct)),`Old [] | GrafiteAst.NTactic (_(*loc*), tacl) -> if status#ng_mode <> `ProofMode then raise (GrafiteTypes.Command_error "Not in proof mode") @@ -1265,62 +1034,27 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status let status = List.fold_left (fun status tac -> + let time0 = Unix.gettimeofday () in let status = eval_ng_tac (text,prefix_len,tac) status in - subst_metasenv_and_fix_names status) + let time3 = Unix.gettimeofday () in + HLog.debug ("... eval_ng_tac done in " ^ string_of_float (time3 -. time0) ^ "s"); + let status = subst_metasenv_and_fix_names status in + let time3 = Unix.gettimeofday () in + HLog.debug ("... subst_metasenv_and_fix_names done in " ^ string_of_float (time3 -. time0) ^ "s"); status) status tacl in - status,`New [] - | GrafiteAst.NonPunctuationTactical (_, tac, punct) -> - let status = - eval_tactical status - (non_punctuation_tactical_of_ast (text,prefix_len,tac)) - in - eval_tactical status - (punctuation_tactical_of_ast (text,prefix_len,punct)),`Old [] - | GrafiteAst.Command (_, cmd) -> - eval_command.ec_go ~disambiguate_command opts status (text,prefix_len,cmd) + status | GrafiteAst.NCommand (_, cmd) -> - eval_ncommand opts status (text,prefix_len,cmd) - | GrafiteAst.Macro (loc, macro) -> - raise (Macro (loc,disambiguate_macro status (text,prefix_len,macro))) + eval_ncommand ~include_paths opts status (text,prefix_len,cmd) | GrafiteAst.NMacro (loc, macro) -> raise (NMacro (loc,macro)) -} and eval_from_moo = {efm_go = fun status fname -> - let ast_of_cmd cmd = - ("",0,GrafiteAst.Executable (HExtlib.dummy_floc, - GrafiteAst.Command (HExtlib.dummy_floc, - cmd))) - in - let moo = GrafiteMarshal.load_moo fname in - List.fold_left - (fun status ast -> - let ast = ast_of_cmd ast in - let status,lemmas = - eval_ast.ea_go - ~disambiguate_tactic:(fun status _ (_,_,tactic) -> status,tactic) - ~disambiguate_command:(fun status (_,_,cmd) -> status,cmd) - ~disambiguate_macro:(fun _ _ -> assert false) - status ast - in - assert (lemmas=`Old []); - status) - status moo -} and eval_ast = {ea_go = fun ~disambiguate_tactic ~disambiguate_command -~disambiguate_macro ?(do_heavy_checks=false) status -(text,prefix_len,st) --> +and eval_ast ~include_paths ?(do_heavy_checks=false) status (text,prefix_len,st) += let opts = { do_heavy_checks = do_heavy_checks ; } in match st with | GrafiteAst.Executable (_,ex) -> - eval_executable.ee_go ~disambiguate_tactic ~disambiguate_command - ~disambiguate_macro opts status (text,prefix_len,ex) + eval_executable ~include_paths opts status (text,prefix_len,ex) | GrafiteAst.Comment (_,c) -> - eval_comment.ecm_go ~disambiguate_command opts status (text,prefix_len,c) -} and eval_comment = { ecm_go = fun ~disambiguate_command opts status (text,prefix_len,c) -> - status, `Old [] -} + eval_comment opts status (text,prefix_len,c) ;; - - -let eval_ast = eval_ast.ea_go