X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=matita%2Fcomponents%2Fgrafite_engine%2FgrafiteEngine.ml;h=ee0573ae741c828201dee08d05f09345fa611628;hb=5cfd68a5d9e73edb40e1cfe021a1426354767aa8;hp=a9a46e7431dfe931b872edc4f4b8188ec68458b6;hpb=3ace6e853d2cb8ce8c98b7d8c07a4f6c6b61ba84;p=helm.git diff --git a/matita/components/grafite_engine/grafiteEngine.ml b/matita/components/grafite_engine/grafiteEngine.ml index a9a46e743..ee0573ae7 100644 --- a/matita/components/grafite_engine/grafiteEngine.ml +++ b/matita/components/grafite_engine/grafiteEngine.ml @@ -41,8 +41,13 @@ let basic_eval_unification_hint (t,n) status = let inject_unification_hint = let basic_eval_unification_hint (t,n) ~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 GrafiteTypes.Serializer.register#run "unification_hints" basic_eval_unification_hint @@ -50,16 +55,14 @@ let inject_unification_hint = let eval_unification_hint status t n = let metasenv,subst,status,t = - GrafiteDisambiguate.disambiguate_nterm status None [] [] [] ("",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 + 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) -> @@ -69,9 +72,12 @@ let basic_index_obj l status = status#auto_cache l) ;; -let basic_eval_interpretation (dsc, (symbol, args), cic_appl_pattern) status = +let basic_eval_interpretation ~alias_only (dsc, (symbol, args), cic_appl_pattern) status = let status = - Interpretations.add_interpretation status dsc (symbol, args) cic_appl_pattern + 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 = @@ -83,6 +89,7 @@ let basic_eval_interpretation (dsc, (symbol, args), cic_appl_pattern) status = 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 @@ -94,16 +101,15 @@ let inject_interpretation = | NotationPt.ApplPattern l -> NotationPt.ApplPattern (List.map refresh l) in let cic_appl_pattern = refresh cic_appl_pattern in - basic_eval_interpretation (dsc, (symbol, args), cic_appl_pattern) + 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 data status in - let dump = inject_interpretation data::status#dump in - status#set_dump dump + 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 = @@ -112,7 +118,7 @@ let basic_eval_alias (mode,diff) status = let inject_alias = let basic_eval_alias (mode,diff) ~refresh_uri_in_universe ~refresh_uri_in_term - ~refresh_uri_in_reference = + ~refresh_uri_in_reference ~alias_only = basic_eval_alias (mode,diff) in GrafiteTypes.Serializer.register#run "alias" basic_eval_alias @@ -120,28 +126,33 @@ let inject_alias = let eval_alias status data= let status = basic_eval_alias data status in - let dump = inject_alias data::status#dump in - status#set_dump dump + 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 env l2)) + (`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 = - let l1 = - CicNotationParser.refresh_uri_in_checked_l1_pattern - ~refresh_uri_in_term ~refresh_uri_in_reference l1 in - let l2 = NotationUtil.refresh_uri_in_term - ~refresh_uri_in_term ~refresh_uri_in_reference l2 - in - basic_eval_input_notation (l1,l2) + 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 @@ -149,8 +160,7 @@ let inject_input_notation = let eval_input_notation status data= let status = basic_eval_input_notation data status in - let dump = inject_input_notation data::status#dump in - status#set_dump dump + NCicLibrary.dump_obj status (inject_input_notation data) ;; let basic_eval_output_notation (l1,l2) status = @@ -160,14 +170,20 @@ let basic_eval_output_notation (l1,l2) status = 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 = - let l1 = - CicNotationParser.refresh_uri_in_checked_l1_pattern - ~refresh_uri_in_term ~refresh_uri_in_reference l1 in - let l2 = NotationUtil.refresh_uri_in_term - ~refresh_uri_in_term ~refresh_uri_in_reference l2 - in - basic_eval_output_notation (l1,l2) + 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 @@ -175,18 +191,21 @@ let inject_output_notation = let eval_output_notation status data= let status = basic_eval_output_notation data status in - let dump = inject_output_notation data::status#dump in - status#set_dump dump + NCicLibrary.dump_obj status (inject_output_notation data) ;; let record_index_obj = let aux l ~refresh_uri_in_universe - ~refresh_uri_in_term ~refresh_uri_in_reference + ~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 GrafiteTypes.Serializer.register#run "index_obj" aux ;; @@ -235,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 @@ -253,60 +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 ~refresh_uri_in_reference - = index_eq (NCicLibrary.refresh_uri uri) + ~alias_only status + = if not alias_only then index_eq false (NCicLibrary.refresh_uri uri) status + else + status in 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 ~refresh_uri_in_reference + 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 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 +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) @@ -343,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) -> @@ -383,6 +492,44 @@ let eval_ng_tac tac = 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, t1) -> Declarative.we_need_to_prove (text,prefix_len,t) id + (match t1 with None -> None | Some t1 -> Some (text,prefix_len,t1)) + |GrafiteAst.BetaRewritingStep (_, t) -> Declarative.beta_rewriting_step (text,prefix_len,t) + | 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 *) ;; @@ -391,39 +538,39 @@ 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 context ty = +let is_proof_irrelevant status context ty = match - NCicReduction.whd ~subst:[] context - (NCicTypeChecker.typeof ~subst:[] ~metasenv:[] context ty) + 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 ?(context=[]) ty = - match NCicReduction.whd ~subst:[] context ty with +let rec relevance_of status ?(context=[]) ty = + match NCicReduction.whd status ~subst:[] context ty with NCic.Prod (n,s,t) -> - not (is_proof_irrelevant context s) :: - relevance_of ~context:((n,NCic.Decl s)::context) t + not (is_proof_irrelevant status context s) :: + relevance_of status ~context:((n,NCic.Decl s)::context) t | _ -> [] ;; -let compute_relevance uri = +let compute_relevance status uri = function NCic.Constant (_,name,bo,ty,attrs) -> - let relevance = relevance_of ty in + 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 ty in + let relevance = relevance_of status ty in relevance,name,recno,ty,bo ) funs in @@ -435,13 +582,13 @@ let compute_relevance uri = let tys = List.map (fun (_,name,arity,cons) -> - let relevance = relevance_of arity in + let relevance = relevance_of status arity in let cons = List.map (fun (_,name,ty) -> let dety = - NCicTypeChecker.debruijn uri tysno ~subst:[] [] ty in - let relevance = relevance_of ~context dety in + NCicTypeChecker.debruijn status uri tysno ~subst:[] [] ty in + let relevance = relevance_of status ~context dety in relevance,name,ty ) cons in @@ -451,28 +598,68 @@ let compute_relevance uri = 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 = + let _root, baseuri, fullpath, _rrelpath = Librarian.baseuri_of_script ~include_paths fname in - let status,obj = - GrafiteTypes.Serializer.require ~baseuri:(NUri.uri_of_string baseuri) - status in - let status = status#set_dump (obj::status#dump) in - let status = status#set_dependencies (fname::status#dependencies) in - (*assert false;*) (* MATITA 1.0mode must be passed to GrafiteTypes.Serializer.require - somehow *) - status + 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) -> + | 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 t ty source target in + 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 composites in + let aliases = GrafiteDisambiguate.aliases_for_objs status composites in eval_alias status (mode,aliases) - | GrafiteAst.NQed loc -> + | GrafiteAst.NQed (loc,index) -> if status#ng_mode <> `ProofMode then raise (GrafiteTypes.Command_error "Not in proof mode") else @@ -483,8 +670,8 @@ let rec eval_ncommand ~include_paths 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 -> @@ -492,10 +679,10 @@ let rec eval_ncommand ~include_paths 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 @@ -503,11 +690,14 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = NCicUntrusted.map_obj_kind (fix ()) obj_kind | _ -> obj_kind in - let obj_kind = compute_relevance uri obj_kind in + let obj_kind = compute_relevance status uri obj_kind in let obj = uri,height,[],[],obj_kind in 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 @@ -517,32 +707,26 @@ let rec eval_ncommand ~include_paths 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 xxaliases = GrafiteDisambiguate.aliases_for_objs [uri] in + (*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 = @@ -551,7 +735,7 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = try let nstatus = eval_ncommand ~include_paths opts status - ("",0,GrafiteAst.NObj (HExtlib.dummy_floc,boxml)) + ("",0,GrafiteAst.NObj (HExtlib.dummy_floc,boxml,true)) in if nstatus#ng_mode <> `CommandMode then begin @@ -562,16 +746,28 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = else nstatus with - | MultiPassDisambiguator.DisambiguationError _ + | MultiPassDisambiguator.DisambiguationError _ -> + HLog.warn "error in disambiguating projection/eliminator"; + status | NCicTypeChecker.TypeCheckerFailure _ -> - (*HLog.warn "error in generating projection/eliminator";*) + HLog.warn "error in typechecking projection/eliminator"; status ) status boxml in - let _,_,_,_,nobj = obj 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 @@ -583,14 +779,69 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = let _,_,menv,_,_ = invobj in (match menv with [] -> eval_ncommand ~include_paths opts status - ("",0,GrafiteAst.NQed Stdpp.dummy_loc) + ("",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 = @@ -607,14 +858,15 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = (fun status (name,cpos,arity) -> try let metasenv,subst,status,t = - GrafiteDisambiguate.disambiguate_nterm status None [] [] [] + 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 aliases = GrafiteDisambiguate.aliases_for_objs nuris in + 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); @@ -631,7 +883,7 @@ let rec eval_ncommand ~include_paths 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 @@ -646,18 +898,18 @@ let rec eval_ncommand ~include_paths 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 ~include_paths 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 @@ -672,26 +924,29 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = let status = status#set_ng_mode `ProofMode in (match nmenv with [] -> - eval_ncommand ~include_paths opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) + eval_ncommand ~include_paths opts status + ("",0,GrafiteAst.NQed(Stdpp.dummy_loc,index)) | _ -> status) - | GrafiteAst.NDiscriminator (_,_) -> assert false (*(loc, indty) -> + | 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 ~include_paths 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, []) *) + status) | GrafiteAst.NInverter (loc, name, indty, selection, sort) -> if status#ng_mode <> `CommandMode then raise (GrafiteTypes.Command_error "Not in command mode") @@ -699,28 +954,28 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = let metasenv,subst,status,sort = match sort with | None -> [],[],status,NCic.Sort NCic.Prop | Some s -> - GrafiteDisambiguate.disambiguate_nterm status None [] [] [] + GrafiteDisambiguate.disambiguate_nterm status `XTSort [] [] [] (text,prefix_len,s) in assert (metasenv = []); - let sort = NCicReduction.whd ~subst [] sort in + 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 + (status#ppterm ~metasenv ~subst ~context:[] sort))) in let status = status#set_ng_mode `ProofMode in let metasenv,subst,status,indty = - GrafiteDisambiguate.disambiguate_nterm status None [] [] subst + 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 r + indtyno, NCicEnvironment.get_checked_indtys status r | _ -> - prerr_endline ("engine: indty =" ^ NCicPp.ppterm ~metasenv:[] + prerr_endline ("engine: indty =" ^ status#ppterm ~metasenv:[] ~subst:[] ~context:[] indty); assert false in let it = List.nth tys indtyno in @@ -731,10 +986,10 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = (match menv with [] -> eval_ncommand ~include_paths opts status - ("",0,GrafiteAst.NQed Stdpp.dummy_loc) + ("",0,GrafiteAst.NQed(Stdpp.dummy_loc,false)) | _ -> assert false) - | GrafiteAst.NUnivConstraint (loc,u1,u2) -> - eval_add_constraint status [`Type,u1] [`Type,u2] + | 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 = @@ -780,8 +1035,13 @@ let rec eval_executable ~include_paths opts status (text,prefix_len,ex) = 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