MODULES = \
extlib \
xml \
+ hgdome \
registry \
syntax_extensions \
thread \
| term, None -> pp_term (* ~pp_parens:false *) term
| term, Some typ -> "(" ^ pp_term (* ~pp_parens:false *) term ^ ": " ^ pp_term typ ^ ")"
-let rec pp_term ?(pp_parens = true) t =
+let rec pp_term (status : #NCic.status) ?(pp_parens = true) t =
+ let pp_term = pp_term status in
let t_pp =
match t with
| Ast.AttributedTerm (attr, term) when debug_printing ->
sprintf "(i.e.%s)" (NReference.string_of_reference uri)
| _ -> ""))
(match typ with None -> "" | Some t -> sprintf " return %s" (pp_term t))
- (pp_patterns patterns)
+ (pp_patterns status patterns)
| Ast.Cast (t1, t2) -> sprintf "(%s: %s)" (pp_term ~pp_parens:true t1) (pp_term ~pp_parens:true t2)
| Ast.LetIn ((var,t2), t1, t3) ->
(* let t2 = match t2 with None -> Ast.Implicit | Some t -> t in *)
| Ast.Ident (name, Some []) | Ast.Ident (name, None)
| Ast.Uri (name, Some []) | Ast.Uri (name, None) -> name
| Ast.NRef nref -> NReference.string_of_reference nref
- | Ast.NCic cic -> NCicPp.ppterm ~metasenv:[] ~context:[] ~subst:[] cic
+ | Ast.NCic cic -> status#ppterm ~metasenv:[] ~context:[] ~subst:[] cic
| Ast.Ident (name, Some substs)
| Ast.Uri (name, Some substs) ->
- sprintf "%s \\subst [%s]" name (pp_substs substs)
+ sprintf "%s \\subst [%s]" name (pp_substs status substs)
| Ast.Implicit `Vector -> "…"
| Ast.Implicit `JustOne -> "?"
| Ast.Implicit (`Tagged name) -> "?"^name
| Ast.UserInput -> "%"
| Ast.Literal l -> pp_literal l
- | Ast.Layout l -> pp_layout l
- | Ast.Magic m -> pp_magic m
+ | Ast.Layout l -> pp_layout status l
+ | Ast.Magic m -> pp_magic status m
| Ast.Variable v -> pp_variable v
in
match pp_parens, t with
| true, Ast.Ident (_, None) -> t_pp
| _ -> sprintf "(%s)" t_pp
-and pp_subst (name, term) = sprintf "%s \\Assign %s" name (pp_term term)
-and pp_substs substs = String.concat "; " (List.map pp_subst substs)
+and pp_subst status (name, term) =
+ sprintf "%s \\Assign %s" name (pp_term status term)
+and pp_substs status substs = String.concat "; " (List.map (pp_subst status) substs)
-and pp_pattern =
+and pp_pattern status =
function
Ast.Pattern (head, href, vars), term ->
let head_pp =
| [] -> head_pp
| _ ->
sprintf "(%s %s)" head_pp
- (String.concat " " (List.map (pp_capture_variable pp_term) vars)))
- (pp_term term)
+ (String.concat " " (List.map (pp_capture_variable (pp_term status)) vars)))
+ (pp_term status term)
| Ast.Wildcard, term ->
- sprintf "_ \\Rightarrow %s" (pp_term term)
+ sprintf "_ \\Rightarrow %s" (pp_term status term)
-and pp_patterns patterns =
- sprintf "[%s]" (String.concat " | " (List.map pp_pattern patterns))
+and pp_patterns status patterns =
+ sprintf "[%s]" (String.concat " | " (List.map (pp_pattern status) patterns))
and pp_box_spec (kind, spacing, indent) =
let int_of_bool b = if b then 1 else 0 in
in
sprintf "%sBOX%d%d" kind_string (int_of_bool spacing) (int_of_bool indent)
-and pp_layout = function
+and pp_layout status =
+ let pp_term = pp_term status in
+ function
| Ast.Sub (t1, t2) -> sprintf "%s \\SUB %s" (pp_term t1) (pp_term t2)
| Ast.Sup (t1, t2) -> sprintf "%s \\SUP %s" (pp_term t1) (pp_term t2)
| Ast.Below (t1, t2) -> sprintf "%s \\BELOW %s" (pp_term t1) (pp_term t2)
(String.concat " " (List.map (fun (k,v) -> k^"="^v) l))
(String.concat " " (List.map pp_term terms))
-and pp_magic = function
+and pp_magic status =
+ let pp_term = pp_term status in
+ function
| Ast.List0 (t, sep_opt) ->
sprintf "list0 %s%s" (pp_term t) (pp_sep_opt sep_opt)
| Ast.List1 (t, sep_opt) ->
| Ast.FreshVar n -> "fresh " ^ n
let _pp_term = ref (pp_term ~pp_parens:false)
-let pp_term t = !_pp_term t
+let pp_term status t = !_pp_term (status :> NCic.status) t
let set_pp_term f = _pp_term := f
let pp_params pp_term = function
"record " ^ name ^ " " ^ pp_params pp_term params ^ ": " ^ pp_term ty ^
" \\def {" ^ pp_fields pp_term fields ^ "\n}"
-let rec pp_value = function
- | Env.TermValue t -> sprintf "$%s$" (pp_term t)
+let rec pp_value (status: #NCic.status) = function
+ | Env.TermValue t -> sprintf "$%s$" (pp_term status t)
| Env.StringValue (Env.Ident s) -> sprintf "\"%s\"" s
| Env.StringValue (Env.Var s) -> sprintf "\"${ident %s}\"" s
| Env.NumValue n -> n
- | Env.OptValue (Some v) -> "Some " ^ pp_value v
+ | Env.OptValue (Some v) -> "Some " ^ pp_value status v
| Env.OptValue None -> "None"
- | Env.ListValue l -> sprintf "[%s]" (String.concat "; " (List.map pp_value l))
+ | Env.ListValue l -> sprintf "[%s]" (String.concat "; " (List.map (pp_value status) l))
let rec pp_value_type =
function
| Env.OptType t -> "Maybe " ^ pp_value_type t
| Env.ListType l -> "List " ^ pp_value_type l
-let pp_env env =
+let pp_env status env =
String.concat "; "
(List.map
(fun (name, (ty, value)) ->
- sprintf "%s : %s = %s" name (pp_value_type ty) (pp_value value))
+ sprintf "%s : %s = %s" name (pp_value_type ty) (pp_value status value))
env)
let rec pp_cic_appl_pattern = function
* BoxPp.render_to_string(s)
*)
-val pp_term: NotationPt.term -> string
+val pp_term: #NCic.status -> NotationPt.term -> string
val pp_obj: ('term -> string) -> 'term NotationPt.obj -> string
-val pp_env: NotationEnv.t -> string
-val pp_value: NotationEnv.value -> string
+val pp_env: #NCic.status -> NotationEnv.t -> string
+val pp_value: #NCic.status -> NotationEnv.value -> string
val pp_value_type: NotationEnv.value_type -> string
val pp_pos: NotationPt.child_pos -> string
val pp_cic_appl_pattern: NotationPt.cic_appl_pattern -> string
(** non re-entrant change of pp_term function above *)
-val set_pp_term: (NotationPt.term -> string) -> unit
-
+val set_pp_term: (NCic.status -> NotationPt.term -> string) -> unit
boxPp.cmi: mpresentation.cmi cicNotationPres.cmi box.cmi
cicNotationPres.cmi: mpresentation.cmi box.cmi
content2pres.cmi: termContentPres.cmi cicNotationPres.cmi
-sequent2pres.cmi: termContentPres.cmi cicNotationPres.cmi
renderingAttrs.cmo: renderingAttrs.cmi
renderingAttrs.cmx: renderingAttrs.cmi
cicNotationLexer.cmo: cicNotationLexer.cmi
cicNotationPres.cmi box.cmi content2pres.cmi
content2pres.cmx: termContentPres.cmx renderingAttrs.cmx mpresentation.cmx \
cicNotationPres.cmx box.cmx content2pres.cmi
-sequent2pres.cmo: termContentPres.cmi mpresentation.cmi cicNotationPres.cmi \
- box.cmi sequent2pres.cmi
-sequent2pres.cmx: termContentPres.cmx mpresentation.cmx cicNotationPres.cmx \
- box.cmx sequent2pres.cmi
boxPp.cmi: mpresentation.cmi cicNotationPres.cmi box.cmi
cicNotationPres.cmi: mpresentation.cmi box.cmi
content2pres.cmi: termContentPres.cmi cicNotationPres.cmi
-sequent2pres.cmi: termContentPres.cmi cicNotationPres.cmi
renderingAttrs.cmo: renderingAttrs.cmi
renderingAttrs.cmx: renderingAttrs.cmi
cicNotationLexer.cmo: cicNotationLexer.cmi
cicNotationPres.cmi box.cmi content2pres.cmi
content2pres.cmx: termContentPres.cmx renderingAttrs.cmx mpresentation.cmx \
cicNotationPres.cmx box.cmx content2pres.cmi
-sequent2pres.cmo: termContentPres.cmi mpresentation.cmi cicNotationPres.cmi \
- box.cmi sequent2pres.cmi
-sequent2pres.cmx: termContentPres.cmx mpresentation.cmx cicNotationPres.cmx \
- box.cmx sequent2pres.cmi
boxPp.mli \
cicNotationPres.mli \
content2pres.mli \
- sequent2pres.mli \
$(NULL)
IMPLEMENTATION_FILES = \
$(INTERFACE_FILES:%.mli=%.ml)
let best_size, _ = best in
if size >= best_size then best else other
+(* merge_columns [ X1 ; X3 ] returns X1
+ X2 X4 X2 X3
+ X4 *)
let merge_columns sep cols =
let sep_len = String.length sep in
let indent = ref 0 in
snd (aux_mpres markup size)
let render_to_string ~map_unicode_to_tex choose_action size markup =
+ (* CSC: no information about hyperlinks yet *)
+ [],
String.concat "\n"
(render_to_strings ~map_unicode_to_tex choose_action size markup)
* http://helm.cs.unibo.it/
*)
- (**
+ (**
* @param map_unicode_to_tex if true converts multibye unicode sequences to
* TeX-like macros (when possible). Default: true
- * @return rows list of rows *)
-val render_to_strings:
- map_unicode_to_tex:bool ->
- (CicNotationPres.boxml_markup Mpresentation.mpres Box.box list -> CicNotationPres.boxml_markup) ->
- int -> CicNotationPres.markup -> string list
-
- (** helper function
- * @param map_unicode_to_tex as above
- * @return s, concatenation of the return value of render_to_strings above
- * with newlines as separators *)
+ * @param size
+ * @returns hyperlinks and text
+ *)
val render_to_string:
map_unicode_to_tex:bool ->
(CicNotationPres.boxml_markup Mpresentation.mpres Box.box list -> CicNotationPres.boxml_markup) ->
- int -> CicNotationPres.markup -> string
+ int -> CicNotationPres.markup ->
+ (int * int * string) list * string
| Ast.Magic m -> aux_magic m
| Ast.Variable v -> aux_variable v
| t ->
- prerr_endline (NotationPp.pp_term t);
+ prerr_endline (NotationPp.pp_term status t);
assert false
and aux_literal =
function
in
let rec find_arg name n = function
| [] ->
+ (* CSC: new NCicPp.status is the best I can do here
+ without changing the return type *)
Ast.fail loc (sprintf "Argument %s not found"
- (NotationPp.pp_term name))
+ (NotationPp.pp_term (new NCicPp.status) name))
| (l,_) :: tl ->
(match position_of name 0 l with
| None, len -> find_arg name (n + len) tl
method notation_parser_db: db
end
-class status ~keywords:kwds =
+class status0 ~keywords:kwds =
object
val db = { grammars = initial_grammars kwds; keywords = kwds; items = [] }
method notation_parser_db = db
= fun o -> {< db = o#notation_parser_db >}
end
+class virtual status ~keywords:kwds =
+ object
+ inherit NCic.status
+ inherit status0 kwds
+ end
+
let extend (status : #status) (CL1P (level1_pattern,precedence)) action =
(* move inside constructor XXX *)
let add1item status (level, level1_pattern, action) =
let keywords = NotationUtil.keywords_of_term level1_pattern @
status#notation_parser_db.keywords in
let items = current_item :: status#notation_parser_db.items in
- let status = status#set_notation_parser_status (new status ~keywords) in
+ let status = status#set_notation_parser_status (new status0 ~keywords) in
let status = status#set_notation_parser_db
{status#notation_parser_db with items = items} in
List.fold_left add1item status items
method notation_parser_db: db
end
-class status: keywords:string list ->
+class virtual status: keywords:string list ->
object('self)
+ inherit NCic.status
inherit g_status
method set_notation_parser_db: db -> 'self
method set_notation_parser_status: 'status. #g_status as 'status -> 'self
BoxPp.render_to_string (function x::_->x|_->assert false)
~map_unicode_to_tex:false 80 t);*)t)
-let render ~lookup_uri ?(prec=(-1)) =
+let render status ~lookup_uri ?(prec=(-1)) =
let module A = Ast in
let module P = Mpresentation in
(* let use_unicode = true in *)
| A.Magic _
| A.Variable _ -> assert false (* should have been instantiated *)
| t ->
- prerr_endline ("unexpected ast: " ^ NotationPp.pp_term t);
+ prerr_endline ("unexpected ast: " ^ NotationPp.pp_term status t);
assert false
and aux_attributes xmlattrs mathonly xref prec t =
let reset = ref false in
* @param ids_to_uris mapping id -> uri for hyperlinking
* @param prec precedence level *)
val render:
+ #NCic.status ->
lookup_uri:(Content.id -> string option) -> ?prec:int -> NotationPt.term ->
markup
let p_mo a b = Mpresentation.Mo(a,b)
let p_mrow a b = Mpresentation.Mrow(a,b)
let p_mphantom a b = Mpresentation.Mphantom(a,b)
+let b_ink a = Box.Ink a
let rec split n l =
if n = 0 then [],l
)],
Some (B.b_toggle [B.b_kw "proof";B.indent (proof2pres true term2pres p)])
-and proof2pres ?skip_initial_lambdas is_top_down term2pres p =
- let rec proof2pres ?skip_initial_lambdas_internal is_top_down p in_bu_conversion =
+and proof2pres0 term2pres ?skip_initial_lambdas_internal is_top_down p in_bu_conversion =
let indent =
let is_decl e =
(match e with
| Some t -> Some (term2pres t)) in
let body =
let presconclude =
- conclude2pres
+ conclude2pres term2pres
?skip_initial_lambdas_internal:
(match skip_initial_lambdas_internal with
Some (`Later s) -> Some (`Now s)
is_top_down p.Con.proof_name p.Con.proof_conclude indent
omit_conclusion in_bu_conversion in
let presacontext =
- acontext2pres
+ acontext2pres term2pres
(if p.Con.proof_conclude.Con.conclude_method = "BU_Conversion" then
is_top_down
else
presconclude indent
(p.Con.proof_conclude.Con.conclude_method = "BU_Conversion")
in
- context2pres
+ context2pres term2pres
(match skip_initial_lambdas_internal with
Some (`Now n) -> snd (HExtlib.split_nth n p.Con.proof_context)
| _ -> p.Con.proof_context)
- presacontext
+ ~continuation:presacontext
in
(*
let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ (if is_top_down then "(TD)" else "(NTD)") ^ "*)"); body; B.b_kw "(*>>*)"]) in
in
B.indent action
- and context2pres c continuation =
+and context2pres term2pres c ~continuation =
(* we generate a subtable for each context element, for selection
purposes
The table generated by the head-element does not have an xref;
let xref = get_xref ce in
B.V([Some "helm", "xref", xref ],
[B.H([Some "helm", "xref", "ce_"^xref],
- [ce2pres_in_proof_context_element ce]);
+ [ce2pres_in_proof_context_element term2pres ce]);
continuation])) tl continuation in
let hd_xref= get_xref hd in
B.V([],
[B.H([Some "helm", "xref", "ce_"^hd_xref],
- [ce2pres_in_proof_context_element hd]);
+ [ce2pres_in_proof_context_element term2pres hd]);
continuation'])
- and ce2pres_in_joint_context_element = function
+and ce2pres_in_joint_context_element term2pres = function
| `Inductive _ -> assert false (* TODO *)
- | (`Declaration _) as x -> ce2pres x
- | (`Hypothesis _) as x -> ce2pres x
- | (`Proof _) as x -> ce2pres x
- | (`Definition _) as x -> ce2pres x
+ | (`Declaration _)
+ | (`Hypothesis _)
+ | (`Proof _)
+ | (`Definition _) as x -> ce2pres term2pres x
- and ce2pres_in_proof_context_element = function
+and ce2pres_in_proof_context_element term2pres = function
| `Joint ho ->
- B.H ([],(List.map ce2pres_in_joint_context_element ho.Content.joint_defs))
- | (`Declaration _) as x -> ce2pres x
- | (`Hypothesis _) as x -> ce2pres x
- | (`Proof _) as x -> ce2pres x
- | (`Definition _) as x -> ce2pres x
+ B.H ([],(List.map (ce2pres_in_joint_context_element term2pres) ho.Content.joint_defs))
+ | (`Declaration _)
+ | (`Hypothesis _)
+ | (`Proof _)
+ | (`Definition _) as x -> ce2pres term2pres x
- and ce2pres =
+and ce2pres term2pres =
function
`Declaration d ->
let ty = term2pres d.Con.dec_type in
B.Text([],")");
B.Text([],".")])
| `Proof p ->
- proof2pres false p false
+ proof2pres0 term2pres false p false
| `Definition d ->
let term = term2pres d.Con.def_term in
B.H ([],
B.Text([],Utf8Macro.unicode_of_tex "\\def");
term])
- and acontext2pres is_top_down ac continuation indent in_bu_conversion =
+and acontext2pres term2pres is_top_down ac continuation indent in_bu_conversion =
let rec aux =
function
[] -> continuation
[] -> in_bu_conversion
| p::_ -> p.Con.proof_conclude.Con.conclude_method = "BU_Conversion"
in
- let hd = proof2pres is_top_down p in_bu_conversion in
+ let hd = proof2pres0 term2pres is_top_down p in_bu_conversion in
let hd = if indent then B.indent hd else hd in
B.V([Some "helm","xref",p.Con.proof_id],
[B.H([Some "helm","xref","ace_"^p.Con.proof_id],[hd]);
continuation])
in aux ac
- and conclude2pres ?skip_initial_lambdas_internal is_top_down name conclude indent omit_conclusion in_bu_conversion =
+and conclude2pres term2pres ?skip_initial_lambdas_internal is_top_down name conclude indent omit_conclusion in_bu_conversion =
let tconclude_body =
match conclude.Con.conclude_conclusion with
Some t (*when not omit_conclusion or
B.Text([],".")] else [B.Text([],".")])
else if conclude.Con.conclude_method = "FalseInd" then
(* false ind is in charge to add the conclusion *)
- falseind conclude
+ falseind term2pres conclude
else
let prequel =
if
else
[] in
let conclude_body =
- conclude_aux ?skip_initial_lambdas_internal is_top_down conclude in
+ conclude_aux term2pres ?skip_initial_lambdas_internal is_top_down conclude in
let ann_concl =
if conclude.Con.conclude_method = "Intros+LetTac"
|| conclude.Con.conclude_method = "ByInduction"
) @ if not in_bu_conversion then [B.Text([],".")] else [])
in
B.V ([], prequel @ [conclude_body; ann_concl])
- | _ -> conclude_aux ?skip_initial_lambdas_internal is_top_down conclude
+ | _ -> conclude_aux term2pres ?skip_initial_lambdas_internal is_top_down conclude
in
if indent then
B.indent (B.H ([Some "helm", "xref", conclude.Con.conclude_id],
else
B.H ([Some "helm", "xref", conclude.Con.conclude_id],[tconclude_body])
- and conclude_aux ?skip_initial_lambdas_internal is_top_down conclude =
+and conclude_aux term2pres ?skip_initial_lambdas_internal is_top_down conclude =
if conclude.Con.conclude_method = "TD_Conversion" then
let expected =
(match conclude.Con.conclude_conclusion with
([],
[make_concl "we need to prove" expected;
B.H ([],[make_concl "or equivalently" synth; B.Text([],".")]);
- proof2pres true subproof false])
+ proof2pres0 term2pres true subproof false])
else if conclude.Con.conclude_method = "BU_Conversion" then
assert false
else if conclude.Con.conclude_method = "Exact" then
[Con.ArgProof p] ->
(match conclude.Con.conclude_args with
[Con.ArgProof p] ->
- proof2pres ?skip_initial_lambdas_internal true p false
+ proof2pres0 term2pres ?skip_initial_lambdas_internal true p false
| _ -> assert false)
| _ -> assert false)
(* OLD CODE
B.V
([None,"align","baseline 1"; None,"equalrows","false";
None,"columnalign","left"],
- [B.H([],[B.Object([],proof2pres p false)]);
+ [B.H([],[B.Object([],proof2pres p term2pres false)]);
B.H([],[B.Object([],
(make_concl "we proved 1" conclusion))])]);
| _ -> assert false)
*)
else if (conclude.Con.conclude_method = "Case") then
- case conclude
+ case term2pres conclude
else if (conclude.Con.conclude_method = "ByInduction") then
- byinduction conclude
+ byinduction term2pres conclude
else if (conclude.Con.conclude_method = "Exists") then
- exists conclude
+ exists term2pres conclude
else if (conclude.Con.conclude_method = "AndInd") then
- andind conclude
+ andind term2pres conclude
else if (conclude.Con.conclude_method = "FalseInd") then
- falseind conclude
+ falseind term2pres conclude
else if conclude.Con.conclude_method = "RewriteLR"
|| conclude.Con.conclude_method = "RewriteRL" then
let justif1,justif2 =
else
B.V ([], [
B.b_kw ("Apply method" ^ conclude.Con.conclude_method ^ " to");
- (B.indent (B.V ([], args2pres conclude.Con.conclude_args)))])
+ (B.indent (B.V ([], args2pres term2pres conclude.Con.conclude_args)))])
- and args2pres l = List.map arg2pres l
+and args2pres term2pres l = List.map (arg2pres term2pres) l
- and arg2pres =
+and arg2pres term2pres =
function
Con.Aux n -> B.b_kw ("aux " ^ n)
| Con.Premise prem -> B.b_kw "premise"
| Con.Lemma lemma -> B.b_kw "lemma"
| Con.Term (_,t) -> term2pres t
- | Con.ArgProof p -> proof2pres true p false
+ | Con.ArgProof p -> proof2pres0 term2pres true p false
| Con.ArgMethod s -> B.b_kw "method"
- and case conclude =
+and case term2pres conclude =
let proof_conclusion =
(match conclude.Con.conclude_conclusion with
None -> B.b_kw "No conclusion???"
(make_concl "we proceed by cases on" case_arg) in
let to_prove =
(make_concl "to prove" proof_conclusion) in
- B.V ([], case_on::to_prove::(make_cases args_for_cases))
+ B.V ([], case_on::to_prove::(make_cases term2pres args_for_cases))
- and byinduction conclude =
+and byinduction term2pres conclude =
let proof_conclusion =
(match conclude.Con.conclude_conclusion with
None -> B.b_kw "No conclusion???"
(make_concl "we proceed by induction on" arg) in
let to_prove =
B.H ([], [make_concl "to prove" proof_conclusion ; B.Text([],".")]) in
- B.V ([], induction_on::to_prove::(make_cases args_for_cases))
+ B.V ([], induction_on::to_prove::(make_cases term2pres args_for_cases))
- and make_cases l = List.map make_case l
+and make_cases term2pres l = List.map (make_case term2pres) l
- and make_case =
+and make_case term2pres =
function
Con.ArgProof p ->
let name =
let hyps = List.map make_hyp indhyps in
text::hyps) in
let body =
- conclude2pres true p.Con.proof_name p.Con.proof_conclude true true false in
+ conclude2pres term2pres true p.Con.proof_name p.Con.proof_conclude true true false in
let presacontext =
let acontext_id =
match p.Con.proof_apply_context with
in
B.Action([None,"type","toggle"],
[ B.indent (add_xref acontext_id (B.b_kw "Proof"));
- acontext2pres
+ acontext2pres term2pres
(p.Con.proof_conclude.Con.conclude_method = "BU_Conversion")
p.Con.proof_apply_context body true
(p.Con.proof_conclude.Con.conclude_method = "BU_Conversion")
B.V ([], pattern::induction_hypothesis@[B.H ([],[asubconcl;B.Text([],".")]);presacontext])
| _ -> assert false
- and falseind conclude =
+and falseind term2pres conclude =
let proof_conclusion =
(match conclude.Con.conclude_conclusion with
None -> B.b_kw "No conclusion???"
| _ -> assert false) in
make_row arg proof_conclusion
- and andind conclude =
+and andind term2pres conclude =
let proof,case_arg =
(match conclude.Con.conclude_args with
[Con.Aux(n);_;Con.ArgProof proof;case_arg] -> proof,case_arg
B.skip;
term2pres hyp2.Con.dec_type]) in
let body =
- conclude2pres false proof.Con.proof_name proof.Con.proof_conclude
+ conclude2pres term2pres false proof.Con.proof_name proof.Con.proof_conclude
false true false in
let presacontext =
- acontext2pres false proof.Con.proof_apply_context body false false
+ acontext2pres term2pres false proof.Con.proof_apply_context body false false
in
B.V
([],
presacontext]);
| _ -> assert false
- and exists conclude =
+and exists term2pres conclude =
let proof =
(match conclude.Con.conclude_args with
[Con.Aux(n);_;Con.ArgProof proof;_] -> proof
B.skip;
term2pres hyp.Con.dec_type]) in
let body =
- conclude2pres false proof.Con.proof_name proof.Con.proof_conclude
+ conclude2pres term2pres false proof.Con.proof_name proof.Con.proof_conclude
false true false in
let presacontext =
- acontext2pres false proof.Con.proof_apply_context body false false
+ acontext2pres term2pres false proof.Con.proof_apply_context body false false
in
B.V
([],
presacontext]);
| _ -> assert false
- in
- proof2pres
- ?skip_initial_lambdas_internal:
- (match skip_initial_lambdas with
- None -> Some (`Later 0) (* we already printed theorem: *)
- | Some n -> Some (`Later n))
- is_top_down p false
+and proof2pres ?skip_initial_lambdas is_top_down term2pres p =
+ proof2pres0 term2pres
+ ?skip_initial_lambdas_internal:
+ (match skip_initial_lambdas with
+ None -> Some (`Later 0) (* we already printed theorem: *)
+ | Some n -> Some (`Later n))
+ is_top_down p false
exception ToDo
(List.map (njoint_def2pres term2pres) defs)))
;;
-let ncontent2pres0
+let nobj2pres0
?skip_initial_lambdas ?(skip_thm_and_qed=false) term2pres
(id,metasenv,obj : NotationPt.term Content.cobj)
=
match obj with
| `Def (Content.Const, thesis, `Proof p) ->
let name = get_name p.Content.proof_name in
- let proof = proof2pres true term2pres ?skip_initial_lambdas p in
+ let proof = proof2pres true ?skip_initial_lambdas term2pres p in
if skip_thm_and_qed then
proof
else
joint.Content.joint_kind joint.Content.joint_defs]
| _ -> raise ToDo
-let ncontent2pres status ?skip_initial_lambdas ?skip_thm_and_qed ~ids_to_nrefs =
+let nterm2pres status ~ids_to_nrefs =
let lookup_uri id =
try
let nref = Hashtbl.find ids_to_nrefs id in
Some (NReference.string_of_reference nref)
with Not_found -> None
in
- ncontent2pres0 ?skip_initial_lambdas ?skip_thm_and_qed
- (fun ?(prec=90) ast ->
- CicNotationPres.box_of_mpres
- (CicNotationPres.render ~lookup_uri ~prec
- (TermContentPres.pp_ast status ast)))
+ fun ?(prec=90) ast ->
+ CicNotationPres.box_of_mpres
+ (CicNotationPres.render status ~lookup_uri ~prec
+ (TermContentPres.pp_ast status ast))
+
+let nobj2pres status ~ids_to_nrefs =
+ nobj2pres0 ?skip_initial_lambdas:None ?skip_thm_and_qed:None
+ (nterm2pres status ~ids_to_nrefs)
+
+let nconjlist2pres0 term2pres context =
+ let rec aux accum =
+ function
+ [] -> accum
+ | None::tl -> aux accum tl
+ | (Some (`Declaration d))::tl ->
+ let
+ { Con.dec_name = dec_name ;
+ Con.dec_id = dec_id ;
+ Con.dec_type = ty } = d in
+ let r =
+ Box.b_h [Some "helm", "xref", dec_id]
+ [ Box.b_object (p_mi []
+ (match dec_name with
+ None -> "_"
+ | Some n -> n)) ;
+ Box.b_space; Box.b_text [] ":"; Box.b_space;
+ term2pres ty] in
+ aux (r::accum) tl
+ | (Some (`Definition d))::tl ->
+ let
+ { Con.def_name = def_name ;
+ Con.def_id = def_id ;
+ Con.def_term = bo } = d in
+ let r =
+ Box.b_h [Some "helm", "xref", def_id]
+ [ Box.b_object (p_mi []
+ (match def_name with
+ None -> "_"
+ | Some n -> n)) ; Box.b_space ;
+ Box.b_text [] (Utf8Macro.unicode_of_tex "\\def") ;
+ Box.b_space; term2pres bo] in
+ aux (r::accum) tl
+ | _::_ -> assert false
+ in
+ if context <> [] then [Box.b_v [] (aux [] context)] else []
+
+let sequent2pres0 term2pres (_,_,context,ty) =
+ let pres_context = nconjlist2pres0 term2pres context in
+ let pres_goal = term2pres ty in
+ (Box.b_h [] [
+ Box.b_space;
+ (Box.b_v []
+ (Box.b_space ::
+ pres_context @ [
+ b_ink [None,"width","4cm"; None,"height","2px"]; (* sequent line *)
+ Box.b_space;
+ pres_goal]))])
+
+let ncontext2pres status ~ids_to_nrefs ctx =
+ let ctx = HExtlib.filter_map (fun x -> x) ctx in
+ context2pres (nterm2pres status ~ids_to_nrefs) ~continuation:Box.smallskip
+ (ctx:>NotationPt.term Con.in_proof_context_element list)
+
+let nsequent2pres status ~ids_to_nrefs =
+ sequent2pres0 (nterm2pres status ~ids_to_nrefs)
(* *)
(**************************************************************************)
-val ncontent2pres:
+val nterm2pres:
#TermContentPres.status ->
- ?skip_initial_lambdas:int -> ?skip_thm_and_qed:bool ->
ids_to_nrefs:(Content.id, NReference.reference) Hashtbl.t ->
- NotationPt.term Content.cobj ->
- CicNotationPres.boxml_markup
+ ?prec:int -> NotationPt.term -> CicNotationPres.boxml_markup
+
+val ncontext2pres:
+ #TermContentPres.status ->
+ ids_to_nrefs:(Content.id, NReference.reference) Hashtbl.t ->
+ NotationPt.term Content.context -> CicNotationPres.boxml_markup
+
+val nobj2pres:
+ #TermContentPres.status ->
+ ids_to_nrefs:(Content.id, NReference.reference) Hashtbl.t ->
+ NotationPt.term Content.cobj -> CicNotationPres.boxml_markup
+
+val nsequent2pres :
+ #TermContentPres.status ->
+ ids_to_nrefs:(Content.id, NReference.reference) Hashtbl.t ->
+ NotationPt.term Content.conjecture -> CicNotationPres.boxml_markup
| _ -> PatternMatcher.Constructor
let tag_of_pattern = get_tag
let tag_of_term t = get_tag t
- let string_of_term = NotationPp.pp_term
- let string_of_pattern = NotationPp.pp_term
+
+ (* Debugging only *)
+ (*CSC: new NCicPp.status is the best I can do now *)
+ let string_of_term = NotationPp.pp_term (new NCicPp.status)
+ let string_of_pattern = NotationPp.pp_term (new NCicPp.status)
end
module M = PatternMatcher.Matcher (Pattern21)
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 19/11/2003 *)
-(* *)
-(***************************************************************************)
-
-(* $Id$ *)
-
-let p_mtr a b = Mpresentation.Mtr(a,b)
-let p_mtd a b = Mpresentation.Mtd(a,b)
-let p_mtable a b = Mpresentation.Mtable(a,b)
-let p_mtext a b = Mpresentation.Mtext(a,b)
-let p_mi a b = Mpresentation.Mi(a,b)
-let p_mo a b = Mpresentation.Mo(a,b)
-let p_mrow a b = Mpresentation.Mrow(a,b)
-let p_mphantom a b = Mpresentation.Mphantom(a,b)
-let b_ink a = Box.Ink a
-
-module K = Content
-module P = Mpresentation
-
-let sequent2pres0 term2pres (_,_,context,ty) =
- let context2pres context =
- let rec aux accum =
- function
- [] -> accum
- | None::tl -> aux accum tl
- | (Some (`Declaration d))::tl ->
- let
- { K.dec_name = dec_name ;
- K.dec_id = dec_id ;
- K.dec_type = ty } = d in
- let r =
- Box.b_h [Some "helm", "xref", dec_id]
- [ Box.b_object (p_mi []
- (match dec_name with
- None -> "_"
- | Some n -> n)) ;
- Box.b_space; Box.b_text [] ":"; Box.b_space;
- term2pres ty] in
- aux (r::accum) tl
- | (Some (`Definition d))::tl ->
- let
- { K.def_name = def_name ;
- K.def_id = def_id ;
- K.def_term = bo } = d in
- let r =
- Box.b_h [Some "helm", "xref", def_id]
- [ Box.b_object (p_mi []
- (match def_name with
- None -> "_"
- | Some n -> n)) ; Box.b_space ;
- Box.b_text [] (Utf8Macro.unicode_of_tex "\\def") ;
- Box.b_space; term2pres bo] in
- aux (r::accum) tl
- | _::_ -> assert false in
- aux [] context in
- let pres_context =
- if context <> [] then [Box.b_v [] (context2pres context)] else [] in
- let pres_goal = term2pres ty in
- (Box.b_h [] [
- Box.b_space;
- (Box.b_v []
- (Box.b_space ::
- pres_context @ [
- b_ink [None,"width","4cm"; None,"height","2px"]; (* sequent line *)
- Box.b_space;
- pres_goal]))])
-
-let nsequent2pres status ~ids_to_nrefs ~subst =
- let lookup_uri id =
- try
- let nref = Hashtbl.find ids_to_nrefs id in
- Some (NReference.string_of_reference nref)
- with Not_found -> None
- in
- sequent2pres0
- (fun ast ->
- CicNotationPres.box_of_mpres
- (CicNotationPres.render ~lookup_uri
- (TermContentPres.pp_ast status ast)))
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 19/11/2003 *)
-(* *)
-(***************************************************************************)
-
-val nsequent2pres :
- #TermContentPres.status ->
- ids_to_nrefs:(Content.id, NReference.reference) Hashtbl.t ->
- subst:NCic.substitution -> NotationPt.term Content.conjecture ->
- CicNotationPres.boxml_markup
~sep:[space] (List.map (fun x -> [f x]) l)
;;
-let pp_ast0 t k =
+let pp_ast0 status t k =
let rec aux =
function
| Ast.Appl ts ->
and special_k = function
| Ast.AttributedTerm (attrs, t) -> Ast.AttributedTerm (attrs, k t)
| t ->
- prerr_endline ("unexpected special: " ^ NotationPp.pp_term t);
+ prerr_endline ("unexpected special: " ^ NotationPp.pp_term status t);
assert false
in
aux t
method content_pres_db: db
end
-class status =
+class virtual status =
object
+ inherit NCic.status
val content_pres_db = initial_db
method content_pres_db = content_pres_db
method set_content_pres_db v = {< content_pres_db = v >}
let rec pp_value = function
| NotationEnv.NumValue _ as v -> v
| NotationEnv.StringValue _ as v -> v
-(* | NotationEnv.TermValue t when t == term -> NotationEnv.TermValue (pp_ast0 t pp_ast1) *)
+(* | NotationEnv.TermValue t when t == term -> NotationEnv.TermValue (pp_ast0 status t pp_ast1) *)
| NotationEnv.TermValue t -> NotationEnv.TermValue (pp_ast1 status t)
| NotationEnv.OptValue None as v -> v
| NotationEnv.OptValue (Some v) ->
Ast.AttributedTerm (attrs, pp_ast1 status term')
| _ ->
(match get_compiled21 status term with
- | None -> pp_ast0 term (pp_ast1 status)
+ | None -> pp_ast0 status term (pp_ast1 status)
| Some (env, ctors, pid) ->
let idrefs =
List.flatten (List.map NotationUtil.get_idrefs ctors)
let pp_ast status ast =
debug_print (lazy "pp_ast <-");
let ast' = pp_ast1 status ast in
- debug_print (lazy ("pp_ast -> " ^ NotationPp.pp_term ast'));
+ debug_print (lazy ("pp_ast -> " ^ NotationPp.pp_term status ast'));
ast'
let fill_pos_info l1_pattern = l1_pattern
in
aux [] env
-let instantiate_level2 env term =
+let instantiate_level2 status env term =
(* prerr_endline ("istanzio: " ^ NotationPp.pp_term term); *)
let fresh_env = ref [] in
let lookup_fresh_name n =
| _ ->
prerr_endline (sprintf
"lookup of %s in env %s did not return an optional value"
- name (NotationPp.pp_env env));
+ name (NotationPp.pp_env status env));
assert false))
| Ast.Fold (`Left, base_pattern, names, rec_pattern) ->
let acc_name = List.hd names in (* names can't be empty, cfr. parser *)
method content_pres_db: db
end
-class status :
+class virtual status :
object ('self)
+ inherit NCic.status
method content_pres_db: db
method set_content_pres_db: db -> 'self
method set_content_pres_status: #g_status -> 'self
(** fills a term pattern instantiating variable magics *)
val instantiate_level2:
- NotationEnv.t -> NotationPt.term ->
- NotationPt.term
+ #NCic.status -> NotationEnv.t -> NotationPt.term -> NotationPt.term
let tactic_terminator = tactical_terminator
let command_terminator = tactical_terminator
-let pp_tactic_pattern ~map_unicode_to_tex (what, hyp, goal) =
+let pp_tactic_pattern status ~map_unicode_to_tex (what, hyp, goal) =
if what = None && hyp = [] && goal = None then "" else
let what_text =
match what with
| None -> ""
- | Some t -> Printf.sprintf "in match (%s) " (NotationPp.pp_term t) in
+ | Some t -> Printf.sprintf "in match (%s) " (NotationPp.pp_term status t) in
let hyp_text =
String.concat " "
(List.map (fun (name, p) -> Printf.sprintf "%s:(%s)" name
- (NotationPp.pp_term p)) hyp) in
+ (NotationPp.pp_term status p)) hyp) in
let goal_text =
match goal with
| None -> ""
| Some t ->
let vdash = if map_unicode_to_tex then "\\vdash" else "⊢" in
- Printf.sprintf "%s (%s)" vdash (NotationPp.pp_term t)
+ Printf.sprintf "%s (%s)" vdash (NotationPp.pp_term status t)
in
Printf.sprintf "%sin %s%s" what_text hyp_text goal_text
-let rec pp_ntactic ~map_unicode_to_tex =
+let rec pp_ntactic status ~map_unicode_to_tex =
let pp_tactic_pattern = pp_tactic_pattern ~map_unicode_to_tex in
function
- | NApply (_,t) -> "napply " ^ NotationPp.pp_term t
+ | NApply (_,t) -> "napply " ^ NotationPp.pp_term status t
| NSmartApply (_,t) -> "fixme"
| NAuto (_,(None,flgs)) ->
"nautobatch" ^
String.concat " " (List.map (fun a,b -> a ^ "=" ^ b) flgs)
| NAuto (_,(Some l,flgs)) ->
"nautobatch" ^ " by " ^
- (String.concat "," (List.map NotationPp.pp_term l)) ^
+ (String.concat "," (List.map (NotationPp.pp_term status) l)) ^
String.concat " " (List.map (fun a,b -> a ^ "=" ^ b) flgs)
- | NCases (_,what,where) -> "ncases " ^ NotationPp.pp_term what ^
+ | NCases (_,what,where) -> "ncases " ^ NotationPp.pp_term status what ^
"...to be implemented..." ^ " " ^ "...to be implemented..."
| NConstructor (_,None,l) -> "@ " ^
- String.concat " " (List.map NotationPp.pp_term l)
+ String.concat " " (List.map (NotationPp.pp_term status) l)
| NConstructor (_,Some x,l) -> "@" ^ string_of_int x ^ " " ^
- String.concat " " (List.map NotationPp.pp_term l)
+ String.concat " " (List.map (NotationPp.pp_term status) l)
| NCase1 (_,n) -> "*" ^ n ^ ":"
| NChange (_,what,wwhat) -> "nchange " ^ "...to be implemented..." ^
- " with " ^ NotationPp.pp_term wwhat
- | NCut (_,t) -> "ncut " ^ NotationPp.pp_term t
-(*| NDiscriminate (_,t) -> "ndiscriminate " ^ NotationPp.pp_term t
- | NSubst (_,t) -> "nsubst " ^ NotationPp.pp_term t *)
+ " with " ^ NotationPp.pp_term status wwhat
+ | NCut (_,t) -> "ncut " ^ NotationPp.pp_term status t
+(*| NDiscriminate (_,t) -> "ndiscriminate " ^ NotationPp.pp_term status t
+ | NSubst (_,t) -> "nsubst " ^ NotationPp.pp_term status t *)
| NClear (_,l) -> "nclear " ^ String.concat " " l
| NDestruct (_,dom,skip) -> "ndestruct ..."
- | NElim (_,what,where) -> "nelim " ^ NotationPp.pp_term what ^
+ | NElim (_,what,where) -> "nelim " ^ NotationPp.pp_term status what ^
"...to be implemented..." ^ " " ^ "...to be implemented..."
| NId _ -> "nid"
| NIntro (_,n) -> "#" ^ n
| NIntros (_,l) -> "#" ^ String.concat " " l
- | NInversion (_,what,where) -> "ninversion " ^ NotationPp.pp_term what ^
+ | NInversion (_,what,where) -> "ninversion " ^ NotationPp.pp_term status what ^
assert false ^ " " ^ assert false
- | NLApply (_,t) -> "lapply " ^ NotationPp.pp_term t
+ | NLApply (_,t) -> "lapply " ^ NotationPp.pp_term status t
| NRewrite (_,dir,n,where) -> "nrewrite " ^
(match dir with `LeftToRight -> ">" | `RightToLeft -> "<") ^
- " " ^ NotationPp.pp_term n ^ " " ^ pp_tactic_pattern where
+ " " ^ NotationPp.pp_term status n ^ " " ^ pp_tactic_pattern status where
| NReduce _ | NGeneralize _ | NLetIn _ | NAssert _ -> "TO BE IMPLEMENTED"
| NDot _ -> "."
| NSemicolon _ -> ";"
(String.concat " " (List.map string_of_int l))
| NUnfocus _ -> "unfocus"
| NSkip _ -> "skip"
- | NTry (_,tac) -> "ntry " ^ pp_ntactic ~map_unicode_to_tex tac
+ | NTry (_,tac) -> "ntry " ^ pp_ntactic status ~map_unicode_to_tex tac
| NAssumption _ -> "nassumption"
| NBlock (_,l) ->
- "(" ^ String.concat " " (List.map (pp_ntactic ~map_unicode_to_tex) l)^ ")"
- | NRepeat (_,t) -> "nrepeat " ^ pp_ntactic ~map_unicode_to_tex t
+ "(" ^ String.concat " " (List.map (pp_ntactic status ~map_unicode_to_tex) l)^ ")"
+ | NRepeat (_,t) -> "nrepeat " ^ pp_ntactic status ~map_unicode_to_tex t
;;
-let pp_nmacro = function
- | NCheck (_, term) -> Printf.sprintf "ncheck %s" (NotationPp.pp_term term)
+let pp_nmacro status = function
+ | NCheck (_, term) -> Printf.sprintf "ncheck %s" (NotationPp.pp_term status term)
| Screenshot (_, name) -> Printf.sprintf "screenshot \"%s\"" name
;;
| Some `LeftToRight -> "> "
| Some `RightToLeft -> "< "
-let pp_notation dir_opt l1_pattern assoc prec l2_pattern =
+let pp_notation status dir_opt l1_pattern assoc prec l2_pattern =
sprintf "notation %s\"%s\" %s %s for %s."
(pp_dir_opt dir_opt)
- (pp_l1_pattern l1_pattern)
+ (pp_l1_pattern status l1_pattern)
(pp_associativity assoc)
(pp_precedence prec)
- (pp_l2_pattern l2_pattern)
+ (pp_l2_pattern status l2_pattern)
-let pp_ncommand = function
+let pp_ncommand status = function
| UnificationHint (_,t, n) ->
- "unification hint " ^ string_of_int n ^ " " ^ NotationPp.pp_term t
+ "unification hint " ^ string_of_int n ^ " " ^ NotationPp.pp_term status t
| NDiscriminator (_,_)
| NInverter (_,_,_,_,_)
| NUnivConstraint (_) -> "not supported"
| NCoercion (_) -> "not supported"
- | NObj (_,obj) -> NotationPp.pp_obj NotationPp.pp_term obj
+ | NObj (_,obj) -> NotationPp.pp_obj (NotationPp.pp_term status) obj
| NQed (_) -> "nqed"
| NCopy (_,name,uri,map) ->
"copy " ^ name ^ " from " ^ NUri.string_of_uri uri ^ " with " ^
| Interpretation (_, dsc, (symbol, arg_patterns), cic_appl_pattern) ->
pp_interpretation dsc symbol arg_patterns cic_appl_pattern
| Notation (_, dir_opt, l1_pattern, assoc, prec, l2_pattern) ->
- pp_notation dir_opt l1_pattern assoc prec l2_pattern
+ pp_notation status dir_opt l1_pattern assoc prec l2_pattern
;;
-let pp_executable ~map_unicode_to_tex =
+let pp_executable status ~map_unicode_to_tex =
function
- | NMacro (_, macro) -> pp_nmacro macro ^ "."
+ | NMacro (_, macro) -> pp_nmacro status macro ^ "."
| NTactic (_,tacl) ->
- String.concat " " (List.map (pp_ntactic ~map_unicode_to_tex) tacl)
- | NCommand (_, cmd) -> pp_ncommand cmd ^ "."
+ String.concat " " (List.map (pp_ntactic status ~map_unicode_to_tex) tacl)
+ | NCommand (_, cmd) -> pp_ncommand status cmd ^ "."
-let pp_comment ~map_unicode_to_tex =
+let pp_comment status ~map_unicode_to_tex =
function
| Note (_,"") -> Printf.sprintf "\n"
| Note (_,str) -> Printf.sprintf "\n(* %s *)" str
| Code (_,code) ->
- Printf.sprintf "\n(** %s. **)" (pp_executable ~map_unicode_to_tex code)
+ Printf.sprintf "\n(** %s. **)" (pp_executable status ~map_unicode_to_tex code)
-let pp_statement =
+let pp_statement status =
function
- | Executable (_, ex) -> pp_executable ex
- | Comment (_, c) -> pp_comment c
+ | Executable (_, ex) -> pp_executable status ex
+ | Comment (_, c) -> pp_comment status c
* http://helm.cs.unibo.it/
*)
-val pp_comment: map_unicode_to_tex:bool -> GrafiteAst.comment -> string
+val pp_comment:
+ #NCic.status -> map_unicode_to_tex:bool -> GrafiteAst.comment -> string
-val pp_executable: map_unicode_to_tex:bool -> GrafiteAst.code -> string
+val pp_executable:
+ #NCic.status -> map_unicode_to_tex:bool -> GrafiteAst.code -> string
val pp_alias: GrafiteAst.alias_spec -> string
-val pp_statement: GrafiteAst.statement -> map_unicode_to_tex:bool -> string
+val pp_statement:
+ #NCic.status -> GrafiteAst.statement -> map_unicode_to_tex:bool -> string
~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 status, composites =
NCicCoercDeclaration.eval_ncoercion status name 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 ->
if status#ng_mode <> `ProofMode then
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 ->
| NReference.CoFix _ -> NReference.CoFix height
| 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
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 =
NCicCoercDeclaration.
basic_eval_and_record_ncoercion_from_t_cpos_arity
status (name,t,cpos,arity) in
- let aliases = GrafiteDisambiguate.aliases_for_objs nuris 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
(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
let command_error msg = raise (Command_error msg)
-class status = fun (b : string) ->
+class virtual status = fun (b : string) ->
let fake_obj =
NUri.uri_of_string "cic:/matita/dummy.decl",0,[],[],
NCic.Constant([],"",None,NCic.Implicit `Closed,(`Provided,`Theorem,`Regular))
val command_error: string -> 'a (** @raise Command_error *)
-class status :
+class virtual status :
string ->
object ('self)
(* Warning: #stack and #obj are meaningful iff #ng_mode is `ProofMode *)
| _ -> skel_dummy
;;
-let src_tgt_of_ty_cpos_arity ty cpos arity =
+let src_tgt_of_ty_cpos_arity status ty cpos arity =
let pis = count_prod ty in
let tpos = pis - arity in
let rec pi_nth i j = function
| NCic.Meta _
| NCic.Implicit _ as x -> x
| NCic.Rel _ -> skel_dummy
- | t -> NCicUtils.map (fun _ () -> ()) () aux t
+ | t -> NCicUtils.map status (fun _ () -> ()) () aux t
in
aux () t
in
mask (pi_tail 0 tpos ty)
;;
-let rec cleanup_skel () = function
+let rec cleanup_skel status () = function
| NCic.Meta _ -> skel_dummy
- | t -> NCicUtils.map (fun _ () -> ()) () cleanup_skel t
+ | t -> NCicUtils.map status (fun _ () -> ()) () (cleanup_skel status) t
;;
-let close_in_context t metasenv =
+let close_in_context status 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 ty = NCicUntrusted.apply_subst status (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
since metas occurring in t have an empty context,
the substitution i build makes sense (i.e, the Rel
I pun in the subst will not be lifted by subst_meta *)
- NCicUntrusted.apply_subst subst ctx
- (NCicSubstitution.lift (List.length ctx) t)
+ NCicUntrusted.apply_subst status subst ctx
+ (NCicSubstitution.lift status (List.length ctx) t)
| _ -> assert false
in
aux (fun _ -> []) [] [] metasenv
;;
-let toposort metasenv =
+let toposort status 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
+ List.mem j (NCicUntrusted.metas_of_term status [] [] t)) metasenv
in
T.topological_sort metasenv deps
;;
let metasenv,subst,status,src =
GrafiteDisambiguate.disambiguate_nterm
status None ctx [] [] ("",0,src) in
- let src = NCicUntrusted.apply_subst subst [] src in
+ let src = NCicUntrusted.apply_subst status subst [] src in
(* CHECK that the declared pattern matches the abstraction *)
let _ = NCicUnification.unify status metasenv subst ctx ty src in
- let src = cleanup_skel () src in
+ let src = cleanup_skel status () src in
status, src, cpos
with
| NCicUnification.UnificationFailure _
let metasenv,subst,status,tgt =
GrafiteDisambiguate.disambiguate_nterm
status None [] [] [] ("",0,tgt) in
- let tgt = NCicUntrusted.apply_subst subst [] tgt in
+ let tgt = NCicUntrusted.apply_subst status subst [] tgt in
(* CHECK che sia unificabile mancante *)
let rec count_prod = function
| NCic.Prod (_,_,x) -> 1 + count_prod x
let arity = count_prod tgt in
let tgt=
if arity > 0 then cleanup_funclass_skel tgt
- else cleanup_skel () tgt
+ else cleanup_skel status () tgt
in
status, tgt, arity
in
NCicUnification.unify status metasenv subst [] a b)
(metasenv,[]) upl
in
- let bo = NCicUntrusted.apply_subst subst [] bo in
- let p = NCicUntrusted.apply_subst subst [] p in
- let metasenv = NCicUntrusted.apply_subst_metasenv subst metasenv in
- let metasenv = toposort metasenv in
- let bo = close_in_context bo metasenv in
+ let bo = NCicUntrusted.apply_subst status subst [] bo in
+ let p = NCicUntrusted.apply_subst status subst [] p in
+ let metasenv = NCicUntrusted.apply_subst_metasenv status subst metasenv in
+ let metasenv = toposort status metasenv in
+ let bo = close_in_context status bo metasenv in
let pos =
match p with
| NCic.Meta (p,_) -> pos_in_list p (List.map fst metasenv)
| t -> raise Stop
in
- let ty = NCicTypeChecker.typeof ~metasenv:[] ~subst:[] [] bo in
- let src,tgt = src_tgt_of_ty_cpos_arity ty pos arity in
+ let ty = NCicTypeChecker.typeof status ~metasenv:[] ~subst:[] [] bo in
+ let src,tgt = src_tgt_of_ty_cpos_arity status ty pos arity in
let src = only_head src in
let tgt = only_head tgt in
debug (lazy(
"composite " ^ name ^ ": "^
- 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 ^
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] bo ^ " : " ^
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] ty ^ " as " ^
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] src ^ " ===> " ^
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] tgt ^
" cpos=" ^ string_of_int pos ^ " arity=" ^ string_of_int arity));
let uri = fresh_uri status name ".con" in
let obj_kind = NCic.Constant
([],name,Some bo,ty,(`Generated,`Definition,`Coercion arity))
in
- let height = NCicTypeChecker.height_of_obj_kind uri [] obj_kind in
+ let height = NCicTypeChecker.height_of_obj_kind status uri [] obj_kind in
let obj = uri,height,[],[],obj_kind in
let c =
NCic.Const
~refresh_uri_in_reference ~alias_only status
=
if not alias_only then
- List.fold_right (aux ~refresh_uri_in_term) l status
+ List.fold_right (aux ~refresh_uri_in_term:(refresh_uri_in_term (status:>NCic.status))) l status
else
status
in
- GrafiteTypes.Serializer.register#run "ncoercion" aux_l
+ GrafiteTypes.Serializer.register#run "ncoercion" aux_l
;;
let basic_eval_and_record_ncoercion infos status =
let basic_eval_and_record_ncoercion_from_t_cpos_arity
status (name,t,cpos,arity)
=
- let ty = NCicTypeChecker.typeof ~subst:[] ~metasenv:[] [] t in
- let src,tgt = src_tgt_of_ty_cpos_arity ty cpos arity in
+ let ty = NCicTypeChecker.typeof status ~subst:[] ~metasenv:[] [] t in
+ let src,tgt = src_tgt_of_ty_cpos_arity status ty cpos arity in
let status, uris =
basic_eval_and_record_ncoercion (name,t,src,tgt,cpos,arity) status
in
let metasenv,subst,status,ty =
GrafiteDisambiguate.disambiguate_nterm status None [] [] [] ("",0,ty) in
assert (metasenv=[]);
- let ty = NCicUntrusted.apply_subst subst [] ty in
+ let ty = NCicUntrusted.apply_subst status subst [] ty in
let metasenv,subst,status,t =
GrafiteDisambiguate.disambiguate_nterm status (Some ty) [] [] [] ("",0,t) in
assert (metasenv=[]);
- let t = NCicUntrusted.apply_subst subst [] t in
+ let t = NCicUntrusted.apply_subst status subst [] t in
let status, src, tgt, cpos, arity =
src_tgt_cpos_arity_of_ty_id_src_tgt status ty id src tgt in
let status, uris =
| N.Implicit _ -> false
| N.UserInput -> true
| _ -> raise (Invalid_argument "malformed target parameter list 1")) l
- | _ -> raise (Invalid_argument ("malformed target parameter list 2\n" ^ NotationPp.pp_term params)) ]
+ | _ ->
+ (*CSC: new NCicPp.status is the best I can do here without changing the
+ result type *)
+ raise (Invalid_argument ("malformed target parameter list 2\n" ^ NotationPp.pp_term (new NCicPp.status) params)) ]
];
direction: [
[ SYMBOL ">" -> `LeftToRight
method parser_db: db
end
-class status =
+class virtual status =
object(self)
inherit CicNotationParser.status ~keywords:[]
- val mutable db = None
+ val mutable db = None (* mutable only to initialize it :-( *)
method parser_db = match db with None -> assert false | Some x -> x
method set_parser_db v = {< db = Some v >}
method set_parser_status
method parser_db: db
end
-class status :
+class virtual status :
object('self)
inherit g_status
inherit CicNotationParser.status
Lazy.t
}
-let initial_db = {
+let initial_db status = {
counter = -1;
pattern32_matrix = [];
level2_patterns32 = IntMap.empty;
interpretations = StringMap.empty;
- compiled32 = lazy (Ncic2astMatcher.Matcher32.compiler [])
+ compiled32 = lazy (Ncic2astMatcher.Matcher32.compiler status [])
}
class type g_status =
method interp_db: db
end
-class status =
- object
+class virtual status =
+ object(self)
inherit NCicCoercion.status
- val interp_db = initial_db
- method interp_db = interp_db
- method set_interp_db v = {< interp_db = v >}
+ val mutable interp_db = None (* mutable only to initialize it :-( *)
+ method interp_db = match interp_db with None -> assert false | Some x -> x
+ method set_interp_db v = {< interp_db = Some v >}
method set_interp_status
: 'status. #g_status as 'status -> 'self
- = fun o -> {< interp_db = o#interp_db >}#set_coercion_status o
+ = fun o -> {< interp_db = Some o#interp_db >}#set_coercion_status o
+ initializer
+ interp_db <- Some (initial_db self)
end
let idref register_ref =
in
status#set_interp_db
{status#interp_db with
- compiled32 = lazy (Ncic2astMatcher.Matcher32.compiler t) }
+ compiled32 = lazy (Ncic2astMatcher.Matcher32.compiler status t) }
;;
let add_interpretation status dsc (symbol, args) appl_pattern =
idref (Ast.Ident (name,None))
with Failure "nth" | Invalid_argument "List.nth" ->
idref (Ast.Ident ("-" ^ string_of_int (n - List.length context),None)))
- | NCic.Const r -> idref ~reference:r (Ast.Ident (NCicPp.r2s true r, None))
+ | NCic.Const r -> idref ~reference:r (Ast.Ident (NCicPp.r2s status true r, None))
| NCic.Meta (n,lc) when List.mem_assoc n subst ->
let _,_,t,_ = List.assoc n subst in
- k ~context (NCicSubstitution.subst_meta lc t)
+ k ~context (NCicSubstitution.subst_meta status lc t)
| NCic.Meta (n,(s,l)) ->
(* CSC: qua non dovremmo espandere *)
let l = NCicUtils.expand_local_context l in
idref (Ast.Meta
- (n, List.map (fun x -> Some (k ~context (NCicSubstitution.lift s x))) l))
+ (n, List.map (fun x -> Some (k ~context (NCicSubstitution.lift status s x))) l))
| NCic.Sort NCic.Prop -> idref (Ast.Sort `Prop)
| NCic.Sort NCic.Type [] -> idref (Ast.Sort `Set)
| NCic.Sort NCic.Type ((`Type,u)::_) ->
ty, k ~context:((n,NCic.Decl s)::context) t))
| NCic.Appl (NCic.Meta (n,lc) :: args) when List.mem_assoc n subst ->
let _,_,t,_ = List.assoc n subst in
- let hd = NCicSubstitution.subst_meta lc t in
+ let hd = NCicSubstitution.subst_meta status lc t in
k ~context
- (NCicReduction.head_beta_reduce ~upto:(List.length args)
+ (NCicReduction.head_beta_reduce status ~upto:(List.length args)
(match hd with
| NCic.Appl l -> NCic.Appl (l@args)
| _ -> NCic.Appl (hd :: args)))
let case_indty =
name, None(*CSC Some (UriManager.uri_of_string puri_str)*) in
let constructors, leftno =
- let _,leftno,tys,_,n = NCicEnvironment.get_checked_indtys r in
+ let _,leftno,tys,_,n = NCicEnvironment.get_checked_indtys status r in
let _,_,_,cl = List.nth tys n in
cl,leftno
in
idref ast (*Ast.AttributedTerm (`IdRef (idref term), ast)*)
;;
-let nmap_sequent0 status ~idref ~metasenv ~subst (i,(n,context,ty)) =
+let nmap_context0 status ~idref ~metasenv ~subst context =
let module K = Content in
let nast_of_cic =
- nast_of_cic1 status ~idref ~output_type:`Term ~metasenv ~subst in
- let context',_ =
+ nast_of_cic1 status ~idref ~output_type:`Term ~metasenv ~subst
+ in
+ fst (
List.fold_right
(fun item (res,context) ->
match item with
K.def_term = nast_of_cic ~context t;
K.def_type = nast_of_cic ~context ty
})::res,item::context
- ) context ([],[])
- in
- ("-1",i,context',nast_of_cic ~context ty)
+ ) context ([],[]))
;;
-let nmap_sequent status ~metasenv ~subst conjecture =
+let nmap_sequent0 status ~idref ~metasenv ~subst (i,(n,context,ty)) =
let module K = Content in
- let ids_to_refs = Hashtbl.create 211 in
- let register_ref = Hashtbl.add ids_to_refs in
- nmap_sequent0 status ~idref:(idref register_ref) ~metasenv ~subst conjecture,
- ids_to_refs
+ let nast_of_cic =
+ nast_of_cic1 status ~idref ~output_type:`Term ~metasenv ~subst in
+ let context' = nmap_context0 status ~idref ~metasenv ~subst context in
+ ("-1",i,context',nast_of_cic ~context ty)
;;
let object_prefix = "obj:";;
}
;;
-let nmap_obj status (uri,_,metasenv,subst,kind) =
+let nmap_obj0 status ~idref (uri,_,metasenv,subst,kind) =
let module K = Content in
- let ids_to_refs = Hashtbl.create 211 in
- let register_ref = Hashtbl.add ids_to_refs in
- let idref = idref register_ref in
let nast_of_cic =
nast_of_cic1 status ~idref ~output_type:`Term ~metasenv ~subst in
let seed = ref 0 in
K.def_term = t;
}
in
- let res =
- match kind with
- | NCic.Fixpoint (is_rec, ifl, _) ->
- (gen_id object_prefix seed, conjectures,
- `Joint
- { K.joint_id = gen_id joint_prefix seed;
- K.joint_kind =
- if is_rec then
- `Recursive (List.map (fun (_,_,i,_,_) -> i) ifl)
- else `CoRecursive;
- K.joint_defs = List.map (build_fixpoint is_rec seed) ifl
- })
- | NCic.Inductive (is_ind, lno, itl, _) ->
- (gen_id object_prefix seed, conjectures,
- `Joint
- { K.joint_id = gen_id joint_prefix seed;
- K.joint_kind =
- if is_ind then `Inductive lno else `CoInductive lno;
- K.joint_defs = List.map (build_inductive is_ind seed) itl
- })
- | NCic.Constant (_,_,Some bo,ty,_) ->
- let ty = nast_of_cic ~context:[] ty in
- let bo = nast_of_cic ~context:[] bo in
- (gen_id object_prefix seed, conjectures,
- `Def (K.Const,ty,
- build_def_item seed [] [] (get_id bo) (NUri.name_of_uri uri) bo ty))
- | NCic.Constant (_,_,None,ty,_) ->
- let ty = nast_of_cic ~context:[] ty in
- (gen_id object_prefix seed, conjectures,
- `Decl (K.Const,
- (*CSC: ??? get_id ty here used to be the id of the axiom! *)
- build_decl_item seed (get_id ty) (NUri.name_of_uri uri) ty))
- in
- res,ids_to_refs
+ match kind with
+ | NCic.Fixpoint (is_rec, ifl, _) ->
+ (gen_id object_prefix seed, conjectures,
+ `Joint
+ { K.joint_id = gen_id joint_prefix seed;
+ K.joint_kind =
+ if is_rec then
+ `Recursive (List.map (fun (_,_,i,_,_) -> i) ifl)
+ else `CoRecursive;
+ K.joint_defs = List.map (build_fixpoint is_rec seed) ifl
+ })
+ | NCic.Inductive (is_ind, lno, itl, _) ->
+ (gen_id object_prefix seed, conjectures,
+ `Joint
+ { K.joint_id = gen_id joint_prefix seed;
+ K.joint_kind =
+ if is_ind then `Inductive lno else `CoInductive lno;
+ K.joint_defs = List.map (build_inductive is_ind seed) itl
+ })
+ | NCic.Constant (_,_,Some bo,ty,_) ->
+ let ty = nast_of_cic ~context:[] ty in
+ let bo = nast_of_cic ~context:[] bo in
+ (gen_id object_prefix seed, conjectures,
+ `Def (K.Const,ty,
+ build_def_item seed [] [] (get_id bo) (NUri.name_of_uri uri) bo ty))
+ | NCic.Constant (_,_,None,ty,_) ->
+ let ty = nast_of_cic ~context:[] ty in
+ (gen_id object_prefix seed, conjectures,
+ `Decl (K.Const,
+ (*CSC: ??? get_id ty here used to be the id of the axiom! *)
+ build_decl_item seed (get_id ty) (NUri.name_of_uri uri) ty))
+;;
+
+let with_idrefs foo status obj =
+ let ids_to_refs = Hashtbl.create 211 in
+ let register_ref = Hashtbl.add ids_to_refs in
+ foo status ~idref:(idref register_ref) obj, ids_to_refs
;;
+
+let nmap_obj status = with_idrefs nmap_obj0 status
+
+let nmap_sequent status ~metasenv ~subst =
+ with_idrefs (nmap_sequent0 ~metasenv ~subst) status
+
+let nmap_term status ~metasenv ~subst ~context =
+ with_idrefs (nast_of_cic1 ~output_type:`Term ~metasenv ~subst ~context) status
+
+let nmap_context status ~metasenv ~subst =
+ with_idrefs (nmap_context0 ~metasenv ~subst) status
method interp_db: db
end
-class status :
+class virtual status :
object ('self)
inherit g_status
inherit NCicCoercion.status
(string * 'term) list -> NotationPt.cic_appl_pattern ->
'term
+val nmap_term:
+ #status ->
+ metasenv:NCic.metasenv -> subst:NCic.substitution -> context:NCic.context ->
+ NCic.term ->
+ NotationPt.term *
+ (Content.id, NReference.reference) Hashtbl.t (* id -> reference *)
+
+val nmap_context:
+ #status ->
+ metasenv:NCic.metasenv -> subst:NCic.substitution ->
+ NCic.context ->
+ NotationPt.term Content.context *
+ (Content.id, NReference.reference) Hashtbl.t (* id -> reference *)
+
val nmap_sequent:
#status -> metasenv:NCic.metasenv -> subst:NCic.substitution ->
int * NCic.conjecture ->
type pattern_t = Ast.cic_appl_pattern
type term_t = NCic.term
+ (* Debugging functions only *)
let string_of_pattern = NotationPp.pp_cic_appl_pattern
let string_of_term t =
- (*CSC: ??? *)
- NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t
+ (new NCicPp.status)#ppterm ~metasenv:[] ~subst:[] ~context:[] t
let classify = function
| Ast.ImplicitPattern
module M = PatternMatcher.Matcher (Pattern32)
- let compiler rows =
+ let compiler status rows =
let match_cb rows matched_terms constructors =
HExtlib.list_findopt
(fun (pl,pid) _ ->
| (name,t)::tl ->
List.for_all
(fun (name',t') ->
- name <> name' || NCicReduction.alpha_eq [] [] [] t t'
+ name <> name' || NCicReduction.alpha_eq status [] [] [] t t'
) tl && check_non_linear_patterns tl
in
if check_non_linear_patterns env then
sig
(** @param l3_patterns level 3 (CIC) patterns (AKA cic_appl_pattern) *)
val compiler :
+ #NCic.status ->
(NotationPt.cic_appl_pattern * int) list ->
(NCic.term ->
((string * NCic.term) list * NCic.term list * int) option)
method disambiguate_db: db
end
-class status =
+class virtual status =
object (self)
inherit Interpretations.status
val disambiguate_db = initial_status
;;
-let disambiguate_nterm estatus expty context metasenv subst thing
+let disambiguate_nterm status expty context metasenv subst thing
=
let diff, metasenv, subst, cic =
singleton "first"
(NCicDisambiguate.disambiguate_term
- ~rdb:estatus
- ~aliases:estatus#disambiguate_db.aliases
+ status
+ ~aliases:status#disambiguate_db.aliases
~expty
- ~universe:(Some estatus#disambiguate_db.multi_aliases)
+ ~universe:(Some status#disambiguate_db.multi_aliases)
~lookup_in_library:nlookup_in_library
- ~mk_choice:(ncic_mk_choice estatus)
+ ~mk_choice:(ncic_mk_choice status)
~mk_implicit ~fix_instance
~description_of_alias:GrafiteAst.description_of_alias
~context ~metasenv ~subst thing)
in
- let estatus =
- set_proof_aliases estatus ~implicit_aliases:true GrafiteAst.WithPreferences
+ let status =
+ set_proof_aliases status ~implicit_aliases:true GrafiteAst.WithPreferences
diff
in
- metasenv, subst, estatus, cic
+ metasenv, subst, status, cic
;;
NotationPt.term Disambiguate.disambiguator_input option *
(string * NCic.term) list * NCic.term option
-let disambiguate_npattern (text, prefix_len, (wanted, hyp_paths, goal_path)) =
- let interp path = NCicDisambiguate.disambiguate_path path in
+let disambiguate_npattern status (text, prefix_len, (wanted, hyp_paths, goal_path)) =
+ let interp path = NCicDisambiguate.disambiguate_path status path in
let goal_path = HExtlib.map_option interp goal_path in
let hyp_paths = List.map (fun (name, path) -> name, interp path) hyp_paths in
- let wanted =
- match wanted with None -> None | Some x -> Some (text,prefix_len,x)
- in
+ let wanted = HExtlib.map_option (fun x -> text,prefix_len,x) wanted in
(wanted, hyp_paths, goal_path)
;;
-let disambiguate_reduction_kind text prefix_len lexicon_status_ref = function
+let disambiguate_reduction_kind text prefix_len = function
| `Unfold (Some t) -> assert false (* MATITA 1.0 *)
| `Normalize
| `Simpl
metasenv, `Auto params
;;
-let disambiguate_nobj estatus ?baseuri (text,prefix_len,obj) =
+let disambiguate_nobj status ?baseuri (text,prefix_len,obj) =
let uri =
let baseuri =
match baseuri with Some x -> x | None -> raise BaseUriNotSetYet
let diff, _, _, cic =
singleton "third"
(NCicDisambiguate.disambiguate_obj
+ status
~lookup_in_library:nlookup_in_library
~description_of_alias:GrafiteAst.description_of_alias
- ~mk_choice:(ncic_mk_choice estatus)
- ~mk_implicit ~fix_instance
- ~uri
- ~rdb:estatus
- ~aliases:estatus#disambiguate_db.aliases
- ~universe:(Some estatus#disambiguate_db.multi_aliases)
+ ~mk_choice:(ncic_mk_choice status)
+ ~mk_implicit ~fix_instance ~uri
+ ~aliases:status#disambiguate_db.aliases
+ ~universe:(Some status#disambiguate_db.multi_aliases)
(text,prefix_len,obj)) in
- let estatus =
- set_proof_aliases estatus ~implicit_aliases:true GrafiteAst.WithPreferences
+ let status =
+ set_proof_aliases status ~implicit_aliases:true GrafiteAst.WithPreferences
diff
in
- estatus, cic
+ status, cic
;;
let disambiguate_cic_appl_pattern status args =
disambiguate
;;
-let aliases_for_objs refs =
+let aliases_for_objs status refs =
List.concat
(List.map
(fun nref ->
let references = NCicLibrary.aliases_of nref in
List.map
(fun u ->
- let name = NCicPp.r2s true u in
+ let name = NCicPp.r2s status true u in
DisambiguateTypes.Id name,
GrafiteAst.Ident_alias (name,NReference.string_of_reference u)
) references) refs)
method disambiguate_db: db
end
-class status :
+class virtual status :
object ('self)
inherit g_status
inherit Interpretations.status
(DisambiguateTypes.domain_item * GrafiteAst.alias_spec) list -> 'status
val aliases_for_objs:
- NUri.uri list -> (DisambiguateTypes.domain_item * GrafiteAst.alias_spec) list
+ #NCic.status -> NUri.uri list ->
+ (DisambiguateTypes.domain_item * GrafiteAst.alias_spec) list
(* args: print function, message (may be empty), status *)
val dump_aliases: (string -> unit) -> string -> #status -> unit
(string * NCic.term) list * NCic.term option
val disambiguate_npattern:
- GrafiteAst.npattern Disambiguate.disambiguator_input -> pattern
+ #NCic.status -> GrafiteAst.npattern Disambiguate.disambiguator_input -> pattern
val disambiguate_cic_appl_pattern:
#status ->
| _ -> (NCic.Rel (howmany + from)) :: (mk_rels (howmany-1) from)
;;
-let refine_term
- metasenv subst context uri ~rdb ~use_coercions term expty _ ~localization_tbl=
+let refine_term (status: #NCicCoercion.status) metasenv subst context uri ~use_coercions term expty _
+ ~localization_tbl
+=
assert (uri=None);
debug_print (lazy (sprintf "TEST_INTERPRETATION: %s"
- (NCicPp.ppterm ~metasenv ~subst ~context term)));
+ (status#ppterm ~metasenv ~subst ~context term)));
try
let localise t =
try NCicUntrusted.NCicHash.find localization_tbl t
with Not_found ->
- prerr_endline ("NOT LOCALISED" ^ NCicPp.ppterm ~metasenv ~subst ~context t);
+ prerr_endline ("NOT LOCALISED" ^ status#ppterm ~metasenv ~subst ~context t);
(*assert false*) HExtlib.dummy_floc
in
let metasenv, subst, term, _ =
NCicRefiner.typeof
- (rdb#set_coerc_db
- (if use_coercions then rdb#coerc_db else NCicCoercion.empty_db))
+ (status#set_coerc_db
+ (if use_coercions then status#coerc_db else NCicCoercion.empty_db))
metasenv subst context term expty ~localise
in
Disambiguate.Ok (term, metasenv, subst, ())
with
| NCicRefiner.Uncertain loc_msg ->
debug_print (lazy ("UNCERTAIN: [" ^ snd (Lazy.force loc_msg) ^ "] " ^
- NCicPp.ppterm ~metasenv ~subst ~context term)) ;
+ status#ppterm ~metasenv ~subst ~context term)) ;
Disambiguate.Uncertain loc_msg
| NCicRefiner.RefineFailure loc_msg ->
debug_print (lazy (sprintf "PRUNED:\nterm%s\nmessage:%s"
- (NCicPp.ppterm ~metasenv ~subst ~context term) (snd(Lazy.force loc_msg))));
+ (status#ppterm ~metasenv ~subst ~context term) (snd(Lazy.force loc_msg))));
Disambiguate.Ko loc_msg
;;
-let refine_obj
- ~rdb metasenv subst _context _uri
- ~use_coercions obj _ _ugraph ~localization_tbl
+let refine_obj status metasenv subst _context _uri ~use_coercions obj _ _ugraph
+ ~localization_tbl
=
assert (metasenv=[]);
assert (subst=[]);
try
let obj =
NCicRefiner.typeof_obj
- (rdb#set_coerc_db
- (if use_coercions then rdb#coerc_db
+ (status#set_coerc_db
+ (if use_coercions then status#coerc_db
else NCicCoercion.empty_db))
obj ~localise
in
with
| NCicRefiner.Uncertain loc_msg ->
debug_print (lazy ("UNCERTAIN: [" ^ snd (Lazy.force loc_msg) ^ "] " ^
- NCicPp.ppobj obj)) ;
+ status#ppobj obj)) ;
Disambiguate.Uncertain loc_msg
| NCicRefiner.RefineFailure loc_msg ->
debug_print (lazy (sprintf "PRUNED:\nobj: %s\nmessage: %s"
- (NCicPp.ppobj obj) (snd(Lazy.force loc_msg))));
+ (status#ppobj obj) (snd(Lazy.force loc_msg))));
Disambiguate.Ko loc_msg
;;
in
aux 1 context
-let interpretate_term_and_interpretate_term_option
- ?(create_dummy_ids=false)
- ~obj_context ~mk_choice ~env ~uri ~is_path ~localization_tbl
+let interpretate_term_and_interpretate_term_option (status: #NCic.status)
+ ?(create_dummy_ids=false) ~obj_context ~mk_choice ~env ~uri ~is_path
+ ~localization_tbl
=
(* create_dummy_ids shouldbe used only for interpretating patterns *)
assert (uri = None);
| t ->
raise (DisambiguateTypes.Invalid_choice
(lazy (loc,"The type of the term to be matched "^
- "is not (co)inductive: " ^ NCicPp.ppterm
+ "is not (co)inductive: " ^ status#ppterm
~metasenv:[] ~subst:[] ~context:[] t))))
| None ->
let rec fst_constructor =
(match Disambiguate.resolve ~env ~mk_choice
(Id (fst_constructor branches)) (`Args []) with
| NCic.Const (NReference.Ref (_,NReference.Con _) as r) ->
- let b,_,_,_,_ = NCicEnvironment.get_checked_indtys r in
+ let b,_,_,_,_= NCicEnvironment.get_checked_indtys status r in
NReference.mk_indty b r
| NCic.Implicit _ ->
raise (Disambiguate.Try_again
raise (DisambiguateTypes.Invalid_choice
(lazy (loc,
"The type of the term to be matched is not (co)inductive: "
- ^ NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t))))
+ ^ status#ppterm ~metasenv:[] ~subst:[] ~context:[] t))))
in
let _,leftsno,itl,_,indtyp_no =
- NCicEnvironment.get_checked_indtys indtype_ref in
+ NCicEnvironment.get_checked_indtys status indtype_ref in
let _,_,_,cl =
try
List.nth itl indtyp_no
with _ -> assert false in
let rec count_prod t =
- match NCicReduction.whd ~subst:[] [] t with
+ match NCicReduction.whd status ~subst:[] [] t with
NCic.Prod (_, _, t) -> 1 + (count_prod t)
| _ -> 0
in
(fun ~context -> aux_option ~localize:true HExtlib.dummy_floc context)
;;
-let interpretate_term ?(create_dummy_ids=false) ~context ~env ~uri ~is_path ast
- ~obj_context ~localization_tbl ~mk_choice
+let interpretate_term status ?(create_dummy_ids=false) ~context ~env ~uri
+ ~is_path ast ~obj_context ~localization_tbl ~mk_choice
=
let context = List.map fst context in
fst
- (interpretate_term_and_interpretate_term_option
- ~obj_context ~mk_choice ~create_dummy_ids ~env ~uri ~is_path ~localization_tbl)
+ (interpretate_term_and_interpretate_term_option status
+ ~obj_context ~mk_choice ~create_dummy_ids ~env ~uri ~is_path
+ ~localization_tbl)
~context ast
;;
-let interpretate_term_option
- ?(create_dummy_ids=false) ~context ~env ~uri ~is_path
- ~localization_tbl ~mk_choice ~obj_context
+let interpretate_term_option status ?(create_dummy_ids=false) ~context ~env ~uri
+ ~is_path ~localization_tbl ~mk_choice ~obj_context
=
let context = List.map fst context in
snd
- (interpretate_term_and_interpretate_term_option
- ~obj_context ~mk_choice ~create_dummy_ids ~env ~uri ~is_path ~localization_tbl)
+ (interpretate_term_and_interpretate_term_option status
+ ~obj_context ~mk_choice ~create_dummy_ids ~env ~uri ~is_path
+ ~localization_tbl)
~context
;;
-let disambiguate_path path =
+let disambiguate_path status path =
let localization_tbl = NCicUntrusted.NCicHash.create 23 in
fst
- (interpretate_term_and_interpretate_term_option
+ (interpretate_term_and_interpretate_term_option status
~obj_context:[] ~mk_choice:(fun _ -> assert false)
~create_dummy_ids:true ~env:DisambiguateTypes.Environment.empty
~uri:None ~is_path:true ~localization_tbl) ~context:[] path
| _ -> assert false
;;
-let interpretate_obj
+let interpretate_obj status
(* ?(create_dummy_ids=false) *)
~context ~env ~uri ~is_path obj ~localization_tbl ~mk_choice
=
match obj with
| NotationPt.Theorem (flavour, name, ty, bo, pragma) ->
let ty' =
- interpretate_term
+ interpretate_term status
~obj_context:[] ~context:[] ~env ~uri:None ~is_path:false ty
in
let height = (* XXX calculate *) 0 in
NotationPt.Binder (kind, var, t)) params t
in
let cic_body =
- interpretate_term
+ interpretate_term status
~obj_context ~context ~env ~uri:None ~is_path:false
(add_binders `Lambda body)
in
let cic_type =
- interpretate_term_option
+ interpretate_term_option status
~obj_context:[]
~context ~env ~uri:None ~is_path:false `Type
(HExtlib.map_option (add_binders `Pi) typ)
NCic.Fixpoint (inductive,inductiveFuns,attrs)
| bo ->
let bo =
- interpretate_term
+ interpretate_term status
~obj_context:[] ~context:[] ~env ~uri:None ~is_path:false bo
in
let attrs = `Provided, flavour, pragma in
| Some t -> t in
let name = cic_name_of_name name in
let t =
- interpretate_term ~obj_context:[] ~context ~env ~uri:None
+ interpretate_term status ~obj_context:[] ~context ~env ~uri:None
~is_path:false t
in
(name,NCic.Decl t)::context,(name,t)::res
(fun (name,_,ty,cl) ->
let ty' =
add_params
- (interpretate_term ~obj_context:[] ~context ~env ~uri:None
+ (interpretate_term status ~obj_context:[] ~context ~env ~uri:None
~is_path:false ty) in
let cl' =
List.map
(fun (name,ty) ->
let ty' =
add_params
- (interpretate_term ~obj_context ~context ~env ~uri:None
+ (interpretate_term status ~obj_context ~context ~env ~uri:None
~is_path:false ty) in
let relevance = [] in
relevance,name,ty'
| Some t -> t in
let name = cic_name_of_name name in
let t =
- interpretate_term ~obj_context:[] ~context ~env ~uri:None
+ interpretate_term status ~obj_context:[] ~context ~env ~uri:None
~is_path:false t
in
(name,NCic.Decl t)::context,(name,t)::res
let leftno = List.length params in
let ty' =
add_params
- (interpretate_term ~obj_context:[] ~context ~env ~uri:None
+ (interpretate_term status ~obj_context:[] ~context ~env ~uri:None
~is_path:false ty) in
let nref =
NReference.reference_of_spec uri (NReference.Ind (true,0,leftno)) in
List.fold_left
(fun (context,res) (name,ty,_coercion,_arity) ->
let ty =
- interpretate_term ~obj_context ~context ~env ~uri:None
+ interpretate_term status ~obj_context ~context ~env ~uri:None
~is_path:false ty in
let context' = (name,NCic.Decl ty)::context in
context',(name,ty)::res
NCic.Inductive (true,leftno,tyl,attrs)
;;
-let disambiguate_term ~context ~metasenv ~subst ~expty
- ~mk_implicit ~description_of_alias ~fix_instance ~mk_choice
- ~aliases ~universe ~rdb ~lookup_in_library
- (text,prefix_len,term)
- =
+let disambiguate_term (status: #NCicCoercion.status) ~context ~metasenv ~subst
+ ~expty ~mk_implicit ~description_of_alias ~fix_instance ~mk_choice
+ ~aliases ~universe ~lookup_in_library (text,prefix_len,term)
+=
let mk_localization_tbl x = NCicUntrusted.NCicHash.create x in
let res,b =
MultiPassDisambiguator.disambiguate_thing
~context ~metasenv ~initial_ugraph:() ~aliases
~mk_implicit ~description_of_alias ~fix_instance
~string_context_of_context:(List.map (fun (x,_) -> Some x))
- ~universe ~uri:None ~pp_thing:NotationPp.pp_term
+ ~universe ~uri:None ~pp_thing:(NotationPp.pp_term status)
~passes:(MultiPassDisambiguator.passes ())
~lookup_in_library ~domain_of_thing:Disambiguate.domain_of_term
- ~interpretate_thing:(interpretate_term ~obj_context:[] ~mk_choice (?create_dummy_ids:None))
- ~refine_thing:(refine_term ~rdb) (text,prefix_len,term)
+ ~interpretate_thing:(interpretate_term status ~obj_context:[] ~mk_choice (?create_dummy_ids:None))
+ ~refine_thing:(refine_term status) (text,prefix_len,term)
~mk_localization_tbl ~expty ~subst
in
List.map (function (a,b,c,d,_) -> a,b,c,d) res, b
;;
-let disambiguate_obj
+let disambiguate_obj (status: #NCicCoercion.status)
~mk_implicit ~description_of_alias ~fix_instance ~mk_choice
- ~aliases ~universe ~rdb ~lookup_in_library ~uri
- (text,prefix_len,obj)
+ ~aliases ~universe ~lookup_in_library ~uri (text,prefix_len,obj)
=
let mk_localization_tbl x = NCicUntrusted.NCicHash.create x in
let res,b =
~string_context_of_context:(List.map (fun (x,_) -> Some x))
~universe
~uri:(Some uri)
- ~pp_thing:(NotationPp.pp_obj NotationPp.pp_term)
+ ~pp_thing:(NotationPp.pp_obj (NotationPp.pp_term status))
~passes:(MultiPassDisambiguator.passes ())
~lookup_in_library ~domain_of_thing:Disambiguate.domain_of_obj
- ~interpretate_thing:(interpretate_obj ~mk_choice)
- ~refine_thing:(refine_obj ~rdb)
+ ~interpretate_thing:(interpretate_obj status ~mk_choice)
+ ~refine_thing:(refine_obj status)
(text,prefix_len,obj)
~mk_localization_tbl ~expty:None
in
(* $Id: nCic.ml 9058 2008-10-13 17:42:30Z tassi $ *)
val disambiguate_term :
+ #NCicCoercion.status ->
context:NCic.context ->
metasenv:NCic.metasenv ->
subst:NCic.substitution ->
mk_choice:('alias -> NCic.term DisambiguateTypes.codomain_item) ->
aliases:'alias DisambiguateTypes.Environment.t ->
universe:'alias list DisambiguateTypes.Environment.t option ->
- rdb:#NCicCoercion.status ->
lookup_in_library:(
DisambiguateTypes.interactive_user_uri_choice_type ->
DisambiguateTypes.input_or_locate_uri_type ->
bool
val disambiguate_obj :
+ #NCicCoercion.status ->
mk_implicit:(bool -> 'alias) ->
description_of_alias:('alias -> string) ->
fix_instance:(DisambiguateTypes.domain_item -> 'alias list -> 'alias list) ->
mk_choice:('alias -> NCic.term DisambiguateTypes.codomain_item) ->
aliases:'alias DisambiguateTypes.Environment.t ->
universe:'alias list DisambiguateTypes.Environment.t option ->
- rdb:#NCicCoercion.status ->
lookup_in_library:(
DisambiguateTypes.interactive_user_uri_choice_type ->
DisambiguateTypes.input_or_locate_uri_type ->
NCic.substitution * NCic.obj)
list * bool
-val disambiguate_path: NotationPt.term -> NCic.term
-
+val disambiguate_path: #NCic.status -> NotationPt.term -> NCic.term
nCicUtils.cmi: nCic.cmo
nCicSubstitution.cmi: nCic.cmo
nCicEnvironment.cmi: nUri.cmi nReference.cmi nCic.cmo
-nCicPp.cmi: nUri.cmi nReference.cmi nCic.cmo
nCicReduction.cmi: nCic.cmo
+nCicPp.cmi: nReference.cmi nCic.cmo
nCicTypeChecker.cmi: nUri.cmi nReference.cmi nCic.cmo
nCicUntrusted.cmi: nCic.cmo
nCic.cmo: nUri.cmi nReference.cmi
nCicSubstitution.cmi
nCicEnvironment.cmo: nUri.cmi nReference.cmi nCic.cmo nCicEnvironment.cmi
nCicEnvironment.cmx: nUri.cmx nReference.cmx nCic.cmx nCicEnvironment.cmi
-nCicPp.cmo: nUri.cmi nReference.cmi nCicSubstitution.cmi nCicEnvironment.cmi \
- nCic.cmo nCicPp.cmi
-nCicPp.cmx: nUri.cmx nReference.cmx nCicSubstitution.cmx nCicEnvironment.cmx \
- nCic.cmx nCicPp.cmi
nCicReduction.cmo: nReference.cmi nCicUtils.cmi nCicSubstitution.cmi \
nCicPp.cmi nCicEnvironment.cmi nCic.cmo nCicReduction.cmi
nCicReduction.cmx: nReference.cmx nCicUtils.cmx nCicSubstitution.cmx \
nCicPp.cmx nCicEnvironment.cmx nCic.cmx nCicReduction.cmi
+nCicPp.cmo: nUri.cmi nReference.cmi nCicSubstitution.cmi nCicReduction.cmi \
+ nCicEnvironment.cmi nCic.cmo nCicPp.cmi
+nCicPp.cmx: nUri.cmx nReference.cmx nCicSubstitution.cmx nCicReduction.cmx \
+ nCicEnvironment.cmx nCic.cmx nCicPp.cmi
nCicTypeChecker.cmo: nUri.cmi nReference.cmi nCicUtils.cmi \
- nCicSubstitution.cmi nCicReduction.cmi nCicPp.cmi nCicEnvironment.cmi \
- nCic.cmo nCicTypeChecker.cmi
+ nCicSubstitution.cmi nCicReduction.cmi nCicEnvironment.cmi nCic.cmo \
+ nCicTypeChecker.cmi
nCicTypeChecker.cmx: nUri.cmx nReference.cmx nCicUtils.cmx \
- nCicSubstitution.cmx nCicReduction.cmx nCicPp.cmx nCicEnvironment.cmx \
- nCic.cmx nCicTypeChecker.cmi
+ nCicSubstitution.cmx nCicReduction.cmx nCicEnvironment.cmx nCic.cmx \
+ nCicTypeChecker.cmi
nCicUntrusted.cmo: nReference.cmi nCicUtils.cmi nCicSubstitution.cmi \
nCicReduction.cmi nCicEnvironment.cmi nCic.cmo nCicUntrusted.cmi
nCicUntrusted.cmx: nReference.cmx nCicUtils.cmx nCicSubstitution.cmx \
nCicUtils.cmi: nCic.cmx
nCicSubstitution.cmi: nCic.cmx
nCicEnvironment.cmi: nUri.cmi nReference.cmi nCic.cmx
-nCicPp.cmi: nUri.cmi nReference.cmi nCic.cmx
nCicReduction.cmi: nCic.cmx
+nCicPp.cmi: nReference.cmi nCic.cmx
nCicTypeChecker.cmi: nUri.cmi nReference.cmi nCic.cmx
nCicUntrusted.cmi: nCic.cmx
nCic.cmo: nUri.cmi nReference.cmi
nCicSubstitution.cmi
nCicEnvironment.cmo: nUri.cmi nReference.cmi nCic.cmx nCicEnvironment.cmi
nCicEnvironment.cmx: nUri.cmx nReference.cmx nCic.cmx nCicEnvironment.cmi
-nCicPp.cmo: nUri.cmi nReference.cmi nCicSubstitution.cmi nCicEnvironment.cmi \
- nCic.cmx nCicPp.cmi
-nCicPp.cmx: nUri.cmx nReference.cmx nCicSubstitution.cmx nCicEnvironment.cmx \
- nCic.cmx nCicPp.cmi
nCicReduction.cmo: nReference.cmi nCicUtils.cmi nCicSubstitution.cmi \
nCicPp.cmi nCicEnvironment.cmi nCic.cmx nCicReduction.cmi
nCicReduction.cmx: nReference.cmx nCicUtils.cmx nCicSubstitution.cmx \
nCicPp.cmx nCicEnvironment.cmx nCic.cmx nCicReduction.cmi
+nCicPp.cmo: nUri.cmi nReference.cmi nCicSubstitution.cmi nCicReduction.cmi \
+ nCicEnvironment.cmi nCic.cmx nCicPp.cmi
+nCicPp.cmx: nUri.cmx nReference.cmx nCicSubstitution.cmx nCicReduction.cmx \
+ nCicEnvironment.cmx nCic.cmx nCicPp.cmi
nCicTypeChecker.cmo: nUri.cmi nReference.cmi nCicUtils.cmi \
- nCicSubstitution.cmi nCicReduction.cmi nCicPp.cmi nCicEnvironment.cmi \
- nCic.cmx nCicTypeChecker.cmi
+ nCicSubstitution.cmi nCicReduction.cmi nCicEnvironment.cmi nCic.cmx \
+ nCicTypeChecker.cmi
nCicTypeChecker.cmx: nUri.cmx nReference.cmx nCicUtils.cmx \
- nCicSubstitution.cmx nCicReduction.cmx nCicPp.cmx nCicEnvironment.cmx \
- nCic.cmx nCicTypeChecker.cmi
+ nCicSubstitution.cmx nCicReduction.cmx nCicEnvironment.cmx nCic.cmx \
+ nCicTypeChecker.cmi
nCicUntrusted.cmo: nReference.cmi nCicUtils.cmi nCicSubstitution.cmi \
nCicReduction.cmi nCicEnvironment.cmi nCic.cmx nCicUntrusted.cmi
nCicUntrusted.cmx: nReference.cmx nCicUtils.cmx nCicSubstitution.cmx \
nCicUtils.mli \
nCicSubstitution.mli \
nCicEnvironment.mli \
- nCicPp.mli \
nCicReduction.mli \
nCicTypeChecker.mli \
- nCicUntrusted.mli
+ nCicUntrusted.mli \
+ nCicPp.mli
IMPLEMENTATION_FILES = \
nCic.ml $(INTERFACE_FILES:%.mli=%.ml)
(* the int must be 0 if the object has no body *)
type obj = NUri.uri * int * metasenv * substitution * obj_kind
+
+(* pretty-printing *)
+class virtual status =
+ object
+ method virtual ppterm: context:context -> subst:substitution ->
+ metasenv:metasenv -> ?margin:int -> ?inside_fix:bool -> term -> string
+
+ method virtual ppcontext: ?sep:string -> subst:substitution ->
+ metasenv:metasenv -> context -> string
+
+ method virtual ppmetasenv: subst:substitution -> metasenv -> string
+
+ method virtual ppsubst: metasenv:metasenv -> ?use_subst:bool -> substitution -> string
+
+ method virtual ppobj: obj -> string
+ end
+
+(* pretty-printing: same as vstatus, but all methods are concrete *)
+(* used only to declare concrete instances of subclasses of vstatus class *)
+class type cstatus =
+ object
+ inherit status
+
+ method ppterm: context:context -> subst:substitution ->
+ metasenv:metasenv -> ?margin:int -> ?inside_fix:bool -> term -> string
+
+ method ppcontext: ?sep:string -> subst:substitution ->
+ metasenv:metasenv -> context -> string
+
+ method ppmetasenv: subst:substitution -> metasenv -> string
+
+ method ppsubst: metasenv:metasenv -> ?use_subst:bool -> substitution -> string
+
+ method ppobj: obj -> string
+ end
let history = ref [];;
let frozen_list = ref [];;
-let get_obj = ref (fun _ -> assert false);;
-let set_get_obj f = get_obj := f;;
+let get_obj = ref (fun _ _ -> assert false);;
+let set_get_obj = (:=) get_obj;;
module F = Format
| C.Prop, C.Type _ -> `UnitOnly
;;
-let typecheck_obj,already_set = ref (fun _ -> assert false), ref false;;
+let typecheck_obj,already_set = ref (fun _ _ -> assert false), ref false;;
let set_typecheck_obj f =
if !already_set then
assert false
| `Exn e -> raise e
;;
-let check_and_add_obj ((u,_,_,_,_) as obj) =
+let check_and_add_obj (status:#NCic.status) ((u,_,_,_,_) as obj) =
let saved_frozen_list = !frozen_list in
try
frozen_list := (u,obj)::saved_frozen_list;
HLog.warn ("Typechecking of " ^ NUri.string_of_uri u);
- !typecheck_obj obj;
+ !typecheck_obj (status :> NCic.status) obj;
frozen_list := saved_frozen_list;
let obj' = `WellTyped obj in
NUri.UriHash.add cache u obj';
raise (Propagate (u,e))
;;
-let get_checked_obj u =
+let get_checked_obj status u =
if List.exists (fun (k,_) -> NUri.eq u k) !frozen_list
then
raise (CircularDependency (lazy (NUri.string_of_uri u)))
else
try NUri.UriHash.find cache u
- with Not_found -> check_and_add_obj (!get_obj u)
+ with Not_found -> check_and_add_obj status (!get_obj (status :> NCic.status) u)
;;
-let get_checked_obj u = to_exn get_checked_obj u;;
+let get_checked_obj (status:#NCic.status) u = to_exn (get_checked_obj status) u;;
-let check_and_add_obj ((u,_,_,_,_) as obj) =
+let check_and_add_obj status ((u,_,_,_,_) as obj) =
if NUri.UriHash.mem cache u then
raise (AlreadyDefined (lazy (NUri.string_of_uri u)))
else
- ignore (to_exn check_and_add_obj obj)
+ ignore (to_exn (check_and_add_obj status) obj)
;;
-let get_checked_decl = function
+let get_checked_decl status = function
| Ref.Ref (uri, Ref.Decl) ->
- (match get_checked_obj uri with
+ (match get_checked_obj status uri with
| _,height,_,_, C.Constant (rlv,name,None,ty,att) ->
rlv,name,ty,att,height
| _,_,_,_, C.Constant (_,_,Some _,_,_) ->
| _ -> prerr_endline "get_checked_decl on a non decl"; assert false
;;
-let get_checked_def = function
+let get_checked_def status = function
| Ref.Ref (uri, Ref.Def _) ->
- (match get_checked_obj uri with
+ (match get_checked_obj status uri with
| _,height,_,_, C.Constant (rlv,name,Some bo,ty,att) ->
rlv,name,bo,ty,att,height
| _,_,_,_, C.Constant (_,_,None,_,_) ->
| _ -> prerr_endline "get_checked_def on a non def"; assert false
;;
-let get_checked_indtys = function
+let get_checked_indtys status = function
| Ref.Ref (uri, (Ref.Ind (_,n,_)|Ref.Con (n,_,_))) ->
- (match get_checked_obj uri with
+ (match get_checked_obj status uri with
| _,_,_,_, C.Inductive (inductive,leftno,tys,att) ->
inductive,leftno,tys,att,n
| _ -> prerr_endline "get_checked_indtys on a non ind 2"; assert false)
| _ -> prerr_endline "get_checked_indtys on a non ind"; assert false
;;
-let get_checked_fixes_or_cofixes = function
+let get_checked_fixes_or_cofixes status = function
| Ref.Ref (uri, (Ref.Fix _|Ref.CoFix _))->
- (match get_checked_obj uri with
+ (match get_checked_obj status uri with
| _,height,_,_, C.Fixpoint (_,funcs,att) ->
funcs, att, height
| _ ->prerr_endline "get_checked_(co)fix on a non (co)fix 2";assert false)
| _ -> prerr_endline "get_checked_(co)fix on a non (co)fix"; assert false
;;
-let get_relevance (Ref.Ref (_, infos) as r) =
+let get_relevance status (Ref.Ref (_, infos) as r) =
match infos with
- Ref.Def _ -> let res,_,_,_,_,_ = get_checked_def r in res
- | Ref.Decl -> let res,_,_,_,_ = get_checked_decl r in res
+ Ref.Def _ -> let res,_,_,_,_,_ = get_checked_def status r in res
+ | Ref.Decl -> let res,_,_,_,_ = get_checked_decl status r in res
| Ref.Ind _ ->
- let _,_,tl,_,n = get_checked_indtys r in
+ let _,_,tl,_,n = get_checked_indtys status r in
let res,_,_,_ = List.nth tl n in
res
| Ref.Con (_,i,_) ->
- let _,_,tl,_,n = get_checked_indtys r in
+ let _,_,tl,_,n = get_checked_indtys status r in
let _,_,_,cl = List.nth tl n in
let res,_,_ = List.nth cl (i - 1) in
res
| Ref.Fix (fixno,_,_)
| Ref.CoFix fixno ->
- let fl,_,_ = get_checked_fixes_or_cofixes r in
+ let fl,_,_ = get_checked_fixes_or_cofixes status r in
let res,_,_,_,_ = List.nth fl fixno in
res
;;
exception BadDependency of string Lazy.t * exn;;
exception AlreadyDefined of string Lazy.t;;
-val set_get_obj: (NUri.uri -> NCic.obj) -> unit
+val set_get_obj: (NCic.status -> NUri.uri -> NCic.obj) -> unit
-val get_checked_obj: NUri.uri -> NCic.obj
+val get_checked_obj: #NCic.status -> NUri.uri -> NCic.obj
-val check_and_add_obj: NCic.obj -> unit
+val check_and_add_obj: #NCic.status -> NCic.obj -> unit
-val get_relevance: NReference.reference -> bool list
+val get_relevance: #NCic.status -> NReference.reference -> bool list
val get_checked_def:
- NReference.reference ->
+ #NCic.status -> NReference.reference ->
NCic.relevance * string * NCic.term * NCic.term * NCic.c_attr * int
(* the last integer is the index of the inductive type in the reference *)
val get_checked_indtys:
- NReference.reference ->
+ #NCic.status -> NReference.reference ->
bool * int * NCic.inductiveType list * NCic.i_attr * int
val get_checked_fixes_or_cofixes:
- NReference.reference ->
+ #NCic.status -> NReference.reference ->
NCic.inductiveFun list * NCic.f_attr * int
val invalidate_item:
val invalidate: unit -> unit
-val set_typecheck_obj: (NCic.obj -> unit) -> unit
+val set_typecheck_obj: (NCic.status -> NCic.obj -> unit) -> unit
(* =========== universes ============= *)
module R = NReference
module F = Format
-let head_beta_reduce = ref (fun ~upto:_ _ -> assert false);;
-let set_head_beta_reduce = (:=) head_beta_reduce;;
-
-let get_obj = ref (fun _ -> assert false);;
-let set_get_obj f = get_obj := f;;
-
-let r2s pp_fix_name r =
+let r2s status pp_fix_name r =
try
match r with
| R.Ref (u,R.Ind (_,i,_)) ->
- (match !get_obj u with
+ (match NCicEnvironment.get_checked_obj status u with
| _,_,_,_, C.Inductive (_,_,itl,_) ->
let _,name,_,_ = List.nth itl i in name
| _ -> assert false)
| R.Ref (u,R.Con (i,j,_)) ->
- (match !get_obj u with
+ (match NCicEnvironment.get_checked_obj status u with
| _,_,_,_, C.Inductive (_,_,itl,_) ->
let _,_,_,cl = List.nth itl i in
let _,name,_ = List.nth cl (j-1) in name
| _ -> assert false)
| R.Ref (u,(R.Decl | R.Def _)) ->
- (match !get_obj u with
+ (match NCicEnvironment.get_checked_obj status u with
| _,_,_,_, C.Constant (_,name,_,_,_) -> name
| _ -> assert false)
| R.Ref (u,(R.Fix (i,_,_)|R.CoFix i)) ->
- (match !get_obj u with
+ (match NCicEnvironment.get_checked_obj status u with
| _,_,_,_, C.Fixpoint (_,fl,_) ->
if pp_fix_name then
let _,name,_,_,_ = List.nth fl i in name
| `Vector -> "…"
;;
-let ppterm ~formatter:f ~context ~subst ~metasenv:_ ?(inside_fix=false) t =
+let ppterm status ~formatter:f ~context ~subst ~metasenv:_ ?(inside_fix=false) t =
let rec aux ?(toplevel=false) ctx = function
| C.Rel m ->
(try
F.fprintf f "%s" (if name = "_" then "__"^string_of_int m else name)
with Failure "nth" | Invalid_argument "List.nth" ->
F.fprintf f " -%d" (m - List.length ctx))
- | C.Const r -> F.fprintf f "%s" (r2s inside_fix r)
+ | C.Const r -> F.fprintf f "%s" (r2s status inside_fix r)
| C.Prod ("_",s,t) ->
if not toplevel then F.fprintf f "(";
F.fprintf f "@[<hov 1>";
if pl <> [] then
begin
F.fprintf f "@[<hov 2>%s ⇒@;"
- (try r2s inside_fix (R.mk_constructor 1 r)
+ (try r2s status inside_fix (R.mk_constructor 1 r)
with R.IllFormedReference _ -> "#ERROR#");
aux ~toplevel:true ctx (List.hd pl);
F.fprintf f "@]";
ignore(List.fold_left
(fun i t ->
F.fprintf f "@;| @[<hov 2>%s ⇒@;"
- (try r2s inside_fix (R.mk_constructor i r)
+ (try r2s status inside_fix (R.mk_constructor i r)
with R.IllFormedReference _ -> "#ERROR#");
aux ~toplevel:true ctx t;
F.fprintf f "@]";
aux ctx x
| C.Appl (C.Meta (n,lc) :: args) when List.mem_assoc n subst ->
let _,_,t,_ = List.assoc n subst in
- let hd = NCicSubstitution.subst_meta lc t in
+ let hd = NCicSubstitution.subst_meta status lc t in
aux ctx
- (!head_beta_reduce ~upto:(List.length args)
+ (NCicReduction.head_beta_reduce (status :> NCic.status) ~upto:(List.length args)
(match hd with
| NCic.Appl l -> NCic.Appl (l@args)
| _ -> NCic.Appl (hd :: args)))
F.fprintf f "?%s" (string_of_implicit_annotation annot)
| C.Meta (n,lc) when List.mem_assoc n subst ->
let _,_,t,_ = List.assoc n subst in
- aux ctx (NCicSubstitution.subst_meta lc t)
+ aux ctx (NCicSubstitution.subst_meta status lc t)
| C.Meta (n,(shift,C.Irl len)) ->
F.fprintf f "?%d(%d,%d)" n shift len
| C.Meta (n,(shift,C.Ctx l)) ->
F.fprintf f "?%d(%d,[" n shift;
if List.length l > 0 then
begin
- aux ctx (NCicSubstitution.lift shift (List.hd l));
+ aux ctx (NCicSubstitution.lift status shift (List.hd l));
List.iter (fun x -> F.fprintf f ",";aux ctx x)
- (List.map (NCicSubstitution.lift shift) (List.tl l));
+ (List.map (NCicSubstitution.lift status shift) (List.tl l));
end;
F.fprintf f "])"
| C.Sort s -> NCicEnvironment.ppsort f s
ppterm ~formatter ~context ~subst ~metasenv ?inside_fix t
;;
-let rec ppcontext ~formatter ?(sep="; ") ~subst ~metasenv = function
+let rec ppcontext status ~formatter ?(sep="; ") ~subst ~metasenv = function
| [] -> ()
| (name, NCic.Decl t) :: tl ->
- ppcontext ~formatter ~sep ~subst ~metasenv tl;
+ ppcontext status ~formatter ~sep ~subst ~metasenv tl;
F.fprintf formatter "%s: " name;
- ppterm ~formatter ~subst ~metasenv ~context:tl t;
+ ppterm status ~formatter ~subst ~metasenv ~context:tl t;
F.fprintf formatter "%s@;" sep
| (name, NCic.Def (bo,ty)) :: tl->
- ppcontext ~formatter ~sep ~subst ~metasenv tl;
+ ppcontext status ~formatter ~sep ~subst ~metasenv tl;
F.fprintf formatter "%s: " name;
- ppterm ~formatter ~subst ~metasenv ~context:tl ty;
+ ppterm status ~formatter ~subst ~metasenv ~context:tl ty;
F.fprintf formatter " := ";
- ppterm ~formatter ~subst ~metasenv ~context:tl bo;
+ ppterm status ~formatter ~subst ~metasenv ~context:tl bo;
F.fprintf formatter "%s@;" sep
;;
-let ppcontext ~formatter ?sep ~subst ~metasenv c =
+let ppcontext status ~formatter ?sep ~subst ~metasenv c =
F.fprintf formatter "@[<hov>";
- ppcontext ~formatter ?sep ~subst ~metasenv c;
+ ppcontext status ~formatter ?sep ~subst ~metasenv c;
F.fprintf formatter "@]";
;;
")"
;;
-let rec ppmetasenv ~formatter ~subst metasenv = function
+let rec ppmetasenv status ~formatter ~subst metasenv = function
| [] -> ()
| (i,(attrs, ctx, ty)) :: tl ->
F.fprintf formatter "@[<hov 2>";
- ppcontext ~formatter ~sep:"; " ~subst ~metasenv ctx;
+ ppcontext status ~formatter ~sep:"; " ~subst ~metasenv ctx;
F.fprintf formatter "@;⊢@;?%d%s :@;" i (ppmetaattrs attrs);
- ppterm ~formatter ~metasenv ~subst ~context:ctx ty;
+ ppterm status ~formatter ~metasenv ~subst ~context:ctx ty;
F.fprintf formatter "@]@\n";
- ppmetasenv ~formatter ~subst metasenv tl
+ ppmetasenv status ~formatter ~subst metasenv tl
;;
-let ppmetasenv ~formatter ~subst metasenv =
- ppmetasenv ~formatter ~subst metasenv metasenv
+let ppmetasenv status ~formatter ~subst metasenv =
+ ppmetasenv status ~formatter ~subst metasenv metasenv
;;
-let rec ppsubst ~formatter ~subst ~metasenv = function
+let rec ppsubst status ~formatter ~subst ~metasenv = function
| [] -> ()
| (i,(attrs, ctx, t, ty)) :: tl ->
- ppcontext ~formatter ~sep:"; " ~subst ~metasenv ctx;
+ ppcontext status ~formatter ~sep:"; " ~subst ~metasenv ctx;
F.fprintf formatter " ⊢ ?%d%s := " i (ppmetaattrs attrs);
- ppterm ~formatter ~metasenv ~subst ~context:ctx t;
+ ppterm status ~formatter ~metasenv ~subst ~context:ctx t;
F.fprintf formatter " : ";
- ppterm ~formatter ~metasenv ~subst ~context:ctx ty;
+ ppterm status ~formatter ~metasenv ~subst ~context:ctx ty;
F.fprintf formatter "\n";
- ppsubst ~formatter ~subst ~metasenv tl
+ ppsubst status ~formatter ~subst ~metasenv tl
;;
-let ppsubst ~formatter ~metasenv ?(use_subst=true) subst =
+let ppsubst status ~formatter ~metasenv ?(use_subst=true) subst =
let ssubst = if use_subst then subst else [] in
- ppsubst ~formatter ~metasenv ~subst:ssubst subst
+ ppsubst status ~formatter ~metasenv ~subst:ssubst subst
;;
let string_of_generated = function
[ string_of_generated g; string_of_flavour f; string_of_pragma p ]
;;
-let ppobj ~formatter (u,_,metasenv, subst, o) =
+let ppobj status ~formatter (u,_,metasenv, subst, o) =
F.fprintf formatter "metasenv:\n";
- ppmetasenv ~formatter ~subst metasenv;
+ ppmetasenv status ~formatter ~subst metasenv;
F.fprintf formatter "\n";
F.fprintf formatter "subst:\n";
(*ppsubst subst ~formatter ~metasenv;*) F.fprintf formatter "...";
~sep:(fun () -> F.fprintf formatter "@\n@[<hov 2>and ")
(fun (_,name,n,ty,bo) ->
F.fprintf formatter "%s on %d :@;" name n;
- ppterm ~formatter ~metasenv ~subst ~context:[] ty;
+ ppterm status ~formatter ~metasenv ~subst ~context:[] ty;
F.fprintf formatter "@]@;@[<hov 2>:=@;";
- ppterm ~formatter ~metasenv ~subst ~context:[] ~inside_fix:true bo;
+ ppterm status ~formatter ~metasenv ~subst ~context:[] ~inside_fix:true bo;
F.fprintf formatter "@]") fl;
F.fprintf formatter "@; %s" (string_of_fattrs attrs);
F.fprintf formatter "@]"
~sep:(fun () -> F.fprintf formatter "@\n@[<hov 2>and ")
(fun (_,name,ty,cl) ->
F.fprintf formatter "%s:@;" name;
- ppterm ~formatter ~metasenv ~subst ~context:[] ty;
+ ppterm status ~formatter ~metasenv ~subst ~context:[] ty;
F.fprintf formatter "@]@;@[<hov 3>:=@;";
HExtlib.list_iter_sep ~sep:(fun () -> F.fprintf formatter "@;")
(fun (_,name,ty) ->
F.fprintf formatter "| %s: " name;
- ppterm ~formatter ~metasenv ~subst ~context:[] ty;)
+ ppterm status ~formatter ~metasenv ~subst ~context:[] ty;)
cl;
F.fprintf formatter "@]"
) tyl ;
F.fprintf formatter "@]"
| NCic.Constant (_,name,None,ty, _) ->
F.fprintf formatter "{%s}@\n@[<hov 2>axiom %s :@;" (NUri.string_of_uri u) name;
- ppterm ~formatter ~metasenv ~subst ~context:[] ty;
+ ppterm status ~formatter ~metasenv ~subst ~context:[] ty;
F.fprintf formatter "@]@\n"
| NCic.Constant (_,name,Some bo,ty, _) ->
F.fprintf formatter "{%s}@\n@[<hov 0>@[<hov 2>definition %s :@;" (NUri.string_of_uri u) name;
- ppterm ~formatter ~metasenv ~subst ~context:[] ty;
+ ppterm status ~formatter ~metasenv ~subst ~context:[] ty;
F.fprintf formatter "@]@;@[<hov 2>:=@;";
- ppterm ~formatter ~metasenv ~subst ~context:[] bo;
+ ppterm status ~formatter ~metasenv ~subst ~context:[] bo;
F.fprintf formatter "@]@\n@]"
;;
-let ppterm ~context ~subst ~metasenv ?margin ?inside_fix t =
- on_buffer (ppterm ~context ~subst ~metasenv ?margin ?inside_fix) t
+let ppterm status ~context ~subst ~metasenv ?margin ?inside_fix t =
+ on_buffer (ppterm status ~context ~subst ~metasenv ?margin ?inside_fix) t
;;
-let ppcontext ?sep ~subst ~metasenv ctx =
- on_buffer (ppcontext ?sep ~subst ~metasenv) ctx
+let ppcontext status ?sep ~subst ~metasenv ctx =
+ on_buffer (ppcontext status ?sep ~subst ~metasenv) ctx
;;
-let ppmetasenv ~subst metasenv = on_buffer (ppmetasenv ~subst) metasenv;;
+let ppmetasenv status ~subst metasenv =
+ on_buffer (ppmetasenv status ~subst) metasenv
+;;
-let ppsubst ~metasenv ?use_subst subst =
- on_buffer (ppsubst ~metasenv ?use_subst) subst
+let ppsubst status ~metasenv ?use_subst subst =
+ on_buffer (ppsubst status ~metasenv ?use_subst) subst
;;
-let ppobj obj = on_buffer ppobj obj;;
+let ppobj status obj = on_buffer (ppobj status) obj;;
-let _ = NCicSubstitution.set_ppterm (ppterm ~margin:80);;
+class status =
+ object(self)
+ (* this method is meant to be overridden in ApplyTransformation *)
+ method ppterm = ppterm self
+ method ppcontext = ppcontext self
+ method ppmetasenv = ppmetasenv self
+ method ppsubst = ppsubst self
+ method ppobj = ppobj self
+ end
(* $Id$ *)
-val set_head_beta_reduce: (upto:int -> NCic.term -> NCic.term) -> unit
-val set_get_obj: (NUri.uri -> NCic.obj) -> unit
-
-val r2s: bool -> NReference.reference -> string
+val r2s: #NCic.status -> bool -> NReference.reference -> string
val string_of_flavour: NCic.def_flavour -> string
-val ppterm:
- context:NCic.context ->
- subst:NCic.substitution ->
- metasenv:NCic.metasenv ->
- ?margin:int ->
- ?inside_fix:bool ->
- NCic.term -> string
-
-val ppcontext:
- ?sep:string ->
- subst:NCic.substitution ->
- metasenv:NCic.metasenv ->
- NCic.context -> string
-
-val ppmetasenv:
- subst:NCic.substitution -> NCic.metasenv -> string
-
-val ppsubst:
- metasenv:NCic.metasenv -> ?use_subst:bool -> NCic.substitution -> string
-
-val ppobj: NCic.obj -> string
+(* low-level pretty printer;
+ all methods are meant to be overridden in ApplyTransformation *)
+class status: NCic.cstatus
(* variants that use a formatter
module Format : sig
type stack = RS.stack_term list
type config = int * env * C.term * stack
- let rec unwind (k,e,t,s) =
+ let rec unwind status (k,e,t,s) =
let t =
if k = 0 then t
else
- NCicSubstitution.psubst ~avoid_beta_redexes:true
- (RS.from_env_for_unwind ~unwind) e t
+ NCicSubstitution.psubst status ~avoid_beta_redexes:true
+ (RS.from_env_for_unwind ~unwind:(unwind status)) e t
in
if s = [] then t
- else C.Appl(t::(RS.from_stack_list_for_unwind ~unwind s))
+ else C.Appl(t::(RS.from_stack_list_for_unwind ~unwind:(unwind status) s))
;;
let list_nth l n = try List.nth l n with Failure _ -> assert false;;
| _,_ -> assert false
;;
- let rec reduce ~delta ?(subst = []) context : config -> config * bool =
+ let rec reduce status ~delta ?(subst = []) context : config -> config * bool =
let rec aux = function
| k, e, C.Rel n, s when n <= k ->
let k',e',t',s' = RS.from_env ~delta (list_nth e (n-1)) in
| k, _, C.Rel n, s as config (* when n > k *) ->
let x= try Some (List.nth context (n - 1 - k)) with Failure _ -> None in
(match x with
- | Some(_,C.Def(x,_)) -> aux (0,[],NCicSubstitution.lift (n - k) x,s)
+ | Some(_,C.Def(x,_)) -> aux (0,[],NCicSubstitution.lift status (n - k) x,s)
| _ -> config, true)
| (k, e, C.Meta (n,l), s) as config ->
(try
let _,_, term,_ = NCicUtils.lookup_subst n subst in
- aux (k, e, NCicSubstitution.subst_meta l term,s)
+ aux (k, e, NCicSubstitution.subst_meta status l term,s)
with NCicUtils.Subst_not_found _ -> config, true)
| (_, _, C.Implicit _, _) -> assert false
| (_, _, C.Sort _, _)
| (_, _, C.Prod _, _)
| (_, _, C.Lambda _, []) as config -> config, true
| (k, e, C.Lambda (_,_,t), p::s) ->
- aux (k+1, (RS.stack_to_env ~reduce:(reduce ~subst context) ~unwind p)::e, t,s)
+ aux (k+1, (RS.stack_to_env ~reduce:(reduce status ~subst context) ~unwind:(unwind status) p)::e, t,s)
| (k, e, C.LetIn (_,_,m,t), s) ->
- let m' = RS.compute_to_env ~reduce:(reduce ~subst context) ~unwind k e m in
+ let m' = RS.compute_to_env ~reduce:(reduce status ~subst context) ~unwind:(unwind status) k e m in
aux (k+1, m'::e, t, s)
| (_, _, C.Appl ([]|[_]), _) -> assert false
| (k, e, C.Appl (he::tl), s) ->
let tl' =
List.map (fun t->RS.compute_to_stack
- ~reduce:(reduce ~subst context) ~unwind (k,e,t,[])) tl
+ ~reduce:(reduce status ~subst context) ~unwind:(unwind status) (k,e,t,[])) tl
in
aux (k, e, he, tl' @ s)
| (_, _, C.Const
if delta >= height then
config, false
else
- let _,_,body,_,_,_ = NCicEnvironment.get_checked_def refer in
+ let _,_,body,_,_,_ = NCicEnvironment.get_checked_def status refer in
aux (0, [], body, s)
| (_, _, C.Const (Ref.Ref (_,
(Ref.Decl|Ref.Ind _|Ref.Con _|Ref.CoFix _))), _) as config ->
None -> config, true
| Some arg ->
let fixes,(_,_,pragma),_ =
- NCicEnvironment.get_checked_fixes_or_cofixes refer in
+ NCicEnvironment.get_checked_fixes_or_cofixes status refer in
if delta >= height then
match pragma with
| `Projection ->
| (_,_,C.Const (Ref.Ref (_,Ref.Con _)), _) as c ->
let new_s =
replace recindex s
- (RS.compute_to_stack ~reduce:(reduce ~subst context)
- ~unwind c) in
+ (RS.compute_to_stack ~reduce:(reduce status ~subst context)
+ ~unwind:(unwind status) c) in
let _,_,_,_,body = List.nth fixes fixno in
aux (0, [], body, new_s)
| _ -> config, true)
let decofix = function
| (_,_,C.Const(Ref.Ref(_,Ref.CoFix c)as refer),s)->
let cofixes,_,_ =
- NCicEnvironment.get_checked_fixes_or_cofixes refer in
+ NCicEnvironment.get_checked_fixes_or_cofixes status refer in
let _,_,_,_,body = List.nth cofixes c in
- let c,_ = reduce ~delta:0 ~subst context (0,[],body,s) in
+ let c,_ = reduce status ~delta:0 ~subst context (0,[],body,s) in
c
| config -> config
in
let match_head = k,e,term,[] in
- let reduced,_ = reduce ~delta:0 ~subst context match_head in
+ let reduced,_ = reduce status ~delta:0 ~subst context match_head in
(match decofix reduced with
| (_, _, C.Const (Ref.Ref (_,Ref.Con (_,j,_))),[]) ->
aux (k, e, List.nth pl (j-1), s)
aux
;;
- let whd ?(delta=0) ~subst context t =
- unwind (fst (reduce ~delta ~subst context (0, [], t, [])))
+ let whd status ?(delta=0) ~subst context t =
+ unwind status (fst (reduce status ~delta ~subst context (0, [], t, [])))
;;
end
let (===) x y = Pervasives.compare x y = 0 ;;
-let get_relevance = ref (fun ~metasenv:_ ~subst:_ _ _ -> assert false);;
+let get_relevance = ref (fun _ ~metasenv:_ ~subst:_ _ _ -> assert false);;
-let set_get_relevance f = get_relevance := f;;
+let set_get_relevance = (:=) get_relevance;;
-let alpha_eq ~test_lambda_source aux test_eq_only metasenv subst context t1 t2 =
+let alpha_eq (status:#NCic.status) ~test_lambda_source aux test_eq_only metasenv subst context
+ t1 t2 =
if t1 === t2 then
true
else
let l2 = NCicUtils.expand_local_context l2 in
(try List.for_all2
(fun t1 t2 -> aux test_eq_only context
- (NCicSubstitution.lift s1 t1)
- (NCicSubstitution.lift s2 t2))
+ (NCicSubstitution.lift status s1 t1)
+ (NCicSubstitution.lift status s2 t2))
l1 l2
with Invalid_argument "List.for_all2" ->
prerr_endline ("Meta " ^ string_of_int n1 ^
" occurrs with local contexts of different lenght\n"^
- NCicPp.ppterm ~metasenv ~subst ~context t1 ^ " === " ^
- NCicPp.ppterm ~metasenv ~subst ~context t2);
+ status#ppterm ~metasenv ~subst ~context t1 ^ " === " ^
+ status#ppterm ~metasenv ~subst ~context t2);
assert false) -> true
| C.Meta (n1,l1), _ ->
(try
let _,_,term,_ = NCicUtils.lookup_subst n1 subst in
- let term = NCicSubstitution.subst_meta l1 term in
+ let term = NCicSubstitution.subst_meta status l1 term in
aux test_eq_only context term t2
with NCicUtils.Subst_not_found _ -> false)
| _, C.Meta (n2,l2) ->
(try
let _,_,term,_ = NCicUtils.lookup_subst n2 subst in
- let term = NCicSubstitution.subst_meta l2 term in
+ let term = NCicSubstitution.subst_meta status l2 term in
aux test_eq_only context t1 term
with NCicUtils.Subst_not_found _ -> false)
| (C.Appl ((C.Const r1) as hd1::tl1), C.Appl (C.Const r2::tl2))
when (Ref.eq r1 r2 &&
- List.length (E.get_relevance r1) >= List.length tl1) ->
- let relevance = E.get_relevance r1 in
+ List.length (E.get_relevance status r1) >= List.length tl1) ->
+ let relevance = E.get_relevance status r1 in
(* if the types were convertible the following optimization is sound
let relevance = match r1 with
| Ref.Ref (_,Ref.Con (_,_,lno)) ->
with Invalid_argument _ -> false
| HExtlib.FailureAt fail ->
let relevance =
- !get_relevance ~metasenv ~subst context hd1 tl1 in
+ !get_relevance (status :> NCic.status) ~metasenv ~subst context hd1 tl1 in
let _,relevance = HExtlib.split_nth fail relevance in
let b,relevance = (match relevance with
| [] -> assert false
| (C.Appl (hd1::tl1), C.Appl (hd2::tl2)) ->
aux test_eq_only context hd1 hd2 &&
- let relevance = !get_relevance ~metasenv ~subst context hd1 tl1 in
+ let relevance = !get_relevance (status :> NCic.status) ~metasenv ~subst context hd1 tl1 in
(try
HExtlib.list_forall_default3
(fun t1 t2 b -> not b || aux true context t1 t2)
| (C.Match (Ref.Ref (_,Ref.Ind (_,tyno,_)) as ref1,outtype1,term1,pl1),
C.Match (ref2,outtype2,term2,pl2)) ->
- let _,_,itl,_,_ = E.get_checked_indtys ref1 in
+ let _,_,itl,_,_ = E.get_checked_indtys status ref1 in
let _,_,ty,_ = List.nth itl tyno in
let rec remove_prods ~subst context ty =
- let ty = whd ~subst context ty in
+ let ty = whd status ~subst context ty in
match ty with
| C.Sort _ -> ty
| C.Prod (name,so,ta) -> remove_prods ~subst ((name,(C.Decl so))::context) ta
;;
(* t1, t2 must be well-typed *)
-let are_convertible ~metasenv ~subst =
+let are_convertible status ~metasenv ~subst =
let rec aux test_eq_only context t1 t2 =
- let alpha_eq test_eq_only =
- alpha_eq ~test_lambda_source:false aux test_eq_only metasenv subst context
+ let alpha_eq status test_eq_only =
+ alpha_eq status ~test_lambda_source:false aux test_eq_only metasenv subst
+ context
in
- if alpha_eq test_eq_only t1 t2 then
+ if alpha_eq status test_eq_only t1 t2 then
true
else
let height_of = function
| _ -> 0
in
let put_in_whd m1 m2 =
- R.reduce ~delta:max_int ~subst context m1,
- R.reduce ~delta:max_int ~subst context m2
+ R.reduce status ~delta:max_int ~subst context m1,
+ R.reduce status ~delta:max_int ~subst context m2
in
let small_delta_step
((_,_,t1,_ as m1), norm1 as x1) ((_,_,t2,_ as m2), norm2 as x2)
=
assert(not (norm1 && norm2));
if norm1 then
- x1, R.reduce ~delta:(height_of t2 -1) ~subst context m2
+ x1, R.reduce status ~delta:(height_of t2 -1) ~subst context m2
else if norm2 then
- R.reduce ~delta:(height_of t1 -1) ~subst context m1, x2
+ R.reduce status ~delta:(height_of t1 -1) ~subst context m1, x2
else
let h1 = height_of t1 in
let h2 = height_of t2 in
let delta = if h1 = h2 then max 0 (h1 -1) else min h1 h2 in
- R.reduce ~delta ~subst context m1,
- R.reduce ~delta ~subst context m2
+ R.reduce status ~delta ~subst context m1,
+ R.reduce status ~delta ~subst context m2
in
let rec convert_machines test_eq_only
((k1,e1,t1,s1),norm1 as m1),((k2,e2,t2,s2), norm2 as m2)
=
- (alpha_eq test_eq_only
- (R.unwind (k1,e1,t1,[])) (R.unwind (k2,e2,t2,[])) &&
+ (alpha_eq status test_eq_only
+ (R.unwind status (k1,e1,t1,[])) (R.unwind status (k2,e2,t2,[])) &&
let relevance =
match t1 with
- C.Const r -> NCicEnvironment.get_relevance r
+ C.Const r -> NCicEnvironment.get_relevance status r
| _ -> [] in
try
HExtlib.list_forall_default3
aux false
;;
-let alpha_eq metasenv subst =
+let alpha_eq status metasenv subst =
let rec aux test_lambda_source context t1 t2 =
- alpha_eq ~test_lambda_source aux true metasenv subst context t1 t2
+ alpha_eq status ~test_lambda_source aux true metasenv subst context t1 t2
in
aux true
;;
-let rec head_beta_reduce ~delta ~upto ~subst t l =
+let rec head_beta_reduce status ~delta ~upto ~subst t l =
match upto, t, l with
| 0, C.Appl l1, _ -> C.Appl (l1 @ l)
| 0, t, [] -> t
| _, C.Meta (n,ctx), _ ->
(try
let _,_, term,_ = NCicUtils.lookup_subst n subst in
- head_beta_reduce ~delta ~upto ~subst
- (NCicSubstitution.subst_meta ctx term) l
+ head_beta_reduce status ~delta ~upto ~subst
+ (NCicSubstitution.subst_meta status ctx term) l
with NCicUtils.Subst_not_found _ -> if l = [] then t else C.Appl (t::l))
- | _, C.Appl (hd::tl), _ -> head_beta_reduce ~delta ~upto ~subst hd (tl @ l)
+ | _, C.Appl (hd::tl), _ -> head_beta_reduce status ~delta ~upto ~subst hd (tl @ l)
| _, C.Lambda(_,_,bo), arg::tl ->
- let bo = NCicSubstitution.subst arg bo in
- head_beta_reduce ~delta ~upto:(upto - 1) ~subst bo tl
+ let bo = NCicSubstitution.subst status arg bo in
+ head_beta_reduce status ~delta ~upto:(upto - 1) ~subst bo tl
| _, C.Const (Ref.Ref (_, Ref.Def height) as re), _
when delta <= height ->
- let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def re in
- head_beta_reduce ~upto ~delta ~subst bo l
+ let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def status re in
+ head_beta_reduce status ~upto ~delta ~subst bo l
| _, t, [] -> t
| _, t, _ -> C.Appl (t::l)
;;
-let head_beta_reduce ?(delta=max_int) ?(upto= -1) ?(subst=[]) t =
- head_beta_reduce ~delta ~upto ~subst t []
+let head_beta_reduce status ?(delta=max_int) ?(upto= -1) ?(subst=[]) t =
+ head_beta_reduce status ~delta ~upto ~subst t []
;;
type stack_item = RS.stack_term
let unwind = R.unwind
let _ =
- NCicUtils.set_head_beta_reduce (fun ~upto t -> head_beta_reduce ~upto t);
- NCicPp.set_head_beta_reduce (fun ~upto t -> head_beta_reduce ~upto t);
+ NCicUtils.set_head_beta_reduce
+ (fun status ~upto t -> head_beta_reduce status ~upto t);
;;
(* if n < 0, then splits all prods from an arity, returning a sort *)
-let rec split_prods ~subst context n te =
- match (n, R.whd ~subst context te) with
+let rec split_prods status ~subst context n te =
+ match (n, R.whd status ~subst context te) with
| (0, _) -> context,te
| (n, C.Sort _) when n <= 0 -> context,te
| (n, C.Prod (name,so,ta)) ->
- split_prods ~subst ((name,(C.Decl so))::context) (n - 1) ta
+ split_prods status ~subst ((name,(C.Decl so))::context) (n - 1) ta
| (_, _) -> raise (AssertFailure (lazy "split_prods"))
;;
val debug: bool ref
val whd :
- ?delta:int -> subst:NCic.substitution ->
- NCic.context -> NCic.term ->
- NCic.term
+ #NCic.status -> ?delta:int -> subst:NCic.substitution ->
+ NCic.context -> NCic.term -> NCic.term
val set_get_relevance :
- (metasenv:NCic.metasenv -> subst:NCic.substitution ->
+ (NCic.status -> metasenv:NCic.metasenv -> subst:NCic.substitution ->
NCic.context -> NCic.term -> NCic.term list -> bool list) -> unit
val are_convertible :
- metasenv:NCic.metasenv -> subst:NCic.substitution ->
+ #NCic.status -> metasenv:NCic.metasenv -> subst:NCic.substitution ->
NCic.context -> NCic.term -> NCic.term -> bool
delta reduction; if provided, ~upto is the maximum number of beta redexes
reduced *)
val head_beta_reduce:
- ?delta:int -> ?upto:int -> ?subst:NCic.substitution -> NCic.term -> NCic.term
+ #NCic.status -> ?delta:int -> ?upto:int -> ?subst:NCic.substitution ->
+ NCic.term -> NCic.term
type stack_item
type environment_item
type machine = int * environment_item list * NCic.term * stack_item list
val reduce_machine :
- delta:int -> ?subst:NCic.substitution -> NCic.context -> machine ->
- machine * bool
+ #NCic.status -> delta:int -> ?subst:NCic.substitution -> NCic.context ->
+ machine -> machine * bool
val from_stack : delta:int -> stack_item -> machine
val from_env : delta:int -> environment_item -> machine
-val unwind : machine -> NCic.term
+val unwind : #NCic.status -> machine -> NCic.term
val split_prods:
- subst:NCic.substitution -> NCic.context -> int -> NCic.term ->
+ #NCic.status -> subst:NCic.substitution -> NCic.context -> int -> NCic.term ->
NCic.context * NCic.term
(* to be used outside the kernel *)
val alpha_eq:
- NCic.metasenv -> NCic.substitution ->
- NCic.context -> NCic.term -> NCic.term -> bool
+ #NCic.status -> NCic.metasenv -> NCic.substitution -> NCic.context ->
+ NCic.term -> NCic.term -> bool
(* $Id$ *)
-let ppterm =
- ref (fun ~context:_ ~subst:_ ~metasenv:_ ?inside_fix _ ->
- let _ = inside_fix in assert false)
-;;
-let set_ppterm f = ppterm := f;;
-
module C = NCic
module Ref = NReference
let debug_print = fun _ -> ();;
-let lift_from ?(no_implicit=true) k n =
+let lift_from status ?(no_implicit=true) k n =
let rec liftaux k = function
| C.Rel m as t -> if m < k then t else C.Rel (m + n)
| C.Meta (i,(m,(C.Irl 0 as l))) when k <= m+1 -> C.Meta (i,(m,l))
| C.Implicit _ as t -> (* was the identity *)
if no_implicit then assert false
else t
- | t -> NCicUtils.map (fun _ k -> k + 1) k liftaux t
+ | t -> NCicUtils.map status (fun _ k -> k + 1) k liftaux t
in
liftaux k
;;
-let lift ?(from=1) ?(no_implicit=true) n t =
- if n = 0 then t else lift_from ~no_implicit from n t
+let lift status ?(from=1) ?(no_implicit=true) n t =
+ if n = 0 then t else lift_from status ~no_implicit from n t
;;
(* well typed and avoid_beta_redexes is true. *)
(* map_arg is ReductionStrategy.from_env_for_unwind when psubst is *)
(* used to implement nCicReduction.unwind' *)
-let rec psubst ?(avoid_beta_redexes=false) ?(no_implicit=true) map_arg args =
+let rec psubst status ?(avoid_beta_redexes=false) ?(no_implicit=true) map_arg args =
let nargs = List.length args in
let rec substaux k = function
| C.Rel n as t ->
if nargs <> 0 then C.Rel (n - nargs) else t
| n when n < k -> t
| n (* k <= n < k+nargs *) ->
- (try lift ~no_implicit (k-1) (map_arg (List.nth args (n-k)))
+ (try lift status ~no_implicit (k-1) (map_arg (List.nth args (n-k)))
with Failure _ | Invalid_argument _ -> assert false))
| C.Meta (i,(m,l)) as t when m >= k + nargs - 1 ->
if nargs <> 0 then C.Meta (i,(m-nargs,l)) else t
let lctx = NCicUtils.expand_local_context l in
C.Meta (i,(0,
C.Ctx (HExtlib.sharing_map
- (fun x -> substaux k (lift ~no_implicit m x)) lctx)))
+ (fun x -> substaux k (lift status ~no_implicit m x)) lctx)))
| C.Implicit _ as t ->
if no_implicit then assert false (* was identity *)
else t
| C.Lambda (_,_,bo) when avoid_beta_redexes ->
(* map_arg is here \x.x, Obj magic is needed because
* we don't have polymorphic recursion w/o records *)
- avoid (psubst
+ avoid (psubst status
~avoid_beta_redexes ~no_implicit
Obj.magic [Obj.magic arg] bo) tl'
| _ -> if he == he' && args == tl then t else C.Appl (he'::args))
in
let tl = HExtlib.sharing_map (substaux k) tl in
avoid (substaux k he) tl
- | t -> NCicUtils.map (fun _ k -> k + 1) k substaux t
+ | t -> NCicUtils.map status (fun _ k -> k + 1) k substaux t
in
substaux 1
;;
-let subst ?avoid_beta_redexes ?no_implicit arg =
- psubst ?avoid_beta_redexes ?no_implicit(fun x -> x)[arg];;
+let subst status ?avoid_beta_redexes ?no_implicit arg =
+ psubst status ?avoid_beta_redexes ?no_implicit(fun x -> x)[arg];;
(* subst_meta (n, C.Ctx [t_1 ; ... ; t_n]) t *)
(* returns the term [t] where [Rel i] is substituted with [t_i] lifted by n *)
(* [t_i] is lifted as usual when it crosses an abstraction *)
-(* subst_meta (n, (C.Irl _ | C.Ctx [])) t | -> lift n t *)
-let subst_meta = function
+(* subst_meta (n, (C.Irl _ | C.Ctx [])) t | -> lift status n t *)
+let subst_meta status = function
| m, C.Irl _
- | m, C.Ctx [] -> lift m
- | m, C.Ctx l -> psubst (lift m) l
+ | m, C.Ctx [] -> lift status m
+ | m, C.Ctx l -> psubst status (lift status m) l
;;
(* $Id$ *)
-val set_ppterm : (context:NCic.context ->
- subst:NCic.substitution ->
- metasenv:NCic.metasenv ->
- ?inside_fix:bool ->
- NCic.term -> string) -> unit
-
-val lift_from : ?no_implicit:bool -> int -> int -> NCic.term -> NCic.term
+val lift_from : #NCic.status -> ?no_implicit:bool -> int -> int -> NCic.term -> NCic.term
(* lift n t *)
(* lifts [t] of [n] *)
(* [from] default 1, lifts only indexes >= [from] *)
(* NOTE: the opposite function (delift_rels) is defined in CicMetaSubst *)
(* since it needs to restrict the metavariables in case of failure *)
-val lift : ?from:int -> ?no_implicit:bool -> int -> NCic.term -> NCic.term
+val lift : #NCic.status -> ?from:int -> ?no_implicit:bool -> int -> NCic.term -> NCic.term
(* subst t1 t2 *)
(* substitutes [t1] for [Rel 1] in [t2] *)
(* are generated. WARNING: the substitution can diverge when t2 is not *)
(* well typed and avoid_beta_redexes is true. *)
val subst :
- ?avoid_beta_redexes:bool -> ?no_implicit:bool ->
+ #NCic.status -> ?avoid_beta_redexes:bool -> ?no_implicit:bool ->
NCic.term -> NCic.term -> NCic.term
(* psubst [avoid] [map_arg] [args] [t]
* the function is ReductionStrategy.from_env_for_unwind when psubst is
* used to implement nCicReduction.unwind' *)
val psubst :
- ?avoid_beta_redexes:bool -> ?no_implicit:bool ->
+ #NCic.status -> ?avoid_beta_redexes:bool -> ?no_implicit:bool ->
('a -> NCic.term) -> 'a list -> NCic.term ->
NCic.term
(* returns the term [t] where [Rel i] is substituted with [t_i] lifted by n *)
(* [t_i] is lifted as usual when it crosses an abstraction *)
(* subst_meta (n, Irl _) t -> lift n t *)
-val subst_meta : NCic.local_context -> NCic.term -> NCic.term
+val subst_meta : #NCic.status -> NCic.local_context -> NCic.term -> NCic.term
module S = NCicSubstitution
module U = NCicUtils
module E = NCicEnvironment
-module PP = NCicPp
exception TypeCheckerFailure of string Lazy.t
exception AssertFailure of string Lazy.t
(* for debugging only
let string_of_recfuns ~subst ~metasenv ~context l =
- let pp = PP.ppterm ~subst ~metasenv ~context in
+ let pp = status#ppterm ~subst ~metasenv ~context in
let safe, rest = List.partition (function (_,Safe) -> true | _ -> false) l in
let dang,unf = List.partition (function (_,UnfFix _)-> false | _->true)rest in
"\n\tsafes: "^String.concat "," (List.map (fun (i,_)->pp (C.Rel i)) safe) ^
(let rec f = function 0 -> [] | n -> true :: f (n-1) in f j) bos
;;
-let debruijn uri number_of_types ~subst context =
+let debruijn status uri number_of_types ~subst context =
(* manca la subst! *)
let rec aux k t =
match t with
| C.Meta (i,(s,l)) ->
(try
let _,_,term,_ = U.lookup_subst i subst in
- let ts = S.subst_meta (0,l) term in
+ let ts = S.subst_meta status (0,l) term in
let ts' = aux (k-s) ts in
if ts == ts' then t else ts'
with U.Subst_not_found _ ->
| C.Const (Ref.Ref (uri1,(Ref.Fix (no,_,_) | Ref.CoFix no)))
| C.Const (Ref.Ref (uri1,Ref.Ind (_,no,_))) when NUri.eq uri uri1 ->
C.Rel (k + number_of_types - no)
- | t -> U.map (fun _ k -> k+1) k aux t
+ | t -> U.map status (fun _ k -> k+1) k aux t
in
aux (List.length context)
;;
-let sort_of_prod ~metasenv ~subst context (name,s) t (t1, t2) =
- let t1 = R.whd ~subst context t1 in
- let t2 = R.whd ~subst ((name,C.Decl s)::context) t2 in
+let sort_of_prod (status:#NCic.status) ~metasenv ~subst context (name,s) t (t1, t2) =
+ let t1 = R.whd status ~subst context t1 in
+ let t2 = R.whd status ~subst ((name,C.Decl s)::context) t2 in
match t1, t2 with
| C.Sort _, C.Sort C.Prop -> t2
| C.Sort (C.Type u1), C.Sort (C.Type u2) ->
in
raise (TypeCheckerFailure (lazy (Printf.sprintf
"%s is expected to be a type, but its type is %s that is not a sort"
- (PP.ppterm ~subst ~metasenv ~context y)
- (PP.ppterm ~subst ~metasenv ~context x))))
+ (status#ppterm ~subst ~metasenv ~context y)
+ (status#ppterm ~subst ~metasenv ~context x))))
;;
(* instantiate_parameters ps (x1:T1)...(xn:Tn)C *)
(* returns ((x_|ps|:T_|ps|)...(xn:Tn)C){ps_1 / x1 ; ... ; ps_|ps| / x_|ps|} *)
-let rec instantiate_parameters params c =
+let rec instantiate_parameters status params c =
match c, params with
| c,[] -> c
- | C.Prod (_,_,ta), he::tl -> instantiate_parameters tl (S.subst he ta)
+ | C.Prod (_,_,ta), he::tl -> instantiate_parameters status tl (S.subst status he ta)
| _,_ -> raise (AssertFailure (lazy "1"))
;;
-let specialize_inductive_type_constrs ~subst context ty_term =
- match R.whd ~subst context ty_term with
+let specialize_inductive_type_constrs status ~subst context ty_term =
+ match R.whd status ~subst context ty_term with
| C.Const (Ref.Ref (_,Ref.Ind _) as ref)
| C.Appl (C.Const (Ref.Ref (_,Ref.Ind _) as ref) :: _ ) as ty ->
let args = match ty with C.Appl (_::tl) -> tl | _ -> [] in
- let _, leftno, itl, _, i = E.get_checked_indtys ref in
+ let _, leftno, itl, _, i = E.get_checked_indtys status ref in
let left_args,_ = HExtlib.split_nth leftno args in
let _,_,_,cl = List.nth itl i in
List.map
- (fun (rel,name,ty) -> rel, name, instantiate_parameters left_args ty) cl
+ (fun (rel,name,ty) -> rel, name, instantiate_parameters status left_args ty) cl
| _ -> assert false
;;
-let specialize_and_abstract_constrs ~subst r_uri r_len context ty_term =
- let cl = specialize_inductive_type_constrs ~subst context ty_term in
+let specialize_and_abstract_constrs status ~subst r_uri r_len context ty_term =
+ let cl = specialize_inductive_type_constrs status ~subst context ty_term in
let len = List.length context in
let context_dcl =
- match E.get_checked_obj r_uri with
+ match E.get_checked_obj status r_uri with
| _,_,_,_, C.Inductive (_,_,tys,_) ->
context @ List.map (fun (_,name,arity,_) -> name,C.Decl arity) tys
| _ -> assert false
in
context_dcl,
- List.map (fun (_,id,ty) -> id, debruijn r_uri r_len ~subst context ty) cl,
+ List.map (fun (_,id,ty) -> id, debruijn status r_uri r_len ~subst context ty) cl,
len, len + r_len
;;
exception DoesOccur;;
-let does_not_occur ~subst context n nn t =
+let does_not_occur status ~subst context n nn t =
let rec aux k _ = function
| C.Rel m when m > n+k && m <= nn+k -> raise DoesOccur
| C.Rel m when m <= k || m > nn+k -> ()
(* possible optimization here: try does_not_occur on l and
perform substitution only if DoesOccur is raised *)
let _,_,term,_ = U.lookup_subst mno subst in
- aux (k-s) () (S.subst_meta (0,l) term)
+ aux (k-s) () (S.subst_meta status (0,l) term)
with U.Subst_not_found _ -> () (*match l with
| C.Irl len -> if not (n+k >= s+len || s > nn+k) then raise DoesOccur
| C.Ctx lc -> List.iter (aux (k-s) ()) lc*))
with DoesOccur -> false
;;
-let rec eat_lambdas ~subst ~metasenv context n te =
- match (n, R.whd ~subst context te) with
+let rec eat_lambdas (status:#NCic.status) ~subst ~metasenv context n te =
+ match (n, R.whd status ~subst context te) with
| (0, _) -> (te, context)
| (n, C.Lambda (name,so,ta)) when n > 0 ->
- eat_lambdas ~subst ~metasenv ((name,(C.Decl so))::context) (n - 1) ta
+ eat_lambdas status ~subst ~metasenv ((name,(C.Decl so))::context) (n - 1) ta
| (n, te) ->
raise (AssertFailure (lazy (Printf.sprintf "eat_lambdas (%d, %s)" n
- (PP.ppterm ~subst ~metasenv ~context te))))
+ (status#ppterm ~subst ~metasenv ~context te))))
;;
-let rec eat_or_subst_lambdas
+let rec eat_or_subst_lambdas status
~subst ~metasenv n te to_be_subst args (context,_,_ as k)
=
- match n, R.whd ~subst context te, to_be_subst, args with
+ match n, R.whd status ~subst context te, to_be_subst, args with
| (n, C.Lambda (_,_,ta),true::to_be_subst,arg::args) when n > 0 ->
- eat_or_subst_lambdas ~subst ~metasenv (n - 1) (S.subst arg ta)
+ eat_or_subst_lambdas status ~subst ~metasenv (n - 1) (S.subst status arg ta)
to_be_subst args k
| (n, C.Lambda (name,so,ta),false::to_be_subst,_::args) when n > 0 ->
- eat_or_subst_lambdas ~subst ~metasenv (n - 1) ta to_be_subst args
+ eat_or_subst_lambdas status ~subst ~metasenv (n - 1) ta to_be_subst args
(shift_k (name,(C.Decl so)) k)
| (_, te, _, _) -> te, k
;;
-let check_homogeneous_call ~subst context indparamsno n uri reduct tl =
+let check_homogeneous_call (status:#NCic.status) ~subst context indparamsno n uri reduct tl =
let last =
List.fold_left
(fun k x ->
if k = 0 then 0
else
- match R.whd ~subst context x with
+ match R.whd status ~subst context x with
| C.Rel m when m = n - (indparamsno - k) -> k - 1
| _ -> raise (TypeCheckerFailure (lazy
("Argument "^string_of_int (indparamsno - k + 1) ^ " (of " ^
string_of_int indparamsno ^ " fixed) is not homogeneous in "^
- "appl:\n"^ PP.ppterm ~context ~subst ~metasenv:[] reduct))))
+ "appl:\n"^ status#ppterm ~context ~subst ~metasenv:[] reduct))))
indparamsno tl
in
if last <> 0 then
(* Inductive types being checked for positivity have *)
(* indexes x s.t. n < x <= nn. *)
-let rec weakly_positive ~subst context n nn uri indparamsno posuri te =
+let rec weakly_positive status ~subst context n nn uri indparamsno posuri te =
(*CSC: Not very nice. *)
let dummy = C.Sort C.Prop in
(*CSC: to be moved in cicSubstitution? *)
when NUri.eq uri' uri ->
let _, rargs = HExtlib.split_nth lno tl in
if rargs = [] then dummy else C.Appl (dummy :: rargs)
- | t -> U.map (fun _ x->x) () subst_inductive_type_with_dummy t
+ | t -> U.map status (fun _ x->x) () subst_inductive_type_with_dummy t
in
(* this function has the same semantics of are_all_occurrences_positive
but the i-th context entry role is played by dummy and some checks
are skipped because we already know that are_all_occurrences_positive
of uri in te. *)
let rec aux context n nn te =
- match R.whd ~subst context te with
+ match R.whd status ~subst context te with
| t when t = dummy -> true
| C.Meta (i,lc) ->
(try
let _,_,term,_ = U.lookup_subst i subst in
- let t = S.subst_meta lc term in
- weakly_positive ~subst context n nn uri indparamsno posuri t
+ let t = S.subst_meta status lc term in
+ weakly_positive status ~subst context n nn uri indparamsno posuri t
with U.Subst_not_found _ -> true)
| C.Appl (te::rargs) when te = dummy ->
- List.for_all (does_not_occur ~subst context n nn) rargs
+ List.for_all (does_not_occur status ~subst context n nn) rargs
| C.Prod (name,source,dest) when
- does_not_occur ~subst ((name,C.Decl source)::context) 0 1 dest ->
+ does_not_occur status ~subst ((name,C.Decl source)::context) 0 1 dest ->
(* dummy abstraction, so we behave as in the anonimous case *)
- strictly_positive ~subst context n nn indparamsno posuri source &&
+ strictly_positive status ~subst context n nn indparamsno posuri source &&
aux ((name,C.Decl source)::context) (n + 1) (nn + 1) dest
| C.Prod (name,source,dest) ->
- does_not_occur ~subst context n nn source &&
+ does_not_occur status ~subst context n nn source &&
aux ((name,C.Decl source)::context) (n + 1) (nn + 1) dest
| _ ->
raise (TypeCheckerFailure (lazy "Malformed inductive constructor type"))
in
aux context n nn (subst_inductive_type_with_dummy () te)
-and strictly_positive ~subst context n nn indparamsno posuri te =
- match R.whd ~subst context te with
- | t when does_not_occur ~subst context n nn t -> true
+and strictly_positive status ~subst context n nn indparamsno posuri te =
+ match R.whd status ~subst context te with
+ | t when does_not_occur status ~subst context n nn t -> true
| C.Meta (i,lc) ->
(try
let _,_,term,_ = U.lookup_subst i subst in
- let t = S.subst_meta lc term in
- strictly_positive ~subst context n nn indparamsno posuri t
+ let t = S.subst_meta status lc term in
+ strictly_positive status ~subst context n nn indparamsno posuri t
with U.Subst_not_found _ -> true)
| C.Rel _ when indparamsno = 0 -> true
| C.Appl ((C.Rel m)::tl) as reduct when m > n && m <= nn ->
- check_homogeneous_call ~subst context indparamsno n posuri reduct tl;
- List.for_all (does_not_occur ~subst context n nn) tl
+ check_homogeneous_call status ~subst context indparamsno n posuri reduct tl;
+ List.for_all (does_not_occur status ~subst context n nn) tl
| C.Prod (name,so,ta) ->
- does_not_occur ~subst context n nn so &&
- strictly_positive ~subst ((name,C.Decl so)::context) (n+1) (nn+1)
+ does_not_occur status ~subst context n nn so &&
+ strictly_positive status ~subst ((name,C.Decl so)::context) (n+1) (nn+1)
indparamsno posuri ta
| C.Appl (C.Const (Ref.Ref (uri,Ref.Ind _) as r)::tl) ->
- let _,paramsno,tyl,_,i = E.get_checked_indtys r in
+ let _,paramsno,tyl,_,i = E.get_checked_indtys status r in
let _,name,ity,cl = List.nth tyl i in
let ok = List.length tyl = 1 in
let params, arguments = HExtlib.split_nth paramsno tl in
- let lifted_params = List.map (S.lift 1) params in
+ let lifted_params = List.map (S.lift status 1) params in
let cl =
- List.map (fun (_,_,te) -> instantiate_parameters lifted_params te) cl
+ List.map (fun (_,_,te) -> instantiate_parameters status lifted_params te) cl
in
ok &&
- List.for_all (does_not_occur ~subst context n nn) arguments &&
+ List.for_all (does_not_occur status ~subst context n nn) arguments &&
List.for_all
- (weakly_positive ~subst ((name,C.Decl ity)::context) (n+1) (nn+1)
+ (weakly_positive status ~subst ((name,C.Decl ity)::context) (n+1) (nn+1)
uri indparamsno posuri) cl
| _ -> false
(* the inductive type indexes are s.t. n < x <= nn *)
-and are_all_occurrences_positive ~subst context uri indparamsno i n nn te =
- match R.whd ~subst context te with
+and are_all_occurrences_positive (status:#NCic.status) ~subst context uri indparamsno i n nn te =
+ match R.whd status ~subst context te with
| C.Appl ((C.Rel m)::tl) as reduct when m = i ->
- check_homogeneous_call ~subst context indparamsno n uri reduct tl;
- List.for_all (does_not_occur ~subst context n nn) tl
+ check_homogeneous_call status ~subst context indparamsno n uri reduct tl;
+ List.for_all (does_not_occur status ~subst context n nn) tl
| C.Rel m when m = i ->
if indparamsno = 0 then
true
(lazy ("Non-positive occurence in mutual inductive definition(s) [3]"^
NUri.string_of_uri uri)))
| C.Prod (name,source,dest) when
- does_not_occur ~subst ((name,C.Decl source)::context) 0 1 dest ->
- strictly_positive ~subst context n nn indparamsno uri source &&
- are_all_occurrences_positive ~subst
+ does_not_occur status ~subst ((name,C.Decl source)::context) 0 1 dest ->
+ strictly_positive status ~subst context n nn indparamsno uri source &&
+ are_all_occurrences_positive status ~subst
((name,C.Decl source)::context) uri indparamsno
(i+1) (n + 1) (nn + 1) dest
| C.Prod (name,source,dest) ->
- if not (does_not_occur ~subst context n nn source) then
+ if not (does_not_occur status ~subst context n nn source) then
raise (TypeCheckerFailure (lazy ("Non-positive occurrence in "^
- PP.ppterm ~context ~metasenv:[] ~subst te)));
- are_all_occurrences_positive ~subst ((name,C.Decl source)::context)
+ status#ppterm ~context ~metasenv:[] ~subst te)));
+ are_all_occurrences_positive status ~subst ((name,C.Decl source)::context)
uri indparamsno (i+1) (n + 1) (nn + 1) dest
| _ ->
raise
exception NotGuarded of string Lazy.t;;
-let type_of_branch ~subst context leftno outty cons tycons =
+let type_of_branch (status:#NCic.status) ~subst context leftno outty cons tycons =
let rec aux liftno context cons tycons =
- match R.whd ~subst context tycons with
- | C.Const (Ref.Ref (_,Ref.Ind _)) -> C.Appl [S.lift liftno outty ; cons]
+ match R.whd status ~subst context tycons with
+ | C.Const (Ref.Ref (_,Ref.Ind _)) -> C.Appl [S.lift status liftno outty ; cons]
| C.Appl (C.Const (Ref.Ref (_,Ref.Ind _))::tl) ->
let _,arguments = HExtlib.split_nth leftno tl in
- C.Appl (S.lift liftno outty::arguments@[cons])
+ C.Appl (S.lift status liftno outty::arguments@[cons])
| C.Prod (name,so,de) ->
let cons =
- match S.lift 1 cons with
+ match S.lift status 1 cons with
| C.Appl l -> C.Appl (l@[C.Rel 1])
| t -> C.Appl [t ; C.Rel 1]
in
C.Prod (name,so, aux (liftno+1) ((name,(C.Decl so))::context) cons de)
| t -> raise (AssertFailure
- (lazy ("type_of_branch, the contructor has type: " ^ NCicPp.ppterm
+ (lazy ("type_of_branch, the contructor has type: " ^ status#ppterm
~metasenv:[] ~context:[] ~subst:[] t)))
in
aux 0 context cons tycons
;;
-let rec typeof ~subst ~metasenv context term =
+let rec typeof (status:#NCic.status) ~subst ~metasenv context term =
let rec typeof_aux context =
- fun t -> (*prerr_endline (PP.ppterm ~metasenv ~subst ~context t);*)
+ fun t -> (*prerr_endline (status#ppterm ~metasenv ~subst ~context t);*)
match t with
| C.Rel n ->
(try
match List.nth context (n - 1) with
- | (_,C.Decl ty) -> S.lift n ty
- | (_,C.Def (_,ty)) -> S.lift n ty
+ | (_,C.Decl ty) -> S.lift status n ty
+ | (_,C.Def (_,ty)) -> S.lift status n ty
with Failure _ ->
raise (TypeCheckerFailure (lazy ("unbound variable " ^ string_of_int n
- ^" under: " ^ NCicPp.ppcontext ~metasenv ~subst context))))
+ ^" under: " ^ status#ppcontext ~metasenv ~subst context))))
| C.Sort s ->
(try C.Sort (NCicEnvironment.typeof_sort s)
with
(* match ty with C.Implicit _ -> assert false | _ -> c,ty *)
with U.Meta_not_found _ ->
raise (AssertFailure (lazy (Printf.sprintf
- "%s not found in:\n%s" (PP.ppterm ~subst ~metasenv ~context t)
- (PP.ppmetasenv ~subst metasenv)
+ "%s not found in:\n%s" (status#ppterm ~subst ~metasenv ~context t)
+ (status#ppmetasenv ~subst metasenv)
)))
in
check_metasenv_consistency t ~subst ~metasenv context canonical_ctx l;
- S.subst_meta l ty
- | C.Const ref -> type_of_constant ref
+ S.subst_meta status l ty
+ | C.Const ref -> type_of_constant status ref
| C.Prod (name,s,t) ->
let sort1 = typeof_aux context s in
let sort2 = typeof_aux ((name,(C.Decl s))::context) t in
- sort_of_prod ~metasenv ~subst context (name,s) t (sort1,sort2)
+ sort_of_prod status ~metasenv ~subst context (name,s) t (sort1,sort2)
| C.Lambda (n,s,t) ->
let sort = typeof_aux context s in
- (match R.whd ~subst context sort with
+ (match R.whd status ~subst context sort with
| C.Meta _ | C.Sort _ -> ()
| _ ->
raise
(TypeCheckerFailure (lazy (Printf.sprintf
("Not well-typed lambda-abstraction: " ^^
"the source %s should be a type; instead it is a term " ^^
- "of type %s") (PP.ppterm ~subst ~metasenv ~context s)
- (PP.ppterm ~subst ~metasenv ~context sort)))));
+ "of type %s") (status#ppterm ~subst ~metasenv ~context s)
+ (status#ppterm ~subst ~metasenv ~context sort)))));
let ty = typeof_aux ((n,(C.Decl s))::context) t in
C.Prod (n,s,ty)
| C.LetIn (n,ty,t,bo) ->
let ty_t = typeof_aux context t in
let _ = typeof_aux context ty in
- if not (R.are_convertible ~metasenv ~subst context ty_t ty) then
+ if not (R.are_convertible status ~metasenv ~subst context ty_t ty) then
raise
(TypeCheckerFailure
(lazy (Printf.sprintf
"The type of %s is %s but it is expected to be %s"
- (PP.ppterm ~subst ~metasenv ~context t)
- (PP.ppterm ~subst ~metasenv ~context ty_t)
- (PP.ppterm ~subst ~metasenv ~context ty))))
+ (status#ppterm ~subst ~metasenv ~context t)
+ (status#ppterm ~subst ~metasenv ~context ty_t)
+ (status#ppterm ~subst ~metasenv ~context ty))))
else
let ty_bo = typeof_aux ((n,C.Def (t,ty))::context) bo in
- S.subst ~avoid_beta_redexes:true t ty_bo
+ S.subst status ~avoid_beta_redexes:true t ty_bo
| C.Appl (he::(_::_ as args)) ->
let ty_he = typeof_aux context he in
let args_with_ty = List.map (fun t -> t, typeof_aux context t) args in
- eat_prods ~subst ~metasenv context he ty_he args_with_ty
+ eat_prods status ~subst ~metasenv context he ty_he args_with_ty
| C.Appl _ -> raise (AssertFailure (lazy "Appl of length < 2"))
| C.Match (Ref.Ref (_,Ref.Ind (_,tyno,_)) as r,outtype,term,pl) ->
let outsort = typeof_aux context outtype in
- let _,leftno,itl,_,_ = E.get_checked_indtys r in
+ let _,leftno,itl,_,_ = E.get_checked_indtys status r in
let constructorsno =
let _,_,_,cl = List.nth itl tyno in List.length cl
in
let parameters, arguments =
- let ty = R.whd ~subst context (typeof_aux context term) in
+ let ty = R.whd status ~subst context (typeof_aux context term) in
let r',tl =
match ty with
C.Const (Ref.Ref (_,Ref.Ind _) as r') -> r',[]
raise
(TypeCheckerFailure (lazy (Printf.sprintf
"Case analysis: analysed term %s is not an inductive one"
- (PP.ppterm ~subst ~metasenv ~context term)))) in
+ (status#ppterm ~subst ~metasenv ~context term)))) in
if not (Ref.eq r r') then
raise
(TypeCheckerFailure (lazy (Printf.sprintf
("Case analysys: analysed term type is %s, but is expected " ^^
"to be (an application of) %s")
- (PP.ppterm ~subst ~metasenv ~context ty)
- (PP.ppterm ~subst ~metasenv ~context (C.Const r')))))
+ (status#ppterm ~subst ~metasenv ~context ty)
+ (status#ppterm ~subst ~metasenv ~context (C.Const r')))))
else
try HExtlib.split_nth leftno tl
with
Failure _ ->
raise (TypeCheckerFailure (lazy (Printf.sprintf
"%s is partially applied"
- (PP.ppterm ~subst ~metasenv ~context ty)))) in
+ (status#ppterm ~subst ~metasenv ~context ty)))) in
(* let's control if the sort elimination is allowed: [(I q1 ... qr)|B] *)
let sort_of_ind_type =
if parameters = [] then C.Const r
else C.Appl ((C.Const r)::parameters) in
let type_of_sort_of_ind_ty = typeof_aux context sort_of_ind_type in
- check_allowed_sort_elimination ~subst ~metasenv r context
+ check_allowed_sort_elimination status ~subst ~metasenv r context
sort_of_ind_type type_of_sort_of_ind_ty outsort;
(* let's check if the type of branches are right *)
if List.length pl <> constructorsno then
let ty_p = typeof_aux context p in
let ty_cons = typeof_aux context cons in
let ty_branch =
- type_of_branch ~subst context leftno outtype cons ty_cons
+ type_of_branch status ~subst context leftno outtype cons ty_cons
in
- j+1, R.are_convertible ~metasenv ~subst context ty_p ty_branch,
+ j+1, R.are_convertible status ~metasenv ~subst context ty_p ty_branch,
ty_p, ty_branch
else
j,false,old_p_ty,old_exp_p_ty
(TypeCheckerFailure
(lazy (Printf.sprintf ("Branch for constructor %s :=\n%s\n"^^
"has type %s\nnot convertible with %s")
- (PP.ppterm ~subst ~metasenv ~context
+ (status#ppterm ~subst ~metasenv ~context
(C.Const (Ref.mk_constructor (j-1) r)))
- (PP.ppterm ~metasenv ~subst ~context (List.nth pl (j-2)))
- (PP.ppterm ~metasenv ~subst ~context p_ty)
- (PP.ppterm ~metasenv ~subst ~context exp_p_ty))));
+ (status#ppterm ~metasenv ~subst ~context (List.nth pl (j-2)))
+ (status#ppterm ~metasenv ~subst ~context p_ty)
+ (status#ppterm ~metasenv ~subst ~context exp_p_ty))));
let res = outtype::arguments@[term] in
- R.head_beta_reduce (C.Appl res)
+ R.head_beta_reduce status (C.Appl res)
| C.Match _ -> assert false
(* check_metasenv_consistency checks that the "canonical" context of a
| _,_,[] ->
raise (AssertFailure (lazy (Printf.sprintf
"(2) Local and canonical context %s have different lengths"
- (PP.ppterm ~subst ~context ~metasenv term))))
+ (status#ppterm ~subst ~context ~metasenv term))))
| m,[],_::_ ->
raise (TypeCheckerFailure (lazy (Printf.sprintf
"Unbound variable -%d in %s" m
- (PP.ppterm ~subst ~metasenv ~context term))))
+ (status#ppterm ~subst ~metasenv ~context term))))
| m,t::tl,ct::ctl ->
(match t,ct with
(_,C.Decl t1), (_,C.Decl t2)
| (_,C.Def (t1,_)), (_,C.Def (t2,_))
| (_,C.Def (_,t1)), (_,C.Decl t2) ->
- if not (R.are_convertible ~metasenv ~subst tl t1 t2) then
+ if not (R.are_convertible status ~metasenv ~subst tl t1 t2) then
raise
(TypeCheckerFailure
(lazy (Printf.sprintf
("Not well typed metavariable local context for %s: " ^^
"%s expected, which is not convertible with %s")
- (PP.ppterm ~subst ~metasenv ~context term)
- (PP.ppterm ~subst ~metasenv ~context t2)
- (PP.ppterm ~subst ~metasenv ~context t1))))
+ (status#ppterm ~subst ~metasenv ~context term)
+ (status#ppterm ~subst ~metasenv ~context t2)
+ (status#ppterm ~subst ~metasenv ~context t1))))
| _,_ ->
raise
(TypeCheckerFailure (lazy (Printf.sprintf
("Not well typed metavariable local context for %s: " ^^
"a definition expected, but a declaration found")
- (PP.ppterm ~subst ~metasenv ~context term)))));
+ (status#ppterm ~subst ~metasenv ~context term)))));
compare (m - 1,tl,ctl)
in
compare (n,context,canonical_context)
let rec lift_metas i = function
| [] -> []
| (n,C.Decl t)::tl ->
- (n,C.Decl (S.subst_meta l (S.lift i t)))::(lift_metas (i+1) tl)
+ (n,C.Decl (S.subst_meta status l (S.lift status i t)))::(lift_metas (i+1) tl)
| (n,C.Def (t,ty))::tl ->
- (n,C.Def ((S.subst_meta l (S.lift i t)),
- S.subst_meta l (S.lift i ty)))::(lift_metas (i+1) tl)
+ (n,C.Def ((S.subst_meta status l (S.lift status i t)),
+ S.subst_meta status l (S.lift status i ty)))::(lift_metas (i+1) tl)
in
lift_metas 1 canonical_context in
let l = U.expand_local_context lc_kind in
| C.Rel n ->
(try
match List.nth context (n - 1) with
- | (_,C.Def (te,_)) -> S.lift n te
+ | (_,C.Def (te,_)) -> S.lift status n te
| _ -> t
with Failure _ -> t)
| _ -> t
in
- if not (R.are_convertible ~metasenv ~subst context optimized_t ct)
+ if not (R.are_convertible status ~metasenv ~subst context optimized_t ct)
then
raise
(TypeCheckerFailure
(lazy (Printf.sprintf
("Not well typed metavariable local context: " ^^
"expected a term convertible with %s, found %s")
- (PP.ppterm ~subst ~metasenv ~context ct)
- (PP.ppterm ~subst ~metasenv ~context t))))
+ (status#ppterm ~subst ~metasenv ~context ct)
+ (status#ppterm ~subst ~metasenv ~context t))))
| t, (_,C.Decl ct) ->
let type_t = typeof_aux context t in
- if not (R.are_convertible ~metasenv ~subst context type_t ct) then
+ if not (R.are_convertible status ~metasenv ~subst context type_t ct) then
raise (TypeCheckerFailure
(lazy (Printf.sprintf
("Not well typed metavariable local context: "^^
"expected a term of type %s, found %s of type %s")
- (PP.ppterm ~subst ~metasenv ~context ct)
- (PP.ppterm ~subst ~metasenv ~context t)
- (PP.ppterm ~subst ~metasenv ~context type_t))))
+ (status#ppterm ~subst ~metasenv ~context ct)
+ (status#ppterm ~subst ~metasenv ~context t)
+ (status#ppterm ~subst ~metasenv ~context type_t))))
) l lifted_canonical_context
with
| Invalid_argument "List.iter2" ->
raise (AssertFailure (lazy (Printf.sprintf
"(1) Local and canonical context %s have different lengths"
- (PP.ppterm ~subst ~metasenv ~context term))))
+ (status#ppterm ~subst ~metasenv ~context term))))
in
typeof_aux context term
-and check_allowed_sort_elimination ~subst ~metasenv r =
+and check_allowed_sort_elimination status ~subst ~metasenv r =
let mkapp he arg =
match he with
| C.Appl l -> C.Appl (l @ [arg])
| t -> C.Appl [t;arg] in
let rec aux context ind arity1 arity2 =
- let arity1 = R.whd ~subst context arity1 in
- let arity2 = R.whd ~subst context arity2 in
+ let arity1 = R.whd status ~subst context arity1 in
+ let arity2 = R.whd status ~subst context arity2 in
match arity1,arity2 with
| C.Prod (name,so1,de1), C.Prod (_,so2,de2) ->
- if not (R.are_convertible ~metasenv ~subst context so1 so2) then
+ if not (R.are_convertible status ~metasenv ~subst context so1 so2) then
raise (TypeCheckerFailure (lazy (Printf.sprintf
"In outtype: expected %s, found %s"
- (PP.ppterm ~subst ~metasenv ~context so1)
- (PP.ppterm ~subst ~metasenv ~context so2)
+ (status#ppterm ~subst ~metasenv ~context so1)
+ (status#ppterm ~subst ~metasenv ~context so2)
)));
aux ((name, C.Decl so1)::context)
- (mkapp (S.lift 1 ind) (C.Rel 1)) de1 de2
+ (mkapp (S.lift status 1 ind) (C.Rel 1)) de1 de2
| C.Sort _, C.Prod (name,so,ta) ->
- if not (R.are_convertible ~metasenv ~subst context so ind) then
+ if not (R.are_convertible status ~metasenv ~subst context so ind) then
raise (TypeCheckerFailure (lazy (Printf.sprintf
"In outtype: expected %s, found %s"
- (PP.ppterm ~subst ~metasenv ~context ind)
- (PP.ppterm ~subst ~metasenv ~context so)
+ (status#ppterm ~subst ~metasenv ~context ind)
+ (status#ppterm ~subst ~metasenv ~context so)
)));
- (match arity1, R.whd ~subst ((name,C.Decl so)::context) ta with
+ (match arity1, R.whd status ~subst ((name,C.Decl so)::context) ta with
| C.Sort s1, (C.Sort s2 as arity2) ->
(match NCicEnvironment.allowed_sort_elimination s1 s2 with
| `Yes -> ()
| `UnitOnly ->
(* TODO: we should pass all these parameters since we
* have them already *)
- let _,leftno,itl,_,i = E.get_checked_indtys r in
+ let _,leftno,itl,_,i = E.get_checked_indtys status r in
let itl_len = List.length itl in
let _,itname,ittype,cl = List.nth itl i in
let cl_len = List.length cl in
(cl_len = 0 ||
(itl_len = 1 && cl_len = 1 &&
let _,_,constrty = List.hd cl in
- is_non_recursive_singleton
+ is_non_recursive_singleton status
~subst r itname ittype constrty &&
- is_non_informative ~metasenv ~subst leftno constrty))
+ is_non_informative status ~metasenv ~subst leftno constrty))
then
raise (TypeCheckerFailure (lazy
("Sort elimination not allowed: " ^
- NCicPp.ppterm ~metasenv ~subst ~context arity1
+ status#ppterm ~metasenv ~subst ~context arity1
^ " towards "^
- NCicPp.ppterm ~metasenv ~subst ~context arity2
+ status#ppterm ~metasenv ~subst ~context arity2
))))
| _ -> ())
| _,_ -> ()
in
aux
-and eat_prods ~subst ~metasenv context he ty_he args_with_ty =
+and eat_prods status ~subst ~metasenv context he ty_he args_with_ty =
let rec aux ty_he = function
| [] -> ty_he
| (arg, ty_arg)::tl ->
- match R.whd ~subst context ty_he with
+ match R.whd status ~subst context ty_he with
| C.Prod (_,s,t) ->
- if R.are_convertible ~metasenv ~subst context ty_arg s then
- aux (S.subst ~avoid_beta_redexes:true arg t) tl
+ if R.are_convertible status ~metasenv ~subst context ty_arg s then
+ aux (S.subst status ~avoid_beta_redexes:true arg t) tl
else
raise
(TypeCheckerFailure
(lazy (Printf.sprintf
("Appl: wrong application of %s: the argument %s has type"^^
"\n%s\nbut it should have type \n%s\nContext:\n%s\n")
- (PP.ppterm ~subst ~metasenv ~context he)
- (PP.ppterm ~subst ~metasenv ~context arg)
- (PP.ppterm ~subst ~metasenv ~context ty_arg)
- (PP.ppterm ~subst ~metasenv ~context s)
- (PP.ppcontext ~subst ~metasenv context))))
+ (status#ppterm ~subst ~metasenv ~context he)
+ (status#ppterm ~subst ~metasenv ~context arg)
+ (status#ppterm ~subst ~metasenv ~context ty_arg)
+ (status#ppterm ~subst ~metasenv ~context s)
+ (status#ppcontext ~subst ~metasenv context))))
| _ ->
raise
(TypeCheckerFailure
(lazy (Printf.sprintf
"Appl: %s is not a function, it cannot be applied"
- (PP.ppterm ~subst ~metasenv ~context
+ (status#ppterm ~subst ~metasenv ~context
(let res = List.length tl in
let eaten = List.length args_with_ty - res in
(C.Appl
in
aux ty_he args_with_ty
-and is_non_recursive_singleton ~subst (Ref.Ref (uri,_)) iname ity cty =
+and is_non_recursive_singleton status ~subst (Ref.Ref (uri,_)) iname ity cty =
let ctx = [iname, C.Decl ity] in
- let cty = debruijn uri 1 [] ~subst cty in
+ let cty = debruijn status uri 1 [] ~subst cty in
let len = List.length ctx in
let rec aux ctx n nn t =
- match R.whd ~subst ctx t with
+ match R.whd status ~subst ctx t with
| C.Prod (name, src, tgt) ->
- does_not_occur ~subst ctx n nn src &&
+ does_not_occur status ~subst ctx n nn src &&
aux ((name, C.Decl src) :: ctx) (n+1) (nn+1) tgt
| C.Rel k | C.Appl (C.Rel k :: _) when k = nn -> true
| _ -> assert false
in
aux ctx (len-1) len cty
-and is_non_informative ~metasenv ~subst paramsno c =
+and is_non_informative status ~metasenv ~subst paramsno c =
let rec aux context c =
- match R.whd ~subst context c with
+ match R.whd status ~subst context c with
| C.Prod (n,so,de) ->
- let s = typeof ~metasenv ~subst context so in
+ let s = typeof status ~metasenv ~subst context so in
(s = C.Sort C.Prop ||
match s with C.Sort (C.Type ((`CProp,_)::_)) -> true | _ -> false) &&
aux ((n,(C.Decl so))::context) de
| _ -> true in
- let context',dx = NCicReduction.split_prods ~subst [] paramsno c in
+ let context',dx = NCicReduction.split_prods status ~subst [] paramsno c in
aux context' dx
-and check_mutual_inductive_defs uri ~metasenv ~subst leftno tyl =
+and check_mutual_inductive_defs status uri ~metasenv ~subst leftno tyl =
(* let's check if the arity of the inductive types are well formed *)
- List.iter (fun (_,_,x,_) -> ignore (typeof ~subst ~metasenv [] x)) tyl;
+ List.iter (fun (_,_,x,_) -> ignore (typeof status ~subst ~metasenv [] x)) tyl;
(* let's check if the types of the inductive constructors are well formed. *)
let len = List.length tyl in
let tys = List.rev_map (fun (_,n,ty,_) -> (n,(C.Decl ty))) tyl in
ignore
(List.fold_right
(fun (it_relev,_,ty,cl) i ->
- let context,ty_sort = NCicReduction.split_prods ~subst [] ~-1 ty in
+ let context,ty_sort = NCicReduction.split_prods status ~subst [] ~-1 ty in
let sx_context_ty_rev,_ = HExtlib.split_nth leftno (List.rev context) in
List.iter
(fun (k_relev,_,te) ->
let k_relev =
try snd (HExtlib.split_nth leftno k_relev)
with Failure _ -> k_relev in
- let te = debruijn uri len [] ~subst te in
- let context,te = NCicReduction.split_prods ~subst tys leftno te in
+ let te = debruijn status uri len [] ~subst te in
+ let context,te = NCicReduction.split_prods status ~subst tys leftno te in
let _,chopped_context_rev =
HExtlib.split_nth (List.length tys) (List.rev context) in
let sx_context_te_rev,_ =
let convertible =
match item1,item2 with
(_,C.Decl ty1),(_,C.Decl ty2) ->
- R.are_convertible ~metasenv ~subst context ty1 ty2
+ R.are_convertible status ~metasenv ~subst context ty1 ty2
| (_,C.Def (bo1,ty1)),(_,C.Def (bo2,ty2)) ->
- R.are_convertible ~metasenv ~subst context ty1 ty2 &&
- R.are_convertible ~metasenv ~subst context bo1 bo2
+ R.are_convertible status ~metasenv ~subst context ty1 ty2 &&
+ R.are_convertible status ~metasenv ~subst context bo1 bo2
| _,_ -> false
in
if not convertible then
item1::context
) [] sx_context_ty_rev sx_context_te_rev)
with Invalid_argument "List.fold_left2" -> assert false);
- let con_sort = typeof ~subst ~metasenv context te in
- (match R.whd ~subst context con_sort, R.whd ~subst [] ty_sort with
+ let con_sort = typeof status ~subst ~metasenv context te in
+ (match R.whd status ~subst context con_sort, R.whd status ~subst [] ty_sort with
(C.Sort (C.Type u1) as s1), (C.Sort (C.Type u2) as s2) ->
if not (E.universe_leq u1 u2) then
raise
(TypeCheckerFailure
- (lazy ("The type " ^ PP.ppterm ~metasenv ~subst ~context s1^
+ (lazy ("The type " ^ status#ppterm ~metasenv ~subst ~context s1^
" of the constructor is not included in the inductive" ^
- " type sort " ^ PP.ppterm ~metasenv ~subst ~context s2)))
+ " type sort " ^ status#ppterm ~metasenv ~subst ~context s2)))
| C.Sort _, C.Sort C.Prop
| C.Sort _, C.Sort C.Type _ -> ()
| _, _ ->
(* let's check also the positivity conditions *)
if
not
- (are_all_occurrences_positive ~subst context uri leftno
+ (are_all_occurrences_positive status ~subst context uri leftno
(i+leftno) leftno (len+leftno) te)
then
raise
(TypeCheckerFailure
(lazy ("Non positive occurence in "^NUri.string_of_uri
uri)))
- else check_relevance ~subst ~metasenv context k_relev te)
+ else check_relevance status ~subst ~metasenv context k_relev te)
cl;
- check_relevance ~subst ~metasenv [] it_relev ty;
+ check_relevance status ~subst ~metasenv [] it_relev ty;
i+1)
tyl 1)
-and check_relevance ~subst ~metasenv context relevance ty =
+and check_relevance status ~subst ~metasenv context relevance ty =
let error context ty =
raise (TypeCheckerFailure
(lazy ("Wrong relevance declaration: " ^
String.concat "," (List.map string_of_bool relevance)^
- "\nfor type: "^PP.ppterm ~metasenv ~subst ~context ty)))
+ "\nfor type: "^status#ppterm ~metasenv ~subst ~context ty)))
in
let rec aux context relevance ty =
- match R.whd ~subst context ty with
+ match R.whd status ~subst context ty with
| C.Prod (name,so,de) ->
- let sort = typeof ~subst ~metasenv context so in
- (match (relevance,R.whd ~subst context sort) with
+ let sort = typeof status ~subst ~metasenv context so in
+ (match (relevance,R.whd status ~subst context sort) with
| [],_ -> ()
| false::tl,C.Sort C.Prop -> aux ((name,(C.Decl so))::context) tl de
| true::_,C.Sort C.Prop
| true::tl,C.Meta _ -> aux ((name,(C.Decl so))::context) tl de
| _ -> raise (AssertFailure (lazy (Printf.sprintf
"Prod: the type %s of the source of %s is not a sort"
- (PP.ppterm ~subst ~metasenv ~context sort)
- (PP.ppterm ~subst ~metasenv ~context so)))))
+ (status#ppterm ~subst ~metasenv ~context sort)
+ (status#ppterm ~subst ~metasenv ~context so)))))
| _ -> (match relevance with
| [] -> ()
| _::_ -> error context ty)
in aux context relevance ty
-and guarded_by_destructors r_uri r_len ~subst ~metasenv context recfuns t =
+and guarded_by_destructors (status:#NCic.status) r_uri r_len ~subst ~metasenv context recfuns t =
let recursor f k t = U.fold shift_k k (fun k () -> f k) () t in
let rec aux (context, recfuns, x as k) t =
(*
prerr_endline ("GB:\n" ^
- PP.ppcontext ~subst ~metasenv context^
- PP.ppterm ~metasenv ~subst ~context t^
+ status#ppcontext ~subst ~metasenv context^
+ status#ppterm ~metasenv ~subst ~context t^
string_of_recfuns ~subst ~metasenv ~context recfuns);
*)
try
match t with
| C.Rel m as t when is_dangerous m recfuns ->
raise (NotGuarded (lazy
- (PP.ppterm ~subst ~metasenv ~context t ^
+ (status#ppterm ~subst ~metasenv ~context t ^
" is a partial application of a fix")))
| C.Appl ((C.Rel m)::tl) as t when is_dangerous m recfuns ->
let rec_no = get_recno m recfuns in
if not (List.length tl > rec_no) then
raise (NotGuarded (lazy
- (PP.ppterm ~context ~subst ~metasenv t ^
+ (status#ppterm ~context ~subst ~metasenv t ^
" is a partial application of a fix")))
else
let rec_arg = List.nth tl rec_no in
- if not (is_really_smaller r_uri r_len ~subst ~metasenv k rec_arg) then
+ if not (is_really_smaller status r_uri r_len ~subst ~metasenv k rec_arg) then
raise (NotGuarded (lazy (Printf.sprintf ("Recursive call %s, %s is not"
- ^^ " smaller.\ncontext:\n%s") (PP.ppterm ~context ~subst ~metasenv
- t) (PP.ppterm ~context ~subst ~metasenv rec_arg)
- (PP.ppcontext ~subst ~metasenv context))));
+ ^^ " smaller.\ncontext:\n%s") (status#ppterm ~context ~subst ~metasenv
+ t) (status#ppterm ~context ~subst ~metasenv rec_arg)
+ (status#ppcontext ~subst ~metasenv context))));
List.iter (aux k) tl
| C.Appl ((C.Rel m)::tl) when is_unfolded m recfuns ->
let fixed_args = get_fixed_args m recfuns in
| C.Rel m ->
(match List.nth context (m-1) with
| _,C.Decl _ -> ()
- | _,C.Def (bo,_) -> aux k (S.lift m bo))
+ | _,C.Def (bo,_) -> aux k (S.lift status m bo))
| C.Meta _ -> ()
| C.Appl (C.Const ((Ref.Ref (uri,Ref.Fix (i,recno,_))) as r)::args) ->
if List.exists (fun t -> try aux k t;false with NotGuarded _ -> true) args
then
- let fl,_,_ = E.get_checked_fixes_or_cofixes r in
+ let fl,_,_ = E.get_checked_fixes_or_cofixes status r in
let ctx_tys, bos =
List.split (List.map (fun (_,name,_,ty,bo) -> (name, C.Decl ty), bo) fl)
in
let fl_len = List.length fl in
- let bos = List.map (debruijn uri fl_len context ~subst) bos in
+ let bos = List.map (debruijn status uri fl_len context ~subst) bos in
let j = List.fold_left min max_int (List.map (fun (_,_,i,_,_)->i) fl) in
let ctx_len = List.length context in
(* we may look for fixed params not only up to j ... *)
HExtlib.list_mapi
(fun bo fno ->
let bo_and_k =
- eat_or_subst_lambdas ~subst ~metasenv j bo fa args new_k
+ eat_or_subst_lambdas status ~subst ~metasenv j bo fa args new_k
in
if
fno = i &&
List.length args > recno &&
(*case where the recursive argument is already really_smaller *)
- is_really_smaller r_uri r_len ~subst ~metasenv k
+ is_really_smaller status r_uri r_len ~subst ~metasenv k
(List.nth args recno)
then
let bo,(context, _, _ as new_k) = bo_and_k in
let bo, context' =
- eat_lambdas ~subst ~metasenv context (recno + 1 - j) bo in
+ eat_lambdas status ~subst ~metasenv context (recno + 1 - j) bo in
let new_context_part,_ =
HExtlib.split_nth (List.length context' - List.length context)
context' in
in
List.iter (fun (bo,k) -> aux k bo) bos_and_ks
| C.Match (Ref.Ref (_,Ref.Ind (true,_,_)),outtype,term,pl) as t ->
- (match R.whd ~subst context term with
+ (match R.whd status ~subst context term with
| C.Rel m | C.Appl (C.Rel m :: _ ) as t when is_safe m recfuns || m = x ->
- let ty = typeof ~subst ~metasenv context term in
+ let ty = typeof status ~subst ~metasenv context term in
let dc_ctx, dcl, start, stop =
- specialize_and_abstract_constrs ~subst r_uri r_len context ty in
+ specialize_and_abstract_constrs status ~subst r_uri r_len context ty in
let args = match t with C.Appl (_::tl) -> tl | _ -> [] in
aux k outtype;
List.iter (aux k) args;
List.iter2
(fun p (_,dc) ->
- let rl = recursive_args ~subst ~metasenv dc_ctx start stop dc in
- let p, k = get_new_safes ~subst k p rl in
+ let rl = recursive_args status ~subst ~metasenv dc_ctx start stop dc in
+ let p, k = get_new_safes status ~subst k p rl in
aux k p)
pl dcl
| _ -> recursor aux k t)
| t -> recursor aux k t
with
NotGuarded _ as exc ->
- let t' = R.whd ~delta:0 ~subst context t in
+ let t' = R.whd status ~delta:0 ~subst context t in
if t = t' then raise exc
else aux k t'
in
try aux (context, recfuns, 1) t
with NotGuarded s -> raise (TypeCheckerFailure s)
-and guarded_by_constructors ~subst ~metasenv context t indURI indlen nn =
+and guarded_by_constructors status ~subst ~metasenv context t indURI indlen nn =
let rec aux context n nn h te =
- match R.whd ~subst context te with
+ match R.whd status ~subst context te with
| C.Rel m when m > n && m <= nn -> h
| C.Rel _ | C.Meta _ -> true
| C.Sort _
| C.Const (Ref.Ref (_,Ref.Ind _))
| C.LetIn _ -> raise (AssertFailure (lazy "17"))
| C.Lambda (name,so,de) ->
- does_not_occur ~subst context n nn so &&
+ does_not_occur status ~subst context n nn so &&
aux ((name,C.Decl so)::context) (n + 1) (nn + 1) h de
| C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
- h && List.for_all (does_not_occur ~subst context n nn) tl
+ h && List.for_all (does_not_occur status ~subst context n nn) tl
| C.Const (Ref.Ref (_,Ref.Con _)) -> true
| C.Appl (C.Const (Ref.Ref (_, Ref.Con (_,j,paramsno))) :: tl) as t ->
- let ty_t = typeof ~subst ~metasenv context t in
+ let ty_t = typeof status ~subst ~metasenv context t in
let dc_ctx, dcl, start, stop =
- specialize_and_abstract_constrs ~subst indURI indlen context ty_t in
+ specialize_and_abstract_constrs status ~subst indURI indlen context ty_t in
let _, dc = List.nth dcl (j-1) in
(*
- prerr_endline (PP.ppterm ~subst ~metasenv ~context:dc_ctx dc);
- prerr_endline (PP.ppcontext ~subst ~metasenv dc_ctx);
+ prerr_endline (status#ppterm ~subst ~metasenv ~context:dc_ctx dc);
+ prerr_endline (status#ppcontext ~subst ~metasenv dc_ctx);
*)
- let rec_params = recursive_args ~subst ~metasenv dc_ctx start stop dc in
+ let rec_params = recursive_args status ~subst ~metasenv dc_ctx start stop dc in
let rec analyse_instantiated_type rec_spec args =
match rec_spec, args with
| h::rec_spec, he::args ->
| _,[] -> true
| _ -> raise (AssertFailure (lazy
("Too many args for constructor: " ^ String.concat " "
- (List.map (fun x-> PP.ppterm ~subst ~metasenv ~context x) args))))
+ (List.map (fun x-> status#ppterm ~subst ~metasenv ~context x) args))))
in
let _, args = HExtlib.split_nth paramsno tl in
analyse_instantiated_type rec_params args
| C.Appl ((C.Match (_,out,te,pl))::_)
| C.Match (_,out,te,pl) as t ->
let tl = match t with C.Appl (_::tl) -> tl | _ -> [] in
- List.for_all (does_not_occur ~subst context n nn) tl &&
- does_not_occur ~subst context n nn out &&
- does_not_occur ~subst context n nn te &&
+ List.for_all (does_not_occur status ~subst context n nn) tl &&
+ does_not_occur status ~subst context n nn out &&
+ does_not_occur status ~subst context n nn te &&
List.for_all (aux context n nn h) pl
(* IMPOSSIBLE unsless we allow to pass cofix to other fix/cofix as we do for
higher order fix in g_b_destructors.
let fl,_,_ = E.get_checked_fixes_or_cofixes ref in
let len = List.length fl in
let tys = List.map (fun (_,n,_,ty,_) -> n, C.Decl ty) fl in
- List.for_all (does_not_occur ~subst context n nn) tl &&
+ List.for_all (does_not_occur status ~subst context n nn) tl &&
List.for_all
(fun (_,_,_,_,bo) ->
- aux (context@tys) n nn h (debruijn u len context bo))
+ aux (context@tys) n nn h (debruijn status u len context bo))
fl
*)
| C.Const _
- | C.Appl _ as t -> does_not_occur ~subst context n nn t
+ | C.Appl _ as t -> does_not_occur status ~subst context n nn t
in
aux context 0 nn false t
-and recursive_args ~subst ~metasenv context n nn te =
- match R.whd ~subst context te with
+and recursive_args status ~subst ~metasenv context n nn te =
+ match R.whd status ~subst context te with
| C.Rel _ | C.Appl _ | C.Const _ -> []
| C.Prod (name,so,de) ->
- (not (does_not_occur ~subst context n nn so)) ::
- (recursive_args ~subst ~metasenv
+ (not (does_not_occur status ~subst context n nn so)) ::
+ (recursive_args status ~subst ~metasenv
((name,(C.Decl so))::context) (n+1) (nn + 1) de)
| t ->
- raise (AssertFailure (lazy ("recursive_args:" ^ PP.ppterm ~subst
+ raise (AssertFailure (lazy ("recursive_args:" ^ status#ppterm ~subst
~metasenv ~context:[] t)))
-and get_new_safes ~subst (context, recfuns, x as k) p rl =
- match R.whd ~subst context p, rl with
+and get_new_safes status ~subst (context, recfuns, x as k) p rl =
+ match R.whd status ~subst context p, rl with
| C.Lambda (name,so,ta), b::tl ->
let recfuns = (if b then [0,Safe] else []) @ recfuns in
- get_new_safes ~subst
+ get_new_safes status ~subst
(shift_k (name,(C.Decl so)) (context, recfuns, x)) ta tl
| C.Meta _ as e, _ | e, [] -> e, k
| _ -> raise (AssertFailure (lazy "Ill formed pattern"))
-and is_really_smaller
+and is_really_smaller status
r_uri r_len ~subst ~metasenv (context, recfuns, x as k) te
=
- match R.whd ~subst context te with
+ match R.whd status ~subst context te with
| C.Rel m when is_safe m recfuns -> true
| C.Lambda (name, s, t) ->
- is_really_smaller r_uri r_len ~subst ~metasenv (shift_k (name,C.Decl s) k) t
+ is_really_smaller status r_uri r_len ~subst ~metasenv (shift_k (name,C.Decl s) k) t
| C.Appl (he::_) ->
- is_really_smaller r_uri r_len ~subst ~metasenv k he
+ is_really_smaller status r_uri r_len ~subst ~metasenv k he
| C.Appl [] | C.Implicit _ -> assert false
| C.Meta _ -> true
| C.Match (Ref.Ref (_,Ref.Ind (isinductive,_,_)),_,term,pl) ->
(match term with
| C.Rel m | C.Appl (C.Rel m :: _ ) when is_safe m recfuns || m = x ->
if not isinductive then
- List.for_all (is_really_smaller r_uri r_len ~subst ~metasenv k) pl
+ List.for_all (is_really_smaller status r_uri r_len ~subst ~metasenv k) pl
else
- let ty = typeof ~subst ~metasenv context term in
+ let ty = typeof status ~subst ~metasenv context term in
let dc_ctx, dcl, start, stop =
- specialize_and_abstract_constrs ~subst r_uri r_len context ty in
+ specialize_and_abstract_constrs status ~subst r_uri r_len context ty in
List.for_all2
(fun p (_,dc) ->
- let rl = recursive_args ~subst ~metasenv dc_ctx start stop dc in
- let e, k = get_new_safes ~subst k p rl in
- is_really_smaller r_uri r_len ~subst ~metasenv k e)
+ let rl = recursive_args status ~subst ~metasenv dc_ctx start stop dc in
+ let e, k = get_new_safes status ~subst k p rl in
+ is_really_smaller status r_uri r_len ~subst ~metasenv k e)
pl dcl
- | _ -> List.for_all (is_really_smaller r_uri r_len ~subst ~metasenv k) pl)
+ | _ -> List.for_all (is_really_smaller status r_uri r_len ~subst ~metasenv k) pl)
| _ -> false
-and returns_a_coinductive ~subst context ty =
- match R.whd ~subst context ty with
+and returns_a_coinductive status ~subst context ty =
+ match R.whd status ~subst context ty with
| C.Const (Ref.Ref (uri,Ref.Ind (false,_,_)) as ref)
| C.Appl (C.Const (Ref.Ref (uri,Ref.Ind (false,_,_)) as ref)::_) ->
- let _, _, itl, _, _ = E.get_checked_indtys ref in
+ let _, _, itl, _, _ = E.get_checked_indtys status ref in
Some (uri,List.length itl)
| C.Prod (n,so,de) ->
- returns_a_coinductive ~subst ((n,C.Decl so)::context) de
+ returns_a_coinductive status ~subst ((n,C.Decl so)::context) de
| _ -> None
-and type_of_constant ((Ref.Ref (uri,_)) as ref) =
+and type_of_constant status ((Ref.Ref (uri,_)) as ref) =
let error () =
raise (TypeCheckerFailure (lazy "Inconsistent cached infos in reference"))
in
- match E.get_checked_obj uri, ref with
+ match E.get_checked_obj status uri, ref with
| (_,_,_,_,C.Inductive(isind1,lno1,tl,_)),Ref.Ref(_,Ref.Ind (isind2,i,lno2))->
if isind1 <> isind2 || lno1 <> lno2 then error ();
let _,_,arity,_ = List.nth tl i in arity
(lazy ("type_of_constant: environment/reference: " ^
Ref.string_of_reference ref)))
-and get_relevance ~metasenv ~subst context t args =
- let ty = typeof ~subst ~metasenv context t in
+and get_relevance status ~metasenv ~subst context t args =
+ let ty = typeof status ~subst ~metasenv context t in
let rec aux context ty = function
| [] -> []
- | arg::tl -> match R.whd ~subst context ty with
+ | arg::tl -> match R.whd status ~subst context ty with
| C.Prod (_,so,de) ->
- let sort = typeof ~subst ~metasenv context so in
- let new_ty = S.subst ~avoid_beta_redexes:true arg de in
- (*prerr_endline ("so: " ^ PP.ppterm ~subst ~metasenv:[]
+ let sort = typeof status ~subst ~metasenv context so in
+ let new_ty = S.subst status ~avoid_beta_redexes:true arg de in
+ (*prerr_endline ("so: " ^ status#ppterm ~subst ~metasenv:[]
~context so);
- prerr_endline ("sort: " ^ PP.ppterm ~subst ~metasenv:[]
+ prerr_endline ("sort: " ^ status#ppterm ~subst ~metasenv:[]
~context sort);*)
- (match R.whd ~subst context sort with
+ (match R.whd status ~subst context sort with
| C.Sort C.Prop ->
false::(aux context new_ty tl)
| C.Sort _
| C.Meta _ -> true::(aux context new_ty tl)
| _ -> raise (TypeCheckerFailure (lazy (Printf.sprintf
"Prod: the type %s of the source of %s is not a sort"
- (PP.ppterm ~subst ~metasenv ~context sort)
- (PP.ppterm ~subst ~metasenv ~context so)))))
+ (status#ppterm ~subst ~metasenv ~context sort)
+ (status#ppterm ~subst ~metasenv ~context so)))))
| _ ->
raise
(TypeCheckerFailure
(lazy (Printf.sprintf
"Appl: %s is not a function, it cannot be applied"
- (PP.ppterm ~subst ~metasenv ~context
+ (status#ppterm ~subst ~metasenv ~context
(let res = List.length tl in
let eaten = List.length args - res in
(C.Appl
in aux context ty args
;;
-let typecheck_context ~metasenv ~subst context =
+let typecheck_context status ~metasenv ~subst context =
ignore
(List.fold_right
(fun d context ->
begin
match d with
- _,C.Decl t -> ignore (typeof ~metasenv ~subst:[] context t)
+ _,C.Decl t -> ignore (typeof status ~metasenv ~subst:[] context t)
| name,C.Def (te,ty) ->
- ignore (typeof ~metasenv ~subst:[] context ty);
- let ty' = typeof ~metasenv ~subst:[] context te in
- if not (R.are_convertible ~metasenv ~subst context ty' ty) then
+ ignore (typeof status ~metasenv ~subst:[] context ty);
+ let ty' = typeof status ~metasenv ~subst:[] context te in
+ if not (R.are_convertible status ~metasenv ~subst context ty' ty) then
raise (AssertFailure (lazy (Printf.sprintf (
"the type of the definiens for %s in the context is not "^^
"convertible with the declared one.\n"^^
"inferred type:\n%s\nexpected type:\n%s")
- name (PP.ppterm ~subst ~metasenv ~context ty')
- (PP.ppterm ~subst ~metasenv ~context ty))))
+ name (status#ppterm ~subst ~metasenv ~context ty')
+ (status#ppterm ~subst ~metasenv ~context ty))))
end;
d::context
) context [])
;;
-let typecheck_metasenv metasenv =
+let typecheck_metasenv status metasenv =
ignore
(List.fold_left
(fun metasenv (i,(_,context,ty) as conj) ->
if List.mem_assoc i metasenv then
raise (TypeCheckerFailure (lazy ("duplicate meta " ^ string_of_int i ^
" in metasenv")));
- typecheck_context ~metasenv ~subst:[] context;
- ignore (typeof ~metasenv ~subst:[] context ty);
+ typecheck_context status ~metasenv ~subst:[] context;
+ ignore (typeof status ~metasenv ~subst:[] context ty);
metasenv @ [conj]
) [] metasenv)
;;
-let typecheck_subst ~metasenv subst =
+let typecheck_subst status ~metasenv subst =
ignore
(List.fold_left
(fun subst (i,(_,context,ty,bo) as conj) ->
if List.mem_assoc i metasenv then
raise (AssertFailure (lazy ("meta " ^ string_of_int i ^
" is both in the metasenv and in the substitution")));
- typecheck_context ~metasenv ~subst context;
- ignore (typeof ~metasenv ~subst context ty);
- let ty' = typeof ~metasenv ~subst context bo in
- if not (R.are_convertible ~metasenv ~subst context ty' ty) then
+ typecheck_context status ~metasenv ~subst context;
+ ignore (typeof status ~metasenv ~subst context ty);
+ let ty' = typeof status ~metasenv ~subst context bo in
+ if not (R.are_convertible status ~metasenv ~subst context ty' ty) then
raise (AssertFailure (lazy (Printf.sprintf (
"the type of the definiens for %d in the substitution is not "^^
"convertible with the declared one.\n"^^
"inferred type:\n%s\nexpected type:\n%s")
i
- (PP.ppterm ~subst ~metasenv ~context ty')
- (PP.ppterm ~subst ~metasenv ~context ty))));
+ (status#ppterm ~subst ~metasenv ~context ty')
+ (status#ppterm ~subst ~metasenv ~context ty))));
subst @ [conj]
) [] subst)
;;
-let height_of_term tl =
+let height_of_term status tl =
let h = ref 0 in
let get_height (NReference.Ref (uri,_)) =
- let _,height,_,_,_ = NCicEnvironment.get_checked_obj uri in
+ let _,height,_,_,_ = NCicEnvironment.get_checked_obj status uri in
height in
let rec aux =
function
1 + !h
;;
-let height_of_obj_kind uri ~subst =
+let height_of_obj_kind status uri ~subst =
function
NCic.Inductive _
| NCic.Constant (_,_,None,_,_)
| NCic.Fixpoint (false,_,_) -> 0
| NCic.Fixpoint (true,ifl,_) ->
let iflno = List.length ifl in
- height_of_term
+ height_of_term status
(List.fold_left
(fun l (_,_,_,ty,bo) ->
- let bo = debruijn uri iflno [] ~subst bo in
+ let bo = debruijn status uri iflno [] ~subst bo in
ty::bo::l
) [] ifl)
- | NCic.Constant (_,_,Some bo,ty,_) -> height_of_term [bo;ty]
+ | NCic.Constant (_,_,Some bo,ty,_) -> height_of_term status [bo;ty]
;;
-let typecheck_obj (uri,height,metasenv,subst,kind) =
+let typecheck_obj status (uri,height,metasenv,subst,kind) =
(*height must be checked since it is not only an optimization during reduction*)
- let iheight = height_of_obj_kind uri ~subst kind in
+ let iheight = height_of_obj_kind status uri ~subst kind in
if height <> iheight then
raise (TypeCheckerFailure (lazy (Printf.sprintf
"the declared object height (%d) is not the inferred one (%d)"
height iheight)));
- typecheck_metasenv metasenv;
- typecheck_subst ~metasenv subst;
+ typecheck_metasenv status metasenv;
+ typecheck_subst status ~metasenv subst;
match kind with
| C.Constant (relevance,_,Some te,ty,_) ->
- let _ = typeof ~subst ~metasenv [] ty in
- let ty_te = typeof ~subst ~metasenv [] te in
- if not (R.are_convertible ~metasenv ~subst [] ty_te ty) then
+ let _ = typeof status ~subst ~metasenv [] ty in
+ let ty_te = typeof status ~subst ~metasenv [] te in
+ if not (R.are_convertible status ~metasenv ~subst [] ty_te ty) then
raise (TypeCheckerFailure (lazy (Printf.sprintf (
"the type of the body is not convertible with the declared one.\n"^^
"inferred type:\n%s\nexpected type:\n%s")
- (PP.ppterm ~subst ~metasenv ~context:[] ty_te)
- (PP.ppterm ~subst ~metasenv ~context:[] ty))));
- check_relevance ~subst ~metasenv [] relevance ty
- (*check_relevance ~in_type:false ~subst ~metasenv relevance te*)
+ (status#ppterm ~subst ~metasenv ~context:[] ty_te)
+ (status#ppterm ~subst ~metasenv ~context:[] ty))));
+ check_relevance status ~subst ~metasenv [] relevance ty
+ (*check_relevance status ~in_type:false ~subst ~metasenv relevance te*)
| C.Constant (relevance,_,None,ty,_) ->
- ignore (typeof ~subst ~metasenv [] ty);
- check_relevance ~subst ~metasenv [] relevance ty
+ ignore (typeof status ~subst ~metasenv [] ty);
+ check_relevance status ~subst ~metasenv [] relevance ty
| C.Inductive (_, leftno, tyl, _) ->
- check_mutual_inductive_defs uri ~metasenv ~subst leftno tyl
+ check_mutual_inductive_defs status uri ~metasenv ~subst leftno tyl
| C.Fixpoint (inductive,fl,_) ->
let types, kl =
List.fold_left
(fun (types,kl) (relevance,name,k,ty,_) ->
- let _ = typeof ~subst ~metasenv [] ty in
- check_relevance ~subst ~metasenv [] relevance ty;
+ let _ = typeof status ~subst ~metasenv [] ty in
+ check_relevance status ~subst ~metasenv [] relevance ty;
((name,C.Decl ty)::types, k::kl)
) ([],[]) fl
in
let dfl, kl =
List.split (List.map2
(fun (_,_,_,_,bo) rno ->
- let dbo = debruijn uri len [] ~subst bo in
+ let dbo = debruijn status uri len [] ~subst bo in
dbo, Evil rno)
fl kl)
in
List.iter2 (fun (_,_,x,ty,_) bo ->
- let ty_bo = typeof ~subst ~metasenv types bo in
- if not (R.are_convertible ~metasenv ~subst types ty_bo ty)
+ let ty_bo = typeof status ~subst ~metasenv types bo in
+ if not (R.are_convertible status ~metasenv ~subst types ty_bo ty)
then raise (TypeCheckerFailure (lazy ("(Co)Fix: ill-typed bodies")))
else
if inductive then begin
- let m, context = eat_lambdas ~subst ~metasenv types (x + 1) bo in
+ let m, context = eat_lambdas status ~subst ~metasenv types (x + 1) bo in
let r_uri, r_len =
let he =
match List.hd context with _,C.Decl t -> t | _ -> assert false
in
- match R.whd ~subst (List.tl context) he with
+ match R.whd status ~subst (List.tl context) he with
| C.Const (Ref.Ref (uri,Ref.Ind _) as ref)
| C.Appl (C.Const (Ref.Ref (uri,Ref.Ind _) as ref) :: _) ->
- let _,_,itl,_,_ = E.get_checked_indtys ref in
+ let _,_,itl,_,_ = E.get_checked_indtys status ref in
uri, List.length itl
| _ ->
raise (TypeCheckerFailure
let rec enum_from k =
function [] -> [] | v::tl -> (k,v)::enum_from (k+1) tl
in
- guarded_by_destructors r_uri r_len
+ guarded_by_destructors status r_uri r_len
~subst ~metasenv context (enum_from (x+2) kl) m
end else
- match returns_a_coinductive ~subst [] ty with
+ match returns_a_coinductive status ~subst [] ty with
| None ->
raise (TypeCheckerFailure
(lazy "CoFix: does not return a coinductive type"))
| Some (r_uri, r_len) ->
(* guarded by constructors conditions C{f,M} *)
if not
- (guarded_by_constructors ~subst ~metasenv types bo r_uri r_len len)
+ (guarded_by_constructors status ~subst ~metasenv types bo r_uri r_len len)
then
raise (TypeCheckerFailure
(lazy "CoFix: not guarded by constructors"))
let set_logger f = logger := f;;
-let typecheck_obj obj =
+let typecheck_obj status obj =
let u,_,_,_,_ = obj in
try
!logger (`Start_type_checking u);
- typecheck_obj obj;
+ typecheck_obj status obj;
!logger (`Type_checking_completed u)
with
Sys.Break as e ->
;;
E.set_typecheck_obj
- (fun obj ->
+ (fun status obj ->
if trust_obj obj then
let u,_,_,_,_ = obj in
!logger (`Trust_obj u)
else
- typecheck_obj obj)
+ typecheck_obj status obj)
;;
let _ = NCicReduction.set_get_relevance get_relevance;;
-
let indent = ref 0;;
let debug = true;;
let logger =
val set_trust : (NCic.obj -> bool) -> unit
val typeof:
- subst:NCic.substitution -> metasenv:NCic.metasenv ->
- NCic.context -> NCic.term ->
- NCic.term
+ #NCic.status -> subst:NCic.substitution -> metasenv:NCic.metasenv ->
+ NCic.context -> NCic.term -> NCic.term
-val height_of_obj_kind: NUri.uri -> subst:NCic.substitution -> NCic.obj_kind -> int
+val height_of_obj_kind:
+ #NCic.status -> NUri.uri -> subst:NCic.substitution -> NCic.obj_kind -> int
val get_relevance :
+ #NCic.status ->
metasenv:NCic.metasenv -> subst:NCic.substitution ->
NCic.context -> NCic.term -> NCic.term list -> bool list
(* type_of_branch subst context leftno outtype
* (constr @ lefts) (ty_constr @ lefts) *)
val type_of_branch :
+ #NCic.status ->
subst:NCic.substitution ->
NCic.context -> int -> NCic.term -> NCic.term -> NCic.term ->
NCic.term
* arity1 = constructor type @ lefts
* arity2 = outtype *)
val check_allowed_sort_elimination :
+ #NCic.status ->
subst:NCic.substitution ->
metasenv:NCic.metasenv ->
NReference.reference -> NCic.context ->
(* Functions to be used by the refiner *)
val debruijn:
- NUri.uri -> int -> subst:NCic.substitution -> NCic.context -> NCic.term ->
- NCic.term
+ #NCic.status -> NUri.uri -> int -> subst:NCic.substitution -> NCic.context ->
+ NCic.term -> NCic.term
+
val are_all_occurrences_positive:
- subst:NCic.substitution ->
- NCic.context -> NUri.uri -> int -> int -> int -> int -> NCic.term -> bool
+ #NCic.status -> subst:NCic.substitution -> NCic.context -> NUri.uri -> int ->
+ int -> int -> int -> NCic.term -> bool
val does_not_occur :
- subst:NCic.substitution -> NCic.context -> int -> int -> NCic.term -> bool
+ #NCic.status -> subst:NCic.substitution -> NCic.context -> int -> int ->
+ NCic.term -> bool
module C = NCic
module Ref = NReference
-let map_term_fold_a g k f a = function
+let map_term_fold_a status g k f a = function
| C.Meta _ -> assert false
| C.Implicit _
| C.Sort _
| C.Appl l :: tl -> C.Appl (l@tl)
| _ -> C.Appl l1
in
- if fire_beta then NCicReduction.head_beta_reduce ~upto t
+ if fire_beta then NCicReduction.head_beta_reduce status ~upto t
else t
| C.Prod (n,s,t) as orig ->
let a,s1 = f k a s in let a,t1 = f (g (n,C.Decl s) k) a t in
else C.Match(r,oty1,t1,pl1)
;;
-let metas_of_term subst context term =
+let metas_of_term status subst context term =
let rec aux ctx acc = function
| NCic.Rel i ->
(match HExtlib.list_skip (i-1) ctx with
| NCic.Meta(i,l) ->
(try
let _,_,bo,_ = NCicUtils.lookup_subst i subst in
- let bo = NCicSubstitution.subst_meta l bo in
+ let bo = NCicSubstitution.subst_meta status l bo in
aux ctx acc bo
with NCicUtils.Subst_not_found _ ->
let shift, lc = l in
let lc = NCicUtils.expand_local_context lc in
- let l = List.map (NCicSubstitution.lift shift) lc in
+ let l = List.map (NCicSubstitution.lift status shift) lc in
List.fold_left (aux ctx) (i::acc) l)
| t -> NCicUtils.fold (fun e c -> e::c) ctx aux acc t
in
exception Occurr;;
-let clean_or_fix_dependent_abstrations ctx t =
+let clean_or_fix_dependent_abstrations status ctx t =
let occurrs_1 t =
let rec aux n _ = function
| NCic.Meta _ -> ()
| NCic.Lambda (name,s,t) when List.mem name ctx ->
let name = fresh ctx name in
NCic.Lambda (name, aux ctx s, aux (name::ctx) t)
- | t -> NCicUtils.map (fun (e,_) ctx -> e::ctx) ctx aux t
+ | t -> NCicUtils.map status (fun (e,_) ctx -> e::ctx) ctx aux t
in
aux (List.map fst ctx) t
;;
-let rec fire_projection_redex on_args = function
+let rec fire_projection_redex status on_args = function
| C.Meta _ as t -> t
| C.Appl(C.Const(Ref.Ref(_,Ref.Fix(fno,rno,_)) as r)::args as ol)as ot->
- let l= if on_args then List.map (fire_projection_redex true) ol else ol in
+ let l= if on_args then List.map (fire_projection_redex status true) ol else ol in
let t = if l == ol then ot else C.Appl l in
- let ifl,(_,_,pragma),_ = NCicEnvironment.get_checked_fixes_or_cofixes r in
+ let ifl,(_,_,pragma),_ = NCicEnvironment.get_checked_fixes_or_cofixes status r in
let conclude () =
if on_args then
- let l' = HExtlib.sharing_map (fire_projection_redex true) l in
+ let l' = HExtlib.sharing_map (fire_projection_redex status true) l in
if l == l' then t else C.Appl l'
else
t (* ot is the same *)
| C.Appl (C.Const(Ref.Ref(_,Ref.Con _))::_) ->
let _, _, _, _, fbody = List.nth ifl fno in (* fbody is closed! *)
let t = C.Appl (fbody::List.tl l) in
- (match NCicReduction.head_beta_reduce ~delta:max_int t with
+ (match NCicReduction.head_beta_reduce status ~delta:max_int t with
| C.Match (_,_, C.Appl(C.Const(Ref.Ref(_,Ref.Con (_,_,leftno)))
::kargs),[pat])->
let _,kargs = HExtlib.split_nth leftno kargs in
- fire_projection_redex false
- (NCicReduction.head_beta_reduce
+ fire_projection_redex status false
+ (NCicReduction.head_beta_reduce status
~delta:max_int (C.Appl (pat :: kargs)))
| C.Appl(C.Match(_,_,C.Appl(C.Const(Ref.Ref(_,Ref.Con (_,_,leftno)))
::kargs),[pat]) :: args) ->
let _,kargs = HExtlib.split_nth leftno kargs in
- fire_projection_redex false
- (NCicReduction.head_beta_reduce
+ fire_projection_redex status false
+ (NCicReduction.head_beta_reduce status
~delta:max_int (C.Appl (pat :: kargs @ args)))
| _ -> conclude ())
| _ -> conclude ())
- | t when on_args -> NCicUtils.map (fun _ x -> x) true fire_projection_redex t
+ | t when on_args ->
+ NCicUtils.map status (fun _ x -> x) true (fire_projection_redex status) t
| t -> t
;;
-let apply_subst ?(fix_projections=false) subst context t =
+let apply_subst status ?(fix_projections=false) subst context t =
let rec apply_subst subst () =
function
NCic.Meta (i,lc) ->
(try
let _,_,t,_ = NCicUtils.lookup_subst i subst in
- let t = NCicSubstitution.subst_meta lc t in
+ let t = NCicSubstitution.subst_meta status lc t in
apply_subst subst () t
with
NCicUtils.Subst_not_found j when j = i ->
NCic.Meta
(i,(0,NCic.Ctx
(List.map (fun t ->
- apply_subst subst () (NCicSubstitution.lift n t)) l))))
- | t -> NCicUtils.map (fun _ () -> ()) () (apply_subst subst) t
+ apply_subst subst () (NCicSubstitution.lift status n t)) l))))
+ | t -> NCicUtils.map status (fun _ () -> ()) () (apply_subst subst) t
in
- (if fix_projections then fire_projection_redex true else fun x -> x)
- (clean_or_fix_dependent_abstrations context (apply_subst subst () t))
+ (if fix_projections then fire_projection_redex status true else fun x -> x)
+ (clean_or_fix_dependent_abstrations status context (apply_subst subst () t))
;;
-let apply_subst_context ~fix_projections subst context =
- let apply_subst = apply_subst ~fix_projections in
+let apply_subst_context status ~fix_projections subst context =
+ let apply_subst = apply_subst status ~fix_projections in
let rec aux c = function
| [] -> []
| (name,NCic.Decl t as e) :: tl ->
List.rev (aux [] (List.rev context))
;;
-let rec apply_subst_metasenv subst = function
+let rec apply_subst_metasenv status subst = function
| [] -> []
| (i,_) :: _ when List.mem_assoc i subst -> assert false
| (i,(name,ctx,ty)) :: tl ->
- (i,(name,apply_subst_context ~fix_projections:true subst ctx,
- apply_subst ~fix_projections:true subst ctx ty)) ::
- apply_subst_metasenv subst tl
+ (i,(name,apply_subst_context status ~fix_projections:true subst ctx,
+ apply_subst status ~fix_projections:true subst ctx ty)) ::
+ apply_subst_metasenv status subst tl
;;
(* hide optional arg *)
-let apply_subst s c t = apply_subst s c t;;
+let apply_subst status s c t = apply_subst status s c t;;
type meta_kind = [ `IsSort | `IsType | `IsTerm ]
end
module MS = HTopoSort.Make(OT)
-let relations_of_menv subst m c =
+let relations_of_menv status subst m c =
let i, (_, ctx, ty) = c in
let m = List.filter (fun (j,_) -> j <> i) m in
- let m_ty = metas_of_term subst ctx ty in
+ let m_ty = metas_of_term status subst ctx ty in
let m_ctx =
snd
(List.fold_right
(fun i (ctx,res) ->
(i::ctx),
(match i with
- | _,NCic.Decl ty -> metas_of_term subst ctx ty
+ | _,NCic.Decl ty -> metas_of_term status subst ctx ty
| _,NCic.Def (t,ty) ->
- metas_of_term subst ctx ty @ metas_of_term subst ctx t) @ res)
+ metas_of_term status subst ctx ty @ metas_of_term status subst ctx t) @ res)
ctx ([],[]))
in
let metas = HExtlib.list_uniq (List.sort compare (m_ty @ m_ctx)) in
List.filter (fun (i,_) -> List.exists ((=) i) metas) m
;;
-let sort_metasenv subst (m : NCic.metasenv) =
- (MS.topological_sort m (relations_of_menv subst m) : NCic.metasenv)
+let sort_metasenv status subst (m : NCic.metasenv) =
+ (MS.topological_sort m (relations_of_menv status subst m) : NCic.metasenv)
;;
-let count_occurrences ~subst n t =
+let count_occurrences status ~subst n t =
let occurrences = ref 0 in
let rec aux k _ = function
| C.Rel m when m = n+k -> incr occurrences
(* possible optimization here: try does_not_occur on l and
perform substitution only if DoesOccur is raised *)
let _,_,term,_ = NCicUtils.lookup_subst mno subst in
- aux (k-s) () (NCicSubstitution.subst_meta (0,l) term)
+ aux (k-s) () (NCicSubstitution.subst_meta status (0,l) term)
with NCicUtils.Subst_not_found _ -> () (*match l with
| C.Irl len -> if not (n+k >= s+len || s > nn+k) then raise DoesOccur
| C.Ctx lc -> List.iter (aux (k-s) ()) lc*))
(* $Id$ *)
val map_term_fold_a:
+ #NCic.status ->
(NCic.hypothesis -> 'k -> 'k) -> 'k ->
('k -> 'a -> NCic.term -> 'a * NCic.term) -> 'a -> NCic.term -> 'a * NCic.term
val map_obj_kind:
?skip_body:bool -> (NCic.term -> NCic.term) -> NCic.obj_kind -> NCic.obj_kind
-val metas_of_term : NCic.substitution -> NCic.context -> NCic.term -> int list
-val sort_metasenv: NCic.substitution -> NCic.metasenv -> NCic.metasenv
+val metas_of_term :
+ #NCic.status -> NCic.substitution -> NCic.context -> NCic.term -> int list
+val sort_metasenv:
+ #NCic.status -> NCic.substitution -> NCic.metasenv -> NCic.metasenv
type meta_kind = [ `IsSort | `IsType | `IsTerm ]
val kind_of_meta: NCic.meta_attrs -> meta_kind
val mk_appl : NCic.term -> NCic.term list -> NCic.term
(* the context is needed only to honour Barendregt's naming convention *)
-val apply_subst : NCic.substitution -> NCic.context -> NCic.term -> NCic.term
-val apply_subst_context : fix_projections:bool ->
+val apply_subst :
+ #NCic.status -> NCic.substitution -> NCic.context -> NCic.term -> NCic.term
+val apply_subst_context :
+ #NCic.status -> fix_projections:bool ->
NCic.substitution -> NCic.context -> NCic.context
-val apply_subst_metasenv : NCic.substitution -> NCic.metasenv -> NCic.metasenv
+val apply_subst_metasenv :
+ #NCic.status -> NCic.substitution -> NCic.metasenv -> NCic.metasenv
val count_occurrences :
- subst:NCic.substitution -> int -> NCic.term -> int
+ #NCic.status -> subst:NCic.substitution -> int -> NCic.term -> int
(* quick, but with false negatives (since no ~subst), check for closed terms *)
val looks_closed : NCic.term -> bool
exception Subst_not_found of int
exception Meta_not_found of int
-let head_beta_reduce = ref (fun ~upto:_ _ -> assert false);;
+let head_beta_reduce = ref (fun _ ~upto:_ _ -> assert false);;
let set_head_beta_reduce = (:=) head_beta_reduce;;
let expand_local_context = function
| C.Match (_,oty,t,pl) -> List.fold_left (f k) (f k (f k acc oty) t) pl
;;
-let map g k f = function
+let map status g k f = function
| C.Meta _ -> assert false
| C.Implicit _
| C.Sort _
| C.Appl l :: tl -> C.Appl (l@tl)
| l1 -> C.Appl l1
in
- if fire_beta then !head_beta_reduce ~upto t
+ if fire_beta then !head_beta_reduce (status :> NCic.status) ~upto t
else t
| C.Prod (n,s,t) as orig ->
let s1 = f k s in let t1 = f (g (n,C.Decl s) k) t in
(NCic.hypothesis -> 'k -> 'k) -> 'k ->
('k -> 'a -> NCic.term -> 'a) -> 'a -> NCic.term -> 'a
val map:
+ #NCic.status ->
(NCic.hypothesis -> 'k -> 'k) -> 'k ->
('k -> NCic.term -> NCic.term) -> NCic.term -> NCic.term
-val set_head_beta_reduce: (upto:int -> NCic.term -> NCic.term) -> unit
+val set_head_beta_reduce: (NCic.status -> upto:int -> NCic.term -> NCic.term) -> unit
let refresh_uri_in_reference (NReference.Ref (uri,spec)) =
NReference.reference_of_spec (refresh_uri uri) spec
-let rec refresh_uri_in_term =
- function
+let refresh_uri_in_term status =
+ let rec aux =
+ function
| NCic.Meta (i,(n,NCic.Ctx l)) ->
- NCic.Meta (i,(n,NCic.Ctx (List.map refresh_uri_in_term l)))
+ NCic.Meta (i,(n,NCic.Ctx (List.map aux l)))
| NCic.Meta _ as t -> t
| NCic.Const ref -> NCic.Const (refresh_uri_in_reference ref)
| NCic.Sort (NCic.Type l) -> NCic.Sort (NCic.Type (refresh_uri_in_universe l))
| NCic.Match (NReference.Ref (uri,spec),outtype,term,pl) ->
let r = NReference.reference_of_spec (refresh_uri uri) spec in
- let outtype = refresh_uri_in_term outtype in
- let term = refresh_uri_in_term term in
- let pl = List.map refresh_uri_in_term pl in
+ let outtype = aux outtype in
+ let term = aux term in
+ let pl = List.map aux pl in
NCic.Match (r,outtype,term,pl)
- | t -> NCicUtils.map (fun _ _ -> ()) () (fun _ -> refresh_uri_in_term) t
+ | t -> NCicUtils.map status (fun _ _ -> ()) () (fun _ -> aux) t
+in
+ aux
;;
-let refresh_uri_in_obj (uri,height,metasenv,subst,obj_kind) =
+let refresh_uri_in_obj status (uri,height,metasenv,subst,obj_kind) =
assert (metasenv = []);
assert (subst = []);
refresh_uri uri,height,metasenv,subst,
- NCicUntrusted.map_obj_kind refresh_uri_in_term obj_kind
+ NCicUntrusted.map_obj_kind (refresh_uri_in_term status) obj_kind
;;
let ng_path_of_baseuri ?(no_suffix=false) baseuri =
let init = load_db;;
-class status =
+class virtual status =
object
+ inherit NCic.status
val timestamp = (time0 : timestamp)
method timestamp = timestamp
method set_timestamp v = {< timestamp = v >}
end
-let time_travel status =
- let sto,ali = status#timestamp in
- let diff_len = List.length !storage - List.length sto in
- let to_be_deleted,_ = HExtlib.split_nth diff_len !storage in
- if List.length to_be_deleted > 0 then
- List.iter NCicEnvironment.invalidate_item to_be_deleted;
- storage := sto; local_aliases := ali
+let time_travel0 (sto,ali) =
+ let diff_len = List.length !storage - List.length sto in
+ let to_be_deleted,_ = HExtlib.split_nth diff_len !storage in
+ if List.length to_be_deleted > 0 then
+ List.iter NCicEnvironment.invalidate_item to_be_deleted;
+ storage := sto; local_aliases := ali
;;
+let time_travel status = time_travel0 status#timestamp;;
+
type obj = string * Obj.t
(* includes are transitively closed; dependencies are only immediate *)
type dump =
type 'a register_type =
'a ->
refresh_uri_in_universe:(NCic.universe -> NCic.universe) ->
- refresh_uri_in_term:(NCic.term -> NCic.term) ->
+ refresh_uri_in_term:(NCic.status -> NCic.term -> NCic.term) ->
refresh_uri_in_reference:(NReference.reference -> NReference.reference) ->
alias_only:bool ->
dumpable_status -> dumpable_status
type 'a register_type =
'a ->
refresh_uri_in_universe:(NCic.universe -> NCic.universe) ->
- refresh_uri_in_term:(NCic.term -> NCic.term) ->
+ refresh_uri_in_term:(NCic.status -> NCic.term -> NCic.term) ->
refresh_uri_in_reference:(NReference.reference -> NReference.reference) ->
alias_only:bool ->
dumpable_status -> dumpable_status
) !storage;
set_global_aliases (!local_aliases @ get_global_aliases ());
List.iter (fun u -> add_deps u [baseuri]) status#dump.includes;
- time_travel (new status)
+ time_travel0 time0
let require2 ~baseuri ~alias_only status =
try
objs = record_include (baseuri,fname)::s#dump.objs })
end
-let fetch_obj uri =
+let fetch_obj status uri =
let obj = require0 ~baseuri:uri in
- refresh_uri_in_obj obj
+ refresh_uri_in_obj status obj
;;
let resolve name =
;;
let add_obj status ((u,_,_,_,_) as obj) =
- NCicEnvironment.check_and_add_obj obj;
+ NCicEnvironment.check_and_add_obj status obj;
storage := (`Obj (u,obj))::!storage;
let _,height,_,_,obj = obj in
let references =
status#set_timestamp (!storage,!local_aliases)
;;
-let get_obj u =
+let get_obj status u =
try
List.assq u
(HExtlib.filter_map
(function `Obj (u,o) -> Some (u,o) | _ -> None )
!storage)
with Not_found ->
- try fetch_obj u
+ try fetch_obj status u
with Sys_error _ ->
raise (NCicEnvironment.ObjectNotFound (lazy (NUri.string_of_uri u)))
;;
NCicEnvironment.set_get_obj get_obj;;
-NCicPp.set_get_obj get_obj;;
type timestamp
-class status :
+class virtual status :
object ('self)
+ inherit NCic.status
method timestamp: timestamp
method set_timestamp: timestamp -> 'self
end
val aliases_of: NUri.uri -> NReference.reference list
val resolve: string -> NReference.reference list
(* warning: get_obj may raise (NCicEnvironment.ObjectNotFoud l) *)
-val get_obj: NUri.uri -> NCic.obj (* changes the current timestamp *)
+val get_obj: #NCic.status -> NUri.uri -> NCic.obj (* changes the current timestamp *)
val time_travel: #status -> unit
type 'a register_type =
'a ->
refresh_uri_in_universe:(NCic.universe -> NCic.universe) ->
- refresh_uri_in_term:(NCic.term -> NCic.term) ->
+ refresh_uri_in_term:(NCic.status -> NCic.term -> NCic.term) ->
refresh_uri_in_reference:(NReference.reference -> NReference.reference) ->
alias_only:bool ->
dumpable_status -> dumpable_status
;;
let compare x y =
- if NCicReduction.alpha_eq [] [] [] x y then 0
+ (* CSC: NCicPp.status is the best I can put here *)
+ if NCicReduction.alpha_eq (new NCicPp.status) [] [] [] x y then 0
(* if x = y then 0 *)
else compare x y
;;
| _ -> None
let pp t =
- NCicPp.ppterm ~context:C.context ~metasenv:C.metasenv ~subst:C.subst t;;
+ (* CSC: NCicPp.status is the best I can put here *)
+ (new NCicPp.status)#ppterm ~context:C.context
+ ~metasenv:C.metasenv ~subst:C.subst t;;
type input = NCic.term
let saturate t ty =
let sty, _, args =
- NCicMetaSubst.saturate ~delta:0 C.metasenv C.subst C.context
- ty 0
+ (* CSC: NCicPp.status is the best I can put here *)
+ NCicMetaSubst.saturate (new NCicPp.status) ~delta:0 C.metasenv C.subst
+ C.context ty 0
in
let proof =
if args = [] then Terms.Leaf t
module NCicParamod(C : NCicBlob.NCicContext) = Paramod.Paramod(B(C))
-let readback ?(demod=false) rdb metasenv subst context (bag,i,fo_subst,l) =
+let readback status ?(demod=false) metasenv subst context (bag,i,fo_subst,l) =
(*
List.iter (fun x ->
print_endline (Pp.pp_unit_clause ~margin:max_int
(fst(Terms.M.find x bag)))) l;
*)
(* let stamp = Unix.gettimeofday () in *)
- let proofterm,prooftype = NCicProof.mk_proof ~demod bag i fo_subst l in
+ let proofterm,prooftype = NCicProof.mk_proof status ~demod bag i fo_subst l in
(* debug (lazy (Printf.sprintf "Got proof term in %fs"
(Unix.gettimeofday() -. stamp))); *)
(*
in
aux 0 metasenv proofterm
in *)
- debug (lazy (NCicPp.ppterm ~metasenv ~subst ~context proofterm));
+ debug (lazy (status#ppterm ~metasenv ~subst ~context proofterm));
(*
let stamp = Unix.gettimeofday () in
let metasenv, subst, proofterm, _prooftype =
NCicRefiner.typeof
- (rdb#set_coerc_db NCicCoercion.empty_db)
+ (status#set_coerc_db NCicCoercion.empty_db)
metasenv subst context proofterm None
in
print (lazy (Printf.sprintf "Refined in %fs"
*)
proofterm, prooftype, metasenv, subst
-let nparamod rdb metasenv subst context t table =
+let nparamod status metasenv subst context t table =
let module C =
struct
let metasenv = metasenv
with
| P.Error _ | P.GaveUp | P.Timeout _ -> []
| P.Unsatisfiable solutions ->
- List.map (readback rdb metasenv subst context) solutions
+ List.map (readback status metasenv subst context) solutions
;;
module EmptyC =
else (debug (lazy "not eq"); s)
;;
-let index_obj s uri =
- let obj = NCicEnvironment.get_checked_obj uri in
+let index_obj status s uri =
+ let obj = NCicEnvironment.get_checked_obj status uri in
debug (lazy ("indexing : " ^ (NUri.string_of_uri uri)));
debug (lazy ("no : " ^ (string_of_int (fst (Obj.magic uri)))));
match obj with
| _ -> s
;;
-let demod rdb metasenv subst context s goal =
+let demod status metasenv subst context s goal =
(* let stamp = Unix.gettimeofday () in *)
match P.demod s goal with
| P.Error _ | P.GaveUp | P.Timeout _ -> []
| P.Unsatisfiable solutions ->
(* print (lazy (Printf.sprintf "Got solutions in %fs"
(Unix.gettimeofday() -. stamp))); *)
- List.map (readback ~demod:true rdb metasenv subst context) solutions
+ List.map (readback ~demod:true status metasenv subst context) solutions
;;
-let paramod rdb metasenv subst context s goal =
+let paramod status metasenv subst context s goal =
(* let stamp = Unix.gettimeofday () in *)
match P.nparamod ~useage:true ~max_steps:max_int
~timeout:(Unix.gettimeofday () +. 300.0) s goal with
| P.Unsatisfiable solutions ->
(* print (lazy (Printf.sprintf "Got solutions in %fs"
(Unix.gettimeofday() -. stamp))); *)
- List.map (readback rdb metasenv subst context) solutions
+ List.map (readback status metasenv subst context) solutions
;;
-let fast_eq_check rdb metasenv subst context s goal =
+let fast_eq_check status metasenv subst context s goal =
(* let stamp = Unix.gettimeofday () in *)
match P.fast_eq_check s goal with
| P.Error _ | P.GaveUp | P.Timeout _ -> []
| P.Unsatisfiable solutions ->
(* print (lazy (Printf.sprintf "Got solutions in %fs"
(Unix.gettimeofday() -. stamp))); *)
- List.map (readback rdb metasenv subst context) solutions
+ List.map (readback status metasenv subst context) solutions
;;
-let is_equation metasenv subst context ty =
+let is_equation status metasenv subst context ty =
let hty, _, _ =
- NCicMetaSubst.saturate ~delta:0 metasenv subst context
+ NCicMetaSubst.saturate status ~delta:0 metasenv subst context
ty 0
in match hty with
| NCic.Appl (eq ::tl) when eq = CB.eqP -> true
;;
(*
-let demodulate rdb metasenv subst context s goal =
+let demodulate status metasenv subst context s goal =
(* let stamp = Unix.gettimeofday () in *)
match P.fast_eq_check s goal with
| P.Error _ | P.GaveUp | P.Timeout _ -> []
| P.Unsatisfiable solutions ->
(* print (lazy (Printf.sprintf "Got solutions in %fs"
(Unix.gettimeofday() -. stamp))); *)
- List.map (readback rdb metasenv subst context) solutions
+ List.map (readback status metasenv subst context) solutions
;;
*)
type state
val empty_state: state
val forward_infer_step: state -> NCic.term -> NCic.term -> state
-val index_obj: state -> NUri.uri -> state
-val is_equation: NCic.metasenv ->
- NCic.substitution -> NCic.context -> NCic.term -> bool
+val index_obj: #NCic.status -> state -> NUri.uri -> state
+val is_equation:
+ #NCic.status -> NCic.metasenv -> NCic.substitution -> NCic.context ->
+ NCic.term -> bool
val paramod :
#NCicCoercion.status ->
NCic.metasenv -> NCic.substitution -> NCic.context ->
let eq_refl() = debug (!eqsig Refl) "refl";;
- let extract lift vl t =
+ let extract status lift vl t =
let rec pos i = function
| [] -> raise Not_found
| j :: tl when j <> i -> 1+ pos i tl
in
let vl_len = List.length vl in
let rec extract = function
- | Terms.Leaf x -> NCicSubstitution.lift (vl_len+lift) x
+ | Terms.Leaf x -> NCicSubstitution.lift status (vl_len+lift) x
| Terms.Var j ->
(try NCic.Rel (pos j vl) with Not_found -> NCic.Implicit `Term)
| Terms.Node l -> NCic.Appl (List.map extract l)
;;
- let mk_predicate hole_type amount ft p1 vl =
+ let mk_predicate status hole_type amount ft p1 vl =
let rec aux t p =
match p with
| [] -> NCic.Rel 1
HExtlib.list_mapi
(fun t i ->
if i = n then aux t tl
- else extract amount (0::vl) t)
+ else extract status amount (0::vl) t)
l
in
NCic.Appl l
| _ -> assert false
- let mk_morphism eq amount ft pl vl =
+ let mk_morphism status eq amount ft pl vl =
let rec aux t p =
match p with
| [] -> eq
List.fold_left
(fun (i,acc) t ->
i+1,
- let f = extract amount vl f in
+ let f = extract status amount vl f in
if i = n then
let imp = NCic.Implicit `Term in
NCic.Appl (dag::imp::imp::imp(* f *)::imp::imp::
[aux t tl])
else
- NCicUntrusted.mk_appl acc [extract amount vl t]
- ) (1,extract amount vl f) l)
+ NCicUntrusted.mk_appl acc [extract status amount vl t]
+ ) (1,extract status amount vl f) l)
in aux ft (List.rev pl)
;;
- let mk_proof ?(demod=false) (bag : NCic.term Terms.bag) mp subst steps =
+ let mk_proof status ?(demod=false) (bag : NCic.term Terms.bag) mp subst steps=
let module NCicBlob =
NCicBlob.NCicBlob(
struct
let proof_type =
let lit,_,_ = get_literal mp in
let lit = Subst.apply_subst subst lit in
- extract 0 [] lit in
+ extract status 0 [] lit in
(* composition of all subst acting on goal *)
let res_subst =
let rec rsaux ongoal acc =
let lit,vl,proof = get_literal id in
if not ongoal && id = mp then
let lit = Subst.apply_subst subst lit in
- let eq_ty = extract amount [] lit in
+ let eq_ty = extract status amount [] lit in
let refl =
if demod then NCic.Implicit `Term
else mk_refl eq_ty in
(* prerr_endline ("Reached m point, id=" ^ (string_of_int id));
(NCic.LetIn ("clause_" ^ string_of_int id, eq_ty, refl,
aux true ((id,([],lit))::seen) (id::tl))) *)
- NCicSubstitution.subst
+ NCicSubstitution.subst status
~avoid_beta_redexes:true ~no_implicit:false refl
(aux true ((id,([],lit))::seen) (id::tl))
else
(*
prerr_endline ("Exact for " ^ (string_of_int id));
NCic.LetIn ("clause_" ^ string_of_int id,
- close_with_forall vl (extract amount vl lit),
- close_with_lambdas vl (extract amount vl ft),
+ close_with_forall vl (extract status amount vl lit),
+ close_with_lambdas vl (extract status amount vl ft),
aux ongoal
((id,(List.map (fun x -> Terms.Var x) vl,lit))::seen) tl)
*)
- NCicSubstitution.subst
+ NCicSubstitution.subst status
~avoid_beta_redexes:true ~no_implicit:false
- (close_with_lambdas vl (extract amount vl ft))
+ (close_with_lambdas vl (extract status amount vl ft))
(aux ongoal
((id,(List.map (fun x -> Terms.Var x) vl,lit))::seen) tl)
| Terms.Step (_, id1, id2, dir, pos, subst) ->
let proof_of_id id =
let vars = List.rev (vars_of id seen) in
let args = List.map (Subst.apply_subst subst) vars in
- let args = List.map (extract amount vl) args in
+ let args = List.map (extract status amount vl) args in
let rel_for_id = NCic.Rel (List.length vl + position id seen) in
if args = [] then rel_for_id
else NCic.Appl (rel_for_id::args)
let id2_ty,l,r =
match ty_of id2 seen with
| Terms.Node [ _; t; l; r ] ->
- extract amount vl (Subst.apply_subst subst t),
- extract amount vl (Subst.apply_subst subst l),
- extract amount vl (Subst.apply_subst subst r)
+ extract status amount vl (Subst.apply_subst subst t),
+ extract status amount vl (Subst.apply_subst subst l),
+ extract status amount vl (Subst.apply_subst subst r)
| _ -> assert false
in
(*prerr_endline "mk_predicate :";
let id2_ty,l,r =
match ty_of id2 seen with
| Terms.Node [ _; t; l; r ] ->
- extract amount vl (Subst.apply_subst subst t),
- extract amount vl (Subst.apply_subst subst l),
- extract amount vl (Subst.apply_subst subst r)
+ extract status amount vl (Subst.apply_subst subst t),
+ extract status amount vl (Subst.apply_subst subst l),
+ extract status amount vl (Subst.apply_subst subst r)
| _ -> assert false
in
(*
prerr_endline ("Positions :" ^
(String.concat ", "
(List.map string_of_int pos)));*)
- mk_predicate
+ mk_predicate status
id2_ty amount (Subst.apply_subst subst id1_ty) pos vl,
id2_ty,
l,r
let body = aux ongoal
((id,(List.map (fun x -> Terms.Var x) vl,lit))::seen) tl
in
- let occ= NCicUntrusted.count_occurrences [] 1 body in
+ let occ =
+ NCicUntrusted.count_occurrences status [] 1 body in
if occ <= 1 then
- NCicSubstitution.subst
+ NCicSubstitution.subst status
~avoid_beta_redexes:true ~no_implicit:false
(close_with_lambdas vl rewrite_step) body
else
NCic.LetIn ("clause_" ^ string_of_int id,
- close_with_forall vl (extract amount vl lit),
+ close_with_forall vl (extract status amount vl lit),
(* NCic.Implicit `Type, *)
close_with_lambdas vl rewrite_step, body)
in
val get_sig: eq_sig_type -> NCic.term
val mk_proof:
+ #NCic.status ->
?demod:bool
-> NCic.term Terms.bag
-> Terms.M.key
method coerc_db: db
end
-class status =
+class virtual status =
object
inherit NCicUnifHint.status
val db = empty_db
= fun o -> {< db = o#coerc_db >}#set_unifhint_status o
end
-let index_coercion status name c src tgt arity arg =
+let index_coercion (status:#status) name c src tgt arity arg =
let db_src,db_tgt = status#coerc_db in
let data = (name,c,arity,arg,src,tgt) in
debug (lazy ("INDEX:" ^
- NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] src ^ " ===> " ^
- NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] tgt ^ " := " ^
- NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] c ^ " " ^
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] src ^ " ===> " ^
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] tgt ^ " := " ^
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] c ^ " " ^
string_of_int arg ^ " " ^ string_of_int arity));
let db_src = DB.index db_src src data in
let db_tgt = DB.index db_tgt tgt data in
let look_for_coercion status metasenv subst context infty expty =
let db_src,db_tgt = status#coerc_db in
match
- NCicUntrusted.apply_subst subst context infty,
- NCicUntrusted.apply_subst subst context expty
+ NCicUntrusted.apply_subst status subst context infty,
+ NCicUntrusted.apply_subst status subst context expty
with
| (NCic.Meta _ | NCic.Appl (NCic.Meta _::_)),
(NCic.Meta _ | NCic.Appl (NCic.Meta _::_)) -> []
| infty, expty ->
debug (lazy ("LOOK FOR COERCIONS: " ^
- NCicPp.ppterm ~metasenv ~subst ~context infty ^ " |===> " ^
- NCicPp.ppterm ~metasenv ~subst ~context expty));
+ status#ppterm ~metasenv ~subst ~context infty ^ " |===> " ^
+ status#ppterm ~metasenv ~subst ~context expty));
let src_class = infty :: NCicUnifHint.eq_class_of status infty in
let tgt_class = expty :: NCicUnifHint.eq_class_of status expty in
debug (lazy ("CANDIDATES SRC: " ^
String.concat "," (List.map (fun (name,t,_,_,_,_) ->
- name ^ " :: " ^ NCicPp.ppterm ~metasenv ~subst ~context t)
+ name ^ " :: " ^ status#ppterm ~metasenv ~subst ~context t)
(DB.Collector.to_list set_src))));
debug (lazy ("CANDIDATES TGT: " ^
String.concat "," (List.map (fun (name,t,_,_,_,_) ->
- name ^ " :: " ^ NCicPp.ppterm ~metasenv ~subst ~context t)
+ name ^ " :: " ^ status#ppterm ~metasenv ~subst ~context t)
(DB.Collector.to_list set_tgt))));
let candidates = DB.Collector.inter set_src set_tgt in
debug (lazy ("CANDIDATES: " ^
String.concat "," (List.map (fun (name,t,_,_,_,_) ->
- name ^ " :: " ^ NCicPp.ppterm ~metasenv ~subst ~context t)
+ name ^ " :: " ^ status#ppterm ~metasenv ~subst ~context t)
candidates)));
List.map
(fun (name,t,arity,arg,_,_) ->
let ty =
- try NCicTypeChecker.typeof ~metasenv:[] ~subst:[] [] t
+ try NCicTypeChecker.typeof status ~metasenv:[] ~subst:[] [] t
with NCicTypeChecker.TypeCheckerFailure s ->
prerr_endline ("illtyped coercion: "^Lazy.force s);
- prerr_endline (NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t);
+ prerr_endline (status#ppterm ~metasenv:[] ~subst:[] ~context:[] t);
assert false
in
let ty, metasenv, args =
- NCicMetaSubst.saturate ~delta:max_int metasenv subst context ty arity
+ NCicMetaSubst.saturate status ~delta:max_int metasenv subst context ty arity
in
debug (lazy (
- NCicPp.ppterm ~metasenv ~subst:[] ~context:[] ty ^ " --- " ^
- NCicPp.ppterm ~metasenv ~subst ~context
+ status#ppterm ~metasenv ~subst:[] ~context:[] ty ^ " --- " ^
+ status#ppterm ~metasenv ~subst ~context
(NCicUntrusted.mk_appl t args) ^ " --- " ^
string_of_int (List.length args) ^ " == " ^ string_of_int arg));
| _,NCic.Appl (he::_) -> he
| _,_ -> t
in
- let b = NCicReduction.alpha_eq metasenv subst context p t in
+ let b = NCicReduction.alpha_eq status metasenv subst context p t in
if not b then None else
- let ty = NCicTypeChecker.typeof ~metasenv:[] ~subst:[] [] p in
+ let ty = NCicTypeChecker.typeof status ~metasenv:[] ~subst:[] [] p in
let pis =
let rec aux = function NCic.Prod (_,_,t) -> 1+aux t | _ -> 0 in
aux ty
) db)
;;
-let generate_dot_file status fmt =
+let generate_dot_file (status:#status) fmt =
let module Pp = GraphvizPp.Dot in
let src_db, _ = status#coerc_db in
let edges = ref [] in
edges := !edges @
List.map
(fun (name,t,a,g,sk,dk) ->
- debug(lazy (let p = NCicPp.ppterm ~metasenv:[] ~context:[]
+ debug(lazy (let p = status#ppterm ~metasenv:[] ~context:[]
~subst:[] in p t ^ " ::: " ^ p sk ^ " |--> " ^ p dk));
let eq_s= sk::NCicUnifHint.eq_class_of status sk in
let eq_t= dk::NCicUnifHint.eq_class_of status dk in
Pp.node (mangle cl)
~attrs:["label",String.concat "\\n"
(List.map (fun t->
- NCicPp.ppterm ~metasenv:[] ~subst:[]
+ status#ppterm ~metasenv:[] ~subst:[]
~context:[] t ~margin:max_int
) cl)]
fmt)
method coerc_db: db
end
-class status :
+class virtual status :
object ('self)
inherit g_status
inherit NCicUnifHint.status
end
;;
-let rec force_does_not_occur metasenv subst restrictions t =
+let rec force_does_not_occur status metasenv subst restrictions t =
let rec aux k ms = function
| NCic.Rel r when List.mem (r - k) restrictions -> raise Occur
| NCic.Rel r as orig ->
| NCic.Meta (n, (shift,lc as l)) as orig ->
(try
let _,_,bo,_ = NCicUtils.lookup_subst n subst in
- aux k ms (NCicSubstitution.subst_meta l bo)
+ aux k ms (NCicSubstitution.subst_meta status l bo)
with
NCicUtils.Subst_not_found _ ->
(* we ignore the subst since restrict will take care of already
* instantiated/restricted metavariabels *)
let l = NCicUtils.expand_local_context lc in
- let sl = List.map (NCicSubstitution.lift shift) l in
+ let sl = List.map (NCicSubstitution.lift status shift) l in
let (metasenv,subst as ms), _, restrictions_for_n, l' =
List.fold_right
(fun t (ms, i, restrictions_for_n, l) ->
try
(*pp (lazy ("L'ORLO DELLA FOSSA: k= " ^ string_of_int k ^ " shift=" ^
- string_of_int shift ^ " t=" ^ NCicPp.ppterm ~metasenv ~subst ~context:[] t));*)
+ string_of_int shift ^ " t=" ^ status#ppterm ~metasenv ~subst ~context:[] t));*)
let ms, t = aux k ms t in
- (*pp (lazy ("LA FOSSA: " ^ NCicPp.ppterm ~metasenv ~subst ~context:[] t));*)
+ (*pp (lazy ("LA FOSSA: " ^ status#ppterm ~metasenv ~subst ~context:[] t));*)
ms, i-1, restrictions_for_n, t::l
with Occur ->
ms, i-1, i::restrictions_for_n, l)
in
if restrictions_for_n = [] then
ms, if sl = l' then orig else (
- (*pp (lazy ("FINITO: " ^ NCicPp.ppterm ~metasenv:[] ~subst:[]
+ (*pp (lazy ("FINITO: " ^ status#ppterm ~metasenv:[] ~subst:[]
~context:[] (NCic.Meta (n,pack_lc (0, NCic.Ctx l')))));*)
NCic.Meta (n, pack_lc (0, NCic.Ctx l'))
)
let l' = pack_lc (0, NCic.Ctx l') in
let _ = pp (lazy ("restrictions for n are:" ^ String.concat "," (List.map string_of_int restrictions_for_n))) in
let metasenv, subst, newmeta, more_restricted =
- restrict metasenv subst n restrictions_for_n in
+ restrict status metasenv subst n restrictions_for_n in
let _ = pp (lazy ("more restricted: " ^String.concat "," (List.map string_of_int more_restricted))) in
let l' = purge_restricted restrictions more_restricted l' in
(metasenv, subst), NCic.Meta (newmeta, l'))
- | t -> NCicUntrusted.map_term_fold_a (fun _ k -> k+1) k aux ms t
+ | t -> NCicUntrusted.map_term_fold_a status (fun _ k -> k+1) k aux ms t
in
aux 0 (metasenv,subst) t
-and force_does_not_occur_in_context metasenv subst restrictions = function
+and force_does_not_occur_in_context status metasenv subst restrictions = function
| name, NCic.Decl t as orig ->
- (* pp (lazy ("CCC: hd is" ^ NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t ^
+ (* pp (lazy ("CCC: hd is" ^ status#ppterm ~metasenv:[] ~subst:[] ~context:[] t ^
"\nCCC: restrictions are:" ^ String.concat "," (List.map string_of_int restrictions)));*)
let (metasenv, subst), t' =
- force_does_not_occur metasenv subst restrictions t in
+ force_does_not_occur status metasenv subst restrictions t in
metasenv, subst, (if t == t' then orig else (name,NCic.Decl t'))
| name, NCic.Def (bo, ty) as orig ->
let (metasenv, subst), bo' =
- force_does_not_occur metasenv subst restrictions bo in
+ force_does_not_occur status metasenv subst restrictions bo in
let (metasenv, subst), ty' =
- force_does_not_occur metasenv subst restrictions ty in
+ force_does_not_occur status metasenv subst restrictions ty in
metasenv, subst,
(if bo == bo' && ty == ty' then orig else (name, NCic.Def (bo', ty')))
-and erase_in_context metasenv subst pos restrictions = function
+and erase_in_context status metasenv subst pos restrictions = function
| [] -> metasenv, subst, restrictions, []
| hd::tl as orig ->
let metasenv, subst, restricted, tl' =
- erase_in_context metasenv subst (pos+1) restrictions tl in
+ erase_in_context status metasenv subst (pos+1) restrictions tl in
if List.mem pos restricted then
metasenv, subst, restricted, tl'
else
let delifted_restricted =
List.map ((+) ~-pos) (List.filter ((<=) pos) restricted) in
force_does_not_occur_in_context
- metasenv subst delifted_restricted hd
+ status metasenv subst delifted_restricted hd
in
metasenv, subst, restricted,
(if hd' == hd && tl' == tl then orig else (hd' :: tl'))
with Occur ->
metasenv, subst, (pos :: restricted), tl'
-and restrict metasenv subst i (restrictions as orig) =
+and restrict status metasenv subst i (restrictions as orig) =
assert (restrictions <> []);
try
let name, ctx, bo, ty = NCicUtils.lookup_subst i subst in
try
let metasenv, subst, restrictions, newctx =
- erase_in_context metasenv subst 1 restrictions ctx in
+ erase_in_context status metasenv subst 1 restrictions ctx in
let (metasenv, subst), newty =
- force_does_not_occur metasenv subst restrictions ty in
+ force_does_not_occur status metasenv subst restrictions ty in
let (metasenv, subst), newbo =
- force_does_not_occur metasenv subst restrictions bo in
+ force_does_not_occur status metasenv subst restrictions bo in
let j = newmeta () in
let subst_entry_j = j, (name, newctx, newbo, newty) in
let reloc_irl = mk_perforated_irl 0 (List.length ctx) restrictions in
"with %s and at least one of the hypotheses occurs in "^^
"the substituted term") i (String.concat ", "
(List.map (fun x -> fst (List.nth ctx (x-1))) restrictions)) i
- (NCicPp.ppterm ~metasenv ~subst ~context:ctx bo))))
+ (status#ppterm ~metasenv ~subst ~context:ctx bo))))
with NCicUtils.Subst_not_found _ ->
try
let name, ctx, ty = NCicUtils.lookup_meta i metasenv in
try
let metasenv, subst, restrictions, newctx =
- erase_in_context metasenv subst 1 restrictions ctx in
+ erase_in_context status metasenv subst 1 restrictions ctx in
let (metasenv, subst), newty =
- force_does_not_occur metasenv subst restrictions ty in
+ force_does_not_occur status metasenv subst restrictions ty in
let j = newmeta () in
let metasenv_entry = j, (name, newctx, newty) in
let reloc_irl =
| NCicUtils.Meta_not_found _ -> assert false
;;
-let rec is_flexible context ~subst = function
+let rec is_flexible status context ~subst = function
| NCic.Meta (i,_) ->
(try
let _,_,t,_ = List.assoc i subst in
- is_flexible context ~subst t
+ is_flexible status context ~subst t
with Not_found -> true)
| NCic.Appl (NCic.Meta (i,_) :: args)->
(try
let _,_,t,_ = List.assoc i subst in
- is_flexible context ~subst
- (NCicReduction.head_beta_reduce ~delta:max_int
+ is_flexible status context ~subst
+ (NCicReduction.head_beta_reduce status ~delta:max_int
(NCic.Appl (t :: args)))
with Not_found -> true)
(* this is a cheap whd, it only performs zeta-reduction.
match List.nth context (i-1)
with
| _,NCic.Def (bo,_) ->
- is_flexible context ~subst
- (NCicSubstitution.lift i bo)
+ is_flexible status context ~subst
+ (NCicSubstitution.lift status i bo)
| _ -> false
with
| Failure _ ->
prerr_endline (Printf.sprintf "Rel %d inside context:\n%s" i
- (NCicPp.ppcontext ~subst ~metasenv:[] context));
+ (status#ppcontext ~subst ~metasenv:[] context));
assert false
| Invalid_argument _ -> assert false)
| _ -> false
(* INVARIANT: we suppose that t is not another occurrence of Meta(n,_),
otherwise the occur check does not make sense in case of unification
of ?n with ?n *)
-let delift ~unify metasenv subst context n l t =
+let delift status ~unify metasenv subst context n l t =
(*D*) inside 'D'; try let rc =
let is_in_scope_meta subst = function
| NCic.Meta (i,_) ->
match l with
| _, NCic.Irl _ -> fun _ _ _ _ _ -> None
| shift, NCic.Ctx l -> fun metasenv subst context k t ->
- if is_flexible context ~subst t || contains_in_scope subst t then None else
+ if is_flexible status context ~subst t || contains_in_scope subst t then None else
let lb =
List.map (fun t ->
- let t = NCicSubstitution.lift (k+shift) t in
- t, is_flexible context ~subst t)
+ let t = NCicSubstitution.lift status (k+shift) t in
+ t, is_flexible status context ~subst t)
l
in
HExtlib.list_findopt
(* CSC: This bit of reduction hurts performances since it is
* possible to have an exponential explosion of the size of the
* proof. required for nat/nth_prime.ma *)
- aux (context,k,in_scope) ms (NCicSubstitution.lift n bo))
+ aux (context,k,in_scope) ms (NCicSubstitution.lift status n bo))
| _,NCic.Decl _ -> ms, NCic.Rel ((position in_scope (n-k) l) + k)
with Failure _ -> assert false) (*Unbound variable found in delift*)
| NCic.Meta (i,_) when i=n ->
"Cannot unify the metavariable ?%d with a term that has "^^
"as subterm %s in which the same metavariable "^^
"occurs (occur check)") i
- (NCicPp.ppterm ~context ~metasenv ~subst t))))
+ (status#ppterm ~context ~metasenv ~subst t))))
| NCic.Meta (i,l1) as orig ->
(try
let tag,c,t,ty = NCicUtils.lookup_subst i subst in
metasenv,
(i,([],c,t,ty)) :: List.filter (fun j,_ -> i <> j) subst
in
- aux (context,k,in_scope) ms (NCicSubstitution.subst_meta l1 t)
+ aux (context,k,in_scope) ms (NCicSubstitution.subst_meta status l1 t)
with NCicUtils.Subst_not_found _ ->
if snd l1 = NCic.Irl 0 || snd l1 = NCic.Ctx [] then ms, orig
else
when shift1 + len1 < shift || shift1 > shift + len ->
let restrictions = HExtlib.list_seq 1 (len1 + 1) in
let metasenv, subst, newmeta, more_restricted =
- restrict metasenv subst i restrictions in
+ restrict status metasenv subst i restrictions in
let l' = (0,NCic.Irl (max 0 (k-shift1))) in
let l' = purge_restricted restrictions more_restricted l' in
(metasenv, subst),NCic.Meta (newmeta,l')
else ms, NCic.Meta (i, (new_shift, lc1))
else
let metasenv, subst, newmeta, more_restricted =
- restrict metasenv subst i restrictions in
+ restrict status metasenv subst i restrictions in
let newlc_len = len1 - List.length restrictions in
let l' = new_shift, NCic.Irl newlc_len in
let l' = purge_restricted restrictions more_restricted l' in
| _ ->
let lc1 = NCicUtils.expand_local_context lc1 in
- let lc1 = List.map (NCicSubstitution.lift shift1) lc1 in
+ let lc1 = List.map (NCicSubstitution.lift status shift1) lc1 in
let rec deliftl tbr j ms = function
| [] -> ms, tbr, []
| t::tl ->
pp (lazy ("TO BE RESTRICTED: " ^
(String.concat "," (List.map string_of_int to_be_r))));
let l1 = pack_lc (0, NCic.Ctx lc1') in
- pp (lazy ("newmeta:" ^ NCicPp.ppterm
+ pp (lazy ("newmeta:" ^ status#ppterm
~metasenv ~subst ~context (NCic.Meta (999,l1))));
- pp (lazy (NCicPp.ppmetasenv ~subst metasenv));
+ pp (lazy (status#ppmetasenv ~subst metasenv));
if to_be_r = [] then
(metasenv, subst),
(if lc1' = lc1 then orig else NCic.Meta (i,l1))
else
let metasenv, subst, newmeta, more_restricted =
- restrict metasenv subst i to_be_r in
+ restrict status metasenv subst i to_be_r in
let l1 = purge_restricted to_be_r more_restricted l1 in
(metasenv, subst), NCic.Meta(newmeta,l1))
| t ->
- NCicUntrusted.map_term_fold_a
+ NCicUntrusted.map_term_fold_a status
(fun e (c,k,s) -> (e::c,k+1,s)) (context,k,in_scope) aux ms t
in
(*
(* related to the delift function. *)
let msg = (lazy (Printf.sprintf
("Error trying to abstract %s over [%s]: the algorithm only tried to "^^
- "abstract over bound variables") (NCicPp.ppterm ~metasenv ~subst
- ~context t) (String.concat "; " (List.map (NCicPp.ppterm ~metasenv
+ "abstract over bound variables") (status#ppterm ~metasenv ~subst
+ ~context t) (String.concat "; " (List.map (status#ppterm ~metasenv
~subst ~context) (let shift, lc = l in List.map (NCicSubstitution.lift
- shift) (NCicUtils.expand_local_context lc))))))
+ status shift) (NCicUtils.expand_local_context lc))))))
in
let shift, lc = l in
let lc = NCicUtils.expand_local_context lc in
- let l = List.map (NCicSubstitution.lift shift) lc in
+ let l = List.map (NCicSubstitution.lift status shift) lc in
if
- List.exists (fun t-> NCicUntrusted.metas_of_term subst context t <> [])l
+ List.exists (fun t-> NCicUntrusted.metas_of_term status subst context t <> [])l
then
raise (Uncertain msg)
else
with NCicUtils.Meta_not_found _ -> assert false
;;
-let saturate ?(delta=0) metasenv subst context ty goal_arity =
+let saturate status ?(delta=0) metasenv subst context ty goal_arity =
assert (goal_arity >= 0);
let rec aux metasenv = function
| NCic.Prod (name,s,t) as ty ->
let metasenv1, _, arg,_ =
mk_meta ~attrs:[`Name name] metasenv context ~with_type:s `IsTerm in
let t, metasenv1, args, pno =
- aux metasenv1 (NCicSubstitution.subst arg t)
+ aux metasenv1 (NCicSubstitution.subst status arg t)
in
if pno + 1 = goal_arity then
ty, metasenv, [], goal_arity+1
else
t, metasenv1, arg::args, pno+1
| ty ->
- match NCicReduction.whd ~subst context ty ~delta with
+ match NCicReduction.whd status ~subst context ty ~delta with
| NCic.Prod _ as ty -> aux metasenv ty
| ty -> ty, metasenv, [], 0
in
* in the term (for occur check).
*)
val delift :
+ #NCic.status ->
unify:(NCic.metasenv -> NCic.substitution -> NCic.context ->
NCic.term -> NCic.term -> (NCic.metasenv * NCic.substitution) option) ->
NCic.metasenv -> NCic.substitution -> NCic.context ->
additional (i.e. l' does not intersects l) positions whose restriction was
forced because of type dependencies *)
val restrict:
+ #NCic.status ->
NCic.metasenv ->
NCic.substitution ->
int -> int list ->
(* returns the resulting type, the metasenv and the arguments *)
val saturate:
+ #NCic.status ->
?delta:int -> NCic.metasenv -> NCic.substitution ->
NCic.context -> NCic.term -> int ->
NCic.term * NCic.metasenv * NCic.term list
val is_out_scope_tag : NCic.meta_attrs -> bool
val int_of_out_scope_tag : NCic.meta_attrs -> int
-val is_flexible : NCic.context -> subst:NCic.substitution -> NCic.term -> bool
+val is_flexible:
+ #NCic.status -> NCic.context -> subst:NCic.substitution -> NCic.term -> bool
(* syntactic_equality up to the *)
(* distinction between fake dependent products *)
(* and non-dependent products, alfa-conversion *)
-let alpha_equivalence =
+let alpha_equivalence status =
let rec aux t t' =
if t = t' then true
else
(fun b t1 t2 -> b && aux t1 t2) true l l'
with
Invalid_argument _ -> false)
- | NCic.Const ref1, NCic.Const ref2 -> t == t'
+ | NCic.Const _, NCic.Const _ -> t == t'
| NCic.Match (it,outt,t,pl), NCic.Match (it',outt',t',pl') ->
it == it' &&
aux outt outt' && aux t t' &&
i = i' &&
(try
List.fold_left2
- (fun b xt xt' -> b && aux (NCicSubstitution.lift s xt) (NCicSubstitution.lift s' xt'))
+ (fun b xt xt' -> b && aux (NCicSubstitution.lift status s xt) (NCicSubstitution.lift status s' xt'))
true lc lc'
with
Invalid_argument _ -> false)
- | NCic.Appl [t], t' | t, NCic.Appl [t'] -> assert false
+ | NCic.Appl [_], _ | _, NCic.Appl [_] -> assert false
| NCic.Sort s, NCic.Sort s' -> s == s'
| _,_ -> false (* we already know that t != t' *)
in
exception WhatAndWithWhatDoNotHaveTheSameLength;;
-let replace_lifting ~equality ~context ~what ~with_what ~where =
+let replace_lifting status ~equality ~context ~what ~with_what ~where =
let find_image ctx what t =
let rec find_image_aux =
function
let add_ctx1 ctx n s ty = (n, NCic.Def (s,ty))::ctx in
let rec substaux k ctx what t =
try
- NCicSubstitution.lift (k-1) (find_image ctx what t)
+ NCicSubstitution.lift status (k-1) (find_image ctx what t)
with Not_found ->
match t with
NCic.Rel _ as t -> t
| NCic.Meta (i, (shift,l)) ->
let l = NCicUtils.expand_local_context l in
let l' =
- List.map (fun t -> substaux k ctx what (NCicSubstitution.lift shift t)) l
+ List.map (fun t -> substaux k ctx what (NCicSubstitution.lift status shift t)) l
in
NCic.Meta(i,NCicMetaSubst.pack_lc (0, NCic.Ctx l'))
| NCic.Sort _ as t -> t
| NCic.Implicit _ as t -> t
| NCic.Prod (n,s,t) ->
NCic.Prod
- (n, substaux k ctx what s, substaux (k + 1) (add_ctx ctx n s) (List.map (NCicSubstitution.lift 1) what) t)
+ (n, substaux k ctx what s, substaux (k + 1) (add_ctx ctx n s) (List.map (NCicSubstitution.lift status 1) what) t)
| NCic.Lambda (n,s,t) ->
NCic.Lambda
- (n, substaux k ctx what s, substaux (k + 1) (add_ctx ctx n s) (List.map (NCicSubstitution.lift 1) what) t)
+ (n, substaux k ctx what s, substaux (k + 1) (add_ctx ctx n s) (List.map (NCicSubstitution.lift status 1) what) t)
| NCic.LetIn (n,s,ty,t) ->
NCic.LetIn
- (n, substaux k ctx what s, substaux k ctx what ty, substaux (k + 1) (add_ctx1 ctx n s ty) (List.map (NCicSubstitution.lift 1) what) t)
+ (n, substaux k ctx what s, substaux k ctx what ty, substaux (k + 1) (add_ctx1 ctx n s ty) (List.map (NCicSubstitution.lift status 1) what) t)
| NCic.Appl (he::tl) ->
(* Invariant: no Appl applied to another Appl *)
let tl' = List.map (substaux k ctx what) tl in
(* $Id: nCicRefiner.ml 9802 2009-05-25 15:39:26Z tassi $ *)
-val alpha_equivalence : NCic.term -> NCic.term -> bool
+val alpha_equivalence : #NCic.status -> NCic.term -> NCic.term -> bool
val replace_lifting :
+ #NCic.status ->
equality:((string * NCic.context_entry) list ->
NCic.term -> NCic.term -> bool) ->
context:(string * NCic.context_entry) list ->
| e -> raise e
;;
-let exp_implicit rdb ~localise metasenv subst context with_type t =
+let exp_implicit status ~localise metasenv subst context with_type t =
function
| `Closed ->
let metasenv,subst,expty =
| Some typ ->
let (metasenv,subst),typ =
try
- NCicMetaSubst.delift
+ NCicMetaSubst.delift status
~unify:(fun m s c t1 t2 ->
- try Some (NCicUnification.unify rdb m s c t1 t2)
+ try Some (NCicUnification.unify status m s c t1 t2)
with NCicUnification.UnificationFailure _ | NCicUnification.Uncertain _ -> None)
metasenv subst context 0 (0,NCic.Irl 0) typ
with
NCicMetaSubst.MetaSubstFailure _
| NCicMetaSubst.Uncertain _ ->
- raise (RefineFailure (lazy (localise t,"Trying to create a closed meta with a non closed type: " ^ NCicPp.ppterm ~metasenv ~subst ~context typ)))
+ raise (RefineFailure (lazy (localise t,"Trying to create a closed meta with a non closed type: " ^ status#ppterm ~metasenv ~subst ~context typ)))
in
metasenv,subst,Some typ
| _ -> assert false
;;
-let check_allowed_sort_elimination rdb localise r orig =
+let check_allowed_sort_elimination status localise r orig =
let mkapp he arg =
match he with
| C.Appl l -> C.Appl (l @ [arg])
(* ctx, ind_type @ lefts, sort_of_ind_ty@lefts, outsort *)
let rec aux metasenv subst context ind arity1 arity2 =
(*D*)inside 'S'; try let rc =
- let arity1 = NCicReduction.whd ~subst context arity1 in
- pp (lazy(NCicPp.ppterm ~subst ~metasenv ~context arity1 ^ " elimsto " ^
- NCicPp.ppterm ~subst ~metasenv ~context arity2 ^ "\nMENV:\n"^
- NCicPp.ppmetasenv ~subst metasenv));
+ let arity1 = NCicReduction.whd status ~subst context arity1 in
+ pp (lazy(status#ppterm ~subst ~metasenv ~context arity1 ^ " elimsto " ^
+ status#ppterm ~subst ~metasenv ~context arity2 ^ "\nMENV:\n"^
+ status#ppmetasenv ~subst metasenv));
match arity1 with
| C.Prod (name,so1,de1) (* , t ==?== C.Prod _ *) ->
let metasenv, _, meta, _ =
NCicMetaSubst.mk_meta metasenv ((name,C.Decl so1)::context) `IsType
in
let metasenv, subst =
- try NCicUnification.unify rdb metasenv subst context
+ try NCicUnification.unify status metasenv subst context
arity2 (C.Prod (name, so1, meta))
with exc -> raise (wrap_exc (lazy (localise orig, Printf.sprintf
"expected %s, found %s" (* XXX localizzare meglio *)
- (NCicPp.ppterm ~subst ~metasenv ~context (C.Prod (name, so1, meta)))
- (NCicPp.ppterm ~subst ~metasenv ~context arity2))) exc)
+ (status#ppterm ~subst ~metasenv ~context (C.Prod (name, so1, meta)))
+ (status#ppterm ~subst ~metasenv ~context arity2))) exc)
in
aux metasenv subst ((name, C.Decl so1)::context)
- (mkapp (NCicSubstitution.lift 1 ind) (C.Rel 1)) de1 meta
+ (mkapp (NCicSubstitution.lift status 1 ind) (C.Rel 1)) de1 meta
| C.Sort _ (* , t ==?== C.Prod _ *) ->
let metasenv, _, meta, _ = NCicMetaSubst.mk_meta metasenv [] `IsSort in
let metasenv, subst =
- try NCicUnification.unify rdb metasenv subst context
+ try NCicUnification.unify status metasenv subst context
arity2 (C.Prod ("_", ind, meta))
with exc -> raise (wrap_exc (lazy (localise orig, Printf.sprintf
"expected %s, found %s" (* XXX localizzare meglio *)
- (NCicPp.ppterm ~subst ~metasenv ~context (C.Prod ("_", ind, meta)))
- (NCicPp.ppterm ~subst ~metasenv ~context arity2))) exc)
+ (status#ppterm ~subst ~metasenv ~context (C.Prod ("_", ind, meta)))
+ (status#ppterm ~subst ~metasenv ~context arity2))) exc)
in
- (try NCicTypeChecker.check_allowed_sort_elimination
+ (try NCicTypeChecker.check_allowed_sort_elimination status
~metasenv ~subst r context ind arity1 arity2;
metasenv, subst
with exc -> raise (wrap_exc (lazy (localise orig,
aux
;;
-let rec typeof rdb
+let rec typeof (status:#NCicCoercion.status)
?(localise=fun _ -> Stdpp.dummy_loc)
metasenv subst context term expty
=
| C.Appl _ when skip_appl -> metasenv, subst, t, expty
| _ ->
pp (lazy ("forcing infty=expty: "^
- (NCicPp.ppterm ~metasenv ~subst ~context infty) ^ " === " ^
- (NCicPp.ppterm ~metasenv ~subst:[] ~context expty)));
+ (status#ppterm ~metasenv ~subst ~context infty) ^ " === " ^
+ (status#ppterm ~metasenv ~subst:[] ~context expty)));
try
let metasenv, subst =
(*D*)inside 'U'; try let rc =
- NCicUnification.unify rdb metasenv subst context infty expty
+ NCicUnification.unify status metasenv subst context infty expty
(*D*)in outside true; rc with exc -> outside false; raise exc
in
metasenv, subst, t, expty
with
| NCicUnification.Uncertain _
| NCicUnification.UnificationFailure _ as exc ->
- try_coercions rdb ~localise
+ try_coercions status ~localise
metasenv subst context t orig infty expty true exc)
| None -> metasenv, subst, t, infty
(*D*)in outside true; rc with exc -> outside false; raise exc
let rec typeof_aux metasenv subst context expty =
fun t as orig ->
(*D*)inside 'R'; try let rc =
- pp (lazy (NCicPp.ppterm ~metasenv ~subst ~context t ^ " ::exp:: " ^
+ pp (lazy (status#ppterm ~metasenv ~subst ~context t ^ " ::exp:: " ^
match expty with None -> "None" | Some e ->
- NCicPp.ppterm ~metasenv ~subst ~context e));
+ status#ppterm ~metasenv ~subst ~context e));
let metasenv, subst, t, infty =
match t with
| C.Rel n ->
let infty =
(try
match List.nth context (n - 1) with
- | (_,C.Decl ty) -> NCicSubstitution.lift n ty
- | (_,C.Def (_,ty)) -> NCicSubstitution.lift n ty
+ | (_,C.Decl ty) -> NCicSubstitution.lift status n ty
+ | (_,C.Def (_,ty)) -> NCicSubstitution.lift status n ty
with Failure _ ->
raise (RefineFailure (lazy (localise t,"unbound variable"))))
in
| NCicEnvironment.AssertFailure msg -> raise (AssertFailure msg))
| C.Implicit infos ->
let (metasenv,_,t,ty),subst =
- exp_implicit rdb ~localise metasenv subst context expty t infos
+ exp_implicit status ~localise metasenv subst context expty t infos
in
if expty = None then
typeof_aux metasenv subst context None t
with NCicUtils.Subst_not_found _ ->
NCicMetaSubst.extend_meta metasenv n
in
- metasenv, subst, t, NCicSubstitution.subst_meta l ty
+ metasenv, subst, t, NCicSubstitution.subst_meta status l ty
| C.Const _ ->
- metasenv, subst, t, NCicTypeChecker.typeof ~subst ~metasenv context t
+ metasenv, subst, t, NCicTypeChecker.typeof status ~subst ~metasenv context t
| C.Prod (name,(s as orig_s),(t as orig_t)) ->
let metasenv, subst, s, s1 = typeof_aux metasenv subst context None s in
let metasenv, subst, s, s1 =
- force_to_sort rdb
+ force_to_sort status
metasenv subst context s orig_s localise s1 in
let context1 = (name,(C.Decl s))::context in
let metasenv, subst, t, s2 = typeof_aux metasenv subst context1 None t in
let metasenv, subst, t, s2 =
- force_to_sort rdb
+ force_to_sort status
metasenv subst context1 t orig_t localise s2 in
let metasenv, subst, s, t, ty =
- sort_of_prod localise metasenv subst
+ sort_of_prod status localise metasenv subst
context orig_s orig_t (name,s) t (s1,s2)
in
metasenv, subst, NCic.Prod(name,s,t), ty
match expty with
| None -> None, None, false
| Some expty ->
- match NCicReduction.whd ~subst context expty with
+ match NCicReduction.whd status ~subst context expty with
| C.Prod (_,s,t) -> Some s, Some t, false
| _ -> None, None, true
in
| _ -> false)
with
| _ -> false) -> metasenv, subst, s
- | _ -> check_type rdb ~localise metasenv subst context s in
+ | _ -> check_type status ~localise metasenv subst context s in
(try
- pp(lazy("Force source to: "^NCicPp.ppterm ~metasenv ~subst
+ pp(lazy("Force source to: "^status#ppterm ~metasenv ~subst
~context exp_s));
- NCicUnification.unify ~test_eq_only:true rdb metasenv subst context s exp_s,s
+ NCicUnification.unify ~test_eq_only:true status metasenv subst context s exp_s,s
with exc -> raise (wrap_exc (lazy (localise orig_s, Printf.sprintf
- "Source type %s was expected to be %s" (NCicPp.ppterm ~metasenv
- ~subst ~context s) (NCicPp.ppterm ~metasenv ~subst ~context
+ "Source type %s was expected to be %s" (status#ppterm ~metasenv
+ ~subst ~context s) (status#ppterm ~metasenv ~subst ~context
exp_s))) exc)))
| None ->
let metasenv, subst, s =
- check_type rdb ~localise metasenv subst context s in
+ check_type status ~localise metasenv subst context s in
(metasenv, subst), s
in
let context_for_t = (n,C.Decl s) :: context in
metasenv, subst, C.Lambda(n,s,t), C.Prod (n,s,ty_t)
| C.LetIn (n,ty,t,bo) ->
let metasenv, subst, ty =
- check_type rdb ~localise metasenv subst context ty in
+ check_type status ~localise metasenv subst context ty in
let metasenv, subst, t, _ =
typeof_aux metasenv subst context (Some ty) t in
let context1 = (n, C.Def (t,ty)) :: context in
| Some x ->
let m, s, x =
NCicUnification.delift_type_wrt_terms
- rdb metasenv subst context1 (NCicSubstitution.lift 1 x)
- [NCicSubstitution.lift 1 t]
+ status metasenv subst context1 (NCicSubstitution.lift status 1 x)
+ [NCicSubstitution.lift status 1 t]
in
m, s, Some x
in
let metasenv, subst, bo, bo_ty =
typeof_aux metasenv subst context1 expty1 bo
in
- let bo_ty = NCicSubstitution.subst ~avoid_beta_redexes:true t bo_ty in
+ let bo_ty = NCicSubstitution.subst status ~avoid_beta_redexes:true t bo_ty in
metasenv, subst, C.LetIn (n, ty, t, bo), bo_ty
| C.Appl ((he as orig_he)::(_::_ as args)) ->
let upto = match orig_he with C.Meta _ -> List.length args | _ -> 0 in
let hbr t =
- if upto > 0 then NCicReduction.head_beta_reduce ~upto t else t
+ if upto > 0 then NCicReduction.head_beta_reduce status ~upto t else t
in
let refine_appl metasenv subst args =
let metasenv, subst, he, ty_he =
typeof_aux metasenv subst context None he in
let metasenv, subst, t, ty =
- eat_prods rdb ~localise force_ty metasenv subst context expty t
+ eat_prods status ~localise force_ty metasenv subst context expty t
orig_he he ty_he args in
metasenv, subst, hbr t, ty
in
(match he with
C.Const (Ref.Ref (uri1,Ref.Con _)) -> (
match
- HExtlib.map_option (NCicReduction.whd ~subst context) expty
+ HExtlib.map_option (NCicReduction.whd status ~subst context) expty
with
Some (C.Appl(C.Const(Ref.Ref (uri2,Ref.Ind _) as ref)::expargs))
when NUri.eq uri1 uri2 ->
(try
- let _,leftno,_,_,_ = NCicEnvironment.get_checked_indtys ref in
+ let _,leftno,_,_,_ = NCicEnvironment.get_checked_indtys status ref in
let leftexpargs,_ = HExtlib.split_nth leftno expargs in
let rec instantiate metasenv subst revargs args =
function
let metasenv,subst,arg,_ =
typeof_aux metasenv subst context None arg in
let metasenv,subst =
- NCicUnification.unify rdb metasenv subst context
+ NCicUnification.unify status metasenv subst context
arg exparg
in
instantiate metasenv subst(arg::revargs) args expargs
| C.Appl _ -> raise (AssertFailure (lazy "Appl of length < 2"))
| C.Match (Ref.Ref (_,Ref.Ind (_,tyno,_)) as r,
outtype,(term as orig_term),pl) as orig ->
- let _, leftno, itl, _, _ = NCicEnvironment.get_checked_indtys r in
+ let _, leftno, itl, _, _ = NCicEnvironment.get_checked_indtys status r in
let _, _, arity, cl = List.nth itl tyno in
let constructorsno = List.length cl in
let _, metasenv, args =
- NCicMetaSubst.saturate metasenv subst context arity 0 in
+ NCicMetaSubst.saturate status metasenv subst context arity 0 in
let ind = if args = [] then C.Const r else C.Appl (C.Const r::args) in
let metasenv, subst, term, _ =
typeof_aux metasenv subst context (Some ind) term in
let metasenv, subst, ind, ind_ty =
typeof_aux metasenv subst context None ind in
let metasenv, subst =
- check_allowed_sort_elimination rdb localise r orig_term metasenv subst
+ check_allowed_sort_elimination status localise r orig_term metasenv subst
context ind ind_ty outsort
in
(* let's check if the type of branches are right *)
match expty with
| None -> metasenv, subst
| Some expty ->
- NCicUnification.unify rdb metasenv subst context resty expty
+ NCicUnification.unify status metasenv subst context resty expty
in
*)
let _, metasenv, subst, pl =
let metasenv, subst, cons, ty_cons =
typeof_aux metasenv subst context None cons in
let ty_branch =
- NCicTypeChecker.type_of_branch
+ NCicTypeChecker.type_of_branch status
~subst context leftno outtype cons ty_cons in
pp (lazy ("TYPEOFBRANCH: " ^
- NCicPp.ppterm ~metasenv ~subst ~context p ^ " ::inf:: " ^
- NCicPp.ppterm ~metasenv ~subst ~context ty_branch ));
+ status#ppterm ~metasenv ~subst ~context p ^ " ::inf:: " ^
+ status#ppterm ~metasenv ~subst ~context ty_branch ));
let metasenv, subst, p, _ =
typeof_aux metasenv subst context (Some ty_branch) p in
j-1, metasenv, subst, p :: branches)
pl (List.length pl, metasenv, subst, [])
in
let resty = C.Appl (outtype::arguments@[term]) in
- let resty = NCicReduction.head_beta_reduce ~subst resty in
+ let resty = NCicReduction.head_beta_reduce status ~subst resty in
metasenv, subst, C.Match (r, outtype, term, pl),resty
| C.Match _ -> assert false
in
- pp (lazy (NCicPp.ppterm ~metasenv ~subst ~context t ^ " ::inf:: "^
- NCicPp.ppterm ~metasenv ~subst ~context infty ));
+ pp (lazy (status#ppterm ~metasenv ~subst ~context t ^ " ::inf:: "^
+ status#ppterm ~metasenv ~subst ~context infty ));
force_ty true true metasenv subst context orig t infty expty
(*D*)in outside true; rc with exc -> outside false; raise exc
in
typeof_aux metasenv subst context expty term
-and check_type rdb ~localise metasenv subst context (ty as orig_ty) =
+and check_type status ~localise metasenv subst context (ty as orig_ty) =
let metasenv, subst, ty, sort =
- typeof rdb ~localise metasenv subst context ty None
+ typeof status ~localise metasenv subst context ty None
in
let metasenv, subst, ty, _ =
- force_to_sort rdb metasenv subst context ty orig_ty localise sort
+ force_to_sort status metasenv subst context ty orig_ty localise sort
in
metasenv, subst, ty
-and try_coercions rdb
+and try_coercions status
~localise
metasenv subst context t orig_t infty expty perform_unification exc
=
- let cs_subst = NCicSubstitution.subst ~avoid_beta_redexes:true in
+ let cs_subst = NCicSubstitution.subst status ~avoid_beta_redexes:true in
try
pp (lazy "WWW: trying coercions -- preliminary unification");
let metasenv, subst =
- NCicUnification.unify rdb metasenv subst context infty expty
+ NCicUnification.unify status metasenv subst context infty expty
in metasenv, subst, t, expty
with
| exn ->
pp (lazy "WWW: no more coercions!");
raise (wrap_exc (lazy (localise orig_t, Printf.sprintf
"The term\n%s\nhas type\n%s\nbut is here used with type\n%s"
- (NCicPp.ppterm ~metasenv ~subst ~context t)
- (NCicPp.ppterm ~metasenv ~subst ~context infty)
- (NCicPp.ppterm ~metasenv ~subst ~context expty))) exc)
+ (status#ppterm ~metasenv ~subst ~context t)
+ (status#ppterm ~metasenv ~subst ~context infty)
+ (status#ppterm ~metasenv ~subst ~context expty))) exc)
| (_,metasenv, newterm, newtype, meta)::tl ->
try
- pp (lazy("K=" ^ NCicPp.ppterm ~metasenv ~subst ~context newterm));
+ pp (lazy("K=" ^ status#ppterm ~metasenv ~subst ~context newterm));
pp (lazy ( "UNIFICATION in CTX:\n"^
- NCicPp.ppcontext ~metasenv ~subst context
+ status#ppcontext ~metasenv ~subst context
^ "\nMENV: " ^
- NCicPp.ppmetasenv metasenv ~subst
+ status#ppmetasenv metasenv ~subst
^ "\nOF: " ^
- NCicPp.ppterm ~metasenv ~subst ~context t ^ " === " ^
- NCicPp.ppterm ~metasenv ~subst ~context meta ^ "\n"));
+ status#ppterm ~metasenv ~subst ~context t ^ " === " ^
+ status#ppterm ~metasenv ~subst ~context meta ^ "\n"));
let metasenv, subst =
- NCicUnification.unify rdb metasenv subst context t meta
+ NCicUnification.unify status metasenv subst context t meta
in
pp (lazy ( "UNIFICATION in CTX:\n"^
- NCicPp.ppcontext ~metasenv ~subst context
+ status#ppcontext ~metasenv ~subst context
^ "\nMENV: " ^
- NCicPp.ppmetasenv metasenv ~subst
+ status#ppmetasenv metasenv ~subst
^ "\nOF: " ^
- NCicPp.ppterm ~metasenv ~subst ~context newtype ^ " === " ^
- NCicPp.ppterm ~metasenv ~subst ~context expty ^ "\n"));
+ status#ppterm ~metasenv ~subst ~context newtype ^ " === " ^
+ status#ppterm ~metasenv ~subst ~context expty ^ "\n"));
let metasenv, subst =
if perform_unification then
- NCicUnification.unify rdb metasenv subst context newtype expty
+ NCicUnification.unify status metasenv subst context newtype expty
else metasenv, subst
in
metasenv, subst, newterm, newtype
let get_cl_and_left_p refit outty =
match refit with
| NReference.Ref (uri, NReference.Ind (_,tyno,leftno)) ->
- let _, leftno, itl, _, _ = NCicEnvironment.get_checked_indtys r in
+ let _, leftno, itl, _, _ = NCicEnvironment.get_checked_indtys status r in
let _, _, ty, cl = List.nth itl tyno in
let constructorsno = List.length cl in
let count_pis t =
let rec aux ctx t =
- match NCicReduction.whd ~subst ~delta:max_int ctx t with
+ match NCicReduction.whd status ~subst ~delta:max_int ctx t with
| NCic.Prod (name,src,tgt) ->
let ctx = (name, (NCic.Decl src)) :: ctx in
1 + aux ctx tgt
match t,n with
| _,0 -> t
| NCic.Lambda (_,_,t),n ->
- pp (lazy ("WWW: failing term? "^ NCicPp.ppterm ~subst:[] ~metasenv:[] ~context:[] t));
+ pp (lazy ("WWW: failing term? "^ status#ppterm ~subst:[] ~metasenv:[] ~context:[] t));
skip_lambda_delifting
(* substitute dangling indices with a dummy *)
- (NCicSubstitution.subst (NCic.Sort NCic.Prop) t) (n - 1)
+ (NCicSubstitution.subst status (NCic.Sort NCic.Prop) t) (n - 1)
| _ -> assert false
in
let get_l_r_p n = function
let rec mkr n = function
| [] -> [] | _::tl -> NCic.Rel n :: mkr (n+1) tl
in
- pp (lazy ("input replace: " ^ NCicPp.ppterm ~context:ctx ~metasenv:[] ~subst:[] bo));
+ pp (lazy ("input replace: " ^ status#ppterm ~context:ctx ~metasenv:[] ~subst:[] bo));
let bo =
- NCicRefineUtil.replace_lifting
- ~equality:(fun _ -> NCicRefineUtil.alpha_equivalence)
+ NCicRefineUtil.replace_lifting status
+ ~equality:(fun _ -> NCicRefineUtil.alpha_equivalence status)
~context:ctx
~what:(matched::right_p)
~with_what:(NCic.Rel 1::List.rev (mkr 2 right_p))
~where:bo
in
- pp (lazy ("output replace: " ^ NCicPp.ppterm ~context:ctx ~metasenv:[] ~subst:[] bo));
+ pp (lazy ("output replace: " ^ status#ppterm ~context:ctx ~metasenv:[] ~subst:[] bo));
bo
| NCic.Lambda (name, src, tgt),_ ->
NCic.Lambda (name, src,
keep_lambdas_and_put_expty
- ((name, NCic.Decl src)::ctx) tgt (NCicSubstitution.lift 1 bo)
- (List.map (NCicSubstitution.lift 1) right_p) (NCicSubstitution.lift 1 matched) (n-1))
+ ((name, NCic.Decl src)::ctx) tgt (NCicSubstitution.lift status 1 bo)
+ (List.map (NCicSubstitution.lift status 1) right_p) (NCicSubstitution.lift status 1 matched) (n-1))
| _ -> assert false
in
(*let eq = NCic.Const (NReference.reference_of_string ("cic:/matita/ng/Plogic/equality/eq.ind(1,0,2)")) in
let t,k =
aux
((name, NCic.Decl src) :: context)
- (NCicSubstitution.lift 1 outty) (NCic.Rel j::par) (j+1)
- (NCicSubstitution.lift 1 mty) (NCicSubstitution.lift 1 m) tgt
+ (NCicSubstitution.lift status 1 outty) (NCic.Rel j::par) (j+1)
+ (NCicSubstitution.lift status 1 mty) (NCicSubstitution.lift status 1 m) tgt
in
NCic.Prod (name, src, t), k
| NCic.Const (Ref.Ref (_,Ref.Ind (_,_,leftno)) as r) ->
in *)
NCic.Prod ("p",
NCic.Appl [eq; mty; m; mty; k],
- (NCicSubstitution.lift 1
- (NCicReduction.head_beta_reduce ~delta:max_int
+ (NCicSubstitution.lift status 1
+ (NCicReduction.head_beta_reduce status ~delta:max_int
(NCicUntrusted.mk_appl outty [k])))),[mty,m,mty,k]
| NCic.Appl (NCic.Const (Ref.Ref (_,Ref.Ind (_,_,leftno)) as r)::pl) ->
let left_p,right_p = HExtlib.split_nth leftno pl in
in
let right_p =
try match
- NCicTypeChecker.typeof ~subst ~metasenv context k
+ NCicTypeChecker.typeof status ~subst ~metasenv context k
with
| NCic.Appl (NCic.Const (Ref.Ref (_,Ref.Ind (_,_,_)))::args) ->
snd (HExtlib.split_nth leftno args)
List.fold_right2
(fun x y (tacc,pacc) ->
let xty =
- try NCicTypeChecker.typeof ~subst ~metasenv context x
+ try NCicTypeChecker.typeof status ~subst ~metasenv context x
with NCicTypeChecker.TypeCheckerFailure _ -> assert false
in
let yty =
- try NCicTypeChecker.typeof ~subst ~metasenv context y
+ try NCicTypeChecker.typeof status ~subst ~metasenv context y
with NCicTypeChecker.TypeCheckerFailure _ -> assert false
in
NCic.Prod ("_", NCic.Appl [eq;xty;x;yty;y],
- NCicSubstitution.lift 1 tacc), (xty,x,yty,y)::pacc)
+ NCicSubstitution.lift status 1 tacc), (xty,x,yty,y)::pacc)
(orig_right_p @ [m]) (right_p @ [k])
- (NCicReduction.head_beta_reduce ~delta:max_int
+ (NCicReduction.head_beta_reduce status ~delta:max_int
(NCicUntrusted.mk_appl outty (right_p@[k])), [])
(* if has_rights then
- NCicReduction.head_beta_reduce ~delta:max_int
+ NCicReduction.head_beta_reduce status ~delta:max_int
(NCic.Appl (outty ::right_p @ [k])),k
else
NCic.Prod ("p",
NCic.Appl [eq; mty; m; k],
- (NCicSubstitution.lift 1
- (NCicReduction.head_beta_reduce ~delta:max_int
+ (NCicSubstitution.lift status 1
+ (NCicReduction.head_beta_reduce status ~delta:max_int
(NCic.Appl (outty ::right_p @ [k]))))),k*)
| _ -> assert false
in
| t,_ -> snd (List.fold_right
(fun (xty,x,yty,y) (n,acc) -> n+1, NCic.Lambda ("p" ^ string_of_int n,
NCic.Appl [eq; xty; x; yty; y],
- NCicSubstitution.lift 1 acc)) eqs (1,t))
+ NCicSubstitution.lift status 1 acc)) eqs (1,t))
(*NCic.Lambda ("p",
- NCic.Appl [eq; mty; m; k],NCicSubstitution.lift 1 t)*)
+ NCic.Appl [eq; mty; m; k],NCicSubstitution.lift status 1 t)*)
in
aux (pbo,cty)
in
let rec aux context mty m = function
| NCic.Lambda (name, src, tgt) ->
let context = (name, NCic.Decl src)::context in
- NCic.Lambda (name, src, aux context (NCicSubstitution.lift 1 mty) (NCicSubstitution.lift 1 m) tgt)
+ NCic.Lambda (name, src, aux context (NCicSubstitution.lift status 1 mty) (NCicSubstitution.lift status 1 m) tgt)
| t ->
let lhs =
match mty with
List.fold_right2
(fun x y acc ->
let xty =
- try NCicTypeChecker.typeof ~subst ~metasenv context x
+ try NCicTypeChecker.typeof status ~subst ~metasenv context x
with NCicTypeChecker.TypeCheckerFailure _ -> assert false
in
let yty =
- try NCicTypeChecker.typeof ~subst ~metasenv context y
+ try NCicTypeChecker.typeof status ~subst ~metasenv context y
with NCicTypeChecker.TypeCheckerFailure _ -> assert false
in
NCic.Prod
("_", NCic.Appl [eq;xty;x;yty;y],
- (NCicSubstitution.lift 1 acc)))
+ (NCicSubstitution.lift status 1 acc)))
lhs rhs t
(* NCic.Prod
("_", NCic.Appl [eq;mty;m;NCic.Rel 1],
- NCicSubstitution.lift 1 t)*)
+ NCicSubstitution.lift status 1 t)*)
in
aux context mty m new_outty
in (* }}} end helper functions *)
(* constructors types with left params already instantiated *)
- let outty = NCicUntrusted.apply_subst subst context outty in
+ let outty = NCicUntrusted.apply_subst status subst context outty in
let cl, left_p, leftno,rno =
get_cl_and_left_p r outty
in
let right_p, mty =
try
match
- NCicTypeChecker.typeof ~subst ~metasenv context m
+ NCicTypeChecker.typeof status ~subst ~metasenv context m
with
| (NCic.Const (Ref.Ref (_,Ref.Ind (_,_,_))) | NCic.Meta _) as mty -> [], mty
| NCic.Appl ((NCic.Const (Ref.Ref (_,Ref.Ind (_,_,_)))|NCic.Meta _)::args) as mty ->
with NCicTypeChecker.TypeCheckerFailure _ ->
raise (AssertFailure(lazy "already ill-typed matched term"))
in
- let mty = NCicUntrusted.apply_subst subst context mty in
- let outty = NCicUntrusted.apply_subst subst context outty in
- let expty = NCicUntrusted.apply_subst subst context expty in
+ let mty = NCicUntrusted.apply_subst status subst context mty in
+ let outty = NCicUntrusted.apply_subst status subst context outty in
+ let expty = NCicUntrusted.apply_subst status subst context expty in
let new_outty =
keep_lambdas_and_put_expty context outty expty right_p m (rno+1)
in
pp
- (lazy ("CASE: new_outty: " ^ NCicPp.ppterm
+ (lazy ("CASE: new_outty: " ^ status#ppterm
~context ~metasenv ~subst new_outty));
let _,pl,subst,metasenv =
List.fold_right2
let infty_pbo, _ =
add_params menv s context cty outty mty m i in
pp
- (lazy ("CASE: infty_pbo: "^ NCicPp.ppterm
+ (lazy ("CASE: infty_pbo: "^ status#ppterm
~context ~metasenv ~subst infty_pbo));
let expty_pbo, eqs = (* k is (K_i left_par k_par) *)
add_params menv s context cty new_outty mty m i in
pp
- (lazy ("CASE: expty_pbo: "^ NCicPp.ppterm
+ (lazy ("CASE: expty_pbo: "^ status#ppterm
~context ~metasenv ~subst expty_pbo));
let pbo = add_lambda_for_refl_m pbo eqs cty in
pp
- (lazy ("CASE: pbo: " ^ NCicPp.ppterm
+ (lazy ("CASE: pbo: " ^ status#ppterm
~context ~metasenv ~subst pbo));
let metasenv, subst, pbo, _ =
- try_coercions rdb ~localise menv s context pbo
+ try_coercions status ~localise menv s context pbo
orig_t (*??*) infty_pbo expty_pbo perform_unification exc
in
pp
- (lazy ("CASE: pbo2: " ^ NCicPp.ppterm
+ (lazy ("CASE: pbo2: " ^ status#ppterm
~context ~metasenv ~subst pbo));
(i-1, pbo::acc, subst, metasenv))
cl pl (List.length pl, [], subst, metasenv)
in
(*let metasenv, subst =
try
- NCicUnification.unify rdb metasenv subst context outty new_outty
+ NCicUnification.unify status metasenv subst context outty new_outty
with _ -> raise (RefineFailure (lazy (localise orig_t, "try_coercions")))
in*)
let new_outty = add_pi_for_refl_m context new_outty mty m leftno rno in
- pp (lazy ("CASE: new_outty: " ^ (NCicPp.ppterm
+ pp (lazy ("CASE: new_outty: " ^ (status#ppterm
~metasenv ~subst ~context new_outty)));
let right_tys =
List.map
- (fun t -> NCicTypeChecker.typeof ~subst ~metasenv context t) right_p in
+ (fun t -> NCicTypeChecker.typeof status ~subst ~metasenv context t) right_p in
let eqs =
List.map2 (fun x y -> NCic.Appl[eq_refl;x;y]) (right_tys@[mty])
(right_p@[m]) in
else mk_fresh_name ctx firstch (n+1)
in
(*{{{*) pp (lazy "LAM");
- pp (lazy ("LAM: t = " ^ NCicPp.ppterm ~metasenv ~subst ~context t));
+ pp (lazy ("LAM: t = " ^ status#ppterm ~metasenv ~subst ~context t));
let name_con = mk_fresh_name context 'c' 0
(*FreshNamesGenerator.mk_fresh_name
~subst metasenv context ~typ:src2 Cic.Anonymous*)
let context_src2 = ((name_con, NCic.Decl src2) :: context) in
(* contravariant part: the argument of f:src->ty *)
let metasenv, subst, rel1, _ =
- try_coercions rdb ~localise metasenv subst context_src2
- (NCic.Rel 1) orig_t (NCicSubstitution.lift 1 src2)
- (NCicSubstitution.lift 1 src) perform_unification exc
+ try_coercions status ~localise metasenv subst context_src2
+ (NCic.Rel 1) orig_t (NCicSubstitution.lift status 1 src2)
+ (NCicSubstitution.lift status 1 src) perform_unification exc
in
(* covariant part: the result of f(c x); x:src2; (c x):src *)
let name_t, bo =
match t with
- | NCic.Lambda (n,_,bo) -> n, cs_subst rel1 (NCicSubstitution.lift_from 2 1 bo)
- | _ -> name_con, NCicUntrusted.mk_appl (NCicSubstitution.lift 1 t) [rel1]
+ | NCic.Lambda (n,_,bo) -> n, cs_subst rel1 (NCicSubstitution.lift_from status 2 1 bo)
+ | _ -> name_con, NCicUntrusted.mk_appl (NCicSubstitution.lift status 1 t) [rel1]
in
(* we fix the possible dependency problem in the source ty *)
- let ty = cs_subst rel1 (NCicSubstitution.lift_from 2 1 ty) in
+ let ty = cs_subst rel1 (NCicSubstitution.lift_from status 2 1 ty) in
let metasenv, subst, bo, _ =
- try_coercions rdb ~localise metasenv subst context_src2
+ try_coercions status ~localise metasenv subst context_src2
bo orig_t ty ty2 perform_unification exc
in
let coerced = NCic.Lambda (name_t,src2, bo) in
- pp (lazy ("LAM: coerced = " ^ NCicPp.ppterm ~metasenv ~subst ~context coerced));
+ pp (lazy ("LAM: coerced = " ^ status#ppterm ~metasenv ~subst ~context coerced));
metasenv, subst, coerced, expty (*}}}*)
| _ -> raise exc
with exc2 ->
pp(lazy("try_coercion " ^
- NCicPp.ppterm ~metasenv ~subst ~context infty ^ " |---> " ^
- NCicPp.ppterm ~metasenv ~subst ~context expty));
+ status#ppterm ~metasenv ~subst ~context infty ^ " |---> " ^
+ status#ppterm ~metasenv ~subst ~context expty));
first exc
(NCicCoercion.look_for_coercion
- rdb metasenv subst context infty expty)
+ status metasenv subst context infty expty)
-and force_to_sort rdb metasenv subst context t orig_t localise ty =
+and force_to_sort status metasenv subst context t orig_t localise ty =
try
let metasenv, subst, ty =
- NCicUnification.sortfy (Failure "sortfy") metasenv subst context ty in
+ NCicUnification.sortfy status (Failure "sortfy") metasenv subst context ty in
metasenv, subst, t, ty
with
Failure _ ->
- let ty = NCicReduction.whd ~subst context ty in
- try_coercions rdb ~localise metasenv subst context
+ let ty = NCicReduction.whd status ~subst context ty in
+ try_coercions status ~localise metasenv subst context
t orig_t ty (NCic.Sort (NCic.Type
(match NCicEnvironment.get_universes () with
| x::_ -> x
| _ -> assert false))) false
(Uncertain (lazy (localise orig_t,
- "The type of " ^ NCicPp.ppterm ~metasenv ~subst ~context t ^
- " is not a sort: " ^ NCicPp.ppterm ~metasenv ~subst ~context ty)))
+ "The type of " ^ status#ppterm ~metasenv ~subst ~context t ^
+ " is not a sort: " ^ status#ppterm ~metasenv ~subst ~context ty)))
-and sort_of_prod
- localise metasenv subst context orig_s orig_t (name,s) t (t1, t2)
+and sort_of_prod status localise metasenv subst context orig_s orig_t (name,s)
+ t (t1, t2)
=
(* force to sort is done in the Prod case in typeof *)
match t1, t2 with
in
raise (RefineFailure (lazy (localise orig,Printf.sprintf
"%s is expected to be a type, but its type is %s that is not a sort"
- (NCicPp.ppterm ~subst ~metasenv ~context y)
- (NCicPp.ppterm ~subst ~metasenv ~context x))))
+ (status#ppterm ~subst ~metasenv ~context y)
+ (status#ppterm ~subst ~metasenv ~context x))))
-and guess_name subst ctx ty =
+and guess_name status subst ctx ty =
let aux initial = "#" ^ String.make 1 initial in
match ty with
| C.Const (NReference.Ref (u,_))
| C.Meta (n,lc) ->
(try
let _,_,t,_ = NCicUtils.lookup_subst n subst in
- guess_name subst ctx (NCicSubstitution.subst_meta lc t)
+ guess_name status subst ctx (NCicSubstitution.subst_meta status lc t)
with NCicUtils.Subst_not_found _ -> aux 'M')
| _ -> aux 'H'
-and eat_prods rdb ~localise force_ty metasenv subst context expty orig_t orig_he he ty_he args =
+and eat_prods status ~localise force_ty metasenv subst context expty orig_t orig_he he ty_he args =
(*D*)inside 'E'; try let rc =
let rec aux metasenv subst args_so_far he ty_he xxx =
(*D*)inside 'V'; try let rc =
| [] ->
let res = NCicUntrusted.mk_appl he (List.rev args_so_far) in
pp(lazy("FORCE FINAL APPL: " ^
- NCicPp.ppterm ~metasenv ~subst ~context res ^
- " of type " ^ NCicPp.ppterm ~metasenv ~subst ~context ty_he
+ status#ppterm ~metasenv ~subst ~context res ^
+ " of type " ^ status#ppterm ~metasenv ~subst ~context ty_he
^ " to type " ^ match expty with None -> "None" | Some x ->
- NCicPp.ppterm ~metasenv ~subst ~context x));
+ status#ppterm ~metasenv ~subst ~context x));
(* whatever the term is, we force the type. in case of ((Lambda..) ?...)
* the application may also be a lambda! *)
force_ty false false metasenv subst context orig_t res ty_he expty
| NCic.Implicit `Vector::tl ->
let has_some_more_pis x =
- match NCicReduction.whd ~subst context x with
+ match NCicReduction.whd status ~subst context x with
| NCic.Meta _ | NCic.Appl (NCic.Meta _::_) -> false
| _ -> true
in
(* instantiating the head could change the has_some_more_pis flag *)
raise (Uncertain msg))
| arg::tl ->
- match NCicReduction.whd ~subst context ty_he with
+ match NCicReduction.whd status ~subst context ty_he with
| C.Prod (_,s,t) ->
let metasenv, subst, arg, _ =
- typeof rdb ~localise metasenv subst context arg (Some s) in
- let t = NCicSubstitution.subst ~avoid_beta_redexes:true arg t in
+ typeof status ~localise metasenv subst context arg (Some s) in
+ let t = NCicSubstitution.subst status ~avoid_beta_redexes:true arg t in
aux metasenv subst (arg :: args_so_far) he t tl
| C.Meta _
| C.Appl (C.Meta _ :: _) as t ->
let metasenv, subst, arg, ty_arg =
- typeof rdb ~localise metasenv subst context arg None in
- let name = guess_name subst context ty_arg in
+ typeof status ~localise metasenv subst context arg None in
+ let name = guess_name status subst context ty_arg in
let metasenv, _, meta, _ =
NCicMetaSubst.mk_meta metasenv
((name,C.Decl ty_arg) :: context) `IsType
let flex_prod = C.Prod (name, ty_arg, meta) in
(* next line grants that ty_args is a type *)
let metasenv,subst, flex_prod, _ =
- typeof rdb ~localise metasenv subst context flex_prod None in
+ typeof status ~localise metasenv subst context flex_prod None in
(*
pp (lazy ( "UNIFICATION in CTX:\n"^
- NCicPp.ppcontext ~metasenv ~subst context
+ status#ppcontext ~metasenv ~subst context
^ "\nOF: " ^
- NCicPp.ppterm ~metasenv ~subst ~context t ^ " === " ^
- NCicPp.ppterm ~metasenv ~subst ~context flex_prod ^ "\n"));
+ status#ppterm ~metasenv ~subst ~context t ^ " === " ^
+ status#ppterm ~metasenv ~subst ~context flex_prod ^ "\n"));
*)
let metasenv, subst =
- try NCicUnification.unify rdb metasenv subst context t flex_prod
+ try NCicUnification.unify status metasenv subst context t flex_prod
with exc -> raise (wrap_exc (lazy (localise orig_he, Printf.sprintf
("The term %s has an inferred type %s, but is applied to the" ^^
" argument %s of type %s")
- (NCicPp.ppterm ~metasenv ~subst ~context he)
- (NCicPp.ppterm ~metasenv ~subst ~context t)
- (NCicPp.ppterm ~metasenv ~subst ~context arg)
- (NCicPp.ppterm ~metasenv ~subst ~context ty_arg)))
+ (status#ppterm ~metasenv ~subst ~context he)
+ (status#ppterm ~metasenv ~subst ~context t)
+ (status#ppterm ~metasenv ~subst ~context arg)
+ (status#ppterm ~metasenv ~subst ~context ty_arg)))
(match exc with
| NCicUnification.UnificationFailure m ->
NCicUnification.Uncertain m
| x -> x))
(* XXX coerce to funclass *)
in
- let meta = NCicSubstitution.subst ~avoid_beta_redexes:true arg meta in
+ let meta = NCicSubstitution.subst status ~avoid_beta_redexes:true arg meta in
aux metasenv subst (arg :: args_so_far) he meta tl
| C.Match (_,_,C.Meta _,_)
| C.Match (_,_,C.Appl (C.Meta _ :: _),_)
| C.Appl (C.Const (NReference.Ref (_, NReference.Fix _)) :: _) ->
raise (Uncertain (lazy (localise orig_he, Printf.sprintf
("The term %s is here applied to %d arguments but expects " ^^
- "only %d arguments") (NCicPp.ppterm ~metasenv ~subst ~context he)
+ "only %d arguments") (status#ppterm ~metasenv ~subst ~context he)
(List.length args) (List.length args_so_far))))
| ty ->
let metasenv, subst, newhead, newheadty =
- try_coercions rdb ~localise metasenv subst context
+ try_coercions status ~localise metasenv subst context
(NCicUntrusted.mk_appl he (List.rev args_so_far)) orig_he ty
(NCic.Prod ("_",NCic.Implicit `Term,NCic.Implicit `Term))
false
(RefineFailure (lazy (localise orig_he, Printf.sprintf
("The term %s is here applied to %d arguments but expects " ^^
- "only %d arguments") (NCicPp.ppterm ~metasenv ~subst ~context he)
+ "only %d arguments") (status#ppterm ~metasenv ~subst ~context he)
(List.length args) (List.length args_so_far))))
in
aux metasenv subst [] newhead newheadty (arg :: tl)
(try find add dt t with Not_found -> assert false)
;;
-let undebruijnate inductive ref t rev_fl =
+let undebruijnate status inductive ref t rev_fl =
let len = List.length rev_fl in
- NCicSubstitution.psubst (fun x -> x)
+ NCicSubstitution.psubst status (fun x -> x)
(HExtlib.list_mapi
(fun (_,_,rno,_,_,_) i ->
let i = len - i - 1 in
let typeof_obj
- rdb ?(localise=fun _ -> Stdpp.dummy_loc) (uri,height,metasenv,subst,obj)
+ status ?(localise=fun _ -> Stdpp.dummy_loc) (uri,height,metasenv,subst,obj)
=
match obj with
| C.Constant (relevance, name, bo, ty, attr) ->
let metasenv, subst, ty =
- check_type rdb ~localise metasenv subst [] ty in
+ check_type status ~localise metasenv subst [] ty in
let metasenv, subst, bo, ty, height =
match bo with
| Some bo ->
let metasenv, subst, bo, ty =
- typeof rdb ~localise metasenv subst [] bo (Some ty) in
+ typeof status ~localise metasenv subst [] bo (Some ty) in
let height = (* XXX recalculate *) height in
metasenv, subst, Some bo, ty, height
| None -> metasenv, subst, None, ty, 0
List.fold_left
(fun (types, metasenv, subst, fl) (relevance,name,k,ty,bo) ->
let metasenv, subst, ty =
- check_type rdb ~localise metasenv subst [] ty in
- let dbo = NCicTypeChecker.debruijn uri len [] ~subst bo in
+ check_type status ~localise metasenv subst [] ty in
+ let dbo = NCicTypeChecker.debruijn status uri len [] ~subst bo in
let localise = relocalise localise dbo bo in
(name,C.Decl ty)::types,
metasenv, subst, (relevance,name,k,ty,dbo,localise)::fl
List.fold_left
(fun (metasenv,subst,fl) (relevance,name,k,ty,dbo,localise) ->
let metasenv, subst, dbo, ty =
- typeof rdb ~localise metasenv subst types dbo (Some ty)
+ typeof status ~localise metasenv subst types dbo (Some ty)
in
metasenv, subst, (relevance,name,k,ty,dbo)::fl)
(metasenv, subst, []) rev_fl
List.map
(fun (relevance,name,k,ty,dbo) ->
let bo =
- undebruijnate inductive
+ undebruijnate status inductive
(NReference.reference_of_spec uri
(if inductive then NReference.Fix (0,k,0)
else NReference.CoFix 0)) dbo rev_fl
List.fold_left
(fun (metasenv,subst,res,ctx) (relevance,n,ty,cl) ->
let metasenv, subst, ty =
- check_type rdb ~localise metasenv subst [] ty in
+ check_type status ~localise metasenv subst [] ty in
metasenv,subst,(relevance,n,ty,cl)::res,(n,NCic.Decl ty)::ctx
) (metasenv,subst,[],[]) itl in
let metasenv,subst,itl,_ =
List.fold_left
(fun (metasenv,subst,res,i) (it_relev,n,ty,cl) ->
- let context,ty_sort = NCicReduction.split_prods ~subst [] ~-1 ty in
+ let context,ty_sort = NCicReduction.split_prods status ~subst [] ~-1 ty in
let sx_context_ty_rev,_= HExtlib.split_nth leftno (List.rev context) in
let metasenv,subst,cl =
List.fold_right
let k_relev =
try snd (HExtlib.split_nth leftno k_relev)
with Failure _ -> k_relev in
- let te = NCicTypeChecker.debruijn uri len [] ~subst te in
+ let te = NCicTypeChecker.debruijn status uri len [] ~subst te in
let metasenv, subst, te =
- check_type rdb ~localise metasenv subst tys te in
- let context,te = NCicReduction.split_prods ~subst tys leftno te in
+ check_type status ~localise metasenv subst tys te in
+ let context,te = NCicReduction.split_prods status ~subst tys leftno te in
let _,chopped_context_rev =
HExtlib.split_nth (List.length tys) (List.rev context) in
let sx_context_te_rev,_ =
match item1,item2 with
(n1,C.Decl ty1),(n2,C.Decl ty2) ->
if n1 = n2 then
- NCicUnification.unify rdb ~test_eq_only:true metasenv
+ NCicUnification.unify status ~test_eq_only:true metasenv
subst context ty1 ty2,true
else
(metasenv,subst),false
| (n1,C.Def (bo1,ty1)),(n2,C.Def (bo2,ty2)) ->
if n1 = n2 then
let metasenv,subst =
- NCicUnification.unify rdb ~test_eq_only:true metasenv
+ NCicUnification.unify status ~test_eq_only:true metasenv
subst context ty1 ty2
in
- NCicUnification.unify rdb ~test_eq_only:true metasenv
+ NCicUnification.unify status ~test_eq_only:true metasenv
subst context bo1 bo2,true
else
(metasenv,subst),false
let (metasenv, subst), _ =
List.fold_left
(fun ((metasenv, subst),l) arg ->
- NCicUnification.unify rdb
+ NCicUnification.unify status
~test_eq_only:true metasenv subst context arg
(NCic.Rel (ctxlen - len - l)), l+1
)
in
aux context (metasenv,subst) te
in
- let con_sort= NCicTypeChecker.typeof ~subst ~metasenv context te in
+ let con_sort= NCicTypeChecker.typeof status ~subst ~metasenv context te in
(match
- NCicReduction.whd ~subst context con_sort,
- NCicReduction.whd ~subst [] ty_sort
+ NCicReduction.whd status ~subst context con_sort,
+ NCicReduction.whd status ~subst [] ty_sort
with
(C.Sort (C.Type u1) as s1), (C.Sort (C.Type u2) as s2) ->
if not (NCicEnvironment.universe_leq u1 u2) then
raise
(RefineFailure
(lazy(localise te, "The type " ^
- NCicPp.ppterm ~metasenv ~subst ~context s1 ^
+ status#ppterm ~metasenv ~subst ~context s1 ^
" of the constructor is not included in the inductive"^
" type sort " ^
- NCicPp.ppterm ~metasenv ~subst ~context s2)))
+ status#ppterm ~metasenv ~subst ~context s2)))
| C.Sort _, C.Sort C.Prop
| C.Sort _, C.Sort C.Type _ -> ()
| _, _ ->
(* let's check also the positivity conditions *)
if
not
- (NCicTypeChecker.are_all_occurrences_positive
+ (NCicTypeChecker.are_all_occurrences_positive status
~subst context uri leftno (i+leftno) leftno (len+leftno) te)
then
raise
(RefineFailure
(lazy (localise te,
"Non positive occurence in " ^
- NCicPp.ppterm ~metasenv ~subst ~context te)))
+ status#ppterm ~metasenv ~subst ~context te)))
else
let relsno = List.length itl + leftno in
let te =
- NCicSubstitution.psubst
+ NCicSubstitution.psubst status
(fun i ->
if i <= leftno then
NCic.Rel i
method uhint_db: db
end
-class status =
+class virtual status =
object
+ inherit NCic.status
val db = HDB.empty, EQDB.empty
method uhint_db = db
method set_uhint_db v = {< db = v >}
let dummy = NCic.Const (NReference.reference_of_string "cic:/dummy_conv.dec");;
let pair t1 t2 = (NCic.Appl [dummy;t1;t2]) ;;
-let index_hint hdb context t1 t2 precedence =
+let index_hint status context t1 t2 precedence =
assert (
(match t1 with
| NCic.Meta _ | NCic.Appl (NCic.Meta _ :: _) -> false | _ -> true)
* the subst function that lives in the kernel *)
let hole = NCic.Meta (-1,(0,NCic.Irl 0)) in
let t1_skeleton =
- List.fold_left (fun t _ -> NCicSubstitution.subst hole t) t1 context
+ List.fold_left (fun t _ -> NCicSubstitution.subst status hole t) t1 context
in
let t2_skeleton =
- List.fold_left (fun t _ -> NCicSubstitution.subst hole t) t2 context
+ List.fold_left (fun t _ -> NCicSubstitution.subst status hole t) t2 context
in
let rec cleanup_skeleton () = function
| NCic.Meta _ -> skel_dummy
- | t -> NCicUtils.map (fun _ () -> ()) () cleanup_skeleton t
+ | t -> NCicUtils.map status (fun _ () -> ()) () cleanup_skeleton t
in
let t1_skeleton = cleanup_skeleton () t1_skeleton in
let t2_skeleton = cleanup_skeleton () t2_skeleton in
let data_t2 = t1_skeleton in
debug(lazy ("INDEXING: " ^
- NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] src ^ " |==> " ^
- NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[]
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] src ^ " |==> " ^
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[]
(let _,x,_,_ = data_hint in x)));
- hdb#set_uhint_db (
- HDB.index (fst (hdb#uhint_db)) src data_hint,
+ status#set_uhint_db (
+ HDB.index (fst (status#uhint_db)) src data_hint,
EQDB.index
- (EQDB.index (snd (hdb#uhint_db)) t2_skeleton (precedence, data_t2))
+ (EQDB.index (snd (status#uhint_db)) t2_skeleton (precedence, data_t2))
t1_skeleton (precedence, data_t1))
;;
-let add_user_provided_hint db t precedence =
+let add_user_provided_hint status t precedence =
let c, a, b =
let rec aux ctx = function
| NCic.Appl l ->
| b::a::_ ->
if
let ty_a =
- NCicTypeChecker.typeof ~metasenv:[] ~subst:[] ctx a
+ NCicTypeChecker.typeof status ~metasenv:[] ~subst:[] ctx a
in
let ty_b =
- NCicTypeChecker.typeof ~metasenv:[] ~subst:[] ctx b
+ NCicTypeChecker.typeof status ~metasenv:[] ~subst:[] ctx b
in
- NCicReduction.are_convertible
+ NCicReduction.are_convertible status
~metasenv:[] ~subst:[] ctx ty_a ty_b
&&
- NCicReduction.are_convertible
+ NCicReduction.are_convertible status
~metasenv:[] ~subst:[] ctx a b
then ctx, a, b
else raise HintNotValid
in
aux [] t
in
- index_hint db c a b precedence
+ index_hint status c a b precedence
;;
(*
;;
*)
-let saturate ?(delta=0) metasenv subst context ty goal_arity =
+let saturate status ?(delta=0) metasenv subst context ty goal_arity =
assert (goal_arity >= 0);
let rec aux metasenv = function
| NCic.Prod (name,s,t) as ty ->
~with_type:s `IsTerm
in
let t, metasenv1, args, pno =
- aux metasenv1 (NCicSubstitution.subst arg t)
+ aux metasenv1 (NCicSubstitution.subst status arg t)
in
if pno + 1 = goal_arity then
ty, metasenv, [], goal_arity+1
else
t, metasenv1, arg::args, pno+1
| ty ->
- match NCicReduction.whd ~subst context ty ~delta with
+ match NCicReduction.whd status ~subst context ty ~delta with
| NCic.Prod _ as ty -> aux metasenv ty
| _ -> ty, metasenv, [], 0 (* differs from the other impl in this line*)
in
res, newmetasenv, arguments
;;
-let eq_class_of hdb t1 =
+let eq_class_of (status:#status) t1 =
let eq_class =
if NDiscriminationTree.NCicIndexable.path_string_of t1 =
[Discrimination_tree.Variable]
[] (* if the trie is unable to handle the key, we skip the query since
it sould retulr the whole content of the trie *)
else
- let candidates = EQDB.retrieve_unifiables (snd hdb#uhint_db) t1 in
+ let candidates = EQDB.retrieve_unifiables (snd status#uhint_db) t1 in
let candidates = EqSet.elements candidates in
let candidates = List.sort (fun (x,_) (y,_) -> compare x y) candidates in
List.map snd candidates
in
- debug(lazy("eq_class of: " ^ NCicPp.ppterm ~metasenv:[] ~context:[] ~subst:[]
+ debug(lazy("eq_class of: " ^ status#ppterm ~metasenv:[] ~context:[] ~subst:[]
t1 ^ " is\n" ^ String.concat "\n"
- (List.map (NCicPp.ppterm ~subst:[] ~metasenv:[] ~context:[]) eq_class)));
+ (List.map (status#ppterm ~metasenv:[] ~context:[] ~subst:[]) eq_class)));
eq_class
;;
-let look_for_hint hdb metasenv subst context t1 t2 =
+let look_for_hint (status:#status) metasenv subst context t1 t2 =
if NDiscriminationTree.NCicIndexable.path_string_of t1 =
[Discrimination_tree.Variable] ||
NDiscriminationTree.NCicIndexable.path_string_of t2 =
[Discrimination_tree.Variable] then [] else begin
- debug(lazy ("KEY1: "^NCicPp.ppterm ~metasenv ~subst ~context t1));
- debug(lazy ("KEY2: "^NCicPp.ppterm ~metasenv ~subst ~context t2));
+ debug(lazy ("KEY1: "^status#ppterm ~metasenv ~subst ~context t1));
+ debug(lazy ("KEY2: "^status#ppterm ~metasenv ~subst ~context t2));
(*
- HDB.iter hdb
+ HDB.iter status
(fun p ds ->
prerr_endline ("ENTRY: " ^
NDiscriminationTree.NCicIndexable.string_of_path p ^ " |--> " ^
- String.concat "|" (List.map (NCicPp.ppterm ~metasenv:[] ~subst:[]
+ String.concat "|" (List.map (status#ppterm ~metasenv:[] ~subst:[]
~context:[]) (HintSet.elements ds))));
*)
- let candidates1 = HDB.retrieve_unifiables (fst hdb#uhint_db) (pair t1 t2) in
- let candidates2 = HDB.retrieve_unifiables (fst hdb#uhint_db) (pair t2 t1) in
+ let candidates1 = HDB.retrieve_unifiables (fst status#uhint_db) (pair t1 t2) in
+ let candidates2 = HDB.retrieve_unifiables (fst status#uhint_db) (pair t2 t1) in
let candidates1 =
List.map (fun (prec,_,_,ty) ->
- prec,true,saturate ~delta:max_int metasenv subst context ty 0)
+ prec,true,saturate status ~delta:max_int metasenv subst context ty 0)
(HintSet.elements candidates1)
in
let candidates2 =
List.map (fun (prec,_,_,ty) ->
- prec,false,saturate ~delta:max_int metasenv subst context ty 0)
+ prec,false,saturate status ~delta:max_int metasenv subst context ty 0)
(HintSet.elements candidates2)
in
let rc =
NCicMetaSubst.mk_meta ~attrs:[`Name name] m context
~with_type:ty `IsTerm
in
- let t = NCicSubstitution.subst i t in
+ let t = NCicSubstitution.subst status i t in
aux () (m, (i,bo)::l) t
- | t -> NCicUntrusted.map_term_fold_a (fun _ () -> ()) () aux acc t
+ | t -> NCicUntrusted.map_term_fold_a status (fun _ () -> ()) () aux acc t
in
let (m,l), t = aux () (m,[]) t in
p,b,(t,m,l))
(fun (metasenv, (t1, t2), premises) ->
("\t" ^ String.concat "; "
(List.map (fun (a,b) ->
- NCicPp.ppterm ~margin:max_int ~metasenv ~subst ~context a ^
+ status#ppterm ~margin:max_int ~metasenv ~subst ~context a ^
" =?= "^
- NCicPp.ppterm ~margin:max_int ~metasenv ~subst ~context b)
+ status#ppterm ~margin:max_int ~metasenv ~subst ~context b)
premises) ^
" ==> "^
- NCicPp.ppterm ~margin:max_int ~metasenv ~subst ~context t1 ^
- " = "^NCicPp.ppterm ~margin:max_int ~metasenv ~subst ~context t2))
+ status#ppterm ~margin:max_int ~metasenv ~subst ~context t1 ^
+ " = "^status#ppterm ~margin:max_int ~metasenv ~subst ~context t2))
rc)));
rc
(* pp_ctx context recproblems *)
F.fprintf "@]"
F.fprintf "\vdash@;";
- NCicPp.ppterm ~fmt ~context:(recproblems@context) ~subst:[] ~metasenv:[];
+ status#ppterm ~fmt ~context:(recproblems@context) ~subst:[] ~metasenv:[];
F.fprintf "@]"
F.fprintf formatter "@?";
prerr_endline (Buffer.contents buff);
()
;;
-let generate_dot_file status fmt =
+let generate_dot_file (status:#status) fmt =
let module Pp = GraphvizPp.Dot in
let h_db, _ = status#uhint_db in
let names = ref [] in
(fun (precedence, l,r, hint) ->
let l =
Str.global_substitute (Str.regexp "\n") (fun _ -> "")
- (NCicPp.ppterm
+ (status#ppterm
~margin:max_int ~metasenv:[] ~context:[] ~subst:[] l)
in
let r =
Str.global_substitute (Str.regexp "\n") (fun _ -> "")
- (NCicPp.ppterm
+ (status#ppterm
~margin:max_int ~metasenv:[] ~context:[] ~subst:[] r)
in
let shint = "???" (*
string_of_int precedence ^ "..." ^
Str.global_substitute (Str.regexp "\n") (fun _ -> "")
- (NCicPp.ppterm
+ (status#ppterm
~margin:max_int ~metasenv:[] ~context:[] ~subst:[] hint)*)
in
nodes := (mangle l,l) :: (mangle r,r) :: !nodes;
method uhint_db: db
end
-class status :
+class virtual status :
object ('self)
inherit g_status
+ inherit NCic.status
method set_uhint_db: db -> 'self
method set_unifhint_status: #g_status -> 'self
end
let (===) x y = Pervasives.compare x y = 0 ;;
-let mk_msg metasenv subst context t1 t2 =
+let mk_msg (status:#NCic.status) metasenv subst context t1 t2 =
(lazy (
- "Can't unify " ^ NCicPp.ppterm ~metasenv ~subst ~context t1 ^
- " with " ^ NCicPp.ppterm ~metasenv ~subst ~context t2))
+ "Can't unify " ^ status#ppterm ~metasenv ~subst ~context t1 ^
+ " with " ^ status#ppterm ~metasenv ~subst ~context t2))
-let mk_appl ~upto hd tl =
- NCicReduction.head_beta_reduce ~upto
+let mk_appl status ~upto hd tl =
+ NCicReduction.head_beta_reduce status ~upto
(match hd with
| NCic.Appl l -> NCic.Appl (l@tl)
| _ -> NCic.Appl (hd :: tl))
exception WrongShape;;
-let eta_reduce subst t =
+let eta_reduce status subst t =
let delift_if_not_occur body =
try
- Some (NCicSubstitution.psubst ~avoid_beta_redexes:true
+ Some (NCicSubstitution.psubst status ~avoid_beta_redexes:true
(fun () -> raise WrongShape) [()] body)
with WrongShape -> None
in
| NCic.Meta (i,lc) as t->
(try
let _,_,t,_ = NCicUtils.lookup_subst i subst in
- let t = NCicSubstitution.subst_meta lc t in
+ let t = NCicSubstitution.subst_meta status lc t in
eat_lambdas ctx t
with NCicUtils.Subst_not_found _ -> ctx, t)
| t -> ctx, t
end
;;
-let ppcontext ~metasenv ~subst c =
- "\nctx:\n"^ NCicPp.ppcontext ~metasenv ~subst c
+let ppcontext status ~metasenv ~subst c =
+ "\nctx:\n"^ status#ppcontext ~metasenv ~subst c
;;
-let ppmetasenv ~subst m = "\nmenv:\n" ^ NCicPp.ppmetasenv ~subst m;;
+let ppmetasenv status ~subst m = "\nmenv:\n" ^ status#ppmetasenv ~subst m;;
-let ppcontext ~metasenv:_metasenv ~subst:_subst _context = "";;
-let ppmetasenv ~subst:_subst _metasenv = "";;
-let ppterm ~metasenv ~subst ~context = NCicPp.ppterm ~metasenv ~subst ~context;;
-(* let ppterm ~metasenv:_ ~subst:_ ~context:_ _ = "";; *)
+let ppcontext _status ~metasenv:_metasenv ~subst:_subst _context = "";;
+let ppmetasenv _status ~subst:_subst _metasenv = "";;
+let ppterm (status:#NCic.status) ~metasenv ~subst ~context = status#ppterm ~metasenv ~subst ~context;;
+(* let ppterm status ~metasenv:_ ~subst:_ ~context:_ _ = "";; *)
let is_locked n subst =
try
| C.Appl [] | C.LetIn _ | C.Implicit _ -> assert false
;;
-let rec lambda_intros rdb metasenv subst context argsno ty =
- pp (lazy ("LAMBDA INTROS: " ^ ppterm ~metasenv ~subst ~context ty));
+let rec lambda_intros status metasenv subst context argsno ty =
+ pp (lazy ("LAMBDA INTROS: " ^ ppterm status ~metasenv ~subst ~context ty));
match argsno with
0 ->
let metasenv, _, bo, _ =
in
metasenv, bo
| _ ->
- (match NCicReduction.whd ~subst context ty with
+ (match NCicReduction.whd status ~subst context ty with
C.Prod (n,so,ta) ->
let metasenv,bo =
- lambda_intros rdb metasenv subst
+ lambda_intros status metasenv subst
((n,C.Decl so)::context) (argsno - 1) ta
in
metasenv,C.Lambda (n,so,bo)
let unopt exc = function None -> raise exc | Some x -> x ;;
-let fix metasenv subst is_sup test_eq_only exc t =
+let fix (status:#NCic.status) metasenv subst is_sup test_eq_only exc t =
(*D*) inside 'f'; try let rc =
- pp (lazy (NCicPp.ppterm ~metasenv ~subst ~context:[] t));
+ pp (lazy (status#ppterm ~metasenv ~subst ~context:[] t));
let rec aux test_eq_only metasenv = function
| NCic.Prod (n,so,ta) ->
let metasenv,so = aux true metasenv so in
let metasenv, _ = NCicMetaSubst.extend_meta metasenv n in
metasenv, orig)
| t ->
- NCicUntrusted.map_term_fold_a (fun _ x -> x) test_eq_only aux metasenv t
+ NCicUntrusted.map_term_fold_a status (fun _ x -> x) test_eq_only aux metasenv t
in
aux test_eq_only metasenv t
(*D*) in outside None; rc with exn -> outside (Some exn); raise exn
metasenv,subst
;;
-let rec sortfy exc metasenv subst context t =
- let t = NCicReduction.whd ~subst context t in
+let rec sortfy status exc metasenv subst context t =
+ let t = NCicReduction.whd status ~subst context t in
let metasenv,subst =
match t with
| NCic.Sort _ -> metasenv, subst
| NCic.Implicit (`Typeof _) ->
metasenv_to_subst n (`IsSort,[],ty) metasenv subst
| ty ->
- let metasenv,subst,ty = sortfy exc metasenv subst context ty in
+ let metasenv,subst,ty = sortfy status exc metasenv subst context ty in
metasenv_to_subst n (`IsSort,[],ty) metasenv subst)
| NCic.Implicit _ -> assert false
| _ -> raise exc
in
metasenv,subst,t
-let tipify exc metasenv subst context t ty =
+let tipify status exc metasenv subst context t ty =
let is_type attrs =
match NCicUntrusted.kind_of_meta attrs with
`IsType | `IsSort -> true
metasenv,subst,true
else
let _,cc,ty = NCicUtils.lookup_meta n metasenv in
- let metasenv,subst,ty = sortfy exc metasenv subst cc ty in
+ let metasenv,subst,ty = sortfy status exc metasenv subst cc ty in
let metasenv =
NCicUntrusted.replace_in_metasenv n
(fun attrs,cc,_ -> NCicUntrusted.set_kind `IsType attrs, cc, ty)
metasenv,subst,true
else
let _,cc,_,ty = NCicUtils.lookup_subst n subst in
- let metasenv,subst,ty = sortfy exc metasenv subst cc ty in
+ let metasenv,subst,ty = sortfy status exc metasenv subst cc ty in
let subst =
NCicUntrusted.replace_in_subst n
(fun attrs,cc,bo,_->NCicUntrusted.set_kind `IsType attrs,cc,bo,ty)
subst
in
- optimize_meta metasenv subst (NCicSubstitution.subst_meta lc bo))
+ optimize_meta metasenv subst (NCicSubstitution.subst_meta status lc bo))
| _ -> metasenv,subst,false
in
let metasenv,subst,b = optimize_meta metasenv subst t in
if b then
metasenv,subst,t
else
- let metasenv,subst,_ = sortfy exc metasenv subst context ty in
+ let metasenv,subst,_ = sortfy status exc metasenv subst context ty in
metasenv,subst,t
;;
-let rec instantiate rdb test_eq_only metasenv subst context n lc t swap =
+let rec instantiate status test_eq_only metasenv subst context n lc t swap =
(*D*) inside 'I'; try let rc =
- pp (lazy(string_of_int n^" :=?= "^ppterm ~metasenv ~subst ~context t));
+ pp (lazy(string_of_int n^" :=?= "^ppterm status ~metasenv ~subst ~context t));
let exc =
- UnificationFailure (mk_msg metasenv subst context (NCic.Meta (n,lc)) t) in
+ UnificationFailure (mk_msg status metasenv subst context (NCic.Meta (n,lc)) t) in
let move_to_subst i ((_,cc,t,_) as infos) metasenv subst =
let metasenv = List.remove_assoc i metasenv in
- pp(lazy(string_of_int n ^ " :==> "^ ppterm ~metasenv ~subst ~context:cc t));
+ pp(lazy(string_of_int n ^ " :==> "^ ppterm status ~metasenv ~subst ~context:cc t));
metasenv, (i,infos) :: subst
in
let delift_to_subst test_eq_only n lc (attrs,cc,ty) t context metasenv subst =
pp (lazy(string_of_int n ^ " := 111 = "^
- ppterm ~metasenv ~subst ~context t));
+ ppterm status ~metasenv ~subst ~context t));
let (metasenv, subst), t =
try
- NCicMetaSubst.delift
+ NCicMetaSubst.delift status
~unify:(fun m s c t1 t2 ->
let ind = !indent in
let res =
- try Some (unify rdb test_eq_only m s c t1 t2 false)
+ try Some (unify status test_eq_only m s c t1 t2 false)
with UnificationFailure _ | Uncertain _ -> None
in
indent := ind; res)
raise (UnificationFailure msg)
in
pp (lazy(string_of_int n ^ " := 222 = "^
- ppterm ~metasenv ~subst ~context:cc t^ppmetasenv ~subst metasenv));
+ ppterm status ~metasenv ~subst ~context:cc t^ppmetasenv status ~subst metasenv));
(* Unifying the types may have already instantiated n. *)
try
let _, _,oldt,_ = NCicUtils.lookup_subst n subst in
- let oldt = NCicSubstitution.subst_meta lc oldt in
- let t = NCicSubstitution.subst_meta lc t in
+ let oldt = NCicSubstitution.subst_meta status lc oldt in
+ let t = NCicSubstitution.subst_meta status lc t in
(* conjecture: always fail --> occur check *)
- unify rdb test_eq_only metasenv subst context t oldt false
+ unify status test_eq_only metasenv subst context t oldt false
with NCicUtils.Subst_not_found _ ->
move_to_subst n (attrs,cc,t,ty) metasenv subst
in
let attrs,cc,ty = NCicUtils.lookup_meta n metasenv in
let kind = NCicUntrusted.kind_of_meta attrs in
- let metasenv,t = fix metasenv subst swap test_eq_only exc t in
- let ty_t = NCicTypeChecker.typeof ~metasenv ~subst context t in
+ let metasenv,t = fix status metasenv subst swap test_eq_only exc t in
+ let ty_t = NCicTypeChecker.typeof status ~metasenv ~subst context t in
let metasenv,subst,t =
match kind with
- `IsSort -> sortfy exc metasenv subst context t
- | `IsType -> tipify exc metasenv subst context t ty_t
+ `IsSort -> sortfy status exc metasenv subst context t
+ | `IsType -> tipify status exc metasenv subst context t ty_t
| `IsTerm -> metasenv,subst,t in
match kind with
| `IsSort ->
| _, NCic.Meta _
| NCic.Meta _, NCic.Sort _ ->
pp (lazy ("On the types: " ^
- ppterm ~metasenv ~subst ~context ty ^ "=<=" ^
- ppterm ~metasenv ~subst ~context ty_t));
+ ppterm status ~metasenv ~subst ~context ty ^ "=<=" ^
+ ppterm status ~metasenv ~subst ~context ty_t));
let metasenv, subst =
- unify rdb false metasenv subst context ty_t ty false in
+ unify status false metasenv subst context ty_t ty false in
delift_to_subst test_eq_only n lc (attrs,cc,ty) t
context metasenv subst
| _ -> assert false)
NCic.Implicit (`Typeof _) ->
let (metasenv, subst), ty_t =
try
- NCicMetaSubst.delift
+ NCicMetaSubst.delift status
~unify:(fun m s c t1 t2 ->
let ind = !indent in
- let res = try Some (unify rdb test_eq_only m s c t1 t2 false )
+ let res = try Some (unify status test_eq_only m s c t1 t2 false )
with UnificationFailure _ | Uncertain _ -> None
in
indent := ind; res)
delift_to_subst test_eq_only n lc (attrs,cc,ty_t) t context metasenv
subst
| _ ->
- let lty = NCicSubstitution.subst_meta lc ty in
+ let lty = NCicSubstitution.subst_meta status lc ty in
pp (lazy ("On the types: " ^
- ppterm ~metasenv ~subst ~context ty_t ^ "=<=" ^
- ppterm ~metasenv ~subst ~context lty));
+ ppterm status ~metasenv ~subst ~context ty_t ^ "=<=" ^
+ ppterm status ~metasenv ~subst ~context lty));
let metasenv, subst =
- unify rdb false metasenv subst context ty_t lty false
+ unify status false metasenv subst context ty_t lty false
in
delift_to_subst test_eq_only n lc (attrs,cc,ty) t context metasenv
subst)
(*D*) in outside None; rc with exn -> outside (Some exn); raise exn
-and unify rdb test_eq_only metasenv subst context t1 t2 swap =
+and unify status test_eq_only metasenv subst context t1 t2 swap =
(*D*) inside 'U'; try let rc =
let fo_unif test_eq_only metasenv subst (norm1,t1) (norm2,t2) =
(*D*) inside 'F'; try let rc =
- pp (lazy(" " ^ ppterm ~metasenv ~subst ~context t1 ^
+ pp (lazy(" " ^ ppterm status ~metasenv ~subst ~context t1 ^
(if swap then " ==>?== "
else " ==<?==" ) ^
- ppterm ~metasenv ~subst ~context t2 ^ ppmetasenv
+ ppterm status ~metasenv ~subst ~context t2 ^ ppmetasenv status
~subst metasenv));
- pp (lazy(" " ^ ppterm ~metasenv ~subst:[] ~context t1 ^
+ pp (lazy(" " ^ ppterm status ~metasenv ~subst:[] ~context t1 ^
(if swap then " ==>??== "
else " ==<??==" ) ^
- ppterm ~metasenv ~subst:[] ~context t2 ^ ppmetasenv
+ ppterm status ~metasenv ~subst:[] ~context t2 ^ ppmetasenv status
~subst metasenv));
if t1 === t2 then
metasenv, subst
| (C.Sort (C.Type a), C.Sort (C.Type b)) when not test_eq_only ->
let a, b = if swap then b,a else a,b in
if NCicEnvironment.universe_leq a b then metasenv, subst
- else raise (UnificationFailure (mk_msg metasenv subst context t1 t2))
+ else raise (UnificationFailure (mk_msg status metasenv subst context t1 t2))
| (C.Sort (C.Type a), C.Sort (C.Type b)) ->
if NCicEnvironment.universe_eq a b then metasenv, subst
- else raise (UnificationFailure (mk_msg metasenv subst context t1 t2))
+ else raise (UnificationFailure (mk_msg status metasenv subst context t1 t2))
| (C.Sort C.Prop,C.Sort (C.Type _)) when not swap ->
if (not test_eq_only) then metasenv, subst
- else raise (UnificationFailure (mk_msg metasenv subst context t1 t2))
+ else raise (UnificationFailure (mk_msg status metasenv subst context t1 t2))
| (C.Sort (C.Type _), C.Sort C.Prop) when swap ->
if (not test_eq_only) then metasenv, subst
- else raise (UnificationFailure (mk_msg metasenv subst context t1 t2))
+ else raise (UnificationFailure (mk_msg status metasenv subst context t1 t2))
| (C.Lambda (name1,s1,t1), C.Lambda(_,s2,t2))
| (C.Prod (name1,s1,t1), C.Prod(_,s2,t2)) ->
- let metasenv, subst = unify rdb true metasenv subst context s1 s2 swap in
- unify rdb test_eq_only metasenv subst ((name1, C.Decl s1)::context) t1 t2 swap
+ let metasenv, subst = unify status true metasenv subst context s1 s2 swap in
+ unify status test_eq_only metasenv subst ((name1, C.Decl s1)::context) t1 t2 swap
| (C.LetIn (name1,ty1,s1,t1), C.LetIn(_,ty2,s2,t2)) ->
- let metasenv,subst=unify rdb test_eq_only metasenv subst context ty1 ty2 swap in
- let metasenv,subst=unify rdb test_eq_only metasenv subst context s1 s2 swap in
+ let metasenv,subst=unify status test_eq_only metasenv subst context ty1 ty2 swap in
+ let metasenv,subst=unify status test_eq_only metasenv subst context s1 s2 swap in
let context = (name1, C.Def (s1,ty1))::context in
- unify rdb test_eq_only metasenv subst context t1 t2 swap
+ unify status test_eq_only metasenv subst context t1 t2 swap
| (C.Meta (n1,(s1,l1 as lc1)),C.Meta (n2,(s2,l2 as lc2))) when n1 = n2 ->
(try
(fun t1 t2 (metasenv, subst, to_restrict, i) ->
try
let metasenv, subst =
- unify rdb (*test_eq_only*) true metasenv subst context
- (NCicSubstitution.lift s1 t1) (NCicSubstitution.lift s2 t2)
+ unify status (*test_eq_only*) true metasenv subst context
+ (NCicSubstitution.lift status s1 t1) (NCicSubstitution.lift status s2 t2)
swap
in
metasenv, subst, to_restrict, i-1
in
if to_restrict <> [] then
let metasenv, subst, _, _ =
- NCicMetaSubst.restrict metasenv subst n1 to_restrict
+ NCicMetaSubst.restrict status metasenv subst n1 to_restrict
in
metasenv, subst
else metasenv, subst
| NCicMetaSubst.MetaSubstFailure msg ->
try
let _,_,term,_ = NCicUtils.lookup_subst n1 subst in
- let term1 = NCicSubstitution.subst_meta lc1 term in
- let term2 = NCicSubstitution.subst_meta lc2 term in
- unify rdb test_eq_only metasenv subst context term1 term2 swap
+ let term1 = NCicSubstitution.subst_meta status lc1 term in
+ let term2 = NCicSubstitution.subst_meta status lc2 term in
+ unify status test_eq_only metasenv subst context term1 term2 swap
with NCicUtils.Subst_not_found _-> raise (UnificationFailure msg))
| NCic.Appl (NCic.Meta (i,_)::_ as l1),
(try
List.fold_left2
(fun (metasenv, subst) t1 t2 ->
- unify rdb (*test_eq_only*) true metasenv subst context t1
+ unify status (*test_eq_only*) true metasenv subst context t1
t2 swap)
(metasenv,subst) l1 l2
with Invalid_argument _ ->
- raise (UnificationFailure (mk_msg metasenv subst context t1 t2)))
+ raise (UnificationFailure (mk_msg status metasenv subst context t1 t2)))
| _, NCic.Meta (n, _) when is_locked n subst && not swap->
(let (metasenv, subst), i =
- match NCicReduction.whd ~subst context t1 with
+ match NCicReduction.whd status ~subst context t1 with
| NCic.Appl (NCic.Meta (i,l) as meta :: args) ->
let metasenv, lambda_Mj =
- lambda_intros rdb metasenv subst context (List.length args)
- (NCicTypeChecker.typeof ~metasenv ~subst context meta)
+ lambda_intros status metasenv subst context (List.length args)
+ (NCicTypeChecker.typeof status ~metasenv ~subst context meta)
in
- unify rdb test_eq_only metasenv subst context
+ unify status test_eq_only metasenv subst context
(C.Meta (i,l)) lambda_Mj false,
i
| NCic.Meta (i,_) -> (metasenv, subst), i
raise (UnificationFailure (lazy "Locked term vs non
flexible term; probably not saturated enough yet!"))
in
- let t1 = NCicReduction.whd ~subst context t1 in
+ let t1 = NCicReduction.whd status ~subst context t1 in
let j, lj =
match t1 with NCic.Meta (j,l) -> j, l | _ -> assert false
in
let metasenv, subst =
- instantiate rdb test_eq_only metasenv subst context j lj t2 true
+ instantiate status test_eq_only metasenv subst context j lj t2 true
in
(* We need to remove the out_scope_tags to avoid propagation of
them that triggers again the ad-hoc case *)
in
(try
let name, ctx, term, ty = NCicUtils.lookup_subst i subst in
- let term = eta_reduce subst term in
+ let term = eta_reduce status subst term in
let subst = List.filter (fun (j,_) -> j <> i) subst in
metasenv, ((i, (name, ctx, term, ty)) :: subst)
with Not_found -> assert false))
| NCic.Meta (n, _), _ when is_locked n subst && swap ->
- unify rdb test_eq_only metasenv subst context t2 t1 false
+ unify status test_eq_only metasenv subst context t2 t1 false
| t, C.Meta (n,lc) when List.mem_assoc n subst ->
let _,_,term,_ = NCicUtils.lookup_subst n subst in
- let term = NCicSubstitution.subst_meta lc term in
- unify rdb test_eq_only metasenv subst context t term swap
+ let term = NCicSubstitution.subst_meta status lc term in
+ unify status test_eq_only metasenv subst context t term swap
| C.Meta (n,_), _ when List.mem_assoc n subst ->
- unify rdb test_eq_only metasenv subst context t2 t1 (not swap)
+ unify status test_eq_only metasenv subst context t2 t1 (not swap)
| _, NCic.Appl (NCic.Meta (i,l)::args) when List.mem_assoc i subst ->
let _,_,term,_ = NCicUtils.lookup_subst i subst in
- let term = NCicSubstitution.subst_meta l term in
- unify rdb test_eq_only metasenv subst context t1
- (mk_appl ~upto:(List.length args) term args) swap
+ let term = NCicSubstitution.subst_meta status l term in
+ unify status test_eq_only metasenv subst context t1
+ (mk_appl status ~upto:(List.length args) term args) swap
| NCic.Appl (NCic.Meta (i,_)::_), _ when List.mem_assoc i subst ->
- unify rdb test_eq_only metasenv subst context t2 t1 (not swap)
+ unify status test_eq_only metasenv subst context t2 t1 (not swap)
| C.Meta (n,_), C.Meta (m,lc') when
let _,cc1,_ = NCicUtils.lookup_meta n metasenv in
let len1 = List.length cc1 in
let len2 = List.length cc2 in
len2 < len1 && cc2 = fst (HExtlib.split_nth len2 cc1) ->
- instantiate rdb test_eq_only metasenv subst context m lc'
- (NCicReduction.head_beta_reduce ~subst t1) (not swap)
+ instantiate status test_eq_only metasenv subst context m lc'
+ (NCicReduction.head_beta_reduce status ~subst t1) (not swap)
| C.Meta (n,lc), C.Meta (m,lc') when
let _,_,tyn = NCicUtils.lookup_meta n metasenv in
let _,_,tym = NCicUtils.lookup_meta m metasenv in
- let tyn = NCicSubstitution.subst_meta lc tyn in
- let tym = NCicSubstitution.subst_meta lc tym in
+ let tyn = NCicSubstitution.subst_meta status lc tyn in
+ let tym = NCicSubstitution.subst_meta status lc tym in
match tyn,tym with
NCic.Sort NCic.Type u1, NCic.Sort NCic.Type u2 ->
NCicEnvironment.universe_lt u1 u2
| _,_ -> false ->
- instantiate rdb test_eq_only metasenv subst context m lc'
- (NCicReduction.head_beta_reduce ~subst t1) (not swap)
+ instantiate status test_eq_only metasenv subst context m lc'
+ (NCicReduction.head_beta_reduce status ~subst t1) (not swap)
| C.Meta (n,lc), t ->
- instantiate rdb test_eq_only metasenv subst context n lc
- (NCicReduction.head_beta_reduce ~subst t) swap
+ instantiate status test_eq_only metasenv subst context n lc
+ (NCicReduction.head_beta_reduce status ~subst t) swap
| t, C.Meta (n,lc) ->
- instantiate rdb test_eq_only metasenv subst context n lc
- (NCicReduction.head_beta_reduce ~subst t) (not swap)
+ instantiate status test_eq_only metasenv subst context n lc
+ (NCicReduction.head_beta_reduce status ~subst t) (not swap)
(* higher order unification case *)
| NCic.Appl (NCic.Meta (i,l) as meta :: args), _ ->
match t2 with
| NCic.Appl (f :: f_args)
when
- List.exists (NCicMetaSubst.is_flexible context ~subst) args ->
+ List.exists (NCicMetaSubst.is_flexible status context ~subst) args ->
let mlen = List.length args in
let flen = List.length f_args in
let min_len = min mlen flen in
(try
Some (List.fold_left2
(fun (m, s) t1 t2 ->
- unify rdb test_eq_only m s context t1 t2 swap
+ unify status test_eq_only m s context t1 t2 swap
) (metasenv,subst)
((NCicUntrusted.mk_appl meta mhe)::margs)
((NCicUntrusted.mk_appl f fhe)::fargs))
?_f[..ti..] =?= t2 --instantiate-->
delift [..ti..] t2 *)
let metasenv, lambda_Mj =
- lambda_intros rdb metasenv subst context (List.length args)
- (NCicTypeChecker.typeof ~metasenv ~subst context meta)
+ lambda_intros status metasenv subst context (List.length args)
+ (NCicTypeChecker.typeof status ~metasenv ~subst context meta)
in
let metasenv, subst =
- unify rdb test_eq_only metasenv subst context
+ unify status test_eq_only metasenv subst context
(C.Meta (i,l)) lambda_Mj swap
in
let metasenv, subst =
- unify rdb test_eq_only metasenv subst context t1 t2 swap
+ unify status test_eq_only metasenv subst context t1 t2 swap
in
(try
let name, ctx, term, ty = NCicUtils.lookup_subst i subst in
- let term = eta_reduce subst term in
+ let term = eta_reduce status subst term in
let subst = List.filter (fun (j,_) -> j <> i) subst in
metasenv, ((i, (name, ctx, term, ty)) :: subst)
with Not_found -> assert false))
| _, NCic.Appl (NCic.Meta (_,_) :: _) ->
- unify rdb test_eq_only metasenv subst context t2 t1 (not swap)
+ unify status test_eq_only metasenv subst context t2 t1 (not swap)
(* processing this case here we avoid a useless small delta step *)
| (C.Appl ((C.Const r1) as _hd1::tl1), C.Appl (C.Const r2::tl2))
when Ref.eq r1 r2 ->
- let relevance = NCicEnvironment.get_relevance r1 in
+ let relevance = NCicEnvironment.get_relevance status r1 in
let metasenv, subst, _ =
try
List.fold_left2
let b, relevance =
match relevance with b::tl -> b,tl | _ -> true, [] in
let metasenv, subst =
- try unify rdb test_eq_only metasenv subst context t1 t2
+ try unify status test_eq_only metasenv subst context t1 t2
swap
with UnificationFailure _ | Uncertain _ when not b ->
metasenv, subst
(metasenv, subst, relevance) tl1 tl2
with
Invalid_argument _ ->
- raise (Uncertain (mk_msg metasenv subst context t1 t2))
+ raise (Uncertain (mk_msg status metasenv subst context t1 t2))
| KeepReducing _ | KeepReducingThis _ -> assert false
in
metasenv, subst
| (C.Match (Ref.Ref (_,Ref.Ind (_,tyno,_)) as ref1,outtype1,term1,pl1),
C.Match (ref2,outtype2,term2,pl2)) when Ref.eq ref1 ref2 ->
- let _,_,itl,_,_ = NCicEnvironment.get_checked_indtys ref1 in
+ let _,_,itl,_,_ = NCicEnvironment.get_checked_indtys status ref1 in
let _,_,ty,_ = List.nth itl tyno in
let rec remove_prods ~subst context ty =
- let ty = NCicReduction.whd ~subst context ty in
+ let ty = NCicReduction.whd status ~subst context ty in
match ty with
| C.Sort _ -> ty
| C.Prod (name,so,ta) ->
| _ -> false
in
(* if not (Ref.eq ref1 ref2) then
- raise (Uncertain (mk_msg metasenv subst context t1 t2))
+ raise (Uncertain (mk_msg status metasenv subst context t1 t2))
else*)
let metasenv, subst =
- unify rdb test_eq_only metasenv subst context outtype1 outtype2 swap in
+ unify status test_eq_only metasenv subst context outtype1 outtype2 swap in
let metasenv, subst =
- try unify rdb test_eq_only metasenv subst context term1 term2 swap
+ try unify status test_eq_only metasenv subst context term1 term2 swap
with UnificationFailure _ | Uncertain _ when is_prop ->
metasenv, subst
in
(try
List.fold_left2
(fun (metasenv,subst) t1 t2 ->
- unify rdb test_eq_only metasenv subst context t1 t2 swap)
+ unify status test_eq_only metasenv subst context t1 t2 swap)
(metasenv, subst) pl1 pl2
with Invalid_argument _ -> assert false)
| (C.Implicit _, _) | (_, C.Implicit _) -> assert false
| _ when norm1 && norm2 ->
if (could_reduce t1 || could_reduce t2) then
- raise (Uncertain (mk_msg metasenv subst context t1 t2))
+ raise (Uncertain (mk_msg status metasenv subst context t1 t2))
else
- raise (UnificationFailure (mk_msg metasenv subst context t1 t2))
- | _ -> raise (KeepReducing (mk_msg metasenv subst context t1 t2))
+ raise (UnificationFailure (mk_msg status metasenv subst context t1 t2))
+ | _ -> raise (KeepReducing (mk_msg status metasenv subst context t1 t2))
(*D*) in outside None; rc with exn -> outside (Some exn); raise exn
in
let fo_unif test_eq_only metasenv subst (norm1,t1 as nt1) (norm2,t2 as nt2)=
try fo_unif test_eq_only metasenv subst nt1 nt2
with
UnificationFailure _ | Uncertain _ when not norm1 || not norm2 ->
- raise (KeepReducing (mk_msg metasenv subst context t1 t2))
+ raise (KeepReducing (mk_msg status metasenv subst context t1 t2))
in
let try_hints metasenv subst (_,t1 as mt1) (_,t2 as mt2) (* exc*) =
- if NCicUntrusted.metas_of_term subst context t1 = [] &&
- NCicUntrusted.metas_of_term subst context t2 = []
+ if NCicUntrusted.metas_of_term status subst context t1 = [] &&
+ NCicUntrusted.metas_of_term status subst context t2 = []
then None
else begin
(*D*) inside 'H'; try let rc =
pp(lazy ("\nProblema:\n" ^
- ppterm ~metasenv ~subst ~context t1 ^ " =?= " ^
- ppterm ~metasenv ~subst ~context t2));
+ ppterm status ~metasenv ~subst ~context t1 ^ " =?= " ^
+ ppterm status ~metasenv ~subst ~context t2));
let candidates =
- NCicUnifHint.look_for_hint rdb metasenv subst context t1 t2
+ NCicUnifHint.look_for_hint status metasenv subst context t1 t2
in
let rec cand_iter = function
| [] -> None (* raise exc *)
String.concat "\n"
(List.map
(fun (a,b) ->
- ppterm ~metasenv ~subst ~context a ^ " =?= " ^
- ppterm ~metasenv ~subst ~context b) premises) ^
+ ppterm status ~metasenv ~subst ~context a ^ " =?= " ^
+ ppterm status ~metasenv ~subst ~context b) premises) ^
"\n-------------------------------------------\n"^
- ppterm ~metasenv ~subst ~context c1 ^ " = " ^
- ppterm ~metasenv ~subst ~context c2));
+ ppterm status ~metasenv ~subst ~context c1 ^ " = " ^
+ ppterm status ~metasenv ~subst ~context c2));
try
(*D*) inside 'K'; try let rc =
let metasenv,subst =
let metasenv,subst =
List.fold_left
(fun (metasenv, subst) (x,y) ->
- unify rdb test_eq_only metasenv subst context x y false)
+ unify status test_eq_only metasenv subst context x y false)
(metasenv, subst) (List.rev premises)
in
pp(lazy("FUNZIONA!"));
end
in
let put_in_whd m1 m2 =
- NCicReduction.reduce_machine ~delta:max_int ~subst context m1,
- NCicReduction.reduce_machine ~delta:max_int ~subst context m2
+ NCicReduction.reduce_machine status ~delta:max_int ~subst context m1,
+ NCicReduction.reduce_machine status ~delta:max_int ~subst context m2
in
let fo_unif_w_hints test_eq_only metasenv subst (_,t1 as m1) (_,t2 as m2) =
try fo_unif test_eq_only metasenv subst m1 m2
in
match
try_hints metasenv subst
- (norm1,NCicReduction.unwind t1) (norm2,NCicReduction.unwind t2)
+ (norm1,NCicReduction.unwind status t1) (norm2,NCicReduction.unwind status t2)
with
| Some x -> x
| None ->
let (t1,norm1),(t2,norm2) = hm1, hm2 in
match
try_hints metasenv subst
- (norm1,NCicReduction.unwind t1) (norm2,NCicReduction.unwind t2)
+ (norm1,NCicReduction.unwind status t1) (norm2,NCicReduction.unwind status t2)
with
| Some x -> x, fun x -> x
| None ->
=
assert (not (norm1 && norm2));
if norm1 then
- x1,NCicReduction.reduce_machine ~delta:0 ~subst context m2
+ x1,NCicReduction.reduce_machine status ~delta:0 ~subst context m2
else if norm2 then
- NCicReduction.reduce_machine ~delta:0 ~subst context m1,x2
+ NCicReduction.reduce_machine status ~delta:0 ~subst context m1,x2
else
let h1 = height_of t1 in
let h2 = height_of t2 in
let delta = if h1 = h2 then max 0 (h1 -1) else min h1 h2 in
- NCicReduction.reduce_machine ~delta ~subst context m1,
- NCicReduction.reduce_machine ~delta ~subst context m2
+ NCicReduction.reduce_machine status ~delta ~subst context m1,
+ NCicReduction.reduce_machine status ~delta ~subst context m2
in
let rec unif_machines metasenv subst =
function
| ((k1,e1,t1,s1),norm1 as m1),((k2,e2,t2,s2),norm2 as m2) ->
(*D*) inside 'M'; try let rc =
pp (lazy("UM: " ^
- ppterm ~metasenv ~subst ~context
- (NCicReduction.unwind (k1,e1,t1,s1)) ^
+ ppterm status ~metasenv ~subst ~context
+ (NCicReduction.unwind status (k1,e1,t1,s1)) ^
" === " ^
- ppterm ~metasenv ~subst ~context
- (NCicReduction.unwind (k2,e2,t2,s2))));
+ ppterm status ~metasenv ~subst ~context
+ (NCicReduction.unwind status (k2,e2,t2,s2))));
pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2));
let relevance =
match t1 with
- | C.Const r -> NCicEnvironment.get_relevance r
+ | C.Const r -> NCicEnvironment.get_relevance status r
| _ -> [] in
let unif_from_stack (metasenv, subst) (t1, t2, b) =
try
| x1::tl1, x2::tl2, r::tr-> check_stack tl1 tl2 tr ((x1,x2,r)::todo)
| x1::tl1, x2::tl2, []-> check_stack tl1 tl2 [] ((x1,x2,true)::todo)
| l1, l2, _ ->
- NCicReduction.unwind (k1,e1,t1,List.rev l1),
- NCicReduction.unwind (k2,e2,t2,List.rev l2),
+ NCicReduction.unwind status (k1,e1,t1,List.rev l1),
+ NCicReduction.unwind status (k2,e2,t2,List.rev l2),
todo
in
let check_stack l1 l2 r =
match t1, t2 with
| NCic.Meta _, _ | _, NCic.Meta _ ->
- (NCicReduction.unwind (k1,e1,t1,s1)),
- (NCicReduction.unwind (k2,e2,t2,s2)),[]
+ (NCicReduction.unwind status (k1,e1,t1,s1)),
+ (NCicReduction.unwind status (k2,e2,t2,s2)),[]
| _ -> check_stack l1 l2 r []
in
let hh1,hh2,todo =
| UnificationFailure _ | Uncertain _ when (not (norm1 && norm2))
-> unif_machines metasenv subst (small_delta_step ~subst m1 m2)
| UnificationFailure msg
- when could_reduce (NCicReduction.unwind (fst m1))
- || could_reduce (NCicReduction.unwind (fst m2))
+ when could_reduce (NCicReduction.unwind status (fst m1))
+ || could_reduce (NCicReduction.unwind status (fst m2))
-> raise (Uncertain msg)
(*D*) in outside None; rc with exn -> outside (Some exn); raise exn
in
(*D*) in outside None; rc with KeepReducing _ -> assert false | exn -> outside (Some exn); raise exn
-and delift_type_wrt_terms rdb metasenv subst context t args =
+and delift_type_wrt_terms status metasenv subst context t args =
let lc = List.rev args @ mk_irl (List.length context) (List.length args+1) in
let (metasenv, subst), t =
try
- NCicMetaSubst.delift
+ NCicMetaSubst.delift status
~unify:(fun m s c t1 t2 ->
let ind = !indent in
let res =
- try Some (unify rdb false m s c t1 t2 false)
+ try Some (unify status false m s c t1 t2 false)
with UnificationFailure _ | Uncertain _ -> None
in
indent := ind; res)
;;
-let unify rdb ?(test_eq_only=false) ?(swap=false) metasenv subst context t1 t2=
+let unify status ?(test_eq_only=false) ?(swap=false) metasenv subst context t1 t2=
indent := "";
- unify rdb test_eq_only metasenv subst context t1 t2 swap;;
+ unify status test_eq_only metasenv subst context t1 t2 swap;;
-let fix_sorts m s =
- fix m s true false (UnificationFailure (lazy "no sup"))
+let fix_sorts status m s =
+ fix status m s true false (UnificationFailure (lazy "no sup"))
;;
(* this should be moved elsewhere *)
val fix_sorts:
- NCic.metasenv -> NCic.substitution ->
+ #NCic.status -> NCic.metasenv -> NCic.substitution ->
NCic.term -> NCic.metasenv * NCic.term
(* delift_type_wrt_terms st m s c t args
NCic.term -> NCic.term list ->
NCic.metasenv * NCic.substitution * NCic.term
-val sortfy :
- exn ->
- NCic.metasenv ->
- NCic.substitution ->
- NCic.context ->
- NCic.term -> NCic.metasenv * NCic.substitution * NCic.term
+val sortfy :#
+ NCic.status -> exn -> NCic.metasenv -> NCic.substitution -> NCic.context ->
+ NCic.term -> NCic.metasenv * NCic.substitution * NCic.term
val debug : bool ref
(*CSC: cut&paste from nCicReduction.split_prods, but does not check that
the return type is a sort *)
-let rec my_split_prods ~subst context n te =
- match (n, NCicReduction.whd ~subst context te) with
+let rec my_split_prods status ~subst context n te =
+ match (n, NCicReduction.whd status ~subst context te) with
| (0, _) -> context,te
| (n, NCic.Prod (name,so,ta)) ->
- my_split_prods ~subst ((name,(NCic.Decl so))::context) (n - 1) ta
+ my_split_prods status ~subst ((name,(NCic.Decl so))::context) (n - 1) ta
| (n, _) when n <= 0 -> context,te
| (_, _) -> raise (Failure "my_split_prods")
;;
| l -> NotationPt.Appl l
;;
-let mk_elim uri leftno it (outsort,suffix) pragma =
+let mk_elim status uri leftno it (outsort,suffix) pragma =
let _,ind_name,ty,cl = it in
let srec_name = ind_name ^ "_" ^ suffix in
let rec_name = mk_id srec_name in
let name_of_k id = mk_id ("H_" ^ id) in
let p_name = mk_id "Q_" in
- let params,ty = NCicReduction.split_prods ~subst:[] [] leftno ty in
+ let params,ty = NCicReduction.split_prods status ~subst:[] [] leftno ty in
let params = List.rev_map (function name,_ -> mk_id name) params in
- let args,sort = NCicReduction.split_prods ~subst:[] [] (-1) ty in
+ let args,sort = NCicReduction.split_prods status ~subst:[] [] (-1) ty in
let args = List.rev_map (function name,_ -> mk_id name) args in
let rec_arg = mk_id (fresh_name ()) in
let p_ty =
let branches =
List.map
(function (_,name,ty) ->
- let _,ty = NCicReduction.split_prods ~subst:[] [] leftno ty in
- let cargs,ty= my_split_prods ~subst:[] [] (-1) ty in
+ let _,ty = NCicReduction.split_prods status ~subst:[] [] leftno ty in
+ let cargs,ty= my_split_prods status ~subst:[] [] (-1) ty in
let cargs_and_recursive_args =
List.rev_map
(function
_,NCic.Def _ -> assert false
| name,NCic.Decl ty ->
- let context,ty = my_split_prods ~subst:[] [] (-1) ty in
+ let context,ty = my_split_prods status ~subst:[] [] (-1) ty in
match ty with
| NCic.Const nref
| NCic.Appl (NCic.Const nref::_)
| _ -> assert false
;;
-let mk_elims (uri,_,_,_,obj) =
+let mk_elims status (uri,_,_,_,obj) =
match obj with
NCic.Inductive (true,leftno,[itl],_) ->
- List.map (fun s -> mk_elim uri leftno itl (ast_of_sort s) (`Elim s))
+ List.map (fun s-> mk_elim status uri leftno itl (ast_of_sort s) (`Elim s))
(NCic.Prop::
List.map (fun s -> NCic.Type s) (NCicEnvironment.get_universes ()))
| _ -> []
(* this code should be unified with NTermCicContent.nast_of_cic0,
but the two contexts have different types *)
-let rec pp rels =
- function
+let pp (status: #NCic.status) =
+ let rec pp rels =
+ function
NCic.Rel i -> List.nth rels (i - 1)
| NCic.Const _ as t ->
NotationPt.Ident
- (NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t,None)
+ (status#ppterm ~metasenv:[] ~subst:[] ~context:[] t,None)
| NCic.Sort s -> NotationPt.Sort (fst (ast_of_sort s))
| NCic.Meta _
| NCic.Implicit _ -> assert false
let name = NUri.name_of_uri uri in
let case_indty = Some (name, None) in
let constructors, leftno =
- let _,leftno,tys,_,n = NCicEnvironment.get_checked_indtys r in
+ let _,leftno,tys,_,n = NCicEnvironment.get_checked_indtys status r in
let _,_,_,cl = List.nth tys n in
cl,leftno
in
with Invalid_argument _ -> assert false
in
NotationPt.Case (pp rels te, case_indty, Some (pp rels outty), patterns)
+ in
+ pp
;;
-let mk_projection leftno tyname consname consty (projname,_,_) i =
+let mk_projection status leftno tyname consname consty (projname,_,_) i =
let argsno = count_prods consty - leftno in
let rec aux names ty leftno =
match leftno,ty with
List.map
(fun name -> mk_appl (mk_id name :: List.rev names @ [arg])) projs
@ names in
- let outtype = pp rels outtype in
+ let outtype = pp status rels outtype in
let outtype= NotationPt.Binder (`Lambda, (arg, Some arg_ty), outtype) in
[arg, Some arg_ty], NotationPt.Case (arg,None,Some outtype,[branch])
| _,NCic.Prod (name,_,t) ->
(`Definition,projname,NotationPt.Implicit `JustOne,Some res,`Projection)
;;
-let mk_projections (_,_,_,_,obj) =
+let mk_projections status (_,_,_,_,obj) =
match obj with
NCic.Inductive
(true,leftno,[_,tyname,_,[_,consname,consty]],(_,`Record fields))
->
- HExtlib.list_mapi (mk_projection leftno tyname consname consty) fields
+ HExtlib.list_mapi (mk_projection status leftno tyname consname consty) fields
| _ -> []
;;
(* $Id: nCic.ml 9058 2008-10-13 17:42:30Z tassi $ *)
-val mk_elims: NCic.obj -> NotationPt.term NotationPt.obj list
-val mk_projections: NCic.obj -> NotationPt.term NotationPt.obj list
+val mk_elims: #NCic.status -> NCic.obj -> NotationPt.term NotationPt.obj list
+val mk_projections:
+ #NCic.status -> NCic.obj -> NotationPt.term NotationPt.obj list
val ast_of_sort :
NCic.sort -> [> `NCProp of string | `NType of string | `Prop ] * string
(* $Id: nCic.ml 9058 2008-10-13 17:42:30Z tassi $ *)
-let rec normalize ?(delta=0) ~subst ctx t =
- normalize_machine ~delta ~subst ctx
- (fst (NCicReduction.reduce_machine ~delta ~subst ctx (0,[],t,[])))
-and normalize_machine ?(delta=0) ~subst ctx (k,e,t,s) =
+let rec normalize status ?(delta=0) ~subst ctx t =
+ normalize_machine status ~delta ~subst ctx
+ (fst (NCicReduction.reduce_machine status ~delta ~subst ctx (0,[],t,[])))
+and normalize_machine status ?(delta=0) ~subst ctx (k,e,t,s) =
assert (delta=0);
let t =
if k = 0 then t
else
- NCicSubstitution.psubst ~avoid_beta_redexes:true
- (fun e -> normalize_machine ~delta ~subst ctx (NCicReduction.from_env ~delta e)) e t in
+ NCicSubstitution.psubst status ~avoid_beta_redexes:true
+ (fun e -> normalize_machine status ~delta ~subst ctx (NCicReduction.from_env ~delta e)) e t in
let t =
match t with
NCic.Meta (n,(s,lc)) ->
let l = NCicUtils.expand_local_context lc in
- let l' = List.map (normalize ~delta ~subst ctx) l in
+ let l' = List.map (normalize status ~delta ~subst ctx) l in
if l = l' then t
else
NCic.Meta (n,(s,NCic.Ctx l))
- | t -> NCicUtils.map (fun h ctx -> h::ctx) ctx (normalize ~delta ~subst) t
+ | t -> NCicUtils.map status (fun h ctx -> h::ctx) ctx (normalize status ~delta ~subst) t
in
if s = [] then t
else
NCic.Appl
(t::
- (List.map (fun i -> normalize_machine ~delta ~subst ctx (NCicReduction.from_stack ~delta i)) s))
+ (List.map (fun i -> normalize_machine status ~delta ~subst ctx (NCicReduction.from_stack ~delta i)) s))
;;
(* $Id: nCic.ml 9058 2008-10-13 17:42:30Z tassi $ *)
val normalize:
- ?delta:int -> subst:NCic.substitution -> NCic.context -> NCic.term -> NCic.term
+ #NCic.status -> ?delta:int -> subst:NCic.substitution -> NCic.context ->
+ NCic.term -> NCic.term
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)
;;
(* input: nome della variabile riscritta
* output: lista dei nomi delle variabili il cui tipo dipende dall'input *)
-let cascade_select_in_ctx ~subst ctx skip iname =
+let cascade_select_in_ctx status ~subst ctx skip iname =
let lctx, rctx = HExtlib.split_nth (iname - 1) ctx in
let lctx = List.rev lctx in
let rec rm_last = function
(fun (acc,context) item ->
match item with
| n,(NCic.Decl s | NCic.Def (s,_))
- when (not (List.for_all (fun x -> NCicTypeChecker.does_not_occur ~subst context (x-1) x s) acc)
+ when (not (List.for_all (fun x -> NCicTypeChecker.does_not_occur status ~subst context (x-1) x s) acc)
&& not (List.mem n skip)) ->
List.iter (fun m -> pp (lazy ("acc has " ^ (string_of_int m)))) acc;
pp (lazy ("acc occurs in the type of " ^ n));
let indices = rm_last indices in
let res = List.map (fun n -> let s,_ = List.nth ctx (n-1) in s) indices in
List.iter (fun n -> pp (lazy n)) res;
- pp (lazy (NCicPp.ppcontext ~metasenv:[] ~subst ctx));
+ pp (lazy (status#ppcontext ~metasenv:[] ~subst ctx));
res, indices
;;
let principle = NotationPt.Binder (`Lambda, (mk_id "x", Some xyty),
NotationPt.Binder (`Lambda, (mk_id "y", Some xyty), outer))
in
- pp (lazy ("discriminator = " ^ (NotationPp.pp_term principle)));
+ pp (lazy ("discriminator = " ^ (NotationPp.pp_term status principle)));
status, principle
;;
| NCic.Const (NReference.Ref (uri, NReference.Ind (_,indtyno,_)) as r)
| NCic.Appl (NCic.Const
(NReference.Ref (uri, NReference.Ind (_,indtyno,_)) as r)::_) ->
- uri, indtyno, NCicEnvironment.get_checked_indtys r
- | _ -> pp (lazy ("discriminate: indty =" ^ NCicPp.ppterm
+ uri, indtyno, NCicEnvironment.get_checked_indtys status r
+ | _ -> pp (lazy ("discriminate: indty =" ^ status#ppterm
~metasenv:[] ~subst:[] ~context:[] it)) ; assert false in
let _,leftno,its,_,_ = its in
status, leftno, List.nth its indtyno, use_jmeq
NotationPt.Binder (`Forall, (mk_id "e",
Some (mk_appl [mk_id "eq";NotationPt.Implicit `JustOne; mk_id "x"; mk_id "y"])),
mk_appl [discr; mk_id "x"; mk_id "y"(*;mk_id "e"*)])))) in
- let status = print_tac (lazy ("cut_term = "^ NotationPp.pp_term cut_term)) status in
+ let status = print_tac (lazy ("cut_term = "^ NotationPp.pp_term status cut_term)) status in
NTactics.cut_tac ("",0, cut_term)
status);
NTactics.branch_tac;
in match ix with
| None -> acc
| Some (i,_) ->
- fst (cascade_select_in_ctx ~subst:(get_subst status) context [] (i+1)) @ acc) skip skip)
+ fst (cascade_select_in_ctx status ~subst:(get_subst status) context [] (i+1)) @ acc) skip skip)
;;
let subst_tac ~context ~dir skip cur_eq =
let names_to_gen, _ =
match var with
| NCic.Rel var ->
- cascade_select_in_ctx ~subst:(get_subst status) context skip (var+cur_eq)
- | _ -> cascade_select_in_ctx ~subst:(get_subst status) context skip cur_eq in
+ cascade_select_in_ctx status ~subst:(get_subst status) context skip (var+cur_eq)
+ | _ -> cascade_select_in_ctx status ~subst:(get_subst status) context skip cur_eq in
let names_to_gen = List.filter (fun n -> n <> eq_name) names_to_gen in
if (List.exists (fun x -> List.mem x skip) names_to_gen)
then oldstatus
let streicher_id = mk_id "streicherK"
in
let names_to_gen, _ =
- cascade_select_in_ctx ~subst:(get_subst status) context skip cur_eq in
+ cascade_select_in_ctx status ~subst:(get_subst status) context skip cur_eq in
let names_to_gen = names_to_gen @ [eq_name] in
let gen_tac x =
NTactics.generalize_tac
let streicher_id = mk_id "streicherK"
in
let names_to_gen, _ =
- cascade_select_in_ctx ~subst:(get_subst status) context skip cur_eq in
+ cascade_select_in_ctx status ~subst:(get_subst status) context skip cur_eq in
let names_to_gen = names_to_gen (* @ [eq_name]*) in
let gen_tac x =
NTactics.generalize_tac
let select_eq ctx acc domain status goal =
let classify ~subst ctx' l r =
(* FIXME: metasenv *)
- if NCicReduction.are_convertible ~metasenv:[] ~subst ctx' l r
+ if NCicReduction.are_convertible status ~metasenv:[] ~subst ctx' l r
then status, `Identity
else status, (match hd_of_term l, hd_of_term r with
| NCic.Const (NReference.Ref (_,NReference.Con (_,ki,nleft)) as kref),
if ki != kj then `Discriminate (0,true)
else
let rit = NReference.mk_indty true kref in
- let _,_,its,_,itno = NCicEnvironment.get_checked_indtys rit in
+ let _,_,its,_,itno = NCicEnvironment.get_checked_indtys status rit in
let it = List.nth its itno in
let newprods = nargs it nleft (ki-1) in
`Discriminate (newprods, false)
| NCic.Rel j, _
- when NCicTypeChecker.does_not_occur ~subst ctx' (j-1) j r
+ when NCicTypeChecker.does_not_occur status ~subst ctx' (j-1) j r
&& l = NCic.Rel j -> `Subst `LeftToRight
| _, NCic.Rel j
- when NCicTypeChecker.does_not_occur ~subst ctx' (j-1) j l
+ when NCicTypeChecker.does_not_occur status ~subst ctx' (j-1) j l
&& r = NCic.Rel j -> `Subst `RightToLeft
| (NCic.Rel _, _ | _, NCic.Rel _ ) -> `Cycle (* could be a blob too... *)
| _ -> `Blob) in
(let _,ctx_ty = HExtlib.split_nth index ctx in
let status, ty = NTacStatus.whd status ctx_ty (mk_cic_term ctx_ty ty) in
let status, ty = term_of_cic_term status ty ctx_ty in
- pp (lazy (Printf.sprintf "select_eq tries %s" (NCicPp.ppterm ~context:ctx_ty ~subst:[] ~metasenv:[] ty)));
+ pp (lazy (Printf.sprintf "select_eq tries %s" (status#ppterm ~context:ctx_ty ~subst:[] ~metasenv:[] ty)));
let status, kind = match ty with
| NCic.Appl [NCic.Const (NReference.Ref (u,_)) ;_;l;r]
when NUri.name_of_uri u = "eq" ->
classify ~subst:(get_subst status) ctx_ty l r
| NCic.Appl [NCic.Const (NReference.Ref (u,_)) ;lty;l;rty;r]
when NUri.name_of_uri u = "jmeq" &&
- NCicReduction.are_convertible ~metasenv:[]
+ NCicReduction.are_convertible status ~metasenv:[]
~subst:(get_subst status) ctx_ty lty rty
-> classify ~subst:(get_subst status) ctx_ty l r
| _ -> status, `NonEq
pp (lazy ("destruct: acc is " ^ String.concat "," acc ));
match selection, kind with
| None, _ ->
- pp (lazy (Printf.sprintf "destruct: nprods is %d, no selection, context is %s" nprods (NCicPp.ppcontext ~metasenv:[] ~subst ctx)));
+ pp (lazy (Printf.sprintf "destruct: nprods is %d, no selection, context is %s" nprods (status#ppcontext ~metasenv:[] ~subst ctx)));
if nprods > 0 then
let fresh = mk_fresh_name ctx 'e' 0 in
let status' = NTactics.exec (NTactics.intro_tac fresh) status goal in
else
status
| Some cur_eq, `Discriminate (newprods,conflict) ->
- pp (lazy (Printf.sprintf "destruct: discriminate - nprods is %d, selection is %d, context is %s" nprods cur_eq (NCicPp.ppcontext ~metasenv:[] ~subst ctx)));
+ pp (lazy (Printf.sprintf "destruct: discriminate - nprods is %d, selection is %d, context is %s" nprods cur_eq (status#ppcontext ~metasenv:[] ~subst ctx)));
let status' = NTactics.exec (discriminate_tac ~context:ctx cur_eq) status goal in
if conflict then status'
else
skip
status' (get_newgoal status status' goal)
| Some cur_eq, `Subst dir ->
- pp (lazy (Printf.sprintf "destruct: subst - nprods is %d, selection is %d, context is %s" nprods cur_eq (NCicPp.ppcontext ~metasenv:[] ~subst ctx)));
+ pp (lazy (Printf.sprintf "destruct: subst - nprods is %d, selection is %d, context is %s" nprods cur_eq (status#ppcontext ~metasenv:[] ~subst ctx)));
let status' = NTactics.exec (subst_tac ~context:ctx ~dir skip cur_eq) status goal in
- pp (lazy (Printf.sprintf " ctx after subst = %s" (NCicPp.ppcontext ~metasenv:[] ~subst (get_ctx status' (get_newgoal status status' goal)))));
+ pp (lazy (Printf.sprintf " ctx after subst = %s" (status#ppcontext ~metasenv:[] ~subst (get_ctx status' (get_newgoal status status' goal)))));
let eq_name,_ = List.nth ctx (cur_eq-1) in
let newgoal = get_newgoal status status' goal in
let has_cleared =
let domain = rm_eq has_cleared domain in
destruct_tac0 nprods acc domain skip status' newgoal
| Some cur_eq, `Identity ->
- pp (lazy (Printf.sprintf "destruct: identity - nprods is %d, selection is %d, context is %s" nprods cur_eq (NCicPp.ppcontext ~metasenv:[] ~subst ctx)));
+ pp (lazy (Printf.sprintf "destruct: identity - nprods is %d, selection is %d, context is %s" nprods cur_eq (status#ppcontext ~metasenv:[] ~subst ctx)));
let eq_name,_ = List.nth ctx (cur_eq-1) in
let status' = NTactics.exec (clearid_tac ~context:ctx skip cur_eq) status goal in
let newgoal = get_newgoal status status' goal in
let domain = rm_eq has_cleared domain in
destruct_tac0 nprods acc domain skip status' newgoal
| Some cur_eq, `Cycle -> (* TODO, should never happen *)
- pp (lazy (Printf.sprintf "destruct: cycle - nprods is %d, selection is %d, context is %s" nprods cur_eq (NCicPp.ppcontext ~metasenv:[] ~subst ctx)));
+ pp (lazy (Printf.sprintf "destruct: cycle - nprods is %d, selection is %d, context is %s" nprods cur_eq (status#ppcontext ~metasenv:[] ~subst ctx)));
assert false
| Some cur_eq, `Blob ->
- pp (lazy (Printf.sprintf "destruct: blob - nprods is %d, selection is %d, context is %s" nprods cur_eq (NCicPp.ppcontext ~metasenv:[] ~subst ctx)));
+ pp (lazy (Printf.sprintf "destruct: blob - nprods is %d, selection is %d, context is %s" nprods cur_eq (status#ppcontext ~metasenv:[] ~subst ctx)));
assert false
| _ -> assert false
;;
NotationPt.Ident (id,None)
;;
-let rec split_arity ~subst context te =
- match NCicReduction.whd ~subst context te with
+let rec split_arity status ~subst context te =
+ match NCicReduction.whd status ~subst context te with
| NCic.Prod (name,so,ta) ->
- split_arity ~subst ((name, (NCic.Decl so))::context) ta
+ split_arity status ~subst ((name, (NCic.Decl so))::context) ta
| t -> context, t
;;
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 mk_inverter name is_ind it leftno ?selection outsort status baseuri =
+let mk_inverter name is_ind it leftno ?selection outsort (status: #NCic.status) baseuri =
pp (lazy ("leftno = " ^ string_of_int leftno));
let _,ind_name,ty,cl = it in
- pp (lazy ("arity: " ^ NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] ty));
+ pp (lazy ("arity: " ^ status#ppterm ~metasenv:[] ~subst:[] ~context:[] ty));
let ncons = List.length cl in
- (**)let params,ty = NCicReduction.split_prods ~subst:[] [] leftno ty in
+ (**)let params,ty = NCicReduction.split_prods status ~subst:[] [] leftno ty in
let params = List.rev_map (function name,_ -> mk_id name) params in
pp (lazy ("lunghezza params = " ^ string_of_int (List.length params)));(**)
- let args,sort= split_arity ~subst:[] [] ty in
- pp (lazy ("arity sort: " ^ NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:args sort));
+ let args,sort= split_arity status ~subst:[] [] ty in
+ pp (lazy ("arity sort: " ^ status#ppterm ~metasenv:[] ~subst:[] ~context:args sort));
(**)let args = List.rev_map (function name,_ -> mk_id name) args in
pp (lazy ("lunghezza args = " ^ string_of_int (List.length args)));(**)
let nparams = List.length args in
method obj: NCic.obj
end
-class pstatus =
+class virtual pstatus =
fun (o: NCic.obj) ->
object (self)
inherit GrafiteDisambiguate.status
type tactic_term = NotationPt.term Disambiguate.disambiguator_input
type tactic_pattern = GrafiteAst.npattern Disambiguate.disambiguator_input
-let pp_tac_status status =
- prerr_endline (NCicPp.ppobj status#obj);
- prerr_endline ("STACK:\n" ^ Continuationals.Stack.pp status#stack)
-;;
-
type cic_term = NCic.context * NCic.term
let ctx_of (c,_) = c ;;
let mk_cic_term c t = c,t ;;
-let ppterm status t =
+let ppterm (status:#pstatus) t =
let uri,height,metasenv,subst,obj = status#obj in
let context,t = t in
- NCicPp.ppterm ~metasenv ~subst ~context t
+ status#ppterm ~metasenv ~subst ~context t
;;
-let ppcontext status c =
+let ppcontext (status: #pstatus) c =
let uri,height,metasenv,subst,obj = status#obj in
- NCicPp.ppcontext ~metasenv ~subst c
+ status#ppcontext ~metasenv ~subst c
;;
-let ppterm_and_context status t =
+let ppterm_and_context (status: #pstatus) t =
let uri,height,metasenv,subst,obj = status#obj in
let context,t = t in
- NCicPp.ppcontext ~metasenv ~subst context ^ "\n ⊢ "^
- NCicPp.ppterm ~metasenv ~subst ~context t
+ status#ppcontext ~metasenv ~subst context ^ "\n ⊢ "^
+ status#ppterm ~metasenv ~subst ~context t
;;
let relocate status destination (source,t as orig) =
let rec compute_ops ctx = function (* destination, source *)
| (n1, NCic.Decl t1 as e)::cl1 as ex, (n2, NCic.Decl t2)::cl2 ->
if n1 = n2 &&
- NCicReduction.are_convertible ctx ~subst ~metasenv t1 t2 then
+ NCicReduction.are_convertible status ctx ~subst ~metasenv t1 t2 then
compute_ops (e::ctx) (cl1,cl2)
else
[ `Delift ctx; `Lift (List.rev ex) ]
| (n1, NCic.Def (b1,t1) as e)::cl1 as ex, (n2, NCic.Def (b2,t2))::cl2 ->
if n1 = n2 &&
- NCicReduction.are_convertible ctx ~subst ~metasenv t1 t2 &&
- NCicReduction.are_convertible ctx ~subst ~metasenv b1 b2 then
+ NCicReduction.are_convertible status ctx ~subst ~metasenv t1 t2 &&
+ NCicReduction.are_convertible status ctx ~subst ~metasenv b1 b2 then
compute_ops (e::ctx) (cl1,cl2)
else
[ `Delift ctx; `Lift (List.rev ex) ]
| (n1, NCic.Def (b1,t1) as e)::cl1 as ex, (n2, NCic.Decl t2)::cl2 ->
if n1 = n2 &&
- NCicReduction.are_convertible ctx ~subst ~metasenv t1 t2 then
+ NCicReduction.are_convertible status ctx ~subst ~metasenv t1 t2 then
compute_ops (e::ctx) (cl1,cl2)
else
[ `Delift ctx; `Lift (List.rev ex) ]
(fun (status, (source,t)) -> function
| `Lift extra_ctx ->
let len = List.length extra_ctx in
- status, (extra_ctx@source, NCicSubstitution.lift len t)
+ status, (extra_ctx@source, NCicSubstitution.lift status len t)
| `Delift ctx ->
let len_ctx = List.length ctx in
let irl = mk_irl 1 (List.length ctx) in
let lc = List.length source - len_ctx, NCic.Ctx irl in
let u, d, metasenv, subst, o = status#obj in
pp(lazy("delifting as " ^
- NCicPp.ppterm ~metasenv ~subst ~context:source
+ status#ppterm ~metasenv ~subst ~context:source
(NCic.Meta (0,lc))));
let (metasenv, subst), t =
- NCicMetaSubst.delift
+ NCicMetaSubst.delift status
~unify:(fun m s c t1 t2 ->
try Some (NCicUnification.unify status m s c t1 t2)
with
let typeof status ctx t =
let status, (_,t) = relocate status ctx t in
let _,_,metasenv,subst,_ = status#obj in
- let ty = NCicTypeChecker.typeof ~subst ~metasenv ctx t in
+ let ty = NCicTypeChecker.typeof status ~subst ~metasenv ctx t in
status, (ctx, ty)
;;
let typeof a b c = wrap "typeof" (typeof a b) c;;
let saturate status ?delta (ctx,t) =
let n,h,metasenv,subst,k = status#obj in
- let t,metasenv,args = NCicMetaSubst.saturate ?delta metasenv subst ctx t 0 in
+ let t,metasenv,args = NCicMetaSubst.saturate status ?delta metasenv subst ctx t 0 in
let status = status#set_obj (n,h,metasenv,subst,k) in
status, (ctx,t), List.map (fun x -> ctx,x) args
;;
let whd status ?delta ctx t =
let status, (_,t) = relocate status ctx t in
let _,_,_,subst,_ = status#obj in
- let t = NCicReduction.whd ~subst ?delta ctx t in
+ let t = NCicReduction.whd status ~subst ?delta ctx t in
status, (ctx, t)
;;
let normalize status ?delta ctx t =
let status, (_,t) = relocate status ctx t in
let _,_,_,subst,_ = status#obj in
- let t = NCicTacReduction.normalize ~subst ?delta ctx t in
+ let t = NCicTacReduction.normalize status ~subst ?delta ctx t in
status, (ctx, t)
;;
let f () =
let name,height,metasenv,subst,obj = status#obj in
let metasenv, t =
- NCicUnification.fix_sorts metasenv subst t in
+ NCicUnification.fix_sorts status metasenv subst t in
let status = status#set_obj (name,height,metasenv,subst,obj) in
status, (ctx,t)
in
aux ctx (status,already_found) t
| NCic.Meta _ -> (status,already_found),t
| _ ->
- NCicUntrusted.map_term_fold_a (fun e c -> e::c) ctx aux
+ NCicUntrusted.map_term_fold_a status (fun e c -> e::c) ctx aux
(status,already_found) t
in
aux ctx (status,false) t
| _, NCic.Meta (i,lc) when List.mem_assoc i subst ->
let cic =
let _,_,t,_ = NCicUtils.lookup_subst i subst in
- NCicSubstitution.subst_meta lc t
+ NCicSubstitution.subst_meta status lc t
in
select status ctx pat cic
| NCic.LetIn (_,t1,s1,b1), NCic.LetIn (n,t2,s2,b2) ->
status,t)
| NCic.Implicit _, t -> status, t
| _,t ->
- fail (lazy ("malformed pattern: " ^ NCicPp.ppterm ~metasenv:[]
+ fail (lazy ("malformed pattern: " ^ status#ppterm ~metasenv:[]
~context:[] ~subst:[] pat ^ " against " ^
- NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t))
+ status#ppterm ~metasenv:[] ~subst:[] ~context:[] t))
in
pp(lazy ("select in: "^ppterm low_status (context,term)));
let status, term = select low_status context path term in
| _,NCic.Appl (NCic.Const (NRef.Ref (_,(NRef.Ind _)) as ref) :: args) ->
ref, args
| _,_ -> fail (lazy ("not an inductive type: " ^ ppterm status ty)) in
- let _,lno,tl,_,i = NCicEnvironment.get_checked_indtys ref in
+ let _,lno,tl,_,i = NCicEnvironment.get_checked_indtys status ref in
let _,_,_,cl = List.nth tl i in
let consno = List.length cl in
let left, right = HExtlib.split_nth lno args in
let apply_subst status ctx t =
let status, (_,t) = relocate status ctx t in
let _,_,_,subst,_ = status#obj in
- status, (ctx, NCicUntrusted.apply_subst subst ctx t)
+ status, (ctx, NCicUntrusted.apply_subst status subst ctx t)
;;
let apply_subst_context status ~fix_projections ctx =
let _,_,_,subst,_ = status#obj in
- NCicUntrusted.apply_subst_context ~fix_projections subst ctx
+ NCicUntrusted.apply_subst_context status ~fix_projections subst ctx
;;
let metas_of_term status (context,t) =
let _,_,_,subst,_ = status#obj in
- NCicUntrusted.metas_of_term subst context t
+ NCicUntrusted.metas_of_term status subst context t
;;
(* ============= move this elsewhere ====================*)
method stack: 'stack
end
-class ['stack] status =
+class virtual ['stack] status =
fun (o: NCic.obj) (s: 'stack) ->
object (self)
inherit (pstatus o)
= fun o -> (self#set_pstatus o)#set_stack o#stack
end
-class type lowtac_status = [unit] status
+class type virtual lowtac_status = [unit] status
type 'status lowtactic = #lowtac_status as 'status -> int -> 'status
-class type tac_status = [Continuationals.Stack.t] status
+class type virtual tac_status = [Continuationals.Stack.t] status
type 'status tactic = #tac_status as 'status -> 'status
+let pp_tac_status (status: #tac_status) =
+ prerr_endline (status#ppobj status#obj);
+ prerr_endline ("STACK:\n" ^ Continuationals.Stack.pp status#stack)
+;;
+
module NCicInverseRelIndexable : Discrimination_tree.Indexable
with type input = cic_term and type constant_name = NUri.uri = struct
method obj: NCic.obj
end
-class pstatus :
+class virtual pstatus :
NCic.obj ->
object ('self)
inherit g_pstatus
method stack: 'stack
end
-class ['stack] status :
+class virtual ['stack] status :
NCic.obj -> 'stack ->
object ('self)
inherit ['stack] g_status
method set_status: 'stack #g_status -> 'self
end
-class type lowtac_status = [unit] status
+class type virtual lowtac_status = [unit] status
type 'status lowtactic = #lowtac_status as 'status -> int -> 'status
-class type tac_status = [Continuationals.Stack.t] status
+class type virtual tac_status = [Continuationals.Stack.t] status
val pp_tac_status: #tac_status -> unit
(e.g. the tactic could perform a global analysis of the set of goals)
*)
+(* CSC: potential bug here: the new methods still use the instance variables
+ of the old status and not the instance variables of the new one *)
+let change_stack_type (status : 'a #NTacStatus.status) (stack: 'b) : 'b NTacStatus.status =
+ let o =
+ object
+ inherit ['b] NTacStatus.status status#obj stack
+ method ppterm = status#ppterm
+ method ppcontext = status#ppcontext
+ method ppsubst = status#ppsubst
+ method ppobj = status#ppobj
+ method ppmetasenv = status#ppmetasenv
+ end
+ in
+ o#set_pstatus status
+;;
+
let exec tac (low_status : #lowtac_status) g =
let stack = [ [0,Open g], [], [], `NoTag ] in
- let status =
- (new NTacStatus.status low_status#obj stack)#set_pstatus low_status
- in
+ let status = change_stack_type low_status stack in
let status = tac status in
(low_status#set_pstatus status)#set_obj status#obj
;;
in
aux s go gc loc_tl
in
- let s0 = (new NTacStatus.status status#obj ())#set_pstatus status in
+ let s0 = change_stack_type status () in
let s0, go0, gc0 = s0, [], [] in
let sn, gon, gcn = aux s0 go0 gc0 g in
debug_print (lazy ("opened: "
names
in
let n,h,metasenv,subst,o = status#obj in
- let metasenv,subst,_,_ = NCicMetaSubst.restrict metasenv subst goal js in
+ let metasenv,subst,_,_ = NCicMetaSubst.restrict status metasenv subst goal js in
status#set_obj (n,h,metasenv,subst,o))
;;
else exact_tac ("",0,Ast.Appl (Ast.Implicit `JustOne :: args))
;;
-let select0_tac ~where:(wanted,hyps,where) ~job =
+let select0_tac ~where ~job =
let found, postprocess =
match job with
| `Substexpand argsno -> mk_in_scope, mk_out_scope argsno
| `ChangeWith f -> f,(fun s t -> s, t)
in
distribute_tac (fun status goal ->
+ let wanted,hyps,where =
+ GrafiteDisambiguate.disambiguate_npattern status where in
let goalty = get_goalty status goal in
let path =
match where with None -> NCic.Implicit `Term | Some where -> where
instantiate ~refine:false status goal instance)
;;
-let select_tac ~where ~job move_down_hyps =
- let (wanted,hyps,where) = GrafiteDisambiguate.disambiguate_npattern where in
- let path =
- match where with None -> NCic.Implicit `Term | Some where -> where in
+let select_tac ~where:((txt,txtlen,(wanted,hyps,path)) as where) ~job
+ move_down_hyps
+=
if not move_down_hyps then
- select0_tac ~where:(wanted,hyps,Some path) ~job
+ select0_tac ~where ~job
else
let path =
List.fold_left
- (fun path (name,path_name) -> NCic.Prod ("_",path_name,path))
- path (List.rev hyps)
+ (fun path (name,ty) ->
+ NotationPt.Binder (`Forall, (NotationPt.Ident (name,None),Some ty),path))
+ (match path with Some x -> x | None -> NotationPt.UserInput) (List.rev hyps)
in
block_tac [
generalize0_tac (List.map (fun (name,_) -> Ast.Ident (name,None)) hyps);
- select0_tac ~where:(wanted,[],Some path) ~job;
+ select0_tac ~where:(txt,txtlen,(wanted,[],Some path)) ~job;
clear_tac (List.map fst hyps) ]
;;
whd status
?delta:(if perform_delta then None else Some max_int) (ctx_of t) t
in
- let where = GrafiteDisambiguate.disambiguate_npattern where in
- select0_tac ~where ~job:(`ChangeWith change)
+ select_tac ~where ~job:(`ChangeWith change) false
;;
let change_tac ~where ~with_what =
let status = unify status (ctx_of t) t ww in
status, ww
in
- let where = GrafiteDisambiguate.disambiguate_npattern where in
- select0_tac ~where ~job:(`ChangeWith change)
+ select_tac ~where ~job:(`ChangeWith change) false
;;
let letin_tac ~where ~what:(_,_,w) name =
let t2 = mk_cic_term ctx t2 in
let status,t2 = apply_subst status ctx t2 in
let status,t2 = term_of_cic_term status t2 ctx in
- prerr_endline ("COMPARING: " ^ NCicPp.ppterm ~subst:[] ~metasenv:[] ~context:ctx t1 ^ " vs " ^ NCicPp.ppterm ~subst:[] ~metasenv:[] ~context:ctx t2);
+ prerr_endline ("COMPARING: " ^ status#ppterm ~subst:[] ~metasenv:[] ~context:ctx t1 ^ " vs " ^ status#ppterm ~subst:[] ~metasenv:[] ~context:ctx t2);
assert (t1=t2);
status
in
's NTacStatus.tactic
val constructor_tac :
- ?num:int -> args:NTacStatus.tactic_term list -> 's NTacStatus.tactic
+ ?num:int -> args:NTacStatus.tactic_term list -> 's NTacStatus.tactic
-val atomic_tac :
- (NTacStatus.tac_status -> 'c #NTacStatus.status) ->
- (#NTacStatus.tac_status as 'f) -> 'f
+val atomic_tac : NTacStatus.tac_status NTacStatus.tactic -> 's NTacStatus.tactic
+ (*(NTacStatus.tac_status -> 'c #NTacStatus.status) ->
+ (#NTacStatus.tac_status as 'f) -> 'f*)
type indtyinfo
else true
with Not_found -> true
-let print_stat tbl =
+let print_stat status tbl =
let l = RefHash.fold (fun a v l -> (a,v)::l) tbl [] in
let relevance v = float !(v.uses) /. float !(v.nominations) in
let vcompare (_,v1) (_,v2) =
Pervasives.compare (relevance v1) (relevance v2) in
let l = List.sort vcompare l in
let vstring (a,v)=
- NotationPp.pp_term (Ast.NCic (NCic.Const a)) ^ ": rel = " ^
+ NotationPp.pp_term status (Ast.NCic (NCic.Const a)) ^ ": rel = " ^
(string_of_float (relevance v)) ^
"; uses = " ^ (string_of_int !(v.uses)) ^
"; nom = " ^ (string_of_int !(v.nominations)) in
let _,_,metasenv,subst,_ = status#obj in
try
let _, ctx, ty = NCicUtils.lookup_meta g metasenv in
- let ty = NCicUntrusted.apply_subst subst ctx ty in
- let ctx = NCicUntrusted.apply_subst_context
+ let ty = NCicUntrusted.apply_subst status subst ctx ty in
+ let ctx = NCicUntrusted.apply_subst_context status
~fix_projections:true subst ctx
in
NTacStatus.mk_cic_term ctx ty
let is_a_fact status ty = branch status ty = 0
let is_a_fact_obj s uri =
- let obj = NCicEnvironment.get_checked_obj uri in
+ let obj = NCicEnvironment.get_checked_obj s uri in
match obj with
| (_,_,[],[],NCic.Constant(_,_,_,ty,_)) ->
is_a_fact s (mk_cic_term [] ty)
let is_a_fact_ast status subst metasenv ctx cand =
debug_print ~depth:0
- (lazy ("------- checking " ^ NotationPp.pp_term cand));
+ (lazy ("------- checking " ^ NotationPp.pp_term status cand));
let status, t = disambiguate status ctx ("",0,cand) None in
let status,t = term_of_cic_term status t ctx in
- let ty = NCicTypeChecker.typeof subst metasenv ctx t in
+ let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
is_a_fact status (mk_cic_term ctx ty)
let current_goal status =
let ctx = ctx_of gty in
open_goal, ctx, gty
-let height_of_ref (NReference.Ref (uri, x)) =
+let height_of_ref status (NReference.Ref (uri, x)) =
match x with
| NReference.Decl
| NReference.Ind _
| NReference.Con _
| NReference.CoFix _ ->
- let _,height,_,_,_ = NCicEnvironment.get_checked_obj uri in
+ let _,height,_,_,_ = NCicEnvironment.get_checked_obj status uri in
height
| NReference.Def h -> h
| NReference.Fix (_,_,h) -> h
;;
(*************************** height functions ********************************)
-let fast_height_of_term t =
+let fast_height_of_term status t =
let h = ref 0 in
let rec aux =
function
| NCic.Implicit _ -> assert false
| NCic.Const nref ->
(*
- prerr_endline (NCicPp.ppterm ~metasenv:[] ~subst:[]
- ~context:[] t ^ ":" ^ string_of_int (height_of_ref nref));
+ prerr_endline (status#ppterm ~metasenv:[] ~subst:[]
+ ~context:[] t ^ ":" ^ string_of_int (height_of_ref status nref));
*)
- h := max !h (height_of_ref nref)
+ h := max !h (height_of_ref status nref)
| NCic.Prod (_,t1,t2)
| NCic.Lambda (_,t1,t2) -> aux t1; aux t2
| NCic.LetIn (_,s,ty,t) -> aux s; aux ty; aux t
let ty = get_goalty status g in
let context = ctx_of ty in
let _, ty = term_of_cic_term status ty (ctx_of ty) in
- let h = ref (fast_height_of_term ty) in
+ let h = ref (fast_height_of_term status ty) in
List.iter
(function
- | _, NCic.Decl ty -> h := max !h (fast_height_of_term ty)
+ | _, NCic.Decl ty -> h := max !h (fast_height_of_term status ty)
| _, NCic.Def (bo,ty) ->
- h := max !h (fast_height_of_term ty);
- h := max !h (fast_height_of_term bo);
+ h := max !h (fast_height_of_term status ty);
+ h := max !h (fast_height_of_term status bo);
)
context;
!h
*)
let n,h,metasenv,subst,o = status#obj in
let gname, ctx, gty = List.assoc goal metasenv in
- let gty = NCicUntrusted.apply_subst subst ctx gty in
+ let gty = NCicUntrusted.apply_subst status subst ctx gty in
let build_status (pt, _, metasenv, subst) =
try
- debug_print (lazy ("refining: "^(NCicPp.ppterm ctx subst metasenv pt)));
+ debug_print (lazy ("refining: "^(status#ppterm ctx subst metasenv pt)));
let stamp = Unix.gettimeofday () in
let metasenv, subst, pt, pty =
(* NCicRefiner.typeof status
(* (status#set_coerc_db NCicCoercion.empty_db) *)
metasenv subst ctx pt None in
- print (lazy ("refined: "^(NCicPp.ppterm ctx subst metasenv pt)));
- debug_print (lazy ("synt: "^(NCicPp.ppterm ctx subst metasenv pty)));
+ print (lazy ("refined: "^(status#ppterm ctx subst metasenv pt)));
+ debug_print (lazy ("synt: "^(status#ppterm ctx subst metasenv pty)));
let metasenv, subst =
NCicUnification.unify status metasenv subst ctx gty pty *)
NCicRefiner.typeof
debug_print (lazy ("WARNING: refining in fast_eq_check failed\n" ^
snd (Lazy.force msg) ^
"\n in the environment\n" ^
- NCicPp.ppmetasenv subst metasenv)); None
+ status#ppmetasenv subst metasenv)); None
| NCicRefiner.AssertFailure msg ->
debug_print (lazy ("WARNING: refining in fast_eq_check failed" ^
Lazy.force msg ^
"\n in the environment\n" ^
- NCicPp.ppmetasenv subst metasenv)); None
+ status#ppmetasenv subst metasenv)); None
| _ -> None
in
HExtlib.filter_map build_status
c:= !c+1;
let t = NCic.Rel !c in
try
- let ty = NCicTypeChecker.typeof [] [] ctx t in
+ let ty = NCicTypeChecker.typeof status [] [] ctx t in
if is_a_fact status (mk_cic_term ctx ty) then
- (debug_print(lazy("eq indexing " ^ (NCicPp.ppterm ctx [] [] ty)));
+ (debug_print(lazy("eq indexing " ^ (status#ppterm ctx [] [] ty)));
NCicParamod.forward_infer_step eq_cache t ty)
else
- (debug_print (lazy ("not a fact: " ^ (NCicPp.ppterm ctx [] [] ty)));
+ (debug_print (lazy ("not a fact: " ^ (status#ppterm ctx [] [] ty)));
eq_cache)
with
| NCicTypeChecker.TypeCheckerFailure _
(*************** subsumption ****************)
-let close_wrt_context =
+let close_wrt_context status =
List.fold_left
(fun ty ctx_entry ->
match ctx_entry with
| name, NCic.Decl t -> NCic.Prod(name,t,ty)
- | name, NCic.Def(bo, _) -> NCicSubstitution.subst bo ty)
+ | name, NCic.Def(bo, _) -> NCicSubstitution.subst status bo ty)
;;
let args_for_context ?(k=1) ctx =
(k,[]) ctx in
args
-let constant_for_meta ctx ty i =
+let constant_for_meta status ctx ty i =
let name = "cic:/foo"^(string_of_int i)^".con" in
let uri = NUri.uri_of_string name in
- let ty = close_wrt_context ty ctx in
- (* prerr_endline (NCicPp.ppterm [] [] [] ty); *)
+ let ty = close_wrt_context status ty ctx in
+ (* prerr_endline (status#ppterm [] [] [] ty); *)
let attr = (`Generated,`Definition,`Local) in
let obj = NCic.Constant([],name,None,ty,attr) in
(* Constant of relevance * string * term option * term * c_attr *)
(* close metasenv returns a ground instance of all the metas in the
metasenv, insantiatied with axioms, and the list of these axioms *)
-let close_metasenv metasenv subst =
+let close_metasenv status metasenv subst =
(*
let metasenv = NCicUntrusted.apply_subst_metasenv subst metasenv in
*)
- let metasenv = NCicUntrusted.sort_metasenv subst metasenv in
+ let metasenv = NCicUntrusted.sort_metasenv status subst metasenv in
List.fold_left
(fun (subst,objs) (i,(iattr,ctx,ty)) ->
- let ty = NCicUntrusted.apply_subst subst ctx ty in
+ let ty = NCicUntrusted.apply_subst status subst ctx ty in
let ctx =
- NCicUntrusted.apply_subst_context ~fix_projections:true
+ NCicUntrusted.apply_subst_context status ~fix_projections:true
subst ctx in
let (uri,_,_,_,obj) as okind =
- constant_for_meta ctx ty i in
+ constant_for_meta status ctx ty i in
try
- NCicEnvironment.check_and_add_obj okind;
+ NCicEnvironment.check_and_add_obj status okind;
let iref = NReference.reference_of_spec uri NReference.Decl in
let iterm =
let args = args_for_context ctx in
if args = [] then NCic.Const iref
else NCic.Appl(NCic.Const iref::args)
in
- (* prerr_endline (NCicPp.ppterm ctx [] [] iterm); *)
+ (* prerr_endline (status#ppterm ctx [] [] iterm); *)
let s_entry = i, ([], ctx, iterm, ty)
in s_entry::subst,okind::objs
with _ -> assert false)
(*
let submenv = metasenv in
*)
- let subst, objs = close_metasenv submenv subst in
+ let subst, objs = close_metasenv status submenv subst in
try
List.iter
(fun i ->
let (_, ctx, t, _) = List.assoc i subst in
- debug_print (lazy (NCicPp.ppterm ctx [] [] t));
+ debug_print (lazy (status#ppterm ctx [] [] t));
List.iter
(fun (uri,_,_,_,_) as obj ->
NCicEnvironment.invalidate_item (`Obj (uri, obj)))
(* (ctx,t) *)
;;
-let replace_meta i args target =
+let replace_meta status i args target =
let rec aux k = function
(* TODO: local context *)
| NCic.Meta (j,lc) when i = j ->
(match args with
| [] -> NCic.Rel 1
| _ -> let args =
- List.map (NCicSubstitution.subst_meta lc) args in
+ List.map (NCicSubstitution.subst_meta status lc) args in
NCic.Appl(NCic.Rel k::args))
| NCic.Meta (j,lc) as m ->
(match lc with
NCic.Meta
(i,(0,NCic.Ctx
(List.map (fun t ->
- aux k (NCicSubstitution.lift n t)) l))))
- | t -> NCicUtils.map (fun _ k -> k+1) k aux t
+ aux k (NCicSubstitution.lift status n t)) l))))
+ | t -> NCicUtils.map status (fun _ k -> k+1) k aux t
in
aux 1 target
;;
-let close_wrt_metasenv subst =
+let close_wrt_metasenv status subst =
List.fold_left
(fun ty (i,(iattr,ctx,mty)) ->
- let mty = NCicUntrusted.apply_subst subst ctx mty in
+ let mty = NCicUntrusted.apply_subst status subst ctx mty in
let ctx =
- NCicUntrusted.apply_subst_context ~fix_projections:true
+ NCicUntrusted.apply_subst_context status ~fix_projections:true
subst ctx in
- let cty = close_wrt_context mty ctx in
+ let cty = close_wrt_context status mty ctx in
let name = "foo"^(string_of_int i) in
- let ty = NCicSubstitution.lift 1 ty in
+ let ty = NCicSubstitution.lift status 1 ty in
let args = args_for_context ~k:1 ctx in
- (* prerr_endline (NCicPp.ppterm ctx [] [] iterm); *)
- let ty = replace_meta i args ty
+ (* prerr_endline (status#ppterm ctx [] [] iterm); *)
+ let ty = replace_meta status i args ty
in
NCic.Prod(name,cty,ty))
;;
let subset = IntSet.remove g subset in
let elems = IntSet.elements subset in
let _, ctx, ty = NCicUtils.lookup_meta g metasenv in
- let ty = NCicUntrusted.apply_subst subst ctx ty in
- debug_print (lazy ("metas in " ^ (NCicPp.ppterm ctx [] metasenv ty)));
+ let ty = NCicUntrusted.apply_subst status subst ctx ty in
+ debug_print (lazy ("metas in " ^ (status#ppterm ctx [] metasenv ty)));
debug_print (lazy (String.concat ", " (List.map string_of_int elems)));
let submenv = List.filter (fun (x,_) -> IntSet.mem x subset) metasenv in
- let submenv = List.rev (NCicUntrusted.sort_metasenv subst submenv) in
+ let submenv = List.rev (NCicUntrusted.sort_metasenv status subst submenv) in
(*
let submenv = metasenv in
*)
- let ty = close_wrt_metasenv subst ty submenv in
- debug_print (lazy (NCicPp.ppterm ctx [] [] ty));
+ let ty = close_wrt_metasenv status subst ty submenv in
+ debug_print (lazy (status#ppterm ctx [] [] ty));
ctx,ty
;;
(****************** smart application ********************)
-let saturate_to_ref metasenv subst ctx nref ty =
- let height = height_of_ref nref in
+let saturate_to_ref status metasenv subst ctx nref ty =
+ let height = height_of_ref status nref in
let rec aux metasenv ty args =
let ty,metasenv,moreargs =
- NCicMetaSubst.saturate ~delta:height metasenv subst ctx ty 0 in
+ NCicMetaSubst.saturate status ~delta:height metasenv subst ctx ty 0 in
match ty with
| NCic.Const(NReference.Ref (_,NReference.Def _) as nre)
when nre<>nref ->
- let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def nre in
+ let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def status nre in
aux metasenv bo (args@moreargs)
| NCic.Appl(NCic.Const(NReference.Ref (_,NReference.Def _) as nre)::tl)
when nre<>nref ->
- let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def nre in
+ let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def status nre in
aux metasenv (NCic.Appl(bo::tl)) (args@moreargs)
| _ -> ty,metasenv,(args@moreargs)
in
let status, t = disambiguate status ctx t None in
let status,t = term_of_cic_term status t ctx in
let _,_,metasenv,subst,_ = status#obj in
- let ty = NCicTypeChecker.typeof subst metasenv ctx t in
+ let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
let ty,metasenv,args =
match gty with
| NCic.Const(nref)
| NCic.Appl(NCic.Const(nref)::_) ->
- saturate_to_ref metasenv subst ctx nref ty
+ saturate_to_ref status metasenv subst ctx nref ty
| _ ->
- NCicMetaSubst.saturate metasenv subst ctx ty 0 in
+ NCicMetaSubst.saturate status metasenv subst ctx ty 0 in
let metasenv,j,inst,_ = NCicMetaSubst.mk_meta metasenv ctx `IsTerm in
let status = status#set_obj (n,h,metasenv,subst,o) in
let pterm = if args=[] then t else
| NCic.Appl l -> NCic.Appl(l@args)
| _ -> NCic.Appl(t::args)
in
- noprint(lazy("pterm " ^ (NCicPp.ppterm ctx [] [] pterm)));
- noprint(lazy("pty " ^ (NCicPp.ppterm ctx [] [] ty)));
+ noprint(lazy("pterm " ^ (status#ppterm ctx [] [] pterm)));
+ noprint(lazy("pty " ^ (status#ppterm ctx [] [] ty)));
let eq_coerc =
let uri =
NUri.uri_of_string "cic:/matita/basics/logic/eq_coerc.con" in
let status = instantiate status g smart in
let _,_,metasenv,subst,_ = status#obj in
let _,ctx,jty = List.assoc j metasenv in
- let jty = NCicUntrusted.apply_subst subst ctx jty in
- debug_print(lazy("goal " ^ (NCicPp.ppterm ctx [] [] jty)));
+ let jty = NCicUntrusted.apply_subst status subst ctx jty in
+ debug_print(lazy("goal " ^ (status#ppterm ctx [] [] jty)));
fast_eq_check unit_eq status j
with
| NCicEnvironment.ObjectNotFound s as e ->
;;
(* all_keys_of_cic_type: term -> term set *)
-let all_keys_of_cic_type metasenv subst context ty =
+let all_keys_of_cic_type status metasenv subst context ty =
let saturate ty =
(* Here we are dropping the metasenv, but this should not raise any
exception (hopefully...) *)
let ty,_,hyps =
- NCicMetaSubst.saturate ~delta:max_int metasenv subst context ty 0
+ NCicMetaSubst.saturate status ~delta:max_int metasenv subst context ty 0
in
ty,List.length hyps
in
NCic.Appl (he::tl) ->
let tl' =
List.map (fun ty ->
- let wty = NCicReduction.whd ~delta:0 ~subst context ty in
+ let wty = NCicReduction.whd status ~delta:0 ~subst context ty in
if ty = wty then
NDiscriminationTree.TermSet.add ty (aux ty)
else
| _ -> NDiscriminationTree.TermSet.empty
in
let ty,ity = saturate ty in
- let wty,iwty = saturate (NCicReduction.whd ~delta:0 ~subst context ty) in
+ let wty,iwty = saturate (NCicReduction.whd status ~delta:0 ~subst context ty) in
if ty = wty then
[ity, NDiscriminationTree.TermSet.add ty (aux ty)]
else
let context = ctx_of t in
let status, t = apply_subst status context t in
let keys =
- all_keys_of_cic_type metasenv subst context
+ all_keys_of_cic_type status metasenv subst context
(snd (term_of_cic_term status t context))
in
status,
set)
;;
-let pp_th status =
+let pp_th (status: #NTacStatus.pstatus) =
List.iter
(fun ctx, idx ->
debug_print(lazy( "-----------------------------------------------"));
- debug_print(lazy( (NCicPp.ppcontext ~metasenv:[] ~subst:[] ctx)));
+ debug_print(lazy( (status#ppcontext ~metasenv:[] ~subst:[] ctx)));
debug_print(lazy( "||====> "));
pp_idx status idx)
;;
trace: Ast.term list
}
-let add_to_trace ~depth cache t =
+let add_to_trace status ~depth cache t =
match t with
| Ast.NRef _ ->
- debug_print ~depth (lazy ("Adding to trace: " ^ NotationPp.pp_term t));
+ debug_print ~depth (lazy ("Adding to trace: " ^ NotationPp.pp_term status t));
{cache with trace = t::cache.trace}
| Ast.NCic _ (* local candidate *)
| _ -> (*not an application *) cache
-let pptrace tr =
+let pptrace status tr =
(lazy ("Proof Trace: " ^ (String.concat ";"
- (List.map NotationPp.pp_term tr))))
+ (List.map (NotationPp.pp_term status) tr))))
(* not used
let remove_from_trace cache t =
match t with
let candidate_ty =
NCicTypeChecker.typeof ~subst:[] ~metasenv:[] [] candidate
in
- let height = fast_height_of_term candidate_ty in
+ let height = fast_height_of_term status candidate_ty in
let rc = signature >= height in
if rc = false then
- debug_print (lazy ("Filtro: " ^ NCicPp.ppterm ~context:[] ~subst:[]
+ debug_print (lazy ("Filtro: " ^ status#ppterm ~context:[] ~subst:[]
~metasenv:[] candidate ^ ": " ^ string_of_int height))
else
- debug_print (lazy ("Tengo: " ^ NCicPp.ppterm ~context:[] ~subst:[]
+ debug_print (lazy ("Tengo: " ^ status#ppterm ~context:[] ~subst:[]
~metasenv:[] candidate ^ ": " ^ string_of_int height));
rc *)
let branch cand =
let status,ct = disambiguate status ctx ("",0,cand) None in
let status,t = term_of_cic_term status ct ctx in
- let ty = NCicTypeChecker.typeof subst metasenv ctx t in
+ let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
let res = branch status (mk_cic_term ctx ty) in
debug_print (lazy ("branch factor for: " ^ (ppterm status ct) ^ " = "
^ (string_of_int res)));
List.sort (fun (a,_) (b,_) -> a - b) candidates in
let candidates = List.map snd candidates in
debug_print (lazy ("candidates =\n" ^ (String.concat "\n"
- (List.map NotationPp.pp_term candidates))));
+ (List.map (NotationPp.pp_term status) candidates))));
candidates
let sort_new_elems l =
let try_candidate ?(smart=0) flags depth status eq_cache ctx t =
try
- debug_print ~depth (lazy ("try " ^ NotationPp.pp_term t));
+ debug_print ~depth (lazy ("try " ^ (NotationPp.pp_term status) t));
let status =
if smart= 0 then NTactics.apply_tac ("",0,t) status
else if smart = 1 then smart_apply_auto ("",0,t) eq_cache status
with Error (msg,exn) -> debug_print ~depth (lazy "failed"); None
;;
-let sort_of subst metasenv ctx t =
- let ty = NCicTypeChecker.typeof subst metasenv ctx t in
- let metasenv',ty = NCicUnification.fix_sorts metasenv subst ty in
+let sort_of status subst metasenv ctx t =
+ let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
+ let metasenv',ty = NCicUnification.fix_sorts status metasenv subst ty in
assert (metasenv = metasenv');
- NCicTypeChecker.typeof subst metasenv ctx ty
+ NCicTypeChecker.typeof status subst metasenv ctx ty
;;
let type0= NUri.uri_of_string ("cic:/matita/pts/Type0.univ")
;;
-let perforate_small subst metasenv context t =
+let perforate_small status subst metasenv context t =
let rec aux = function
| NCic.Appl (hd::tl) ->
let map t =
- let s = sort_of subst metasenv context t in
+ let s = sort_of status subst metasenv context t in
match s with
| NCic.Sort(NCic.Type [`Type,u])
when u=type0 -> NCic.Meta (0,(0,NCic.Irl 0))
| NCic.Appl _
| NCic.Const _
| NCic.Rel _ ->
- let weak = perforate_small subst metasenv context raw_gty in
+ let weak = perforate_small status subst metasenv context raw_gty in
Some weak, Some (mk_cic_term context weak)
| _ -> None,None
else None,None
| NCic.Appl _
| NCic.Const _
| NCic.Rel _ ->
- let weak_gty = perforate_small subst metasenv context raw_gty in
+ let weak_gty = perforate_small status subst metasenv context raw_gty in
(*
NCic.Appl (hd:: HExtlib.mk_list(NCic.Meta (0,(0,NCic.Irl 0)))
(List.length tl)) in *)
let tcache = cache.facts in
let is_prod, is_eq =
let status, t = term_of_cic_term status gty context in
- let t = NCicReduction.whd subst context t in
+ let t = NCicReduction.whd status subst context t in
match t with
| NCic.Prod _ -> true, false
- | _ -> false, NCicParamod.is_equation metasenv subst context t
+ | _ -> false, NCicParamod.is_equation status metasenv subst context t
in
debug_print~depth (lazy (string_of_bool is_eq));
(* old
let n,h,metasenv,subst,obj = status#obj in
let ctx = ctx_of gty in
let _ , target = term_of_cic_term status gty ctx in
- let target = NCicSubstitution.lift 1 target in
+ let target = NCicSubstitution.lift status 1 target in
(* candidates must only be searched w.r.t the given context *)
let candidates =
try
(match snd (term_of_cic_term status src ctx) with
| NCic.Const(NReference.Ref (_,NReference.Ind _) as r)
| NCic.Appl (NCic.Const(NReference.Ref (_,NReference.Ind _) as r)::_) ->
- let _,_,itys,_,_ = NCicEnvironment.get_checked_indtys r in
+ let _,_,itys,_,_ = NCicEnvironment.get_checked_indtys status r in
(match itys with
(* | [_,_,_,[_;_]] con nat va, ovviamente, in loop *)
| [_,_,_,[_]]
let reduce ~whd ~depth status g =
let n,h,metasenv,subst,o = status#obj in
let attr, ctx, ty = NCicUtils.lookup_meta g metasenv in
- let ty = NCicUntrusted.apply_subst subst ctx ty in
+ let ty = NCicUntrusted.apply_subst status subst ctx ty in
let ty' =
- (if whd then NCicReduction.whd else NCicTacReduction.normalize) ~subst ctx ty
+ (if whd then NCicReduction.whd else NCicTacReduction.normalize) status ~subst ctx ty
in
if ty = ty' then []
else
(debug_print ~depth
- (lazy ("reduced to: "^ NCicPp.ppterm ctx subst metasenv ty'));
+ (lazy ("reduced to: "^ status#ppterm ctx subst metasenv ty'));
let metasenv =
(g,(attr,ctx,ty'))::(List.filter (fun (i,_) -> i<>g) metasenv)
in
flags signature cache depth status : unit =
debug_print ~depth (lazy ("entering auto clusters at depth " ^
(string_of_int depth)));
- debug_print ~depth (pptrace cache.trace);
+ debug_print ~depth (pptrace status cache.trace);
(* ignore(Unix.select [] [] [] 0.01); *)
let status = clean_up_tac status in
let goals = head_goals status#stack in
(* BRAND NEW VERSION *)
auto_main flags signature cache depth status: unit =
debug_print ~depth (lazy "entering auto main");
- debug_print ~depth (pptrace cache.trace);
+ debug_print ~depth (pptrace status cache.trace);
debug_print ~depth (lazy ("stack length = " ^
(string_of_int (List.length status#stack))));
(* ignore(Unix.select [] [] [] 0.01); *)
(lazy ("(re)considering goal " ^
(string_of_int g) ^" : "^ppterm status gty));
debug_print (~depth:depth)
- (lazy ("Case: " ^ NotationPp.pp_term t));
+ (lazy ("Case: " ^ NotationPp.pp_term status t));
let depth,cache =
if t=Ast.Ident("__whd",None) ||
t=Ast.Ident("__intros",None)
then depth, cache
else depth+1,loop_cache in
- let cache = add_to_trace ~depth cache t in
+ let cache = add_to_trace status ~depth cache t in
try
auto_clusters flags signature cache depth status
with Gaveup _ ->
debug_print (lazy(
NDiscriminationTree.NCicIndexable.string_of_path p ^ " |--> " ^
String.concat "\n " (List.map (
- NCicPp.ppterm ~metasenv:[] ~context:[] ~subst:[])
+ status#ppterm ~metasenv:[] ~context:[] ~subst:[])
(NDiscriminationTree.TermSet.elements t))
)));
*)
debug_print (lazy ("proved at depth " ^ string_of_int x));
List.iter (toref incr_uses statistics) trace;
let trace = cleanup_trace s trace in
- let _ = debug_print (pptrace trace) in
+ let _ = debug_print (pptrace status trace) in
let stack =
match s#stack with
| (g,t,k,f) :: rest -> (filter_open g,t,k,f):: rest
oldstatus#set_status s
in
let s = up_to depth depth in
- debug_print (print_stat statistics);
+ debug_print (print_stat status statistics);
debug_print(lazy
("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time)));
debug_print(lazy
(* $Id$ *)
+let use_high_level_pretty_printer = ref true;;
+
+let to_text to_content to_pres lowlevel ~map_unicode_to_tex size status t =
+ if !use_high_level_pretty_printer then
+ let content,ids_to_nrefs = to_content status t in
+ let pres = to_pres status ~ids_to_nrefs content in
+ let pres = CicNotationPres.mpres_of_box pres in
+ BoxPp.render_to_string ~map_unicode_to_tex
+ (function x::_ -> x | _ -> assert false) size pres
+ else
+ [],lowlevel t
+
+let ntxt_of_cic_sequent ~metasenv ~subst =
+ to_text (Interpretations.nmap_sequent ~metasenv ~subst)
+ Content2pres.nsequent2pres
+ (fun seq -> (new NCicPp.status)#ppmetasenv ~subst [seq])
+
+let ntxt_of_cic_object ~map_unicode_to_tex =
+ to_text Interpretations.nmap_obj Content2pres.nobj2pres ~map_unicode_to_tex
+ (new NCicPp.status)#ppobj
+
+let ntxt_of_cic_term ~metasenv ~subst ~context =
+ to_text (Interpretations.nmap_term ~metasenv ~subst ~context)
+ (Content2pres.nterm2pres ?prec:None)
+ ((new NCicPp.status)#ppterm ~metasenv ~subst ~context)
+
+let ntxt_of_cic_context ~metasenv ~subst =
+ to_text (Interpretations.nmap_context ~metasenv ~subst)
+ Content2pres.ncontext2pres
+ ((new NCicPp.status)#ppcontext ~metasenv ~subst)
+
+let ntxt_of_cic_subst ~map_unicode_to_tex size status ~metasenv ?use_subst subst =
+ [],
+ "<<<high level printer for subst not implemented; low-level printing:>>>\n" ^
+ (new NCicPp.status)#ppsubst ~metasenv ?use_subst subst
+
class status =
- object
+ object(self)
inherit Interpretations.status
inherit TermContentPres.status
- end
+ method ppterm ~context ~subst ~metasenv ?margin ?inside_fix t =
+ snd (ntxt_of_cic_term ~map_unicode_to_tex:true 80 self ~metasenv ~subst
+ ~context t)
-let mpres_document pres_box =
- Xml.add_xml_declaration (CicNotationPres.print_box pres_box)
+ method ppcontext ?sep ~subst ~metasenv context =
+ snd (ntxt_of_cic_context ~map_unicode_to_tex:true 80 self ~metasenv ~subst
+ context)
-let ntxt_of_cic_sequent ~map_unicode_to_tex size status metasenv subst sequent =
- let content_sequent,ids_to_refs =
- Interpretations.nmap_sequent status ~metasenv ~subst sequent in
- let pres_sequent =
- Sequent2pres.nsequent2pres status ids_to_refs subst content_sequent in
- let pres_sequent = CicNotationPres.mpres_of_box pres_sequent in
- BoxPp.render_to_string ~map_unicode_to_tex
- (function x::_ -> x | _ -> assert false) size pres_sequent
-
-let ntxt_of_cic_object ~map_unicode_to_tex size status obj =
- let cobj,ids_to_nrefs = Interpretations.nmap_obj status obj in
- let pres_sequent = Content2pres.ncontent2pres status ~ids_to_nrefs cobj in
- let pres_sequent = CicNotationPres.mpres_of_box pres_sequent in
- BoxPp.render_to_string ~map_unicode_to_tex
- (function x::_ -> x | _ -> assert false) size pres_sequent
-;;
+ method ppsubst ~metasenv ?use_subst subst =
+ snd (ntxt_of_cic_subst ~map_unicode_to_tex:true 80 self ~metasenv ?use_subst
+ subst)
+
+ method ppmetasenv ~subst metasenv =
+ String.concat "\n"
+ (List.map
+ (fun m -> snd (ntxt_of_cic_sequent ~map_unicode_to_tex:true 80 self
+ ~metasenv ~subst m)) metasenv)
+
+ method ppobj obj =
+ snd (ntxt_of_cic_object ~map_unicode_to_tex:true 80 self obj)
+ end
(* *)
(***************************************************************************)
+val use_high_level_pretty_printer: bool ref
+
class status :
object
+ inherit NCic.cstatus
inherit Interpretations.status
inherit TermContentPres.status
end
val ntxt_of_cic_sequent:
+ metasenv:NCic.metasenv -> subst:NCic.substitution -> (* metasenv,substitution*)
map_unicode_to_tex:bool -> int -> #status ->
- NCic.metasenv -> NCic.substitution -> (* metasenv, substitution *)
int * NCic.conjecture -> (* sequent *)
- string (* text *)
+ (int * int * string) list * string (* hyperlinks, text *)
val ntxt_of_cic_object:
- map_unicode_to_tex:bool -> int -> #status -> NCic.obj -> string
+ map_unicode_to_tex:bool -> int -> #status -> NCic.obj ->
+ (int * int * string) list * string (* hyperlinks, text *)
let register_matita_script_current f = matita_script_current := f;;
let get_matita_script_current () = !matita_script_current ();;
-type document_element = string
+type document_element = (int * int * string) list * string (* hyperlinks,text *)
class type cicMathView =
object
(** Gdome.element of a MathML document whose rendering should be blank. Used
* by cicBrowser to render "about:blank" document *)
-let empty_mathml = lazy ""
+let empty_mathml = lazy ([],"")
(** shown for goals closed by side effects *)
-let closed_goal_mathml = lazy "chiuso per side effect..."
+let closed_goal_mathml = lazy ([],"chiuso per side effect...")
(*
let rec has_maction (elt :Gdome.element) =
(Cic.id, Cic.hypothesis) Hashtbl.t *
(Cic.id, Cic.id option) Hashtbl.t * ('a, 'b) Hashtbl.t * 'c option)*) option -> unit)
(* dal widget di Luca *)
- method load_root ~root =
+ method load_root ~root:(hyperlinks,text) =
self#buffer#delete ~start:(self#buffer#get_iter `START)
~stop:(self#buffer#get_iter `END);
- self#buffer#insert root
+ self#buffer#insert text;
+ let hyperlink_tag = self#buffer#create_tag [`FOREGROUND "green"] in
+ List.iter
+ ( fun (start,stop,(href : string)) ->
+ self#buffer#apply_tag hyperlink_tag
+ ~start:(self#buffer#get_iter (`OFFSET start))
+ ~stop:(self#buffer#get_iter (`OFFSET stop))
+ ) hyperlinks
method action_toggle = (fun _ -> assert false : document_element -> bool)
method remove_selections = (() : unit)
method set_selection = (fun _ -> () : document_element option -> unit)
let sequent = List.assoc metano metasenv in
let txt =
ApplyTransformation.ntxt_of_cic_sequent
- ~map_unicode_to_tex:false 80 status metasenv subst (metano,sequent)
+ ~map_unicode_to_tex:false 80 status ~metasenv ~subst (metano,sequent)
in
(* MATITA 1.0 if BuildTimeConf.debug then begin
let name =
*)
addDebugSeparator ();
addDebugCheckbox "high level pretty printer" ~init:true
- (fun mi () -> assert false (* MATITA 1.0 *));
- addDebugSeparator ();
- addDebugItem "always show all disambiguation errors"
- (fun _ -> MatitaGui.all_disambiguation_passes := true);
- addDebugItem "prune disambiguation errors"
- (fun _ -> MatitaGui.all_disambiguation_passes := false);
+ (fun mi () -> ApplyTransformation.use_high_level_pretty_printer := mi#active);
addDebugSeparator ();
+ addDebugCheckbox "prune errors"
+ (fun mi () -> MatitaGui.all_disambiguation_passes := not (mi#active));
+ (*MATITA 1.0: ??? addDebugItem "prune disambiguation errors"
+ (fun _ -> MatitaGui.all_disambiguation_passes := false);*)
addDebugCheckbox "multiple disambiguation passes" ~init:true
(fun mi () -> MultiPassDisambiguator.only_one_pass := mi#active);
+ addDebugSeparator ();
addDebugCheckbox "tactics logging"
(fun mi () -> NTacStatus.debug := mi#active);
addDebugCheckbox "disambiguation/refiner/unification/metasubst logging"
open GrafiteTypes
open Printf
+class status baseuri =
+ object
+ inherit GrafiteTypes.status baseuri
+ inherit ApplyTransformation.status
+ end
+
exception TryingToAdd of string Lazy.t
-exception EnrichedWithStatus of exn * GrafiteTypes.status
+exception EnrichedWithStatus of exn * status
exception AlreadyLoaded of string Lazy.t
exception FailureCompiling of string * exn
exception CircularDependency of string
let slash_n_RE = Pcre.regexp "\\n" ;;
-let pp_ast_statement grafite_status stm =
- let stm = GrafiteAstPp.pp_statement stm
+let pp_ast_statement status stm =
+ let stm = GrafiteAstPp.pp_statement status stm
~map_unicode_to_tex:(Helm_registry.get_bool "matita.paste_unicode_as_tex")
in
let stm = Pcre.replace ~rex:slash_n_RE stm in
if Http_getter_storage.is_read_only baseuri then assert false;
activate_extraction baseuri fname ;
(* MATITA 1.0: debbo fare time_travel sulla ng_library? *)
- let grafite_status = new GrafiteTypes.status baseuri in
+ let status = new status baseuri in
let big_bang = Unix.gettimeofday () in
let { Unix.tms_utime = big_bang_u ; Unix.tms_stime = big_bang_s} =
Unix.times ()
(Http_getter.filename ~local:true ~writable:true (baseuri ^
"foo.con")));
let buf =
- GrafiteParser.parsable_statement grafite_status
+ GrafiteParser.parsable_statement status
(Ulexing.from_utf8_channel (open_in fname))
in
let print_cb =
if not (Helm_registry.get_bool "matita.verbose") then (fun _ _ -> ())
else pp_ast_statement
in
- let asserted, grafite_status =
- eval_from_stream ~compiling ~asserted ~include_paths grafite_status buf print_cb in
+ let asserted, status =
+ eval_from_stream ~compiling ~asserted ~include_paths status buf print_cb in
let elapsed = Unix.time () -. time in
(if Helm_registry.get_bool "matita.moo" then begin
GrafiteTypes.Serializer.serialize ~baseuri:(NUri.uri_of_string baseuri)
- grafite_status
+ status
end;
let tm = Unix.gmtime elapsed in
let sec = string_of_int tm.Unix.tm_sec ^ "''" in
exception FailureCompiling of string * exn
exception CircularDependency of string
+class status:
+ string ->
+ object
+ inherit GrafiteTypes.status
+ inherit ApplyTransformation.status
+ end
+
val get_ast:
GrafiteTypes.status -> include_paths:string list -> GrafiteParser.parsable ->
GrafiteAst.statement
| _ -> self#blank ()
method private _loadNReference (NReference.Ref (uri,_)) =
- let obj = NCicEnvironment.get_checked_obj uri in
- self#_loadNObj (get_matita_script_current ())#status obj
+ let status = (get_matita_script_current ())#status in
+ let obj = NCicEnvironment.get_checked_obj status uri in
+ self#_loadNObj status obj
method private _loadDir dir =
let content = Http_getter.ls ~local:false dir in
projects / helm.git / commitdiff