diff options
Diffstat (limited to 'interp')
| -rw-r--r-- | interp/constrextern.ml | 36 | ||||
| -rw-r--r-- | interp/constrintern.ml | 18 | ||||
| -rw-r--r-- | interp/declare.ml | 15 | ||||
| -rw-r--r-- | interp/declare.mli | 5 | ||||
| -rw-r--r-- | interp/notation.ml | 10 | ||||
| -rw-r--r-- | interp/notation.mli | 1 | ||||
| -rw-r--r-- | interp/ppextend.ml | 9 | ||||
| -rw-r--r-- | interp/ppextend.mli | 10 |
8 files changed, 26 insertions, 78 deletions
diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 54861ae4cc..e85415bed3 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -320,38 +320,6 @@ let drop_implicits_in_patt cst nb_expl args = let imps = List.skipn_at_least nb_expl (select_stronger_impargs impl_st) in impls_fit [] (imps,args) -let has_curly_brackets ntn = - String.length ntn >= 6 && (String.is_sub "{ _ } " ntn 0 || - String.is_sub " { _ }" ntn (String.length ntn - 6) || - String.string_contains ~where:ntn ~what:" { _ } ") - -let rec wildcards ntn n = - if Int.equal n (String.length ntn) then [] - else let l = spaces ntn (n+1) in if ntn.[n] == '_' then n::l else l -and spaces ntn n = - if Int.equal n (String.length ntn) then [] - else if ntn.[n] == ' ' then wildcards ntn (n+1) else spaces ntn (n+1) - -let expand_curly_brackets loc mknot ntn l = - let ntn' = ref ntn in - let rec expand_ntn i = - function - | [] -> [] - | a::l -> - let a' = - let p = List.nth (wildcards !ntn' 0) i - 2 in - if p>=0 && p+5 <= String.length !ntn' && String.is_sub "{ _ }" !ntn' p - then begin - ntn' := - String.sub !ntn' 0 p ^ "_" ^ - String.sub !ntn' (p+5) (String.length !ntn' -p-5); - mknot (loc,"{ _ }",[a]) end - else a in - a' :: expand_ntn (i+1) l in - let l = expand_ntn 0 l in - (* side effect *) - mknot (loc,!ntn',l) - let destPrim = function { CAst.v = CPrim t } -> Some t | _ -> None let destPatPrim = function { CAst.v = CPatPrim t } -> Some t | _ -> None @@ -367,9 +335,7 @@ let is_zero s = in aux 0 let make_notation_gen loc ntn mknot mkprim destprim l = - if has_curly_brackets ntn - then expand_curly_brackets loc mknot ntn l - else match ntn,List.map destprim l with + match ntn,List.map destprim l with (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) | "- _", [Some (Numeral (p,true))] when not (is_zero p) -> mknot (loc,ntn,([mknot (loc,"( _ )",l)])) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c9fc3aa4f3..e465677cde 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -2038,7 +2038,9 @@ let interp_constr_evars_gen_impls env evdref ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env c in let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:(expected_type == IsType) c in - understand_tcc_evars env evdref ~expected_type c, imps + let evd, c = understand_tcc env !evdref ~expected_type c in + evdref := evd; + c, imps let interp_constr_evars_impls env evdref ?(impls=empty_internalization_env) c = interp_constr_evars_gen_impls env evdref ~impls WithoutTypeConstraint c @@ -2053,7 +2055,9 @@ let interp_type_evars_impls env evdref ?(impls=empty_internalization_env) c = let interp_constr_evars_gen env evdref ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env c in - understand_tcc_evars env evdref ~expected_type c + let evd, c = understand_tcc env !evdref ~expected_type c in + evdref := evd; + c let interp_constr_evars env evdref ?(impls=empty_internalization_env) c = interp_constr_evars_gen env evdref WithoutTypeConstraint ~impls c @@ -2098,7 +2102,9 @@ let interp_binder env sigma na t = let interp_binder_evars env evdref na t = let t = intern_gen IsType env t in let t' = locate_if_hole ?loc:(loc_of_glob_constr t) na t in - understand_tcc_evars env evdref ~expected_type:IsType t' + let evd, c = understand_tcc env !evdref ~expected_type:IsType t' in + evdref := evd; + c let my_intern_constr env lvar acc c = internalize env acc false lvar c @@ -2125,7 +2131,8 @@ let interp_glob_context_evars env evdref k bl = if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t else t in - let t = understand_tcc_evars env evdref ~expected_type:IsType t' in + let (evd,t) = understand_tcc env !evdref ~expected_type:IsType t' in + evdref := evd; match b with None -> let d = LocalAssum (na,t) in @@ -2137,7 +2144,8 @@ let interp_glob_context_evars env evdref k bl = in (push_rel d env, d::params, succ n, impls) | Some b -> - let c = understand_tcc_evars env evdref ~expected_type:(OfType t) b in + let (evd,c) = understand_tcc env !evdref ~expected_type:(OfType t) b in + evdref := evd; let d = LocalDef (na, c, t) in (push_rel d env, d::params, n, impls)) (env,[],k+1,[]) (List.rev bl) diff --git a/interp/declare.ml b/interp/declare.ml index 70f422b514..7fcb38296f 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -32,14 +32,6 @@ type internal_flag = | InternalTacticRequest (* kernel action, no message is displayed *) | UserIndividualRequest (* user action, a message is displayed *) -(** XML output hooks *) - -let (f_xml_declare_variable, xml_declare_variable) = Hook.make ~default:ignore () -let (f_xml_declare_constant, xml_declare_constant) = Hook.make ~default:ignore () -let (f_xml_declare_inductive, xml_declare_inductive) = Hook.make ~default:ignore () - -let if_xml f x = if !Flags.xml_export then f x else () - (** Declaration of section variables and local definitions *) type section_variable_entry = @@ -95,7 +87,6 @@ let declare_variable id obj = declare_var_implicits id; Notation.declare_ref_arguments_scope (VarRef id); Heads.declare_head (EvalVarRef id); - if_xml (Hook.get f_xml_declare_variable) oname; oname @@ -256,7 +247,6 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e let id = Label.to_id (pi3 (Constant.repr3 c)) in ignore(add_leaf id o); update_tables c; - let () = if_xml (Hook.get f_xml_declare_constant) (InternalTacticRequest, c) in match role with | Safe_typing.Subproof -> () | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|] @@ -268,9 +258,7 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e cst_kind = kind; cst_locl = local; } in - let kn = declare_constant_common id cst in - let () = if_xml (Hook.get f_xml_declare_constant) (internal, kn) in - kn + declare_constant_common id cst let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) @@ -410,7 +398,6 @@ let declare_mind mie = let isrecord,isprim = declare_projections mind in declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; - if_xml (Hook.get f_xml_declare_inductive) (isrecord,oname); oname, isprim (* Declaration messages *) diff --git a/interp/declare.mli b/interp/declare.mli index 6a09434645..ccd7d28bb5 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -69,11 +69,6 @@ val set_declare_scheme : the whole block and a boolean indicating if it is a primitive record. *) val declare_mind : mutual_inductive_entry -> object_name * bool -(** Hooks for XML output *) -val xml_declare_variable : (object_name -> unit) Hook.t -val xml_declare_constant : (internal_flag * constant -> unit) Hook.t -val xml_declare_inductive : (bool * object_name -> unit) Hook.t - (** Declaration messages *) val definition_message : Id.t -> unit diff --git a/interp/notation.ml b/interp/notation.ml index c07a009438..c373faf680 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -41,7 +41,6 @@ open Context.Named.Declaration (**********************************************************************) (* Scope of symbols *) -type level = precedence * tolerability list type delimiters = string type notation_location = (DirPath.t * DirPath.t) * string @@ -83,11 +82,18 @@ let parenRelation_eq t1 t2 = match t1, t2 with | Prec l1, Prec l2 -> Int.equal l1 l2 | _ -> false -let level_eq (l1, t1) (l2, t2) = +let notation_var_internalization_type_eq v1 v2 = match v1, v2 with +| NtnInternTypeConstr, NtnInternTypeConstr -> true +| NtnInternTypeBinder, NtnInternTypeBinder -> true +| NtnInternTypeIdent, NtnInternTypeIdent -> true +| (NtnInternTypeConstr | NtnInternTypeBinder | NtnInternTypeIdent), _ -> false + +let level_eq (l1, t1, u1) (l2, t2, u2) = let tolerability_eq (i1, r1) (i2, r2) = Int.equal i1 i2 && parenRelation_eq r1 r2 in Int.equal l1 l2 && List.equal tolerability_eq t1 t2 + && List.equal notation_var_internalization_type_eq u1 u2 let declare_scope scope = try let _ = String.Map.find scope !scope_map in () diff --git a/interp/notation.mli b/interp/notation.mli index e63ad10cde..f9f247fe10 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -21,7 +21,6 @@ open Ppextend (** A scope is a set of interpreters for symbols + optional interpreter and printers for integers + optional delimiters *) -type level = precedence * tolerability list type delimiters = string type scope type scopes (** = [scope_name list] *) diff --git a/interp/ppextend.ml b/interp/ppextend.ml index 2bbe87bbca..3ebc9b71d2 100644 --- a/interp/ppextend.ml +++ b/interp/ppextend.ml @@ -7,17 +7,10 @@ (************************************************************************) open Pp +open Notation_term (*s Pretty-print. *) -(* Dealing with precedences *) - -type precedence = int - -type parenRelation = L | E | Any | Prec of precedence - -type tolerability = precedence * parenRelation - type ppbox = | PpHB of int | PpHOVB of int diff --git a/interp/ppextend.mli b/interp/ppextend.mli index a347a5c7b7..6ff5a42728 100644 --- a/interp/ppextend.mli +++ b/interp/ppextend.mli @@ -6,15 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** {6 Pretty-print. } *) - -(** Dealing with precedences *) - -type precedence = int +open Notation_term -type parenRelation = L | E | Any | Prec of precedence - -type tolerability = precedence * parenRelation +(** {6 Pretty-print. } *) type ppbox = | PpHB of int |