X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=matita%2Fcomponents%2Fgrafite_engine%2FgrafiteEngine.ml;h=5997297cd765b2491551e91ba726e2372119f87a;hb=fa3139698294b99889afd375298f9b071cdfbd67;hp=0e5f7b529ebb1109a4975e30e1c998c5d8e5db6d;hpb=d8c17db3c787f3ea964bbcd3b27427ca44b356d0;p=helm.git diff --git a/matita/components/grafite_engine/grafiteEngine.ml b/matita/components/grafite_engine/grafiteEngine.ml index 0e5f7b529..5997297cd 100644 --- a/matita/components/grafite_engine/grafiteEngine.ml +++ b/matita/components/grafite_engine/grafiteEngine.ml @@ -41,8 +41,12 @@ 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 t in basic_eval_unification_hint (t,n) status + else + status in GrafiteTypes.Serializer.register#run "unification_hints" basic_eval_unification_hint @@ -69,9 +73,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 +90,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,14 +102,14 @@ 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 status = basic_eval_interpretation ~alias_only:false data status in let dump = inject_interpretation data::status#dump in status#set_dump dump ;; @@ -112,7 +120,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 @@ -134,14 +142,18 @@ let basic_eval_input_notation (l1,l2) status = 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_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) status + else + status in GrafiteTypes.Serializer.register#run "input_notation" basic_eval_input_notation @@ -160,14 +172,18 @@ 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_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) status + else + status in GrafiteTypes.Serializer.register#run "output_notation" basic_eval_output_notation @@ -181,12 +197,15 @@ let eval_output_notation status 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 = + 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 ;; @@ -266,7 +285,9 @@ let index_eq uri 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 (NCicLibrary.refresh_uri uri) status else + status in GrafiteTypes.Serializer.register#run "index_eq" basic_index_eq ;; @@ -290,11 +311,15 @@ let basic_eval_add_constraint (u1,u2) status = let inject_constraint = let basic_eval_add_constraint (u1,u2) - ~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference + ~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 + basic_eval_add_constraint (u1,u2) status + else + status in GrafiteTypes.Serializer.register#run "constraints" basic_eval_add_constraint ;; @@ -343,6 +368,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) -> @@ -377,7 +403,7 @@ 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) @@ -396,26 +422,82 @@ let subst_metasenv_and_fix_names status = status#set_obj(u,h,NCicUntrusted.apply_subst_metasenv subst metasenv,subst,o) ;; +let is_proof_irrelevant context ty = + match + NCicReduction.whd ~subst:[] context + (NCicTypeChecker.typeof ~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 + NCic.Prod (n,s,t) -> + not (is_proof_irrelevant context s) :: + relevance_of ~context:((n,NCic.Decl s)::context) t + | _ -> [] +;; + +let compute_relevance uri = + function + NCic.Constant (_,name,bo,ty,attrs) -> + let relevance = relevance_of 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 + 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 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 + relevance,name,ty + ) cons + in + (relevance,name,arity,cons) + ) tys + in + NCic.Inductive (ind,leftno,tys,attrs) +;; + 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,obj = - GrafiteTypes.Serializer.require ~baseuri:(NUri.uri_of_string baseuri) - status in + GrafiteTypes.Serializer.require ~alias_only ~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 | GrafiteAst.UnificationHint (loc, t, n) -> eval_unification_hint status t n | GrafiteAst.NCoercion (loc, name, t, ty, source, target) -> let status, composites = - NCicCoercDeclaration.eval_ncoercion status name t ty source target - in - GrafiteDisambiguate.add_aliases_for_objs status composites + NCicCoercDeclaration.eval_ncoercion status name t ty source target in + let mode = GrafiteAst.WithPreferences in (* MATITA 1.0: fixme *) + let aliases = GrafiteDisambiguate.aliases_for_objs composites in + eval_alias status (mode,aliases) | GrafiteAst.NQed loc -> if status#ng_mode <> `ProofMode then raise (GrafiteTypes.Command_error "Not in proof mode") @@ -447,6 +529,7 @@ 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 = uri,height,[],[],obj_kind in let old_status = status in let status = NCicLibrary.add_obj status obj in @@ -485,7 +568,9 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = let uris = uri::List.rev uris_rev in *) let status = status#set_ng_mode `CommandMode in - let status = GrafiteDisambiguate.add_aliases_for_objs status [uri] in + let xxaliases = GrafiteDisambiguate.aliases_for_objs [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 boxml -> @@ -554,9 +639,9 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = let status, nuris = NCicCoercDeclaration. basic_eval_and_record_ncoercion_from_t_cpos_arity - status (name,t,cpos,arity) - in - GrafiteDisambiguate.add_aliases_for_objs status nuris + status (name,t,cpos,arity) in + let aliases = GrafiteDisambiguate.aliases_for_objs nuris in + eval_alias status (mode,aliases) with MultiPassDisambiguator.DisambiguationError _-> HLog.warn ("error in generating coercion: "^name); status)