X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=matitaB%2Fcomponents%2Fgrafite_engine%2FgrafiteEngine.ml;h=02dfb00127adddb88455891d20ff78e87f82715e;hb=3b7b8afcb429a60d716d5226a5b6ab0d003228b1;hp=7febf874e3a25ac5defb81232663ace8756a3fe2;hpb=cacbe3c6493ddce76c4c13379ade271d8dd172e8;p=helm.git diff --git a/matitaB/components/grafite_engine/grafiteEngine.ml b/matitaB/components/grafite_engine/grafiteEngine.ml index 7febf874e..02dfb0012 100644 --- a/matitaB/components/grafite_engine/grafiteEngine.ml +++ b/matitaB/components/grafite_engine/grafiteEngine.ml @@ -34,6 +34,8 @@ type options = { do_heavy_checks: bool ; } +let prerr_endline _ = () + let basic_eval_unification_hint (t,n) status = NCicUnifHint.add_user_provided_hint status t n ;; @@ -44,7 +46,7 @@ let inject_unification_hint = ~alias_only status = if not alias_only then - let t = refresh_uri_in_term (status :> NCic.status) t in + let t = refresh_uri_in_term (status :> NCicEnvironment.status) t in basic_eval_unification_hint (t,n) status else status @@ -79,11 +81,12 @@ let basic_eval_interpretation ~alias_only (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)] + (* FIXME! the uri should be filled with something meaningful! *) + [DisambiguateTypes.Symbol symbol, + GrafiteAst.Symbol_alias (symbol,None,dsc)] in - GrafiteDisambiguate.set_proof_aliases status ~implicit_aliases:false mode diff + GrafiteDisambiguate.add_to_disambiguation_univ status diff ;; let inject_interpretation = @@ -113,7 +116,8 @@ let eval_interpretation status data= ;; let basic_eval_alias (mode,diff) status = - GrafiteDisambiguate.set_proof_aliases status ~implicit_aliases:false mode diff + prerr_endline "basic_eval_alias"; + GrafiteDisambiguate.add_to_disambiguation_univ status diff ;; let inject_alias = @@ -132,8 +136,15 @@ let eval_alias status 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 rec get_disamb = function + | [] -> Stdpp.dummy_loc,None,None + | (_,(csym,NotationEnv.NoType,NotationEnv.DisambiguationValue dv))::_ -> dv + | _::tl -> get_disamb tl + in *) + let l2' = + TermContentPres.instantiate_level2 status env (*(get_disamb env)*) l2 in + prerr_endline ("new l2 ast : " ^ (NotationPp.pp_term status l2')); + NotationPt.AttributedTerm (`Loc loc,l2')) ;; let inject_input_notation = @@ -144,10 +155,10 @@ let inject_input_notation = 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_term:(refresh_uri_in_term (status:>NCicEnvironment.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_term:(refresh_uri_in_term (status:>NCicEnvironment.status)) ~refresh_uri_in_reference l2 in basic_eval_input_notation (l1,l2) status @@ -175,10 +186,10 @@ let inject_output_notation = 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_term:(refresh_uri_in_term (status:>NCicEnvironment.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_term:(refresh_uri_in_term (status:>NCicEnvironment.status)) ~refresh_uri_in_reference l2 in basic_eval_output_notation (l1,l2) status @@ -198,7 +209,7 @@ let record_index_obj = 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 + let refresh_uri_in_term = refresh_uri_in_term (status:>NCicEnvironment.status) in if not alias_only then basic_index_obj (List.map @@ -314,7 +325,7 @@ let inject_constraint = (* 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 u1 u2; + NCicEnvironment.add_lt_constraint status u1 u2; status else status @@ -346,7 +357,7 @@ let eval_ng_tac tac = ) seqs) | GrafiteAst.NAuto (_loc, (None,a)) -> NnAuto.auto_tac ~params:(None,a) ?trace_ref:None - | GrafiteAst.NAuto (_loc, (Some l,a)) -> + | GrafiteAst.NAuto (_loc, (Some (_,l),a)) -> NnAuto.auto_tac ~params:(Some List.map (fun x -> "",0,x) l,a) ?trace_ref:None | GrafiteAst.NBranch _ -> NTactics.branch_tac ~force:false @@ -485,13 +496,40 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = GrafiteTypes.Serializer.require ~alias_only ~baseuri ~fname:fullpath 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,`Ambiguous) in + let metasenv,subst, status,t = + GrafiteDisambiguate.disambiguate_nterm + status None [] [] [] ("",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 + | _ -> 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 status, composites = - NCicCoercDeclaration.eval_ncoercion status name t ty source target in + NCicCoercDeclaration.eval_ncoercion status name compose t ty source + target 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 -> + | 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 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 @@ -511,7 +549,7 @@ 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 status (fun _ () -> ()) () fix t @@ -526,7 +564,7 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = let obj = uri,height,[],[],obj_kind in let old_status = status in let status = NCicLibrary.add_obj status obj in - let index_obj = + let index_obj = index && match obj_kind with NCic.Constant (_,_,_,_,(_,`Example,_)) | NCic.Fixpoint (_,_,(_,`Example,_)) -> false @@ -560,7 +598,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 @@ -571,16 +609,17 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = else nstatus with - | MultiPassDisambiguator.DisambiguationError _ + | GrafiteDisambiguate.Error _ | NCicTypeChecker.TypeCheckerFailure _ -> (*HLog.warn "error in generating projection/eliminator";*) status ) status boxml in let _,_,_,_,nobj = obj 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 @@ -592,14 +631,74 @@ 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"; *) 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) + (NCicEnvironment.get_universes status)))) 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 + prerr_endline ("creazione discriminatore per " ^ ind_name); + (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 -> + prerr_endline (Printf.sprintf + "unable to generate leibniz discrimination principle (constructor %s too big)" + 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 + | _ -> + prerr_endline "error in generating discrimination principle"; + (*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 + prerr_endline ("creazione discriminatore per " ^ ind_name); + (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 _ -> (*HLog.warn "error in generating discrimination principle"; *) + prerr_endline "error in generating discrimination principle"; + let status = status#set_ng_mode `CommandMode in + status) + status' itl | _ -> status in let coercions = @@ -617,15 +716,16 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = try let metasenv,subst,status,t = GrafiteDisambiguate.disambiguate_nterm status None [] [] [] - ("",0,NotationPt.Ident (name,None)) in + ("",0,NotationPt.Ident (name,`Ambiguous)) in assert (metasenv = [] && subst = []); let status, nuris = NCicCoercDeclaration. basic_eval_and_record_ncoercion_from_t_cpos_arity - status (name,t,cpos,arity) in + + status (name,true,t,cpos,arity) in let aliases = GrafiteDisambiguate.aliases_for_objs status nuris in eval_alias status (mode,aliases) - with MultiPassDisambiguator.DisambiguationError _-> + with GrafiteDisambiguate.Error _ -> HLog.warn ("error in generating coercion: "^name); status) status coercions @@ -665,8 +765,8 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = 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 @@ -681,26 +781,30 @@ 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 None [] [] [] (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 (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") @@ -708,8 +812,10 @@ 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 [] [] [] - (text,prefix_len,s) + let metasenv,subst,status,sort = + GrafiteDisambiguate.disambiguate_nterm status None [] [] [] + (text,prefix_len,s) + in metasenv,subst,status,sort in assert (metasenv = []); let sort = NCicReduction.whd status ~subst [] sort in @@ -740,7 +846,7 @@ 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] @@ -752,6 +858,7 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = in eval_interpretation status (dsc,(symbol, args),cic_appl_pattern) | GrafiteAst.Notation (loc, dir, l1, associativity, precedence, l2) -> + prerr_endline ("new notation: " ^ (NotationPp.pp_term status l1)); let l1 = CicNotationParser.check_l1_pattern l1 (dir = Some `RightToLeft) precedence associativity @@ -760,8 +867,11 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = if dir <> Some `RightToLeft then eval_input_notation status (l1,l2) else status in + let status = if dir <> Some `LeftToRight then eval_output_notation status (l1,l2) else status + in prerr_endline ("new grammar:\n" ^ (Print_grammar.ebnf_of_term status)); + status | GrafiteAst.Alias (loc, spec) -> let diff = (*CSC: Warning: this code should be factorized with the corresponding @@ -769,10 +879,10 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = 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] + | GrafiteAst.Symbol_alias (symb, uri, desc) -> + [DisambiguateTypes.Symbol symb,spec] + | GrafiteAst.Number_alias (uri,desc) -> + [DisambiguateTypes.Num,spec] in let mode = GrafiteAst.WithPreferences in(*assert false in (* VEDI SOPRA *) MATITA 1.0*) eval_alias status (mode,diff) @@ -784,12 +894,14 @@ 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 - raise (GrafiteTypes.Command_error "Not in proof mode") + (prerr_endline ("not in proof mode 2: " ^ GrafiteAstPp.pp_executable status ~map_unicode_to_tex:false ex); + raise (GrafiteTypes.Command_error "Not in proof mode")) else let status = List.fold_left (fun status tac -> let status = eval_ng_tac (text,prefix_len,tac) status in + prerr_endline "prima di subst_metasenv_and_fix_names"; subst_metasenv_and_fix_names status) status tacl in