aboutsummaryrefslogtreecommitdiff
path: root/interp/constrextern.ml
diff options
context:
space:
mode:
Diffstat (limited to 'interp/constrextern.ml')
-rw-r--r--interp/constrextern.ml223
1 files changed, 169 insertions, 54 deletions
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index f6da10c961..8a798bfb00 100644
--- a/interp/constrextern.ml
+++ b/interp/constrextern.ml
@@ -66,22 +66,138 @@ let print_universes = Detyping.print_universes
(* This suppresses printing of primitive tokens (e.g. numeral) and notations *)
let print_no_symbol = ref false
-(* This tells which notations still not to used if print_no_symbol is true *)
-let print_non_active_notations = ref ([] : interp_rule list)
+(**********************************************************************)
+(* Turning notations and scopes on and off for printing *)
+module IRuleSet = Set.Make(struct
+ type t = interp_rule
+ let compare x y = Pervasives.compare x y
+ end)
+
+let inactive_notations_table =
+ Summary.ref ~name:"inactive_notations_table" (IRuleSet.empty)
+let inactive_scopes_table =
+ Summary.ref ~name:"inactive_scopes_table" CString.Set.empty
+
+let show_scope scopt =
+ match scopt with
+ | None -> str ""
+ | Some sc -> spc () ++ str "in scope" ++ spc () ++ str sc
+
+let _show_inactive_notations () =
+ begin
+ if CString.Set.is_empty !inactive_scopes_table
+ then
+ Feedback.msg_notice (str "No inactive notation scopes.")
+ else
+ let _ = Feedback.msg_notice (str "Inactive notation scopes:") in
+ CString.Set.iter (fun sc -> Feedback.msg_notice (str " " ++ str sc))
+ !inactive_scopes_table
+ end;
+ if IRuleSet.is_empty !inactive_notations_table
+ then
+ Feedback.msg_notice (str "No individual inactive notations.")
+ else
+ let _ = Feedback.msg_notice (str "Inactive notations:") in
+ IRuleSet.iter
+ (function
+ | NotationRule (scopt, ntn) ->
+ Feedback.msg_notice (str ntn ++ show_scope scopt)
+ | SynDefRule kn -> Feedback.msg_notice (str (Names.KerName.to_string kn)))
+ !inactive_notations_table
+
+let deactivate_notation nr =
+ match nr with
+ | SynDefRule kn ->
+ (* shouldn't we check wether it is well defined? *)
+ inactive_notations_table := IRuleSet.add nr !inactive_notations_table
+ | NotationRule (scopt, ntn) ->
+ match availability_of_notation (scopt, ntn) (scopt, []) with
+ | None -> user_err ~hdr:"Notation"
+ (str ntn ++ spc () ++ str "does not exist"
+ ++ (match scopt with
+ | None -> spc () ++ str "in the empty scope."
+ | Some _ -> show_scope scopt ++ str "."))
+ | Some _ ->
+ if IRuleSet.mem nr !inactive_notations_table then
+ Feedback.msg_warning
+ (str "Notation" ++ spc () ++ str ntn ++ spc ()
+ ++ str "is already inactive" ++ show_scope scopt ++ str ".")
+ else inactive_notations_table := IRuleSet.add nr !inactive_notations_table
+
+let reactivate_notation nr =
+ try
+ inactive_notations_table :=
+ IRuleSet.remove nr !inactive_notations_table
+ with Not_found ->
+ match nr with
+ | NotationRule (scopt, ntn) ->
+ Feedback.msg_warning (str "Notation" ++ spc () ++ str ntn ++ spc ()
+ ++ str "is already active" ++ show_scope scopt ++
+ str ".")
+ | SynDefRule kn ->
+ Feedback.msg_warning
+ (str "Notation" ++ spc () ++ str (Names.KerName.to_string kn)
+ ++ spc () ++ str "is already active.")
+
+
+let deactivate_scope sc =
+ ignore (find_scope sc); (* ensures that the scope exists *)
+ if CString.Set.mem sc !inactive_scopes_table
+ then
+ Feedback.msg_warning (str "Notation Scope" ++ spc () ++ str sc ++ spc ()
+ ++ str "is already inactive.")
+ else
+ inactive_scopes_table := CString.Set.add sc !inactive_scopes_table
+
+let reactivate_scope sc =
+ try
+ inactive_scopes_table := CString.Set.remove sc !inactive_scopes_table
+ with Not_found ->
+ Feedback.msg_warning (str "Notation Scope" ++ spc () ++ str sc ++ spc ()
+ ++ str "is already active.")
+
+let is_inactive_rule nr =
+ IRuleSet.mem nr !inactive_notations_table ||
+ match nr with
+ | NotationRule (Some sc, ntn) -> CString.Set.mem sc !inactive_scopes_table
+ | NotationRule (None, ntn) -> false
+ | SynDefRule _ -> false
+
+(* args: notation, scope, activate/deactivate *)
+let toggle_scope_printing ~scope ~activate =
+ if activate then
+ reactivate_scope scope
+ else
+ deactivate_scope scope
+
+let toggle_notation_printing ?scope ~notation ~activate =
+ if activate then
+ reactivate_notation (NotationRule (scope, notation))
+ else
+ deactivate_notation (NotationRule (scope, notation))
(* This governs printing of projections using the dot notation symbols *)
let print_projections = ref false
let print_meta_as_hole = ref false
-let with_arguments f = Flags.with_option print_arguments f
-let with_implicits f = Flags.with_option print_implicits f
-let with_coercions f = Flags.with_option print_coercions f
let with_universes f = Flags.with_option print_universes f
let with_meta_as_hole f = Flags.with_option print_meta_as_hole f
let without_symbols f = Flags.with_option print_no_symbol f
-let without_specific_symbols l f =
- Flags.with_extra_values print_non_active_notations l f
+
+(* XXX: Where to put this in the library? Util maybe? *)
+let protect_ref r nf f x =
+ let old_ref = !r in
+ r := nf !r;
+ try let res = f x in r := old_ref; res
+ with reraise ->
+ let reraise = Backtrace.add_backtrace reraise in
+ r := old_ref;
+ Exninfo.iraise reraise
+
+let without_specific_symbols l =
+ protect_ref inactive_notations_table
+ (fun tbl -> IRuleSet.(union (of_list l) tbl))
(**********************************************************************)
(* Control printing of records *)
@@ -239,23 +355,31 @@ let expand_curly_brackets loc mknot ntn l =
let destPrim = function { CAst.v = CPrim t } -> Some t | _ -> None
let destPatPrim = function { CAst.v = CPatPrim t } -> Some t | _ -> None
+let is_number s =
+ let rec aux i =
+ Int.equal (String.length s) i ||
+ match s.[i] with '0'..'9' -> aux (i+1) | _ -> false
+ in aux 0
+
+let is_zero s =
+ let rec aux i =
+ Int.equal (String.length s) i || (s.[i] == '0' && aux (i+1))
+ 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
(* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *)
- | "- _", [Some (Numeral p)] when Bigint.is_strictly_pos p ->
+ | "- _", [Some (Numeral (p,true))] when not (is_zero p) ->
mknot (loc,ntn,([mknot (loc,"( _ )",l)]))
| _ ->
match decompose_notation_key ntn, l with
- | [Terminal "-"; Terminal x], [] ->
- (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x)))
- with Failure _ -> mknot (loc,ntn,[]))
- | [Terminal x], [] ->
- (try mkprim (loc, Numeral (Bigint.of_string x))
- with Failure _ -> mknot (loc,ntn,[]))
- | _ ->
- mknot (loc,ntn,l)
+ | [Terminal "-"; Terminal x], [] when is_number x ->
+ mkprim (loc, Numeral (x,false))
+ | [Terminal x], [] when is_number x ->
+ mkprim (loc, Numeral (x,true))
+ | _ -> mknot (loc,ntn,l)
let make_notation loc ntn (terms,termlists,binders as subst) =
if not (List.is_empty termlists) || not (List.is_empty binders) then
@@ -288,17 +412,8 @@ let pattern_printable_in_both_syntax (ind,_ as c) =
(* Better to use extern_glob_constr composed with injection/retraction ?? *)
let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
- (* pboutill: There are letins in pat which is incompatible with notations and
- not explicit application. *)
- match pat with
- | { loc; v = PatCstr(cstrsp,args,na) }
- when !Flags.in_debugger||Inductiveops.constructor_has_local_defs cstrsp ->
- let c = extern_reference ?loc Id.Set.empty (ConstructRef cstrsp) in
- let args = List.map (extern_cases_pattern_in_scope scopes vars) args in
- CAst.make ?loc @@ CPatCstr (c, Some (add_patt_for_params (fst cstrsp) args), [])
- | _ ->
try
- if !Flags.raw_print || !print_no_symbol then raise No_match;
+ if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match;
let (na,sc,p) = uninterp_prim_token_cases_pattern pat in
match availability_of_prim_token p sc scopes with
| None -> raise No_match
@@ -307,7 +422,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
insert_pat_alias ?loc (insert_pat_delimiters ?loc (CAst.make ?loc @@ CPatPrim p) key) na
with No_match ->
try
- if !Flags.raw_print || !print_no_symbol then raise No_match;
+ if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match;
extern_notation_pattern scopes vars pat
(uninterp_cases_pattern_notations pat)
with No_match ->
@@ -321,21 +436,19 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
if !Flags.raw_print then raise Exit;
let projs = Recordops.lookup_projections (fst cstrsp) in
let rec ip projs args acc =
- match projs with
- | [] -> acc
- | None :: q -> ip q args acc
- | Some c :: q ->
- match args with
- | [] -> raise No_match
-
-
-
-
-
- | { CAst.v = CPatAtom None } :: tail -> ip q tail acc
- (* we don't want to have 'x = _' in our patterns *)
- | head :: tail -> ip q tail
- ((extern_reference ?loc Id.Set.empty (ConstRef c), head) :: acc)
+ match projs, args with
+ | [], [] -> acc
+ | proj :: q, pat :: tail ->
+ let acc =
+ match proj, pat with
+ | _, { CAst.v = CPatAtom None } ->
+ (* we don't want to have 'x := _' in our patterns *)
+ acc
+ | Some c, _ ->
+ ((extern_reference ?loc Id.Set.empty (ConstRef c), pat) :: acc)
+ | _ -> raise No_match in
+ ip q tail acc
+ | _ -> assert false
in
CPatRecord(List.rev (ip projs args []))
with
@@ -401,7 +514,7 @@ and extern_notation_pattern (tmp_scope,scopes as allscopes) vars t = function
| [] -> raise No_match
| (keyrule,pat,n as _rule)::rules ->
try
- if List.mem keyrule !print_non_active_notations then raise No_match;
+ if is_inactive_rule keyrule then raise No_match;
let loc = t.loc in
match t.v with
| PatCstr (cstr,_,na) ->
@@ -417,8 +530,8 @@ let rec extern_notation_ind_pattern allscopes vars ind args = function
| [] -> raise No_match
| (keyrule,pat,n as _rule)::rules ->
try
- if List.mem keyrule !print_non_active_notations then raise No_match;
- apply_notation_to_pattern (IndRef ind)
+ if is_inactive_rule keyrule then raise No_match;
+ apply_notation_to_pattern (IndRef ind)
(match_notation_constr_ind_pattern ind args pat) allscopes vars keyrule
with
No_match -> extern_notation_ind_pattern allscopes vars ind args rules
@@ -663,9 +776,11 @@ let rec extern inctx scopes vars r =
| GEvar (n,l) ->
extern_evar n (List.map (on_snd (extern false scopes vars)) l)
- | GPatVar (b,n) ->
+ | GPatVar kind ->
if !print_meta_as_hole then CHole (None, Misctypes.IntroAnonymous, None) else
- if b then CPatVar n else CEvar (n,[])
+ (match kind with
+ | Evar_kinds.SecondOrderPatVar n -> CPatVar n
+ | Evar_kinds.FirstOrderPatVar n -> CEvar (n,[]))
| GApp (f,args) ->
(match f with
@@ -698,7 +813,7 @@ let rec extern inctx scopes vars r =
| None :: q -> raise No_match
| Some c :: q ->
match locs with
- | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern]")
+ | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].")
| (_, false) :: locs' ->
(* we don't want to print locals *)
ip q locs' args acc
@@ -886,7 +1001,7 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function
| (keyrule,pat,n as _rule)::rules ->
let loc = Glob_ops.loc_of_glob_constr t in
try
- if List.mem keyrule !print_non_active_notations then raise No_match;
+ if is_inactive_rule keyrule then raise No_match;
(* Adjusts to the number of arguments expected by the notation *)
let (t,args,argsscopes,argsimpls) = match t.v ,n with
| GApp (f,args), Some n
@@ -1033,17 +1148,17 @@ let rec glob_of_pat env sigma pat = CAst.make @@ match pat with
let id = try match lookup_name_of_rel n env with
| Name id -> id
| Anonymous ->
- anomaly ~label:"glob_constr_of_pattern" (Pp.str "index to an anonymous variable")
+ anomaly ~label:"glob_constr_of_pattern" (Pp.str "index to an anonymous variable.")
with Not_found -> Id.of_string ("_UNBOUND_REL_"^(string_of_int n)) in
GVar id
| PMeta None -> GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous,None)
- | PMeta (Some n) -> GPatVar (false,n)
+ | PMeta (Some n) -> GPatVar (Evar_kinds.FirstOrderPatVar n)
| PProj (p,c) -> GApp (CAst.make @@ GRef (ConstRef (Projection.constant p),None),
[glob_of_pat env sigma c])
| PApp (f,args) ->
GApp (glob_of_pat env sigma f,Array.map_to_list (glob_of_pat env sigma) args)
| PSoApp (n,args) ->
- GApp (CAst.make @@ GPatVar (true,n),
+ GApp (CAst.make @@ GPatVar (Evar_kinds.SecondOrderPatVar n),
List.map (glob_of_pat env sigma) args)
| PProd (na,t,c) ->
GProd (na,Explicit,glob_of_pat env sigma t,glob_of_pat (na::env) sigma c)
@@ -1064,7 +1179,7 @@ let rec glob_of_pat env sigma pat = CAst.make @@ match pat with
| _, Some ind ->
let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat env sigma c)) bl in
simple_cases_matrix_of_branches ind bl'
- | _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive")
+ | _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive.")
in
let mat = if info.cip_extensible then mat @ [any_any_branch] else mat
in
@@ -1072,7 +1187,7 @@ let rec glob_of_pat env sigma pat = CAst.make @@ match pat with
| PMeta None, _, _ -> (Anonymous,None),None
| _, Some ind, Some nargs ->
return_type_of_predicate ind nargs (glob_of_pat env sigma p)
- | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive")
+ | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.")
in
GCases (RegularStyle,rtn,[glob_of_pat env sigma tm,indnames],mat)
| PFix f -> (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkFix f))).v (** FIXME bad env *)
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-28 16:33:37 +0000