status, src, tgt, cpos, arity
;;
+let basic_eval_and_inject_ncoercion infos status =
+ let status = basic_eval_ncoercion infos status in
+ let dump = inject_ncoercion infos::status#dump in
+ status#set_dump dump
+;;
+
let eval_ncoercion status name t ty (id,src) tgt =
let metasenv,subst,status,ty =
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
+ src_tgt_cpos_arity_of_ty_id_src_tgt status ty id src tgt in
+ let status =
+ basic_eval_and_inject_ncoercion (name,t,src,tgt,cpos,arity) status
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 []
;;
(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 =
*)
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 ->
- try
- 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
- with
- NCicTypeChecker.TypeCheckerFailure msg
- when Lazy.force msg =
- "Sort elimination not allowed" ->
- status,uris
- ) (status,`New [] (* uris *)) boxml
+ let status,uris =
+ List.fold_left
+ (fun (status,uris) boxml ->
+ try
+ 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
+ with
+ NCicTypeChecker.TypeCheckerFailure msg
+ when Lazy.force msg =
+ "Sort elimination not allowed" ->
+ status,uris
+ ) (status,`New [] (* uris *)) boxml 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 =
+ List.fold_left
+ (fun status (name,cpos,arity) ->
+ let metasenv,subst,status,t =
+ GrafiteDisambiguate.disambiguate_nterm None status [] [] []
+ ("",0,CicNotationPt.Ident (name,None)) in
+ assert (metasenv = [] && subst = []);
+ let ty = NCicTypeChecker.typeof ~subst ~metasenv [] t in
+ let src,tgt = src_tgt_of_ty_cpos_arity ty cpos arity in
+ basic_eval_and_inject_ncoercion (name,t,src,tgt,cpos,arity)
+ status
+ ) status coercions
+ in
+ status,uris
with
exn ->
NCicLibrary.time_travel old_status;