~alias_only status
=
if not alias_only then
- let t = refresh_uri_in_term t in basic_eval_unification_hint (t,n) status
+ let t = refresh_uri_in_term (status :> NCic.status) t in
+ basic_eval_unification_hint (t,n) status
else
status
in
let metasenv,subst,status,t =
GrafiteDisambiguate.disambiguate_nterm status None [] [] [] ("",0,t) in
assert (metasenv=[]);
- let t = NCicUntrusted.apply_subst subst [] t in
+ 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))
;;
GrafiteParser.extend status l1
(fun env loc ->
NotationPt.AttributedTerm
- (`Loc loc,TermContentPres.instantiate_level2 env l2))
+ (`Loc loc,TermContentPres.instantiate_level2 status env l2))
;;
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_reference l1 in
+ ~refresh_uri_in_term:(refresh_uri_in_term (status:>NCic.status))
+ ~refresh_uri_in_reference l1 in
let l2 = NotationUtil.refresh_uri_in_term
- ~refresh_uri_in_term ~refresh_uri_in_reference l2
+ ~refresh_uri_in_term:(refresh_uri_in_term (status:>NCic.status))
+ ~refresh_uri_in_reference l2
in
basic_eval_input_notation (l1,l2) status
else
if not alias_only then
let l1 =
CicNotationParser.refresh_uri_in_checked_l1_pattern
- ~refresh_uri_in_term ~refresh_uri_in_reference l1 in
+ ~refresh_uri_in_term:(refresh_uri_in_term (status:>NCic.status))
+ ~refresh_uri_in_reference l1 in
let l2 = NotationUtil.refresh_uri_in_term
- ~refresh_uri_in_term ~refresh_uri_in_reference l2
+ ~refresh_uri_in_term:(refresh_uri_in_term (status:>NCic.status))
+ ~refresh_uri_in_reference l2
in
basic_eval_output_notation (l1,l2) status
else
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
if not alias_only then
basic_index_obj
(List.map
if keys <> [] then
begin
HLog.debug ("Indexing:" ^
- NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t);
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] t);
HLog.debug ("With keys:" ^ String.concat "\n" (List.map (fun t ->
- NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t) keys));
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] t) keys));
Some (keys,t)
end
else
begin
HLog.debug ("Not indexing:" ^
- NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t);
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] t);
None
end)
data
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 eq_status = NCicParamod.index_obj status eq_status uri in
+ status#set_eq_cache eq_status
;;
let record_index_eq =
let u,h,metasenv, subst,o = status#obj in
let o =
NCicUntrusted.map_obj_kind ~skip_body:true
- (NCicUntrusted.apply_subst subst []) o
+ (NCicUntrusted.apply_subst status subst []) o
in
- status#set_obj(u,h,NCicUntrusted.apply_subst_metasenv subst metasenv,subst,o)
+ status#set_obj(u,h,NCicUntrusted.apply_subst_metasenv status subst metasenv,subst,o)
;;
-let is_proof_irrelevant context ty =
+let is_proof_irrelevant status context ty =
match
- NCicReduction.whd ~subst:[] context
- (NCicTypeChecker.typeof ~subst:[] ~metasenv:[] context ty)
+ NCicReduction.whd status ~subst:[] context
+ (NCicTypeChecker.typeof status ~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
+let rec relevance_of status ?(context=[]) ty =
+ match NCicReduction.whd status ~subst:[] context ty with
NCic.Prod (n,s,t) ->
- not (is_proof_irrelevant context s) ::
- relevance_of ~context:((n,NCic.Decl s)::context) t
+ not (is_proof_irrelevant status context s) ::
+ relevance_of status ~context:((n,NCic.Decl s)::context) t
| _ -> []
;;
-let compute_relevance uri =
+let compute_relevance status uri =
function
NCic.Constant (_,name,bo,ty,attrs) ->
- let relevance = relevance_of ty in
+ let relevance = relevance_of status 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
+ let relevance = relevance_of status ty in
relevance,name,recno,ty,bo
) funs
in
let tys =
List.map
(fun (_,name,arity,cons) ->
- let relevance = relevance_of arity in
+ let relevance = relevance_of status 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
+ NCicTypeChecker.debruijn status uri tysno ~subst:[] [] ty in
+ let relevance = relevance_of status ~context dety in
relevance,name,ty
) cons
in
let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) =
match cmd with
| GrafiteAst.Include (loc, mode, fname) ->
- let _root, baseuri, _fullpath, _rrelpath =
+ let _root, baseuri, fullpath, _rrelpath =
Librarian.baseuri_of_script ~include_paths fname in
let baseuri = NUri.uri_of_string baseuri in
(* MATITA 1.0: keep WithoutPreferences? *)
let alias_only = (mode = GrafiteAst.OnlyPreferences) in
- GrafiteTypes.Serializer.require ~alias_only ~baseuri ~fname status
+ 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,None) 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 composites in
+ 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
else
let obj_kind =
NCicUntrusted.map_obj_kind
- (NCicUntrusted.apply_subst subst []) obj_kind in
- let height = NCicTypeChecker.height_of_obj_kind uri [] obj_kind in
+ (NCicUntrusted.apply_subst status subst []) obj_kind in
+ let height = NCicTypeChecker.height_of_obj_kind status uri [] obj_kind in
(* fix the height inside the object *)
let rec fix () = function
| NCic.Const (NReference.Ref (u,spec)) when NUri.eq u uri ->
(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 (fun _ () -> ()) () fix t
+ | t -> NCicUtils.map status (fun _ () -> ()) () fix t
in
let obj_kind =
match obj_kind with
NCicUntrusted.map_obj_kind (fix ()) obj_kind
| _ -> obj_kind
in
- let obj_kind = compute_relevance uri obj_kind in
+ let obj_kind = compute_relevance status uri obj_kind in
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
index_eq uri status
with _ -> prerr_endline "got an exception"; status
in *)
-(* prerr_endline (NCicPp.ppobj obj); *)
+(* prerr_endline (status#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
+ (*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 xxaliases = GrafiteDisambiguate.aliases_for_objs [uri] 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
let status =
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
) 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
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 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
+ (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 ->
+ HLog.warn (Printf.sprintf
+ "unable to generate leibniz discrimination principle (constructor %s too big)"
+ k);
+ let status = status#set_ng_mode `CommandMode in status
+ | _ -> (*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
+ (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"; *)
+ let status = status#set_ng_mode `CommandMode in
+ status)
+ status' itl
| _ -> status
in
let coercions =
let status, nuris =
NCicCoercDeclaration.
basic_eval_and_record_ncoercion_from_t_cpos_arity
- status (name,t,cpos,arity) in
- let aliases = GrafiteDisambiguate.aliases_for_objs nuris 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 _->
HLog.warn ("error in generating coercion: "^name);
raise (GrafiteTypes.Command_error "Not in command mode")
else
let tgt_uri_ext, old_ok =
- match NCicEnvironment.get_checked_obj src_uri with
+ match NCicEnvironment.get_checked_obj status src_uri with
| _,_,[],[], (NCic.Inductive _ as ok) -> ".ind", ok
| _,_,[],[], (NCic.Fixpoint _ as ok) -> ".con", ok
| _,_,[],[], (NCic.Constant _ as ok) -> ".con", ok
(try NCic.Const
(NReference.reference_of_spec (List.assoc u map)spec)
with Not_found -> t)
- | t -> NCicUtils.map (fun _ _ -> ()) () subst t
+ | t -> NCicUtils.map status (fun _ _ -> ()) () subst t
in
NCicUntrusted.map_obj_kind ~skip_body:false (subst ()) old_ok
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 (status#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
- 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
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")
(text,prefix_len,s)
in
assert (metasenv = []);
- let sort = NCicReduction.whd ~subst [] sort in
+ let sort = NCicReduction.whd status ~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
+ (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
let indtyno,(_,leftno,tys,_,_) =
match indty with
NCic.Const ((NReference.Ref (_,NReference.Ind (_,indtyno,_))) as r) ->
- indtyno, NCicEnvironment.get_checked_indtys r
+ indtyno, NCicEnvironment.get_checked_indtys status r
| _ ->
- prerr_endline ("engine: indty =" ^ NCicPp.ppterm ~metasenv:[]
+ prerr_endline ("engine: indty =" ^ status#ppterm ~metasenv:[]
~subst:[] ~context:[] indty);
assert false in
let it = List.nth tys indtyno in
(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]