GrafiteAst.Coercion
(HExtlib.dummy_floc, CicUtil.term_of_uri uri, false, arity, saturations)
+let basic_eval_unification_hint (t,n) status =
+ NCicUnifHint.add_user_provided_hint status t n
+;;
+
+let inject_unification_hint =
+ let basic_eval_unification_hint (t,n) ~refresh_uri_in_term =
+ let t = refresh_uri_in_term t in basic_eval_unification_hint (t,n)
+ in
+ NRstatus.Serializer.register "unification_hints" basic_eval_unification_hint
+;;
+
let eval_unification_hint status t n =
- (* XXX no undo *)
- NCicUnifHint.add_user_provided_hint t n;
+ let estatus = GrafiteTypes.get_estatus status in
+ let metasenv,subst,estatus,t =
+ GrafiteDisambiguate.disambiguate_nterm None estatus [] [] [] ("",0,t) in
+ assert (metasenv=[]);
+ let t = NCicUntrusted.apply_subst subst [] t in
+ let status = GrafiteTypes.set_estatus estatus status in
+ let estatus =
+ basic_eval_unification_hint (t,n) (GrafiteTypes.get_estatus status) in
+ let dump = inject_unification_hint (t,n)::estatus#dump in
+ let estatus = estatus#set_dump dump in
+ let status = GrafiteTypes.set_estatus estatus status in
status,`Old []
;;
| GrafiteAst.Merge _ -> NTactics.merge_tac
;;
-let eval_ng_tac (text, prefix_len, tac) =
+let rec eval_ng_tac (text, prefix_len, tac) =
match tac with
| GrafiteAst.NApply (_loc, t) -> NTactics.apply_tac (text,prefix_len,t)
| GrafiteAst.NAssert (_loc, seqs) ->
) hyps,
(text,prefix_len,concl))
) seqs)
+ | GrafiteAst.NAuto (_loc, (l,a)) ->
+ NTactics.auto_tac
+ ~params:(List.map (fun x -> "",0,x) l,a)
+ | GrafiteAst.NBranch _ -> NTactics.branch_tac
| GrafiteAst.NCases (_loc, what, where) ->
NTactics.cases_tac
~what:(text,prefix_len,what)
| GrafiteAst.NChange (_loc, pat, ww) ->
NTactics.change_tac
~where:(text,prefix_len,pat) ~with_what:(text,prefix_len,ww)
+ | GrafiteAst.NDot _ -> NTactics.dot_tac
| GrafiteAst.NElim (_loc, what, where) ->
NTactics.elim_tac
~what:(text,prefix_len,what)
~where:(text,prefix_len,where)
- | GrafiteAst.NEval (_loc, where, reduction) ->
- NTactics.eval_tac ~reduction ~where:(text,prefix_len,where)
+ | GrafiteAst.NFocus (_,l) -> NTactics.focus_tac l
| GrafiteAst.NGeneralize (_loc, where) ->
NTactics.generalize_tac ~where:(text,prefix_len,where)
| GrafiteAst.NId _ -> (fun x -> x)
| 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.NReduce (_loc, reduction, where) ->
+ NTactics.reduce_tac ~reduction ~where:(text,prefix_len,where)
| GrafiteAst.NRewrite (_loc,dir,what,where) ->
NTactics.rewrite_tac ~dir ~what:(text,prefix_len,what)
~where:(text,prefix_len,where)
+ | GrafiteAst.NSemicolon _ -> fun x -> x
+ | GrafiteAst.NShift _ -> NTactics.shift_tac
+ | GrafiteAst.NSkip _ -> NTactics.skip_tac
+ | GrafiteAst.NUnfocus _ -> NTactics.unfocus_tac
+ | GrafiteAst.NWildcard _ -> NTactics.wildcard_tac
+ | GrafiteAst.NTry (_,tac) -> NTactics.try_tac
+ (eval_ng_tac (text, prefix_len, tac))
+ | GrafiteAst.NAssumption _ -> NTactics.assumption_tac
+;;
+
+let subst_metasenv_and_fix_names s =
+ let u,h,metasenv, subst,o = s.NTacStatus.istatus.NTacStatus.pstatus in
+ let o =
+ NCicUntrusted.map_obj_kind ~skip_body:true
+ (NCicUntrusted.apply_subst subst []) o
+ in
+ { s with NTacStatus.istatus =
+ { s.NTacStatus.istatus with NTacStatus.pstatus =
+ 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.NQed loc ->
+ (match status.GrafiteTypes.ng_status with
+ | GrafiteTypes.ProofMode
+ { NTacStatus.istatus =
+ { NTacStatus.pstatus = pstatus; estatus = estatus } } ->
+ let uri,height,menv,subst,obj_kind = pstatus in
+ if menv <> [] then
+ raise
+ (GrafiteTypes.Command_error"You can't Qed an incomplete theorem")
+ 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
+ (* fix the height inside the object *)
+ let rec fix () = function
+ | NCic.Const (NReference.Ref (u,spec)) when NUri.eq u uri ->
+ NCic.Const (NReference.reference_of_spec u
+ (match spec with
+ | NReference.Def _ -> NReference.Def height
+ | NReference.Fix (i,j,_) -> NReference.Fix(i,j,height)
+ | NReference.CoFix _ -> NReference.CoFix height
+ | NReference.Ind _ | NReference.Con _
+ | NReference.Decl as s -> s))
+ | t -> NCicUtils.map (fun _ () -> ()) () fix t
+ in
+ let obj_kind =
+ match obj_kind with
+ | NCic.Fixpoint _ ->
+ NCicUntrusted.map_obj_kind (fix ()) obj_kind
+ | _ -> obj_kind
+ in
+ let obj = uri,height,[],[],obj_kind in
+ NCicTypeChecker.typecheck_obj obj;
+ let estatus = NCicLibrary.add_obj estatus uri obj in
+ let objs = NCicElim.mk_elims obj in
+ let timestamp,uris_rev =
+ List.fold_left
+ (fun (estatus,uris_rev) (uri,_,_,_,_) as obj ->
+ NCicTypeChecker.typecheck_obj obj;
+ let estatus = NCicLibrary.add_obj estatus uri obj in
+ estatus,uri::uris_rev
+ ) (estatus,[]) objs in
+ let uris = uri::List.rev uris_rev in
+ GrafiteTypes.set_estatus estatus
+ {status with
+ GrafiteTypes.ng_status =
+ GrafiteTypes.CommandMode estatus },`New uris
+ | _ -> raise (GrafiteTypes.Command_error "Not in proof mode"))
+ | GrafiteAst.NObj (loc,obj) ->
+ let estatus =
+ match status.GrafiteTypes.ng_status with
+ | GrafiteTypes.ProofMode _ -> assert false
+ | GrafiteTypes.CommandMode es -> es
+ in
+ let estatus,obj =
+ GrafiteDisambiguate.disambiguate_nobj estatus
+ ~baseuri:(GrafiteTypes.get_baseuri status) (text,prefix_len,obj) in
+ let uri,height,nmenv,nsubst,nobj = obj in
+ let ninitial_stack = Continuationals.Stack.of_nmetasenv nmenv in
+ let status =
+ { status with
+ GrafiteTypes.ng_status =
+ GrafiteTypes.ProofMode
+ (subst_metasenv_and_fix_names
+ { NTacStatus.gstatus = ninitial_stack;
+ istatus = { NTacStatus.pstatus = obj; estatus = estatus}})
+ }
+ in
+ (match nmenv with
+ [] ->
+ eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc)
+ | _ -> status,`New [])
+ | GrafiteAst.NUnivConstraint (loc,strict,u1,u2) ->
+ NCicEnvironment.add_constraint strict [false,u1] [false,u2];
+ status, `New [u1;u2]
;;
let rec eval_command = {ec_go = fun ~disambiguate_command opts status
Inversion_principle.build_inverter ~add_obj status uri indty_uri params
in
res,`Old uris
- | GrafiteAst.UnificationHint (loc, t, n) ->
- eval_unification_hint status t n
| GrafiteAst.Default (loc, what, uris) as cmd ->
LibraryObjects.set_default what uris;
GrafiteTypes.add_moo_content [cmd] status,`Old []
| GrafiteAst.Drop loc -> raise Drop
- | GrafiteAst.Include (loc, baseuri) ->
+ | GrafiteAst.Include (loc, _, baseuri) ->
let moopath_rw, moopath_r =
LibraryMisc.obj_file_of_baseuri
~must_exist:false ~baseuri ~writable:true,
raise (IncludedFileNotCompiled (moopath_rw,baseuri))
in
let status = eval_from_moo.efm_go status moopath in
+ let estatus = GrafiteTypes.get_estatus status in
+ let estatus =
+ NRstatus.Serializer.require ~baseuri:(NUri.uri_of_string baseuri)
+ estatus in
+ let status = GrafiteTypes.set_estatus estatus status in
(* debug
let lt_uri = UriManager.uri_of_string "cic:/matita/nat/orders/lt.con" in
let nat_uri = UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind" in
let name = UriManager.name_of_uri uri in
let obj = Cic.Constant (name,Some (Lazy.force bo),ty,[],attrs) in
let status, lemmas = add_obj uri obj status in
- {status with
- GrafiteTypes.proof_status = GrafiteTypes.No_proof},
+ {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof},
(*CSC: I throw away the arities *)
`Old (uri::lemmas)
- | GrafiteAst.NQed loc ->
- (match status.GrafiteTypes.ng_status with
- | GrafiteTypes.ProofMode
- { NTacStatus.istatus =
- {NTacStatus.pstatus = pstatus; lstatus=lexicon_status} } ->
- let uri,height,menv,subst,obj = pstatus in
- if menv <> [] then
- raise
- (GrafiteTypes.Command_error"You can't Qed an incomplete theorem")
- else
- let obj =
-prerr_endline "CSC: here we should fix the height!!!";
- uri,height,[],[],
- NCicUntrusted.map_obj_kind (NCicUntrusted.apply_subst subst) obj
- in
- NCicLibrary.add_obj uri obj;
- {status with
- GrafiteTypes.ng_status =
- GrafiteTypes.CommandMode lexicon_status },`New [uri]
- | _ -> raise (GrafiteTypes.Command_error "Not in proof mode"))
| GrafiteAst.Relation (loc, id, a, aeq, refl, sym, trans) ->
Setoids.add_relation id a aeq refl sym trans;
status, `Old [] (*CSC: TO BE FIXED *)
| GrafiteAst.Set (loc, name, value) -> status, `Old []
(* GrafiteTypes.set_option status name value,[] *)
- | GrafiteAst.NObj (loc,obj) ->
- let lexicon_status =
- match status.GrafiteTypes.ng_status with
- | GrafiteTypes.ProofMode _ -> assert false
- | GrafiteTypes.CommandMode ls -> ls in
- let lexicon_status,obj =
- GrafiteDisambiguate.disambiguate_nobj lexicon_status
- ~baseuri:(GrafiteTypes.get_baseuri status) (text,prefix_len,obj) in
- let uri,height,nmenv,nsubst,nobj = obj in
- (match nmenv with
- [] ->
- (* CSC: cut&paste code from NQed *)
- let obj =
-prerr_endline "CSC: here we should fix the height!!!";
- uri,height,[],[],
- NCicUntrusted.map_obj_kind (NCicUntrusted.apply_subst nsubst) nobj
- in
- NCicLibrary.add_obj uri obj;
- {status with
- GrafiteTypes.ng_status=GrafiteTypes.CommandMode lexicon_status },
- `New [uri]
- | _ ->
- let ninitial_stack = Continuationals.Stack.of_nmetasenv nmenv in
- { status with
- GrafiteTypes.ng_status =
- GrafiteTypes.ProofMode
- { NTacStatus.gstatus = ninitial_stack;
- istatus = { NTacStatus.pstatus = obj; lstatus = lexicon_status}}
- },`New [])
| GrafiteAst.Obj (loc,obj) ->
let ext,name =
match obj with
| GrafiteAst.Tactic (_, None, punct) ->
eval_tactical status
(punctuation_tactical_of_ast (text,prefix_len,punct)),`Old []
- | GrafiteAst.NTactic (_(*loc*), tac, punct) ->
+ | GrafiteAst.NTactic (_(*loc*), tacl) ->
(match status.GrafiteTypes.ng_status with
| GrafiteTypes.CommandMode _ -> assert false
| GrafiteTypes.ProofMode nstatus ->
- let nstatus = eval_ng_tac (text,prefix_len,tac) nstatus in
- let nstatus = eval_ng_punct (text,prefix_len,punct) nstatus in
+ let nstatus =
+ List.fold_left
+ (fun nstatus tac ->
+ let nstatus = eval_ng_tac (text,prefix_len,tac) nstatus in
+ subst_metasenv_and_fix_names nstatus)
+ nstatus tacl
+ in
NTacStatus.pp_tac_status nstatus;
{ status with GrafiteTypes.ng_status= GrafiteTypes.ProofMode nstatus },
`New [])
(punctuation_tactical_of_ast (text,prefix_len,punct)),`Old []
| GrafiteAst.Command (_, cmd) ->
eval_command.ec_go ~disambiguate_command opts status (text,prefix_len,cmd)
+ | GrafiteAst.NCommand (_, cmd) ->
+ eval_ncommand opts status (text,prefix_len,cmd)
| GrafiteAst.Macro (loc, macro) ->
raise (Macro (loc,disambiguate_macro status (text,prefix_len,macro)))
projects / helm.git / blobdiff