X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fgrafite_engine%2FgrafiteEngine.ml;h=239d30d2d1480ff0b0c354a757cacbf4105cc058;hb=12f96bd48b460d06f9858a334ee7c52d6831712f;hp=f1aea02da0a71efd0bece6fa26c0df667a5cc685;hpb=c515405206bfeb9f99d3e175b7f1e390ba299f28;p=helm.git diff --git a/helm/software/components/grafite_engine/grafiteEngine.ml b/helm/software/components/grafite_engine/grafiteEngine.ml index f1aea02da..239d30d2d 100644 --- a/helm/software/components/grafite_engine/grafiteEngine.ml +++ b/helm/software/components/grafite_engine/grafiteEngine.ml @@ -33,6 +33,7 @@ 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 @@ -40,6 +41,11 @@ 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 *) @@ -481,7 +487,10 @@ let inject_unification_hint = = let t = refresh_uri_in_term t in basic_eval_unification_hint (t,n) in - NRstatus.Serializer.register "unification_hints" basic_eval_unification_hint + NCicLibrary.Serializer.register#run "unification_hints" + object(_ : 'a NCicLibrary.register_type) + method run = basic_eval_unification_hint + end ;; let eval_unification_hint status t n = @@ -495,246 +504,150 @@ let eval_unification_hint status t n = status,`New [] ;; -let product f l1 l2 = - List.fold_left - (fun acc x -> - List.fold_left - (fun acc y -> - f x y :: acc) - acc l2) - [] l1 -;; - -let pos_in_list x l = - match - HExtlib.list_findopt (fun y i -> if y = x then Some i else None) l - with - | Some i -> i - | None -> assert false -;; - -let pos_of x t = - match t with - | NCic.Appl l -> pos_in_list x l - | _ -> assert false -;; - -let rec count_prod = function - | NCic.Prod (_,_,x) -> 1 + count_prod x - | _ -> 0 -;; - -let term_at i t = - match t with - | NCic.Appl l -> - (match - HExtlib.list_findopt (fun y j -> if i+1=j then Some y else None) l - with - | Some i -> i - | None -> assert false) - | _ -> assert false -;; +let basic_index_obj l status = + status#set_auto_cache + (List.fold_left + (fun t (ks,v) -> + List.fold_left (fun t k -> + NDiscriminationTree.DiscriminationTree.index t k v) + t ks) + status#auto_cache l) +;; -let src_tgt_of_ty_cpos_arity ty cpos arity = - let pis = count_prod ty in - let tpos = pis - arity in - let rec aux i j = function - | NCic.Prod (_,s,_) when i = j -> s - | NCic.Prod (_,_,t) -> aux (i+1) j t - | t -> assert (i = j); t - in - let mask t = - let rec aux () = function - | NCic.Meta _ - | NCic.Implicit _ as x -> x - | NCic.Rel _ -> NCic.Implicit `Type - | t -> NCicUtils.map (fun _ () -> ()) () aux t - in - aux () t - in - mask (aux 0 cpos ty), mask (aux 0 tpos ty) -;; - -let close_in_context t metasenv = - let rec aux m_subst subst ctx = function - | (i,(tag,[],ty)) :: tl -> - let name = "x" ^ string_of_int (List.length ctx) in - let subst = (i,(tag,[],NCic.Rel (List.length tl+1),ty))::subst in - let ty = NCicUntrusted.apply_subst (m_subst (List.length ctx)) ctx ty in - let m_subst m = - (i,(tag,[],NCic.Rel (m-List.length ctx),ty))::(m_subst m) - in - NCic.Lambda (name, ty, aux m_subst subst ((name,NCic.Decl ty)::ctx) tl) - | [] -> NCicUntrusted.apply_subst subst ctx - (NCicSubstitution.lift (List.length ctx) t) - | _ -> assert false - in - aux (fun _ -> []) [] [] metasenv -;; - -let toposort metasenv = - let module T = HTopoSort.Make( - struct type t = int * NCic.conjecture let compare (i,_) (j,_) = i-j end) - in - let deps (_,(_,_,t)) = - List.filter (fun (j,_) -> - List.mem j (NCicUntrusted.metas_of_term [] [] t)) metasenv - in - T.topological_sort metasenv deps -;; - -let basic_eval_ncoercion (name,t,s,d,p,a) status = - let to_s = - NCicCoercion.look_for_coercion status [] [] [] (NCic.Implicit `Type) s - in - let from_d = - NCicCoercion.look_for_coercion status [] [] [] d (NCic.Implicit `Type) - in - let status = NCicCoercion.index_coercion status t s d a p in - let c = - List.find - (function (_,NCic.Appl (x::_),_,_) -> x = t | _ -> assert false) - (NCicCoercion.look_for_coercion status [] [] [] s d) - in - let composites = - let to_s_o_c = - product (fun (m1,t1,_,j) (mc,c,_,i) -> m1@mc,c,[i,t1],j,a) - to_s [c] - in - let c_o_from_d = - product (fun (mc,c,_,j) (m1,t1,ty,i) -> m1@mc,t1,[i,c],j,count_prod ty) - [c] from_d - in - let to_s_o_c_o_from_d = - product (fun (m1,t1,_,j) (m,t,upl,i,a)-> - m@m1,t,(i,t1)::upl,j,a) - to_s c_o_from_d - in - to_s_o_c @ c_o_from_d @ to_s_o_c_o_from_d - in - let composites = - HExtlib.filter_map - (fun (metasenv, bo, upl, p, arity) -> - try - let metasenv, subst = - List.fold_left - (fun (metasenv,subst) (a,b) -> - NCicUnification.unify status metasenv subst [] a b) - (metasenv,[]) upl - in - let bo = NCicUntrusted.apply_subst subst [] bo in - let metasenv = toposort metasenv in - let bo = close_in_context bo metasenv in - let pos = - match p with - | NCic.Meta (p,_) -> pos_in_list p (List.map fst metasenv) - | _ -> assert false - in - let ty = NCicTypeChecker.typeof ~metasenv:[] ~subst:[] [] bo in - let src,tgt = src_tgt_of_ty_cpos_arity ty pos arity in - prerr_endline ( - NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] bo ^ " : " ^ - NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] ty ^ " as " ^ - NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] src ^ " ===> " ^ - NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] tgt ^ - " cpos=" ^ string_of_int pos ^ " arity=" ^ string_of_int arity); - Some (bo,src,tgt,arity,pos) - with - | NCicTypeChecker.TypeCheckerFailure _ - | NCicUnification.UnificationFailure _ - | NCicUnification.Uncertain _ -> None - ) composites - in - List.fold_left - (fun st (t,s,d,a,p) -> NCicCoercion.index_coercion st t s d a p) - status composites +let record_index_obj = + let aux l + ~refresh_uri_in_universe + ~refresh_uri_in_term + = + basic_index_obj + (List.map + (fun ks,v -> List.map refresh_uri_in_term ks, refresh_uri_in_term v) + l) + in + NCicLibrary.Serializer.register#run "index_obj" + object(_ : 'a NCicLibrary.register_type) + method run = aux + end ;; -let inject_ncoercion = - let basic_eval_ncoercion x ~refresh_uri_in_universe ~refresh_uri_in_term = - basic_eval_ncoercion x +let index_obj_for_auto status (uri, height, _, _, kind) = + (*prerr_endline (string_of_int height);*) + let mk_item orig_ty spec = + let ty,_,_ = NCicMetaSubst.saturate ~delta:max_int [] [] [] orig_ty 0 in + let keys = + match ty with + | NCic.Const (NReference.Ref (_,NReference.Def h)) + | NCic.Appl (NCic.Const (NReference.Ref (_,NReference.Def h))::_) + when h > 0 -> + let ty',_,_= NCicMetaSubst.saturate ~delta:(h-1) [] [] [] orig_ty 0 in + [ty;ty'] + | _ -> [ty] + in + keys,NCic.Const(NReference.reference_of_spec uri spec) in - NRstatus.Serializer.register "ncoercion" basic_eval_ncoercion -;; + let data = + match kind with + | NCic.Fixpoint (ind,ifl,_) -> + HExtlib.list_mapi + (fun (_,_,rno,ty,_) i -> + if ind then mk_item ty (NReference.Fix (i,rno,height)) + else mk_item ty (NReference.CoFix height)) ifl + | NCic.Inductive (b,lno,itl,_) -> + HExtlib.list_mapi + (fun (_,_,ty,_) i -> mk_item ty (NReference.Ind (b,i,lno))) itl + @ + List.map (fun ((_,_,ty),i,j) -> mk_item ty (NReference.Con (i,j+1,lno))) + (List.flatten (HExtlib.list_mapi + (fun (_,_,_,cl) i -> HExtlib.list_mapi (fun x j-> x,i,j) cl) + itl)) + | NCic.Constant (_,_,Some _, ty, _) -> + [ mk_item ty (NReference.Def height) ] + | NCic.Constant (_,_,None, ty, _) -> + [ mk_item ty NReference.Decl ] + in + let data = HExtlib.filter_map + (fun (keys, t) -> + let keys = List.filter + (function + | (NCic.Meta _) + | (NCic.Appl (NCic.Meta _::_)) -> false + | _ -> true) + keys + in + if keys <> [] then + begin + HLog.debug ("Indexing:" ^ + NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t); + HLog.debug ("With keys:" ^ String.concat "\n" (List.map (fun t -> + NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t) keys)); + Some (keys,t) + end + else + begin + HLog.debug ("Not indexing:" ^ + NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t); + None + end) + data + in + let status = basic_index_obj data status in + let dump = record_index_obj data :: status#dump in + status#set_dump dump +;; -let src_tgt_cpos_arity_of_ty_id_src_tgt status ty id src tgt = - let status, src, cpos = - let rec aux cpos ctx = function - | NCic.Prod (name,ty,bo) -> - if name <> id then aux (cpos+1) ((name,NCic.Decl ty)::ctx) bo - else - (try - let metasenv,subst,status,src = - GrafiteDisambiguate.disambiguate_nterm - None status ctx [] [] ("",0,src) in - let src = NCicUntrusted.apply_subst subst [] src in - (* CHECK that the declared pattern matches the abstraction *) - let _ = NCicUnification.unify status metasenv subst ctx ty src in - status, src, cpos - with - | NCicUnification.UnificationFailure _ - | NCicUnification.Uncertain _ - | MultiPassDisambiguator.DisambiguationError _ -> - raise (GrafiteTypes.Command_error "bad source pattern")) - | _ -> assert false - in - aux 0 [] ty - in - let status, tgt, arity = - let metasenv,subst,status,tgt = - GrafiteDisambiguate.disambiguate_nterm - None status [] [] [] ("",0,tgt) in - let tgt = NCicUntrusted.apply_subst subst [] tgt in - (* CHECK che sia unificabile mancante *) - let rec count_prod = function - | NCic.Prod (_,_,x) -> 1 + count_prod x - | _ -> 0 - in - status, tgt, count_prod tgt - in - status, src, tgt, cpos, arity +let index_eq uri 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 eval_ncoercion status name t ty (id,src) tgt = - - let metasenv,subst,status,ty = - GrafiteDisambiguate.disambiguate_nterm None status [] [] [] ("",0,ty) in - assert (metasenv=[]); - let ty = NCicUntrusted.apply_subst subst [] ty in - let metasenv,subst,status,t = - GrafiteDisambiguate.disambiguate_nterm (Some ty) status [] [] [] ("",0,t) in - assert (metasenv=[]); - let t = NCicUntrusted.apply_subst subst [] t in - - let status, src, tgt, cpos, arity = - src_tgt_cpos_arity_of_ty_id_src_tgt status ty id src tgt +let record_index_eq = + let basic_index_eq uri + ~refresh_uri_in_universe + ~refresh_uri_in_term + = index_eq (NCicLibrary.refresh_uri uri) in - - let status = basic_eval_ncoercion (name,t,src,tgt,cpos,arity) status in - let dump = inject_ncoercion (name,t,src,tgt,cpos,arity)::status#dump in - let status = status#set_dump dump in - status,`New [] + NCicLibrary.Serializer.register#run "index_eq" + object(_ : 'a NCicLibrary.register_type) + method run = basic_index_eq + end ;; -let basic_eval_add_constraint (s,u1,u2) status = - NCicLibrary.add_constraint status s u1 u2 +let index_eq_for_auto status uri = + if NnAuto.is_a_fact_obj status uri then + let newstatus = index_eq 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) + 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 (s,u1,u2) + let basic_eval_add_constraint (u1,u2) ~refresh_uri_in_universe ~refresh_uri_in_term = let u1 = refresh_uri_in_universe u1 in let u2 = refresh_uri_in_universe u2 in - basic_eval_add_constraint (s,u1,u2) + basic_eval_add_constraint (u1,u2) in - NRstatus.Serializer.register "constraints" basic_eval_add_constraint + NCicLibrary.Serializer.register#run "constraints" + object(_:'a NCicLibrary.register_type) + method run = basic_eval_add_constraint + end ;; -let eval_add_constraint status s u1 u2 = - let status = basic_eval_add_constraint (s,u1,u2) status in - let dump = inject_constraint (s,u1,u2)::status#dump in +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 [] ;; @@ -839,7 +752,7 @@ 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 + | GrafiteAst.Branch _ -> NTactics.branch_tac ~force:false | GrafiteAst.Shift _ -> NTactics.shift_tac | GrafiteAst.Pos (_,l) -> NTactics.pos_tac l | GrafiteAst.Wildcard _ -> NTactics.wildcard_tac @@ -850,6 +763,8 @@ let eval_ng_tac tac = let rec aux f (text, prefix_len, tac) = match tac with | GrafiteAst.NApply (_loc, t) -> NTactics.apply_tac (text,prefix_len,t) + | GrafiteAst.NSmartApply (_loc, t) -> + NnAuto.smart_apply_tac (text,prefix_len,t) | GrafiteAst.NAssert (_loc, seqs) -> NTactics.assert_tac ((List.map @@ -862,9 +777,9 @@ let eval_ng_tac tac = (text,prefix_len,concl)) ) seqs) | GrafiteAst.NAuto (_loc, (l,a)) -> - NTactics.auto_tac + NAuto.auto_tac ~params:(List.map (fun x -> "",0,x) l,a) - | GrafiteAst.NBranch _ -> NTactics.branch_tac + | GrafiteAst.NBranch _ -> NTactics.branch_tac ~force:false | GrafiteAst.NCases (_loc, what, where) -> NTactics.cases_tac ~what:(text,prefix_len,what) @@ -873,6 +788,13 @@ let eval_ng_tac tac = | GrafiteAst.NChange (_loc, pat, ww) -> NTactics.change_tac ~where:(text,prefix_len,pat) ~with_what:(text,prefix_len,ww) + | GrafiteAst.NConstructor (_loc,num,args) -> + NTactics.constructor_tac + ?num ~args:(List.map (fun x -> text,prefix_len,x) args) + | 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.NDestruct _ -> NDestructTac.destruct_tac | GrafiteAst.NDot _ -> NTactics.dot_tac | GrafiteAst.NElim (_loc, what, where) -> NTactics.elim_tac @@ -883,11 +805,13 @@ let eval_ng_tac tac = NTactics.generalize_tac ~where:(text,prefix_len,where) | GrafiteAst.NId _ -> (fun x -> x) | GrafiteAst.NIntro (_loc,n) -> NTactics.intro_tac n + | GrafiteAst.NLApply (_loc, t) -> NTactics.lapply_tac (text,prefix_len,t) | GrafiteAst.NLetIn (_loc,where,what,name) -> NTactics.letin_tac ~where:(text,prefix_len,where) ~what:(text,prefix_len,what) name | GrafiteAst.NMerge _ -> NTactics.merge_tac | GrafiteAst.NPos (_,l) -> NTactics.pos_tac l + | GrafiteAst.NPosbyname (_,s) -> NTactics.case_tac s | GrafiteAst.NReduce (_loc, reduction, where) -> NTactics.reduce_tac ~reduction ~where:(text,prefix_len,where) | GrafiteAst.NRewrite (_loc,dir,what,where) -> @@ -918,11 +842,12 @@ let subst_metasenv_and_fix_names status = status#set_obj(u,h,NCicUntrusted.apply_subst_metasenv subst metasenv,subst,o) ;; + let rec eval_ncommand opts status (text,prefix_len,cmd) = match cmd with | GrafiteAst.UnificationHint (loc, t, n) -> eval_unification_hint status t n | GrafiteAst.NCoercion (loc, name, t, ty, source, target) -> - eval_ncoercion status name t ty source target + NCicCoercDeclaration.eval_ncoercion status name t ty source target | GrafiteAst.NQed loc -> if status#ng_mode <> `ProofMode then raise (GrafiteTypes.Command_error "Not in proof mode") @@ -955,31 +880,112 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = | _ -> obj_kind in let obj = uri,height,[],[],obj_kind in - let status = NCicLibrary.add_obj status obj in - prerr_endline (NCicPp.ppobj obj); - let boxml = NCicElim.mk_elims obj in + let old_status = status in + let status = NCicLibrary.add_obj status obj in + let status = index_obj_for_auto status obj in + let status = index_eq_for_auto status uri 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 + try + index_eq uri status + with _ -> prerr_endline "got an exception"; status + in *) +(* prerr_endline (NCicPp.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 - List.fold_left - (fun (status,uris) boxml -> - let status,nuris = - eval_ncommand opts status - ("",0,GrafiteAst.NObj (HExtlib.dummy_floc,boxml)) - in - match uris,nuris with - `New uris, `New nuris -> status,`New (nuris@uris) - | _ -> assert false - ) (status,`New [] (* uris *)) boxml + let status = status#set_ng_mode `CommandMode in + let status = LexiconSync.add_aliases_for_objs status (`New [uri]) in + let status,uris = + List.fold_left + (fun (status,uris) boxml -> + try + let nstatus,nuris = + eval_ncommand opts status + ("",0,GrafiteAst.NObj (HExtlib.dummy_floc,boxml)) + in + if nstatus#ng_mode <> `CommandMode then + begin + HLog.error "error in generating projection/eliminator"; + prerr_endline (NCicPp.ppobj nstatus#obj); + nstatus, uris + end + else + nstatus, concat_nuris uris nuris + with + | MultiPassDisambiguator.DisambiguationError _ + | NCicTypeChecker.TypeCheckerFailure _ -> + HLog.warn "error in generating projection/eliminator"; + status,uris + ) (status,`New [] (* uris *)) boxml in + let _,_,_,_,nobj = obj in + let status = match nobj with + NCic.Inductive (true,leftno,[it],_) -> + let _,ind_name,ty,cl = it in + List.fold_left + (fun status outsort -> + let status = status#set_ng_mode `ProofMode in + try + (let status,invobj = NInversion.mk_inverter + (ind_name ^ "_inv_" ^ (snd (NCicElim.ast_of_sort outsort))) + 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 [])) + (* 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 ())) + | _ -> status + in + let coercions = + match obj with + _,_,_,_,NCic.Inductive + (true,leftno,[_,_,_,[_,_,_]],(_,`Record fields)) + -> + HExtlib.filter_map + (fun (name,is_coercion,arity) -> + if is_coercion then Some(name,leftno,arity) else None) fields + | _ -> [] in + let status,uris = + List.fold_left + (fun (status,uris) (name,cpos,arity) -> + try + let metasenv,subst,status,t = + GrafiteDisambiguate.disambiguate_nterm None status [] [] [] + ("",0,CicNotationPt.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 + with MultiPassDisambiguator.DisambiguationError _-> + HLog.warn ("error in generating coercion: "^name); + status, uris) + (status,uris) coercions + in + status,uris + with + exn -> + NCicLibrary.time_travel old_status; + raise exn) | GrafiteAst.NCopy (log,tgt,src_uri, map) -> if status#ng_mode <> `CommandMode then raise (GrafiteTypes.Command_error "Not in command mode") @@ -1006,7 +1012,7 @@ let status = LexiconSync.add_aliases_for_objs status (`New [uri]) in 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 (NCicPp.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 @@ -1028,8 +1034,57 @@ let status = LexiconSync.add_aliases_for_objs status (`New [uri]) in [] -> eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) | _ -> status,`New []) - | GrafiteAst.NUnivConstraint (loc,strict,u1,u2) -> - eval_add_constraint status strict [false,u1] [false,u2] + | GrafiteAst.NDiscriminator (_,_) -> assert false (*(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 + | _ -> 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 _,_,menv,_,_ = obj in + (match menv with + [] -> eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) + | _ -> prerr_endline ("Discriminator: non empty metasenv"); + status, `New []) *) + | 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) + in + assert (metasenv = []); + let sort = NCicReduction.whd ~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 + 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 + let it = List.nth tys indtyno in + let status,obj = NInversion.mk_inverter name 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 @@ -1115,7 +1170,7 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status status in let status = - NRstatus.Serializer.require ~baseuri:(NUri.uri_of_string baseuri) + NCicLibrary.Serializer.require ~baseuri:(NUri.uri_of_string baseuri) status in let status = GrafiteTypes.add_moo_content @@ -1268,6 +1323,8 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status eval_ncommand opts status (text,prefix_len,cmd) | GrafiteAst.Macro (loc, macro) -> raise (Macro (loc,disambiguate_macro status (text,prefix_len,macro))) + | GrafiteAst.NMacro (loc, macro) -> + raise (NMacro (loc,macro)) } and eval_from_moo = {efm_go = fun status fname -> let ast_of_cmd cmd =