X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=matita%2Fcomponents%2Fgrafite_engine%2FgrafiteEngine.ml;h=a9a46e7431dfe931b872edc4f4b8188ec68458b6;hb=3ace6e853d2cb8ce8c98b7d8c07a4f6c6b61ba84;hp=a70e78855b52939c0d1b9f0f36f0899e12fd3072;hpb=30bbfa78612ca1ad0c131a75d7075cfd35bebbe1;p=helm.git diff --git a/matita/components/grafite_engine/grafiteEngine.ml b/matita/components/grafite_engine/grafiteEngine.ml index a70e78855..a9a46e743 100644 --- a/matita/components/grafite_engine/grafiteEngine.ml +++ b/matita/components/grafite_engine/grafiteEngine.ml @@ -40,8 +40,7 @@ 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_universe ~refresh_uri_in_term ~refresh_uri_in_reference = let t = refresh_uri_in_term t in basic_eval_unification_hint (t,n) in @@ -51,13 +50,13 @@ let inject_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 None [] [] [] ("",0,t) in assert (metasenv=[]); let t = NCicUntrusted.apply_subst 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,[] + status ;; let basic_index_obj l status = @@ -70,10 +69,119 @@ let basic_index_obj l status = status#auto_cache l) ;; +let basic_eval_interpretation (dsc, (symbol, args), cic_appl_pattern) status = + let status = + Interpretations.add_interpretation status dsc (symbol, args) cic_appl_pattern + 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 + = + 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 (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 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 = + 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 + let dump = inject_alias data::status#dump in + status#set_dump dump +;; + +let basic_eval_input_notation (l1,l2) status = + GrafiteParser.extend status l1 + (fun env loc -> + NotationPt.AttributedTerm + (`Loc loc,TermContentPres.instantiate_level2 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 + = + 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) + 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 + let dump = inject_input_notation data::status#dump in + status#set_dump dump +;; + +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 + = + 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) + 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 + let dump = inject_output_notation data::status#dump in + status#set_dump dump +;; + 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 = basic_index_obj (List.map @@ -157,8 +265,7 @@ 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_universe ~refresh_uri_in_term ~refresh_uri_in_reference = index_eq (NCicLibrary.refresh_uri uri) in GrafiteTypes.Serializer.register#run "index_eq" basic_index_eq @@ -183,8 +290,7 @@ 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_universe ~refresh_uri_in_term ~refresh_uri_in_reference = let u1 = refresh_uri_in_universe u1 in let u2 = refresh_uri_in_universe u2 in @@ -197,7 +303,7 @@ 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,[] + status ;; let eval_ng_tac tac = @@ -271,7 +377,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) @@ -290,6 +396,61 @@ 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 @@ -300,12 +461,17 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = GrafiteTypes.Serializer.require ~baseuri:(NUri.uri_of_string baseuri) status in let status = status#set_dump (obj::status#dump) in - assert false (* mode must be passed to GrafiteTypes.Serializer.require + let status = status#set_dependencies (fname::status#dependencies) in + (*assert false;*) (* MATITA 1.0mode must be passed to GrafiteTypes.Serializer.require somehow *) - status,[] + 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 + let 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") @@ -337,6 +503,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 @@ -375,12 +542,14 @@ 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 = LexiconSync.add_aliases_for_objs status [uri] in - let status,uris = + 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,uris) boxml -> + (fun status boxml -> try - let nstatus,nuris = + let nstatus = eval_ncommand ~include_paths opts status ("",0,GrafiteAst.NObj (HExtlib.dummy_floc,boxml)) in @@ -388,16 +557,16 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = begin (*HLog.warn "error in generating projection/eliminator";*) assert(status#ng_mode = `CommandMode); - status, uris + status end else - nstatus, uris@nuris + nstatus with | MultiPassDisambiguator.DisambiguationError _ | NCicTypeChecker.TypeCheckerFailure _ -> (*HLog.warn "error in generating projection/eliminator";*) - status,uris - ) (status,[] (* uris *)) boxml in + status + ) status boxml in let _,_,_,_,nobj = obj in let status = match nobj with NCic.Inductive (is_ind,leftno,[it],_) -> @@ -412,10 +581,10 @@ let rec eval_ncommand ~include_paths 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 + (match menv with [] -> eval_ncommand ~include_paths opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) - | _ -> status,[])) + | _ -> status)) (* XXX *) with _ -> (*HLog.warn "error in generating inversion principle"; *) let status = status#set_ng_mode `CommandMode in status) @@ -433,27 +602,26 @@ let rec eval_ncommand ~include_paths 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 [] [] [] + GrafiteDisambiguate.disambiguate_nterm status None [] [] [] ("",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 = nuris@uris in - status, uris + 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, uris) - (status,uris) coercions + status) + status coercions in - status,uris + status with exn -> NCicLibrary.time_travel old_status; @@ -505,7 +673,7 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = (match nmenv with [] -> eval_ncommand ~include_paths opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) - | _ -> status,[]) + | _ -> status) | GrafiteAst.NDiscriminator (_,_) -> assert false (*(loc, indty) -> if status#ng_mode <> `CommandMode then raise (GrafiteTypes.Command_error "Not in command mode") @@ -530,95 +698,61 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = 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 None [] [] [] + (text,prefix_len,s) in assert (metasenv = []); let sort = NCicReduction.whd ~subst [] sort in - let sort = match sort with + 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" + (NCicPp.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 None [] [] 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 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 ~include_paths opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) - | _ -> assert false) + 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) + | _ -> assert false) | GrafiteAst.NUnivConstraint (loc,u1,u2) -> eval_add_constraint status [`Type,u1] [`Type,u2] (* ex lexicon commands *) | GrafiteAst.Interpretation (loc, dsc, (symbol, args), cic_appl_pattern) -> - let rec disambiguate = - function - NotationPt.ApplPattern l -> - NotationPt.ApplPattern (List.map disambiguate l) - | NotationPt.VarPattern id - when not - (List.exists - (function (NotationPt.IdentArg (_,id')) -> id'=id) args) - -> - let item = DisambiguateTypes.Id id in - begin try - match DisambiguateTypes.Environment.find item status#lstatus.LexiconTypes.aliases with - GrafiteAst.Ident_alias (_, uri) -> - NotationPt.NRefPattern (NReference.reference_of_string uri) - | _ -> assert false - with Not_found -> - prerr_endline - ("LexiconEngine.eval_command: domain item not found: " ^ - (DisambiguateTypes.string_of_domain_item item)); - LexiconEngine.dump_aliases prerr_endline "" status; - raise - (Failure - ((DisambiguateTypes.string_of_domain_item item) ^ " not found")) - end - | p -> p + let cic_appl_pattern = + GrafiteDisambiguate.disambiguate_cic_appl_pattern status args + cic_appl_pattern in - let cic_appl_pattern = disambiguate cic_appl_pattern in - let status = - Interpretations.add_interpretation status - dsc (symbol, args) cic_appl_pattern in - let mode = GrafiteAst.WithPreferences (*assert false*) in (* VEDI SOTTO *) - let diff = - [DisambiguateTypes.Symbol (symbol, 0), - GrafiteAst.Symbol_alias (symbol,0,dsc)] in - let status = LexiconEngine.set_proof_aliases status mode diff in - status, [] - (*assert false*) (* MANCA SALVATAGGIO SU DISCO CHE DEVE TENERE IN CONTO - IL MODE WithPreference/WithOutPreferences*) + 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 = - if dir <> Some `RightToLeft then - GrafiteParser.extend status l1 - (fun env loc -> - NotationPt.AttributedTerm - (`Loc loc,TermContentPres.instantiate_level2 env l2)) + if dir <> Some `RightToLeft then eval_input_notation status (l1,l2) else status in - let status = - if dir <> Some `LeftToRight then - let status = TermContentPres.add_pretty_printer status l2 l1 in - status - else - status - in -(* assert false (* MANCA SALVATAGGIO SU DISCO *) *) - status, [] (* capire [] XX *) + 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 @@ -631,22 +765,13 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = | GrafiteAst.Number_alias (instance,desc) -> [DisambiguateTypes.Num instance,spec] in - let mode = assert false in (* VEDI SOPRA *) - LexiconEngine.set_proof_aliases status mode diff; - assert false (* MANCA SALVATAGGIO SU DISCO *) + 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, [] - -let rec eval_command opts status (text,prefix_len,cmd) = - let status,uris = - match cmd with - | GrafiteAst.Print (_,_) -> status,[] - | GrafiteAst.Set (loc, name, value) -> status, [] - in - status,uris +let eval_comment opts status (text,prefix_len,c) = status -and eval_executable ~include_paths opts status (text,prefix_len,ex) = +let rec eval_executable ~include_paths opts status (text,prefix_len,ex) = match ex with | GrafiteAst.NTactic (_(*loc*), tacl) -> if status#ng_mode <> `ProofMode then @@ -659,9 +784,7 @@ and eval_executable ~include_paths opts status (text,prefix_len,ex) = subst_metasenv_and_fix_names status) status tacl in - status,[] - | GrafiteAst.Command (_, cmd) -> - eval_command opts status (text,prefix_len,cmd) + status | GrafiteAst.NCommand (_, cmd) -> eval_ncommand ~include_paths opts status (text,prefix_len,cmd) | GrafiteAst.NMacro (loc, macro) ->