let eval_unification_hint status t n =
let metasenv,subst,status,t =
- GrafiteDisambiguate.disambiguate_nterm status None [] [] [] ("",0,t) in
+ GrafiteDisambiguate.disambiguate_nterm status `XTSort [] [] [] ("",0,t) in
assert (metasenv=[]);
let t = NCicUntrusted.apply_subst status subst [] t in
let status = basic_eval_unification_hint (t,n) status in
NCicLibrary.dump_obj status (inject_unification_hint (t,n))
;;
-let basic_index_obj l status =
+let basic_index_obj l (status:#NCic.status) =
status#set_auto_cache
(List.fold_left
(fun t (ks,v) ->
NCicLibrary.dump_obj status (record_index_obj data)
;;
-let index_eq uri status =
+let basic_extract_obj obj status =
+ try
+ ignore (Helm_registry.get "extract_haskell");
+ let status,(msg,infos) = NCicExtraction.haskell_of_obj status obj in
+ prerr_endline msg;
+ status,infos
+ with
+ Helm_registry.Key_not_found _ -> status,NCicExtraction.empty_info
+ | exn -> prerr_endline ("EXTRACTION FAILURE: " ^ Printexc.to_string exn); assert false
+;;
+
+let basic_extract_ocaml_obj obj status =
+ try
+ let status = OcamlExtraction.print_ocaml_of_obj status obj in
+ let infos,status = status#get_info in
+ status,infos
+ with
+ exn -> prerr_endline ("EXTRACTION FAILURE: " ^ Printexc.to_string exn); assert false
+;;
+
+let inject_extract_obj =
+ let basic_extract_obj info
+ ~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference
+ ~alias_only status
+ =
+ let info= NCicExtraction.refresh_uri_in_info ~refresh_uri_in_reference info in
+ status#set_extraction_db
+ (NCicExtraction.register_infos status#extraction_db info)
+ in
+ GrafiteTypes.Serializer.register#run "extraction" basic_extract_obj
+;;
+
+let inject_extract_ocaml_obj =
+ let basic_extract_ocaml_obj info
+ ~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference
+ ~alias_only status
+ =
+ let info= OcamlExtractionTable.refresh_uri_in_info ~refresh_uri_in_reference ~refresh_uri:NCicLibrary.refresh_uri info in
+ status#set_ocaml_extraction_db
+ (OcamlExtractionTable.register_infos status#ocaml_extraction_db info)
+ in
+ GrafiteTypes.Serializer.register#run "ocaml_extraction" basic_extract_ocaml_obj
+;;
+
+let eval_extract_obj status obj =
+ let status,infos = basic_extract_obj obj status in
+ NCicLibrary.dump_obj status (inject_extract_obj infos)
+;;
+
+let eval_extract_ocaml_obj status obj =
+ let status,infos = basic_extract_ocaml_obj obj status in
+ NCicLibrary.dump_obj status (inject_extract_ocaml_obj infos)
+;;
+
+(*
+module EmptyC =
+ struct
+ let metasenv = []
+ let subst = []
+ let context = []
+ end
+*)
+
+let index_eq print uri (status:#NCic.status) =
let eq_status = status#eq_cache in
- let eq_status = NCicParamod.index_obj status eq_status uri in
- status#set_eq_cache eq_status
+ let eq_status,clause = NCicParamod.index_obj status eq_status uri in
+ if print then
+ ((*let module NCicBlob =
+ struct
+ include NCicBlob.NCicBlob(EmptyC)
+ let pp t = status#ppterm ~metasenv:[] ~subst:[] ~context:[] t
+ end in
+ let module Pp = Pp.Pp(NCicBlob) in*)
+ (match clause with
+ | Some (*clause*) (_,Terms.Equation (_,_,_,o),_,_) ->
+ HLog.debug ("Indexed with orientation: " ^ Pp.string_of_comparison o);
+ (*HLog.debug ("Indexed as:" ^ Pp.pp_unit_clause clause)*)
+ | _ -> HLog.debug "Not indexed (i.e. pruned)")) ;
+ status#set_eq_cache eq_status
;;
let record_index_eq =
let basic_index_eq uri
~refresh_uri_in_universe ~refresh_uri_in_term ~refresh_uri_in_reference
~alias_only status
- = if not alias_only then index_eq (NCicLibrary.refresh_uri uri) status else
- status
+ = if not alias_only then index_eq false (NCicLibrary.refresh_uri uri) status
+ else
+ status
in
GrafiteTypes.Serializer.register#run "index_eq" basic_index_eq
;;
let index_eq_for_auto status uri =
if NnAuto.is_a_fact_obj status uri then
- let newstatus = index_eq uri status in
+ let newstatus = index_eq true uri status in
if newstatus#eq_cache == status#eq_cache then status
else
((*prerr_endline ("recording " ^ (NUri.string_of_uri uri));*)
NCic.Inductive (ind,leftno,tys,attrs)
;;
+let extract_uris status uris =
+ List.fold_left
+ (fun status uri ->
+ let obj = NCicEnvironment.get_checked_obj status uri in
+ let status = eval_extract_obj status obj in
+ eval_extract_ocaml_obj status obj
+ ) status uris
+;;
let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) =
match cmd with
let baseuri = NUri.uri_of_string baseuri in
(* MATITA 1.0: keep WithoutPreferences? *)
let alias_only = (mode = GrafiteAst.OnlyPreferences) in
+ let status =
GrafiteTypes.Serializer.require
- ~alias_only ~baseuri ~fname:fullpath status
+ ~alias_only ~baseuri ~fname:fullpath status in
+ OcamlExtraction.print_open status
+ (NCicLibrary.get_transitively_included status)
| GrafiteAst.UnificationHint (loc, t, n) -> eval_unification_hint status t n
| GrafiteAst.NCoercion (loc, name, compose, None) ->
let status, t, ty, source, target =
let o_t = NotationPt.Ident (name,None) in
let metasenv,subst, status,t =
GrafiteDisambiguate.disambiguate_nterm
- status None [] [] [] ("",0,o_t) in
+ status `XTNone [] [] [] ("",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
+ | 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
+ | NCic.Sort _ as r -> NotationPt.NCic r (* FG: missing case *)
+ | _ -> 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 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)
+ | 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 cmd =
+ GrafiteAst.NCoercion (loc, name, compose, Some (t, ty, source, target))
+ in
+ eval_ncommand ~include_paths opts status (text,prefix_len,cmd)
| 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 status = extract_uris status composites in
let mode = GrafiteAst.WithPreferences in (* MATITA 1.0: fixme *)
let aliases = GrafiteDisambiguate.aliases_for_objs status composites in
eval_alias status (mode,aliases)
(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
let obj = uri,height,[],[],obj_kind in
let old_status = status in
let status = NCicLibrary.add_obj status obj in
+ let status = eval_extract_obj status obj in
+ let status = eval_extract_ocaml_obj status obj in
+ (try
let index_obj = index &&
match obj_kind with
NCic.Constant (_,_,_,_,(_,`Example,_))
if index_obj then
let status = index_obj_for_auto status obj in
(try index_eq_for_auto status uri
- with _ -> status)
+ with
+ Sys.Break as exn -> raise exn
+ | _ -> status)
else
status in
+ (* purge tinycals stack *)
+ let ninitial_stack = Continuationals.Stack.of_nmetasenv [] in
+ let status = status#set_stack ninitial_stack in
(*
try
index_eq uri status
in *)
(* prerr_endline (status#ppobj obj); *)
HLog.message ("New object: " ^ NUri.string_of_uri uri);
- (try
(*prerr_endline (status#ppobj obj);*)
let boxml = NCicElim.mk_elims status obj in
let boxml = boxml @ NCicElim.mk_projections status obj in
- let status = status#set_ng_mode `CommandMode in
+ let status = status#set_ng_mode `CommandMode in
let xxaliases = GrafiteDisambiguate.aliases_for_objs status [uri] in
let mode = GrafiteAst.WithPreferences in (* MATITA 1.0: fixme *)
let status = eval_alias status (mode,xxaliases) in
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
else
nstatus
with
- | MultiPassDisambiguator.DisambiguationError _
+ | MultiPassDisambiguator.DisambiguationError _ ->
+ HLog.warn "error in disambiguating projection/eliminator";
+ status
| NCicTypeChecker.TypeCheckerFailure _ ->
- (*HLog.warn "error in generating projection/eliminator";*)
+ HLog.warn "error in typechecking projection/eliminator";
status
) status boxml in
- let _,_,_,_,nobj = obj in
+ let _,_,_,_,nobj = obj in
+ (* attempting to generate an inversion principle on the maximum
+ * universe can take a long time to fail: this code removes maximal
+ * sorts from the universe list *)
+ let universes = NCicEnvironment.get_universes () in
+ let max_univ = List.fold_left max [] universes in
+ let universes =
+ List.filter (fun x -> NCicEnvironment.universe_lt x max_univ)
+ universes
+ 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
("",0,GrafiteAst.NQed (Stdpp.dummy_loc,false))
| _ -> status))
(* XXX *)
- with _ -> (*HLog.warn "error in generating inversion principle"; *)
+ with
+ Sys.Break as exn -> raise exn
+ | _ -> (*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) universes))) status itl
| _ -> status
in
let status = match nobj with
("",0,GrafiteAst.NQed(Stdpp.dummy_loc,false))
| _ -> status))
(* XXX *)
- with _ -> (*HLog.warn "error in generating discrimination principle"; *)
+ with
+ Sys.Break as exn -> raise exn
+ | _ -> (*HLog.warn "error in generating discrimination principle"; *)
let status = status#set_ng_mode `CommandMode in
status)
status' itl
(fun status (name,cpos,arity) ->
try
let metasenv,subst,status,t =
- GrafiteDisambiguate.disambiguate_nterm status None [] [] []
+ GrafiteDisambiguate.disambiguate_nterm status `XTNone [] [] []
("",0,NotationPt.Ident (name,None)) in
assert (metasenv = [] && subst = []);
let status, nuris =
basic_eval_and_record_ncoercion_from_t_cpos_arity
status (name,true,t,cpos,arity) in
let aliases = GrafiteDisambiguate.aliases_for_objs status nuris in
+ let status = extract_uris status nuris in
eval_alias status (mode,aliases)
with MultiPassDisambiguator.DisambiguationError _->
HLog.warn ("error in generating coercion: "^name);
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,false))
- | GrafiteAst.NObj (loc,obj) ->
+ | GrafiteAst.NObj (loc,obj,index) ->
if status#ng_mode <> `CommandMode then
raise (GrafiteTypes.Command_error "Not in command mode")
else
let status = status#set_ng_mode `ProofMode in
(match nmenv with
[] ->
- eval_ncommand ~include_paths opts status ("",0,GrafiteAst.NQed(Stdpp.dummy_loc,true))
+ eval_ncommand ~include_paths opts status
+ ("",0,GrafiteAst.NQed(Stdpp.dummy_loc,index))
| _ -> status)
| GrafiteAst.NDiscriminator (loc, indty) ->
if status#ng_mode <> `CommandMode then
else
let status = status#set_ng_mode `ProofMode in
let metasenv,subst,status,indty =
- GrafiteDisambiguate.disambiguate_nterm status None [] [] [] (text,prefix_len,indty) in
+ GrafiteDisambiguate.disambiguate_nterm status `XTNone [] [] [] (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 (_,ind_name,_,_ as it) = List.nth tys indtyno in
let status,obj =
- NDestructTac.mk_discriminator ~use_jmeq:true (ind_name ^ "_jmdiscr")
+ NDestructTac.mk_discriminator ~use_jmeq:true ~force:true (ind_name ^ "_jmdiscr")
it leftno status status#baseuri in
let _,_,menv,_,_ = obj in
(match menv with
let metasenv,subst,status,sort = match sort with
| None -> [],[],status,NCic.Sort NCic.Prop
| Some s ->
- GrafiteDisambiguate.disambiguate_nterm status None [] [] []
+ GrafiteDisambiguate.disambiguate_nterm status `XTSort [] [] []
(text,prefix_len,s)
in
assert (metasenv = []);
(status#ppterm ~metasenv ~subst ~context:[] sort))) in
let status = status#set_ng_mode `ProofMode in
let metasenv,subst,status,indty =
- GrafiteDisambiguate.disambiguate_nterm status None [] [] subst
+ GrafiteDisambiguate.disambiguate_nterm status `XTNone [] [] subst
(text,prefix_len,indty) in
let indtyno,(_,leftno,tys,_,_) =
match indty with
let status =
List.fold_left
(fun status tac ->
+ let time0 = Unix.gettimeofday () in
let status = eval_ng_tac (text,prefix_len,tac) status in
- subst_metasenv_and_fix_names status)
+ let time3 = Unix.gettimeofday () in
+ HLog.debug ("... eval_ng_tac done in " ^ string_of_float (time3 -. time0) ^ "s");
+ let status = subst_metasenv_and_fix_names status in
+ let time3 = Unix.gettimeofday () in
+ HLog.debug ("... subst_metasenv_and_fix_names done in " ^ string_of_float (time3 -. time0) ^ "s"); status)
status tacl
in
status