From 894d518aa760c9f816ddb0dc2b3fa88e1fe20a94 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Tue, 11 Jan 2011 21:06:37 +0000 Subject: [PATCH] HUGE COMMIT: 1) sequent2pres merged into content2pres 2) more functions to render sequents/context/substs to content and then to presentation 3) new virtual class NCic.status with methods implementing pretty-printing functions (same interface that used to be given in NCicPp); objects of this class are now used REALLY ALL OVER the matita code (well, almost...) 4) NCicPp implements a concrete version of NCic.status (low level pretty-printer) 5) ApplyTransformation implements a concrete version of NCic.status (high level pretty-printer that uses notation). It also exports the boolean reference to deactivate the high level pretty printer in favour of the low level one 6) some code simplifications here and there (in particular for tactics) 7) return type of BoxPp changed to yield informations about hyperlinks; the information is not used yet by the interface and it is not computed yet (not that easy to do...) 8) other minor stuff here and there --- matita/components/Makefile | 1 + matita/components/content/notationPp.ml | 52 +- matita/components/content/notationPp.mli | 9 +- matita/components/content_pres/.depend | 5 - matita/components/content_pres/.depend.opt | 5 - matita/components/content_pres/Makefile | 1 - matita/components/content_pres/boxPp.ml | 5 + matita/components/content_pres/boxPp.mli | 18 +- .../content_pres/cicNotationParser.ml | 16 +- .../content_pres/cicNotationParser.mli | 3 +- .../content_pres/cicNotationPres.ml | 4 +- .../content_pres/cicNotationPres.mli | 1 + .../components/content_pres/content2pres.ml | 202 ++++-- .../components/content_pres/content2pres.mli | 21 +- .../content_pres/content2presMatcher.ml | 7 +- .../components/content_pres/sequent2pres.ml | 109 ---- .../components/content_pres/sequent2pres.mli | 39 -- .../content_pres/termContentPres.ml | 17 +- .../content_pres/termContentPres.mli | 6 +- matita/components/grafite/grafiteAstPp.ml | 78 +-- matita/components/grafite/grafiteAstPp.mli | 9 +- .../grafite_engine/grafiteEngine.ml | 96 +-- .../components/grafite_engine/grafiteTypes.ml | 2 +- .../grafite_engine/grafiteTypes.mli | 2 +- .../grafite_engine/nCicCoercDeclaration.ml | 64 +- .../grafite_parser/grafiteParser.ml | 9 +- .../grafite_parser/grafiteParser.mli | 2 +- .../ng_cic_content/interpretations.ml | 140 ++-- .../ng_cic_content/interpretations.mli | 16 +- .../ng_cic_content/ncic2astMatcher.ml | 8 +- .../ng_cic_content/ncic2astMatcher.mli | 1 + .../ng_disambiguation/grafiteDisambiguate.ml | 51 +- .../ng_disambiguation/grafiteDisambiguate.mli | 7 +- .../ng_disambiguation/nCicDisambiguate.ml | 117 ++-- .../ng_disambiguation/nCicDisambiguate.mli | 7 +- matita/components/ng_kernel/.depend | 18 +- matita/components/ng_kernel/.depend.opt | 18 +- matita/components/ng_kernel/Makefile | 4 +- matita/components/ng_kernel/nCic.ml | 35 + .../components/ng_kernel/nCicEnvironment.ml | 48 +- .../components/ng_kernel/nCicEnvironment.mli | 16 +- matita/components/ng_kernel/nCicPp.ml | 122 ++-- matita/components/ng_kernel/nCicPp.mli | 29 +- matita/components/ng_kernel/nCicReduction.ml | 130 ++-- matita/components/ng_kernel/nCicReduction.mli | 24 +- .../components/ng_kernel/nCicSubstitution.ml | 36 +- .../components/ng_kernel/nCicSubstitution.mli | 16 +- .../components/ng_kernel/nCicTypeChecker.ml | 610 +++++++++--------- .../components/ng_kernel/nCicTypeChecker.mli | 23 +- matita/components/ng_kernel/nCicUntrusted.ml | 77 +-- matita/components/ng_kernel/nCicUntrusted.mli | 18 +- matita/components/ng_kernel/nCicUtils.ml | 6 +- matita/components/ng_kernel/nCicUtils.mli | 3 +- matita/components/ng_library/nCicLibrary.ml | 56 +- matita/components/ng_library/nCicLibrary.mli | 7 +- .../components/ng_paramodulation/nCicBlob.ml | 12 +- .../ng_paramodulation/nCicParamod.ml | 36 +- .../ng_paramodulation/nCicParamod.mli | 7 +- .../components/ng_paramodulation/nCicProof.ml | 55 +- .../ng_paramodulation/nCicProof.mli | 1 + matita/components/ng_refiner/nCicCoercion.ml | 44 +- matita/components/ng_refiner/nCicCoercion.mli | 2 +- matita/components/ng_refiner/nCicMetaSubst.ml | 104 +-- .../components/ng_refiner/nCicMetaSubst.mli | 6 +- .../components/ng_refiner/nCicRefineUtil.ml | 20 +- .../components/ng_refiner/nCicRefineUtil.mli | 3 +- matita/components/ng_refiner/nCicRefiner.ml | 388 +++++------ matita/components/ng_refiner/nCicUnifHint.ml | 87 +-- matita/components/ng_refiner/nCicUnifHint.mli | 3 +- .../components/ng_refiner/nCicUnification.ml | 316 ++++----- .../components/ng_refiner/nCicUnification.mli | 11 +- matita/components/ng_tactics/nCicElim.ml | 41 +- matita/components/ng_tactics/nCicElim.mli | 5 +- .../components/ng_tactics/nCicTacReduction.ml | 18 +- .../ng_tactics/nCicTacReduction.mli | 3 +- matita/components/ng_tactics/nDestructTac.ml | 54 +- matita/components/ng_tactics/nInversion.ml | 20 +- matita/components/ng_tactics/nTacStatus.ml | 72 +-- matita/components/ng_tactics/nTacStatus.mli | 8 +- matita/components/ng_tactics/nTactics.ml | 52 +- matita/components/ng_tactics/nTactics.mli | 8 +- matita/components/ng_tactics/nnAuto.ml | 214 +++--- matita/matita/applyTransformation.ml | 76 ++- matita/matita/applyTransformation.mli | 10 +- matita/matita/cicMathView.ml | 19 +- matita/matita/matita.ml | 12 +- matita/matita/matitaEngine.ml | 22 +- matita/matita/matitaEngine.mli | 7 + matita/matita/matitaMathView.ml | 5 +- 89 files changed, 2125 insertions(+), 2042 deletions(-) delete mode 100644 matita/components/content_pres/sequent2pres.ml delete mode 100644 matita/components/content_pres/sequent2pres.mli diff --git a/matita/components/Makefile b/matita/components/Makefile index 61ce8a364..d8e240e56 100644 --- a/matita/components/Makefile +++ b/matita/components/Makefile @@ -8,6 +8,7 @@ NULL = MODULES = \ extlib \ xml \ + hgdome \ registry \ syntax_extensions \ thread \ diff --git a/matita/components/content/notationPp.ml b/matita/components/content/notationPp.ml index b75192460..8828a0321 100644 --- a/matita/components/content/notationPp.ml +++ b/matita/components/content/notationPp.ml @@ -78,7 +78,8 @@ let pp_capture_variable pp_term = | 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 -> @@ -107,7 +108,7 @@ let rec pp_term ?(pp_parens = true) t = 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 *) @@ -140,10 +141,10 @@ let rec pp_term ?(pp_parens = true) t = | 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 @@ -161,8 +162,8 @@ let rec pp_term ?(pp_parens = true) t = | 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 @@ -174,10 +175,11 @@ let rec pp_term ?(pp_parens = true) t = | 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 = @@ -191,13 +193,13 @@ and pp_pattern = | [] -> 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 @@ -207,7 +209,9 @@ and pp_box_spec (kind, spacing, indent) = 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) @@ -238,7 +242,9 @@ and pp_layout = function (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) -> @@ -272,7 +278,7 @@ and pp_variable = function | 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 @@ -323,14 +329,14 @@ let pp_obj 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 @@ -340,11 +346,11 @@ let rec pp_value_type = | 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 diff --git a/matita/components/content/notationPp.mli b/matita/components/content/notationPp.mli index 51a284e2e..b1a552332 100644 --- a/matita/components/content/notationPp.mli +++ b/matita/components/content/notationPp.mli @@ -38,11 +38,11 @@ * 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 @@ -51,5 +51,4 @@ val pp_attribute: NotationPt.term_attribute -> 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 diff --git a/matita/components/content_pres/.depend b/matita/components/content_pres/.depend index 7b0acd5dc..5c11c1ded 100644 --- a/matita/components/content_pres/.depend +++ b/matita/components/content_pres/.depend @@ -8,7 +8,6 @@ termContentPres.cmi: cicNotationParser.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 @@ -37,7 +36,3 @@ content2pres.cmo: termContentPres.cmi renderingAttrs.cmi mpresentation.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 diff --git a/matita/components/content_pres/.depend.opt b/matita/components/content_pres/.depend.opt index 7b0acd5dc..5c11c1ded 100644 --- a/matita/components/content_pres/.depend.opt +++ b/matita/components/content_pres/.depend.opt @@ -8,7 +8,6 @@ termContentPres.cmi: cicNotationParser.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 @@ -37,7 +36,3 @@ content2pres.cmo: termContentPres.cmi renderingAttrs.cmi mpresentation.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 diff --git a/matita/components/content_pres/Makefile b/matita/components/content_pres/Makefile index e3e223d72..655ffbe8f 100644 --- a/matita/components/content_pres/Makefile +++ b/matita/components/content_pres/Makefile @@ -12,7 +12,6 @@ INTERFACE_FILES = \ boxPp.mli \ cicNotationPres.mli \ content2pres.mli \ - sequent2pres.mli \ $(NULL) IMPLEMENTATION_FILES = \ $(INTERFACE_FILES:%.mli=%.ml) diff --git a/matita/components/content_pres/boxPp.ml b/matita/components/content_pres/boxPp.ml index 295275ee3..80c669d45 100644 --- a/matita/components/content_pres/boxPp.ml +++ b/matita/components/content_pres/boxPp.ml @@ -51,6 +51,9 @@ let choose_rendering size (best, other) = 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 @@ -242,6 +245,8 @@ let render_to_strings ~map_unicode_to_tex choose_action size markup = 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) diff --git a/matita/components/content_pres/boxPp.mli b/matita/components/content_pres/boxPp.mli index 291c59a2a..c4d6fd53b 100644 --- a/matita/components/content_pres/boxPp.mli +++ b/matita/components/content_pres/boxPp.mli @@ -23,21 +23,15 @@ * 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 diff --git a/matita/components/content_pres/cicNotationParser.ml b/matita/components/content_pres/cicNotationParser.ml index f3953eb08..53c60820c 100644 --- a/matita/components/content_pres/cicNotationParser.ml +++ b/matita/components/content_pres/cicNotationParser.ml @@ -157,7 +157,7 @@ let extract_term_production status pattern = | 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 @@ -663,8 +663,10 @@ EXTEND 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 @@ -814,7 +816,7 @@ class type g_status = 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 @@ -824,6 +826,12 @@ class status ~keywords:kwds = = 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) = @@ -848,7 +856,7 @@ let extend (status : #status) (CL1P (level1_pattern,precedence)) 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 diff --git a/matita/components/content_pres/cicNotationParser.mli b/matita/components/content_pres/cicNotationParser.mli index d9e812f60..1ec1fd59c 100644 --- a/matita/components/content_pres/cicNotationParser.mli +++ b/matita/components/content_pres/cicNotationParser.mli @@ -33,8 +33,9 @@ class type g_status = 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 diff --git a/matita/components/content_pres/cicNotationPres.ml b/matita/components/content_pres/cicNotationPres.ml index d3465d30a..04440ffe7 100644 --- a/matita/components/content_pres/cicNotationPres.ml +++ b/matita/components/content_pres/cicNotationPres.ml @@ -200,7 +200,7 @@ let add_parens child_prec curr_prec t = 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 *) @@ -309,7 +309,7 @@ let render ~lookup_uri ?(prec=(-1)) = | 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 diff --git a/matita/components/content_pres/cicNotationPres.mli b/matita/components/content_pres/cicNotationPres.mli index a558da866..57e7ee844 100644 --- a/matita/components/content_pres/cicNotationPres.mli +++ b/matita/components/content_pres/cicNotationPres.mli @@ -39,6 +39,7 @@ val box_of_mpres: mathml_markup -> boxml_markup * @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 diff --git a/matita/components/content_pres/content2pres.ml b/matita/components/content_pres/content2pres.ml index 6d8031d85..6606b088b 100644 --- a/matita/components/content_pres/content2pres.ml +++ b/matita/components/content_pres/content2pres.ml @@ -46,6 +46,7 @@ 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 let rec split n l = if n = 0 then [],l @@ -149,8 +150,7 @@ let rec justification ~for_rewriting_step ~ignore_atoms term2pres p = )], 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 @@ -165,7 +165,7 @@ and proof2pres ?skip_initial_lambdas is_top_down term2pres p = | 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) @@ -173,7 +173,7 @@ and proof2pres ?skip_initial_lambdas is_top_down term2pres p = 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 @@ -182,11 +182,11 @@ and proof2pres ?skip_initial_lambdas is_top_down term2pres p = 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 @@ -207,7 +207,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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; @@ -221,30 +221,30 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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 @@ -267,7 +267,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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 ([], @@ -276,7 +276,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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 @@ -296,14 +296,14 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( [] -> 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 @@ -320,7 +320,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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 @@ -345,7 +345,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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" @@ -367,7 +367,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( ) @ 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], @@ -375,7 +375,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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 @@ -393,7 +393,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( ([], [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 @@ -416,7 +416,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( [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 @@ -429,21 +429,21 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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 = @@ -531,20 +531,20 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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???" @@ -571,9 +571,9 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( (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???" @@ -601,11 +601,11 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( (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 = @@ -666,7 +666,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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 @@ -675,7 +675,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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") @@ -683,7 +683,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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???" @@ -710,7 +710,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( | _ -> 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 @@ -746,10 +746,10 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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 ([], @@ -760,7 +760,7 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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 @@ -787,10 +787,10 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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 ([], @@ -799,13 +799,13 @@ let body = B.V([],[B.b_kw ("(*<<" ^ p.Con.proof_conclude.Con.conclude_method ^ ( 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 @@ -976,14 +976,14 @@ let njoint_def2pres term2pres joint_kind defs = (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 @@ -1020,15 +1020,75 @@ let ncontent2pres0 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) diff --git a/matita/components/content_pres/content2pres.mli b/matita/components/content_pres/content2pres.mli index 52ce9ad5a..ac5b67363 100644 --- a/matita/components/content_pres/content2pres.mli +++ b/matita/components/content_pres/content2pres.mli @@ -32,9 +32,22 @@ (* *) (**************************************************************************) -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 diff --git a/matita/components/content_pres/content2presMatcher.ml b/matita/components/content_pres/content2presMatcher.ml index 5316c92ee..8b613a524 100644 --- a/matita/components/content_pres/content2presMatcher.ml +++ b/matita/components/content_pres/content2presMatcher.ml @@ -67,8 +67,11 @@ struct | _ -> 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) diff --git a/matita/components/content_pres/sequent2pres.ml b/matita/components/content_pres/sequent2pres.ml deleted file mode 100644 index 53e8e19b4..000000000 --- a/matita/components/content_pres/sequent2pres.ml +++ /dev/null @@ -1,109 +0,0 @@ -(* 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 *) -(* 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))) diff --git a/matita/components/content_pres/sequent2pres.mli b/matita/components/content_pres/sequent2pres.mli deleted file mode 100644 index a81872159..000000000 --- a/matita/components/content_pres/sequent2pres.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* 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 *) -(* 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 diff --git a/matita/components/content_pres/termContentPres.ml b/matita/components/content_pres/termContentPres.ml index bdf07fb83..6846c30b5 100644 --- a/matita/components/content_pres/termContentPres.ml +++ b/matita/components/content_pres/termContentPres.ml @@ -109,7 +109,7 @@ let map_space f l = ~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 -> @@ -289,7 +289,7 @@ let pp_ast0 t k = 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 @@ -317,8 +317,9 @@ class type g_status = 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 >} @@ -459,7 +460,7 @@ let rec pp_ast1 status term = 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) -> @@ -476,7 +477,7 @@ let rec pp_ast1 status term = 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) @@ -494,7 +495,7 @@ let load_patterns21 status t = 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 @@ -573,7 +574,7 @@ let tail_names names env = 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 = @@ -666,7 +667,7 @@ let instantiate_level2 env term = | _ -> 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 *) diff --git a/matita/components/content_pres/termContentPres.mli b/matita/components/content_pres/termContentPres.mli index 69cb38b99..9c08650c2 100644 --- a/matita/components/content_pres/termContentPres.mli +++ b/matita/components/content_pres/termContentPres.mli @@ -32,8 +32,9 @@ class type g_status = 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 @@ -53,5 +54,4 @@ val pp_ast: #status -> NotationPt.term -> NotationPt.term (** fills a term pattern instantiating variable magics *) val instantiate_level2: - NotationEnv.t -> NotationPt.term -> - NotationPt.term + #NCic.status -> NotationEnv.t -> NotationPt.term -> NotationPt.term diff --git a/matita/components/grafite/grafiteAstPp.ml b/matita/components/grafite/grafiteAstPp.ml index c20a5d8c3..48fc8691c 100644 --- a/matita/components/grafite/grafiteAstPp.ml +++ b/matita/components/grafite/grafiteAstPp.ml @@ -32,62 +32,62 @@ let tactical_terminator = "" 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 _ -> ";" @@ -102,15 +102,15 @@ let rec pp_ntactic ~map_unicode_to_tex = (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 ;; @@ -153,22 +153,22 @@ let pp_dir_opt = function | 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 " ^ @@ -185,24 +185,24 @@ let pp_ncommand = function | 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 diff --git a/matita/components/grafite/grafiteAstPp.mli b/matita/components/grafite/grafiteAstPp.mli index a695b20d2..30972df7f 100644 --- a/matita/components/grafite/grafiteAstPp.mli +++ b/matita/components/grafite/grafiteAstPp.mli @@ -23,10 +23,13 @@ * 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 diff --git a/matita/components/grafite_engine/grafiteEngine.ml b/matita/components/grafite_engine/grafiteEngine.ml index 4ccf56653..7febf874e 100644 --- a/matita/components/grafite_engine/grafiteEngine.ml +++ b/matita/components/grafite_engine/grafiteEngine.ml @@ -44,7 +44,8 @@ let inject_unification_hint = ~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 @@ -56,7 +57,7 @@ let eval_unification_hint status t n = 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)) ;; @@ -132,7 +133,7 @@ let basic_eval_input_notation (l1,l2) status = 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 = @@ -143,9 +144,11 @@ 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 @@ -172,9 +175,11 @@ let inject_output_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_output_notation (l1,l2) status else @@ -193,6 +198,7 @@ let record_index_obj = 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 @@ -248,15 +254,15 @@ let compute_keys status uri height kind = 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 @@ -271,8 +277,8 @@ let index_obj_for_auto status (uri, height, _, _, kind) = 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 = @@ -407,39 +413,39 @@ let subst_metasenv_and_fix_names status = 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 @@ -451,13 +457,13 @@ let compute_relevance uri = 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 @@ -483,7 +489,7 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = 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 @@ -496,8 +502,8 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = 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 -> @@ -508,7 +514,7 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = | 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 @@ -516,7 +522,7 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = 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 @@ -538,14 +544,14 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = 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 = @@ -617,7 +623,7 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = 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); @@ -634,7 +640,7 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = 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 @@ -649,13 +655,13 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = (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 @@ -706,14 +712,14 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = (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 @@ -721,9 +727,9 @@ let rec eval_ncommand ~include_paths opts status (text,prefix_len,cmd) = 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 diff --git a/matita/components/grafite_engine/grafiteTypes.ml b/matita/components/grafite_engine/grafiteTypes.ml index 06cf9b968..7cb6bef0c 100644 --- a/matita/components/grafite_engine/grafiteTypes.ml +++ b/matita/components/grafite_engine/grafiteTypes.ml @@ -31,7 +31,7 @@ exception Command_error of string 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)) diff --git a/matita/components/grafite_engine/grafiteTypes.mli b/matita/components/grafite_engine/grafiteTypes.mli index 4e226f703..92d4cc2aa 100644 --- a/matita/components/grafite_engine/grafiteTypes.mli +++ b/matita/components/grafite_engine/grafiteTypes.mli @@ -31,7 +31,7 @@ exception Command_error of string 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 *) diff --git a/matita/components/grafite_engine/nCicCoercDeclaration.ml b/matita/components/grafite_engine/nCicCoercDeclaration.ml index e204422e3..f1b051d46 100644 --- a/matita/components/grafite_engine/nCicCoercDeclaration.ml +++ b/matita/components/grafite_engine/nCicCoercDeclaration.ml @@ -54,7 +54,7 @@ let rec cleanup_funclass_skel = function | _ -> 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 @@ -72,7 +72,7 @@ let src_tgt_of_ty_cpos_arity ty cpos arity = | 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 @@ -80,17 +80,17 @@ let src_tgt_of_ty_cpos_arity ty cpos arity = 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 @@ -100,20 +100,20 @@ let close_in_context t metasenv = 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 ;; @@ -134,10 +134,10 @@ let src_tgt_cpos_arity_of_ty_id_src_tgt status ty id src tgt = 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 _ @@ -152,7 +152,7 @@ let src_tgt_cpos_arity_of_ty_id_src_tgt status ty id src tgt = 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 @@ -161,7 +161,7 @@ let src_tgt_cpos_arity_of_ty_id_src_tgt status ty id src tgt = 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 @@ -217,32 +217,32 @@ let close_graph name t s d to_s from_d p a status = 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 @@ -292,11 +292,11 @@ let record_ncoercion = ~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 = @@ -307,8 +307,8 @@ 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 @@ -319,11 +319,11 @@ let eval_ncoercion (status: #GrafiteTypes.status) name t ty (id,src) tgt = 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 = diff --git a/matita/components/grafite_parser/grafiteParser.ml b/matita/components/grafite_parser/grafiteParser.ml index 9b5ecfe7c..492274f97 100644 --- a/matita/components/grafite_parser/grafiteParser.ml +++ b/matita/components/grafite_parser/grafiteParser.ml @@ -166,7 +166,10 @@ EXTEND | 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 @@ -636,10 +639,10 @@ class type g_status = 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 diff --git a/matita/components/grafite_parser/grafiteParser.mli b/matita/components/grafite_parser/grafiteParser.mli index ec5cdbb21..aa0fb5bde 100644 --- a/matita/components/grafite_parser/grafiteParser.mli +++ b/matita/components/grafite_parser/grafiteParser.mli @@ -31,7 +31,7 @@ class type g_status = method parser_db: db end -class status : +class virtual status : object('self) inherit g_status inherit CicNotationParser.status diff --git a/matita/components/ng_cic_content/interpretations.ml b/matita/components/ng_cic_content/interpretations.ml index 0c78e08f9..ee4bb9437 100644 --- a/matita/components/ng_cic_content/interpretations.ml +++ b/matita/components/ng_cic_content/interpretations.ml @@ -58,12 +58,12 @@ type db = { 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 = @@ -72,15 +72,17 @@ 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 = @@ -144,7 +146,7 @@ let load_patterns32 status t = 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 = @@ -237,15 +239,15 @@ let nast_of_cic0 status 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)::_) -> @@ -272,9 +274,9 @@ let nast_of_cic0 status 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))) @@ -315,7 +317,7 @@ let nast_of_cic0 status 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 @@ -388,11 +390,12 @@ let rec nast_of_cic1 status ~idref ~output_type ~metasenv ~subst ~context term = 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 @@ -418,17 +421,15 @@ let nmap_sequent0 status ~idref ~metasenv ~subst (i,(n,context,ty)) = 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:";; @@ -501,11 +502,8 @@ let build_decl_item seed id n s = } ;; -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 @@ -550,38 +548,52 @@ let build_fixpoint b seed = 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 diff --git a/matita/components/ng_cic_content/interpretations.mli b/matita/components/ng_cic_content/interpretations.mli index 2bf18caa6..71732cc7d 100644 --- a/matita/components/ng_cic_content/interpretations.mli +++ b/matita/components/ng_cic_content/interpretations.mli @@ -36,7 +36,7 @@ class type g_status = method interp_db: db end -class status : +class virtual status : object ('self) inherit g_status inherit NCicCoercion.status @@ -75,6 +75,20 @@ val instantiate_appl_pattern: (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 -> diff --git a/matita/components/ng_cic_content/ncic2astMatcher.ml b/matita/components/ng_cic_content/ncic2astMatcher.ml index f6617451d..4f65e9c03 100644 --- a/matita/components/ng_cic_content/ncic2astMatcher.ml +++ b/matita/components/ng_cic_content/ncic2astMatcher.ml @@ -59,10 +59,10 @@ struct 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 @@ -73,7 +73,7 @@ struct 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) _ -> @@ -93,7 +93,7 @@ struct | (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 diff --git a/matita/components/ng_cic_content/ncic2astMatcher.mli b/matita/components/ng_cic_content/ncic2astMatcher.mli index 5d1e2c571..47721cf4e 100644 --- a/matita/components/ng_cic_content/ncic2astMatcher.mli +++ b/matita/components/ng_cic_content/ncic2astMatcher.mli @@ -27,6 +27,7 @@ module Matcher32: 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) diff --git a/matita/components/ng_disambiguation/grafiteDisambiguate.ml b/matita/components/ng_disambiguation/grafiteDisambiguate.ml index 490780fbe..dbdd21313 100644 --- a/matita/components/ng_disambiguation/grafiteDisambiguate.ml +++ b/matita/components/ng_disambiguation/grafiteDisambiguate.ml @@ -43,7 +43,7 @@ class type g_status = method disambiguate_db: db end -class status = +class virtual status = object (self) inherit Interpretations.status val disambiguate_db = initial_status @@ -171,26 +171,26 @@ let fix_instance item l = ;; -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 ;; @@ -198,17 +198,15 @@ type pattern = 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 @@ -243,7 +241,7 @@ let disambiguate_just disambiguate_term context metasenv = 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 @@ -260,20 +258,19 @@ let disambiguate_nobj estatus ?baseuri (text,prefix_len,obj) = 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 = @@ -310,14 +307,14 @@ 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) diff --git a/matita/components/ng_disambiguation/grafiteDisambiguate.mli b/matita/components/ng_disambiguation/grafiteDisambiguate.mli index f19ea836a..1f5553e91 100644 --- a/matita/components/ng_disambiguation/grafiteDisambiguate.mli +++ b/matita/components/ng_disambiguation/grafiteDisambiguate.mli @@ -31,7 +31,7 @@ class type g_status = method disambiguate_db: db end -class status : +class virtual status : object ('self) inherit g_status inherit Interpretations.status @@ -50,7 +50,8 @@ val set_proof_aliases: (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 @@ -73,7 +74,7 @@ type pattern = (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 -> diff --git a/matita/components/ng_disambiguation/nCicDisambiguate.ml b/matita/components/ng_disambiguation/nCicDisambiguate.ml index be5aacb93..5c2de5caa 100644 --- a/matita/components/ng_disambiguation/nCicDisambiguate.ml +++ b/matita/components/ng_disambiguation/nCicDisambiguate.ml @@ -32,39 +32,39 @@ let rec mk_rels howmany from = | _ -> (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=[]); @@ -76,8 +76,8 @@ let refine_obj 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 @@ -85,11 +85,11 @@ let refine_obj 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 ;; @@ -103,9 +103,9 @@ let find_in_context name context = 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); @@ -185,7 +185,7 @@ let interpretate_term_and_interpretate_term_option | 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 = @@ -207,7 +207,7 @@ let interpretate_term_and_interpretate_term_option (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 @@ -216,16 +216,16 @@ let interpretate_term_and_interpretate_term_option 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 @@ -373,31 +373,32 @@ let interpretate_term_and_interpretate_term_option (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 @@ -408,7 +409,7 @@ let ncic_name_of_ident = function | _ -> assert false ;; -let interpretate_obj +let interpretate_obj status (* ?(create_dummy_ids=false) *) ~context ~env ~uri ~is_path obj ~localization_tbl ~mk_choice = @@ -422,7 +423,7 @@ let interpretate_obj 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 @@ -457,12 +458,12 @@ let interpretate_obj 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) @@ -474,7 +475,7 @@ let interpretate_obj 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 @@ -490,7 +491,7 @@ let interpretate_obj | 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 @@ -515,14 +516,14 @@ let interpretate_obj (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' @@ -546,7 +547,7 @@ let interpretate_obj | 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 @@ -558,7 +559,7 @@ let interpretate_obj 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 @@ -568,7 +569,7 @@ let interpretate_obj 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 @@ -591,11 +592,10 @@ let interpretate_obj 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 @@ -603,20 +603,19 @@ let disambiguate_term ~context ~metasenv ~subst ~expty ~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 = @@ -627,11 +626,11 @@ let disambiguate_obj ~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 diff --git a/matita/components/ng_disambiguation/nCicDisambiguate.mli b/matita/components/ng_disambiguation/nCicDisambiguate.mli index d2ae7f566..715be6a85 100644 --- a/matita/components/ng_disambiguation/nCicDisambiguate.mli +++ b/matita/components/ng_disambiguation/nCicDisambiguate.mli @@ -12,6 +12,7 @@ (* $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 -> @@ -22,7 +23,6 @@ val disambiguate_term : 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 -> @@ -36,13 +36,13 @@ val disambiguate_term : 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 -> @@ -54,5 +54,4 @@ val disambiguate_obj : NCic.substitution * NCic.obj) list * bool -val disambiguate_path: NotationPt.term -> NCic.term - +val disambiguate_path: #NCic.status -> NotationPt.term -> NCic.term diff --git a/matita/components/ng_kernel/.depend b/matita/components/ng_kernel/.depend index 9a4ae3fc1..7217cb552 100644 --- a/matita/components/ng_kernel/.depend +++ b/matita/components/ng_kernel/.depend @@ -3,8 +3,8 @@ nReference.cmi: nUri.cmi 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 @@ -21,20 +21,20 @@ nCicSubstitution.cmx: nReference.cmx nCicUtils.cmx nCic.cmx \ 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 \ diff --git a/matita/components/ng_kernel/.depend.opt b/matita/components/ng_kernel/.depend.opt index d7c542af5..ab14e0fad 100644 --- a/matita/components/ng_kernel/.depend.opt +++ b/matita/components/ng_kernel/.depend.opt @@ -3,8 +3,8 @@ nReference.cmi: nUri.cmi 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 @@ -21,20 +21,20 @@ nCicSubstitution.cmx: nReference.cmx nCicUtils.cmx nCic.cmx \ 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 \ diff --git a/matita/components/ng_kernel/Makefile b/matita/components/ng_kernel/Makefile index 3cacb50d1..35b89f3b1 100644 --- a/matita/components/ng_kernel/Makefile +++ b/matita/components/ng_kernel/Makefile @@ -7,10 +7,10 @@ INTERFACE_FILES = \ 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) diff --git a/matita/components/ng_kernel/nCic.ml b/matita/components/ng_kernel/nCic.ml index fa204588d..7e4e4f855 100644 --- a/matita/components/ng_kernel/nCic.ml +++ b/matita/components/ng_kernel/nCic.ml @@ -119,3 +119,38 @@ type obj_kind = (* 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 diff --git a/matita/components/ng_kernel/nCicEnvironment.ml b/matita/components/ng_kernel/nCicEnvironment.ml index c5c692733..c7389f167 100644 --- a/matita/components/ng_kernel/nCicEnvironment.ml +++ b/matita/components/ng_kernel/nCicEnvironment.ml @@ -24,8 +24,8 @@ let cache = NUri.UriHash.create 313;; 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 @@ -243,7 +243,7 @@ let allowed_sort_elimination s1 s2 = | 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 @@ -301,12 +301,12 @@ let to_exn f x = | `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'; @@ -339,27 +339,27 @@ let check_and_add_obj ((u,_,_,_,_) as 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 _,_,_) -> @@ -368,9 +368,9 @@ let get_checked_decl = function | _ -> 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,_,_) -> @@ -379,40 +379,40 @@ let get_checked_def = function | _ -> 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 ;; diff --git a/matita/components/ng_kernel/nCicEnvironment.mli b/matita/components/ng_kernel/nCicEnvironment.mli index 8483b8a1f..80fcd2b68 100644 --- a/matita/components/ng_kernel/nCicEnvironment.mli +++ b/matita/components/ng_kernel/nCicEnvironment.mli @@ -16,25 +16,25 @@ exception ObjectNotFound of string Lazy.t;; 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: @@ -43,7 +43,7 @@ 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 ============= *) diff --git a/matita/components/ng_kernel/nCicPp.ml b/matita/components/ng_kernel/nCicPp.ml index 523b3d4e1..0d78c4971 100644 --- a/matita/components/ng_kernel/nCicPp.ml +++ b/matita/components/ng_kernel/nCicPp.ml @@ -15,32 +15,26 @@ module C = NCic 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 @@ -63,7 +57,7 @@ let string_of_implicit_annotation = function | `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 @@ -71,7 +65,7 @@ let ppterm ~formatter:f ~context ~subst ~metasenv:_ ?(inside_fix=false) t = 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 "@["; @@ -120,14 +114,14 @@ let ppterm ~formatter:f ~context ~subst ~metasenv:_ ?(inside_fix=false) t = if pl <> [] then begin F.fprintf f "@[%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 "@;| @[%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 "@]"; @@ -145,9 +139,9 @@ let ppterm ~formatter:f ~context ~subst ~metasenv:_ ?(inside_fix=false) t = 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))) @@ -162,16 +156,16 @@ let ppterm ~formatter:f ~context ~subst ~metasenv:_ ?(inside_fix=false) t = 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 @@ -195,24 +189,24 @@ let ppterm ~formatter ~context ~subst ~metasenv ?(margin=80) ?inside_fix t = 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 "@["; - ppcontext ~formatter ?sep ~subst ~metasenv c; + ppcontext status ~formatter ?sep ~subst ~metasenv c; F.fprintf formatter "@]"; ;; @@ -234,36 +228,36 @@ let ppmetaattrs = ")" ;; -let rec ppmetasenv ~formatter ~subst metasenv = function +let rec ppmetasenv status ~formatter ~subst metasenv = function | [] -> () | (i,(attrs, ctx, ty)) :: tl -> F.fprintf formatter "@["; - 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 @@ -296,9 +290,9 @@ let string_of_fattrs (g,f,p) = [ 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 "..."; @@ -311,9 +305,9 @@ let ppobj ~formatter (u,_,metasenv, subst, o) = ~sep:(fun () -> F.fprintf formatter "@\n@[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 "@]@;@[:=@;"; - 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 "@]" @@ -325,42 +319,52 @@ let ppobj ~formatter (u,_,metasenv, subst, o) = ~sep:(fun () -> F.fprintf formatter "@\n@[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 "@]@;@[:=@;"; 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@[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@[@[definition %s :@;" (NUri.string_of_uri u) name; - ppterm ~formatter ~metasenv ~subst ~context:[] ty; + ppterm status ~formatter ~metasenv ~subst ~context:[] ty; F.fprintf formatter "@]@;@[:=@;"; - 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 diff --git a/matita/components/ng_kernel/nCicPp.mli b/matita/components/ng_kernel/nCicPp.mli index 39fe4f2f6..02b6c8642 100644 --- a/matita/components/ng_kernel/nCicPp.mli +++ b/matita/components/ng_kernel/nCicPp.mli @@ -11,34 +11,13 @@ (* $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 diff --git a/matita/components/ng_kernel/nCicReduction.ml b/matita/components/ng_kernel/nCicReduction.ml index 236f5778e..8a84810a3 100644 --- a/matita/components/ng_kernel/nCicReduction.ml +++ b/matita/components/ng_kernel/nCicReduction.ml @@ -83,15 +83,15 @@ module Reduction(RS : Strategy) = struct 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;; @@ -102,7 +102,7 @@ module Reduction(RS : Strategy) = struct | _,_ -> 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 @@ -110,27 +110,27 @@ module Reduction(RS : Strategy) = struct | 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 @@ -138,7 +138,7 @@ module Reduction(RS : Strategy) = struct 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 -> @@ -150,7 +150,7 @@ module Reduction(RS : Strategy) = struct 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 -> @@ -165,8 +165,8 @@ module Reduction(RS : Strategy) = struct | (_,_,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) @@ -174,14 +174,14 @@ module Reduction(RS : Strategy) = struct 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) @@ -193,8 +193,8 @@ module Reduction(RS : Strategy) = struct 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 @@ -208,11 +208,12 @@ let whd = R.whd 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 @@ -242,33 +243,33 @@ let alpha_eq ~test_lambda_source aux test_eq_only metasenv subst context t1 t2 = 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)) -> @@ -284,7 +285,7 @@ let alpha_eq ~test_lambda_source aux test_eq_only metasenv subst context t1 t2 = 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 @@ -301,7 +302,7 @@ let alpha_eq ~test_lambda_source aux test_eq_only metasenv subst context t1 t2 = | (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) @@ -310,10 +311,10 @@ let alpha_eq ~test_lambda_source aux test_eq_only metasenv subst 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 @@ -334,12 +335,13 @@ let alpha_eq ~test_lambda_source aux test_eq_only metasenv subst context t1 t2 = ;; (* 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 @@ -350,32 +352,32 @@ let are_convertible ~metasenv ~subst = | _ -> 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 @@ -392,14 +394,14 @@ let are_convertible ~metasenv ~subst = 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 @@ -407,23 +409,23 @@ let rec head_beta_reduce ~delta ~upto ~subst t l = | _, 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 @@ -437,17 +439,17 @@ let from_env = RS.from_env 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")) ;; diff --git a/matita/components/ng_kernel/nCicReduction.mli b/matita/components/ng_kernel/nCicReduction.mli index 35159fc1c..f53cb5dc8 100644 --- a/matita/components/ng_kernel/nCicReduction.mli +++ b/matita/components/ng_kernel/nCicReduction.mli @@ -16,16 +16,15 @@ exception AssertFailure of string Lazy.t;; 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 @@ -33,7 +32,8 @@ val are_convertible : 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 @@ -41,17 +41,17 @@ 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 diff --git a/matita/components/ng_kernel/nCicSubstitution.ml b/matita/components/ng_kernel/nCicSubstitution.ml index d3e6756d8..0ca566cc3 100644 --- a/matita/components/ng_kernel/nCicSubstitution.ml +++ b/matita/components/ng_kernel/nCicSubstitution.ml @@ -11,18 +11,12 @@ (* $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)) @@ -34,13 +28,13 @@ let lift_from ?(no_implicit=true) k n = | 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 ;; @@ -51,7 +45,7 @@ let lift ?(from=1) ?(no_implicit=true) 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 -> @@ -60,7 +54,7 @@ let rec psubst ?(avoid_beta_redexes=false) ?(no_implicit=true) map_arg args = 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 @@ -69,7 +63,7 @@ let rec psubst ?(avoid_beta_redexes=false) ?(no_implicit=true) map_arg args = 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 @@ -83,27 +77,27 @@ let rec psubst ?(avoid_beta_redexes=false) ?(no_implicit=true) map_arg args = | 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 ;; diff --git a/matita/components/ng_kernel/nCicSubstitution.mli b/matita/components/ng_kernel/nCicSubstitution.mli index 7e27a5d4c..9ba2d11fa 100644 --- a/matita/components/ng_kernel/nCicSubstitution.mli +++ b/matita/components/ng_kernel/nCicSubstitution.mli @@ -11,20 +11,14 @@ (* $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] *) @@ -32,7 +26,7 @@ val lift : ?from:int -> ?no_implicit:bool -> int -> NCic.term -> NCic.term (* 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] @@ -43,7 +37,7 @@ val subst : * 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 @@ -51,5 +45,5 @@ val psubst : (* 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 diff --git a/matita/components/ng_kernel/nCicTypeChecker.ml b/matita/components/ng_kernel/nCicTypeChecker.ml index 4a89e9d12..0a73358e0 100644 --- a/matita/components/ng_kernel/nCicTypeChecker.ml +++ b/matita/components/ng_kernel/nCicTypeChecker.ml @@ -17,7 +17,6 @@ module R = NCicReduction module S = NCicSubstitution module U = NCicUtils module E = NCicEnvironment -module PP = NCicPp exception TypeCheckerFailure of string Lazy.t exception AssertFailure of string Lazy.t @@ -61,7 +60,7 @@ let shift_k e (c,rf,x) = e::c,List.map (fun (k,v) -> k+1,v) rf,x+1;; (* 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) ^ @@ -96,14 +95,14 @@ let fixed_args bos j n nn = (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 _ -> @@ -115,14 +114,14 @@ let debruijn uri number_of_types ~subst context = | 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) -> @@ -139,49 +138,49 @@ let sort_of_prod ~metasenv ~subst context (name,s) t (t1, t2) = 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 -> () @@ -196,7 +195,7 @@ let does_not_occur ~subst context n nn t = (* 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*)) @@ -206,41 +205,41 @@ let does_not_occur ~subst context n nn t = 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 @@ -251,7 +250,7 @@ let check_homogeneous_call ~subst context indparamsno n uri reduct tl = (* 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? *) @@ -265,75 +264,75 @@ let rec weakly_positive ~subst context n nn uri indparamsno posuri te = 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 @@ -342,16 +341,16 @@ and are_all_occurrences_positive ~subst context uri indparamsno i n nn te = (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 @@ -361,40 +360,40 @@ and are_all_occurrences_positive ~subst context uri indparamsno i n nn te = 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 @@ -410,57 +409,57 @@ let rec typeof ~subst ~metasenv context term = (* 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',[] @@ -469,27 +468,27 @@ let rec typeof ~subst ~metasenv context term = 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 @@ -506,9 +505,9 @@ let rec typeof ~subst ~metasenv context term = 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 @@ -519,13 +518,13 @@ let rec typeof ~subst ~metasenv context term = (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 @@ -543,31 +542,31 @@ let rec typeof ~subst ~metasenv context term = | _,_,[] -> 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) @@ -578,10 +577,10 @@ let rec typeof ~subst ~metasenv context term = 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 @@ -599,73 +598,73 @@ let rec typeof ~subst ~metasenv context term = | 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 @@ -675,46 +674,46 @@ and check_allowed_sort_elimination ~subst ~metasenv r = (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 @@ -723,50 +722,50 @@ and eat_prods ~subst ~metasenv context he ty_he args_with_ty = 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,_ = @@ -777,10 +776,10 @@ and check_mutual_inductive_defs uri ~metasenv ~subst leftno tyl = 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 @@ -791,15 +790,15 @@ and check_mutual_inductive_defs uri ~metasenv ~subst leftno tyl = 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 _ -> () | _, _ -> @@ -809,31 +808,31 @@ and check_mutual_inductive_defs uri ~metasenv ~subst leftno tyl = (* 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 @@ -843,41 +842,41 @@ and check_relevance ~subst ~metasenv context relevance ty = | 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 @@ -886,17 +885,17 @@ and guarded_by_destructors r_uri r_len ~subst ~metasenv context recfuns t = | 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 ... *) @@ -913,18 +912,18 @@ and guarded_by_destructors r_uri r_len ~subst ~metasenv context recfuns t = 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 @@ -938,34 +937,34 @@ and guarded_by_destructors r_uri r_len ~subst ~metasenv context recfuns t = 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 _ @@ -974,21 +973,21 @@ and guarded_by_constructors ~subst ~metasenv context t indURI indlen nn = | 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 -> @@ -996,16 +995,16 @@ and guarded_by_constructors ~subst ~metasenv context t indURI indlen nn = | _,[] -> 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. @@ -1016,81 +1015,81 @@ and guarded_by_constructors ~subst ~metasenv context t indURI indlen nn = 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 @@ -1115,33 +1114,33 @@ and type_of_constant ((Ref.Ref (uri,_)) as ref) = (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 @@ -1150,42 +1149,42 @@ and get_relevance ~metasenv ~subst context t args = 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) -> @@ -1195,25 +1194,25 @@ let typecheck_subst ~metasenv subst = 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 @@ -1233,54 +1232,54 @@ let height_of_term tl = 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 @@ -1288,25 +1287,25 @@ let typecheck_obj (uri,height,metasenv,subst,kind) = 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 @@ -1316,17 +1315,17 @@ let typecheck_obj (uri,height,metasenv,subst,kind) = 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")) @@ -1348,11 +1347,11 @@ let logger = 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 -> @@ -1364,17 +1363,16 @@ let typecheck_obj obj = ;; 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 = diff --git a/matita/components/ng_kernel/nCicTypeChecker.mli b/matita/components/ng_kernel/nCicTypeChecker.mli index a0c927284..6ca329fbf 100644 --- a/matita/components/ng_kernel/nCicTypeChecker.mli +++ b/matita/components/ng_kernel/nCicTypeChecker.mli @@ -26,19 +26,21 @@ val set_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 @@ -47,6 +49,7 @@ val type_of_branch : * arity1 = constructor type @ lefts * arity2 = outtype *) val check_allowed_sort_elimination : + #NCic.status -> subst:NCic.substitution -> metasenv:NCic.metasenv -> NReference.reference -> NCic.context -> @@ -54,11 +57,13 @@ val check_allowed_sort_elimination : (* 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 diff --git a/matita/components/ng_kernel/nCicUntrusted.ml b/matita/components/ng_kernel/nCicUntrusted.ml index 82f7cef80..bd5055874 100644 --- a/matita/components/ng_kernel/nCicUntrusted.ml +++ b/matita/components/ng_kernel/nCicUntrusted.ml @@ -14,7 +14,7 @@ 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 _ @@ -32,7 +32,7 @@ let map_term_fold_a g k f a = function | 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 @@ -51,7 +51,7 @@ let map_term_fold_a g k f a = function 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 @@ -60,12 +60,12 @@ let metas_of_term subst context term = | 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 @@ -118,7 +118,7 @@ let map_obj_kind ?(skip_body=false) f = 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 _ -> () @@ -155,20 +155,20 @@ let clean_or_fix_dependent_abstrations ctx t = | 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 *) @@ -179,32 +179,33 @@ let rec fire_projection_redex on_args = function | 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 -> @@ -214,15 +215,15 @@ let apply_subst ?(fix_projections=false) subst context t = 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 -> @@ -234,17 +235,17 @@ let apply_subst_context ~fix_projections subst context = 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 ] @@ -290,30 +291,30 @@ module OT = 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 @@ -325,7 +326,7 @@ let count_occurrences ~subst n t = (* 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*)) diff --git a/matita/components/ng_kernel/nCicUntrusted.mli b/matita/components/ng_kernel/nCicUntrusted.mli index 7ff7f9335..7967936e3 100644 --- a/matita/components/ng_kernel/nCicUntrusted.mli +++ b/matita/components/ng_kernel/nCicUntrusted.mli @@ -12,14 +12,17 @@ (* $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 @@ -36,12 +39,15 @@ module NCicHash : Hashtbl.S with type key = NCic.term 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 diff --git a/matita/components/ng_kernel/nCicUtils.ml b/matita/components/ng_kernel/nCicUtils.ml index a99ae0407..f22e02a7e 100644 --- a/matita/components/ng_kernel/nCicUtils.ml +++ b/matita/components/ng_kernel/nCicUtils.ml @@ -17,7 +17,7 @@ module Ref = NReference 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 @@ -56,7 +56,7 @@ let fold g k f acc = 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 _ @@ -74,7 +74,7 @@ let map g k f = function | 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 diff --git a/matita/components/ng_kernel/nCicUtils.mli b/matita/components/ng_kernel/nCicUtils.mli index 6baaeda03..6697e31b5 100644 --- a/matita/components/ng_kernel/nCicUtils.mli +++ b/matita/components/ng_kernel/nCicUtils.mli @@ -25,8 +25,9 @@ val fold: (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 diff --git a/matita/components/ng_library/nCicLibrary.ml b/matita/components/ng_library/nCicLibrary.ml index cbc9c17b8..87f0cb31b 100644 --- a/matita/components/ng_library/nCicLibrary.ml +++ b/matita/components/ng_library/nCicLibrary.ml @@ -25,27 +25,30 @@ let refresh_uri_in_universe = 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 = @@ -141,22 +144,24 @@ let load_db,set_global_aliases,get_global_aliases,add_deps,get_deps,remove_deps= 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 = @@ -192,7 +197,7 @@ module type SerializerType = 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 @@ -211,7 +216,7 @@ module Serializer(D: sig type dumpable_s val get: dumpable_s -> 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 @@ -251,7 +256,7 @@ module Serializer(D: sig type dumpable_s val get: dumpable_s -> 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 @@ -303,9 +308,9 @@ module Serializer(D: sig type dumpable_s val get: dumpable_s -> dumpable_status 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 = @@ -324,7 +329,7 @@ let aliases_of uri = ;; 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 = @@ -371,17 +376,16 @@ let add_constraint status u1 u2 = 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;; diff --git a/matita/components/ng_library/nCicLibrary.mli b/matita/components/ng_library/nCicLibrary.mli index c65ee1df1..63bd7518a 100644 --- a/matita/components/ng_library/nCicLibrary.mli +++ b/matita/components/ng_library/nCicLibrary.mli @@ -16,8 +16,9 @@ exception IncludedFileNotCompiled of string * string type timestamp -class status : +class virtual status : object ('self) + inherit NCic.status method timestamp: timestamp method set_timestamp: timestamp -> 'self end @@ -29,7 +30,7 @@ val add_constraint: 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 @@ -60,7 +61,7 @@ module type SerializerType = 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 diff --git a/matita/components/ng_paramodulation/nCicBlob.ml b/matita/components/ng_paramodulation/nCicBlob.ml index e141272af..b9314a203 100644 --- a/matita/components/ng_paramodulation/nCicBlob.ml +++ b/matita/components/ng_paramodulation/nCicBlob.ml @@ -79,7 +79,8 @@ with type t = NCic.term and type input = NCic.term = struct ;; 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 ;; @@ -97,7 +98,9 @@ with type t = NCic.term and type input = NCic.term = struct | _ -> 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 @@ -118,8 +121,9 @@ with type t = NCic.term and type input = NCic.term = struct 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 diff --git a/matita/components/ng_paramodulation/nCicParamod.ml b/matita/components/ng_paramodulation/nCicParamod.ml index ef9852fcc..6e91b9028 100644 --- a/matita/components/ng_paramodulation/nCicParamod.ml +++ b/matita/components/ng_paramodulation/nCicParamod.ml @@ -26,14 +26,14 @@ module B(C : NCicBlob.NCicContext): Orderings.Blob 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))); *) (* @@ -50,12 +50,12 @@ let readback ?(demod=false) rdb metasenv subst context (bag,i,fo_subst,l) = 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" @@ -63,7 +63,7 @@ let readback ?(demod=false) rdb metasenv subst context (bag,i,fo_subst,l) = *) 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 @@ -87,7 +87,7 @@ let nparamod rdb metasenv subst context t table = 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 = @@ -111,8 +111,8 @@ let forward_infer_step s t ty = 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 @@ -125,17 +125,17 @@ let index_obj s uri = | _ -> 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 @@ -143,22 +143,22 @@ let paramod rdb metasenv subst context s goal = | 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 @@ -166,13 +166,13 @@ let is_equation metasenv subst context ty = ;; (* -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 ;; *) diff --git a/matita/components/ng_paramodulation/nCicParamod.mli b/matita/components/ng_paramodulation/nCicParamod.mli index 86a104073..36c5a7cab 100644 --- a/matita/components/ng_paramodulation/nCicParamod.mli +++ b/matita/components/ng_paramodulation/nCicParamod.mli @@ -20,9 +20,10 @@ val nparamod : 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 -> diff --git a/matita/components/ng_paramodulation/nCicProof.ml b/matita/components/ng_paramodulation/nCicProof.ml index f9b60ba26..cabca8259 100644 --- a/matita/components/ng_paramodulation/nCicProof.ml +++ b/matita/components/ng_paramodulation/nCicProof.ml @@ -48,7 +48,7 @@ let debug c _ = c;; 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 @@ -56,7 +56,7 @@ let debug c _ = c;; 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) @@ -65,7 +65,7 @@ let debug c _ = c;; ;; - 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 @@ -89,7 +89,7 @@ let debug c _ = c;; 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 @@ -162,7 +162,7 @@ let debug c _ = c;; | _ -> 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 @@ -181,18 +181,18 @@ let debug c _ = c;; 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 @@ -236,7 +236,7 @@ let debug c _ = c;; 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 = @@ -264,14 +264,14 @@ let debug c _ = c;; 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 @@ -284,14 +284,14 @@ let debug c _ = c;; (* 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) -> @@ -307,7 +307,7 @@ let debug c _ = c;; 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) @@ -324,9 +324,9 @@ let debug c _ = c;; 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 :"; @@ -350,9 +350,9 @@ let debug c _ = c;; 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 (* @@ -367,7 +367,7 @@ let debug c _ = c;; 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 @@ -383,14 +383,15 @@ let debug c _ = c;; 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 diff --git a/matita/components/ng_paramodulation/nCicProof.mli b/matita/components/ng_paramodulation/nCicProof.mli index f1e1e3b32..5baa10535 100644 --- a/matita/components/ng_paramodulation/nCicProof.mli +++ b/matita/components/ng_paramodulation/nCicProof.mli @@ -17,6 +17,7 @@ val set_default_sig: unit -> unit val get_sig: eq_sig_type -> NCic.term val mk_proof: + #NCic.status -> ?demod:bool -> NCic.term Terms.bag -> Terms.M.key diff --git a/matita/components/ng_refiner/nCicCoercion.ml b/matita/components/ng_refiner/nCicCoercion.ml index 3b6da0af5..cfb9d1b6b 100644 --- a/matita/components/ng_refiner/nCicCoercion.ml +++ b/matita/components/ng_refiner/nCicCoercion.ml @@ -39,7 +39,7 @@ class type g_status = method coerc_db: db end -class status = +class virtual status = object inherit NCicUnifHint.status val db = empty_db @@ -50,13 +50,13 @@ class status = = 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 @@ -66,16 +66,16 @@ let index_coercion status name c src tgt arity arg = 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 @@ -95,36 +95,36 @@ let look_for_coercion status metasenv subst context infty expty = 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)); @@ -150,9 +150,9 @@ let match_coercion status ~metasenv ~subst ~context t = | _,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 @@ -163,7 +163,7 @@ let match_coercion status ~metasenv ~subst ~context t = ) 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 @@ -171,7 +171,7 @@ let generate_dot_file status fmt = 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 @@ -203,7 +203,7 @@ let generate_dot_file status fmt = 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) diff --git a/matita/components/ng_refiner/nCicCoercion.mli b/matita/components/ng_refiner/nCicCoercion.mli index 8ea0107de..4f1fa4186 100644 --- a/matita/components/ng_refiner/nCicCoercion.mli +++ b/matita/components/ng_refiner/nCicCoercion.mli @@ -19,7 +19,7 @@ class type g_status = method coerc_db: db end -class status : +class virtual status : object ('self) inherit g_status inherit NCicUnifHint.status diff --git a/matita/components/ng_refiner/nCicMetaSubst.ml b/matita/components/ng_refiner/nCicMetaSubst.ml index b18364509..03f4affdf 100644 --- a/matita/components/ng_refiner/nCicMetaSubst.ml +++ b/matita/components/ng_refiner/nCicMetaSubst.ml @@ -117,7 +117,7 @@ let purge_restricted restrictions more_restrictions l = 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 -> @@ -128,21 +128,21 @@ let rec force_does_not_occur metasenv subst restrictions t = | 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) @@ -150,7 +150,7 @@ let rec force_does_not_occur metasenv subst restrictions t = 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')) ) @@ -158,34 +158,34 @@ let rec force_does_not_occur metasenv subst restrictions t = 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 @@ -194,24 +194,24 @@ and erase_in_context metasenv subst pos restrictions = function 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 @@ -228,15 +228,15 @@ and restrict metasenv subst i (restrictions as orig) = "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 = @@ -259,17 +259,17 @@ and restrict metasenv subst i (restrictions as orig) = | 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. @@ -283,13 +283,13 @@ let rec is_flexible context ~subst = function 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 @@ -307,7 +307,7 @@ exception Found;; (* 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,_) -> @@ -332,11 +332,11 @@ let delift ~unify metasenv subst context n l t = 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 @@ -363,7 +363,7 @@ let delift ~unify metasenv subst context n l t = (* 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 -> @@ -371,7 +371,7 @@ let delift ~unify metasenv subst context n l t = "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 @@ -386,7 +386,7 @@ let delift ~unify metasenv subst context n l t = 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 @@ -398,7 +398,7 @@ let delift ~unify metasenv subst context n l t = 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') @@ -426,7 +426,7 @@ let delift ~unify metasenv subst context n l t = 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 @@ -434,7 +434,7 @@ let delift ~unify metasenv subst context n l t = | _ -> 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 -> @@ -449,20 +449,20 @@ let delift ~unify metasenv subst context n l t = 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 (* @@ -482,16 +482,16 @@ let delift ~unify metasenv subst context n l t = (* 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 @@ -526,21 +526,21 @@ let extend_meta metasenv n = 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 diff --git a/matita/components/ng_refiner/nCicMetaSubst.mli b/matita/components/ng_refiner/nCicMetaSubst.mli index 1c96577a7..c9530d42d 100644 --- a/matita/components/ng_refiner/nCicMetaSubst.mli +++ b/matita/components/ng_refiner/nCicMetaSubst.mli @@ -35,6 +35,7 @@ val maxmeta: unit -> int * 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 -> @@ -46,6 +47,7 @@ val delift : 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 -> @@ -63,6 +65,7 @@ val extend_meta: NCic.metasenv -> int -> NCic.metasenv * NCic.term (* 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 @@ -72,4 +75,5 @@ val pack_lc : int * NCic.lc_kind -> int * NCic.lc_kind 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 diff --git a/matita/components/ng_refiner/nCicRefineUtil.ml b/matita/components/ng_refiner/nCicRefineUtil.ml index 7015f1b5d..30ae05577 100644 --- a/matita/components/ng_refiner/nCicRefineUtil.ml +++ b/matita/components/ng_refiner/nCicRefineUtil.ml @@ -31,7 +31,7 @@ exception Subst_not_found of int (* 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 @@ -48,7 +48,7 @@ let alpha_equivalence = (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' && @@ -65,11 +65,11 @@ let alpha_equivalence = 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 @@ -78,7 +78,7 @@ let alpha_equivalence = 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 @@ -93,27 +93,27 @@ let replace_lifting ~equality ~context ~what ~with_what ~where = 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 diff --git a/matita/components/ng_refiner/nCicRefineUtil.mli b/matita/components/ng_refiner/nCicRefineUtil.mli index 345b6bde2..228342378 100644 --- a/matita/components/ng_refiner/nCicRefineUtil.mli +++ b/matita/components/ng_refiner/nCicRefineUtil.mli @@ -11,9 +11,10 @@ (* $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 -> diff --git a/matita/components/ng_refiner/nCicRefiner.ml b/matita/components/ng_refiner/nCicRefiner.ml index 705d80cd4..4645e6f6e 100644 --- a/matita/components/ng_refiner/nCicRefiner.ml +++ b/matita/components/ng_refiner/nCicRefiner.ml @@ -57,7 +57,7 @@ let wrap_exc msg = function | 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 = @@ -66,15 +66,15 @@ let exp_implicit rdb ~localise metasenv subst context with_type t = | 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 @@ -91,7 +91,7 @@ let exp_implicit rdb ~localise metasenv subst context with_type t = | _ -> 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]) @@ -99,36 +99,36 @@ let check_allowed_sort_elimination rdb localise r orig = (* 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, @@ -139,7 +139,7 @@ let check_allowed_sort_elimination rdb localise r orig = aux ;; -let rec typeof rdb +let rec typeof (status:#NCicCoercion.status) ?(localise=fun _ -> Stdpp.dummy_loc) metasenv subst context term expty = @@ -153,19 +153,19 @@ let rec typeof rdb | 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 @@ -173,17 +173,17 @@ let rec typeof rdb 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 @@ -196,7 +196,7 @@ let rec typeof rdb | 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 @@ -209,21 +209,21 @@ let rec typeof rdb 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 @@ -232,7 +232,7 @@ let rec typeof rdb 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 @@ -251,18 +251,18 @@ let rec typeof rdb | _ -> 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 @@ -276,7 +276,7 @@ let rec typeof rdb 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 @@ -286,26 +286,26 @@ let rec typeof rdb | 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 @@ -322,12 +322,12 @@ let rec typeof rdb (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 @@ -351,7 +351,7 @@ let rec typeof rdb 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 @@ -366,11 +366,11 @@ let rec typeof rdb | 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 @@ -405,7 +405,7 @@ let rec typeof rdb 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 *) @@ -417,7 +417,7 @@ let rec typeof rdb 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 = @@ -431,46 +431,46 @@ let rec typeof rdb 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 -> @@ -480,32 +480,32 @@ and try_coercions rdb 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 @@ -523,12 +523,12 @@ and try_coercions rdb 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 @@ -540,10 +540,10 @@ and try_coercions rdb 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 @@ -578,22 +578,22 @@ and try_coercions rdb 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 @@ -608,8 +608,8 @@ and try_coercions rdb 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) -> @@ -624,8 +624,8 @@ and try_coercions rdb 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 @@ -636,7 +636,7 @@ and try_coercions rdb 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) @@ -652,27 +652,27 @@ and try_coercions rdb 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 @@ -688,9 +688,9 @@ and try_coercions rdb | 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 @@ -699,7 +699,7 @@ and try_coercions rdb 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 @@ -712,32 +712,32 @@ and try_coercions rdb 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 -> @@ -746,14 +746,14 @@ and try_coercions rdb 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 @@ -764,38 +764,38 @@ and try_coercions rdb 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 @@ -809,7 +809,7 @@ and try_coercions rdb 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*) @@ -817,53 +817,53 @@ and try_coercions rdb 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 @@ -881,10 +881,10 @@ and sort_of_prod 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,_)) @@ -894,11 +894,11 @@ and guess_name subst ctx ty = | 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 = @@ -906,16 +906,16 @@ and eat_prods rdb ~localise force_ty metasenv subst context expty orig_t orig_he | [] -> 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 @@ -933,17 +933,17 @@ and eat_prods rdb ~localise force_ty metasenv subst context expty orig_t orig_he (* 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 @@ -951,47 +951,47 @@ and eat_prods rdb ~localise force_ty metasenv subst context expty orig_t orig_he 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) @@ -1037,9 +1037,9 @@ let relocalise old_localise dt t add = (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 @@ -1052,17 +1052,17 @@ let undebruijnate inductive ref t rev_fl = 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 @@ -1075,8 +1075,8 @@ let typeof_obj 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 @@ -1086,7 +1086,7 @@ let typeof_obj 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 @@ -1096,7 +1096,7 @@ let typeof_obj 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 @@ -1112,13 +1112,13 @@ let typeof_obj 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 @@ -1126,10 +1126,10 @@ let typeof_obj 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,_ = @@ -1143,17 +1143,17 @@ let typeof_obj 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 @@ -1186,7 +1186,7 @@ let typeof_obj 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 ) @@ -1198,20 +1198,20 @@ let typeof_obj 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 _ -> () | _, _ -> @@ -1222,18 +1222,18 @@ let typeof_obj (* 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 diff --git a/matita/components/ng_refiner/nCicUnifHint.ml b/matita/components/ng_refiner/nCicUnifHint.ml index 0f0708d63..ff8de7554 100644 --- a/matita/components/ng_refiner/nCicUnifHint.ml +++ b/matita/components/ng_refiner/nCicUnifHint.ml @@ -51,8 +51,9 @@ class type g_status = 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 >} @@ -64,7 +65,7 @@ class status = 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) @@ -76,14 +77,14 @@ let index_hint hdb context t1 t2 precedence = * 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 @@ -103,18 +104,18 @@ let index_hint hdb context t1 t2 precedence = 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 -> @@ -122,15 +123,15 @@ let add_user_provided_hint db t precedence = | 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 @@ -141,7 +142,7 @@ let add_user_provided_hint db t precedence = in aux [] t in - index_hint db c a b precedence + index_hint status c a b precedence ;; (* @@ -206,7 +207,7 @@ let db () = ;; *) -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 -> @@ -215,14 +216,14 @@ let saturate ?(delta=0) metasenv subst context ty goal_arity = ~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 @@ -230,7 +231,7 @@ let saturate ?(delta=0) metasenv subst context ty goal_arity = 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] @@ -238,43 +239,43 @@ let eq_class_of hdb t1 = [] (* 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 = @@ -287,9 +288,9 @@ let look_for_hint hdb metasenv subst context t1 t2 = 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)) @@ -313,13 +314,13 @@ let look_for_hint hdb metasenv subst context t1 t2 = (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 @@ -353,7 +354,7 @@ let pp_hint t p = (* 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); @@ -361,7 +362,7 @@ let pp_hint t p = () ;; -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 @@ -380,18 +381,18 @@ let generate_dot_file status fmt = (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; diff --git a/matita/components/ng_refiner/nCicUnifHint.mli b/matita/components/ng_refiner/nCicUnifHint.mli index 421ef9ffb..832e980e2 100644 --- a/matita/components/ng_refiner/nCicUnifHint.mli +++ b/matita/components/ng_refiner/nCicUnifHint.mli @@ -20,9 +20,10 @@ class type g_status = 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 diff --git a/matita/components/ng_refiner/nCicUnification.ml b/matita/components/ng_refiner/nCicUnification.ml index a74172ca0..1e37ff797 100644 --- a/matita/components/ng_refiner/nCicUnification.ml +++ b/matita/components/ng_refiner/nCicUnification.ml @@ -21,13 +21,13 @@ exception KeepReducingThis of 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)) @@ -35,10 +35,10 @@ let mk_appl ~upto 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 @@ -48,7 +48,7 @@ let eta_reduce subst t = | 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 @@ -108,15 +108,15 @@ let outside exc_opt = 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 @@ -143,8 +143,8 @@ let rec could_reduce = | 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, _ = @@ -152,10 +152,10 @@ let rec lambda_intros rdb metasenv subst context argsno ty = 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) @@ -164,9 +164,9 @@ let rec lambda_intros rdb metasenv subst context argsno ty = 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 @@ -187,7 +187,7 @@ let fix metasenv subst is_sup test_eq_only exc t = 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 @@ -205,8 +205,8 @@ let metasenv_to_subst n (kind,context,ty) metasenv subst = 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 @@ -220,14 +220,14 @@ let rec sortfy exc metasenv subst context t = | 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 @@ -242,7 +242,7 @@ let tipify exc metasenv subst context t ty = 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) @@ -256,43 +256,43 @@ let tipify exc metasenv subst context t 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) @@ -305,25 +305,25 @@ let rec instantiate rdb test_eq_only metasenv subst context n lc t swap = 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 -> @@ -349,10 +349,10 @@ let rec instantiate rdb test_eq_only metasenv subst context n lc t swap = | _, 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) @@ -362,10 +362,10 @@ let rec instantiate rdb test_eq_only metasenv subst context n lc t swap = 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) @@ -380,30 +380,30 @@ let rec instantiate rdb test_eq_only metasenv subst context n lc t swap = 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 " ==??== " else " == 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 @@ -456,8 +456,8 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = (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 @@ -467,7 +467,7 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = 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 @@ -476,9 +476,9 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = | 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), @@ -486,21 +486,21 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = (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 @@ -508,12 +508,12 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = 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 *) @@ -528,27 +528,27 @@ and unify rdb 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.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 @@ -557,25 +557,25 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = 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), _ -> @@ -588,7 +588,7 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = 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 @@ -597,7 +597,7 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = (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)) @@ -616,30 +616,30 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = ?_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 @@ -647,7 +647,7 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = 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 @@ -656,17 +656,17 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = (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) -> @@ -679,47 +679,47 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = | _ -> 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 *) @@ -728,11 +728,11 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = 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 = @@ -742,7 +742,7 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = 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!")); @@ -757,8 +757,8 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = 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 @@ -770,7 +770,7 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = 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 -> @@ -794,7 +794,7 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = 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 -> @@ -817,30 +817,30 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = = 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 @@ -855,15 +855,15 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = | 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 = @@ -881,8 +881,8 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = | 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 @@ -899,15 +899,15 @@ and unify rdb test_eq_only metasenv subst context t1 t2 swap = (*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) @@ -920,10 +920,10 @@ and delift_type_wrt_terms rdb metasenv subst context t args = ;; -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")) ;; diff --git a/matita/components/ng_refiner/nCicUnification.mli b/matita/components/ng_refiner/nCicUnification.mli index 159d24c10..ec21d6643 100644 --- a/matita/components/ng_refiner/nCicUnification.mli +++ b/matita/components/ng_refiner/nCicUnification.mli @@ -25,7 +25,7 @@ val unify : (* 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 @@ -38,11 +38,8 @@ val delift_type_wrt_terms: 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 diff --git a/matita/components/ng_tactics/nCicElim.ml b/matita/components/ng_tactics/nCicElim.ml index 8d41e88e1..bae10cc56 100644 --- a/matita/components/ng_tactics/nCicElim.ml +++ b/matita/components/ng_tactics/nCicElim.ml @@ -25,11 +25,11 @@ let mk_id id = (*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") ;; @@ -42,15 +42,15 @@ let mk_appl = | 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 = @@ -72,14 +72,14 @@ let mk_elim uri leftno it (outsort,suffix) pragma = 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::_) @@ -175,10 +175,10 @@ let ast_of_sort s = | _ -> 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 ())) | _ -> [] @@ -204,12 +204,13 @@ let rec nth_prod projs n ty = (* 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 @@ -227,7 +228,7 @@ let rec pp rels = 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 @@ -250,9 +251,11 @@ let rec pp rels = 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 @@ -270,7 +273,7 @@ let mk_projection leftno tyname consname consty (projname,_,_) i = 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) -> @@ -294,11 +297,11 @@ let mk_projection leftno tyname consname consty (projname,_,_) i = (`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 | _ -> [] ;; diff --git a/matita/components/ng_tactics/nCicElim.mli b/matita/components/ng_tactics/nCicElim.mli index 470a800a1..826374fab 100644 --- a/matita/components/ng_tactics/nCicElim.mli +++ b/matita/components/ng_tactics/nCicElim.mli @@ -11,7 +11,8 @@ (* $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 diff --git a/matita/components/ng_tactics/nCicTacReduction.ml b/matita/components/ng_tactics/nCicTacReduction.ml index bc756a9ff..c1eba801f 100644 --- a/matita/components/ng_tactics/nCicTacReduction.ml +++ b/matita/components/ng_tactics/nCicTacReduction.ml @@ -11,29 +11,29 @@ (* $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)) ;; diff --git a/matita/components/ng_tactics/nCicTacReduction.mli b/matita/components/ng_tactics/nCicTacReduction.mli index 51b7851a7..b19e57478 100644 --- a/matita/components/ng_tactics/nCicTacReduction.mli +++ b/matita/components/ng_tactics/nCicTacReduction.mli @@ -12,4 +12,5 @@ (* $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 diff --git a/matita/components/ng_tactics/nDestructTac.ml b/matita/components/ng_tactics/nDestructTac.ml index 25d297be2..0ed800626 100644 --- a/matita/components/ng_tactics/nDestructTac.ml +++ b/matita/components/ng_tactics/nDestructTac.ml @@ -66,14 +66,14 @@ let subst_metasenv_and_fix_names status = 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 @@ -85,7 +85,7 @@ let cascade_select_in_ctx ~subst ctx skip iname = (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)); @@ -95,7 +95,7 @@ let cascade_select_in_ctx ~subst ctx skip iname = 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 ;; @@ -250,7 +250,7 @@ let mk_discriminator it ~use_jmeq nleft xyty status = 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 ;; @@ -315,8 +315,8 @@ let discriminate_tac ~context cur_eq status = | 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 @@ -338,7 +338,7 @@ let discriminate_tac ~context cur_eq status = 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; @@ -372,7 +372,7 @@ let saturate_skip status context skip = 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 = @@ -395,8 +395,8 @@ 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 @@ -458,7 +458,7 @@ let clearid_tac ~context skip cur_eq = 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 @@ -482,7 +482,7 @@ let clearid_tac ~context skip cur_eq = 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 @@ -516,7 +516,7 @@ let get_ctx st goal = 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), @@ -524,15 +524,15 @@ let select_eq ctx acc domain status goal = 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 @@ -545,14 +545,14 @@ let select_eq ctx acc domain status goal = (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 @@ -582,7 +582,7 @@ let rec destruct_tac0 nprods acc domain skip status goal = 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 @@ -590,7 +590,7 @@ let rec destruct_tac0 nprods acc domain skip status goal = 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 @@ -600,9 +600,9 @@ let rec destruct_tac0 nprods acc domain skip status goal = 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 = @@ -615,7 +615,7 @@ let rec destruct_tac0 nprods acc domain skip status goal = 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 @@ -629,10 +629,10 @@ let rec destruct_tac0 nprods acc domain skip status goal = 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 ;; diff --git a/matita/components/ng_tactics/nInversion.ml b/matita/components/ng_tactics/nInversion.ml index 904a221ff..cf4711db5 100644 --- a/matita/components/ng_tactics/nInversion.ml +++ b/matita/components/ng_tactics/nInversion.ml @@ -26,10 +26,10 @@ let mk_id id = 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 ;; @@ -60,21 +60,21 @@ let subst_metasenv_and_fix_names status = 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 diff --git a/matita/components/ng_tactics/nTacStatus.ml b/matita/components/ng_tactics/nTacStatus.ml index dd763c327..9a6358baa 100644 --- a/matita/components/ng_tactics/nTacStatus.ml +++ b/matita/components/ng_tactics/nTacStatus.ml @@ -72,7 +72,7 @@ class type g_pstatus = method obj: NCic.obj end -class pstatus = +class virtual pstatus = fun (o: NCic.obj) -> object (self) inherit GrafiteDisambiguate.status @@ -89,31 +89,26 @@ class pstatus = 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) = @@ -125,20 +120,20 @@ 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) ] @@ -154,17 +149,17 @@ let relocate status destination (source,t as orig) = (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 @@ -205,14 +200,14 @@ let disambiguate a b c d = wrap "disambiguate" (disambiguate a b c) d;; 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 ;; @@ -221,14 +216,14 @@ let saturate a ?delta b = wrap "saturate" (saturate a ?delta) b;; 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) ;; @@ -245,7 +240,7 @@ let fix_sorts 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 @@ -372,7 +367,7 @@ let select_term 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 @@ -383,7 +378,7 @@ let select_term | _, 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) -> @@ -434,9 +429,9 @@ let select_term 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 @@ -453,7 +448,7 @@ let analyse_indty status ty = | _,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 @@ -463,17 +458,17 @@ let analyse_indty status ty = 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 ====================*) @@ -484,7 +479,7 @@ class type ['stack] g_status = method stack: 'stack end -class ['stack] status = +class virtual ['stack] status = fun (o: NCic.obj) (s: 'stack) -> object (self) inherit (pstatus o) @@ -495,14 +490,19 @@ class ['stack] status = = 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 diff --git a/matita/components/ng_tactics/nTacStatus.mli b/matita/components/ng_tactics/nTacStatus.mli index 30989faba..35e74debf 100644 --- a/matita/components/ng_tactics/nTacStatus.mli +++ b/matita/components/ng_tactics/nTacStatus.mli @@ -49,7 +49,7 @@ class type g_pstatus = method obj: NCic.obj end -class pstatus : +class virtual pstatus : NCic.obj -> object ('self) inherit g_pstatus @@ -127,7 +127,7 @@ class type ['stack] g_status = method stack: 'stack end -class ['stack] status : +class virtual ['stack] status : NCic.obj -> 'stack -> object ('self) inherit ['stack] g_status @@ -136,11 +136,11 @@ class ['stack] 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 diff --git a/matita/components/ng_tactics/nTactics.ml b/matita/components/ng_tactics/nTactics.ml index b13de05d6..dbc134319 100644 --- a/matita/components/ng_tactics/nTactics.ml +++ b/matita/components/ng_tactics/nTactics.ml @@ -202,11 +202,25 @@ let compare_statuses ~past ~present = (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 ;; @@ -236,7 +250,7 @@ let distribute_tac tac (status : #tac_status) = 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: " @@ -318,7 +332,7 @@ let clear_tac names = 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)) ;; @@ -327,7 +341,7 @@ let generalize0_tac args = 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 @@ -335,6 +349,8 @@ let select0_tac ~where:(wanted,hyps,where) ~job = | `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 @@ -377,21 +393,21 @@ let select0_tac ~where:(wanted,hyps,where) ~job = 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) ] ;; @@ -445,8 +461,7 @@ let reduce_tac ~reduction ~where = 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 = @@ -455,8 +470,7 @@ 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 = @@ -631,7 +645,7 @@ let assert0_tac (hyps,concl) = distribute_tac (fun status goal -> 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 diff --git a/matita/components/ng_tactics/nTactics.mli b/matita/components/ng_tactics/nTactics.mli index d9964ddce..985849b63 100644 --- a/matita/components/ng_tactics/nTactics.mli +++ b/matita/components/ng_tactics/nTactics.mli @@ -68,11 +68,11 @@ val assert_tac: '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 diff --git a/matita/components/ng_tactics/nnAuto.ml b/matita/components/ng_tactics/nnAuto.ml index f4466fc1a..020b819c9 100644 --- a/matita/components/ng_tactics/nnAuto.ml +++ b/matita/components/ng_tactics/nnAuto.ml @@ -66,14 +66,14 @@ let is_relevant tbl item = 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 @@ -87,8 +87,8 @@ let get_sgoalty status g = 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 @@ -131,7 +131,7 @@ let branch status 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) @@ -140,10 +140,10 @@ let is_a_fact_obj s uri = 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 = @@ -154,20 +154,20 @@ 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 @@ -178,10 +178,10 @@ let fast_height_of_term t = | 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 @@ -195,13 +195,13 @@ let height_of_goal g status = 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 @@ -228,17 +228,17 @@ let solve f status eq_cache goal = *) 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 @@ -257,12 +257,12 @@ let solve f status eq_cache goal = 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 @@ -299,12 +299,12 @@ let index_local_equations eq_cache 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 _ @@ -364,12 +364,12 @@ let demod_tac ~params s = (*************** 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 = @@ -382,11 +382,11 @@ 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 *) @@ -407,28 +407,28 @@ let refresh metasenv = (* 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) @@ -442,12 +442,12 @@ let ground_instances status gl = (* 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))) @@ -459,14 +459,14 @@ let ground_instances status gl = (* (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 @@ -475,25 +475,25 @@ let replace_meta i args target = 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)) ;; @@ -504,34 +504,34 @@ let close status g = 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 @@ -544,14 +544,14 @@ let smart_apply t unit_eq status g = 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 @@ -559,8 +559,8 @@ let smart_apply t unit_eq status g = | 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 @@ -574,8 +574,8 @@ let smart_apply t unit_eq status g = 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 -> @@ -611,12 +611,12 @@ let rec cartesian = ;; (* 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 @@ -625,7 +625,7 @@ let all_keys_of_cic_type metasenv subst context ty = 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 @@ -641,7 +641,7 @@ let all_keys_of_cic_type metasenv subst context ty = | _ -> 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 @@ -654,7 +654,7 @@ let all_keys_of_type status t = 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, @@ -770,11 +770,11 @@ let pp_idx status idx = 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) ;; @@ -812,17 +812,17 @@ type cache = 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 @@ -864,13 +864,13 @@ let only signature _context candidate = true 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 *) @@ -885,7 +885,7 @@ let sort_candidates status ctx candidates = 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))); @@ -896,7 +896,7 @@ let sort_candidates status ctx candidates = 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 = @@ -904,7 +904,7 @@ 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 @@ -935,21 +935,21 @@ let try_candidate ?(smart=0) flags depth status eq_cache ctx t = 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)) @@ -982,7 +982,7 @@ let get_candidates ?(smart=true) depth flags status cache signature gty = | 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 @@ -1070,7 +1070,7 @@ let get_candidates ?(smart=true) status cache signature gty = | 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 *) @@ -1108,10 +1108,10 @@ let applicative_case depth signature status flags gty cache = 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 @@ -1197,7 +1197,7 @@ let is_subsumed depth status gty cache = 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 @@ -1248,7 +1248,7 @@ let is_prod status = (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 *) | [_,_,_,[_]] @@ -1305,14 +1305,14 @@ let intros ~depth status cache = 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 @@ -1485,7 +1485,7 @@ let rec auto_clusters ?(top=false) 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 @@ -1562,7 +1562,7 @@ and (* 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); *) @@ -1626,13 +1626,13 @@ auto_main flags signature cache depth status: unit = (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 _ -> @@ -1677,7 +1677,7 @@ let auto_tac ~params:(univ,flags) ?(trace_ref=ref []) status = 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)) ))); *) @@ -1729,7 +1729,7 @@ let auto_tac ~params:(univ,flags) ?(trace_ref=ref []) status = 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 @@ -1740,7 +1740,7 @@ let auto_tac ~params:(univ,flags) ?(trace_ref=ref []) status = 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 diff --git a/matita/matita/applyTransformation.ml b/matita/matita/applyTransformation.ml index 236e59def..51ac81268 100644 --- a/matita/matita/applyTransformation.ml +++ b/matita/matita/applyTransformation.ml @@ -35,28 +35,64 @@ (* $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 = + [], + "<<>>\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 diff --git a/matita/matita/applyTransformation.mli b/matita/matita/applyTransformation.mli index bcf3690d2..d5886abd8 100644 --- a/matita/matita/applyTransformation.mli +++ b/matita/matita/applyTransformation.mli @@ -33,17 +33,21 @@ (* *) (***************************************************************************) +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 *) diff --git a/matita/matita/cicMathView.ml b/matita/matita/cicMathView.ml index d319c2d5f..bd73d9213 100644 --- a/matita/matita/cicMathView.ml +++ b/matita/matita/cicMathView.ml @@ -34,7 +34,7 @@ let matita_script_current = ref (fun _ -> (assert false : < advance: ?statement: 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 @@ -67,10 +67,10 @@ let xref_ds = Gdome.domString "xref" (** 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) = @@ -184,10 +184,17 @@ object (self) (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) @@ -591,7 +598,7 @@ object (self) 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 = diff --git a/matita/matita/matita.ml b/matita/matita/matita.ml index 72b82839d..7312602fa 100644 --- a/matita/matita/matita.ml +++ b/matita/matita/matita.ml @@ -82,15 +82,15 @@ let init_debugging_menu gui = *) 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" diff --git a/matita/matita/matitaEngine.ml b/matita/matita/matitaEngine.ml index 64b3cc1eb..913ba87f6 100644 --- a/matita/matita/matitaEngine.ml +++ b/matita/matita/matitaEngine.ml @@ -29,8 +29,14 @@ module G = GrafiteAst 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 @@ -40,8 +46,8 @@ let debug_print = if debug then prerr_endline else ignore ;; 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 @@ -204,7 +210,7 @@ and compile ~compiling ~asserted ~include_paths fname = 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 () @@ -238,19 +244,19 @@ and compile ~compiling ~asserted ~include_paths fname = (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 diff --git a/matita/matita/matitaEngine.mli b/matita/matita/matitaEngine.mli index 2f7d1b439..d412d3ad0 100644 --- a/matita/matita/matitaEngine.mli +++ b/matita/matita/matitaEngine.mli @@ -29,6 +29,13 @@ exception AlreadyLoaded of string Lazy.t 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 diff --git a/matita/matita/matitaMathView.ml b/matita/matita/matitaMathView.ml index a970c569f..455d037b9 100644 --- a/matita/matita/matitaMathView.ml +++ b/matita/matita/matitaMathView.ml @@ -550,8 +550,9 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) | _ -> 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 -- 2.39.2