diff options
304 files changed, 3013 insertions, 9090 deletions
diff --git a/.gitignore b/.gitignore index bea12162c..7434f6212 100644 --- a/.gitignore +++ b/.gitignore @@ -49,6 +49,7 @@ config/Makefile config/coq_config.ml config/Info-*.plist dev/ocamldebug-coq +dev/camlp4.dbg plugins/micromega/csdpcert kernel/byterun/dllcoqrun.so coqdoc.sty @@ -157,5 +158,8 @@ dev/myinclude /doc/refman/Reference-Manual.hoptind /doc/refman/Reference-Manual.optidx /doc/refman/Reference-Manual.optind + user-contrib .*.sw* +test-suite/.lia.cache +test-suite/.nra.cache @@ -1,3 +1,12 @@ +Changes beyond V8.6 +=================== + +Tactics + +- New tactic "extensionality in H" which applies (possibly dependent) + functional extensionality in H supposed to be a quantified equality + until giving a bare equality. + Changes from V8.5 to V8.6beta1 ============================== @@ -227,7 +227,7 @@ cacheclean: find theories plugins test-suite -name '.*.aux' -delete cleanconfig: - rm -f config/Makefile config/coq_config.ml myocamlbuild_config.ml dev/ocamldebug-v7 config/Info-*.plist + rm -f config/Makefile config/coq_config.ml myocamlbuild_config.ml dev/ocamldebug-coq dev/camlp4.dbg config/Info-*.plist distclean: clean cleanconfig cacheclean diff --git a/Makefile.build b/Makefile.build index 95df69c2d..9d76638e1 100644 --- a/Makefile.build +++ b/Makefile.build @@ -220,7 +220,7 @@ CINCLUDES= -I $(CAMLHLIB) $(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN) cd $(dir $(LIBCOQRUN)) && \ - $(OCAMLFIND) ocamlmklib -oc $(COQRUN) $(foreach u,$(BYTERUN),$(notdir $(u))) + $(OCAMLFIND) ocamlmklib -oc $(COQRUN) $(notdir $(BYTERUN)) kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' \ @@ -505,6 +505,12 @@ test-suite: world $(ALLSTDLIB).v # but the -include mechanism should already ensure that we have # up-to-date dependencies. +# Specific rule for kernel.cma, with $(VMBYTEFLAGS). +# This helps loading dllcoqrun.so during an ocamldebug +kernel/kernel.cma: kernel/kernel.mllib + $(SHOW)'OCAMLC -a -o $@' + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(VMBYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) + %.cma: %.mllib $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) @@ -591,7 +597,7 @@ plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLLEX $<' $(HIDE)$(OCAMLLEX) -o $@ "$*.mll" -%.ml: %.ml4 | $(CAMLP4DEPS) +%.ml: %.ml4 $(CAMLP4DEPS) $(SHOW)'CAMLP4O $<' $(HIDE)$(CAMLP4O) -I $(MYCAMLP4LIB) $(PR_O) \ $(CAMLP4DEPS) $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@ diff --git a/Makefile.dev b/Makefile.dev index 1f81edc2c..8c1812da1 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -15,21 +15,18 @@ .PHONY: devel printers -DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/printers.cma +DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo devel: printers -printers: $(DEBUGPRINTERS) - -dev/printers.cma: dev/printers.mllib - $(SHOW)'Testing $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(SYSCMA) $(P4CMA) $(filter-out %.mllib, $^) -o test-printer - @rm -f test-printer - $(SHOW)'OCAMLC -a $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(SYSCMA) $(P4CMA) $(filter-out %.mllib, $^) -linkall -a -o $@ - -dev/%.mllib.d: dev/%.mllib | $(OCAMLLIBDEP) $(GENFILES) - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) -I dev "$<" $(TOTARGET) +printers: $(CORECMA) $(DEBUGPRINTERS) dev/camlp4.dbg + +ifeq ($(CAMLP4),camlp5) +dev/camlp4.dbg: + echo "load_printer gramlib.cma" > $@ +else +dev/camlp4.dbg: + echo "load_printer camlp4lib.cma" > $@ +endif ############ # revision diff --git a/checker/Makefile b/checker/Makefile deleted file mode 100644 index 2bcc9d365..000000000 --- a/checker/Makefile +++ /dev/null @@ -1,88 +0,0 @@ -OCAMLC=ocamlc -OCAMLOPT=ocamlopt - -COQSRC=.. - -MLDIRS=-I $(COQSRC)/config -I $(COQSRC)/lib -I $(COQSRC)/kernel -I +camlp4 -BYTEFLAGS=$(MLDIRS) -OPTFLAGS=$(MLDIRS) - -CHECKERNAME=coqchk - -BINARIES=../bin/$(CHECKERNAME)$(EXE) ../bin/$(CHECKERNAME).opt$(EXE) -MCHECKERLOCAL :=\ - declarations.cmo environ.cmo \ - closure.cmo reduction.cmo \ - type_errors.cmo \ - modops.cmo \ - inductive.cmo typeops.cmo \ - indtypes.cmo subtyping.cmo mod_checking.cmo \ -validate.cmo \ - safe_typing.cmo check.cmo \ - check_stat.cmo checker.cmo - -MCHECKER:=\ - $(COQSRC)/config/coq_config.cmo \ - $(COQSRC)/lib/pp_control.cmo $(COQSRC)/lib/pp.cmo $(COQSRC)/lib/compat.cmo \ - $(COQSRC)/lib/util.cmo $(COQSRC)/lib/option.cmo $(COQSRC)/lib/hashcons.cmo \ - $(COQSRC)/lib/system.cmo $(COQSRC)/lib/flags.cmo \ - $(COQSRC)/lib/predicate.cmo $(COQSRC)/lib/rtree.cmo \ - $(COQSRC)/kernel/names.cmo $(COQSRC)/kernel/univ.cmo \ - $(COQSRC)/kernel/esubst.cmo term.cmo \ - $(MCHECKERLOCAL) - -all: $(BINARIES) - -byte : ../bin/$(CHECKERNAME)$(EXE) -opt : ../bin/$(CHECKERNAME).opt$(EXE) - -check.cma: $(MCHECKERLOCAL) - ocamlc $(BYTEFLAGS) -a -o $@ $(MCHECKER) - -check.cmxa: $(MCHECKERLOCAL:.cmo=.cmx) - ocamlopt $(OPTFLAGS) -a -o $@ $(MCHECKER:.cmo=.cmx) - -../bin/$(CHECKERNAME)$(EXE): check.cma - ocamlc $(BYTEFLAGS) -o $@ unix.cma gramlib.cma check.cma main.ml - -../bin/$(CHECKERNAME).opt$(EXE): check.cmxa - ocamlopt $(OPTFLAGS) -o $@ unix.cmxa gramlib.cmxa check.cmxa main.ml - -stats: - @echo STRUCTURE - @wc names.ml term.ml declarations.ml environ.ml type_errors.ml - @echo - @echo REDUCTION - @-wc esubst.ml closure.ml reduction.ml - @echo - @echo TYPAGE - @wc univ.ml inductive.ml indtypes.ml typeops.ml safe_typing.ml - @echo - @echo MODULES - @wc modops.ml subtyping.ml - @echo - @echo INTERFACE - @wc check*.ml main.ml - @echo - @echo TOTAL - @wc *.ml | tail -1 - -.SUFFIXES:.ml .mli .cmi .cmo .cmx - -.ml.cmo: - $(OCAMLC) -c $(BYTEFLAGS) $< - -.ml.cmx: - $(OCAMLOPT) -c $(OPTFLAGS) $< - -.mli.cmi: - $(OCAMLC) -c $(BYTEFLAGS) $< - - -depend:: - ocamldep *.ml* > .depend - -clean:: - rm -f *.cm* *.o *.a *~ $(BINARIES) - --include .depend diff --git a/checker/check.ml b/checker/check.ml index 8b299bf2a..11678fa6b 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -248,12 +248,12 @@ let locate_qualified_library qid = let error_unmapped_dir qid = let prefix = qid.dirpath in - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirlist prefix ++ fnl ()) let error_lib_not_found qid = - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str"Cannot find library " ++ pr_path qid ++ str" in loadpath") let try_locate_absolute_library dir = @@ -314,18 +314,18 @@ let intern_from_file (dir, f) = let () = close_in ch in let ch = open_in_bin f in if not (String.equal (Digest.channel ch pos) checksum) then - errorlabstrm "intern_from_file" (str "Checksum mismatch"); + user_err ~hdr:"intern_from_file" (str "Checksum mismatch"); let () = close_in ch in if dir <> sd.md_name then - errorlabstrm "intern_from_file" + user_err ~hdr:"intern_from_file" (name_clash_message dir sd.md_name f); if tasks <> None || discharging <> None then - errorlabstrm "intern_from_file" + user_err ~hdr:"intern_from_file" (str "The file "++str f++str " contains unfinished tasks"); if opaque_csts <> None then begin chk_pp (str " (was a vio file) "); Option.iter (fun (_,_,b) -> if not b then - errorlabstrm "intern_from_file" + user_err ~hdr:"intern_from_file" (str "The file "++str f++str " is still a .vio")) opaque_csts; Validate.validate !Flags.debug Values.v_univopaques opaque_csts; diff --git a/checker/checker.ml b/checker/checker.ml index 8dbb7e011..95a9ea78b 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -216,7 +216,9 @@ let report () = (str "." ++ spc () ++ str "Please report" ++ let guill s = str "\"" ++ str s ++ str "\"" -let where s = +let where = function +| None -> mt () +| Some s -> if !Flags.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) let rec explain_exn = function diff --git a/checker/modops.ml b/checker/modops.ml index b720fb621..aba9da2fe 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -33,7 +33,7 @@ let error_no_such_label_sub l l1 = Label.to_string l^" is missing in "^l1^".") let error_not_a_module_loc loc s = - user_err_loc (loc,"",str ("\""^Label.to_string s^"\" is not a module")) + user_err ~loc (str ("\""^Label.to_string s^"\" is not a module")) let error_not_a_module s = error_not_a_module_loc Loc.ghost s diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index 11cd742ba..53d80c6d5 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -89,6 +89,6 @@ let import file clib univs digest = let unsafe_import file clib univs digest = let env = !genv in if !Flags.debug then check_imports Feedback.msg_warning clib.comp_name env clib.comp_deps - else check_imports (errorlabstrm"unsafe_import") clib.comp_name env clib.comp_deps; + else check_imports (user_err ~hdr:"unsafe_import") clib.comp_name env clib.comp_deps; check_engagement env clib.comp_enga; full_add_module clib.comp_name clib.comp_mod univs digest diff --git a/configure.ml b/configure.ml index 507fd351a..c3ba953de 100644 --- a/configure.ml +++ b/configure.ml @@ -11,7 +11,7 @@ #load "str.cma" open Printf -let coq_version = "8.6.0" +let coq_version = "trunk" let coq_macos_version = "8.4.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) let vo_magic = 8511 @@ -1093,6 +1093,7 @@ let write_makefile f = pr "LOCAL=%B\n\n" !Prefs.local; pr "# Bytecode link flags : should we use -custom or not ?\n"; pr "CUSTOM=%s\n" custom_flag; + pr "VMBYTEFLAGS=%s\n" (String.concat " " vmbyteflags); pr "%s\n\n" !build_loadpath; pr "# Paths for true installation\n"; List.iter (fun (v,msg,_,_) -> pr "# %s: path for %s\n" v msg) install_dirs; diff --git a/dev/base_db b/dev/base_db index b540aed6c..e18ac534a 100644 --- a/dev/base_db +++ b/dev/base_db @@ -1,6 +1,6 @@ -load_printer "gramlib.cma" -load_printer "top_printers.cmo" -install_printer Top_printers.prid -install_printer Top_printers.prsp -install_printer Top_printers.print_pure_constr +source core.dbg +load_printer top_printers.cmo +install_printer Top_printers.ppid +install_printer Top_printers.ppsp +install_printer Top_printers.ppconstr diff --git a/dev/base_include b/dev/base_include index b09b6df2d..0abcefc38 100644 --- a/dev/base_include +++ b/dev/base_include @@ -195,7 +195,7 @@ let qid = Libnames.qualid_of_string;; (* parsing of terms *) let parse_constr = Pcoq.parse_string Pcoq.Constr.constr;; -let parse_tac = Pcoq.parse_string Pcoq.Tactic.tactic;; +let parse_tac = Pcoq.parse_string Pltac.tactic;; let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac;; (* build a term of type glob_constr without type-checking or resolution of diff --git a/dev/core.dbg b/dev/core.dbg new file mode 100644 index 000000000..38b9b2946 --- /dev/null +++ b/dev/core.dbg @@ -0,0 +1,18 @@ +source camlp4.dbg +load_printer threads.cma +load_printer str.cma +load_printer clib.cma +load_printer lib.cma +load_printer kernel.cma +load_printer library.cma +load_printer engine.cma +load_printer pretyping.cma +load_printer interp.cma +load_printer proofs.cma +load_printer parsing.cma +load_printer printing.cma +load_printer tactics.cma +load_printer stm.cma +load_printer toplevel.cma +load_printer highparsing.cma +load_printer ltac.cma @@ -1,4 +1,5 @@ -load_printer "printers.cma" +source core.dbg +load_printer top_printers.cmo install_printer Top_printers.ppfuture diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 79a0c6312..800194b1d 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -1,4 +1,56 @@ ========================================= += CHANGES BETWEEN COQ V8.6 AND COQ V8.7 = +========================================= + +* ML API * + +We renamed the following functions: + + Context.Rel.Declaration.fold -> Context.Rel.Declaration.fold_constr + Context.Named.Declaration.fold -> Context.Named.Declaration.fold_constr + Printer.pr_var_list_decl -> Printer.pr_compacted_decl + Printer.pr_var_decl -> Printer.pr_named_decl + Nameops.lift_subscript -> Nameops.increment_subscript + +We removed the following functions: + + Termops.compact_named_context_reverse ... practical substitute is Termops.compact_named_context + Namegen.to_avoid ... equivalent substitute is Names.Id.List.mem + +We renamed the following modules: + + Context.ListNamed -> Context.Compacted + +The following type aliases where removed + + Context.section_context ... it was just an alias for "Context.Named.t" which is still available + +The module Constrarg was merged into Stdarg. + +** Ltac API ** + +Many Ltac specific API has been moved in its own ltac/ folder. Amongst other +important things: + +- Pcoq.Tactic -> Pltac +- Constrarg.wit_tactic -> Tacarg.wit_tactic +- Constrarg.wit_ltac -> Tacarg.wit_ltac +- API below ltac/ that accepted a *_tactic_expr now accept a *_generic_argument + instead +- Some printing functions were moved from Pptactic to Pputils +- A part of Tacexpr has been moved to Tactypes + +** Error handling ** + +- All error functions now take an optional parameter `?loc:Loc.t`. For + functions that used to carry a suffix `_loc`, such suffix has been + dropped. + +- `errorlabstrm` has been removed in favor of `user_err`. + +- The header parameter to `user_err` has been made optional. + +========================================= = CHANGES BETWEEN COQ V8.5 AND COQ V8.6 = ========================================= diff --git a/dev/doc/debugging.txt b/dev/doc/debugging.txt index f0df2fc37..79cde4884 100644 --- a/dev/doc/debugging.txt +++ b/dev/doc/debugging.txt @@ -51,8 +51,8 @@ Debugging from Caml debugger failure/error/anomaly has been raised - Alternatively, for an error or an anomaly, add breakpoints in the middle of each of error* functions or anomaly* functions in lib/util.ml - - If "source db" fails, recompile printers.cma with - "make dev/printers.cma" and try again + - If "source db" fails, do a "make printers" and try again (it should build + top_printers.cmo and the core cma files). Global gprof-based profiling ============================ diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index f9310e076..46caca8d6 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -12,11 +12,13 @@ [ -z "$COQTOP" -a -d "$PWD/kernel" ] && COQTOP=$PWD [ -z "$COQTOP" -a -d "$PWD/../kernel" ] && COQTOP=`dirname $PWD` +export CAML_LD_LIBRARY_PATH=$COQTOP/kernel/byterun:$CAML_LD_LIBRARY_PATH + exec $OCAMLDEBUG \ - -I $CAMLP4LIB \ + -I $CAMLP4LIB -I +threads \ -I $COQTOP \ -I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar \ - -I $COQTOP/lib -I $COQTOP/intf -I $COQTOP/kernel \ + -I $COQTOP/lib -I $COQTOP/intf -I $COQTOP/kernel -I $COQTOP/kernel/byterun \ -I $COQTOP/library -I $COQTOP/engine \ -I $COQTOP/pretyping -I $COQTOP/parsing \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \ diff --git a/dev/printers.mllib b/dev/printers.mllib deleted file mode 100644 index 316549548..000000000 --- a/dev/printers.mllib +++ /dev/null @@ -1,219 +0,0 @@ -Coq_config - -Terminal -Hook -Canary -Hashset -Hashcons -CSet -CMap -Int -Dyn -HMap -Option -Store -Exninfo -Backtrace -IStream -Pp_control -Loc -CList -CString -Tok -Compat -Flags -Control -Loc -Serialize -Stateid -CObj -CArray -CStack -Util -Pp -Ppstyle -Richpp -Feedback -Segmenttree -Unicodetable -Unicode -CErrors -CWarnings -Bigint -CUnix -Minisys -System -Envars -Aux_file -Profile -Explore -Predicate -Rtree -Heap -Genarg -Stateid -CEphemeron -Future -RemoteCounter -Monad - -Names -Univ -UGraph -Esubst -Uint31 -Sorts -Evar -Constr -Context -Vars -Term -Mod_subst -Cbytecodes -Copcodes -Cemitcodes -Nativevalues -Primitives -Nativeinstr -Future -Opaqueproof -Declareops -Retroknowledge -Conv_oracle -Pre_env -Nativelambda -Nativecode -Nativelib -Cbytegen -Environ -CClosure -Reduction -Nativeconv -Type_errors -Modops -Inductive -Typeops -Fast_typeops -Indtypes -Cooking -Term_typing -Subtyping -Mod_typing -Nativelibrary -Safe_typing -Unionfind - -Summary -Nameops -Libnames -Globnames -Global -Nametab -Libobject -Lib -Loadpath -Goptions -Decls -Heads -Keys -Locusops -Miscops -Universes -Termops -Namegen -UState -Evd -Sigma -Glob_ops -Redops -Pretype_errors -Evarutil -Reductionops -Inductiveops -Arguments_renaming -Nativenorm -Retyping -Cbv - -Evardefine -Evarsolve -Recordops -Evarconv -Typing -Patternops -Constr_matching -Find_subterm -Tacred -Classops -Typeclasses_errors -Logic_monad -Proofview_monad -Proofview -Ftactic -Geninterp -Typeclasses -Detyping -Indrec -Program -Coercion -Cases -Pretyping -Unification -Declaremods -Library -States - -Genprint -CLexer -Ppextend -Pputils -Ppannotation -Stdarg -Constrarg -Constrexpr_ops -Genintern -Notation_ops -Notation -Dumpglob -Syntax_def -Smartlocate -Topconstr -Reserve -Impargs -Implicit_quantifiers -Constrintern -Modintern -Constrextern -Goal -Miscprint -Logic -Refiner -Clenv -Evar_refiner -Refine -Proof -Proof_global -Pfedit -Decl_mode -Ppconstr -Pcoq -Printer -Pptactic -Ppdecl_proof -Egramml -Egramcoq -Tacsubst -Trie -Dn -Btermdn -Hints -Himsg -ExplainErr -Locality -Assumptions -Vernacinterp -Dischargedhypsmap -Discharge -Declare -Ind_tables -Top_printers diff --git a/dev/top_printers.ml b/dev/top_printers.ml index a3d5cf5c1..b552d9994 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -502,7 +502,7 @@ END open Pcoq open Genarg -open Constrarg +open Stdarg open Egramml let _ = diff --git a/doc/refman/RefMan-tus.tex b/doc/refman/RefMan-tus.tex index 3e2988676..797b0aded 100644 --- a/doc/refman/RefMan-tus.tex +++ b/doc/refman/RefMan-tus.tex @@ -1012,7 +1012,7 @@ the different kinds of errors used in \Coq{} : \fun{val Std.error : string -> 'a} {For simple error messages} -\fun{val Std.errorlabstrm : string -> std\_ppcmds -> 'a} +\fun{val Std.user_err : ?loc:Loc.t -> string -> std\_ppcmds -> 'a} {See Section~\ref{PrettyPrinter} : this can be used if the user want to display a term or build a complex error message} diff --git a/engine/evarutil.ml b/engine/evarutil.ml index df170c8dd..13444cb37 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -18,6 +18,9 @@ open Environ open Evd open Sigma.Notations +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + let safe_evar_info sigma evk = try Some (Evd.find sigma evk) with Not_found -> None @@ -167,13 +170,11 @@ let is_ground_term evd t = not (has_undefined_evars evd t) let is_ground_env evd env = - let open Context.Rel.Declaration in let is_ground_rel_decl = function - | LocalDef (_,b,_) -> is_ground_term evd b + | RelDecl.LocalDef (_,b,_) -> is_ground_term evd b | _ -> true in - let open Context.Named.Declaration in let is_ground_named_decl = function - | LocalDef (_,b,_) -> is_ground_term evd b + | NamedDecl.LocalDef (_,b,_) -> is_ground_term evd b | _ -> true in List.for_all is_ground_rel_decl (rel_context env) && List.for_all is_ground_named_decl (named_context env) @@ -255,11 +256,10 @@ let non_instantiated sigma = (************************) let make_pure_subst evi args = - let open Context.Named.Declaration in snd (List.fold_right (fun decl (args,l) -> match args with - | a::rest -> (rest, (get_id decl, a)::l) + | a::rest -> (rest, (NamedDecl.get_id decl, a)::l) | _ -> anomaly (Pp.str "Instance does not match its signature")) (evar_filtered_context evi) (Array.rev_to_list args,[])) @@ -331,21 +331,18 @@ let push_var id (n, s) = (succ n, s) let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) = - let open Context.Named.Declaration in let replace_var_named_declaration id0 id decl = - let id' = get_id decl in + let id' = NamedDecl.get_id decl in let id' = if Id.equal id0 id' then id else id' in let vsubst = [id0 , mkVar id] in - decl |> set_id id' |> map_constr (replace_vars vsubst) + decl |> NamedDecl.set_id id' |> NamedDecl.map_constr (replace_vars vsubst) in let extract_if_neq id = function | Anonymous -> None | Name id' when id_ord id id' = 0 -> None | Name id' -> Some id' in - let open Context.Rel.Declaration in - let (na, c, t) = to_tuple decl in - let open Context.Named.Declaration in + let na = RelDecl.get_name decl in let id = (* ppedrot: we want to infer nicer names for the refine tactic, but keeping at the same time backward compatibility in other code @@ -356,7 +353,7 @@ let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) = else (** id_of_name_using_hdchar only depends on the rel context which is empty here *) - next_ident_away (id_of_name_using_hdchar empty_env t na) avoid + next_ident_away (id_of_name_using_hdchar empty_env (RelDecl.get_type decl) na) avoid in match extract_if_neq id na with | Some id0 when not (is_section_variable id0) -> @@ -366,10 +363,7 @@ let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) = context. Unless [id] is a section variable. *) let subst = (fst subst, Int.Map.map (replace_vars [id0,mkVar id]) (snd subst)) in let vsubst = (id0,mkVar id)::vsubst in - let d = match c with - | None -> LocalAssum (id0, subst2 subst vsubst t) - | Some c -> LocalDef (id0, subst2 subst vsubst c, subst2 subst vsubst t) - in + let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> NamedDecl.map_constr (subst2 subst vsubst) in let nc = List.map (replace_var_named_declaration id0 id) nc in (push_var id0 subst, vsubst, Id.Set.add id avoid, d :: nc) | _ -> @@ -377,10 +371,7 @@ let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) = incorrect. We revert to a less robust behaviour where the new binder has name [id]. Which amounts to the same behaviour than when [id=id0]. *) - let d = match c with - | None -> LocalAssum (id, subst2 subst vsubst t) - | Some c -> LocalDef (id, subst2 subst vsubst c, subst2 subst vsubst t) - in + let d = decl |> NamedDecl.of_rel_decl (fun _ -> id) |> NamedDecl.map_constr (subst2 subst vsubst) in (push_var id subst, vsubst, Id.Set.add id avoid, d :: nc) let push_rel_context_to_named_context env typ = @@ -560,8 +551,7 @@ let rec check_and_clear_in_constr env evdref err ids global c = let () = Id.Map.iter check ri in (* No dependency at all, we can keep this ev's context hyp *) (ri, true::filter) - with Depends id -> let open Context.Named.Declaration in - (Id.Map.add (get_id h) id ri, false::filter)) + with Depends id -> (Id.Map.add (NamedDecl.get_id h) id ri, false::filter)) ctxt (Array.to_list l) (Id.Map.empty,[]) in (* Check if some rid to clear in the context of ev has dependencies in the type of ev and adjust the source of the dependency *) @@ -600,10 +590,9 @@ let clear_hyps_in_evi_main env evdref hyps terms ids = let terms = List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids global) terms in let nhyps = - let open Context.Named.Declaration in let check_context decl = - let err = OccurHypInSimpleClause (Some (get_id decl)) in - map_constr (check_and_clear_in_constr env evdref err ids global) decl + let err = OccurHypInSimpleClause (Some (NamedDecl.get_id decl)) in + NamedDecl.map_constr (check_and_clear_in_constr env evdref err ids global) decl in let check_value vk = match force_lazy_val vk with | None -> vk @@ -642,8 +631,8 @@ let process_dependent_evar q acc evm is_dependent e = hypotheses), they are all dependent. *) queue_term q true evi.evar_concl; List.iter begin fun decl -> - let open Context.Named.Declaration in - queue_term q true (get_type decl); + let open NamedDecl in + queue_term q true (NamedDecl.get_type decl); match decl with | LocalAssum _ -> () | LocalDef (_,b,_) -> queue_term q true b @@ -719,9 +708,8 @@ let undefined_evars_of_term evd t = evrec Evar.Set.empty t let undefined_evars_of_named_context evd nc = - let open Context.Named.Declaration in Context.Named.fold_outside - (fold (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c))) + (NamedDecl.fold_constr (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c))) nc ~init:Evar.Set.empty diff --git a/engine/evd.ml b/engine/evd.ml index 291c08978..69ca45444 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -18,6 +18,9 @@ open Environ open Globnames open Context.Named.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (** Generic filters *) module Filter : sig @@ -226,7 +229,7 @@ let evar_instance_array test_id info args = if i < len then let c = Array.unsafe_get args i in if test_id d c then instrec filter ctxt (succ i) - else (get_id d, c) :: instrec filter ctxt (succ i) + else (NamedDecl.get_id d, c) :: instrec filter ctxt (succ i) else instance_mismatch () | _ -> instance_mismatch () in @@ -235,7 +238,7 @@ let evar_instance_array test_id info args = let map i d = if (i < len) then let c = Array.unsafe_get args i in - if test_id d c then None else Some (get_id d, c) + if test_id d c then None else Some (NamedDecl.get_id d, c) else instance_mismatch () in List.map_filter_i map (evar_context info) @@ -243,7 +246,7 @@ let evar_instance_array test_id info args = instrec filter (evar_context info) 0 let make_evar_instance_array info args = - evar_instance_array (isVarId % get_id) info args + evar_instance_array (NamedDecl.get_id %> isVarId) info args let instantiate_evar_array info c args = let inst = make_evar_instance_array info args in @@ -284,7 +287,7 @@ let metavars_of c = let rec collrec acc c = match kind_of_term c with | Meta mv -> Int.Set.add mv acc - | _ -> fold_constr collrec acc c + | _ -> Term.fold_constr collrec acc c in collrec Int.Set.empty c @@ -383,8 +386,7 @@ let add_name_newly_undefined naming evk evi (evtoid, idtoev as names) = | Misctypes.IntroAnonymous -> None | Misctypes.IntroIdentifier id -> if Idmap.mem id idtoev then - user_err_loc - (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id); + user_err (str "Already an existential evar of name " ++ pr_id id); Some id | Misctypes.IntroFresh id -> let id = Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in @@ -681,7 +683,7 @@ let restrict evk filter ?candidates evd = evar_extra = Store.empty } in let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in let ctxt = Filter.filter_list filter (evar_context evar_info) in - let id_inst = Array.map_of_list (mkVar % get_id) ctxt in + let id_inst = Array.map_of_list (NamedDecl.get_id %> mkVar) ctxt in let body = mkEvar(evk',id_inst) in let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; @@ -731,23 +733,22 @@ let evar_list c = let rec evrec acc c = match kind_of_term c with | Evar (evk, _ as ev) -> ev :: acc - | _ -> fold_constr evrec acc c in + | _ -> Term.fold_constr evrec acc c in evrec [] c let evars_of_term c = let rec evrec acc c = match kind_of_term c with | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) - | _ -> fold_constr evrec acc c + | _ -> Term.fold_constr evrec acc c in evrec Evar.Set.empty c let evars_of_named_context nc = - List.fold_right (fun decl s -> - Option.fold_left (fun s t -> - Evar.Set.union s (evars_of_term t)) - (Evar.Set.union s (evars_of_term (get_type decl))) (get_value decl)) - nc Evar.Set.empty + Context.Named.fold_outside + (NamedDecl.fold_constr (fun constr s -> Evar.Set.union s (evars_of_term constr))) + nc + ~init:Evar.Set.empty let evars_of_filtered_evar_info evi = Evar.Set.union (evars_of_term evi.evar_concl) @@ -1283,11 +1284,10 @@ let pr_meta_map mmap = prlist pr_meta_binding (metamap_to_list mmap) let pr_decl (decl,ok) = - let id = get_id decl in - match get_value decl with - | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}") - | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ - print_constr c ++ str (if ok then ")" else "}") + match decl with + | LocalAssum (id,_) -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}") + | LocalDef (id,c,_) -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ + print_constr c ++ str (if ok then ")" else "}") let pr_evar_source = function | Evar_kinds.QuestionMark _ -> str "underscore" @@ -1398,12 +1398,11 @@ let pr_evar_universe_context ctx = h 0 (Universes.pr_universe_opt_subst (UState.subst ctx)) ++ fnl()) let print_env_short env = - let pr_body n = function - | None -> pr_name n - | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in - let pr_named_decl decl = pr_body (Name (get_id decl)) (get_value decl) in - let pr_rel_decl decl = let open Context.Rel.Declaration in - pr_body (get_name decl) (get_value decl) in + let pr_rel_decl = function + | RelDecl.LocalAssum (n,_) -> pr_name n + | RelDecl.LocalDef (n,b,_) -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" + in + let pr_named_decl = NamedDecl.to_rel_decl %> pr_rel_decl in let nc = List.rev (named_context env) in let rc = List.rev (rel_context env) in str "[" ++ pr_sequence pr_named_decl nc ++ str "]" ++ spc () ++ diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 17ff898b0..6e821ea5a 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -34,7 +34,7 @@ exception Timeout exception TacticFailure of exn let _ = CErrors.register_handler begin function - | Timeout -> CErrors.errorlabstrm "Some timeout function" (Pp.str"Timeout!") + | Timeout -> CErrors.user_err ~hdr:"Some timeout function" (Pp.str"Timeout!") | Exception e -> CErrors.print e | TacticFailure e -> CErrors.print e | _ -> Pervasives.raise CErrors.Unhandled diff --git a/engine/namegen.ml b/engine/namegen.ml index 84eb98684..92a915111 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -24,6 +24,8 @@ open Environ open Termops open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (**********************************************************************) (* Conventional names *) @@ -114,9 +116,9 @@ let hdchar env c = | Rel n -> (if n<=k then "p" (* the initial term is flexible product/function *) else - try match Environ.lookup_rel (n-k) env |> to_tuple with - | (Name id,_,_) -> lowercase_first_char id - | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) + try match Environ.lookup_rel (n-k) env with + | LocalAssum (Name id,_) | LocalDef (Name id,_,_) -> lowercase_first_char id + | LocalAssum (Anonymous,t) | LocalDef (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) with Not_found -> "y") | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> let id = match lna.(i) with Name id -> id | _ -> assert false in @@ -168,7 +170,7 @@ let it_mkLambda_or_LetIn_name env b hyps = (* Looks for next "good" name by lifting subscript *) let next_ident_away_from id bad = - let rec name_rec id = if bad id then name_rec (lift_subscript id) else id in + let rec name_rec id = if bad id then name_rec (increment_subscript id) else id in name_rec id (* Restart subscript from x0 if name starts with xN, or x00 if name @@ -180,10 +182,6 @@ let restart_subscript id = *** make_ident id (Some 0) *** but compatibility would be lost... *) forget_subscript id -let rec to_avoid id = function -| [] -> false -| id' :: avoid -> Id.equal id id' || to_avoid id avoid - let visible_ids (nenv, c) = let accu = ref (Refset_env.empty, Int.Set.empty, Id.Set.empty) in let rec visible_ids n c = match kind_of_term c with @@ -230,8 +228,8 @@ let visible_ids (nenv, c) = let next_name_away_in_cases_pattern env_t na avoid = let id = match na with Name id -> id | Anonymous -> default_dependent_ident in let visible = visible_ids env_t in - let bad id = to_avoid id avoid || is_constructor id - || Id.Set.mem id visible in + let bad id = Id.List.mem id avoid || is_constructor id + || Id.Set.mem id visible in next_ident_away_from id bad (* 2- Looks for a fresh name for introduction in goal *) @@ -244,8 +242,8 @@ let next_name_away_in_cases_pattern env_t na avoid = name is taken by finding a free subscript starting from 0 *) let next_ident_away_in_goal id avoid = - let id = if to_avoid id avoid then restart_subscript id else id in - let bad id = to_avoid id avoid || (is_global id && not (is_section_variable id)) in + let id = if Id.List.mem id avoid then restart_subscript id else id in + let bad id = Id.List.mem id avoid || (is_global id && not (is_section_variable id)) in next_ident_away_from id bad let next_name_away_in_goal na avoid = @@ -262,16 +260,16 @@ let next_name_away_in_goal na avoid = beyond the current subscript *) let next_global_ident_away id avoid = - let id = if to_avoid id avoid then restart_subscript id else id in - let bad id = to_avoid id avoid || is_global id in + let id = if Id.List.mem id avoid then restart_subscript id else id in + let bad id = Id.List.mem id avoid || is_global id in next_ident_away_from id bad (* 4- Looks for next fresh name outside a list; if name already used, looks for same name with lower available subscript *) let next_ident_away id avoid = - if to_avoid id avoid then - next_ident_away_from (restart_subscript id) (fun id -> to_avoid id avoid) + if Id.List.mem id avoid then + next_ident_away_from (restart_subscript id) (fun id -> Id.List.mem id avoid) else id let next_name_away_with_default default na avoid = @@ -295,11 +293,10 @@ let make_all_name_different env = let avoid = ref (ids_of_named_context (named_context env)) in process_rel_context (fun decl newenv -> - let (na,_,t) = to_tuple decl in - let na = named_hd newenv t na in + let na = named_hd newenv (RelDecl.get_type decl) (RelDecl.get_name decl) in let id = next_name_away na !avoid in avoid := id::!avoid; - push_rel (set_name (Name id) decl) newenv) + push_rel (RelDecl.set_name (Name id) decl) newenv) env (* 5- Looks for next fresh name outside a list; avoids also to use names that @@ -309,7 +306,7 @@ let make_all_name_different env = let next_ident_away_for_default_printing env_t id avoid = let visible = visible_ids env_t in - let bad id = to_avoid id avoid || Id.Set.mem id visible in + let bad id = Id.List.mem id avoid || Id.Set.mem id visible in next_ident_away_from id bad let next_name_away_for_default_printing env_t na avoid = diff --git a/engine/proofview.ml b/engine/proofview.ml index 855235d2b..333ae78b3 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -341,7 +341,7 @@ let set_nosuchgoals_hook f = nosuchgoals_hook := f let _ = CErrors.register_handler begin function | NoSuchGoals n -> let suffix = !nosuchgoals_hook n in - CErrors.errorlabstrm "" + CErrors.user_err (str "No such " ++ str (String.plural n "goal") ++ str "." ++ pr_non_empty_arg (fun x -> x) suffix) | _ -> raise CErrors.Unhandled @@ -427,7 +427,7 @@ let _ = CErrors.register_handler begin function str"Incorrect number of goals" ++ spc() ++ str"(expected "++int i++str(String.plural i " tactic") ++ str")." in - CErrors.errorlabstrm "" errmsg + CErrors.user_err errmsg | _ -> raise CErrors.Unhandled end @@ -839,11 +839,11 @@ let tclPROGRESS t = if not test then tclUNIT res else - tclZERO (CErrors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) + tclZERO (CErrors.UserError (Some "Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) exception Timeout let _ = CErrors.register_handler begin function - | Timeout -> CErrors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") + | Timeout -> CErrors.user_err ~hdr:"Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") | _ -> Pervasives.raise CErrors.Unhandled end @@ -1050,7 +1050,7 @@ module Goal = struct exception NotExactlyOneSubgoal let _ = CErrors.register_handler begin function | NotExactlyOneSubgoal -> - CErrors.errorlabstrm "" (Pp.str"Not exactly one subgoal.") + CErrors.user_err (Pp.str"Not exactly one subgoal.") | _ -> raise CErrors.Unhandled end diff --git a/engine/termops.ml b/engine/termops.ml index 17e56ec31..5e65652c0 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -17,6 +17,7 @@ open Environ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration +module CompactedDecl = Context.Compacted.Declaration (* Sorts and sort family *) @@ -978,18 +979,27 @@ let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init let mem_named_context_val id ctxt = try Environ.lookup_named_val id ctxt; true with Not_found -> false -let compact_named_context_reverse sign = +let compact_named_context sign = let compact l decl = - let (i1,c1,t1) = NamedDecl.to_tuple decl in - match l with - | [] -> [[i1],c1,t1] - | (l2,c2,t2)::q -> - if Option.equal Constr.equal c1 c2 && Constr.equal t1 t2 - then (i1::l2,c2,t2)::q - else ([i1],c1,t1)::l - in Context.Named.fold_inside compact ~init:[] sign - -let compact_named_context sign = List.rev (compact_named_context_reverse sign) + match decl, l with + | NamedDecl.LocalAssum (i,t), [] -> + [CompactedDecl.LocalAssum ([i],t)] + | NamedDecl.LocalDef (i,c,t), [] -> + [CompactedDecl.LocalDef ([i],c,t)] + | NamedDecl.LocalAssum (i1,t1), CompactedDecl.LocalAssum (li,t2) :: q -> + if Constr.equal t1 t2 + then CompactedDecl.LocalAssum (i1::li, t2) :: q + else CompactedDecl.LocalAssum ([i1],t1) :: CompactedDecl.LocalAssum (li,t2) :: q + | NamedDecl.LocalDef (i1,c1,t1), CompactedDecl.LocalDef (li,c2,t2) :: q -> + if Constr.equal c1 c2 && Constr.equal t1 t2 + then CompactedDecl.LocalDef (i1::li, c2, t2) :: q + else CompactedDecl.LocalDef ([i1],c1,t1) :: CompactedDecl.LocalDef (li,c2,t2) :: q + | NamedDecl.LocalAssum (i,t), q -> + CompactedDecl.LocalAssum ([i],t) :: q + | NamedDecl.LocalDef (i,c,t), q -> + CompactedDecl.LocalDef ([i],c,t) :: q + in + sign |> Context.Named.fold_inside compact ~init:[] |> List.rev let clear_named_body id env = let open NamedDecl in diff --git a/engine/termops.mli b/engine/termops.mli index 0a7ac1f26..7d6e99acc 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -238,8 +238,7 @@ val fold_named_context_both_sides : ('a -> Context.Named.Declaration.t -> Context.Named.Declaration.t list -> 'a) -> Context.Named.t -> init:'a -> 'a val mem_named_context_val : Id.t -> named_context_val -> bool -val compact_named_context : Context.Named.t -> Context.NamedList.t -val compact_named_context_reverse : Context.Named.t -> Context.NamedList.t +val compact_named_context : Context.Named.t -> Context.Compacted.t val clear_named_body : Id.t -> env -> env diff --git a/engine/uState.ml b/engine/uState.ml index c35f97b2e..c66af02bb 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -255,8 +255,8 @@ let universe_context ?names ctx = let l = try UNameMap.find (Id.to_string id) (fst ctx.uctx_names) with Not_found -> - user_err_loc (loc, "universe_context", - str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") + user_err ~loc ~hdr:"universe_context" + (str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc)) pl ([], [], levels) in @@ -269,8 +269,8 @@ let universe_context ?names ctx = Option.default Loc.ghost info.uloc with Not_found -> Loc.ghost in - user_err_loc (loc, "universe_context", - (str(CString.plural n "Universe") ++ spc () ++ + user_err ~loc ~hdr:"universe_context" + ((str(CString.plural n "Universe") ++ spc () ++ Univ.LSet.pr (pr_uctx_level ctx) left ++ spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")) diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp index 2d5c40894..919ca3ad7 100644 --- a/grammar/q_util.mlp +++ b/grammar/q_util.mlp @@ -70,8 +70,8 @@ let rec mlexpr_of_prod_entry_key f = function | Uentryl (e, l) -> (** Keep in sync with Pcoq! *) assert (e = "tactic"); - if l = 5 then <:expr< Extend.Aentry (Pcoq.Tactic.binder_tactic) >> - else <:expr< Extend.Aentryl (Pcoq.Tactic.tactic_expr) $mlexpr_of_int l$ >> + if l = 5 then <:expr< Extend.Aentry (Pltac.binder_tactic) >> + else <:expr< Extend.Aentryl (Pltac.tactic_expr) $mlexpr_of_int l$ >> let rec type_of_user_symbol = function | Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) -> diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index a1b3f4f25..175853d50 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -61,7 +61,7 @@ let rec mlexpr_of_symbol = function <:expr< Extend.Uentry (Genarg.ArgT.Any $arg$) >> | Uentryl (e, l) -> assert (e = "tactic"); - let arg = get_argt <:expr< Constrarg.wit_tactic >> in + let arg = get_argt <:expr< Tacarg.wit_tactic >> in <:expr< Extend.Uentryl (Genarg.ArgT.Any $arg$) $mlexpr_of_int l$>> let make_prod_item = function diff --git a/ide/ide.mllib b/ide/ide.mllib index b2f32fcf7..72a14134b 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -1,12 +1,7 @@ Minilib -Okey -Config_file -Configwin_keys -Configwin_types Configwin_messages Configwin_ihm Configwin -Editable_cells Config_parser Tags Wg_Notebook diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 5b07d3ec3..48fd0a93e 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -13,6 +13,10 @@ open Util open Pp open Printer +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration +module CompactedDecl = Context.Compacted.Declaration + (** Ide_slave : an implementation of [Interface], i.e. mainly an interp function and a rewind function. This specialized loop is triggered when the -ideslave option is passed to Coqtop. Currently CoqIDE is @@ -96,7 +100,7 @@ let is_undo cmd = match cmd with (** Check whether a command is forbidden by CoqIDE *) let coqide_cmd_checks (loc,ast) = - let user_error s = CErrors.user_err_loc (loc, "CoqIde", str s) in + let user_error s = CErrors.user_err ~loc ~hdr:"CoqIde" (str s) in if is_debug ast then user_error "Debug mode not available within CoqIDE"; if is_known_option ast then @@ -133,7 +137,8 @@ let annotate phrase = (** Goal display *) let hyp_next_tac sigma env decl = - let (id,_,ast) = Context.Named.Declaration.to_tuple decl in + let id = NamedDecl.get_id decl in + let ast = NamedDecl.get_type decl in let id_s = Names.Id.to_string id in let type_s = string_of_ppcmds (pr_ltype_env env sigma ast) in [ @@ -190,16 +195,12 @@ let process_goal sigma g = Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr) in let process_hyp d (env,l) = - let d = Context.NamedList.Declaration.map_constr (Reductionops.nf_evar sigma) d in - let d' = List.map (fun name -> let open Context.Named.Declaration in - match pi2 d with - | None -> LocalAssum (name, pi3 d) - | Some value -> LocalDef (name, value, pi3 d)) - (pi1 d) in + let d = CompactedDecl.map_constr (Reductionops.nf_evar sigma) d in + let d' = CompactedDecl.to_named_context d in (List.fold_right Environ.push_named d' env, - (Richpp.richpp_of_pp (pr_var_list_decl env sigma d)) :: l) in + (Richpp.richpp_of_pp (pr_compacted_decl env sigma d)) :: l) in let (_env, hyps) = - Context.NamedList.fold process_hyp + Context.Compacted.fold process_hyp (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in { Interface.goal_hyp = List.rev hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } @@ -300,7 +301,7 @@ let dirpath_of_string_list s = let id = try Nametab.full_name_module qid with Not_found -> - CErrors.errorlabstrm "Search.interface_search" + CErrors.user_err ~hdr:"Search.interface_search" (str "Module " ++ str path ++ str " not found.") in id diff --git a/ide/richprinter.ml b/ide/richprinter.ml index 5f39f36ea..995cef1ac 100644 --- a/ide/richprinter.ml +++ b/ide/richprinter.ml @@ -2,7 +2,6 @@ open Richpp module RichppConstr = Ppconstr.Richpp module RichppVernac = Ppvernac.Richpp -module RichppTactic = Pptactic.Richpp type rich_pp = Ppannotation.t Richpp.located Xml_datatype.gxml diff --git a/ide/texmacspp.ml b/ide/texmacspp.ml index 680da7f54..6fbed38fb 100644 --- a/ide/texmacspp.ml +++ b/ide/texmacspp.ml @@ -127,10 +127,6 @@ let xmlProofMode loc name = xmlWithLoc loc "proofmode" ["name",name] [] let xmlProof loc xml = xmlWithLoc loc "proof" [] xml -let xmlRawTactic name rtac = - Element("rawtactic", ["name",name], - [PCData (Pp.string_of_ppcmds (Pptactic.pr_raw_tactic rtac))]) - let xmlSectionSubsetDescr name ssd = Element("sectionsubsetdescr",["name",name], [PCData (Proof_using.to_string ssd)]) @@ -744,7 +740,7 @@ let rec tmpp v loc = | VernacShow _ as x -> xmlTODO loc x | VernacCheckGuard as x -> xmlTODO loc x | VernacProof (tac,using) -> - let tac = Option.map (xmlRawTactic "closingtactic") tac in + let tac = None (** FIXME *) in let using = Option.map (xmlSectionSubsetDescr "using") using in xmlProof loc (Option.List.(cons tac (cons using []))) | VernacProofMode name -> xmlProofMode loc name diff --git a/ide/utils/config_file.ml b/ide/utils/config_file.ml deleted file mode 100644 index 4d0aabeb6..000000000 --- a/ide/utils/config_file.ml +++ /dev/null @@ -1,640 +0,0 @@ -(*********************************************************************************) -(* Cameleon *) -(* *) -(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. *) -(* *) -(* This program is free software; you can redistribute it and/or modify *) -(* it under the terms of the GNU Library General Public License as *) -(* published by the Free Software Foundation; either version 2 of the *) -(* License, or any later version. *) -(* *) -(* This program 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 Library General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU Library General Public *) -(* License along with this program; if not, write to the Free Software *) -(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) -(* 02111-1307 USA *) -(* *) -(* Contact: Maxence.Guesdon@inria.fr *) -(* *) -(*********************************************************************************) - -(* TODO *) -(* section comments *) -(* better obsoletes: no "{}", line cuts *) - -(* possible improvements: *) -(* use lex/yacc instead of genlex to be more robust, efficient, allow arrays and other types, read comments. *) -(* description and help, level (beginner/advanced/...) for each cp *) -(* find an option from its name and group *) -(* class hooks *) -(* get the sections of a group / of a file *) -(* read file format from inifiles and ConfigParser *) - - -(* Read the mli before reading this file! *) - - -(* ******************************************************************************** *) -(* ******************************** misc utilities ******************************** *) -(* ******************************************************************************** *) -(* This code is intended to be usable without any dependencies. *) - -(* pipeline style, see for instance Raw.of_channel. *) -let (|>) x f = f x - -(* as List.assoc, but applies f to the element matching [key] and returns the list -where this element has been replaced by the result of f. *) -let rec list_assoc_remove key f = function - | [] -> raise Not_found - | (key',value) as elt :: tail -> - if key <> key' - then elt :: list_assoc_remove key f tail - else match f value with - | None -> tail - | Some a -> (key',a) :: tail - -(* reminiscent of String.concat. Same as [Queue.iter f1 queue] - but calls [f2 ()] between each calls to f1. - Does not call f2 before the first call nor after the last call to f2. - Could be more efficient with a richer module interface of Queue. -*) -let queue_iter_between f1 f2 queue = -(* let f flag elt = if flag then f2 (); (f1 elt:unit); true in *) - let f flag elt = if flag then f2 (); f1 elt; true in - ignore (Queue.fold f false queue) - -let list_iter_between f1 f2 = function - [] -> () - | a::[] -> f1 a - | a::tail -> f1 a; List.iter (fun elt -> (f2 ():unit); f1 elt) tail -(* | a::tail -> f1 a; List.iter (fun elt -> f2 (); f1 elt) tail *) -(* !! types ??? *) - -(* to ensure that strings will be parsed correctly by Genlex. -It's more comfortable not to have quotes around the string, but sometimes it's necessary. *) -exception Unsafe_string -let safe_string s = - if s = "" - then "\"\"" - else if ( - try match s.[0] with - | 'a'..'z' | 'A'..'Z' -> - for i = 1 to String.length s - 1 do - match s.[i] with - 'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> () - | _ -> raise Unsafe_string - done; - false - | _ -> - try - string_of_int (int_of_string s) <> s || - string_of_float (float_of_string s) <> s - with Failure "int_of_string" | Failure "float_of_string" -> true - with Unsafe_string -> true) - then Printf.sprintf "\"%s\"" (String.escaped s) - else s - - -(* ******************************************************************************** *) -(* ************************************* core ************************************* *) -(* ******************************************************************************** *) - -module Raw = struct - type cp = - | String of string - | Int of int - | Float of float - | List of cp list - | Tuple of cp list - | Section of (string * cp) list - -(* code generated by -camlp4 pa_o.cmo pa_op.cmo pr_o.cmo -- -o config_file_parser.ml -impl config_file_parser.ml4 -Unreadable on purpose, edit the file config_file_parser.ml4 rather than editing this (huge) lines. Then manually copy-paste here the content of config_file_parser.ml. -Could be one day rewritten with ocamllex/yacc to be more robust, efficient, allow arrays, read comments...*) - module Parse = struct - let lexer = Genlex.make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","] - let rec file l (strm__ : _ Stream.t) = match try Some (ident strm__) with Stream.Failure -> None with Some id -> begin match Stream.peek strm__ with Some (Genlex.Kwd "=") -> Stream.junk strm__; let v = try value strm__ with Stream.Failure -> raise (Stream.Error "") in begin try file ((id, v) :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> raise (Stream.Error "") end | _ -> List.rev l - and value (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd "{") -> Stream.junk strm__; let v = try file [] strm__ with Stream.Failure -> raise (Stream.Error "") in begin match Stream.peek strm__ with Some (Genlex.Kwd "}") -> Stream.junk strm__; Section v | _ -> raise (Stream.Error "") end | Some (Genlex.Ident s) -> Stream.junk strm__; String s | Some (Genlex.String s) -> Stream.junk strm__; String s | Some (Genlex.Int i) -> Stream.junk strm__; Int i | Some (Genlex.Float f) -> Stream.junk strm__; Float f | Some (Genlex.Char c) -> Stream.junk strm__; String (String.make 1 c) | Some (Genlex.Kwd "[") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in List v | Some (Genlex.Kwd "(") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in Tuple v | _ -> raise Stream.Failure - and ident (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Ident s) -> Stream.junk strm__; s | Some (Genlex.String s) -> Stream.junk strm__; s | _ -> raise Stream.Failure - and list l (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd ";") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | Some (Genlex.Kwd ",") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match try Some (value strm__) with Stream.Failure -> None with Some v -> begin try list (v :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match Stream.peek strm__ with Some (Genlex.Kwd "]") -> Stream.junk strm__; List.rev l | Some (Genlex.Kwd ")") -> Stream.junk strm__; List.rev l | _ -> raise Stream.Failure - end - - open Format - (* formating convention: the caller has to open the box, close it and flush the output *) - (* remarks on Format: - set_margin forces a call to set_max_indent - sprintf et bprintf are flushed at each call*) - - (* pretty print a Raw.cp *) - let rec save formatter = function - | String s -> fprintf formatter "%s" (safe_string s) (* How can I cut lines and *) - | Int i -> fprintf formatter "%d" i (* print backslashes just before the \n? *) - | Float f -> fprintf formatter "%g" f - | List l -> - fprintf formatter "[@[<b0>"; - list_iter_between - (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]") - (fun () -> fprintf formatter ";@ ") - l; - fprintf formatter "@]]" - | Tuple l -> - fprintf formatter "(@[<b0>"; - list_iter_between - (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]") - (fun () -> fprintf formatter ",@ ") - l; - fprintf formatter "@])" - | Section l -> - fprintf formatter "{@;<0 2>@[<hv0>"; - list_iter_between - (fun (name,value) -> - fprintf formatter "@[<hov2>%s =@ @[<b2>" name; - save formatter value; - fprintf formatter "@]@]";) - (fun () -> fprintf formatter "@;<2 0>") - l; - fprintf formatter "@]}" - -(* let to_string r = save str_formatter r; flush_str_formatter () *) - let to_channel out_channel r = - let f = formatter_of_out_channel out_channel in - fprintf f "@[<b2>"; save f r; fprintf f "@]@?" - - let of_string s = s |> Stream.of_string |> Parse.lexer |> Parse.value - - let of_channel in_channel = - let result = in_channel |> Stream.of_channel |> Parse.lexer |> Parse.file [] in - close_in in_channel; - result -end - -(* print the given string in a way compatible with Format. - Truncate the lines when needed, indent the newlines.*) -let print_help formatter = - String.iter (function - | ' ' -> Format.pp_print_space formatter () - | '\n' -> Format.pp_force_newline formatter () - | c -> Format.pp_print_char formatter c) - -type 'a wrappers = { - to_raw : 'a -> Raw.cp; - of_raw : Raw.cp -> 'a} - -class type ['a] cp = object -(* method private to_raw = wrappers.to_raw *) -(* method private of_raw = wrappers.of_raw *) -(* method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set *) - method add_hook : ('a -> 'a -> unit) -> unit - method get : 'a - method get_default : 'a - method set : 'a -> unit - method reset : unit - - method get_formatted : Format.formatter -> unit - method get_default_formatted : Format.formatter -> unit - method get_help_formatted : Format.formatter -> unit - - method get_name : string list - method get_short_name : string option - method set_short_name : string -> unit - method get_help : string - method get_spec : Arg.spec - - method set_raw : Raw.cp -> unit -end - -type groupable_cp = < - get_name : string list; - get_short_name : string option; - get_help : string; - - get_formatted : Format.formatter -> unit; - get_default_formatted : Format.formatter -> unit; - get_help_formatted : Format.formatter -> unit; - get_spec : Arg.spec; - - reset : unit; - set_raw : Raw.cp -> unit; > - -exception Double_name -exception Missing_cp of groupable_cp -exception Wrong_type of (out_channel -> unit) - -(* Two exceptions to stop the iteration on queues. *) -exception Found -exception Found_cp of groupable_cp - -(* The data structure to store the cps. -It's a tree, each node is a section, and a queue of sons with their name. -Each leaf contains a cp. *) -type 'a nametree = - | Immediate of 'a - | Subsection of ((string * 'a nametree) Queue.t) - (* this Queue must be nonempty for group.read.choose *) - -class group = object (self) - val mutable cps = Queue.create () (* hold all the added cps, in a nametree. *) - - method add : 'a. 'a cp -> unit = fun original_cp -> - let cp = (original_cp :> groupable_cp) in - (* function called when we reach the end of the list cp#get_name. *) - let add_immediate name cp queue = - Queue.iter (fun (name',_) -> if name = name' then raise Double_name) queue; - Queue.push (name, Immediate cp) queue in - (* adds the cp with name [first_name::last_name] in section [section]. *) - let rec add_in_section section first_name last_name cp queue = - let sub_add = match last_name with (* what to do once we have find the correct section *) - | [] -> add_immediate first_name - | middle_name :: last_name -> add_in_section first_name middle_name last_name in - try - Queue.iter - (function - | name, Subsection subsection when name = section -> - sub_add cp subsection; raise Found - | _ -> ()) - queue; - let sub_queue = Queue.create () in - sub_add cp sub_queue; - Queue.push (section, Subsection sub_queue) queue - with Found -> () in - (match cp#get_name with - | [] -> failwith "empty name" - | first_name :: [] -> add_immediate first_name cp cps - | first_name :: middle_name :: last_name -> - add_in_section first_name middle_name last_name cp cps) - - method write ?(with_help=true) filename = - let out_channel = open_out filename in - let formatter = Format.formatter_of_out_channel out_channel in - let print = Format.fprintf formatter in - print "@[<v>"; - let rec save_queue formatter = - queue_iter_between - (fun (name,nametree) -> save_nametree name nametree) - (Format.pp_print_cut formatter) - and save_nametree name = function - | Immediate cp -> - if with_help && cp#get_help <> "" then - (print "@[<hov3>(* "; cp#get_help_formatted formatter; - print "@ *)@]@,"); - Format.fprintf formatter "@[<hov2>%s =@ @[<b2>" (safe_string name); - cp#get_formatted formatter; - print "@]@]" - | Subsection queue -> - Format.fprintf formatter "%s = {@;<0 2>@[<v>" (safe_string name); - save_queue formatter queue; - print "@]@,}" in - save_queue formatter cps; - print "@]@."; close_out out_channel - - method read ?obsoletes ?(no_default=false) - ?(on_type_error = fun groupable_cp raw_cp output filename in_channel -> - close_in in_channel; - Printf.eprintf - "Type error while loading configuration parameter %s from file %s.\n%!" - (String.concat "." groupable_cp#get_name) filename; - output stderr; - exit 1) - filename = - (* [filename] is created if it doesn't exist. In this case there is no need to read it. *) - match Sys.file_exists filename with false -> self#write filename | true -> - let in_channel = open_in filename in - (* what to do when a cp is missing: *) - let missing cp default = if no_default then raise (Missing_cp cp) else default in - (* returns a cp contained in the nametree queue, which must be nonempty *) - let choose queue = - let rec iter q = Queue.iter (function - | _, Immediate cp -> raise (Found_cp cp) - | _, Subsection q -> iter q) q in - try iter queue; failwith "choose" with Found_cp cp -> cp in - (* [set_and_remove raw_cps nametree] sets the cp of [nametree] to their value - defined in [raw_cps] and returns the remaining raw_cps. *) - let set_cp cp value = - try cp#set_raw value - with Wrong_type output -> on_type_error cp value output filename in_channel in - let rec set_and_remove raw_cps = function - | name, Immediate cp -> - (try list_assoc_remove name (fun value -> set_cp cp value; None) raw_cps - with Not_found -> missing cp raw_cps) - | name, Subsection queue -> - (try list_assoc_remove name - (function - | Raw.Section l -> - (match remainings l queue with - | [] -> None - | l -> Some (Raw.Section l)) - | r -> missing (choose queue) (Some r)) - raw_cps - with Not_found -> missing (choose queue) raw_cps) - and remainings raw_cps queue = Queue.fold set_and_remove raw_cps queue in - let remainings = remainings (Raw.of_channel in_channel) cps in - (* Handling of cps defined in filename but not belonging to self. *) - if remainings <> [] then match obsoletes with - | Some filename -> - let out_channel = - open_out filename in -(* open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] 0o666 filename in *) - let formatter = Format.formatter_of_out_channel out_channel in - Format.fprintf formatter "@[<v>"; - Raw.save formatter (Raw.Section remainings); - Format.fprintf formatter "@]@."; - close_out out_channel - | None -> () - - method command_line_args ~section_separator = - let print = Format.fprintf Format.str_formatter in (* shortcut *) - let result = ref [] in let push x = result := x :: !result in - let rec iter = function - | _, Immediate cp -> - let key = "-" ^ String.concat section_separator cp#get_name in - let spec = cp#get_spec in - let doc = ( - print "@[<hv5>"; - Format.pp_print_as Format.str_formatter (String.length key +3) ""; - if cp#get_help <> "" - then (print "@,@[<b2>"; cp#get_help_formatted Format.str_formatter; print "@]@ ") - else print "@,"; - print "@[<hv>@[current:@;<1 2>@[<hov1>"; cp#get_formatted Format.str_formatter; - print "@]@],@ @[default:@;<1 2>@[<b2>"; cp#get_default_formatted Format.str_formatter; - print "@]@]@]@]"; - Format.flush_str_formatter ()) in - (match cp#get_short_name with - | None -> () - | Some short_name -> push ("-" ^ short_name,spec,"")); - push (key,spec,doc) - | _, Subsection queue -> Queue.iter iter queue in - Queue.iter iter cps; - List.rev !result -end - - -(* Given wrappers for the type 'a, cp_custom_type defines a class 'a cp. *) -class ['a] cp_custom_type wrappers - ?group:(group:group option) name ?short_name default help = -object (self) - method private to_raw = wrappers.to_raw - method private of_raw = wrappers.of_raw - - val mutable value = default - (* output *) - method get = value - method get_default = default - method get_formatted formatter = self#get |> self#to_raw |> Raw.save formatter - method get_default_formatted formatter = self#get_default |> self#to_raw |> Raw.save formatter - (* input *) - method set v = let v' = value in value <- v; self#exec_hooks v' v - method set_raw v = self#of_raw v |> self#set - method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set - method reset = self#set self#get_default - - (* name *) - val mutable shortname = short_name - method get_name = name - method get_short_name = shortname - method set_short_name s = shortname <- Some s - - (* help *) - method get_help = help - method get_help_formatted formatter = print_help formatter self#get_help - method get_spec = Arg.String self#set_string - - (* hooks *) - val mutable hooks = [] - method add_hook f = hooks <- (f:'a->'a->unit) :: hooks - method private exec_hooks v' v = List.iter (fun f -> f v' v) hooks - - initializer match group with Some g -> g#add (self :> 'a cp) | None -> () -end - - -(* ******************************************************************************** *) -(* ****************************** predefined classes ****************************** *) -(* ******************************************************************************** *) - -let int_wrappers = { - to_raw = (fun v -> Raw.Int v); - of_raw = function - | Raw.Int v -> v - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Int expected, got %a\n%!" Raw.to_channel r))} -class int_cp ?group name ?short_name default help = object (self) - inherit [int] cp_custom_type int_wrappers ?group name ?short_name default help - method get_spec = Arg.Int self#set -end - -let float_wrappers = { - to_raw = (fun v -> Raw.Float v); - of_raw = function - | Raw.Float v -> v - | Raw.Int v -> float v - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Float expected, got %a\n%!" Raw.to_channel r)) -} -class float_cp ?group name ?short_name default help = object (self) - inherit [float] cp_custom_type float_wrappers ?group name ?short_name default help - method get_spec = Arg.Float self#set -end - -(* The Pervasives version is too restrictive *) -let bool_of_string s = - match String.lowercase s with - | "false" | "no" | "n" | "0" -> false (* "0" and "1" aren't used. *) - | "true" | "yes" | "y" | "1" -> true - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Bool expected, got %s\n%!" r)) -let bool_wrappers = { - to_raw = (fun v -> Raw.String (string_of_bool v)); - of_raw = function - | Raw.String v -> bool_of_string v - | Raw.Int v -> v <> 0 - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Bool expected, got %a\n%!" Raw.to_channel r)) -} -class bool_cp ?group name ?short_name default help = object (self) - inherit [bool] cp_custom_type bool_wrappers ?group name ?short_name default help - method get_spec = Arg.Bool self#set -end - -let string_wrappers = { - to_raw = (fun v -> Raw.String v); - of_raw = function - | Raw.String v -> v - | Raw.Int v -> string_of_int v - | Raw.Float v -> string_of_float v - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.String expected, got %a\n%!" Raw.to_channel r)) -} -class string_cp ?group name ?short_name default help = object (self) - inherit [string] cp_custom_type string_wrappers ?group name ?short_name default help - method private of_string s = s - method get_spec = Arg.String self#set -end - -let list_wrappers wrappers = { - to_raw = (fun l -> Raw.List (List.map wrappers.to_raw l)); - of_raw = function - | Raw.List l -> List.map wrappers.of_raw l - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.List expected, got %a\n%!" Raw.to_channel r)) -} -class ['a] list_cp wrappers = ['a list] cp_custom_type (list_wrappers wrappers) - -let option_wrappers wrappers = { - to_raw = (function - | Some v -> wrappers.to_raw v - | None -> Raw.String ""); - of_raw = function - | Raw.String s as v -> ( - if s = "" || s = "None" then None - else if String.length s >= 5 && String.sub s 0 5 = "Some " - then Some (wrappers.of_raw (Raw.String (String.sub s 5 (String.length s -5)))) - else Some (wrappers.of_raw v)) - | r -> Some (wrappers.of_raw r)} -class ['a] option_cp wrappers = ['a option] cp_custom_type (option_wrappers wrappers) - -let enumeration_wrappers enum = - let switched = List.map (fun (string,cons) -> cons,string) enum in - {to_raw = (fun v -> Raw.String (List.assq v switched)); - of_raw = function - | Raw.String s -> - (try List.assoc s enum - with Not_found -> failwith (Printf.sprintf "%s isn't a known constructor" s)) - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw enumeration expected, got %a\n%!" Raw.to_channel r)) -} -class ['a] enumeration_cp enum ?group name ?short_name default help = object (self) - inherit ['a] cp_custom_type (enumeration_wrappers enum) - ?group name ?short_name default help - method get_spec = Arg.Symbol (List.map fst enum, (fun s -> self#set (List.assoc s enum))) -end - -let tuple2_wrappers wrapa wrapb = { - to_raw = (fun (a,b) -> Raw.Tuple [wrapa.to_raw a; wrapb.to_raw b]); - of_raw = function - | Raw.Tuple [a;b] -> wrapa.of_raw a, wrapb.of_raw b - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Tuple 2 expected, got %a\n%!" Raw.to_channel r)) -} -class ['a, 'b] tuple2_cp wrapa wrapb = ['a*'b] cp_custom_type (tuple2_wrappers wrapa wrapb) - -let tuple3_wrappers wrapa wrapb wrapc = { - to_raw = (fun (a,b,c) -> Raw.Tuple[wrapa.to_raw a; wrapb.to_raw b; wrapc.to_raw c]); - of_raw = function - | Raw.Tuple [a;b;c] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Tuple 3 expected, got %a\n%!" Raw.to_channel r)) -} -class ['a,'b,'c] tuple3_cp wrapa wrapb wrapc = - ['a*'b*'c] cp_custom_type (tuple3_wrappers wrapa wrapb wrapc) - -let tuple4_wrappers wrapa wrapb wrapc wrapd = { - to_raw=(fun (a,b,c,d)->Raw.Tuple[wrapa.to_raw a;wrapb.to_raw b;wrapc.to_raw c;wrapd.to_raw d]); - of_raw = function - | Raw.Tuple [a;b;c;d] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c, wrapd.of_raw d - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Tuple 4 expected, got %a\n%!" Raw.to_channel r)) -} -class ['a,'b,'c,'d] tuple4_cp wrapa wrapb wrapc wrapd = - ['a*'b*'c*'d] cp_custom_type (tuple4_wrappers wrapa wrapb wrapc wrapd) - -class string2_cp = [string,string] tuple2_cp string_wrappers string_wrappers -(* class color_cp = string_cp *) -class font_cp = string_cp -class filename_cp = string_cp - - -(* ******************************************************************************** *) -(******************** Backward compatibility with module Flags.****************** *) -(* ******************************************************************************** *) - -type 'a option_class = 'a wrappers -type 'a option_record = 'a cp -type options_file = {mutable filename:string; group:group} - -let create_options_file filename = {filename = filename; group = new group} -let set_options_file options_file filename = options_file.filename <- filename -let load {filename=f; group = g} = g#read f -let append {group=g} filename = g#read filename -let save {filename=f; group = g} = g#write ~with_help:false f -let save_with_help {filename=f; group = g} = g#write ~with_help:true f -let define_option {group=group} name help option_class default = - (new cp_custom_type option_class ~group name default help) -let option_hook cp f = cp#add_hook (fun _ _ -> f ()) - -let string_option = string_wrappers -let color_option = string_wrappers -let font_option = string_wrappers -let int_option = int_wrappers -let bool_option = bool_wrappers -let float_option = float_wrappers -let string2_option = tuple2_wrappers string_wrappers string_wrappers - -let option_option = option_wrappers -let list_option = list_wrappers -let sum_option = enumeration_wrappers -let tuple2_option (a,b) = tuple2_wrappers a b -let tuple3_option (a,b,c) = tuple3_wrappers a b c -let tuple4_option (a,b,c,d) = tuple4_wrappers a b c d - -let ( !! ) cp = cp#get -let ( =:= ) cp value = cp#set value - -let shortname cp = String.concat ":" cp#get_name -let get_help cp = cp#get_help - -type option_value = - Module of option_module -| StringValue of string -| IntValue of int -| FloatValue of float -| List of option_value list -| SmallList of option_value list -and option_module = (string * option_value) list - -let rec value_to_raw = function - | Module a -> Raw.Section (List.map (fun (name,value) -> name, value_to_raw value) a) - | StringValue a -> Raw.String a - | IntValue a -> Raw.Int a - | FloatValue a -> Raw.Float a - | List a -> Raw.List (List.map value_to_raw a) - | SmallList a -> Raw.Tuple (List.map value_to_raw a) -let rec raw_to_value = function - | Raw.String a -> StringValue a - | Raw.Int a -> IntValue a - | Raw.Float a -> FloatValue a - | Raw.List a -> List (List.map raw_to_value a) - | Raw.Tuple a -> SmallList (List.map raw_to_value a) - | Raw.Section a -> Module (List.map (fun (name,value) -> name, raw_to_value value) a) - -let define_option_class _ of_option_value to_option_value = - {to_raw = (fun a -> a |> to_option_value |> value_to_raw); - of_raw = (fun a -> a |> raw_to_value |> of_option_value)} - -let to_value {to_raw = to_raw} a = a |> to_raw |> raw_to_value -let from_value {of_raw = of_raw} a = a |> value_to_raw |> of_raw - -let of_value_w wrappers a = a |> value_to_raw |> wrappers.of_raw -let to_value_w wrappers a = a |> wrappers.to_raw |> raw_to_value -(* fancy indentation when finishing this stub code, not good style :-) *) -let value_to_string : option_value -> string = of_value_w string_option -let string_to_value = to_value_w string_option -let value_to_int = of_value_w int_option -let int_to_value = to_value_w int_option -let value_to_bool = of_value_w bool_option -let bool_to_value = to_value_w bool_option -let value_to_float = of_value_w float_option -let float_to_value = to_value_w float_option -let value_to_string2 = of_value_w string2_option -let string2_to_value = to_value_w string2_option -let value_to_list of_value = - let wrapper = define_option_class "" of_value (fun _ -> failwith "value_to_list") in - of_value_w (list_option wrapper) -let list_to_value to_value = - let wrapper = define_option_class "" (fun _ -> failwith "value_to_list") to_value in - to_value_w (list_option wrapper) diff --git a/ide/utils/config_file.mli b/ide/utils/config_file.mli deleted file mode 100644 index 22328e7f1..000000000 --- a/ide/utils/config_file.mli +++ /dev/null @@ -1,352 +0,0 @@ -(*********************************************************************************) -(* Cameleon *) -(* *) -(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. *) -(* *) -(* This program is free software; you can redistribute it and/or modify *) -(* it under the terms of the GNU Library General Public License as *) -(* published by the Free Software Foundation; either version 2 of the *) -(* License, or any later version. *) -(* *) -(* This program 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 Library General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU Library General Public *) -(* License along with this program; if not, write to the Free Software *) -(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) -(* 02111-1307 USA *) -(* *) -(* Contact: Maxence.Guesdon@inria.fr *) -(* *) -(*********************************************************************************) - -(** - This module implements a mechanism to handle configuration files. - A configuration file is defined as a set of [variable = value] lines, - where value can be - a simple string (types int, string, bool...), - a list of values between brackets (lists) or parentheses (tuples), - or a set of [variable = value] lines between braces. - The configuration file is automatically loaded and saved, - and configuration parameters are manipulated inside the program as easily as references. - - Object implementation by Jean-Baptiste Rouquier. -*) - -(** {1:lowlevelinterface Low level interface} *) -(** Skip this section on a first reading... *) - -(** The type of cp freshly parsed from configuration file, -not yet wrapped in their proper type. *) -module Raw : sig - type cp = - | String of string (** base types, reproducing the tokens of Genlex *) - | Int of int - | Float of float - | List of cp list (** compound types *) - | Tuple of cp list - | Section of (string * cp) list - - (** A parser. *) - val of_string : string -> cp - - (** Used to print the values into a log file for instance. *) - val to_channel : out_channel -> cp -> unit -end - -(** A type used to specialize polymorphics classes and define new classes. - {!Config_file.predefinedwrappers} are provided. - *) -type 'a wrappers = { to_raw : 'a -> Raw.cp; of_raw : Raw.cp -> 'a; } - -(** An exception raised by {!Config_file.cp.set_raw} - when the argument doesn't have a suitable {!Config_file.Raw.cp} type. - The function explains the problem and flush the output.*) -exception Wrong_type of (out_channel -> unit) - -(* (\** {2 Miscellaneous functions} *\) *) - -(* val bool_of_string : string -> bool *) - -(** {1 High level interface} *) -(** {2 The two main classes} *) - -(** A Configuration Parameter, in short cp, ie - a value we can store in and read from a configuration file. *) -class type ['a] cp = object - (** {1 Accessing methods} *) - - method get : 'a - method set : 'a -> unit - method get_default : 'a - method get_help : string - method get_name : string list - - (** Resets to the default value. *) - method reset : unit - - (** {1 Miscellaneous} *) - - (** All the hooks are executed each time the method set is called, - just after setting the new value.*) - method add_hook : ('a -> 'a -> unit) -> unit - - (** Used to generate command line arguments in {!Config_file.group.command_line_args} *) - method set_short_name : string -> unit - - (** [None] if no optional short_name was provided during object creation - and [set_short_name] was never called.*) - method get_short_name : string option - - (** {1 Methods for internal use} *) - - method get_formatted : Format.formatter -> unit - method get_default_formatted : Format.formatter -> unit - method get_help_formatted : Format.formatter -> unit - - method get_spec : Arg.spec - method set_raw : Raw.cp -> unit -end - -(** Unification over all possible ['a cp]: - contains the main methods of ['a cp] except the methods using the type ['a]. - A [group] manipulates only [groupable_cp] for homogeneity. *) -type groupable_cp = < - get_name : string list; - get_short_name : string option; - get_help : string; - - get_formatted : Format.formatter -> unit; - get_default_formatted : Format.formatter -> unit; - get_help_formatted : Format.formatter -> unit; - get_spec : Arg.spec; - - reset : unit; - set_raw : Raw.cp -> unit; > - -(** Raised in case a name is already used. - See {!Config_file.group.add} *) -exception Double_name - -(** An exception possibly raised if we want to check that - every cp is defined in a configuration file. - See {!Config_file.group.read}. -*) -exception Missing_cp of groupable_cp - -(** A group of cps, that can be loaded and saved, -or used to generate command line arguments. - -The basic usage is to have only one group and one configuration file, -but this mechanism allows having more, -for instance having another smaller group for the options to pass on the command line. -*) -class group : object - (** Adds a cp to the group. - Note that the type ['a] must be lost - to allow cps of different types to belong to the same group. - @raise Double_name if [cp#get_name] is already used. *) -(* method add : 'a cp -> 'a cp *) - method add : 'a cp -> unit - - (**[write filename] saves all the cps into the configuration file [filename].*) - method write : ?with_help:bool -> string -> unit - - (** [read filename] reads [filename] - and stores the values it specifies into the cps belonging to this group. - The file is created (and not read) if it doesn't exists. - In the default behaviour, no warning is issued - if not all cps are updated or if some values of [filename] aren't used. - - If [obsoletes] is specified, - then prints in this file all the values that are - in [filename] but not in this group. - Those cps are likely to be erroneous or obsolete. - Opens this file only if there is something to write in it. - - If [no_default] is [true], then raises [Missing_cp foo] if - the cp [foo] isn't defined in [filename] but belongs to this group. - - [on_type_error groupable_cp value output filename in_channel] - is called if the file doesn't give suitable value - (string instead of int for instance, or a string not belonging to the expected enumeration) - for the cp [groupable_cp]. - [value] is the value read from the file, - [output] is the argument of {!Config_file.Wrong_type}, - [filename] is the same argument as the one given to read, - and [in_channel] refers to [filename] to allow a function to close it if needed. - Default behaviour is to print an error message and call [exit 1]. -*) - method read : ?obsoletes:string -> ?no_default:bool -> - ?on_type_error : (groupable_cp -> Raw.cp -> (out_channel -> unit) -> - string -> in_channel -> unit) -> - string -> unit - - (** Interface with module Arg. - @param section_separator the string used to concatenate the name of a cp, - to get the command line option name. - ["-"] is a good default. - @return a list that can be used with [Arg.parse] and [Arg.usage].*) - method command_line_args : section_separator:string -> (string * Arg.spec * string) list - end - -(** {2 Predefined cp classes} *) - -(** The last three non-optional arguments are always - [name] (of type string list), [default_value] and [help] (of type string). - - [name] is the path to the cp: [["section";"subsection"; ...; "foo"]]. - It can consists of a single element but must not be empty. - - [short_name] will be added a "-" and used in - {!Config_file.group.command_line_args}. - - [group], if provided, adds the freshly defined option to it - (something like [initializer group#add self]). - - [help] needs not contain newlines, it will be automatically truncated where needed. - It is mandatory but can be [""]. -*) - -class int_cp : ?group:group -> string list -> ?short_name:string -> int -> string -> [int] cp -class float_cp : ?group:group -> string list -> ?short_name:string -> float -> string -> [float] cp -class bool_cp : ?group:group -> string list -> ?short_name:string -> bool -> string -> [bool] cp -class string_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> [string] cp -class ['a] list_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a list -> string -> ['a list] cp -class ['a] option_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a option -> string -> ['a option] cp -class ['a] enumeration_cp : (string * 'a) list -> ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp -class ['a, 'b] tuple2_cp : 'a wrappers -> 'b wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b -> string -> ['a * 'b] cp -class ['a, 'b, 'c] tuple3_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c -> string -> ['a * 'b * 'c] cp -class ['a, 'b, 'c, 'd] tuple4_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c * 'd -> string -> ['a * 'b * 'c * 'd] cp -class string2_cp : ?group:group -> string list -> ?short_name:string -> string * string -> string -> [string, string] tuple2_cp -(* class color_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp *) -class font_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp -class filename_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp - -(** {2:predefinedwrappers Predefined wrappers} *) - -val int_wrappers : int wrappers -val float_wrappers : float wrappers -val bool_wrappers : bool wrappers -val string_wrappers : string wrappers -val list_wrappers : 'a wrappers -> 'a list wrappers -val option_wrappers : 'a wrappers -> 'a option wrappers - -(** If you have a [type suit = Spades | Hearts | Diamond | Clubs], then -{[enumeration_wrappers ["spades",Spades; "hearts",Hearts; "diamond",Diamond; "clubs",Clubs]]} -will allow you to use cp of this type. -For sum types with not only constant constructors, -you will need to define your own cp class. *) -val enumeration_wrappers : (string * 'a) list -> 'a wrappers -val tuple2_wrappers : 'a wrappers -> 'b wrappers -> ('a * 'b) wrappers -val tuple3_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> ('a * 'b * 'c) wrappers -val tuple4_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ('a * 'b * 'c * 'd) wrappers - -(** {2 Defining new cp classes} *) - -(** To define a new cp class, you just have to provide an implementation for the wrappers -between your type [foo] and the type [Raw.cp]. -Once you have your wrappers [w], write -{[class foo_cp = [foo] cp_custom_type w]} - -For further details, have a look at the commented .ml file, -section "predefined cp classes". -*) -class ['a] cp_custom_type : 'a wrappers -> - ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp - - -(** {1 Backward compatibility} - -Deprecated. - -All the functions from the module Options are available, except: - -- [prune_file]: use [group#write ?obsoletes:"foo.ml"]. -- [smalllist_to_value], [smalllist_option]: use lists or tuples. -- [get_class]. -- [class_hook]: hooks are local to a cp. - If you want hooks global to a class, - define a new class that inherit from {!Config_file.cp_custom_type}. -- [set_simple_option], [get_simple_option], [simple_options], [simple_args]: - use {!Config_file.group.write}. -- [set_option_hook]: use {!Config_file.cp.add_hook}. -- [set_string_wrappers]: define a new class with {!Config_file.cp_custom_type}. - -The old configurations files are readable by this module. -*) - - - - - -(**/**) -type 'a option_class -type 'a option_record -type options_file - -val create_options_file : string -> options_file -val set_options_file : options_file -> string -> unit -val load : options_file -> unit -val append : options_file -> string -> unit -val save : options_file -> unit -val save_with_help : options_file -> unit -(* val define_option : options_file -> *) -(* string list -> string -> 'a option_class -> 'a -> 'a option_record *) -val option_hook : 'a option_record -> (unit -> unit) -> unit - -val string_option : string option_class -val color_option : string option_class -val font_option : string option_class -val int_option : int option_class -val bool_option : bool option_class -val float_option : float option_class -val string2_option : (string * string) option_class - -val option_option : 'a option_class -> 'a option option_class -val list_option : 'a option_class -> 'a list option_class -val sum_option : (string * 'a) list -> 'a option_class -val tuple2_option : - 'a option_class * 'b option_class -> ('a * 'b) option_class -val tuple3_option : 'a option_class * 'b option_class * 'c option_class -> - ('a * 'b * 'c) option_class -val tuple4_option : - 'a option_class * 'b option_class * 'c option_class * 'd option_class -> - ('a * 'b * 'c * 'd) option_class - -val ( !! ) : 'a option_record -> 'a -val ( =:= ) : 'a option_record -> 'a -> unit -val shortname : 'a option_record -> string -val get_help : 'a option_record -> string - -type option_value = - Module of option_module -| StringValue of string -| IntValue of int -| FloatValue of float -| List of option_value list -| SmallList of option_value list -and option_module = (string * option_value) list - -val define_option_class : - string -> (option_value -> 'a) -> ('a -> option_value) -> 'a option_class - -val to_value : 'a option_class -> 'a -> option_value -val from_value : 'a option_class -> option_value -> 'a - -val value_to_string : option_value -> string -val string_to_value : string -> option_value -val value_to_int : option_value -> int -val int_to_value : int -> option_value -val bool_of_string : string -> bool -val value_to_bool : option_value -> bool -val bool_to_value : bool -> option_value -val value_to_float : option_value -> float -val float_to_value : float -> option_value -val value_to_string2 : option_value -> string * string -val string2_to_value : string * string -> option_value -val value_to_list : (option_value -> 'a) -> option_value -> 'a list -val list_to_value : ('a -> option_value) -> 'a list -> option_value diff --git a/ide/utils/configwin.ml b/ide/utils/configwin.ml index 4606ef29f..69e8b647a 100644 --- a/ide/utils/configwin.ml +++ b/ide/utils/configwin.ml @@ -36,44 +36,16 @@ type return_button = | Return_ok | Return_cancel -let string_to_key = Configwin_types.string_to_key -let key_to_string = Configwin_types.key_to_string -let key_cp_wrapper = Configwin_types.key_cp_wrapper -class key_cp = Configwin_types.key_cp - - let string = Configwin_ihm.string -let text = Configwin_ihm.text let strings = Configwin_ihm.strings let list = Configwin_ihm.list let bool = Configwin_ihm.bool -let filename = Configwin_ihm.filename -let filenames = Configwin_ihm.filenames -let color = Configwin_ihm.color -let font = Configwin_ihm.font let combo = Configwin_ihm.combo let custom = Configwin_ihm.custom -let date = Configwin_ihm.date -let hotkey = Configwin_ihm.hotkey let modifiers = Configwin_ihm.modifiers -let html = Configwin_ihm.html let edit ?(apply=(fun () -> ())) title ?width ?height conf_struct_list = Configwin_ihm.edit ~with_apply: true ~apply title ?width ?height conf_struct_list - -let get = Configwin_ihm.edit ~with_apply: false ~apply: (fun () -> ()) - -let simple_edit - ?(apply=(fun () -> ())) - title ?width ?height - param_list = Configwin_ihm.simple_edit ~with_apply: true ~apply title ?width ?height param_list - -let simple_get = Configwin_ihm.simple_edit - ~with_apply: false ~apply: (fun () -> ()) - -let box = Configwin_ihm.box - -let tabbed_box = Configwin_ihm.tabbed_box diff --git a/ide/utils/configwin.mli b/ide/utils/configwin.mli index c5fbf39a0..7616e471d 100644 --- a/ide/utils/configwin.mli +++ b/ide/utils/configwin.mli @@ -50,22 +50,6 @@ type return_button = button or the window manager but never clicked on the apply button.*) - -(** {2 The key option class (to use with the {!Config_file} library)} *) - -val string_to_key : string -> Gdk.Tags.modifier list * int - -val key_to_string : Gdk.Tags.modifier list * int -> string - -val key_cp_wrapper : (Gdk.Tags.modifier list * int) Config_file.wrappers - -class key_cp : - ?group:Config_file.group -> - string list -> - ?short_name:string -> - Gdk.Tags.modifier list * int -> - string -> [Gdk.Tags.modifier list * int] Config_file.cp_custom_type - (** {2 Functions to create parameters} *) (** [string label value] creates a string parameter. @@ -136,24 +120,6 @@ val list : ?editable: bool -> ?help: string -> 'a list -> parameter_kind -(** [color label value] creates a color parameter. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the entry widget must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). -*) -val color : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** [font label value] creates a font parameter. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the entry widget must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). -*) -val font : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - (** [combo label choices value] creates a combo parameter. @param editable indicate if the value is editable (default is [true]). @param expand indicate if the entry widget must expand or not (default is [true]). @@ -169,69 +135,6 @@ val combo : ?editable: bool -> ?expand: bool -> ?help: string -> ?new_allowed: bool -> ?blank_allowed: bool -> string -> string list -> string -> parameter_kind -(** [text label value] creates a text parameter. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the box for the text must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). -*) -val text : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** Same as {!Configwin.text} but html bindings are available - in the text widget. Use the [configwin_html_config] utility - to edit your bindings. -*) -val html : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** [filename label value] creates a filename parameter. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the entry widget must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). -*) -val filename : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** [filenames label value] creates a filename list parameter. - @param editable indicate if the value is editable (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). - @param eq the comparison function, used not to have doubles in list. Default - is [Pervasives.(=)]. If you want to allow doubles in the list, give a function - always returning false. -*) -val filenames : ?editable: bool -> ?help: string -> - ?f: (string list -> unit) -> - ?eq: (string -> string -> bool) -> - string -> string list -> parameter_kind - -(** [date label value] creates a date parameter. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the entry widget must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). - @param f_string the function used to display the date as a string. The parameter - is a tupe [(day,month,year)], where [month] is between [0] and [11]. The default - function creates the string [year/month/day]. -*) -val date : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: ((int * int * int) -> unit) -> - ?f_string: ((int * int * int -> string)) -> - string -> (int * int * int) -> parameter_kind - -(** [hotkey label value] creates a hot key parameter. - A hot key is defined by a list of modifiers and a key code. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the entry widget must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). -*) -val hotkey : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: ((Gdk.Tags.modifier list * int) -> unit) -> - string -> (Gdk.Tags.modifier list * int) -> parameter_kind - val modifiers : ?editable: bool -> ?expand: bool -> ?help: string -> ?allow:(Gdk.Tags.modifier list) -> ?f: (Gdk.Tags.modifier list -> unit) -> @@ -259,46 +162,3 @@ val edit : ?height:int -> configuration_structure list -> return_button - -(** This function takes a configuration structure and creates a window used - to get the various parameters from the user. It is the same window as edit but - there is no apply button.*) -val get : - string -> - ?width:int -> - ?height:int -> - configuration_structure list -> - return_button - -(** This function takes a list of parameter specifications and - creates a window to configure the various parameters. - @param apply this function is called when the apply button is clicked, after - giving new values to parameters.*) -val simple_edit : - ?apply: (unit -> unit) -> - string -> - ?width:int -> - ?height:int -> - parameter_kind list -> return_button - -(** This function takes a list of parameter specifications and - creates a window to configure the various parameters, - without Apply button.*) -val simple_get : - string -> - ?width:int -> - ?height:int -> - parameter_kind list -> return_button - -(** Create a [GPack.box] with the list of given parameters, - Return the box and the function to call to apply new values to parameters. -*) -val box : parameter_kind list -> GData.tooltips -> GPack.box * (unit -> unit) - -(** Create a [GPack.box] with the list of given configuration structure list, - and the given list of buttons (defined by their label and callback). - Before calling the callback of a button, the [apply] function - of each parameter is called. -*) -val tabbed_box : configuration_structure list -> - (string * (unit -> unit)) list -> GData.tooltips -> GPack.box diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml index c1062a9db..70133fb9f 100644 --- a/ide/utils/configwin_ihm.ml +++ b/ide/utils/configwin_ihm.ml @@ -27,7 +27,25 @@ open Configwin_types -module O = Config_file +let modifiers_to_string m = + let rec iter m s = + match m with + [] -> s + | c :: m -> + iter m (( + match c with + `CONTROL -> "<ctrl>" + | `SHIFT -> "<shft>" + | `LOCK -> "<lock>" + | `MOD1 -> "<alt>" + | `MOD2 -> "<mod2>" + | `MOD3 -> "<mod3>" + | `MOD4 -> "<mod4>" + | `MOD5 -> "<mod5>" + | _ -> raise Not_found + ) ^ s) + in + iter m "" class type widget = object @@ -35,112 +53,9 @@ class type widget = method apply : unit -> unit end -let file_html_config = Filename.concat Configwin_messages.home ".configwin_html" - let debug = false let dbg s = if debug then Minilib.log s else () -(** Return the config group for the html config file, - and the option for bindings. *) -let html_config_file_and_option () = - let ini = new O.group in - let bindings = new O.list_cp - Configwin_types.htmlbinding_cp_wrapper - ~group: ini - ["bindings"] - ~short_name: "bd" - [ { html_key = Configwin_types.string_to_key "A-b" ; - html_begin = "<b>"; - html_end = "</b>" ; - } ; - { html_key = Configwin_types.string_to_key "A-i" ; - html_begin = "<i>"; - html_end = "</i>" ; - } - ] - "" - in - ini#read file_html_config ; - (ini, bindings) - -(** This variable contains the last directory where the user selected a file.*) -let last_dir = ref "";; - -(** This function allows the user to select a file and returns the - selected file name. An optional function allows changing the - behaviour of the ok button. - A VOIR : mutli-selection ? *) -let select_files ?dir - ?(fok : (string -> unit) option) - the_title = - let files = ref ([] : string list) in - let fs = GWindow.file_selection ~modal:true - ~title: the_title () in - (* we set the previous directory, if no directory is given *) - ( - match dir with - None -> - if !last_dir <> "" then - let _ = fs#set_filename !last_dir in - () - else - () - | Some dir -> - let _ = fs#set_filename !last_dir in - () - ); - - let _ = fs # connect#destroy ~callback: GMain.Main.quit in - let _ = fs # ok_button # connect#clicked ~callback: - (match fok with - None -> - (fun () -> files := [fs#filename] ; fs#destroy ()) - | Some f -> - (fun () -> f fs#filename) - ) - in - let _ = fs # cancel_button # connect#clicked ~callback:fs#destroy in - fs # show (); - GMain.Main.main (); - match !files with - | [] -> - [] - | [""] -> - [] - | l -> - (* we keep the directory in last_dir *) - last_dir := Filename.dirname (List.hd l); - l -;; - -(** Make the user select a date. *) -let select_date title (day,mon,year) = - let v_opt = ref None in - let window = GWindow.dialog ~modal:true ~title () in - let hbox = GPack.hbox ~border_width:10 ~packing:window#vbox#add () in - let cal = GMisc.calendar ~packing: (hbox#pack ~expand: true) () in - cal#select_month ~month: mon ~year: year ; - cal#select_day day; - let bbox = window#action_area in - - let bok = GButton.button ~label: Configwin_messages.mOk - ~packing:(bbox#pack ~expand:true ~padding:4) () - in - let bcancel = GButton.button ~label: Configwin_messages.mCancel - ~packing:(bbox#pack ~expand:true ~padding:4) () - in - ignore (bok#connect#clicked ~callback: - (fun () -> v_opt := Some (cal#date); window#destroy ())); - ignore(bcancel#connect#clicked ~callback: window#destroy); - - bok#grab_default (); - ignore(window#connect#destroy ~callback: GMain.Main.quit); - window#set_position `CENTER; - window#show (); - GMain.Main.main (); - !v_opt - - (** This class builds a frame with a clist and two buttons : one to add items and one to remove the selected items. The class takes in parameter a function used to add items and @@ -460,164 +375,6 @@ class custom_param_box param (tt:GData.tooltips) = method apply = param.custom_f_apply () end -(** This class is used to build a box for a color parameter.*) -class color_param_box param (tt:GData.tooltips) = - let _ = dbg "color_param_box" in - let v = ref param.color_value in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.color_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let w_test = GMisc.arrow - ~kind: `RIGHT - ~shadow: `OUT - ~width: 20 - ~height: 20 - ~packing: (hbox#pack ~expand: false ~padding: 2 ) - () - in - let we = GEdit.entry - ~editable: param.color_editable - ~packing: (hbox#pack ~expand: param.color_expand ~padding: 2) - () - in - let _ = - match param.color_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - let set_color s = - let style = w_test#misc#style#copy in - ( - try style#set_fg [ (`NORMAL, `NAME s) ; ] - with _ -> () - ); - w_test#misc#set_style style; - in - let _ = set_color !v in - let _ = we#set_text !v in - let f_sel () = - let dialog = GWindow.color_selection_dialog - ~title: param.color_label - ~modal: true - ~show: true - () - in - let wb_ok = dialog#ok_button in - let wb_cancel = dialog#cancel_button in - let _ = dialog#connect#destroy ~callback:GMain.Main.quit in - let _ = wb_ok#connect#clicked - ~callback:(fun () -> -(* let color = dialog#colorsel#color in - let r = (Gdk.Color.red color) in - let g = (Gdk.Color.green color)in - let b = (Gdk.Color.blue color) in - let s = Printf.sprintf "#%4X%4X%4X" r g b in - let _ = - for i = 1 to (String.length s) - 1 do - if s.[i] = ' ' then s.[i] <- '0' - done - in - we#set_text s ; *) - dialog#destroy () - ) - in - let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in - GMain.Main.main () - in - let _ = - if param.color_editable then ignore (wb#connect#clicked ~callback:f_sel) - in - - object (self) - (** This method returns the main box ready to be packed. *) - method box = hbox#coerce - (** This method applies the new value of the parameter. *) - method apply = - let new_value = we#text in - if new_value <> param.color_value then - let _ = param.color_f_apply new_value in - param.color_value <- new_value - else - () - - initializer - ignore (we#connect#changed ~callback:(fun () -> set_color we#text)); - - end ;; - -(** This class is used to build a box for a font parameter.*) -class font_param_box param (tt:GData.tooltips) = - let _ = dbg "font_param_box" in - let v = ref param.font_value in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.font_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.font_expand ~padding: 2) - () - in - let _ = - match param.font_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - let set_entry_font font_opt = - match font_opt with - None -> () - | Some s -> - let style = we#misc#style#copy in - ( - try - let font = Gdk.Font.load_fontset s in - style#set_font font - with _ -> () - ); - we#misc#set_style style - in - let _ = set_entry_font (Some !v) in - let _ = we#set_text !v in - let f_sel () = - let dialog = GWindow.font_selection_dialog - ~title: param.font_label - ~modal: true - ~show: true - () - in - dialog#selection#set_font_name !v; - let wb_ok = dialog#ok_button in - let wb_cancel = dialog#cancel_button in - let _ = dialog#connect#destroy ~callback:GMain.Main.quit in - let _ = wb_ok#connect#clicked - ~callback:(fun () -> - let font = dialog#selection#font_name in - we#set_text font ; - set_entry_font (Some font); - dialog#destroy () - ) - in - let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in - GMain.Main.main () - in - let _ = if param.font_editable then ignore (wb#connect#clicked ~callback:f_sel) in - - object (self) - (** This method returns the main box ready to be packed. *) - method box = hbox#coerce - (** This method applies the new value of the parameter. *) - method apply = - let new_value = we#text in - if new_value <> param.font_value then - let _ = param.font_f_apply new_value in - param.font_value <- new_value - else - () - end ;; - (** This class is used to build a box for a text parameter.*) class text_param_box param (tt:GData.tooltips) = let _ = dbg "text_param_box" in @@ -662,35 +419,6 @@ class text_param_box param (tt:GData.tooltips) = () end ;; -(** This class is used to build a box a html parameter. *) -class html_param_box param (tt:GData.tooltips) = - let _ = dbg "html_param_box" in - object (self) - inherit text_param_box param tt - - method private exec html_start html_end () = - let (i1,i2) = wview#buffer#selection_bounds in - let s = i1#get_text ~stop: i2 in - match s with - "" -> - wview#buffer#insert (html_start^html_end) - | _ -> - ignore (wview#buffer#insert ~iter: i2 html_end); - ignore (wview#buffer#insert ~iter: i1 html_start); - wview#buffer#place_cursor ~where: i2 - - initializer - dbg "html_param_box:initializer"; - let (_,html_bindings) = html_config_file_and_option () in - dbg "html_param_box:connecting key press events"; - let add_shortcut hb = - let (mods, k) = hb.html_key in - Okey.add wview ~mods k (self#exec hb.html_begin hb.html_end) - in - List.iter add_shortcut html_bindings#get; - dbg "html_param_box:end" - end - (** This class is used to build a box for a boolean parameter.*) class bool_param_box param (tt:GData.tooltips) = let _ = dbg "bool_param_box" in @@ -719,105 +447,6 @@ class bool_param_box param (tt:GData.tooltips) = () end ;; -(** This class is used to build a box for a file name parameter.*) -class filename_param_box param (tt:GData.tooltips) = - let _ = dbg "filename_param_box" in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.string_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let we = GEdit.entry - ~editable: param.string_editable - ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2) - () - in - let _ = - match param.string_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - let _ = we#set_text (param.string_to_string param.string_value) in - - let f_click () = - match select_files param.string_label with - [] -> - () - | f :: _ -> - we#set_text f - in - let _ = - if param.string_editable then - let _ = wb#connect#clicked ~callback:f_click in - () - else - () - in - - object (self) - (** This method returns the main box ready to be packed. *) - method box = hbox#coerce - (** This method applies the new value of the parameter. *) - method apply = - let new_value = param.string_of_string we#text in - if new_value <> param.string_value then - let _ = param.string_f_apply new_value in - param.string_value <- new_value - else - () - end ;; - -(** This class is used to build a box for a hot key parameter.*) -class hotkey_param_box param (tt:GData.tooltips) = - let _ = dbg "hotkey_param_box" in - let hbox = GPack.hbox () in - let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in - let _wl = GMisc.label ~text: param.hk_label ~packing: wev#add () in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.hk_expand ~padding: 2) - () - in - let value = ref param.hk_value in - let _ = - match param.hk_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in - let _ = we#set_text (Configwin_types.key_to_string param.hk_value) in - let mods_we_dont_care = [`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] in - let capture ev = - let key = GdkEvent.Key.keyval ev in - let modifiers = GdkEvent.Key.state ev in - let mods = List.filter - (fun m -> not (List.mem m mods_we_dont_care)) - modifiers - in - value := (mods, key); - we#set_text (Glib.Convert.locale_to_utf8 (Configwin_types.key_to_string !value)); - false - in - let _ = - if param.hk_editable then - ignore (we#event#connect#key_press ~callback:capture) - else - () - in - - object (self) - (** This method returns the main box ready to be packed. *) - method box = hbox#coerce - (** This method applies the new value of the parameter. *) - method apply = - let new_value = !value in - if new_value <> param.hk_value then - let _ = param.hk_f_apply new_value in - param.hk_value <- new_value - else - () - end ;; - class modifiers_param_box param = let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand:true ~fill:true ~padding: 2) () in @@ -825,7 +454,7 @@ class modifiers_param_box param = let value = ref param.md_value in let _ = List.map (fun modifier -> let but = GButton.toggle_button - ~label:(Configwin_types.modifiers_to_string [modifier]) + ~label:(modifiers_to_string [modifier]) ~active:(List.mem modifier param.md_value) ~packing:(hbox#pack ~expand:false) () in ignore (but#connect#toggled @@ -854,55 +483,6 @@ class modifiers_param_box param = () end ;; -(** This class is used to build a box for a date parameter.*) -class date_param_box param (tt:GData.tooltips) = - let _ = dbg "date_param_box" in - let v = ref param.date_value in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.date_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.date_expand ~padding: 2) - () - in - - let _ = - match param.date_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - - let _ = we#set_text (param.date_f_string param.date_value) in - let f_click () = - match select_date param.date_label !v with - None -> () - | Some (y,m,d) -> - v := (d,m,y) ; - we#set_text (param.date_f_string (d,m,y)) - in - let _ = - if param.date_editable then - let _ = wb#connect#clicked ~callback:f_click in - () - else - () - in - - object (self) - (** This method returns the main box ready to be packed. *) - method box = hbox#coerce - (** This method applies the new value of the parameter. *) - method apply = - if !v <> param.date_value then - let _ = param.date_f_apply !v in - param.date_value <- !v - else - () - end ;; - (** This class is used to build a box for a parameter whose values are a list.*) class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = let _ = dbg "list_param_box" in @@ -975,10 +555,6 @@ class configuration_box (tt : GData.tooltips) conf_struct = let box = new bool_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box - | Filename_param p -> - let box = new filename_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box | List_param f -> let box = f tt in let _ = main_box#pack ~expand: true ~padding: 2 box#box in @@ -987,30 +563,10 @@ class configuration_box (tt : GData.tooltips) conf_struct = let box = new custom_param_box p tt in let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in box - | Color_param p -> - let box = new color_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Font_param p -> - let box = new font_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Date_param p -> - let box = new date_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Hotkey_param p -> - let box = new hotkey_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box | Modifiers_param p -> let box = new modifiers_param_box p in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box - | Html_param p -> - let box = new html_param_box p tt in - let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in - box in let set_icon iter = function @@ -1102,36 +658,6 @@ class configuration_box (tt : GData.tooltips) conf_struct = end -(** Create a vbox with the list of given configuration structure list, - and the given list of buttons (defined by their label and callback). - Before calling the callback of a button, the [apply] function - of each parameter is called. -*) -let tabbed_box conf_struct_list buttons tooltips = - let param_box = - new configuration_box tooltips conf_struct_list - in - let f_apply () = param_box#apply - in - let hbox_buttons = GPack.hbox ~packing: (param_box#box#pack ~expand: false ~padding: 4) () in - let rec iter_buttons ?(grab=false) = function - [] -> - () - | (label, callb) :: q -> - let b = GButton.button ~label: label - ~packing:(hbox_buttons#pack ~expand:true ~fill: true ~padding:4) () - in - ignore (b#connect#clicked ~callback: - (fun () -> f_apply (); callb ())); - (* If it's the first button then give it the focus *) - if grab then b#grab_default (); - - iter_buttons q - in - iter_buttons ~grab: true buttons; - - param_box#box - (** This function takes a configuration structure list and creates a window to configure the various parameters. *) let edit ?(with_apply=true) @@ -1174,110 +700,6 @@ let edit ?(with_apply=true) in iter Return_cancel -(** Create a vbox with the list of given parameters. *) -let box param_list tt = - let main_box = GPack.vbox () in - let f parameter = - match parameter with - String_param p -> - let box = new string_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Combo_param p -> - let box = new combo_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Text_param p -> - let box = new text_param_box p tt in - let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in - box - | Bool_param p -> - let box = new bool_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Filename_param p -> - let box = new filename_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | List_param f -> - let box = f tt in - let _ = main_box#pack ~expand: true ~padding: 2 box#box in - box - | Custom_param p -> - let box = new custom_param_box p tt in - let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in - box - | Color_param p -> - let box = new color_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Font_param p -> - let box = new font_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Date_param p -> - let box = new date_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Hotkey_param p -> - let box = new hotkey_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Modifiers_param p -> - let box = new modifiers_param_box p in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Html_param p -> - let box = new html_param_box p tt in - let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in - box - in - let list_param_box = List.map f param_list in - let f_apply () = - List.iter (fun param_box -> param_box#apply) list_param_box - in - (main_box, f_apply) - -(** This function takes a list of parameter specifications and - creates a window to configure the various parameters.*) -let simple_edit ?(with_apply=true) - ?(apply=(fun () -> ())) - title ?width ?height - param_list = - let dialog = GWindow.dialog - ~modal: true ~title: title - ?height ?width - () - in - let tooltips = GData.tooltips () in - if with_apply then - dialog#add_button Configwin_messages.mApply `APPLY; - - dialog#add_button Configwin_messages.mOk `OK; - dialog#add_button Configwin_messages.mCancel `CANCEL; - - let (box, f_apply) = box param_list tooltips in - dialog#vbox#pack ~expand: true ~fill: true box#coerce; - - let destroy () = - tooltips#destroy () ; - dialog#destroy (); - in - let rec iter rep = - try - match dialog#run () with - | `APPLY -> f_apply (); apply (); iter Return_apply - | `OK -> f_apply () ; destroy () ; Return_ok - | _ -> destroy (); rep - with - Failure s -> - GToolbox.message_box ~title:"Error" s; iter rep - | e -> - GToolbox.message_box ~title:"Error" (Printexc.to_string e); iter rep - in - iter Return_cancel - - let edit_string l s = match GToolbox.input_string ~title: l ~text: s Configwin_messages.mValue with None -> s @@ -1342,30 +764,6 @@ let strings ?(editable=true) ?help ?(add=(fun () -> [])) label v = list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v -(** Create a color param. *) -let color ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Color_param - { - color_label = label ; - color_help = help ; - color_value = v ; - color_editable = editable ; - color_f_apply = f ; - color_expand = expand ; - } - -(** Create a font param. *) -let font ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Font_param - { - font_label = label ; - font_help = help ; - font_value = v ; - font_editable = editable ; - font_f_apply = f ; - font_expand = expand ; - } - (** Create a combo param. *) let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ?(new_allowed=false) @@ -1383,82 +781,6 @@ let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) combo_expand = expand ; } -(** Create a text param. *) -let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Text_param - { - string_label = label ; - string_help = help ; - string_value = v ; - string_editable = editable ; - string_f_apply = f ; - string_expand = expand ; - string_to_string = (fun x -> x) ; - string_of_string = (fun x -> x) ; - } - -(** Create a html param. *) -let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Html_param - { - string_label = label ; - string_help = help ; - string_value = v ; - string_editable = editable ; - string_f_apply = f ; - string_expand = expand ; - string_to_string = (fun x -> x) ; - string_of_string = (fun x -> x) ; - } - -(** Create a filename param. *) -let filename ?(editable=true) ?(expand=true)?help ?(f=(fun _ -> ())) label v = - Filename_param - { - string_label = label ; - string_help = help ; - string_value = v ; - string_editable = editable ; - string_f_apply = f ; - string_expand = expand ; - string_to_string = (fun x -> x) ; - string_of_string = (fun x -> x) ; - } - -(** Create a filenames param.*) -let filenames ?(editable=true) ?help ?(f=(fun _ -> ())) - ?(eq=Pervasives.(=)) - label v = - let add () = select_files label in - list ~editable ?help ~f ~eq ~add label (fun s -> [Glib.Convert.locale_to_utf8 s]) v - -(** Create a date param. *) -let date ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) - ?(f_string=(fun(d,m,y)-> Printf.sprintf "%d/%d/%d" y (m+1) d)) - label v = - Date_param - { - date_label = label ; - date_help = help ; - date_value = v ; - date_editable = editable ; - date_f_string = f_string ; - date_f_apply = f ; - date_expand = expand ; - } - -(** Create a hot key param. *) -let hotkey ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Hotkey_param - { - hk_label = label ; - hk_help = help ; - hk_value = v ; - hk_editable = editable ; - hk_f_apply = f ; - hk_expand = expand ; - } - let modifiers ?(editable=true) ?(expand=true) diff --git a/ide/utils/configwin_ihm.mli b/ide/utils/configwin_ihm.mli new file mode 100644 index 000000000..c867ad912 --- /dev/null +++ b/ide/utils/configwin_ihm.mli @@ -0,0 +1,66 @@ +(*********************************************************************************) +(* Cameleon *) +(* *) +(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. *) +(* *) +(* This program is free software; you can redistribute it and/or modify *) +(* it under the terms of the GNU Library General Public License as *) +(* published by the Free Software Foundation; either version 2 of the *) +(* License, or any later version. *) +(* *) +(* This program 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 Library General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU Library General Public *) +(* License along with this program; if not, write to the Free Software *) +(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) +(* 02111-1307 USA *) +(* *) +(* Contact: Maxence.Guesdon@inria.fr *) +(* *) +(*********************************************************************************) + +open Configwin_types + +val string : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: (string -> unit) -> string -> string -> parameter_kind +val bool : ?editable: bool -> ?help: string -> + ?f: (bool -> unit) -> string -> bool -> parameter_kind +val strings : ?editable: bool -> ?help: string -> + ?f: (string list -> unit) -> + ?eq: (string -> string -> bool) -> + ?add: (unit -> string list) -> + string -> string list -> parameter_kind +val list : ?editable: bool -> ?help: string -> + ?f: ('a list -> unit) -> + ?eq: ('a -> 'a -> bool) -> + ?edit: ('a -> 'a) -> + ?add: (unit -> 'a list) -> + ?titles: string list -> + ?color: ('a -> string option) -> + string -> + ('a -> string list) -> + 'a list -> + parameter_kind +val combo : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: (string -> unit) -> + ?new_allowed: bool -> ?blank_allowed: bool -> + string -> string list -> string -> parameter_kind + +val modifiers : ?editable: bool -> ?expand: bool -> ?help: string -> + ?allow:(Gdk.Tags.modifier list) -> + ?f: (Gdk.Tags.modifier list -> unit) -> + string -> Gdk.Tags.modifier list -> parameter_kind +val custom : ?label: string -> GPack.box -> (unit -> unit) -> bool -> parameter_kind + +val edit : + ?with_apply:bool -> + ?apply:(unit -> unit) -> + string -> + ?width:int -> + ?height:int -> + configuration_structure list -> + return_button diff --git a/ide/utils/configwin_keys.ml b/ide/utils/configwin_keys.ml deleted file mode 100644 index 9f44e5c6b..000000000 --- a/ide/utils/configwin_keys.ml +++ /dev/null @@ -1,4176 +0,0 @@ -(*********************************************************************************) -(* Cameleon *) -(* *) -(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. *) -(* *) -(* This program is free software; you can redistribute it and/or modify *) -(* it under the terms of the GNU Library General Public License as *) -(* published by the Free Software Foundation; either version 2 of the *) -(* License, or any later version. *) -(* *) -(* This program 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 Library General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU Library General Public *) -(* License along with this program; if not, write to the Free Software *) -(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) -(* 02111-1307 USA *) -(* *) -(* Contact: Maxence.Guesdon@inria.fr *) -(* *) -(*********************************************************************************) - -(** Key codes - - Ce fichier provient de X11/keysymdef.h - les noms des symboles deviennent : XK_ -> xk_ - - Thanks to Fabrice Le Fessant. -*) - -let xk_VoidSymbol = 0xFFFFFF (** void symbol *) - - -(** TTY Functions, cleverly chosen to map to ascii, for convenience of - programming, but could have been arbitrary (at the cost of lookup - tables in client code. -*) - -let xk_BackSpace = 0xFF08 (** back space, back char *) -let xk_Tab = 0xFF09 -let xk_Linefeed = 0xFF0A (** Linefeed, LF *) -let xk_Clear = 0xFF0B -let xk_Return = 0xFF0D (** Return, enter *) -let xk_Pause = 0xFF13 (** Pause, hold *) -let xk_Scroll_Lock = 0xFF14 -let xk_Sys_Req = 0xFF15 -let xk_Escape = 0xFF1B -let xk_Delete = 0xFFFF (** Delete, rubout *) - - - -(** International & multi-key character composition *) - -let xk_Multi_key = 0xFF20 (** Multi-key character compose *) - -(** Japanese keyboard support *) - -let xk_Kanji = 0xFF21 (** Kanji, Kanji convert *) -let xk_Muhenkan = 0xFF22 (** Cancel Conversion *) -let xk_Henkan_Mode = 0xFF23 (** Start/Stop Conversion *) -let xk_Henkan = 0xFF23 (** Alias for Henkan_Mode *) -let xk_Romaji = 0xFF24 (** to Romaji *) -let xk_Hiragana = 0xFF25 (** to Hiragana *) -let xk_Katakana = 0xFF26 (** to Katakana *) -let xk_Hiragana_Katakana = 0xFF27 (** Hiragana/Katakana toggle *) -let xk_Zenkaku = 0xFF28 (** to Zenkaku *) -let xk_Hankaku = 0xFF29 (** to Hankaku *) -let xk_Zenkaku_Hankaku = 0xFF2A (** Zenkaku/Hankaku toggle *) -let xk_Touroku = 0xFF2B (** Add to Dictionary *) -let xk_Massyo = 0xFF2C (** Delete from Dictionary *) -let xk_Kana_Lock = 0xFF2D (** Kana Lock *) -let xk_Kana_Shift = 0xFF2E (** Kana Shift *) -let xk_Eisu_Shift = 0xFF2F (** Alphanumeric Shift *) -let xk_Eisu_toggle = 0xFF30 (** Alphanumeric toggle *) - -(** = 0xFF31 thru = 0xFF3F are under xk_KOREAN *) - -(** Cursor control & motion *) - -let xk_Home = 0xFF50 -let xk_Left = 0xFF51 (** Move left, left arrow *) -let xk_Up = 0xFF52 (** Move up, up arrow *) -let xk_Right = 0xFF53 (** Move right, right arrow *) -let xk_Down = 0xFF54 (** Move down, down arrow *) -let xk_Prior = 0xFF55 (** Prior, previous *) -let xk_Page_Up = 0xFF55 -let xk_Next = 0xFF56 (** Next *) -let xk_Page_Down = 0xFF56 -let xk_End = 0xFF57 (** EOL *) -let xk_Begin = 0xFF58 (** BOL *) - - -(** Misc Functions *) - -let xk_Select = 0xFF60 (** Select, mark *) -let xk_Print = 0xFF61 -let xk_Execute = 0xFF62 (** Execute, run, do *) -let xk_Insert = 0xFF63 (** Insert, insert here *) -let xk_Undo = 0xFF65 (** Undo, oops *) -let xk_Redo = 0xFF66 (** redo, again *) -let xk_Menu = 0xFF67 -let xk_Find = 0xFF68 (** Find, search *) -let xk_Cancel = 0xFF69 (** Cancel, stop, abort, exit *) -let xk_Help = 0xFF6A (** Help *) -let xk_Break = 0xFF6B -let xk_Mode_switch = 0xFF7E (** Character set switch *) -let xk_script_switch = 0xFF7E (** Alias for mode_switch *) -let xk_Num_Lock = 0xFF7F - -(** Keypad Functions, keypad numbers cleverly chosen to map to ascii *) - -let xk_KP_Space = 0xFF80 (** space *) -let xk_KP_Tab = 0xFF89 -let xk_KP_Enter = 0xFF8D (** enter *) -let xk_KP_F1 = 0xFF91 (** PF1, KP_A, ... *) -let xk_KP_F2 = 0xFF92 -let xk_KP_F3 = 0xFF93 -let xk_KP_F4 = 0xFF94 -let xk_KP_Home = 0xFF95 -let xk_KP_Left = 0xFF96 -let xk_KP_Up = 0xFF97 -let xk_KP_Right = 0xFF98 -let xk_KP_Down = 0xFF99 -let xk_KP_Prior = 0xFF9A -let xk_KP_Page_Up = 0xFF9A -let xk_KP_Next = 0xFF9B -let xk_KP_Page_Down = 0xFF9B -let xk_KP_End = 0xFF9C -let xk_KP_Begin = 0xFF9D -let xk_KP_Insert = 0xFF9E -let xk_KP_Delete = 0xFF9F -let xk_KP_Equal = 0xFFBD (** equals *) -let xk_KP_Multiply = 0xFFAA -let xk_KP_Add = 0xFFAB -let xk_KP_Separator = 0xFFAC (** separator, often comma *) -let xk_KP_Subtract = 0xFFAD -let xk_KP_Decimal = 0xFFAE -let xk_KP_Divide = 0xFFAF - -let xk_KP_0 = 0xFFB0 -let xk_KP_1 = 0xFFB1 -let xk_KP_2 = 0xFFB2 -let xk_KP_3 = 0xFFB3 -let xk_KP_4 = 0xFFB4 -let xk_KP_5 = 0xFFB5 -let xk_KP_6 = 0xFFB6 -let xk_KP_7 = 0xFFB7 -let xk_KP_8 = 0xFFB8 -let xk_KP_9 = 0xFFB9 - - - -(* - * Auxilliary Functions; note the duplicate definitions for left and right - * function keys; Sun keyboards and a few other manufactures have such - * function key groups on the left and/or right sides of the keyboard. - * We've not found a keyboard with more than 35 function keys total. - *) - -let xk_F1 = 0xFFBE -let xk_F2 = 0xFFBF -let xk_F3 = 0xFFC0 -let xk_F4 = 0xFFC1 -let xk_F5 = 0xFFC2 -let xk_F6 = 0xFFC3 -let xk_F7 = 0xFFC4 -let xk_F8 = 0xFFC5 -let xk_F9 = 0xFFC6 -let xk_F10 = 0xFFC7 -let xk_F11 = 0xFFC8 -let xk_L1 = 0xFFC8 -let xk_F12 = 0xFFC9 -let xk_L2 = 0xFFC9 -let xk_F13 = 0xFFCA -let xk_L3 = 0xFFCA -let xk_F14 = 0xFFCB -let xk_L4 = 0xFFCB -let xk_F15 = 0xFFCC -let xk_L5 = 0xFFCC -let xk_F16 = 0xFFCD -let xk_L6 = 0xFFCD -let xk_F17 = 0xFFCE -let xk_L7 = 0xFFCE -let xk_F18 = 0xFFCF -let xk_L8 = 0xFFCF -let xk_F19 = 0xFFD0 -let xk_L9 = 0xFFD0 -let xk_F20 = 0xFFD1 -let xk_L10 = 0xFFD1 -let xk_F21 = 0xFFD2 -let xk_R1 = 0xFFD2 -let xk_F22 = 0xFFD3 -let xk_R2 = 0xFFD3 -let xk_F23 = 0xFFD4 -let xk_R3 = 0xFFD4 -let xk_F24 = 0xFFD5 -let xk_R4 = 0xFFD5 -let xk_F25 = 0xFFD6 -let xk_R5 = 0xFFD6 -let xk_F26 = 0xFFD7 -let xk_R6 = 0xFFD7 -let xk_F27 = 0xFFD8 -let xk_R7 = 0xFFD8 -let xk_F28 = 0xFFD9 -let xk_R8 = 0xFFD9 -let xk_F29 = 0xFFDA -let xk_R9 = 0xFFDA -let xk_F30 = 0xFFDB -let xk_R10 = 0xFFDB -let xk_F31 = 0xFFDC -let xk_R11 = 0xFFDC -let xk_F32 = 0xFFDD -let xk_R12 = 0xFFDD -let xk_F33 = 0xFFDE -let xk_R13 = 0xFFDE -let xk_F34 = 0xFFDF -let xk_R14 = 0xFFDF -let xk_F35 = 0xFFE0 -let xk_R15 = 0xFFE0 - -(** Modifiers *) - -let xk_Shift_L = 0xFFE1 (** Left shift *) -let xk_Shift_R = 0xFFE2 (** Right shift *) -let xk_Control_L = 0xFFE3 (** Left control *) -let xk_Control_R = 0xFFE4 (** Right control *) -let xk_Caps_Lock = 0xFFE5 (** Caps lock *) -let xk_Shift_Lock = 0xFFE6 (** Shift lock *) - -let xk_Meta_L = 0xFFE7 (** Left meta *) -let xk_Meta_R = 0xFFE8 (** Right meta *) -let xk_Alt_L = 0xFFE9 (** Left alt *) -let xk_Alt_R = 0xFFEA (** Right alt *) -let xk_Super_L = 0xFFEB (** Left super *) -let xk_Super_R = 0xFFEC (** Right super *) -let xk_Hyper_L = 0xFFED (** Left hyper *) -let xk_Hyper_R = 0xFFEE (** Right hyper *) - - -(* - * ISO 9995 Function and Modifier Keys - * Byte 3 = = 0xFE - *) - - -let xk_ISO_Lock = 0xFE01 -let xk_ISO_Level2_Latch = 0xFE02 -let xk_ISO_Level3_Shift = 0xFE03 -let xk_ISO_Level3_Latch = 0xFE04 -let xk_ISO_Level3_Lock = 0xFE05 -let xk_ISO_Group_Shift = 0xFF7E (** Alias for mode_switch *) -let xk_ISO_Group_Latch = 0xFE06 -let xk_ISO_Group_Lock = 0xFE07 -let xk_ISO_Next_Group = 0xFE08 -let xk_ISO_Next_Group_Lock = 0xFE09 -let xk_ISO_Prev_Group = 0xFE0A -let xk_ISO_Prev_Group_Lock = 0xFE0B -let xk_ISO_First_Group = 0xFE0C -let xk_ISO_First_Group_Lock = 0xFE0D -let xk_ISO_Last_Group = 0xFE0E -let xk_ISO_Last_Group_Lock = 0xFE0F - -let xk_ISO_Left_Tab = 0xFE20 -let xk_ISO_Move_Line_Up = 0xFE21 -let xk_ISO_Move_Line_Down = 0xFE22 -let xk_ISO_Partial_Line_Up = 0xFE23 -let xk_ISO_Partial_Line_Down = 0xFE24 -let xk_ISO_Partial_Space_Left = 0xFE25 -let xk_ISO_Partial_Space_Right = 0xFE26 -let xk_ISO_Set_Margin_Left = 0xFE27 -let xk_ISO_Set_Margin_Right = 0xFE28 -let xk_ISO_Release_Margin_Left = 0xFE29 -let xk_ISO_Release_Margin_Right = 0xFE2A -let xk_ISO_Release_Both_Margins = 0xFE2B -let xk_ISO_Fast_Cursor_Left = 0xFE2C -let xk_ISO_Fast_Cursor_Right = 0xFE2D -let xk_ISO_Fast_Cursor_Up = 0xFE2E -let xk_ISO_Fast_Cursor_Down = 0xFE2F -let xk_ISO_Continuous_Underline = 0xFE30 -let xk_ISO_Discontinuous_Underline = 0xFE31 -let xk_ISO_Emphasize = 0xFE32 -let xk_ISO_Center_Object = 0xFE33 -let xk_ISO_Enter = 0xFE34 - -let xk_dead_grave = 0xFE50 -let xk_dead_acute = 0xFE51 -let xk_dead_circumflex = 0xFE52 -let xk_dead_tilde = 0xFE53 -let xk_dead_macron = 0xFE54 -let xk_dead_breve = 0xFE55 -let xk_dead_abovedot = 0xFE56 -let xk_dead_diaeresis = 0xFE57 -let xk_dead_abovering = 0xFE58 -let xk_dead_doubleacute = 0xFE59 -let xk_dead_caron = 0xFE5A -let xk_dead_cedilla = 0xFE5B -let xk_dead_ogonek = 0xFE5C -let xk_dead_iota = 0xFE5D -let xk_dead_voiced_sound = 0xFE5E -let xk_dead_semivoiced_sound = 0xFE5F -let xk_dead_belowdot = 0xFE60 - -let xk_First_Virtual_Screen = 0xFED0 -let xk_Prev_Virtual_Screen = 0xFED1 -let xk_Next_Virtual_Screen = 0xFED2 -let xk_Last_Virtual_Screen = 0xFED4 -let xk_Terminate_Server = 0xFED5 - -let xk_AccessX_Enable = 0xFE70 -let xk_AccessX_Feedback_Enable = 0xFE71 -let xk_RepeatKeys_Enable = 0xFE72 -let xk_SlowKeys_Enable = 0xFE73 -let xk_BounceKeys_Enable = 0xFE74 -let xk_StickyKeys_Enable = 0xFE75 -let xk_MouseKeys_Enable = 0xFE76 -let xk_MouseKeys_Accel_Enable = 0xFE77 -let xk_Overlay1_Enable = 0xFE78 -let xk_Overlay2_Enable = 0xFE79 -let xk_AudibleBell_Enable = 0xFE7A - -let xk_Pointer_Left = 0xFEE0 -let xk_Pointer_Right = 0xFEE1 -let xk_Pointer_Up = 0xFEE2 -let xk_Pointer_Down = 0xFEE3 -let xk_Pointer_UpLeft = 0xFEE4 -let xk_Pointer_UpRight = 0xFEE5 -let xk_Pointer_DownLeft = 0xFEE6 -let xk_Pointer_DownRight = 0xFEE7 -let xk_Pointer_Button_Dflt = 0xFEE8 -let xk_Pointer_Button1 = 0xFEE9 -let xk_Pointer_Button2 = 0xFEEA -let xk_Pointer_Button3 = 0xFEEB -let xk_Pointer_Button4 = 0xFEEC -let xk_Pointer_Button5 = 0xFEED -let xk_Pointer_DblClick_Dflt = 0xFEEE -let xk_Pointer_DblClick1 = 0xFEEF -let xk_Pointer_DblClick2 = 0xFEF0 -let xk_Pointer_DblClick3 = 0xFEF1 -let xk_Pointer_DblClick4 = 0xFEF2 -let xk_Pointer_DblClick5 = 0xFEF3 -let xk_Pointer_Drag_Dflt = 0xFEF4 -let xk_Pointer_Drag1 = 0xFEF5 -let xk_Pointer_Drag2 = 0xFEF6 -let xk_Pointer_Drag3 = 0xFEF7 -let xk_Pointer_Drag4 = 0xFEF8 -let xk_Pointer_Drag5 = 0xFEFD - -let xk_Pointer_EnableKeys = 0xFEF9 -let xk_Pointer_Accelerate = 0xFEFA -let xk_Pointer_DfltBtnNext = 0xFEFB -let xk_Pointer_DfltBtnPrev = 0xFEFC - - - -(* - * 3270 Terminal Keys - * Byte 3 = = 0xFD - *) - - -let xk_3270_Duplicate = 0xFD01 -let xk_3270_FieldMark = 0xFD02 -let xk_3270_Right2 = 0xFD03 -let xk_3270_Left2 = 0xFD04 -let xk_3270_BackTab = 0xFD05 -let xk_3270_EraseEOF = 0xFD06 -let xk_3270_EraseInput = 0xFD07 -let xk_3270_Reset = 0xFD08 -let xk_3270_Quit = 0xFD09 -let xk_3270_PA1 = 0xFD0A -let xk_3270_PA2 = 0xFD0B -let xk_3270_PA3 = 0xFD0C -let xk_3270_Test = 0xFD0D -let xk_3270_Attn = 0xFD0E -let xk_3270_CursorBlink = 0xFD0F -let xk_3270_AltCursor = 0xFD10 -let xk_3270_KeyClick = 0xFD11 -let xk_3270_Jump = 0xFD12 -let xk_3270_Ident = 0xFD13 -let xk_3270_Rule = 0xFD14 -let xk_3270_Copy = 0xFD15 -let xk_3270_Play = 0xFD16 -let xk_3270_Setup = 0xFD17 -let xk_3270_Record = 0xFD18 -let xk_3270_ChangeScreen = 0xFD19 -let xk_3270_DeleteWord = 0xFD1A -let xk_3270_ExSelect = 0xFD1B -let xk_3270_CursorSelect = 0xFD1C -let xk_3270_PrintScreen = 0xFD1D -let xk_3270_Enter = 0xFD1E - - -(* - * Latin 1 - * Byte 3 = 0 - *) - -let xk_space = 0x020 -let xk_exclam = 0x021 -let xk_quotedbl = 0x022 -let xk_numbersign = 0x023 -let xk_dollar = 0x024 -let xk_percent = 0x025 -let xk_ampersand = 0x026 -let xk_apostrophe = 0x027 -let xk_quoteright = 0x027 (** deprecated *) -let xk_parenleft = 0x028 -let xk_parenright = 0x029 -let xk_asterisk = 0x02a -let xk_plus = 0x02b -let xk_comma = 0x02c -let xk_minus = 0x02d -let xk_period = 0x02e -let xk_slash = 0x02f -let xk_0 = 0x030 -let xk_1 = 0x031 -let xk_2 = 0x032 -let xk_3 = 0x033 -let xk_4 = 0x034 -let xk_5 = 0x035 -let xk_6 = 0x036 -let xk_7 = 0x037 -let xk_8 = 0x038 -let xk_9 = 0x039 -let xk_colon = 0x03a -let xk_semicolon = 0x03b -let xk_less = 0x03c -let xk_equal = 0x03d -let xk_greater = 0x03e -let xk_question = 0x03f -let xk_at = 0x040 -let xk_A = 0x041 -let xk_B = 0x042 -let xk_C = 0x043 -let xk_D = 0x044 -let xk_E = 0x045 -let xk_F = 0x046 -let xk_G = 0x047 -let xk_H = 0x048 -let xk_I = 0x049 -let xk_J = 0x04a -let xk_K = 0x04b -let xk_L = 0x04c -let xk_M = 0x04d -let xk_N = 0x04e -let xk_O = 0x04f -let xk_P = 0x050 -let xk_Q = 0x051 -let xk_R = 0x052 -let xk_S = 0x053 -let xk_T = 0x054 -let xk_U = 0x055 -let xk_V = 0x056 -let xk_W = 0x057 -let xk_X = 0x058 -let xk_Y = 0x059 -let xk_Z = 0x05a -let xk_bracketleft = 0x05b -let xk_backslash = 0x05c -let xk_bracketright = 0x05d -let xk_asciicircum = 0x05e -let xk_underscore = 0x05f -let xk_grave = 0x060 -let xk_quoteleft = 0x060 (** deprecated *) -let xk_a = 0x061 -let xk_b = 0x062 -let xk_c = 0x063 -let xk_d = 0x064 -let xk_e = 0x065 -let xk_f = 0x066 -let xk_g = 0x067 -let xk_h = 0x068 -let xk_i = 0x069 -let xk_j = 0x06a -let xk_k = 0x06b -let xk_l = 0x06c -let xk_m = 0x06d -let xk_n = 0x06e -let xk_o = 0x06f -let xk_p = 0x070 -let xk_q = 0x071 -let xk_r = 0x072 -let xk_s = 0x073 -let xk_t = 0x074 -let xk_u = 0x075 -let xk_v = 0x076 -let xk_w = 0x077 -let xk_x = 0x078 -let xk_y = 0x079 -let xk_z = 0x07a -let xk_braceleft = 0x07b -let xk_bar = 0x07c -let xk_braceright = 0x07d -let xk_asciitilde = 0x07e - -let xk_nobreakspace = 0x0a0 -let xk_exclamdown = 0x0a1 -let xk_cent = 0x0a2 -let xk_sterling = 0x0a3 -let xk_currency = 0x0a4 -let xk_yen = 0x0a5 -let xk_brokenbar = 0x0a6 -let xk_section = 0x0a7 -let xk_diaeresis = 0x0a8 -let xk_copyright = 0x0a9 -let xk_ordfeminine = 0x0aa -let xk_guillemotleft = 0x0ab (** left angle quotation mark *) -let xk_notsign = 0x0ac -let xk_hyphen = 0x0ad -let xk_registered = 0x0ae -let xk_macron = 0x0af -let xk_degree = 0x0b0 -let xk_plusminus = 0x0b1 -let xk_twosuperior = 0x0b2 -let xk_threesuperior = 0x0b3 -let xk_acute = 0x0b4 -let xk_mu = 0x0b5 -let xk_paragraph = 0x0b6 -let xk_periodcentered = 0x0b7 -let xk_cedilla = 0x0b8 -let xk_onesuperior = 0x0b9 -let xk_masculine = 0x0ba -let xk_guillemotright = 0x0bb (** right angle quotation mark *) -let xk_onequarter = 0x0bc -let xk_onehalf = 0x0bd -let xk_threequarters = 0x0be -let xk_questiondown = 0x0bf -let xk_Agrave = 0x0c0 -let xk_Aacute = 0x0c1 -let xk_Acircumflex = 0x0c2 -let xk_Atilde = 0x0c3 -let xk_Adiaeresis = 0x0c4 -let xk_Aring = 0x0c5 -let xk_AE = 0x0c6 -let xk_Ccedilla = 0x0c7 -let xk_Egrave = 0x0c8 -let xk_Eacute = 0x0c9 -let xk_Ecircumflex = 0x0ca -let xk_Ediaeresis = 0x0cb -let xk_Igrave = 0x0cc -let xk_Iacute = 0x0cd -let xk_Icircumflex = 0x0ce -let xk_Idiaeresis = 0x0cf -let xk_ETH = 0x0d0 -let xk_Eth = 0x0d0 (** deprecated *) -let xk_Ntilde = 0x0d1 -let xk_Ograve = 0x0d2 -let xk_Oacute = 0x0d3 -let xk_Ocircumflex = 0x0d4 -let xk_Otilde = 0x0d5 -let xk_Odiaeresis = 0x0d6 -let xk_multiply = 0x0d7 -let xk_Ooblique = 0x0d8 -let xk_Ugrave = 0x0d9 -let xk_Uacute = 0x0da -let xk_Ucircumflex = 0x0db -let xk_Udiaeresis = 0x0dc -let xk_Yacute = 0x0dd -let xk_THORN = 0x0de -let xk_Thorn = 0x0de (** deprecated *) -let xk_ssharp = 0x0df -let xk_agrave = 0x0e0 -let xk_aacute = 0x0e1 -let xk_acircumflex = 0x0e2 -let xk_atilde = 0x0e3 -let xk_adiaeresis = 0x0e4 -let xk_aring = 0x0e5 -let xk_ae = 0x0e6 -let xk_ccedilla = 0x0e7 -let xk_egrave = 0x0e8 -let xk_eacute = 0x0e9 -let xk_ecircumflex = 0x0ea -let xk_ediaeresis = 0x0eb -let xk_igrave = 0x0ec -let xk_iacute = 0x0ed -let xk_icircumflex = 0x0ee -let xk_idiaeresis = 0x0ef -let xk_eth = 0x0f0 -let xk_ntilde = 0x0f1 -let xk_ograve = 0x0f2 -let xk_oacute = 0x0f3 -let xk_ocircumflex = 0x0f4 -let xk_otilde = 0x0f5 -let xk_odiaeresis = 0x0f6 -let xk_division = 0x0f7 -let xk_oslash = 0x0f8 -let xk_ugrave = 0x0f9 -let xk_uacute = 0x0fa -let xk_ucircumflex = 0x0fb -let xk_udiaeresis = 0x0fc -let xk_yacute = 0x0fd -let xk_thorn = 0x0fe -let xk_ydiaeresis = 0x0ff - - -(* - * Latin 2 - * Byte 3 = 1 - *) - - -let xk_Aogonek = 0x1a1 -let xk_breve = 0x1a2 -let xk_Lstroke = 0x1a3 -let xk_Lcaron = 0x1a5 -let xk_Sacute = 0x1a6 -let xk_Scaron = 0x1a9 -let xk_Scedilla = 0x1aa -let xk_Tcaron = 0x1ab -let xk_Zacute = 0x1ac -let xk_Zcaron = 0x1ae -let xk_Zabovedot = 0x1af -let xk_aogonek = 0x1b1 -let xk_ogonek = 0x1b2 -let xk_lstroke = 0x1b3 -let xk_lcaron = 0x1b5 -let xk_sacute = 0x1b6 -let xk_caron = 0x1b7 -let xk_scaron = 0x1b9 -let xk_scedilla = 0x1ba -let xk_tcaron = 0x1bb -let xk_zacute = 0x1bc -let xk_doubleacute = 0x1bd -let xk_zcaron = 0x1be -let xk_zabovedot = 0x1bf -let xk_Racute = 0x1c0 -let xk_Abreve = 0x1c3 -let xk_Lacute = 0x1c5 -let xk_Cacute = 0x1c6 -let xk_Ccaron = 0x1c8 -let xk_Eogonek = 0x1ca -let xk_Ecaron = 0x1cc -let xk_Dcaron = 0x1cf -let xk_Dstroke = 0x1d0 -let xk_Nacute = 0x1d1 -let xk_Ncaron = 0x1d2 -let xk_Odoubleacute = 0x1d5 -let xk_Rcaron = 0x1d8 -let xk_Uring = 0x1d9 -let xk_Udoubleacute = 0x1db -let xk_Tcedilla = 0x1de -let xk_racute = 0x1e0 -let xk_abreve = 0x1e3 -let xk_lacute = 0x1e5 -let xk_cacute = 0x1e6 -let xk_ccaron = 0x1e8 -let xk_eogonek = 0x1ea -let xk_ecaron = 0x1ec -let xk_dcaron = 0x1ef -let xk_dstroke = 0x1f0 -let xk_nacute = 0x1f1 -let xk_ncaron = 0x1f2 -let xk_odoubleacute = 0x1f5 -let xk_udoubleacute = 0x1fb -let xk_rcaron = 0x1f8 -let xk_uring = 0x1f9 -let xk_tcedilla = 0x1fe -let xk_abovedot = 0x1ff - - -(* - * Latin 3 - * Byte 3 = 2 - *) - - -let xk_Hstroke = 0x2a1 -let xk_Hcircumflex = 0x2a6 -let xk_Iabovedot = 0x2a9 -let xk_Gbreve = 0x2ab -let xk_Jcircumflex = 0x2ac -let xk_hstroke = 0x2b1 -let xk_hcircumflex = 0x2b6 -let xk_idotless = 0x2b9 -let xk_gbreve = 0x2bb -let xk_jcircumflex = 0x2bc -let xk_Cabovedot = 0x2c5 -let xk_Ccircumflex = 0x2c6 -let xk_Gabovedot = 0x2d5 -let xk_Gcircumflex = 0x2d8 -let xk_Ubreve = 0x2dd -let xk_Scircumflex = 0x2de -let xk_cabovedot = 0x2e5 -let xk_ccircumflex = 0x2e6 -let xk_gabovedot = 0x2f5 -let xk_gcircumflex = 0x2f8 -let xk_ubreve = 0x2fd -let xk_scircumflex = 0x2fe - - - -(* - * Latin 4 - * Byte 3 = 3 - *) - - -let xk_kra = 0x3a2 -let xk_kappa = 0x3a2 (** deprecated *) -let xk_Rcedilla = 0x3a3 -let xk_Itilde = 0x3a5 -let xk_Lcedilla = 0x3a6 -let xk_Emacron = 0x3aa -let xk_Gcedilla = 0x3ab -let xk_Tslash = 0x3ac -let xk_rcedilla = 0x3b3 -let xk_itilde = 0x3b5 -let xk_lcedilla = 0x3b6 -let xk_emacron = 0x3ba -let xk_gcedilla = 0x3bb -let xk_tslash = 0x3bc -let xk_ENG = 0x3bd -let xk_eng = 0x3bf -let xk_Amacron = 0x3c0 -let xk_Iogonek = 0x3c7 -let xk_Eabovedot = 0x3cc -let xk_Imacron = 0x3cf -let xk_Ncedilla = 0x3d1 -let xk_Omacron = 0x3d2 -let xk_Kcedilla = 0x3d3 -let xk_Uogonek = 0x3d9 -let xk_Utilde = 0x3dd -let xk_Umacron = 0x3de -let xk_amacron = 0x3e0 -let xk_iogonek = 0x3e7 -let xk_eabovedot = 0x3ec -let xk_imacron = 0x3ef -let xk_ncedilla = 0x3f1 -let xk_omacron = 0x3f2 -let xk_kcedilla = 0x3f3 -let xk_uogonek = 0x3f9 -let xk_utilde = 0x3fd -let xk_umacron = 0x3fe - - -(* - * Katakana - * Byte 3 = 4 - *) - - -let xk_overline = 0x47e -let xk_kana_fullstop = 0x4a1 -let xk_kana_openingbracket = 0x4a2 -let xk_kana_closingbracket = 0x4a3 -let xk_kana_comma = 0x4a4 -let xk_kana_conjunctive = 0x4a5 -let xk_kana_middledot = 0x4a5 (** deprecated *) -let xk_kana_WO = 0x4a6 -let xk_kana_a = 0x4a7 -let xk_kana_i = 0x4a8 -let xk_kana_u = 0x4a9 -let xk_kana_e = 0x4aa -let xk_kana_o = 0x4ab -let xk_kana_ya = 0x4ac -let xk_kana_yu = 0x4ad -let xk_kana_yo = 0x4ae -let xk_kana_tsu = 0x4af -let xk_kana_tu = 0x4af (** deprecated *) -let xk_prolongedsound = 0x4b0 -let xk_kana_A = 0x4b1 -let xk_kana_I = 0x4b2 -let xk_kana_U = 0x4b3 -let xk_kana_E = 0x4b4 -let xk_kana_O = 0x4b5 -let xk_kana_KA = 0x4b6 -let xk_kana_KI = 0x4b7 -let xk_kana_KU = 0x4b8 -let xk_kana_KE = 0x4b9 -let xk_kana_KO = 0x4ba -let xk_kana_SA = 0x4bb -let xk_kana_SHI = 0x4bc -let xk_kana_SU = 0x4bd -let xk_kana_SE = 0x4be -let xk_kana_SO = 0x4bf -let xk_kana_TA = 0x4c0 -let xk_kana_CHI = 0x4c1 -let xk_kana_TI = 0x4c1 (** deprecated *) -let xk_kana_TSU = 0x4c2 -let xk_kana_TU = 0x4c2 (** deprecated *) -let xk_kana_TE = 0x4c3 -let xk_kana_TO = 0x4c4 -let xk_kana_NA = 0x4c5 -let xk_kana_NI = 0x4c6 -let xk_kana_NU = 0x4c7 -let xk_kana_NE = 0x4c8 -let xk_kana_NO = 0x4c9 -let xk_kana_HA = 0x4ca -let xk_kana_HI = 0x4cb -let xk_kana_FU = 0x4cc -let xk_kana_HU = 0x4cc (** deprecated *) -let xk_kana_HE = 0x4cd -let xk_kana_HO = 0x4ce -let xk_kana_MA = 0x4cf -let xk_kana_MI = 0x4d0 -let xk_kana_MU = 0x4d1 -let xk_kana_ME = 0x4d2 -let xk_kana_MO = 0x4d3 -let xk_kana_YA = 0x4d4 -let xk_kana_YU = 0x4d5 -let xk_kana_YO = 0x4d6 -let xk_kana_RA = 0x4d7 -let xk_kana_RI = 0x4d8 -let xk_kana_RU = 0x4d9 -let xk_kana_RE = 0x4da -let xk_kana_RO = 0x4db -let xk_kana_WA = 0x4dc -let xk_kana_N = 0x4dd -let xk_voicedsound = 0x4de -let xk_semivoicedsound = 0x4df -let xk_kana_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Arabic - * Byte 3 = 5 - *) - - -let xk_Arabic_comma = 0x5ac -let xk_Arabic_semicolon = 0x5bb -let xk_Arabic_question_mark = 0x5bf -let xk_Arabic_hamza = 0x5c1 -let xk_Arabic_maddaonalef = 0x5c2 -let xk_Arabic_hamzaonalef = 0x5c3 -let xk_Arabic_hamzaonwaw = 0x5c4 -let xk_Arabic_hamzaunderalef = 0x5c5 -let xk_Arabic_hamzaonyeh = 0x5c6 -let xk_Arabic_alef = 0x5c7 -let xk_Arabic_beh = 0x5c8 -let xk_Arabic_tehmarbuta = 0x5c9 -let xk_Arabic_teh = 0x5ca -let xk_Arabic_theh = 0x5cb -let xk_Arabic_jeem = 0x5cc -let xk_Arabic_hah = 0x5cd -let xk_Arabic_khah = 0x5ce -let xk_Arabic_dal = 0x5cf -let xk_Arabic_thal = 0x5d0 -let xk_Arabic_ra = 0x5d1 -let xk_Arabic_zain = 0x5d2 -let xk_Arabic_seen = 0x5d3 -let xk_Arabic_sheen = 0x5d4 -let xk_Arabic_sad = 0x5d5 -let xk_Arabic_dad = 0x5d6 -let xk_Arabic_tah = 0x5d7 -let xk_Arabic_zah = 0x5d8 -let xk_Arabic_ain = 0x5d9 -let xk_Arabic_ghain = 0x5da -let xk_Arabic_tatweel = 0x5e0 -let xk_Arabic_feh = 0x5e1 -let xk_Arabic_qaf = 0x5e2 -let xk_Arabic_kaf = 0x5e3 -let xk_Arabic_lam = 0x5e4 -let xk_Arabic_meem = 0x5e5 -let xk_Arabic_noon = 0x5e6 -let xk_Arabic_ha = 0x5e7 -let xk_Arabic_heh = 0x5e7 (** deprecated *) -let xk_Arabic_waw = 0x5e8 -let xk_Arabic_alefmaksura = 0x5e9 -let xk_Arabic_yeh = 0x5ea -let xk_Arabic_fathatan = 0x5eb -let xk_Arabic_dammatan = 0x5ec -let xk_Arabic_kasratan = 0x5ed -let xk_Arabic_fatha = 0x5ee -let xk_Arabic_damma = 0x5ef -let xk_Arabic_kasra = 0x5f0 -let xk_Arabic_shadda = 0x5f1 -let xk_Arabic_sukun = 0x5f2 -let xk_Arabic_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Cyrillic - * Byte 3 = 6 - *) - -let xk_Serbian_dje = 0x6a1 -let xk_Macedonia_gje = 0x6a2 -let xk_Cyrillic_io = 0x6a3 -let xk_Ukrainian_ie = 0x6a4 -let xk_Ukranian_je = 0x6a4 (** deprecated *) -let xk_Macedonia_dse = 0x6a5 -let xk_Ukrainian_i = 0x6a6 -let xk_Ukranian_i = 0x6a6 (** deprecated *) -let xk_Ukrainian_yi = 0x6a7 -let xk_Ukranian_yi = 0x6a7 (** deprecated *) -let xk_Cyrillic_je = 0x6a8 -let xk_Serbian_je = 0x6a8 (** deprecated *) -let xk_Cyrillic_lje = 0x6a9 -let xk_Serbian_lje = 0x6a9 (** deprecated *) -let xk_Cyrillic_nje = 0x6aa -let xk_Serbian_nje = 0x6aa (** deprecated *) -let xk_Serbian_tshe = 0x6ab -let xk_Macedonia_kje = 0x6ac -let xk_Byelorussian_shortu = 0x6ae -let xk_Cyrillic_dzhe = 0x6af -let xk_Serbian_dze = 0x6af (** deprecated *) -let xk_numerosign = 0x6b0 -let xk_Serbian_DJE = 0x6b1 -let xk_Macedonia_GJE = 0x6b2 -let xk_Cyrillic_IO = 0x6b3 -let xk_Ukrainian_IE = 0x6b4 -let xk_Ukranian_JE = 0x6b4 (** deprecated *) -let xk_Macedonia_DSE = 0x6b5 -let xk_Ukrainian_I = 0x6b6 -let xk_Ukranian_I = 0x6b6 (** deprecated *) -let xk_Ukrainian_YI = 0x6b7 -let xk_Ukranian_YI = 0x6b7 (** deprecated *) -let xk_Cyrillic_JE = 0x6b8 -let xk_Serbian_JE = 0x6b8 (** deprecated *) -let xk_Cyrillic_LJE = 0x6b9 -let xk_Serbian_LJE = 0x6b9 (** deprecated *) -let xk_Cyrillic_NJE = 0x6ba -let xk_Serbian_NJE = 0x6ba (** deprecated *) -let xk_Serbian_TSHE = 0x6bb -let xk_Macedonia_KJE = 0x6bc -let xk_Byelorussian_SHORTU = 0x6be -let xk_Cyrillic_DZHE = 0x6bf -let xk_Serbian_DZE = 0x6bf (** deprecated *) -let xk_Cyrillic_yu = 0x6c0 -let xk_Cyrillic_a = 0x6c1 -let xk_Cyrillic_be = 0x6c2 -let xk_Cyrillic_tse = 0x6c3 -let xk_Cyrillic_de = 0x6c4 -let xk_Cyrillic_ie = 0x6c5 -let xk_Cyrillic_ef = 0x6c6 -let xk_Cyrillic_ghe = 0x6c7 -let xk_Cyrillic_ha = 0x6c8 -let xk_Cyrillic_i = 0x6c9 -let xk_Cyrillic_shorti = 0x6ca -let xk_Cyrillic_ka = 0x6cb -let xk_Cyrillic_el = 0x6cc -let xk_Cyrillic_em = 0x6cd -let xk_Cyrillic_en = 0x6ce -let xk_Cyrillic_o = 0x6cf -let xk_Cyrillic_pe = 0x6d0 -let xk_Cyrillic_ya = 0x6d1 -let xk_Cyrillic_er = 0x6d2 -let xk_Cyrillic_es = 0x6d3 -let xk_Cyrillic_te = 0x6d4 -let xk_Cyrillic_u = 0x6d5 -let xk_Cyrillic_zhe = 0x6d6 -let xk_Cyrillic_ve = 0x6d7 -let xk_Cyrillic_softsign = 0x6d8 -let xk_Cyrillic_yeru = 0x6d9 -let xk_Cyrillic_ze = 0x6da -let xk_Cyrillic_sha = 0x6db -let xk_Cyrillic_e = 0x6dc -let xk_Cyrillic_shcha = 0x6dd -let xk_Cyrillic_che = 0x6de -let xk_Cyrillic_hardsign = 0x6df -let xk_Cyrillic_YU = 0x6e0 -let xk_Cyrillic_A = 0x6e1 -let xk_Cyrillic_BE = 0x6e2 -let xk_Cyrillic_TSE = 0x6e3 -let xk_Cyrillic_DE = 0x6e4 -let xk_Cyrillic_IE = 0x6e5 -let xk_Cyrillic_EF = 0x6e6 -let xk_Cyrillic_GHE = 0x6e7 -let xk_Cyrillic_HA = 0x6e8 -let xk_Cyrillic_I = 0x6e9 -let xk_Cyrillic_SHORTI = 0x6ea -let xk_Cyrillic_KA = 0x6eb -let xk_Cyrillic_EL = 0x6ec -let xk_Cyrillic_EM = 0x6ed -let xk_Cyrillic_EN = 0x6ee -let xk_Cyrillic_O = 0x6ef -let xk_Cyrillic_PE = 0x6f0 -let xk_Cyrillic_YA = 0x6f1 -let xk_Cyrillic_ER = 0x6f2 -let xk_Cyrillic_ES = 0x6f3 -let xk_Cyrillic_TE = 0x6f4 -let xk_Cyrillic_U = 0x6f5 -let xk_Cyrillic_ZHE = 0x6f6 -let xk_Cyrillic_VE = 0x6f7 -let xk_Cyrillic_SOFTSIGN = 0x6f8 -let xk_Cyrillic_YERU = 0x6f9 -let xk_Cyrillic_ZE = 0x6fa -let xk_Cyrillic_SHA = 0x6fb -let xk_Cyrillic_E = 0x6fc -let xk_Cyrillic_SHCHA = 0x6fd -let xk_Cyrillic_CHE = 0x6fe -let xk_Cyrillic_HARDSIGN = 0x6ff - - -(* - * Greek - * Byte 3 = 7 - *) - - -let xk_Greek_ALPHAaccent = 0x7a1 -let xk_Greek_EPSILONaccent = 0x7a2 -let xk_Greek_ETAaccent = 0x7a3 -let xk_Greek_IOTAaccent = 0x7a4 -let xk_Greek_IOTAdiaeresis = 0x7a5 -let xk_Greek_OMICRONaccent = 0x7a7 -let xk_Greek_UPSILONaccent = 0x7a8 -let xk_Greek_UPSILONdieresis = 0x7a9 -let xk_Greek_OMEGAaccent = 0x7ab -let xk_Greek_accentdieresis = 0x7ae -let xk_Greek_horizbar = 0x7af -let xk_Greek_alphaaccent = 0x7b1 -let xk_Greek_epsilonaccent = 0x7b2 -let xk_Greek_etaaccent = 0x7b3 -let xk_Greek_iotaaccent = 0x7b4 -let xk_Greek_iotadieresis = 0x7b5 -let xk_Greek_iotaaccentdieresis = 0x7b6 -let xk_Greek_omicronaccent = 0x7b7 -let xk_Greek_upsilonaccent = 0x7b8 -let xk_Greek_upsilondieresis = 0x7b9 -let xk_Greek_upsilonaccentdieresis = 0x7ba -let xk_Greek_omegaaccent = 0x7bb -let xk_Greek_ALPHA = 0x7c1 -let xk_Greek_BETA = 0x7c2 -let xk_Greek_GAMMA = 0x7c3 -let xk_Greek_DELTA = 0x7c4 -let xk_Greek_EPSILON = 0x7c5 -let xk_Greek_ZETA = 0x7c6 -let xk_Greek_ETA = 0x7c7 -let xk_Greek_THETA = 0x7c8 -let xk_Greek_IOTA = 0x7c9 -let xk_Greek_KAPPA = 0x7ca -let xk_Greek_LAMDA = 0x7cb -let xk_Greek_LAMBDA = 0x7cb -let xk_Greek_MU = 0x7cc -let xk_Greek_NU = 0x7cd -let xk_Greek_XI = 0x7ce -let xk_Greek_OMICRON = 0x7cf -let xk_Greek_PI = 0x7d0 -let xk_Greek_RHO = 0x7d1 -let xk_Greek_SIGMA = 0x7d2 -let xk_Greek_TAU = 0x7d4 -let xk_Greek_UPSILON = 0x7d5 -let xk_Greek_PHI = 0x7d6 -let xk_Greek_CHI = 0x7d7 -let xk_Greek_PSI = 0x7d8 -let xk_Greek_OMEGA = 0x7d9 -let xk_Greek_alpha = 0x7e1 -let xk_Greek_beta = 0x7e2 -let xk_Greek_gamma = 0x7e3 -let xk_Greek_delta = 0x7e4 -let xk_Greek_epsilon = 0x7e5 -let xk_Greek_zeta = 0x7e6 -let xk_Greek_eta = 0x7e7 -let xk_Greek_theta = 0x7e8 -let xk_Greek_iota = 0x7e9 -let xk_Greek_kappa = 0x7ea -let xk_Greek_lamda = 0x7eb -let xk_Greek_lambda = 0x7eb -let xk_Greek_mu = 0x7ec -let xk_Greek_nu = 0x7ed -let xk_Greek_xi = 0x7ee -let xk_Greek_omicron = 0x7ef -let xk_Greek_pi = 0x7f0 -let xk_Greek_rho = 0x7f1 -let xk_Greek_sigma = 0x7f2 -let xk_Greek_finalsmallsigma = 0x7f3 -let xk_Greek_tau = 0x7f4 -let xk_Greek_upsilon = 0x7f5 -let xk_Greek_phi = 0x7f6 -let xk_Greek_chi = 0x7f7 -let xk_Greek_psi = 0x7f8 -let xk_Greek_omega = 0x7f9 -let xk_Greek_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Technical - * Byte 3 = 8 - *) - - -let xk_leftradical = 0x8a1 -let xk_topleftradical = 0x8a2 -let xk_horizconnector = 0x8a3 -let xk_topintegral = 0x8a4 -let xk_botintegral = 0x8a5 -let xk_vertconnector = 0x8a6 -let xk_topleftsqbracket = 0x8a7 -let xk_botleftsqbracket = 0x8a8 -let xk_toprightsqbracket = 0x8a9 -let xk_botrightsqbracket = 0x8aa -let xk_topleftparens = 0x8ab -let xk_botleftparens = 0x8ac -let xk_toprightparens = 0x8ad -let xk_botrightparens = 0x8ae -let xk_leftmiddlecurlybrace = 0x8af -let xk_rightmiddlecurlybrace = 0x8b0 -let xk_topleftsummation = 0x8b1 -let xk_botleftsummation = 0x8b2 -let xk_topvertsummationconnector = 0x8b3 -let xk_botvertsummationconnector = 0x8b4 -let xk_toprightsummation = 0x8b5 -let xk_botrightsummation = 0x8b6 -let xk_rightmiddlesummation = 0x8b7 -let xk_lessthanequal = 0x8bc -let xk_notequal = 0x8bd -let xk_greaterthanequal = 0x8be -let xk_integral = 0x8bf -let xk_therefore = 0x8c0 -let xk_variation = 0x8c1 -let xk_infinity = 0x8c2 -let xk_nabla = 0x8c5 -let xk_approximate = 0x8c8 -let xk_similarequal = 0x8c9 -let xk_ifonlyif = 0x8cd -let xk_implies = 0x8ce -let xk_identical = 0x8cf -let xk_radical = 0x8d6 -let xk_includedin = 0x8da -let xk_includes = 0x8db -let xk_intersection = 0x8dc -let xk_union = 0x8dd -let xk_logicaland = 0x8de -let xk_logicalor = 0x8df -let xk_partialderivative = 0x8ef -let xk_function = 0x8f6 -let xk_leftarrow = 0x8fb -let xk_uparrow = 0x8fc -let xk_rightarrow = 0x8fd -let xk_downarrow = 0x8fe - - -(* - * Special - * Byte 3 = 9 - *) - - -let xk_blank = 0x9df -let xk_soliddiamond = 0x9e0 -let xk_checkerboard = 0x9e1 -let xk_ht = 0x9e2 -let xk_ff = 0x9e3 -let xk_cr = 0x9e4 -let xk_lf = 0x9e5 -let xk_nl = 0x9e8 -let xk_vt = 0x9e9 -let xk_lowrightcorner = 0x9ea -let xk_uprightcorner = 0x9eb -let xk_upleftcorner = 0x9ec -let xk_lowleftcorner = 0x9ed -let xk_crossinglines = 0x9ee -let xk_horizlinescan1 = 0x9ef -let xk_horizlinescan3 = 0x9f0 -let xk_horizlinescan5 = 0x9f1 -let xk_horizlinescan7 = 0x9f2 -let xk_horizlinescan9 = 0x9f3 -let xk_leftt = 0x9f4 -let xk_rightt = 0x9f5 -let xk_bott = 0x9f6 -let xk_topt = 0x9f7 -let xk_vertbar = 0x9f8 - - -(* - * Publishing - * Byte 3 = a - *) - - -let xk_emspace = 0xaa1 -let xk_enspace = 0xaa2 -let xk_em3space = 0xaa3 -let xk_em4space = 0xaa4 -let xk_digitspace = 0xaa5 -let xk_punctspace = 0xaa6 -let xk_thinspace = 0xaa7 -let xk_hairspace = 0xaa8 -let xk_emdash = 0xaa9 -let xk_endash = 0xaaa -let xk_signifblank = 0xaac -let xk_ellipsis = 0xaae -let xk_doubbaselinedot = 0xaaf -let xk_onethird = 0xab0 -let xk_twothirds = 0xab1 -let xk_onefifth = 0xab2 -let xk_twofifths = 0xab3 -let xk_threefifths = 0xab4 -let xk_fourfifths = 0xab5 -let xk_onesixth = 0xab6 -let xk_fivesixths = 0xab7 -let xk_careof = 0xab8 -let xk_figdash = 0xabb -let xk_leftanglebracket = 0xabc -let xk_decimalpoint = 0xabd -let xk_rightanglebracket = 0xabe -let xk_marker = 0xabf -let xk_oneeighth = 0xac3 -let xk_threeeighths = 0xac4 -let xk_fiveeighths = 0xac5 -let xk_seveneighths = 0xac6 -let xk_trademark = 0xac9 -let xk_signaturemark = 0xaca -let xk_trademarkincircle = 0xacb -let xk_leftopentriangle = 0xacc -let xk_rightopentriangle = 0xacd -let xk_emopencircle = 0xace -let xk_emopenrectangle = 0xacf -let xk_leftsinglequotemark = 0xad0 -let xk_rightsinglequotemark = 0xad1 -let xk_leftdoublequotemark = 0xad2 -let xk_rightdoublequotemark = 0xad3 -let xk_prescription = 0xad4 -let xk_minutes = 0xad6 -let xk_seconds = 0xad7 -let xk_latincross = 0xad9 -let xk_hexagram = 0xada -let xk_filledrectbullet = 0xadb -let xk_filledlefttribullet = 0xadc -let xk_filledrighttribullet = 0xadd -let xk_emfilledcircle = 0xade -let xk_emfilledrect = 0xadf -let xk_enopencircbullet = 0xae0 -let xk_enopensquarebullet = 0xae1 -let xk_openrectbullet = 0xae2 -let xk_opentribulletup = 0xae3 -let xk_opentribulletdown = 0xae4 -let xk_openstar = 0xae5 -let xk_enfilledcircbullet = 0xae6 -let xk_enfilledsqbullet = 0xae7 -let xk_filledtribulletup = 0xae8 -let xk_filledtribulletdown = 0xae9 -let xk_leftpointer = 0xaea -let xk_rightpointer = 0xaeb -let xk_club = 0xaec -let xk_diamond = 0xaed -let xk_heart = 0xaee -let xk_maltesecross = 0xaf0 -let xk_dagger = 0xaf1 -let xk_doubledagger = 0xaf2 -let xk_checkmark = 0xaf3 -let xk_ballotcross = 0xaf4 -let xk_musicalsharp = 0xaf5 -let xk_musicalflat = 0xaf6 -let xk_malesymbol = 0xaf7 -let xk_femalesymbol = 0xaf8 -let xk_telephone = 0xaf9 -let xk_telephonerecorder = 0xafa -let xk_phonographcopyright = 0xafb -let xk_caret = 0xafc -let xk_singlelowquotemark = 0xafd -let xk_doublelowquotemark = 0xafe -let xk_cursor = 0xaff - - -(* - * APL - * Byte 3 = b - *) - - -let xk_leftcaret = 0xba3 -let xk_rightcaret = 0xba6 -let xk_downcaret = 0xba8 -let xk_upcaret = 0xba9 -let xk_overbar = 0xbc0 -let xk_downtack = 0xbc2 -let xk_upshoe = 0xbc3 -let xk_downstile = 0xbc4 -let xk_underbar = 0xbc6 -let xk_jot = 0xbca -let xk_quad = 0xbcc -let xk_uptack = 0xbce -let xk_circle = 0xbcf -let xk_upstile = 0xbd3 -let xk_downshoe = 0xbd6 -let xk_rightshoe = 0xbd8 -let xk_leftshoe = 0xbda -let xk_lefttack = 0xbdc -let xk_righttack = 0xbfc - - -(* - * Hebrew - * Byte 3 = c - *) - - -let xk_hebrew_doublelowline = 0xcdf -let xk_hebrew_aleph = 0xce0 -let xk_hebrew_bet = 0xce1 -let xk_hebrew_beth = 0xce1 (** deprecated *) -let xk_hebrew_gimel = 0xce2 -let xk_hebrew_gimmel = 0xce2 (** deprecated *) -let xk_hebrew_dalet = 0xce3 -let xk_hebrew_daleth = 0xce3 (** deprecated *) -let xk_hebrew_he = 0xce4 -let xk_hebrew_waw = 0xce5 -let xk_hebrew_zain = 0xce6 -let xk_hebrew_zayin = 0xce6 (** deprecated *) -let xk_hebrew_chet = 0xce7 -let xk_hebrew_het = 0xce7 (** deprecated *) -let xk_hebrew_tet = 0xce8 -let xk_hebrew_teth = 0xce8 (** deprecated *) -let xk_hebrew_yod = 0xce9 -let xk_hebrew_finalkaph = 0xcea -let xk_hebrew_kaph = 0xceb -let xk_hebrew_lamed = 0xcec -let xk_hebrew_finalmem = 0xced -let xk_hebrew_mem = 0xcee -let xk_hebrew_finalnun = 0xcef -let xk_hebrew_nun = 0xcf0 -let xk_hebrew_samech = 0xcf1 -let xk_hebrew_samekh = 0xcf1 (** deprecated *) -let xk_hebrew_ayin = 0xcf2 -let xk_hebrew_finalpe = 0xcf3 -let xk_hebrew_pe = 0xcf4 -let xk_hebrew_finalzade = 0xcf5 -let xk_hebrew_finalzadi = 0xcf5 (** deprecated *) -let xk_hebrew_zade = 0xcf6 -let xk_hebrew_zadi = 0xcf6 (** deprecated *) -let xk_hebrew_qoph = 0xcf7 -let xk_hebrew_kuf = 0xcf7 (** deprecated *) -let xk_hebrew_resh = 0xcf8 -let xk_hebrew_shin = 0xcf9 -let xk_hebrew_taw = 0xcfa -let xk_hebrew_taf = 0xcfa (** deprecated *) -let xk_Hebrew_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Thai - * Byte 3 = d - *) - - -let xk_Thai_kokai = 0xda1 -let xk_Thai_khokhai = 0xda2 -let xk_Thai_khokhuat = 0xda3 -let xk_Thai_khokhwai = 0xda4 -let xk_Thai_khokhon = 0xda5 -let xk_Thai_khorakhang = 0xda6 -let xk_Thai_ngongu = 0xda7 -let xk_Thai_chochan = 0xda8 -let xk_Thai_choching = 0xda9 -let xk_Thai_chochang = 0xdaa -let xk_Thai_soso = 0xdab -let xk_Thai_chochoe = 0xdac -let xk_Thai_yoying = 0xdad -let xk_Thai_dochada = 0xdae -let xk_Thai_topatak = 0xdaf -let xk_Thai_thothan = 0xdb0 -let xk_Thai_thonangmontho = 0xdb1 -let xk_Thai_thophuthao = 0xdb2 -let xk_Thai_nonen = 0xdb3 -let xk_Thai_dodek = 0xdb4 -let xk_Thai_totao = 0xdb5 -let xk_Thai_thothung = 0xdb6 -let xk_Thai_thothahan = 0xdb7 -let xk_Thai_thothong = 0xdb8 -let xk_Thai_nonu = 0xdb9 -let xk_Thai_bobaimai = 0xdba -let xk_Thai_popla = 0xdbb -let xk_Thai_phophung = 0xdbc -let xk_Thai_fofa = 0xdbd -let xk_Thai_phophan = 0xdbe -let xk_Thai_fofan = 0xdbf -let xk_Thai_phosamphao = 0xdc0 -let xk_Thai_moma = 0xdc1 -let xk_Thai_yoyak = 0xdc2 -let xk_Thai_rorua = 0xdc3 -let xk_Thai_ru = 0xdc4 -let xk_Thai_loling = 0xdc5 -let xk_Thai_lu = 0xdc6 -let xk_Thai_wowaen = 0xdc7 -let xk_Thai_sosala = 0xdc8 -let xk_Thai_sorusi = 0xdc9 -let xk_Thai_sosua = 0xdca -let xk_Thai_hohip = 0xdcb -let xk_Thai_lochula = 0xdcc -let xk_Thai_oang = 0xdcd -let xk_Thai_honokhuk = 0xdce -let xk_Thai_paiyannoi = 0xdcf -let xk_Thai_saraa = 0xdd0 -let xk_Thai_maihanakat = 0xdd1 -let xk_Thai_saraaa = 0xdd2 -let xk_Thai_saraam = 0xdd3 -let xk_Thai_sarai = 0xdd4 -let xk_Thai_saraii = 0xdd5 -let xk_Thai_saraue = 0xdd6 -let xk_Thai_sarauee = 0xdd7 -let xk_Thai_sarau = 0xdd8 -let xk_Thai_sarauu = 0xdd9 -let xk_Thai_phinthu = 0xdda -let xk_Thai_maihanakat_maitho = 0xdde -let xk_Thai_baht = 0xddf -let xk_Thai_sarae = 0xde0 -let xk_Thai_saraae = 0xde1 -let xk_Thai_sarao = 0xde2 -let xk_Thai_saraaimaimuan = 0xde3 -let xk_Thai_saraaimaimalai = 0xde4 -let xk_Thai_lakkhangyao = 0xde5 -let xk_Thai_maiyamok = 0xde6 -let xk_Thai_maitaikhu = 0xde7 -let xk_Thai_maiek = 0xde8 -let xk_Thai_maitho = 0xde9 -let xk_Thai_maitri = 0xdea -let xk_Thai_maichattawa = 0xdeb -let xk_Thai_thanthakhat = 0xdec -let xk_Thai_nikhahit = 0xded -let xk_Thai_leksun = 0xdf0 -let xk_Thai_leknung = 0xdf1 -let xk_Thai_leksong = 0xdf2 -let xk_Thai_leksam = 0xdf3 -let xk_Thai_leksi = 0xdf4 -let xk_Thai_lekha = 0xdf5 -let xk_Thai_lekhok = 0xdf6 -let xk_Thai_lekchet = 0xdf7 -let xk_Thai_lekpaet = 0xdf8 -let xk_Thai_lekkao = 0xdf9 - - -(* - * Korean - * Byte 3 = e - *) - - - -let xk_Hangul = 0xff31 (** Hangul start/stop(toggle) *) -let xk_Hangul_Start = 0xff32 (** Hangul start *) -let xk_Hangul_End = 0xff33 (** Hangul end, English start *) -let xk_Hangul_Hanja = 0xff34 (** Start Hangul->Hanja Conversion *) -let xk_Hangul_Jamo = 0xff35 (** Hangul Jamo mode *) -let xk_Hangul_Romaja = 0xff36 (** Hangul Romaja mode *) -let xk_Hangul_Codeinput = 0xff37 (** Hangul code input mode *) -let xk_Hangul_Jeonja = 0xff38 (** Jeonja mode *) -let xk_Hangul_Banja = 0xff39 (** Banja mode *) -let xk_Hangul_PreHanja = 0xff3a (** Pre Hanja conversion *) -let xk_Hangul_PostHanja = 0xff3b (** Post Hanja conversion *) -let xk_Hangul_SingleCandidate = 0xff3c (** Single candidate *) -let xk_Hangul_MultipleCandidate = 0xff3d (** Multiple candidate *) -let xk_Hangul_PreviousCandidate = 0xff3e (** Previous candidate *) -let xk_Hangul_Special = 0xff3f (** Special symbols *) -let xk_Hangul_switch = 0xFF7E (** Alias for mode_switch *) - -(** Hangul Consonant Characters *) -let xk_Hangul_Kiyeog = 0xea1 -let xk_Hangul_SsangKiyeog = 0xea2 -let xk_Hangul_KiyeogSios = 0xea3 -let xk_Hangul_Nieun = 0xea4 -let xk_Hangul_NieunJieuj = 0xea5 -let xk_Hangul_NieunHieuh = 0xea6 -let xk_Hangul_Dikeud = 0xea7 -let xk_Hangul_SsangDikeud = 0xea8 -let xk_Hangul_Rieul = 0xea9 -let xk_Hangul_RieulKiyeog = 0xeaa -let xk_Hangul_RieulMieum = 0xeab -let xk_Hangul_RieulPieub = 0xeac -let xk_Hangul_RieulSios = 0xead -let xk_Hangul_RieulTieut = 0xeae -let xk_Hangul_RieulPhieuf = 0xeaf -let xk_Hangul_RieulHieuh = 0xeb0 -let xk_Hangul_Mieum = 0xeb1 -let xk_Hangul_Pieub = 0xeb2 -let xk_Hangul_SsangPieub = 0xeb3 -let xk_Hangul_PieubSios = 0xeb4 -let xk_Hangul_Sios = 0xeb5 -let xk_Hangul_SsangSios = 0xeb6 -let xk_Hangul_Ieung = 0xeb7 -let xk_Hangul_Jieuj = 0xeb8 -let xk_Hangul_SsangJieuj = 0xeb9 -let xk_Hangul_Cieuc = 0xeba -let xk_Hangul_Khieuq = 0xebb -let xk_Hangul_Tieut = 0xebc -let xk_Hangul_Phieuf = 0xebd -let xk_Hangul_Hieuh = 0xebe - -(** Hangul Vowel Characters *) -let xk_Hangul_A = 0xebf -let xk_Hangul_AE = 0xec0 -let xk_Hangul_YA = 0xec1 -let xk_Hangul_YAE = 0xec2 -let xk_Hangul_EO = 0xec3 -let xk_Hangul_E = 0xec4 -let xk_Hangul_YEO = 0xec5 -let xk_Hangul_YE = 0xec6 -let xk_Hangul_O = 0xec7 -let xk_Hangul_WA = 0xec8 -let xk_Hangul_WAE = 0xec9 -let xk_Hangul_OE = 0xeca -let xk_Hangul_YO = 0xecb -let xk_Hangul_U = 0xecc -let xk_Hangul_WEO = 0xecd -let xk_Hangul_WE = 0xece -let xk_Hangul_WI = 0xecf -let xk_Hangul_YU = 0xed0 -let xk_Hangul_EU = 0xed1 -let xk_Hangul_YI = 0xed2 -let xk_Hangul_I = 0xed3 - -(** Hangul syllable-final (JongSeong) Characters *) -let xk_Hangul_J_Kiyeog = 0xed4 -let xk_Hangul_J_SsangKiyeog = 0xed5 -let xk_Hangul_J_KiyeogSios = 0xed6 -let xk_Hangul_J_Nieun = 0xed7 -let xk_Hangul_J_NieunJieuj = 0xed8 -let xk_Hangul_J_NieunHieuh = 0xed9 -let xk_Hangul_J_Dikeud = 0xeda -let xk_Hangul_J_Rieul = 0xedb -let xk_Hangul_J_RieulKiyeog = 0xedc -let xk_Hangul_J_RieulMieum = 0xedd -let xk_Hangul_J_RieulPieub = 0xede -let xk_Hangul_J_RieulSios = 0xedf -let xk_Hangul_J_RieulTieut = 0xee0 -let xk_Hangul_J_RieulPhieuf = 0xee1 -let xk_Hangul_J_RieulHieuh = 0xee2 -let xk_Hangul_J_Mieum = 0xee3 -let xk_Hangul_J_Pieub = 0xee4 -let xk_Hangul_J_PieubSios = 0xee5 -let xk_Hangul_J_Sios = 0xee6 -let xk_Hangul_J_SsangSios = 0xee7 -let xk_Hangul_J_Ieung = 0xee8 -let xk_Hangul_J_Jieuj = 0xee9 -let xk_Hangul_J_Cieuc = 0xeea -let xk_Hangul_J_Khieuq = 0xeeb -let xk_Hangul_J_Tieut = 0xeec -let xk_Hangul_J_Phieuf = 0xeed -let xk_Hangul_J_Hieuh = 0xeee - -(** Ancient Hangul Consonant Characters *) -let xk_Hangul_RieulYeorinHieuh = 0xeef -let xk_Hangul_SunkyeongeumMieum = 0xef0 -let xk_Hangul_SunkyeongeumPieub = 0xef1 -let xk_Hangul_PanSios = 0xef2 -let xk_Hangul_KkogjiDalrinIeung = 0xef3 -let xk_Hangul_SunkyeongeumPhieuf = 0xef4 -let xk_Hangul_YeorinHieuh = 0xef5 - -(** Ancient Hangul Vowel Characters *) -let xk_Hangul_AraeA = 0xef6 -let xk_Hangul_AraeAE = 0xef7 - -(** Ancient Hangul syllable-final (JongSeong) Characters *) -let xk_Hangul_J_PanSios = 0xef8 -let xk_Hangul_J_KkogjiDalrinIeung = 0xef9 -let xk_Hangul_J_YeorinHieuh = 0xefa - -(** Korean currency symbol *) -let xk_Korean_Won = 0xeff - - - -let name_to_keysym = [ -"VoidSymbol",0xFFFFFF; -"BackSpace",0xFF08; -"Tab",0xFF09; -"Linefeed",0xFF0A; -"Clear",0xFF0B; -"Return",0xFF0D; -"Pause",0xFF13; -"Scroll_Lock",0xFF14; -"Sys_Req",0xFF15; -"Escape",0xFF1B; -"Delete",0xFFFF; -"Multi_key",0xFF20; -"Kanji",0xFF21; -"Muhenkan",0xFF22; -"Henkan_Mode",0xFF23; -"Henkan",0xFF23; -"Romaji",0xFF24; -"Hiragana",0xFF25; -"Katakana",0xFF26; -"Hiragana_Katakana",0xFF27; -"Zenkaku",0xFF28; -"Hankaku",0xFF29; -"Zenkaku_Hankaku",0xFF2A; -"Touroku",0xFF2B; -"Massyo",0xFF2C; -"Kana_Lock",0xFF2D; -"Kana_Shift",0xFF2E; -"Eisu_Shift",0xFF2F; -"Eisu_toggle",0xFF30; -"Home",0xFF50; -"Left",0xFF51; -"Up",0xFF52; -"Right",0xFF53; -"Down",0xFF54; -"Prior",0xFF55; -"Page_Up",0xFF55; -"Next",0xFF56; -"Page_Down",0xFF56; -"End",0xFF57; -"Begin",0xFF58; -"Select",0xFF60; -"Print",0xFF61; -"Execute",0xFF62; -"Insert",0xFF63; -"Undo",0xFF65; -"Redo",0xFF66; -"Menu",0xFF67; -"Find",0xFF68; -"Cancel",0xFF69; -"Help",0xFF6A; -"Break",0xFF6B; -"Mode_switch",0xFF7E; -"script_switch",0xFF7E; -"Num_Lock",0xFF7F; -"KP_Space",0xFF80; -"KP_Tab",0xFF89; -"KP_Enter",0xFF8D; -"KP_F1",0xFF91; -"KP_F2",0xFF92; -"KP_F3",0xFF93; -"KP_F4",0xFF94; -"KP_Home",0xFF95; -"KP_Left",0xFF96; -"KP_Up",0xFF97; -"KP_Right",0xFF98; -"KP_Down",0xFF99; -"KP_Prior",0xFF9A; -"KP_Page_Up",0xFF9A; -"KP_Next",0xFF9B; -"KP_Page_Down",0xFF9B; -"KP_End",0xFF9C; -"KP_Begin",0xFF9D; -"KP_Insert",0xFF9E; -"KP_Delete",0xFF9F; -"KP_Equal",0xFFBD; -"KP_Multiply",0xFFAA; -"KP_Add",0xFFAB; -"KP_Separator",0xFFAC; -"KP_Subtract",0xFFAD; -"KP_Decimal",0xFFAE; -"KP_Divide",0xFFAF; -"KP_0",0xFFB0; -"KP_1",0xFFB1; -"KP_2",0xFFB2; -"KP_3",0xFFB3; -"KP_4",0xFFB4; -"KP_5",0xFFB5; -"KP_6",0xFFB6; -"KP_7",0xFFB7; -"KP_8",0xFFB8; -"KP_9",0xFFB9; -"F1",0xFFBE; -"F2",0xFFBF; -"F3",0xFFC0; -"F4",0xFFC1; -"F5",0xFFC2; -"F6",0xFFC3; -"F7",0xFFC4; -"F8",0xFFC5; -"F9",0xFFC6; -"F10",0xFFC7; -"F11",0xFFC8; -"L1",0xFFC8; -"F12",0xFFC9; -"L2",0xFFC9; -"F13",0xFFCA; -"L3",0xFFCA; -"F14",0xFFCB; -"L4",0xFFCB; -"F15",0xFFCC; -"L5",0xFFCC; -"F16",0xFFCD; -"L6",0xFFCD; -"F17",0xFFCE; -"L7",0xFFCE; -"F18",0xFFCF; -"L8",0xFFCF; -"F19",0xFFD0; -"L9",0xFFD0; -"F20",0xFFD1; -"L10",0xFFD1; -"F21",0xFFD2; -"R1",0xFFD2; -"F22",0xFFD3; -"R2",0xFFD3; -"F23",0xFFD4; -"R3",0xFFD4; -"F24",0xFFD5; -"R4",0xFFD5; -"F25",0xFFD6; -"R5",0xFFD6; -"F26",0xFFD7; -"R6",0xFFD7; -"F27",0xFFD8; -"R7",0xFFD8; -"F28",0xFFD9; -"R8",0xFFD9; -"F29",0xFFDA; -"R9",0xFFDA; -"F30",0xFFDB; -"R10",0xFFDB; -"F31",0xFFDC; -"R11",0xFFDC; -"F32",0xFFDD; -"R12",0xFFDD; -"F33",0xFFDE; -"R13",0xFFDE; -"F34",0xFFDF; -"R14",0xFFDF; -"F35",0xFFE0; -"R15",0xFFE0; -"Shift_L",0xFFE1; -"Shift_R",0xFFE2; -"Control_L",0xFFE3; -"Control_R",0xFFE4; -"Caps_Lock",0xFFE5; -"Shift_Lock",0xFFE6; -"Meta_L",0xFFE7; -"Meta_R",0xFFE8; -"Alt_L",0xFFE9; -"Alt_R",0xFFEA; -"Super_L",0xFFEB; -"Super_R",0xFFEC; -"Hyper_L",0xFFED; -"Hyper_R",0xFFEE; -"ISO_Lock",0xFE01; -"ISO_Level2_Latch",0xFE02; -"ISO_Level3_Shift",0xFE03; -"ISO_Level3_Latch",0xFE04; -"ISO_Level3_Lock",0xFE05; -"ISO_Group_Shift",0xFF7E; -"ISO_Group_Latch",0xFE06; -"ISO_Group_Lock",0xFE07; -"ISO_Next_Group",0xFE08; -"ISO_Next_Group_Lock",0xFE09; -"ISO_Prev_Group",0xFE0A; -"ISO_Prev_Group_Lock",0xFE0B; -"ISO_First_Group",0xFE0C; -"ISO_First_Group_Lock",0xFE0D; -"ISO_Last_Group",0xFE0E; -"ISO_Last_Group_Lock",0xFE0F; -"ISO_Left_Tab",0xFE20; -"ISO_Move_Line_Up",0xFE21; -"ISO_Move_Line_Down",0xFE22; -"ISO_Partial_Line_Up",0xFE23; -"ISO_Partial_Line_Down",0xFE24; -"ISO_Partial_Space_Left",0xFE25; -"ISO_Partial_Space_Right",0xFE26; -"ISO_Set_Margin_Left",0xFE27; -"ISO_Set_Margin_Right",0xFE28; -"ISO_Release_Margin_Left",0xFE29; -"ISO_Release_Margin_Right",0xFE2A; -"ISO_Release_Both_Margins",0xFE2B; -"ISO_Fast_Cursor_Left",0xFE2C; -"ISO_Fast_Cursor_Right",0xFE2D; -"ISO_Fast_Cursor_Up",0xFE2E; -"ISO_Fast_Cursor_Down",0xFE2F; -"ISO_Continuous_Underline",0xFE30; -"ISO_Discontinuous_Underline",0xFE31; -"ISO_Emphasize",0xFE32; -"ISO_Center_Object",0xFE33; -"ISO_Enter",0xFE34; -"dead_grave",0xFE50; -"dead_acute",0xFE51; -"dead_circumflex",0xFE52; -"dead_tilde",0xFE53; -"dead_macron",0xFE54; -"dead_breve",0xFE55; -"dead_abovedot",0xFE56; -"dead_diaeresis",0xFE57; -"dead_abovering",0xFE58; -"dead_doubleacute",0xFE59; -"dead_caron",0xFE5A; -"dead_cedilla",0xFE5B; -"dead_ogonek",0xFE5C; -"dead_iota",0xFE5D; -"dead_voiced_sound",0xFE5E; -"dead_semivoiced_sound",0xFE5F; -"dead_belowdot",0xFE60; -"First_Virtual_Screen",0xFED0; -"Prev_Virtual_Screen",0xFED1; -"Next_Virtual_Screen",0xFED2; -"Last_Virtual_Screen",0xFED4; -"Terminate_Server",0xFED5; -"AccessX_Enable",0xFE70; -"AccessX_Feedback_Enable",0xFE71; -"RepeatKeys_Enable",0xFE72; -"SlowKeys_Enable",0xFE73; -"BounceKeys_Enable",0xFE74; -"StickyKeys_Enable",0xFE75; -"MouseKeys_Enable",0xFE76; -"MouseKeys_Accel_Enable",0xFE77; -"Overlay1_Enable",0xFE78; -"Overlay2_Enable",0xFE79; -"AudibleBell_Enable",0xFE7A; -"Pointer_Left",0xFEE0; -"Pointer_Right",0xFEE1; -"Pointer_Up",0xFEE2; -"Pointer_Down",0xFEE3; -"Pointer_UpLeft",0xFEE4; -"Pointer_UpRight",0xFEE5; -"Pointer_DownLeft",0xFEE6; -"Pointer_DownRight",0xFEE7; -"Pointer_Button_Dflt",0xFEE8; -"Pointer_Button1",0xFEE9; -"Pointer_Button2",0xFEEA; -"Pointer_Button3",0xFEEB; -"Pointer_Button4",0xFEEC; -"Pointer_Button5",0xFEED; -"Pointer_DblClick_Dflt",0xFEEE; -"Pointer_DblClick1",0xFEEF; -"Pointer_DblClick2",0xFEF0; -"Pointer_DblClick3",0xFEF1; -"Pointer_DblClick4",0xFEF2; -"Pointer_DblClick5",0xFEF3; -"Pointer_Drag_Dflt",0xFEF4; -"Pointer_Drag1",0xFEF5; -"Pointer_Drag2",0xFEF6; -"Pointer_Drag3",0xFEF7; -"Pointer_Drag4",0xFEF8; -"Pointer_Drag5",0xFEFD; -"Pointer_EnableKeys",0xFEF9; -"Pointer_Accelerate",0xFEFA; -"Pointer_DfltBtnNext",0xFEFB; -"Pointer_DfltBtnPrev",0xFEFC; -"3270_Duplicate",0xFD01; -"3270_FieldMark",0xFD02; -"3270_Right2",0xFD03; -"3270_Left2",0xFD04; -"3270_BackTab",0xFD05; -"3270_EraseEOF",0xFD06; -"3270_EraseInput",0xFD07; -"3270_Reset",0xFD08; -"3270_Quit",0xFD09; -"3270_PA1",0xFD0A; -"3270_PA2",0xFD0B; -"3270_PA3",0xFD0C; -"3270_Test",0xFD0D; -"3270_Attn",0xFD0E; -"3270_CursorBlink",0xFD0F; -"3270_AltCursor",0xFD10; -"3270_KeyClick",0xFD11; -"3270_Jump",0xFD12; -"3270_Ident",0xFD13; -"3270_Rule",0xFD14; -"3270_Copy",0xFD15; -"3270_Play",0xFD16; -"3270_Setup",0xFD17; -"3270_Record",0xFD18; -"3270_ChangeScreen",0xFD19; -"3270_DeleteWord",0xFD1A; -"3270_ExSelect",0xFD1B; -"3270_CursorSelect",0xFD1C; -"3270_PrintScreen",0xFD1D; -"3270_Enter",0xFD1E; -"space",0x020; -"exclam",0x021; -"quotedbl",0x022; -"numbersign",0x023; -"dollar",0x024; -"percent",0x025; -"ampersand",0x026; -"apostrophe",0x027; -"quoteright",0x027; -"parenleft",0x028; -"parenright",0x029; -"asterisk",0x02a; -"plus",0x02b; -"comma",0x02c; -"minus",0x02d; -"period",0x02e; -"slash",0x02f; -"0",0x030; -"1",0x031; -"2",0x032; -"3",0x033; -"4",0x034; -"5",0x035; -"6",0x036; -"7",0x037; -"8",0x038; -"9",0x039; -"colon",0x03a; -"semicolon",0x03b; -"less",0x03c; -"equal",0x03d; -"greater",0x03e; -"question",0x03f; -"at",0x040; -"A",0x041; -"B",0x042; -"C",0x043; -"D",0x044; -"E",0x045; -"F",0x046; -"G",0x047; -"H",0x048; -"I",0x049; -"J",0x04a; -"K",0x04b; -"L",0x04c; -"M",0x04d; -"N",0x04e; -"O",0x04f; -"P",0x050; -"Q",0x051; -"R",0x052; -"S",0x053; -"T",0x054; -"U",0x055; -"V",0x056; -"W",0x057; -"X",0x058; -"Y",0x059; -"Z",0x05a; -"bracketleft",0x05b; -"backslash",0x05c; -"bracketright",0x05d; -"asciicircum",0x05e; -"underscore",0x05f; -"grave",0x060; -"quoteleft",0x060; -"a",0x061; -"b",0x062; -"c",0x063; -"d",0x064; -"e",0x065; -"f",0x066; -"g",0x067; -"h",0x068; -"i",0x069; -"j",0x06a; -"k",0x06b; -"l",0x06c; -"m",0x06d; -"n",0x06e; -"o",0x06f; -"p",0x070; -"q",0x071; -"r",0x072; -"s",0x073; -"t",0x074; -"u",0x075; -"v",0x076; -"w",0x077; -"x",0x078; -"y",0x079; -"z",0x07a; -"braceleft",0x07b; -"bar",0x07c; -"braceright",0x07d; -"asciitilde",0x07e; -"nobreakspace",0x0a0; -"exclamdown",0x0a1; -"cent",0x0a2; -"sterling",0x0a3; -"currency",0x0a4; -"yen",0x0a5; -"brokenbar",0x0a6; -"section",0x0a7; -"diaeresis",0x0a8; -"copyright",0x0a9; -"ordfeminine",0x0aa; -"guillemotleft",0x0ab; -"notsign",0x0ac; -"hyphen",0x0ad; -"registered",0x0ae; -"macron",0x0af; -"degree",0x0b0; -"plusminus",0x0b1; -"twosuperior",0x0b2; -"threesuperior",0x0b3; -"acute",0x0b4; -"mu",0x0b5; -"paragraph",0x0b6; -"periodcentered",0x0b7; -"cedilla",0x0b8; -"onesuperior",0x0b9; -"masculine",0x0ba; -"guillemotright",0x0bb; -"onequarter",0x0bc; -"onehalf",0x0bd; -"threequarters",0x0be; -"questiondown",0x0bf; -"Agrave",0x0c0; -"Aacute",0x0c1; -"Acircumflex",0x0c2; -"Atilde",0x0c3; -"Adiaeresis",0x0c4; -"Aring",0x0c5; -"AE",0x0c6; -"Ccedilla",0x0c7; -"Egrave",0x0c8; -"Eacute",0x0c9; -"Ecircumflex",0x0ca; -"Ediaeresis",0x0cb; -"Igrave",0x0cc; -"Iacute",0x0cd; -"Icircumflex",0x0ce; -"Idiaeresis",0x0cf; -"ETH",0x0d0; -"Eth",0x0d0; -"Ntilde",0x0d1; -"Ograve",0x0d2; -"Oacute",0x0d3; -"Ocircumflex",0x0d4; -"Otilde",0x0d5; -"Odiaeresis",0x0d6; -"multiply",0x0d7; -"Ooblique",0x0d8; -"Ugrave",0x0d9; -"Uacute",0x0da; -"Ucircumflex",0x0db; -"Udiaeresis",0x0dc; -"Yacute",0x0dd; -"THORN",0x0de; -"Thorn",0x0de; -"ssharp",0x0df; -"agrave",0x0e0; -"aacute",0x0e1; -"acircumflex",0x0e2; -"atilde",0x0e3; -"adiaeresis",0x0e4; -"aring",0x0e5; -"ae",0x0e6; -"ccedilla",0x0e7; -"egrave",0x0e8; -"eacute",0x0e9; -"ecircumflex",0x0ea; -"ediaeresis",0x0eb; -"igrave",0x0ec; -"iacute",0x0ed; -"icircumflex",0x0ee; -"idiaeresis",0x0ef; -"eth",0x0f0; -"ntilde",0x0f1; -"ograve",0x0f2; -"oacute",0x0f3; -"ocircumflex",0x0f4; -"otilde",0x0f5; -"odiaeresis",0x0f6; -"division",0x0f7; -"oslash",0x0f8; -"ugrave",0x0f9; -"uacute",0x0fa; -"ucircumflex",0x0fb; -"udiaeresis",0x0fc; -"yacute",0x0fd; -"thorn",0x0fe; -"ydiaeresis",0x0ff; -"Aogonek",0x1a1; -"breve",0x1a2; -"Lstroke",0x1a3; -"Lcaron",0x1a5; -"Sacute",0x1a6; -"Scaron",0x1a9; -"Scedilla",0x1aa; -"Tcaron",0x1ab; -"Zacute",0x1ac; -"Zcaron",0x1ae; -"Zabovedot",0x1af; -"aogonek",0x1b1; -"ogonek",0x1b2; -"lstroke",0x1b3; -"lcaron",0x1b5; -"sacute",0x1b6; -"caron",0x1b7; -"scaron",0x1b9; -"scedilla",0x1ba; -"tcaron",0x1bb; -"zacute",0x1bc; -"doubleacute",0x1bd; -"zcaron",0x1be; -"zabovedot",0x1bf; -"Racute",0x1c0; -"Abreve",0x1c3; -"Lacute",0x1c5; -"Cacute",0x1c6; -"Ccaron",0x1c8; -"Eogonek",0x1ca; -"Ecaron",0x1cc; -"Dcaron",0x1cf; -"Dstroke",0x1d0; -"Nacute",0x1d1; -"Ncaron",0x1d2; -"Odoubleacute",0x1d5; -"Rcaron",0x1d8; -"Uring",0x1d9; -"Udoubleacute",0x1db; -"Tcedilla",0x1de; -"racute",0x1e0; -"abreve",0x1e3; -"lacute",0x1e5; -"cacute",0x1e6; -"ccaron",0x1e8; -"eogonek",0x1ea; -"ecaron",0x1ec; -"dcaron",0x1ef; -"dstroke",0x1f0; -"nacute",0x1f1; -"ncaron",0x1f2; -"odoubleacute",0x1f5; -"udoubleacute",0x1fb; -"rcaron",0x1f8; -"uring",0x1f9; -"tcedilla",0x1fe; -"abovedot",0x1ff; -"Hstroke",0x2a1; -"Hcircumflex",0x2a6; -"Iabovedot",0x2a9; -"Gbreve",0x2ab; -"Jcircumflex",0x2ac; -"hstroke",0x2b1; -"hcircumflex",0x2b6; -"idotless",0x2b9; -"gbreve",0x2bb; -"jcircumflex",0x2bc; -"Cabovedot",0x2c5; -"Ccircumflex",0x2c6; -"Gabovedot",0x2d5; -"Gcircumflex",0x2d8; -"Ubreve",0x2dd; -"Scircumflex",0x2de; -"cabovedot",0x2e5; -"ccircumflex",0x2e6; -"gabovedot",0x2f5; -"gcircumflex",0x2f8; -"ubreve",0x2fd; -"scircumflex",0x2fe; -"kra",0x3a2; -"kappa",0x3a2; -"Rcedilla",0x3a3; -"Itilde",0x3a5; -"Lcedilla",0x3a6; -"Emacron",0x3aa; -"Gcedilla",0x3ab; -"Tslash",0x3ac; -"rcedilla",0x3b3; -"itilde",0x3b5; -"lcedilla",0x3b6; -"emacron",0x3ba; -"gcedilla",0x3bb; -"tslash",0x3bc; -"ENG",0x3bd; -"eng",0x3bf; -"Amacron",0x3c0; -"Iogonek",0x3c7; -"Eabovedot",0x3cc; -"Imacron",0x3cf; -"Ncedilla",0x3d1; -"Omacron",0x3d2; -"Kcedilla",0x3d3; -"Uogonek",0x3d9; -"Utilde",0x3dd; -"Umacron",0x3de; -"amacron",0x3e0; -"iogonek",0x3e7; -"eabovedot",0x3ec; -"imacron",0x3ef; -"ncedilla",0x3f1; -"omacron",0x3f2; -"kcedilla",0x3f3; -"uogonek",0x3f9; -"utilde",0x3fd; -"umacron",0x3fe; -"overline",0x47e; -"kana_fullstop",0x4a1; -"kana_openingbracket",0x4a2; -"kana_closingbracket",0x4a3; -"kana_comma",0x4a4; -"kana_conjunctive",0x4a5; -"kana_middledot",0x4a5; -"kana_WO",0x4a6; -"kana_a",0x4a7; -"kana_i",0x4a8; -"kana_u",0x4a9; -"kana_e",0x4aa; -"kana_o",0x4ab; -"kana_ya",0x4ac; -"kana_yu",0x4ad; -"kana_yo",0x4ae; -"kana_tsu",0x4af; -"kana_tu",0x4af; -"prolongedsound",0x4b0; -"kana_A",0x4b1; -"kana_I",0x4b2; -"kana_U",0x4b3; -"kana_E",0x4b4; -"kana_O",0x4b5; -"kana_KA",0x4b6; -"kana_KI",0x4b7; -"kana_KU",0x4b8; -"kana_KE",0x4b9; -"kana_KO",0x4ba; -"kana_SA",0x4bb; -"kana_SHI",0x4bc; -"kana_SU",0x4bd; -"kana_SE",0x4be; -"kana_SO",0x4bf; -"kana_TA",0x4c0; -"kana_CHI",0x4c1; -"kana_TI",0x4c1; -"kana_TSU",0x4c2; -"kana_TU",0x4c2; -"kana_TE",0x4c3; -"kana_TO",0x4c4; -"kana_NA",0x4c5; -"kana_NI",0x4c6; -"kana_NU",0x4c7; -"kana_NE",0x4c8; -"kana_NO",0x4c9; -"kana_HA",0x4ca; -"kana_HI",0x4cb; -"kana_FU",0x4cc; -"kana_HU",0x4cc; -"kana_HE",0x4cd; -"kana_HO",0x4ce; -"kana_MA",0x4cf; -"kana_MI",0x4d0; -"kana_MU",0x4d1; -"kana_ME",0x4d2; -"kana_MO",0x4d3; -"kana_YA",0x4d4; -"kana_YU",0x4d5; -"kana_YO",0x4d6; -"kana_RA",0x4d7; -"kana_RI",0x4d8; -"kana_RU",0x4d9; -"kana_RE",0x4da; -"kana_RO",0x4db; -"kana_WA",0x4dc; -"kana_N",0x4dd; -"voicedsound",0x4de; -"semivoicedsound",0x4df; -"kana_switch",0xFF7E; -"Arabic_comma",0x5ac; -"Arabic_semicolon",0x5bb; -"Arabic_question_mark",0x5bf; -"Arabic_hamza",0x5c1; -"Arabic_maddaonalef",0x5c2; -"Arabic_hamzaonalef",0x5c3; -"Arabic_hamzaonwaw",0x5c4; -"Arabic_hamzaunderalef",0x5c5; -"Arabic_hamzaonyeh",0x5c6; -"Arabic_alef",0x5c7; -"Arabic_beh",0x5c8; -"Arabic_tehmarbuta",0x5c9; -"Arabic_teh",0x5ca; -"Arabic_theh",0x5cb; -"Arabic_jeem",0x5cc; -"Arabic_hah",0x5cd; -"Arabic_khah",0x5ce; -"Arabic_dal",0x5cf; -"Arabic_thal",0x5d0; -"Arabic_ra",0x5d1; -"Arabic_zain",0x5d2; -"Arabic_seen",0x5d3; -"Arabic_sheen",0x5d4; -"Arabic_sad",0x5d5; -"Arabic_dad",0x5d6; -"Arabic_tah",0x5d7; -"Arabic_zah",0x5d8; -"Arabic_ain",0x5d9; -"Arabic_ghain",0x5da; -"Arabic_tatweel",0x5e0; -"Arabic_feh",0x5e1; -"Arabic_qaf",0x5e2; -"Arabic_kaf",0x5e3; -"Arabic_lam",0x5e4; -"Arabic_meem",0x5e5; -"Arabic_noon",0x5e6; -"Arabic_ha",0x5e7; -"Arabic_heh",0x5e7; -"Arabic_waw",0x5e8; -"Arabic_alefmaksura",0x5e9; -"Arabic_yeh",0x5ea; -"Arabic_fathatan",0x5eb; -"Arabic_dammatan",0x5ec; -"Arabic_kasratan",0x5ed; -"Arabic_fatha",0x5ee; -"Arabic_damma",0x5ef; -"Arabic_kasra",0x5f0; -"Arabic_shadda",0x5f1; -"Arabic_sukun",0x5f2; -"Arabic_switch",0xFF7E; -"Serbian_dje",0x6a1; -"Macedonia_gje",0x6a2; -"Cyrillic_io",0x6a3; -"Ukrainian_ie",0x6a4; -"Ukranian_je",0x6a4; -"Macedonia_dse",0x6a5; -"Ukrainian_i",0x6a6; -"Ukranian_i",0x6a6; -"Ukrainian_yi",0x6a7; -"Ukranian_yi",0x6a7; -"Cyrillic_je",0x6a8; -"Serbian_je",0x6a8; -"Cyrillic_lje",0x6a9; -"Serbian_lje",0x6a9; -"Cyrillic_nje",0x6aa; -"Serbian_nje",0x6aa; -"Serbian_tshe",0x6ab; -"Macedonia_kje",0x6ac; -"Byelorussian_shortu",0x6ae; -"Cyrillic_dzhe",0x6af; -"Serbian_dze",0x6af; -"numerosign",0x6b0; -"Serbian_DJE",0x6b1; -"Macedonia_GJE",0x6b2; -"Cyrillic_IO",0x6b3; -"Ukrainian_IE",0x6b4; -"Ukranian_JE",0x6b4; -"Macedonia_DSE",0x6b5; -"Ukrainian_I",0x6b6; -"Ukranian_I",0x6b6; -"Ukrainian_YI",0x6b7; -"Ukranian_YI",0x6b7; -"Cyrillic_JE",0x6b8; -"Serbian_JE",0x6b8; -"Cyrillic_LJE",0x6b9; -"Serbian_LJE",0x6b9; -"Cyrillic_NJE",0x6ba; -"Serbian_NJE",0x6ba; -"Serbian_TSHE",0x6bb; -"Macedonia_KJE",0x6bc; -"Byelorussian_SHORTU",0x6be; -"Cyrillic_DZHE",0x6bf; -"Serbian_DZE",0x6bf; -"Cyrillic_yu",0x6c0; -"Cyrillic_a",0x6c1; -"Cyrillic_be",0x6c2; -"Cyrillic_tse",0x6c3; -"Cyrillic_de",0x6c4; -"Cyrillic_ie",0x6c5; -"Cyrillic_ef",0x6c6; -"Cyrillic_ghe",0x6c7; -"Cyrillic_ha",0x6c8; -"Cyrillic_i",0x6c9; -"Cyrillic_shorti",0x6ca; -"Cyrillic_ka",0x6cb; -"Cyrillic_el",0x6cc; -"Cyrillic_em",0x6cd; -"Cyrillic_en",0x6ce; -"Cyrillic_o",0x6cf; -"Cyrillic_pe",0x6d0; -"Cyrillic_ya",0x6d1; -"Cyrillic_er",0x6d2; -"Cyrillic_es",0x6d3; -"Cyrillic_te",0x6d4; -"Cyrillic_u",0x6d5; -"Cyrillic_zhe",0x6d6; -"Cyrillic_ve",0x6d7; -"Cyrillic_softsign",0x6d8; -"Cyrillic_yeru",0x6d9; -"Cyrillic_ze",0x6da; -"Cyrillic_sha",0x6db; -"Cyrillic_e",0x6dc; -"Cyrillic_shcha",0x6dd; -"Cyrillic_che",0x6de; -"Cyrillic_hardsign",0x6df; -"Cyrillic_YU",0x6e0; -"Cyrillic_A",0x6e1; -"Cyrillic_BE",0x6e2; -"Cyrillic_TSE",0x6e3; -"Cyrillic_DE",0x6e4; -"Cyrillic_IE",0x6e5; -"Cyrillic_EF",0x6e6; -"Cyrillic_GHE",0x6e7; -"Cyrillic_HA",0x6e8; -"Cyrillic_I",0x6e9; -"Cyrillic_SHORTI",0x6ea; -"Cyrillic_KA",0x6eb; -"Cyrillic_EL",0x6ec; -"Cyrillic_EM",0x6ed; -"Cyrillic_EN",0x6ee; -"Cyrillic_O",0x6ef; -"Cyrillic_PE",0x6f0; -"Cyrillic_YA",0x6f1; -"Cyrillic_ER",0x6f2; -"Cyrillic_ES",0x6f3; -"Cyrillic_TE",0x6f4; -"Cyrillic_U",0x6f5; -"Cyrillic_ZHE",0x6f6; -"Cyrillic_VE",0x6f7; -"Cyrillic_SOFTSIGN",0x6f8; -"Cyrillic_YERU",0x6f9; -"Cyrillic_ZE",0x6fa; -"Cyrillic_SHA",0x6fb; -"Cyrillic_E",0x6fc; -"Cyrillic_SHCHA",0x6fd; -"Cyrillic_CHE",0x6fe; -"Cyrillic_HARDSIGN",0x6ff; -"Greek_ALPHAaccent",0x7a1; -"Greek_EPSILONaccent",0x7a2; -"Greek_ETAaccent",0x7a3; -"Greek_IOTAaccent",0x7a4; -"Greek_IOTAdiaeresis",0x7a5; -"Greek_OMICRONaccent",0x7a7; -"Greek_UPSILONaccent",0x7a8; -"Greek_UPSILONdieresis",0x7a9; -"Greek_OMEGAaccent",0x7ab; -"Greek_accentdieresis",0x7ae; -"Greek_horizbar",0x7af; -"Greek_alphaaccent",0x7b1; -"Greek_epsilonaccent",0x7b2; -"Greek_etaaccent",0x7b3; -"Greek_iotaaccent",0x7b4; -"Greek_iotadieresis",0x7b5; -"Greek_iotaaccentdieresis",0x7b6; -"Greek_omicronaccent",0x7b7; -"Greek_upsilonaccent",0x7b8; -"Greek_upsilondieresis",0x7b9; -"Greek_upsilonaccentdieresis",0x7ba; -"Greek_omegaaccent",0x7bb; -"Greek_ALPHA",0x7c1; -"Greek_BETA",0x7c2; -"Greek_GAMMA",0x7c3; -"Greek_DELTA",0x7c4; -"Greek_EPSILON",0x7c5; -"Greek_ZETA",0x7c6; -"Greek_ETA",0x7c7; -"Greek_THETA",0x7c8; -"Greek_IOTA",0x7c9; -"Greek_KAPPA",0x7ca; -"Greek_LAMDA",0x7cb; -"Greek_LAMBDA",0x7cb; -"Greek_MU",0x7cc; -"Greek_NU",0x7cd; -"Greek_XI",0x7ce; -"Greek_OMICRON",0x7cf; -"Greek_PI",0x7d0; -"Greek_RHO",0x7d1; -"Greek_SIGMA",0x7d2; -"Greek_TAU",0x7d4; -"Greek_UPSILON",0x7d5; -"Greek_PHI",0x7d6; -"Greek_CHI",0x7d7; -"Greek_PSI",0x7d8; -"Greek_OMEGA",0x7d9; -"Greek_alpha",0x7e1; -"Greek_beta",0x7e2; -"Greek_gamma",0x7e3; -"Greek_delta",0x7e4; -"Greek_epsilon",0x7e5; -"Greek_zeta",0x7e6; -"Greek_eta",0x7e7; -"Greek_theta",0x7e8; -"Greek_iota",0x7e9; -"Greek_kappa",0x7ea; -"Greek_lamda",0x7eb; -"Greek_lambda",0x7eb; -"Greek_mu",0x7ec; -"Greek_nu",0x7ed; -"Greek_xi",0x7ee; -"Greek_omicron",0x7ef; -"Greek_pi",0x7f0; -"Greek_rho",0x7f1; -"Greek_sigma",0x7f2; -"Greek_finalsmallsigma",0x7f3; -"Greek_tau",0x7f4; -"Greek_upsilon",0x7f5; -"Greek_phi",0x7f6; -"Greek_chi",0x7f7; -"Greek_psi",0x7f8; -"Greek_omega",0x7f9; -"Greek_switch",0xFF7E; -"leftradical",0x8a1; -"topleftradical",0x8a2; -"horizconnector",0x8a3; -"topintegral",0x8a4; -"botintegral",0x8a5; -"vertconnector",0x8a6; -"topleftsqbracket",0x8a7; -"botleftsqbracket",0x8a8; -"toprightsqbracket",0x8a9; -"botrightsqbracket",0x8aa; -"topleftparens",0x8ab; -"botleftparens",0x8ac; -"toprightparens",0x8ad; -"botrightparens",0x8ae; -"leftmiddlecurlybrace",0x8af; -"rightmiddlecurlybrace",0x8b0; -"topleftsummation",0x8b1; -"botleftsummation",0x8b2; -"topvertsummationconnector",0x8b3; -"botvertsummationconnector",0x8b4; -"toprightsummation",0x8b5; -"botrightsummation",0x8b6; -"rightmiddlesummation",0x8b7; -"lessthanequal",0x8bc; -"notequal",0x8bd; -"greaterthanequal",0x8be; -"integral",0x8bf; -"therefore",0x8c0; -"variation",0x8c1; -"infinity",0x8c2; -"nabla",0x8c5; -"approximate",0x8c8; -"similarequal",0x8c9; -"ifonlyif",0x8cd; -"implies",0x8ce; -"identical",0x8cf; -"radical",0x8d6; -"includedin",0x8da; -"includes",0x8db; -"intersection",0x8dc; -"union",0x8dd; -"logicaland",0x8de; -"logicalor",0x8df; -"partialderivative",0x8ef; -"function",0x8f6; -"leftarrow",0x8fb; -"uparrow",0x8fc; -"rightarrow",0x8fd; -"downarrow",0x8fe; -"blank",0x9df; -"soliddiamond",0x9e0; -"checkerboard",0x9e1; -"ht",0x9e2; -"ff",0x9e3; -"cr",0x9e4; -"lf",0x9e5; -"nl",0x9e8; -"vt",0x9e9; -"lowrightcorner",0x9ea; -"uprightcorner",0x9eb; -"upleftcorner",0x9ec; -"lowleftcorner",0x9ed; -"crossinglines",0x9ee; -"horizlinescan1",0x9ef; -"horizlinescan3",0x9f0; -"horizlinescan5",0x9f1; -"horizlinescan7",0x9f2; -"horizlinescan9",0x9f3; -"leftt",0x9f4; -"rightt",0x9f5; -"bott",0x9f6; -"topt",0x9f7; -"vertbar",0x9f8; -"emspace",0xaa1; -"enspace",0xaa2; -"em3space",0xaa3; -"em4space",0xaa4; -"digitspace",0xaa5; -"punctspace",0xaa6; -"thinspace",0xaa7; -"hairspace",0xaa8; -"emdash",0xaa9; -"endash",0xaaa; -"signifblank",0xaac; -"ellipsis",0xaae; -"doubbaselinedot",0xaaf; -"onethird",0xab0; -"twothirds",0xab1; -"onefifth",0xab2; -"twofifths",0xab3; -"threefifths",0xab4; -"fourfifths",0xab5; -"onesixth",0xab6; -"fivesixths",0xab7; -"careof",0xab8; -"figdash",0xabb; -"leftanglebracket",0xabc; -"decimalpoint",0xabd; -"rightanglebracket",0xabe; -"marker",0xabf; -"oneeighth",0xac3; -"threeeighths",0xac4; -"fiveeighths",0xac5; -"seveneighths",0xac6; -"trademark",0xac9; -"signaturemark",0xaca; -"trademarkincircle",0xacb; -"leftopentriangle",0xacc; -"rightopentriangle",0xacd; -"emopencircle",0xace; -"emopenrectangle",0xacf; -"leftsinglequotemark",0xad0; -"rightsinglequotemark",0xad1; -"leftdoublequotemark",0xad2; -"rightdoublequotemark",0xad3; -"prescription",0xad4; -"minutes",0xad6; -"seconds",0xad7; -"latincross",0xad9; -"hexagram",0xada; -"filledrectbullet",0xadb; -"filledlefttribullet",0xadc; -"filledrighttribullet",0xadd; -"emfilledcircle",0xade; -"emfilledrect",0xadf; -"enopencircbullet",0xae0; -"enopensquarebullet",0xae1; -"openrectbullet",0xae2; -"opentribulletup",0xae3; -"opentribulletdown",0xae4; -"openstar",0xae5; -"enfilledcircbullet",0xae6; -"enfilledsqbullet",0xae7; -"filledtribulletup",0xae8; -"filledtribulletdown",0xae9; -"leftpointer",0xaea; -"rightpointer",0xaeb; -"club",0xaec; -"diamond",0xaed; -"heart",0xaee; -"maltesecross",0xaf0; -"dagger",0xaf1; -"doubledagger",0xaf2; -"checkmark",0xaf3; -"ballotcross",0xaf4; -"musicalsharp",0xaf5; -"musicalflat",0xaf6; -"malesymbol",0xaf7; -"femalesymbol",0xaf8; -"telephone",0xaf9; -"telephonerecorder",0xafa; -"phonographcopyright",0xafb; -"caret",0xafc; -"singlelowquotemark",0xafd; -"doublelowquotemark",0xafe; -"cursor",0xaff; -"leftcaret",0xba3; -"rightcaret",0xba6; -"downcaret",0xba8; -"upcaret",0xba9; -"overbar",0xbc0; -"downtack",0xbc2; -"upshoe",0xbc3; -"downstile",0xbc4; -"underbar",0xbc6; -"jot",0xbca; -"quad",0xbcc; -"uptack",0xbce; -"circle",0xbcf; -"upstile",0xbd3; -"downshoe",0xbd6; -"rightshoe",0xbd8; -"leftshoe",0xbda; -"lefttack",0xbdc; -"righttack",0xbfc; -"hebrew_doublelowline",0xcdf; -"hebrew_aleph",0xce0; -"hebrew_bet",0xce1; -"hebrew_beth",0xce1; -"hebrew_gimel",0xce2; -"hebrew_gimmel",0xce2; -"hebrew_dalet",0xce3; -"hebrew_daleth",0xce3; -"hebrew_he",0xce4; -"hebrew_waw",0xce5; -"hebrew_zain",0xce6; -"hebrew_zayin",0xce6; -"hebrew_chet",0xce7; -"hebrew_het",0xce7; -"hebrew_tet",0xce8; -"hebrew_teth",0xce8; -"hebrew_yod",0xce9; -"hebrew_finalkaph",0xcea; -"hebrew_kaph",0xceb; -"hebrew_lamed",0xcec; -"hebrew_finalmem",0xced; -"hebrew_mem",0xcee; -"hebrew_finalnun",0xcef; -"hebrew_nun",0xcf0; -"hebrew_samech",0xcf1; -"hebrew_samekh",0xcf1; -"hebrew_ayin",0xcf2; -"hebrew_finalpe",0xcf3; -"hebrew_pe",0xcf4; -"hebrew_finalzade",0xcf5; -"hebrew_finalzadi",0xcf5; -"hebrew_zade",0xcf6; -"hebrew_zadi",0xcf6; -"hebrew_qoph",0xcf7; -"hebrew_kuf",0xcf7; -"hebrew_resh",0xcf8; -"hebrew_shin",0xcf9; -"hebrew_taw",0xcfa; -"hebrew_taf",0xcfa; -"Hebrew_switch",0xFF7E; -"Thai_kokai",0xda1; -"Thai_khokhai",0xda2; -"Thai_khokhuat",0xda3; -"Thai_khokhwai",0xda4; -"Thai_khokhon",0xda5; -"Thai_khorakhang",0xda6; -"Thai_ngongu",0xda7; -"Thai_chochan",0xda8; -"Thai_choching",0xda9; -"Thai_chochang",0xdaa; -"Thai_soso",0xdab; -"Thai_chochoe",0xdac; -"Thai_yoying",0xdad; -"Thai_dochada",0xdae; -"Thai_topatak",0xdaf; -"Thai_thothan",0xdb0; -"Thai_thonangmontho",0xdb1; -"Thai_thophuthao",0xdb2; -"Thai_nonen",0xdb3; -"Thai_dodek",0xdb4; -"Thai_totao",0xdb5; -"Thai_thothung",0xdb6; -"Thai_thothahan",0xdb7; -"Thai_thothong",0xdb8; -"Thai_nonu",0xdb9; -"Thai_bobaimai",0xdba; -"Thai_popla",0xdbb; -"Thai_phophung",0xdbc; -"Thai_fofa",0xdbd; -"Thai_phophan",0xdbe; -"Thai_fofan",0xdbf; -"Thai_phosamphao",0xdc0; -"Thai_moma",0xdc1; -"Thai_yoyak",0xdc2; -"Thai_rorua",0xdc3; -"Thai_ru",0xdc4; -"Thai_loling",0xdc5; -"Thai_lu",0xdc6; -"Thai_wowaen",0xdc7; -"Thai_sosala",0xdc8; -"Thai_sorusi",0xdc9; -"Thai_sosua",0xdca; -"Thai_hohip",0xdcb; -"Thai_lochula",0xdcc; -"Thai_oang",0xdcd; -"Thai_honokhuk",0xdce; -"Thai_paiyannoi",0xdcf; -"Thai_saraa",0xdd0; -"Thai_maihanakat",0xdd1; -"Thai_saraaa",0xdd2; -"Thai_saraam",0xdd3; -"Thai_sarai",0xdd4; -"Thai_saraii",0xdd5; -"Thai_saraue",0xdd6; -"Thai_sarauee",0xdd7; -"Thai_sarau",0xdd8; -"Thai_sarauu",0xdd9; -"Thai_phinthu",0xdda; -"Thai_maihanakat_maitho",0xdde; -"Thai_baht",0xddf; -"Thai_sarae",0xde0; -"Thai_saraae",0xde1; -"Thai_sarao",0xde2; -"Thai_saraaimaimuan",0xde3; -"Thai_saraaimaimalai",0xde4; -"Thai_lakkhangyao",0xde5; -"Thai_maiyamok",0xde6; -"Thai_maitaikhu",0xde7; -"Thai_maiek",0xde8; -"Thai_maitho",0xde9; -"Thai_maitri",0xdea; -"Thai_maichattawa",0xdeb; -"Thai_thanthakhat",0xdec; -"Thai_nikhahit",0xded; -"Thai_leksun",0xdf0; -"Thai_leknung",0xdf1; -"Thai_leksong",0xdf2; -"Thai_leksam",0xdf3; -"Thai_leksi",0xdf4; -"Thai_lekha",0xdf5; -"Thai_lekhok",0xdf6; -"Thai_lekchet",0xdf7; -"Thai_lekpaet",0xdf8; -"Thai_lekkao",0xdf9; -"Hangul",0xff31; -"Hangul_Start",0xff32; -"Hangul_End",0xff33; -"Hangul_Hanja",0xff34; -"Hangul_Jamo",0xff35; -"Hangul_Romaja",0xff36; -"Hangul_Codeinput",0xff37; -"Hangul_Jeonja",0xff38; -"Hangul_Banja",0xff39; -"Hangul_PreHanja",0xff3a; -"Hangul_PostHanja",0xff3b; -"Hangul_SingleCandidate",0xff3c; -"Hangul_MultipleCandidate",0xff3d; -"Hangul_PreviousCandidate",0xff3e; -"Hangul_Special",0xff3f; -"Hangul_switch",0xFF7E; -"Hangul_Kiyeog",0xea1; -"Hangul_SsangKiyeog",0xea2; -"Hangul_KiyeogSios",0xea3; -"Hangul_Nieun",0xea4; -"Hangul_NieunJieuj",0xea5; -"Hangul_NieunHieuh",0xea6; -"Hangul_Dikeud",0xea7; -"Hangul_SsangDikeud",0xea8; -"Hangul_Rieul",0xea9; -"Hangul_RieulKiyeog",0xeaa; -"Hangul_RieulMieum",0xeab; -"Hangul_RieulPieub",0xeac; -"Hangul_RieulSios",0xead; -"Hangul_RieulTieut",0xeae; -"Hangul_RieulPhieuf",0xeaf; -"Hangul_RieulHieuh",0xeb0; -"Hangul_Mieum",0xeb1; -"Hangul_Pieub",0xeb2; -"Hangul_SsangPieub",0xeb3; -"Hangul_PieubSios",0xeb4; -"Hangul_Sios",0xeb5; -"Hangul_SsangSios",0xeb6; -"Hangul_Ieung",0xeb7; -"Hangul_Jieuj",0xeb8; -"Hangul_SsangJieuj",0xeb9; -"Hangul_Cieuc",0xeba; -"Hangul_Khieuq",0xebb; -"Hangul_Tieut",0xebc; -"Hangul_Phieuf",0xebd; -"Hangul_Hieuh",0xebe; -"Hangul_A",0xebf; -"Hangul_AE",0xec0; -"Hangul_YA",0xec1; -"Hangul_YAE",0xec2; -"Hangul_EO",0xec3; -"Hangul_E",0xec4; -"Hangul_YEO",0xec5; -"Hangul_YE",0xec6; -"Hangul_O",0xec7; -"Hangul_WA",0xec8; -"Hangul_WAE",0xec9; -"Hangul_OE",0xeca; -"Hangul_YO",0xecb; -"Hangul_U",0xecc; -"Hangul_WEO",0xecd; -"Hangul_WE",0xece; -"Hangul_WI",0xecf; -"Hangul_YU",0xed0; -"Hangul_EU",0xed1; -"Hangul_YI",0xed2; -"Hangul_I",0xed3; -"Hangul_J_Kiyeog",0xed4; -"Hangul_J_SsangKiyeog",0xed5; -"Hangul_J_KiyeogSios",0xed6; -"Hangul_J_Nieun",0xed7; -"Hangul_J_NieunJieuj",0xed8; -"Hangul_J_NieunHieuh",0xed9; -"Hangul_J_Dikeud",0xeda; -"Hangul_J_Rieul",0xedb; -"Hangul_J_RieulKiyeog",0xedc; -"Hangul_J_RieulMieum",0xedd; -"Hangul_J_RieulPieub",0xede; -"Hangul_J_RieulSios",0xedf; -"Hangul_J_RieulTieut",0xee0; -"Hangul_J_RieulPhieuf",0xee1; -"Hangul_J_RieulHieuh",0xee2; -"Hangul_J_Mieum",0xee3; -"Hangul_J_Pieub",0xee4; -"Hangul_J_PieubSios",0xee5; -"Hangul_J_Sios",0xee6; -"Hangul_J_SsangSios",0xee7; -"Hangul_J_Ieung",0xee8; -"Hangul_J_Jieuj",0xee9; -"Hangul_J_Cieuc",0xeea; -"Hangul_J_Khieuq",0xeeb; -"Hangul_J_Tieut",0xeec; -"Hangul_J_Phieuf",0xeed; -"Hangul_J_Hieuh",0xeee; -"Hangul_RieulYeorinHieuh",0xeef; -"Hangul_SunkyeongeumMieum",0xef0; -"Hangul_SunkyeongeumPieub",0xef1; -"Hangul_PanSios",0xef2; -"Hangul_KkogjiDalrinIeung",0xef3; -"Hangul_SunkyeongeumPhieuf",0xef4; -"Hangul_YeorinHieuh",0xef5; -"Hangul_AraeA",0xef6; -"Hangul_AraeAE",0xef7; -"Hangul_J_PanSios",0xef8; -"Hangul_J_KkogjiDalrinIeung",0xef9; -"Hangul_J_YeorinHieuh",0xefa; -"Korean_Won",0xeff; -] -let keysym_to_name = [ -0xFFFFFF,"VoidSymbol"; -0xFF08,"BackSpace"; -0xFF09,"Tab"; -0xFF0A,"Linefeed"; -0xFF0B,"Clear"; -0xFF0D,"Return"; -0xFF13,"Pause"; -0xFF14,"Scroll_Lock"; -0xFF15,"Sys_Req"; -0xFF1B,"Escape"; -0xFFFF,"Delete"; -0xFF20,"Multi_key"; -0xFF21,"Kanji"; -0xFF22,"Muhenkan"; -0xFF23,"Henkan_Mode"; -0xFF23,"Henkan"; -0xFF24,"Romaji"; -0xFF25,"Hiragana"; -0xFF26,"Katakana"; -0xFF27,"Hiragana_Katakana"; -0xFF28,"Zenkaku"; -0xFF29,"Hankaku"; -0xFF2A,"Zenkaku_Hankaku"; -0xFF2B,"Touroku"; -0xFF2C,"Massyo"; -0xFF2D,"Kana_Lock"; -0xFF2E,"Kana_Shift"; -0xFF2F,"Eisu_Shift"; -0xFF30,"Eisu_toggle"; -0xFF50,"Home"; -0xFF51,"Left"; -0xFF52,"Up"; -0xFF53,"Right"; -0xFF54,"Down"; -0xFF55,"Prior"; -0xFF55,"Page_Up"; -0xFF56,"Next"; -0xFF56,"Page_Down"; -0xFF57,"End"; -0xFF58,"Begin"; -0xFF60,"Select"; -0xFF61,"Print"; -0xFF62,"Execute"; -0xFF63,"Insert"; -0xFF65,"Undo"; -0xFF66,"Redo"; -0xFF67,"Menu"; -0xFF68,"Find"; -0xFF69,"Cancel"; -0xFF6A,"Help"; -0xFF6B,"Break"; -0xFF7E,"Mode_switch"; -0xFF7E,"script_switch"; -0xFF7F,"Num_Lock"; -0xFF80,"KP_Space"; -0xFF89,"KP_Tab"; -0xFF8D,"KP_Enter"; -0xFF91,"KP_F1"; -0xFF92,"KP_F2"; -0xFF93,"KP_F3"; -0xFF94,"KP_F4"; -0xFF95,"KP_Home"; -0xFF96,"KP_Left"; -0xFF97,"KP_Up"; -0xFF98,"KP_Right"; -0xFF99,"KP_Down"; -0xFF9A,"KP_Prior"; -0xFF9A,"KP_Page_Up"; -0xFF9B,"KP_Next"; -0xFF9B,"KP_Page_Down"; -0xFF9C,"KP_End"; -0xFF9D,"KP_Begin"; -0xFF9E,"KP_Insert"; -0xFF9F,"KP_Delete"; -0xFFBD,"KP_Equal"; -0xFFAA,"KP_Multiply"; -0xFFAB,"KP_Add"; -0xFFAC,"KP_Separator"; -0xFFAD,"KP_Subtract"; -0xFFAE,"KP_Decimal"; -0xFFAF,"KP_Divide"; -0xFFB0,"KP_0"; -0xFFB1,"KP_1"; -0xFFB2,"KP_2"; -0xFFB3,"KP_3"; -0xFFB4,"KP_4"; -0xFFB5,"KP_5"; -0xFFB6,"KP_6"; -0xFFB7,"KP_7"; -0xFFB8,"KP_8"; -0xFFB9,"KP_9"; -0xFFBE,"F1"; -0xFFBF,"F2"; -0xFFC0,"F3"; -0xFFC1,"F4"; -0xFFC2,"F5"; -0xFFC3,"F6"; -0xFFC4,"F7"; -0xFFC5,"F8"; -0xFFC6,"F9"; -0xFFC7,"F10"; -0xFFC8,"F11"; -0xFFC8,"L1"; -0xFFC9,"F12"; -0xFFC9,"L2"; -0xFFCA,"F13"; -0xFFCA,"L3"; -0xFFCB,"F14"; -0xFFCB,"L4"; -0xFFCC,"F15"; -0xFFCC,"L5"; -0xFFCD,"F16"; -0xFFCD,"L6"; -0xFFCE,"F17"; -0xFFCE,"L7"; -0xFFCF,"F18"; -0xFFCF,"L8"; -0xFFD0,"F19"; -0xFFD0,"L9"; -0xFFD1,"F20"; -0xFFD1,"L10"; -0xFFD2,"F21"; -0xFFD2,"R1"; -0xFFD3,"F22"; -0xFFD3,"R2"; -0xFFD4,"F23"; -0xFFD4,"R3"; -0xFFD5,"F24"; -0xFFD5,"R4"; -0xFFD6,"F25"; -0xFFD6,"R5"; -0xFFD7,"F26"; -0xFFD7,"R6"; -0xFFD8,"F27"; -0xFFD8,"R7"; -0xFFD9,"F28"; -0xFFD9,"R8"; -0xFFDA,"F29"; -0xFFDA,"R9"; -0xFFDB,"F30"; -0xFFDB,"R10"; -0xFFDC,"F31"; -0xFFDC,"R11"; -0xFFDD,"F32"; -0xFFDD,"R12"; -0xFFDE,"F33"; -0xFFDE,"R13"; -0xFFDF,"F34"; -0xFFDF,"R14"; -0xFFE0,"F35"; -0xFFE0,"R15"; -0xFFE1,"Shift_L"; -0xFFE2,"Shift_R"; -0xFFE3,"Control_L"; -0xFFE4,"Control_R"; -0xFFE5,"Caps_Lock"; -0xFFE6,"Shift_Lock"; -0xFFE7,"Meta_L"; -0xFFE8,"Meta_R"; -0xFFE9,"Alt_L"; -0xFFEA,"Alt_R"; -0xFFEB,"Super_L"; -0xFFEC,"Super_R"; -0xFFED,"Hyper_L"; -0xFFEE,"Hyper_R"; -0xFE01,"ISO_Lock"; -0xFE02,"ISO_Level2_Latch"; -0xFE03,"ISO_Level3_Shift"; -0xFE04,"ISO_Level3_Latch"; -0xFE05,"ISO_Level3_Lock"; -0xFF7E,"ISO_Group_Shift"; -0xFE06,"ISO_Group_Latch"; -0xFE07,"ISO_Group_Lock"; -0xFE08,"ISO_Next_Group"; -0xFE09,"ISO_Next_Group_Lock"; -0xFE0A,"ISO_Prev_Group"; -0xFE0B,"ISO_Prev_Group_Lock"; -0xFE0C,"ISO_First_Group"; -0xFE0D,"ISO_First_Group_Lock"; -0xFE0E,"ISO_Last_Group"; -0xFE0F,"ISO_Last_Group_Lock"; -0xFE20,"ISO_Left_Tab"; -0xFE21,"ISO_Move_Line_Up"; -0xFE22,"ISO_Move_Line_Down"; -0xFE23,"ISO_Partial_Line_Up"; -0xFE24,"ISO_Partial_Line_Down"; -0xFE25,"ISO_Partial_Space_Left"; -0xFE26,"ISO_Partial_Space_Right"; -0xFE27,"ISO_Set_Margin_Left"; -0xFE28,"ISO_Set_Margin_Right"; -0xFE29,"ISO_Release_Margin_Left"; -0xFE2A,"ISO_Release_Margin_Right"; -0xFE2B,"ISO_Release_Both_Margins"; -0xFE2C,"ISO_Fast_Cursor_Left"; -0xFE2D,"ISO_Fast_Cursor_Right"; -0xFE2E,"ISO_Fast_Cursor_Up"; -0xFE2F,"ISO_Fast_Cursor_Down"; -0xFE30,"ISO_Continuous_Underline"; -0xFE31,"ISO_Discontinuous_Underline"; -0xFE32,"ISO_Emphasize"; -0xFE33,"ISO_Center_Object"; -0xFE34,"ISO_Enter"; -0xFE50,"dead_grave"; -0xFE51,"dead_acute"; -0xFE52,"dead_circumflex"; -0xFE53,"dead_tilde"; -0xFE54,"dead_macron"; -0xFE55,"dead_breve"; -0xFE56,"dead_abovedot"; -0xFE57,"dead_diaeresis"; -0xFE58,"dead_abovering"; -0xFE59,"dead_doubleacute"; -0xFE5A,"dead_caron"; -0xFE5B,"dead_cedilla"; -0xFE5C,"dead_ogonek"; -0xFE5D,"dead_iota"; -0xFE5E,"dead_voiced_sound"; -0xFE5F,"dead_semivoiced_sound"; -0xFE60,"dead_belowdot"; -0xFED0,"First_Virtual_Screen"; -0xFED1,"Prev_Virtual_Screen"; -0xFED2,"Next_Virtual_Screen"; -0xFED4,"Last_Virtual_Screen"; -0xFED5,"Terminate_Server"; -0xFE70,"AccessX_Enable"; -0xFE71,"AccessX_Feedback_Enable"; -0xFE72,"RepeatKeys_Enable"; -0xFE73,"SlowKeys_Enable"; -0xFE74,"BounceKeys_Enable"; -0xFE75,"StickyKeys_Enable"; -0xFE76,"MouseKeys_Enable"; -0xFE77,"MouseKeys_Accel_Enable"; -0xFE78,"Overlay1_Enable"; -0xFE79,"Overlay2_Enable"; -0xFE7A,"AudibleBell_Enable"; -0xFEE0,"Pointer_Left"; -0xFEE1,"Pointer_Right"; -0xFEE2,"Pointer_Up"; -0xFEE3,"Pointer_Down"; -0xFEE4,"Pointer_UpLeft"; -0xFEE5,"Pointer_UpRight"; -0xFEE6,"Pointer_DownLeft"; -0xFEE7,"Pointer_DownRight"; -0xFEE8,"Pointer_Button_Dflt"; -0xFEE9,"Pointer_Button1"; -0xFEEA,"Pointer_Button2"; -0xFEEB,"Pointer_Button3"; -0xFEEC,"Pointer_Button4"; -0xFEED,"Pointer_Button5"; -0xFEEE,"Pointer_DblClick_Dflt"; -0xFEEF,"Pointer_DblClick1"; -0xFEF0,"Pointer_DblClick2"; -0xFEF1,"Pointer_DblClick3"; -0xFEF2,"Pointer_DblClick4"; -0xFEF3,"Pointer_DblClick5"; -0xFEF4,"Pointer_Drag_Dflt"; -0xFEF5,"Pointer_Drag1"; -0xFEF6,"Pointer_Drag2"; -0xFEF7,"Pointer_Drag3"; -0xFEF8,"Pointer_Drag4"; -0xFEFD,"Pointer_Drag5"; -0xFEF9,"Pointer_EnableKeys"; -0xFEFA,"Pointer_Accelerate"; -0xFEFB,"Pointer_DfltBtnNext"; -0xFEFC,"Pointer_DfltBtnPrev"; -0xFD01,"3270_Duplicate"; -0xFD02,"3270_FieldMark"; -0xFD03,"3270_Right2"; -0xFD04,"3270_Left2"; -0xFD05,"3270_BackTab"; -0xFD06,"3270_EraseEOF"; -0xFD07,"3270_EraseInput"; -0xFD08,"3270_Reset"; -0xFD09,"3270_Quit"; -0xFD0A,"3270_PA1"; -0xFD0B,"3270_PA2"; -0xFD0C,"3270_PA3"; -0xFD0D,"3270_Test"; -0xFD0E,"3270_Attn"; -0xFD0F,"3270_CursorBlink"; -0xFD10,"3270_AltCursor"; -0xFD11,"3270_KeyClick"; -0xFD12,"3270_Jump"; -0xFD13,"3270_Ident"; -0xFD14,"3270_Rule"; -0xFD15,"3270_Copy"; -0xFD16,"3270_Play"; -0xFD17,"3270_Setup"; -0xFD18,"3270_Record"; -0xFD19,"3270_ChangeScreen"; -0xFD1A,"3270_DeleteWord"; -0xFD1B,"3270_ExSelect"; -0xFD1C,"3270_CursorSelect"; -0xFD1D,"3270_PrintScreen"; -0xFD1E,"3270_Enter"; -0x020,"space"; -0x021,"exclam"; -0x022,"quotedbl"; -0x023,"numbersign"; -0x024,"dollar"; -0x025,"percent"; -0x026,"ampersand"; -0x027,"apostrophe"; -0x027,"quoteright"; -0x028,"parenleft"; -0x029,"parenright"; -0x02a,"asterisk"; -0x02b,"plus"; -0x02c,"comma"; -0x02d,"minus"; -0x02e,"period"; -0x02f,"slash"; -0x030,"0"; -0x031,"1"; -0x032,"2"; -0x033,"3"; -0x034,"4"; -0x035,"5"; -0x036,"6"; -0x037,"7"; -0x038,"8"; -0x039,"9"; -0x03a,"colon"; -0x03b,"semicolon"; -0x03c,"less"; -0x03d,"equal"; -0x03e,"greater"; -0x03f,"question"; -0x040,"at"; -0x041,"A"; -0x042,"B"; -0x043,"C"; -0x044,"D"; -0x045,"E"; -0x046,"F"; -0x047,"G"; -0x048,"H"; -0x049,"I"; -0x04a,"J"; -0x04b,"K"; -0x04c,"L"; -0x04d,"M"; -0x04e,"N"; -0x04f,"O"; -0x050,"P"; -0x051,"Q"; -0x052,"R"; -0x053,"S"; -0x054,"T"; -0x055,"U"; -0x056,"V"; -0x057,"W"; -0x058,"X"; -0x059,"Y"; -0x05a,"Z"; -0x05b,"bracketleft"; -0x05c,"backslash"; -0x05d,"bracketright"; -0x05e,"asciicircum"; -0x05f,"underscore"; -0x060,"grave"; -0x060,"quoteleft"; -0x061,"a"; -0x062,"b"; -0x063,"c"; -0x064,"d"; -0x065,"e"; -0x066,"f"; -0x067,"g"; -0x068,"h"; -0x069,"i"; -0x06a,"j"; -0x06b,"k"; -0x06c,"l"; -0x06d,"m"; -0x06e,"n"; -0x06f,"o"; -0x070,"p"; -0x071,"q"; -0x072,"r"; -0x073,"s"; -0x074,"t"; -0x075,"u"; -0x076,"v"; -0x077,"w"; -0x078,"x"; -0x079,"y"; -0x07a,"z"; -0x07b,"braceleft"; -0x07c,"bar"; -0x07d,"braceright"; -0x07e,"asciitilde"; -0x0a0,"nobreakspace"; -0x0a1,"exclamdown"; -0x0a2,"cent"; -0x0a3,"sterling"; -0x0a4,"currency"; -0x0a5,"yen"; -0x0a6,"brokenbar"; -0x0a7,"section"; -0x0a8,"diaeresis"; -0x0a9,"copyright"; -0x0aa,"ordfeminine"; -0x0ab,"guillemotleft"; -0x0ac,"notsign"; -0x0ad,"hyphen"; -0x0ae,"registered"; -0x0af,"macron"; -0x0b0,"degree"; -0x0b1,"plusminus"; -0x0b2,"twosuperior"; -0x0b3,"threesuperior"; -0x0b4,"acute"; -0x0b5,"mu"; -0x0b6,"paragraph"; -0x0b7,"periodcentered"; -0x0b8,"cedilla"; -0x0b9,"onesuperior"; -0x0ba,"masculine"; -0x0bb,"guillemotright"; -0x0bc,"onequarter"; -0x0bd,"onehalf"; -0x0be,"threequarters"; -0x0bf,"questiondown"; -0x0c0,"Agrave"; -0x0c1,"Aacute"; -0x0c2,"Acircumflex"; -0x0c3,"Atilde"; -0x0c4,"Adiaeresis"; -0x0c5,"Aring"; -0x0c6,"AE"; -0x0c7,"Ccedilla"; -0x0c8,"Egrave"; -0x0c9,"Eacute"; -0x0ca,"Ecircumflex"; -0x0cb,"Ediaeresis"; -0x0cc,"Igrave"; -0x0cd,"Iacute"; -0x0ce,"Icircumflex"; -0x0cf,"Idiaeresis"; -0x0d0,"ETH"; -0x0d0,"Eth"; -0x0d1,"Ntilde"; -0x0d2,"Ograve"; -0x0d3,"Oacute"; -0x0d4,"Ocircumflex"; -0x0d5,"Otilde"; -0x0d6,"Odiaeresis"; -0x0d7,"multiply"; -0x0d8,"Ooblique"; -0x0d9,"Ugrave"; -0x0da,"Uacute"; -0x0db,"Ucircumflex"; -0x0dc,"Udiaeresis"; -0x0dd,"Yacute"; -0x0de,"THORN"; -0x0de,"Thorn"; -0x0df,"ssharp"; -0x0e0,"agrave"; -0x0e1,"aacute"; -0x0e2,"acircumflex"; -0x0e3,"atilde"; -0x0e4,"adiaeresis"; -0x0e5,"aring"; -0x0e6,"ae"; -0x0e7,"ccedilla"; -0x0e8,"egrave"; -0x0e9,"eacute"; -0x0ea,"ecircumflex"; -0x0eb,"ediaeresis"; -0x0ec,"igrave"; -0x0ed,"iacute"; -0x0ee,"icircumflex"; -0x0ef,"idiaeresis"; -0x0f0,"eth"; -0x0f1,"ntilde"; -0x0f2,"ograve"; -0x0f3,"oacute"; -0x0f4,"ocircumflex"; -0x0f5,"otilde"; -0x0f6,"odiaeresis"; -0x0f7,"division"; -0x0f8,"oslash"; -0x0f9,"ugrave"; -0x0fa,"uacute"; -0x0fb,"ucircumflex"; -0x0fc,"udiaeresis"; -0x0fd,"yacute"; -0x0fe,"thorn"; -0x0ff,"ydiaeresis"; -0x1a1,"Aogonek"; -0x1a2,"breve"; -0x1a3,"Lstroke"; -0x1a5,"Lcaron"; -0x1a6,"Sacute"; -0x1a9,"Scaron"; -0x1aa,"Scedilla"; -0x1ab,"Tcaron"; -0x1ac,"Zacute"; -0x1ae,"Zcaron"; -0x1af,"Zabovedot"; -0x1b1,"aogonek"; -0x1b2,"ogonek"; -0x1b3,"lstroke"; -0x1b5,"lcaron"; -0x1b6,"sacute"; -0x1b7,"caron"; -0x1b9,"scaron"; -0x1ba,"scedilla"; -0x1bb,"tcaron"; -0x1bc,"zacute"; -0x1bd,"doubleacute"; -0x1be,"zcaron"; -0x1bf,"zabovedot"; -0x1c0,"Racute"; -0x1c3,"Abreve"; -0x1c5,"Lacute"; -0x1c6,"Cacute"; -0x1c8,"Ccaron"; -0x1ca,"Eogonek"; -0x1cc,"Ecaron"; -0x1cf,"Dcaron"; -0x1d0,"Dstroke"; -0x1d1,"Nacute"; -0x1d2,"Ncaron"; -0x1d5,"Odoubleacute"; -0x1d8,"Rcaron"; -0x1d9,"Uring"; -0x1db,"Udoubleacute"; -0x1de,"Tcedilla"; -0x1e0,"racute"; -0x1e3,"abreve"; -0x1e5,"lacute"; -0x1e6,"cacute"; -0x1e8,"ccaron"; -0x1ea,"eogonek"; -0x1ec,"ecaron"; -0x1ef,"dcaron"; -0x1f0,"dstroke"; -0x1f1,"nacute"; -0x1f2,"ncaron"; -0x1f5,"odoubleacute"; -0x1fb,"udoubleacute"; -0x1f8,"rcaron"; -0x1f9,"uring"; -0x1fe,"tcedilla"; -0x1ff,"abovedot"; -0x2a1,"Hstroke"; -0x2a6,"Hcircumflex"; -0x2a9,"Iabovedot"; -0x2ab,"Gbreve"; -0x2ac,"Jcircumflex"; -0x2b1,"hstroke"; -0x2b6,"hcircumflex"; -0x2b9,"idotless"; -0x2bb,"gbreve"; -0x2bc,"jcircumflex"; -0x2c5,"Cabovedot"; -0x2c6,"Ccircumflex"; -0x2d5,"Gabovedot"; -0x2d8,"Gcircumflex"; -0x2dd,"Ubreve"; -0x2de,"Scircumflex"; -0x2e5,"cabovedot"; -0x2e6,"ccircumflex"; -0x2f5,"gabovedot"; -0x2f8,"gcircumflex"; -0x2fd,"ubreve"; -0x2fe,"scircumflex"; -0x3a2,"kra"; -0x3a2,"kappa"; -0x3a3,"Rcedilla"; -0x3a5,"Itilde"; -0x3a6,"Lcedilla"; -0x3aa,"Emacron"; -0x3ab,"Gcedilla"; -0x3ac,"Tslash"; -0x3b3,"rcedilla"; -0x3b5,"itilde"; -0x3b6,"lcedilla"; -0x3ba,"emacron"; -0x3bb,"gcedilla"; -0x3bc,"tslash"; -0x3bd,"ENG"; -0x3bf,"eng"; -0x3c0,"Amacron"; -0x3c7,"Iogonek"; -0x3cc,"Eabovedot"; -0x3cf,"Imacron"; -0x3d1,"Ncedilla"; -0x3d2,"Omacron"; -0x3d3,"Kcedilla"; -0x3d9,"Uogonek"; -0x3dd,"Utilde"; -0x3de,"Umacron"; -0x3e0,"amacron"; -0x3e7,"iogonek"; -0x3ec,"eabovedot"; -0x3ef,"imacron"; -0x3f1,"ncedilla"; -0x3f2,"omacron"; -0x3f3,"kcedilla"; -0x3f9,"uogonek"; -0x3fd,"utilde"; -0x3fe,"umacron"; -0x47e,"overline"; -0x4a1,"kana_fullstop"; -0x4a2,"kana_openingbracket"; -0x4a3,"kana_closingbracket"; -0x4a4,"kana_comma"; -0x4a5,"kana_conjunctive"; -0x4a5,"kana_middledot"; -0x4a6,"kana_WO"; -0x4a7,"kana_a"; -0x4a8,"kana_i"; -0x4a9,"kana_u"; -0x4aa,"kana_e"; -0x4ab,"kana_o"; -0x4ac,"kana_ya"; -0x4ad,"kana_yu"; -0x4ae,"kana_yo"; -0x4af,"kana_tsu"; -0x4af,"kana_tu"; -0x4b0,"prolongedsound"; -0x4b1,"kana_A"; -0x4b2,"kana_I"; -0x4b3,"kana_U"; -0x4b4,"kana_E"; -0x4b5,"kana_O"; -0x4b6,"kana_KA"; -0x4b7,"kana_KI"; -0x4b8,"kana_KU"; -0x4b9,"kana_KE"; -0x4ba,"kana_KO"; -0x4bb,"kana_SA"; -0x4bc,"kana_SHI"; -0x4bd,"kana_SU"; -0x4be,"kana_SE"; -0x4bf,"kana_SO"; -0x4c0,"kana_TA"; -0x4c1,"kana_CHI"; -0x4c1,"kana_TI"; -0x4c2,"kana_TSU"; -0x4c2,"kana_TU"; -0x4c3,"kana_TE"; -0x4c4,"kana_TO"; -0x4c5,"kana_NA"; -0x4c6,"kana_NI"; -0x4c7,"kana_NU"; -0x4c8,"kana_NE"; -0x4c9,"kana_NO"; -0x4ca,"kana_HA"; -0x4cb,"kana_HI"; -0x4cc,"kana_FU"; -0x4cc,"kana_HU"; -0x4cd,"kana_HE"; -0x4ce,"kana_HO"; -0x4cf,"kana_MA"; -0x4d0,"kana_MI"; -0x4d1,"kana_MU"; -0x4d2,"kana_ME"; -0x4d3,"kana_MO"; -0x4d4,"kana_YA"; -0x4d5,"kana_YU"; -0x4d6,"kana_YO"; -0x4d7,"kana_RA"; -0x4d8,"kana_RI"; -0x4d9,"kana_RU"; -0x4da,"kana_RE"; -0x4db,"kana_RO"; -0x4dc,"kana_WA"; -0x4dd,"kana_N"; -0x4de,"voicedsound"; -0x4df,"semivoicedsound"; -0xFF7E,"kana_switch"; -0x5ac,"Arabic_comma"; -0x5bb,"Arabic_semicolon"; -0x5bf,"Arabic_question_mark"; -0x5c1,"Arabic_hamza"; -0x5c2,"Arabic_maddaonalef"; -0x5c3,"Arabic_hamzaonalef"; -0x5c4,"Arabic_hamzaonwaw"; -0x5c5,"Arabic_hamzaunderalef"; -0x5c6,"Arabic_hamzaonyeh"; -0x5c7,"Arabic_alef"; -0x5c8,"Arabic_beh"; -0x5c9,"Arabic_tehmarbuta"; -0x5ca,"Arabic_teh"; -0x5cb,"Arabic_theh"; -0x5cc,"Arabic_jeem"; -0x5cd,"Arabic_hah"; -0x5ce,"Arabic_khah"; -0x5cf,"Arabic_dal"; -0x5d0,"Arabic_thal"; -0x5d1,"Arabic_ra"; -0x5d2,"Arabic_zain"; -0x5d3,"Arabic_seen"; -0x5d4,"Arabic_sheen"; -0x5d5,"Arabic_sad"; -0x5d6,"Arabic_dad"; -0x5d7,"Arabic_tah"; -0x5d8,"Arabic_zah"; -0x5d9,"Arabic_ain"; -0x5da,"Arabic_ghain"; -0x5e0,"Arabic_tatweel"; -0x5e1,"Arabic_feh"; -0x5e2,"Arabic_qaf"; -0x5e3,"Arabic_kaf"; -0x5e4,"Arabic_lam"; -0x5e5,"Arabic_meem"; -0x5e6,"Arabic_noon"; -0x5e7,"Arabic_ha"; -0x5e7,"Arabic_heh"; -0x5e8,"Arabic_waw"; -0x5e9,"Arabic_alefmaksura"; -0x5ea,"Arabic_yeh"; -0x5eb,"Arabic_fathatan"; -0x5ec,"Arabic_dammatan"; -0x5ed,"Arabic_kasratan"; -0x5ee,"Arabic_fatha"; -0x5ef,"Arabic_damma"; -0x5f0,"Arabic_kasra"; -0x5f1,"Arabic_shadda"; -0x5f2,"Arabic_sukun"; -0xFF7E,"Arabic_switch"; -0x6a1,"Serbian_dje"; -0x6a2,"Macedonia_gje"; -0x6a3,"Cyrillic_io"; -0x6a4,"Ukrainian_ie"; -0x6a4,"Ukranian_je"; -0x6a5,"Macedonia_dse"; -0x6a6,"Ukrainian_i"; -0x6a6,"Ukranian_i"; -0x6a7,"Ukrainian_yi"; -0x6a7,"Ukranian_yi"; -0x6a8,"Cyrillic_je"; -0x6a8,"Serbian_je"; -0x6a9,"Cyrillic_lje"; -0x6a9,"Serbian_lje"; -0x6aa,"Cyrillic_nje"; -0x6aa,"Serbian_nje"; -0x6ab,"Serbian_tshe"; -0x6ac,"Macedonia_kje"; -0x6ae,"Byelorussian_shortu"; -0x6af,"Cyrillic_dzhe"; -0x6af,"Serbian_dze"; -0x6b0,"numerosign"; -0x6b1,"Serbian_DJE"; -0x6b2,"Macedonia_GJE"; -0x6b3,"Cyrillic_IO"; -0x6b4,"Ukrainian_IE"; -0x6b4,"Ukranian_JE"; -0x6b5,"Macedonia_DSE"; -0x6b6,"Ukrainian_I"; -0x6b6,"Ukranian_I"; -0x6b7,"Ukrainian_YI"; -0x6b7,"Ukranian_YI"; -0x6b8,"Cyrillic_JE"; -0x6b8,"Serbian_JE"; -0x6b9,"Cyrillic_LJE"; -0x6b9,"Serbian_LJE"; -0x6ba,"Cyrillic_NJE"; -0x6ba,"Serbian_NJE"; -0x6bb,"Serbian_TSHE"; -0x6bc,"Macedonia_KJE"; -0x6be,"Byelorussian_SHORTU"; -0x6bf,"Cyrillic_DZHE"; -0x6bf,"Serbian_DZE"; -0x6c0,"Cyrillic_yu"; -0x6c1,"Cyrillic_a"; -0x6c2,"Cyrillic_be"; -0x6c3,"Cyrillic_tse"; -0x6c4,"Cyrillic_de"; -0x6c5,"Cyrillic_ie"; -0x6c6,"Cyrillic_ef"; -0x6c7,"Cyrillic_ghe"; -0x6c8,"Cyrillic_ha"; -0x6c9,"Cyrillic_i"; -0x6ca,"Cyrillic_shorti"; -0x6cb,"Cyrillic_ka"; -0x6cc,"Cyrillic_el"; -0x6cd,"Cyrillic_em"; -0x6ce,"Cyrillic_en"; -0x6cf,"Cyrillic_o"; -0x6d0,"Cyrillic_pe"; -0x6d1,"Cyrillic_ya"; -0x6d2,"Cyrillic_er"; -0x6d3,"Cyrillic_es"; -0x6d4,"Cyrillic_te"; -0x6d5,"Cyrillic_u"; -0x6d6,"Cyrillic_zhe"; -0x6d7,"Cyrillic_ve"; -0x6d8,"Cyrillic_softsign"; -0x6d9,"Cyrillic_yeru"; -0x6da,"Cyrillic_ze"; -0x6db,"Cyrillic_sha"; -0x6dc,"Cyrillic_e"; -0x6dd,"Cyrillic_shcha"; -0x6de,"Cyrillic_che"; -0x6df,"Cyrillic_hardsign"; -0x6e0,"Cyrillic_YU"; -0x6e1,"Cyrillic_A"; -0x6e2,"Cyrillic_BE"; -0x6e3,"Cyrillic_TSE"; -0x6e4,"Cyrillic_DE"; -0x6e5,"Cyrillic_IE"; -0x6e6,"Cyrillic_EF"; -0x6e7,"Cyrillic_GHE"; -0x6e8,"Cyrillic_HA"; -0x6e9,"Cyrillic_I"; -0x6ea,"Cyrillic_SHORTI"; -0x6eb,"Cyrillic_KA"; -0x6ec,"Cyrillic_EL"; -0x6ed,"Cyrillic_EM"; -0x6ee,"Cyrillic_EN"; -0x6ef,"Cyrillic_O"; -0x6f0,"Cyrillic_PE"; -0x6f1,"Cyrillic_YA"; -0x6f2,"Cyrillic_ER"; -0x6f3,"Cyrillic_ES"; -0x6f4,"Cyrillic_TE"; -0x6f5,"Cyrillic_U"; -0x6f6,"Cyrillic_ZHE"; -0x6f7,"Cyrillic_VE"; -0x6f8,"Cyrillic_SOFTSIGN"; -0x6f9,"Cyrillic_YERU"; -0x6fa,"Cyrillic_ZE"; -0x6fb,"Cyrillic_SHA"; -0x6fc,"Cyrillic_E"; -0x6fd,"Cyrillic_SHCHA"; -0x6fe,"Cyrillic_CHE"; -0x6ff,"Cyrillic_HARDSIGN"; -0x7a1,"Greek_ALPHAaccent"; -0x7a2,"Greek_EPSILONaccent"; -0x7a3,"Greek_ETAaccent"; -0x7a4,"Greek_IOTAaccent"; -0x7a5,"Greek_IOTAdiaeresis"; -0x7a7,"Greek_OMICRONaccent"; -0x7a8,"Greek_UPSILONaccent"; -0x7a9,"Greek_UPSILONdieresis"; -0x7ab,"Greek_OMEGAaccent"; -0x7ae,"Greek_accentdieresis"; -0x7af,"Greek_horizbar"; -0x7b1,"Greek_alphaaccent"; -0x7b2,"Greek_epsilonaccent"; -0x7b3,"Greek_etaaccent"; -0x7b4,"Greek_iotaaccent"; -0x7b5,"Greek_iotadieresis"; -0x7b6,"Greek_iotaaccentdieresis"; -0x7b7,"Greek_omicronaccent"; -0x7b8,"Greek_upsilonaccent"; -0x7b9,"Greek_upsilondieresis"; -0x7ba,"Greek_upsilonaccentdieresis"; -0x7bb,"Greek_omegaaccent"; -0x7c1,"Greek_ALPHA"; -0x7c2,"Greek_BETA"; -0x7c3,"Greek_GAMMA"; -0x7c4,"Greek_DELTA"; -0x7c5,"Greek_EPSILON"; -0x7c6,"Greek_ZETA"; -0x7c7,"Greek_ETA"; -0x7c8,"Greek_THETA"; -0x7c9,"Greek_IOTA"; -0x7ca,"Greek_KAPPA"; -0x7cb,"Greek_LAMDA"; -0x7cb,"Greek_LAMBDA"; -0x7cc,"Greek_MU"; -0x7cd,"Greek_NU"; -0x7ce,"Greek_XI"; -0x7cf,"Greek_OMICRON"; -0x7d0,"Greek_PI"; -0x7d1,"Greek_RHO"; -0x7d2,"Greek_SIGMA"; -0x7d4,"Greek_TAU"; -0x7d5,"Greek_UPSILON"; -0x7d6,"Greek_PHI"; -0x7d7,"Greek_CHI"; -0x7d8,"Greek_PSI"; -0x7d9,"Greek_OMEGA"; -0x7e1,"Greek_alpha"; -0x7e2,"Greek_beta"; -0x7e3,"Greek_gamma"; -0x7e4,"Greek_delta"; -0x7e5,"Greek_epsilon"; -0x7e6,"Greek_zeta"; -0x7e7,"Greek_eta"; -0x7e8,"Greek_theta"; -0x7e9,"Greek_iota"; -0x7ea,"Greek_kappa"; -0x7eb,"Greek_lamda"; -0x7eb,"Greek_lambda"; -0x7ec,"Greek_mu"; -0x7ed,"Greek_nu"; -0x7ee,"Greek_xi"; -0x7ef,"Greek_omicron"; -0x7f0,"Greek_pi"; -0x7f1,"Greek_rho"; -0x7f2,"Greek_sigma"; -0x7f3,"Greek_finalsmallsigma"; -0x7f4,"Greek_tau"; -0x7f5,"Greek_upsilon"; -0x7f6,"Greek_phi"; -0x7f7,"Greek_chi"; -0x7f8,"Greek_psi"; -0x7f9,"Greek_omega"; -0xFF7E,"Greek_switch"; -0x8a1,"leftradical"; -0x8a2,"topleftradical"; -0x8a3,"horizconnector"; -0x8a4,"topintegral"; -0x8a5,"botintegral"; -0x8a6,"vertconnector"; -0x8a7,"topleftsqbracket"; -0x8a8,"botleftsqbracket"; -0x8a9,"toprightsqbracket"; -0x8aa,"botrightsqbracket"; -0x8ab,"topleftparens"; -0x8ac,"botleftparens"; -0x8ad,"toprightparens"; -0x8ae,"botrightparens"; -0x8af,"leftmiddlecurlybrace"; -0x8b0,"rightmiddlecurlybrace"; -0x8b1,"topleftsummation"; -0x8b2,"botleftsummation"; -0x8b3,"topvertsummationconnector"; -0x8b4,"botvertsummationconnector"; -0x8b5,"toprightsummation"; -0x8b6,"botrightsummation"; -0x8b7,"rightmiddlesummation"; -0x8bc,"lessthanequal"; -0x8bd,"notequal"; -0x8be,"greaterthanequal"; -0x8bf,"integral"; -0x8c0,"therefore"; -0x8c1,"variation"; -0x8c2,"infinity"; -0x8c5,"nabla"; -0x8c8,"approximate"; -0x8c9,"similarequal"; -0x8cd,"ifonlyif"; -0x8ce,"implies"; -0x8cf,"identical"; -0x8d6,"radical"; -0x8da,"includedin"; -0x8db,"includes"; -0x8dc,"intersection"; -0x8dd,"union"; -0x8de,"logicaland"; -0x8df,"logicalor"; -0x8ef,"partialderivative"; -0x8f6,"function"; -0x8fb,"leftarrow"; -0x8fc,"uparrow"; -0x8fd,"rightarrow"; -0x8fe,"downarrow"; -0x9df,"blank"; -0x9e0,"soliddiamond"; -0x9e1,"checkerboard"; -0x9e2,"ht"; -0x9e3,"ff"; -0x9e4,"cr"; -0x9e5,"lf"; -0x9e8,"nl"; -0x9e9,"vt"; -0x9ea,"lowrightcorner"; -0x9eb,"uprightcorner"; -0x9ec,"upleftcorner"; -0x9ed,"lowleftcorner"; -0x9ee,"crossinglines"; -0x9ef,"horizlinescan1"; -0x9f0,"horizlinescan3"; -0x9f1,"horizlinescan5"; -0x9f2,"horizlinescan7"; -0x9f3,"horizlinescan9"; -0x9f4,"leftt"; -0x9f5,"rightt"; -0x9f6,"bott"; -0x9f7,"topt"; -0x9f8,"vertbar"; -0xaa1,"emspace"; -0xaa2,"enspace"; -0xaa3,"em3space"; -0xaa4,"em4space"; -0xaa5,"digitspace"; -0xaa6,"punctspace"; -0xaa7,"thinspace"; -0xaa8,"hairspace"; -0xaa9,"emdash"; -0xaaa,"endash"; -0xaac,"signifblank"; -0xaae,"ellipsis"; -0xaaf,"doubbaselinedot"; -0xab0,"onethird"; -0xab1,"twothirds"; -0xab2,"onefifth"; -0xab3,"twofifths"; -0xab4,"threefifths"; -0xab5,"fourfifths"; -0xab6,"onesixth"; -0xab7,"fivesixths"; -0xab8,"careof"; -0xabb,"figdash"; -0xabc,"leftanglebracket"; -0xabd,"decimalpoint"; -0xabe,"rightanglebracket"; -0xabf,"marker"; -0xac3,"oneeighth"; -0xac4,"threeeighths"; -0xac5,"fiveeighths"; -0xac6,"seveneighths"; -0xac9,"trademark"; -0xaca,"signaturemark"; -0xacb,"trademarkincircle"; -0xacc,"leftopentriangle"; -0xacd,"rightopentriangle"; -0xace,"emopencircle"; -0xacf,"emopenrectangle"; -0xad0,"leftsinglequotemark"; -0xad1,"rightsinglequotemark"; -0xad2,"leftdoublequotemark"; -0xad3,"rightdoublequotemark"; -0xad4,"prescription"; -0xad6,"minutes"; -0xad7,"seconds"; -0xad9,"latincross"; -0xada,"hexagram"; -0xadb,"filledrectbullet"; -0xadc,"filledlefttribullet"; -0xadd,"filledrighttribullet"; -0xade,"emfilledcircle"; -0xadf,"emfilledrect"; -0xae0,"enopencircbullet"; -0xae1,"enopensquarebullet"; -0xae2,"openrectbullet"; -0xae3,"opentribulletup"; -0xae4,"opentribulletdown"; -0xae5,"openstar"; -0xae6,"enfilledcircbullet"; -0xae7,"enfilledsqbullet"; -0xae8,"filledtribulletup"; -0xae9,"filledtribulletdown"; -0xaea,"leftpointer"; -0xaeb,"rightpointer"; -0xaec,"club"; -0xaed,"diamond"; -0xaee,"heart"; -0xaf0,"maltesecross"; -0xaf1,"dagger"; -0xaf2,"doubledagger"; -0xaf3,"checkmark"; -0xaf4,"ballotcross"; -0xaf5,"musicalsharp"; -0xaf6,"musicalflat"; -0xaf7,"malesymbol"; -0xaf8,"femalesymbol"; -0xaf9,"telephone"; -0xafa,"telephonerecorder"; -0xafb,"phonographcopyright"; -0xafc,"caret"; -0xafd,"singlelowquotemark"; -0xafe,"doublelowquotemark"; -0xaff,"cursor"; -0xba3,"leftcaret"; -0xba6,"rightcaret"; -0xba8,"downcaret"; -0xba9,"upcaret"; -0xbc0,"overbar"; -0xbc2,"downtack"; -0xbc3,"upshoe"; -0xbc4,"downstile"; -0xbc6,"underbar"; -0xbca,"jot"; -0xbcc,"quad"; -0xbce,"uptack"; -0xbcf,"circle"; -0xbd3,"upstile"; -0xbd6,"downshoe"; -0xbd8,"rightshoe"; -0xbda,"leftshoe"; -0xbdc,"lefttack"; -0xbfc,"righttack"; -0xcdf,"hebrew_doublelowline"; -0xce0,"hebrew_aleph"; -0xce1,"hebrew_bet"; -0xce1,"hebrew_beth"; -0xce2,"hebrew_gimel"; -0xce2,"hebrew_gimmel"; -0xce3,"hebrew_dalet"; -0xce3,"hebrew_daleth"; -0xce4,"hebrew_he"; -0xce5,"hebrew_waw"; -0xce6,"hebrew_zain"; -0xce6,"hebrew_zayin"; -0xce7,"hebrew_chet"; -0xce7,"hebrew_het"; -0xce8,"hebrew_tet"; -0xce8,"hebrew_teth"; -0xce9,"hebrew_yod"; -0xcea,"hebrew_finalkaph"; -0xceb,"hebrew_kaph"; -0xcec,"hebrew_lamed"; -0xced,"hebrew_finalmem"; -0xcee,"hebrew_mem"; -0xcef,"hebrew_finalnun"; -0xcf0,"hebrew_nun"; -0xcf1,"hebrew_samech"; -0xcf1,"hebrew_samekh"; -0xcf2,"hebrew_ayin"; -0xcf3,"hebrew_finalpe"; -0xcf4,"hebrew_pe"; -0xcf5,"hebrew_finalzade"; -0xcf5,"hebrew_finalzadi"; -0xcf6,"hebrew_zade"; -0xcf6,"hebrew_zadi"; -0xcf7,"hebrew_qoph"; -0xcf7,"hebrew_kuf"; -0xcf8,"hebrew_resh"; -0xcf9,"hebrew_shin"; -0xcfa,"hebrew_taw"; -0xcfa,"hebrew_taf"; -0xFF7E,"Hebrew_switch"; -0xda1,"Thai_kokai"; -0xda2,"Thai_khokhai"; -0xda3,"Thai_khokhuat"; -0xda4,"Thai_khokhwai"; -0xda5,"Thai_khokhon"; -0xda6,"Thai_khorakhang"; -0xda7,"Thai_ngongu"; -0xda8,"Thai_chochan"; -0xda9,"Thai_choching"; -0xdaa,"Thai_chochang"; -0xdab,"Thai_soso"; -0xdac,"Thai_chochoe"; -0xdad,"Thai_yoying"; -0xdae,"Thai_dochada"; -0xdaf,"Thai_topatak"; -0xdb0,"Thai_thothan"; -0xdb1,"Thai_thonangmontho"; -0xdb2,"Thai_thophuthao"; -0xdb3,"Thai_nonen"; -0xdb4,"Thai_dodek"; -0xdb5,"Thai_totao"; -0xdb6,"Thai_thothung"; -0xdb7,"Thai_thothahan"; -0xdb8,"Thai_thothong"; -0xdb9,"Thai_nonu"; -0xdba,"Thai_bobaimai"; -0xdbb,"Thai_popla"; -0xdbc,"Thai_phophung"; -0xdbd,"Thai_fofa"; -0xdbe,"Thai_phophan"; -0xdbf,"Thai_fofan"; -0xdc0,"Thai_phosamphao"; -0xdc1,"Thai_moma"; -0xdc2,"Thai_yoyak"; -0xdc3,"Thai_rorua"; -0xdc4,"Thai_ru"; -0xdc5,"Thai_loling"; -0xdc6,"Thai_lu"; -0xdc7,"Thai_wowaen"; -0xdc8,"Thai_sosala"; -0xdc9,"Thai_sorusi"; -0xdca,"Thai_sosua"; -0xdcb,"Thai_hohip"; -0xdcc,"Thai_lochula"; -0xdcd,"Thai_oang"; -0xdce,"Thai_honokhuk"; -0xdcf,"Thai_paiyannoi"; -0xdd0,"Thai_saraa"; -0xdd1,"Thai_maihanakat"; -0xdd2,"Thai_saraaa"; -0xdd3,"Thai_saraam"; -0xdd4,"Thai_sarai"; -0xdd5,"Thai_saraii"; -0xdd6,"Thai_saraue"; -0xdd7,"Thai_sarauee"; -0xdd8,"Thai_sarau"; -0xdd9,"Thai_sarauu"; -0xdda,"Thai_phinthu"; -0xdde,"Thai_maihanakat_maitho"; -0xddf,"Thai_baht"; -0xde0,"Thai_sarae"; -0xde1,"Thai_saraae"; -0xde2,"Thai_sarao"; -0xde3,"Thai_saraaimaimuan"; -0xde4,"Thai_saraaimaimalai"; -0xde5,"Thai_lakkhangyao"; -0xde6,"Thai_maiyamok"; -0xde7,"Thai_maitaikhu"; -0xde8,"Thai_maiek"; -0xde9,"Thai_maitho"; -0xdea,"Thai_maitri"; -0xdeb,"Thai_maichattawa"; -0xdec,"Thai_thanthakhat"; -0xded,"Thai_nikhahit"; -0xdf0,"Thai_leksun"; -0xdf1,"Thai_leknung"; -0xdf2,"Thai_leksong"; -0xdf3,"Thai_leksam"; -0xdf4,"Thai_leksi"; -0xdf5,"Thai_lekha"; -0xdf6,"Thai_lekhok"; -0xdf7,"Thai_lekchet"; -0xdf8,"Thai_lekpaet"; -0xdf9,"Thai_lekkao"; -0xff31,"Hangul"; -0xff32,"Hangul_Start"; -0xff33,"Hangul_End"; -0xff34,"Hangul_Hanja"; -0xff35,"Hangul_Jamo"; -0xff36,"Hangul_Romaja"; -0xff37,"Hangul_Codeinput"; -0xff38,"Hangul_Jeonja"; -0xff39,"Hangul_Banja"; -0xff3a,"Hangul_PreHanja"; -0xff3b,"Hangul_PostHanja"; -0xff3c,"Hangul_SingleCandidate"; -0xff3d,"Hangul_MultipleCandidate"; -0xff3e,"Hangul_PreviousCandidate"; -0xff3f,"Hangul_Special"; -0xFF7E,"Hangul_switch"; -0xea1,"Hangul_Kiyeog"; -0xea2,"Hangul_SsangKiyeog"; -0xea3,"Hangul_KiyeogSios"; -0xea4,"Hangul_Nieun"; -0xea5,"Hangul_NieunJieuj"; -0xea6,"Hangul_NieunHieuh"; -0xea7,"Hangul_Dikeud"; -0xea8,"Hangul_SsangDikeud"; -0xea9,"Hangul_Rieul"; -0xeaa,"Hangul_RieulKiyeog"; -0xeab,"Hangul_RieulMieum"; -0xeac,"Hangul_RieulPieub"; -0xead,"Hangul_RieulSios"; -0xeae,"Hangul_RieulTieut"; -0xeaf,"Hangul_RieulPhieuf"; -0xeb0,"Hangul_RieulHieuh"; -0xeb1,"Hangul_Mieum"; -0xeb2,"Hangul_Pieub"; -0xeb3,"Hangul_SsangPieub"; -0xeb4,"Hangul_PieubSios"; -0xeb5,"Hangul_Sios"; -0xeb6,"Hangul_SsangSios"; -0xeb7,"Hangul_Ieung"; -0xeb8,"Hangul_Jieuj"; -0xeb9,"Hangul_SsangJieuj"; -0xeba,"Hangul_Cieuc"; -0xebb,"Hangul_Khieuq"; -0xebc,"Hangul_Tieut"; -0xebd,"Hangul_Phieuf"; -0xebe,"Hangul_Hieuh"; -0xebf,"Hangul_A"; -0xec0,"Hangul_AE"; -0xec1,"Hangul_YA"; -0xec2,"Hangul_YAE"; -0xec3,"Hangul_EO"; -0xec4,"Hangul_E"; -0xec5,"Hangul_YEO"; -0xec6,"Hangul_YE"; -0xec7,"Hangul_O"; -0xec8,"Hangul_WA"; -0xec9,"Hangul_WAE"; -0xeca,"Hangul_OE"; -0xecb,"Hangul_YO"; -0xecc,"Hangul_U"; -0xecd,"Hangul_WEO"; -0xece,"Hangul_WE"; -0xecf,"Hangul_WI"; -0xed0,"Hangul_YU"; -0xed1,"Hangul_EU"; -0xed2,"Hangul_YI"; -0xed3,"Hangul_I"; -0xed4,"Hangul_J_Kiyeog"; -0xed5,"Hangul_J_SsangKiyeog"; -0xed6,"Hangul_J_KiyeogSios"; -0xed7,"Hangul_J_Nieun"; -0xed8,"Hangul_J_NieunJieuj"; -0xed9,"Hangul_J_NieunHieuh"; -0xeda,"Hangul_J_Dikeud"; -0xedb,"Hangul_J_Rieul"; -0xedc,"Hangul_J_RieulKiyeog"; -0xedd,"Hangul_J_RieulMieum"; -0xede,"Hangul_J_RieulPieub"; -0xedf,"Hangul_J_RieulSios"; -0xee0,"Hangul_J_RieulTieut"; -0xee1,"Hangul_J_RieulPhieuf"; -0xee2,"Hangul_J_RieulHieuh"; -0xee3,"Hangul_J_Mieum"; -0xee4,"Hangul_J_Pieub"; -0xee5,"Hangul_J_PieubSios"; -0xee6,"Hangul_J_Sios"; -0xee7,"Hangul_J_SsangSios"; -0xee8,"Hangul_J_Ieung"; -0xee9,"Hangul_J_Jieuj"; -0xeea,"Hangul_J_Cieuc"; -0xeeb,"Hangul_J_Khieuq"; -0xeec,"Hangul_J_Tieut"; -0xeed,"Hangul_J_Phieuf"; -0xeee,"Hangul_J_Hieuh"; -0xeef,"Hangul_RieulYeorinHieuh"; -0xef0,"Hangul_SunkyeongeumMieum"; -0xef1,"Hangul_SunkyeongeumPieub"; -0xef2,"Hangul_PanSios"; -0xef3,"Hangul_KkogjiDalrinIeung"; -0xef4,"Hangul_SunkyeongeumPhieuf"; -0xef5,"Hangul_YeorinHieuh"; -0xef6,"Hangul_AraeA"; -0xef7,"Hangul_AraeAE"; -0xef8,"Hangul_J_PanSios"; -0xef9,"Hangul_J_KkogjiDalrinIeung"; -0xefa,"Hangul_J_YeorinHieuh"; -0xeff,"Korean_Won"; -] diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.mli index ace751c64..9e339d135 100644 --- a/ide/utils/configwin_types.ml +++ b/ide/utils/configwin_types.mli @@ -25,113 +25,6 @@ (** This module contains the types used in Configwin. *) -open Config_file - -let name_to_keysym = - ("Button1", Configwin_keys.xk_Pointer_Button1) :: - ("Button2", Configwin_keys.xk_Pointer_Button2) :: - ("Button3", Configwin_keys.xk_Pointer_Button3) :: - ("Button4", Configwin_keys.xk_Pointer_Button4) :: - ("Button5", Configwin_keys.xk_Pointer_Button5) :: - Configwin_keys.name_to_keysym - -let string_to_key s = - let mask = ref [] in - let key = try - let pos = String.rindex s '-' in - for i = 0 to pos - 1 do - let m = match s.[i] with - 'C' -> `CONTROL - | 'S' -> `SHIFT - | 'L' -> `LOCK - | 'M' -> `MOD1 - | 'A' -> `MOD1 - | '1' -> `MOD1 - | '2' -> `MOD2 - | '3' -> `MOD3 - | '4' -> `MOD4 - | '5' -> `MOD5 - | _ -> - Minilib.log s; - raise Not_found - in - mask := m :: !mask - done; - String.sub s (pos+1) (String.length s - pos - 1) - with _ -> - s - in - try - !mask, List.assoc key name_to_keysym - with - e -> - Minilib.log s; - raise e - -let key_to_string (m, k) = - let s = List.assoc k Configwin_keys.keysym_to_name in - match m with - [] -> s - | _ -> - let rec iter m s = - match m with - [] -> s - | c :: m -> - iter m (( - match c with - `CONTROL -> "C" - | `SHIFT -> "S" - | `LOCK -> "L" - | `MOD1 -> "A" - | `MOD2 -> "2" - | `MOD3 -> "3" - | `MOD4 -> "4" - | `MOD5 -> "5" - | _ -> raise Not_found - ) ^ s) - in - iter m ("-" ^ s) - -let modifiers_to_string m = - let rec iter m s = - match m with - [] -> s - | c :: m -> - iter m (( - match c with - `CONTROL -> "<ctrl>" - | `SHIFT -> "<shft>" - | `LOCK -> "<lock>" - | `MOD1 -> "<alt>" - | `MOD2 -> "<mod2>" - | `MOD3 -> "<mod3>" - | `MOD4 -> "<mod4>" - | `MOD5 -> "<mod5>" - | _ -> raise Not_found - ) ^ s) - in - iter m "" - -let value_to_key v = - match v with - Raw.String s -> string_to_key s - | _ -> - Minilib.log "value_to_key"; - raise Not_found - -let key_to_value k = - Raw.String (key_to_string k) - -let key_cp_wrapper = - { - to_raw = key_to_value ; - of_raw = value_to_key ; - } - -(** A class to define key options, with the {!Config_file} module. *) -class key_cp = - [(Gdk.Tags.modifier list * int)] Config_file.cp_custom_type key_cp_wrapper - (** This type represents a string or filename parameter, or any other type, depending on the given conversion functions. *) type 'a string_param = { @@ -188,49 +81,6 @@ type custom_param = { custom_framed : string option ; (** optional label for an optional frame *) } ;; -type color_param = { - color_label : string; (** the label of the parameter *) - mutable color_value : string; (** the current value of the parameter *) - color_editable : bool ; (** indicates if the value can be changed *) - color_f_apply : (string -> unit) ; (** the function to call to apply the new value of the parameter *) - color_help : string option ; (** optional help string *) - color_expand : bool ; (** expand the entry widget or not *) - } ;; - -type date_param = { - date_label : string ; (** the label of the parameter *) - mutable date_value : int * int * int ; (** day, month, year *) - date_editable : bool ; (** indicates if the value can be changed *) - date_f_string : (int * int * int) -> string ; - (** the function used to display the current value (day, month, year) *) - date_f_apply : ((int * int * int) -> unit) ; - (** the function to call to apply the new value (day, month, year) of the parameter *) - date_help : string option ; (** optional help string *) - date_expand : bool ; (** expand the entry widget or not *) - } ;; - -type font_param = { - font_label : string ; (** the label of the parameter *) - mutable font_value : string ; (** the font name *) - font_editable : bool ; (** indicates if the value can be changed *) - font_f_apply : (string -> unit) ; - (** the function to call to apply the new value of the parameter *) - font_help : string option ; (** optional help string *) - font_expand : bool ; (** expand the entry widget or not *) - } ;; - - -type hotkey_param = { - hk_label : string ; (** the label of the parameter *) - mutable hk_value : (Gdk.Tags.modifier list * int) ; - (** The value, as a list of modifiers and a key code *) - hk_editable : bool ; (** indicates if the value can be changed *) - hk_f_apply : ((Gdk.Tags.modifier list * int) -> unit) ; - (** the function to call to apply the new value of the paramter *) - hk_help : string option ; (** optional help string *) - hk_expand : bool ; (** expand or not *) - } - type modifiers_param = { md_label : string ; (** the label of the parameter *) mutable md_value : Gdk.Tags.modifier list ; @@ -248,17 +98,11 @@ type modifiers_param = { type parameter_kind = String_param of string string_param | List_param of (GData.tooltips -> <box: GObj.widget ; apply : unit>) - | Filename_param of string string_param | Bool_param of bool_param | Text_param of string string_param | Combo_param of combo_param | Custom_param of custom_param - | Color_param of color_param - | Date_param of date_param - | Font_param of font_param - | Hotkey_param of hotkey_param | Modifiers_param of modifiers_param - | Html_param of string string_param ;; (** This type represents the structure of the configuration window. *) @@ -275,28 +119,3 @@ type return_button = | Return_cancel (** The user closed the window with the cancel button or the window manager but never clicked on the apply button.*) - -(** {2 Bindings in the html editor} *) - -type html_binding = { - mutable html_key : (Gdk.Tags.modifier list * int) ; - mutable html_begin : string ; - mutable html_end : string ; - } - -let htmlbinding_cp_wrapper = - let w = Config_file.tuple3_wrappers - key_cp_wrapper - Config_file.string_wrappers - Config_file.string_wrappers - in - { - to_raw = (fun v -> w.to_raw (v.html_key, v.html_begin, v.html_end)) ; - of_raw = - (fun r -> let (k,b,e) = w.of_raw r in - { html_key = k ; html_begin = b ; html_end = e } - ) ; - } - -class htmlbinding_cp = - [html_binding] Config_file.option_cp htmlbinding_cp_wrapper diff --git a/ide/utils/editable_cells.ml b/ide/utils/editable_cells.ml deleted file mode 100644 index 33968b8dd..000000000 --- a/ide/utils/editable_cells.ml +++ /dev/null @@ -1,113 +0,0 @@ -open Gobject - -let create l = - let hbox = GPack.hbox () in - let scw = GBin.scrolled_window - ~hpolicy:`AUTOMATIC - ~vpolicy:`AUTOMATIC - ~packing:(hbox#pack ~expand:true) () in - - let columns = new GTree.column_list in - let command_col = columns#add Data.string in - let coq_col = columns#add Data.string in - let store = GTree.list_store columns - in - -(* populate the store *) - let _ = List.iter (fun (x,y) -> - let row = store#append () in - store#set ~row ~column:command_col x; - store#set ~row ~column:coq_col y) - l - in - let view = GTree.view ~model:store ~packing:scw#add_with_viewport () in - - (* Alternate colors for the rows *) - view#set_rules_hint true; - - let renderer_comm = GTree.cell_renderer_text [`EDITABLE true] in - ignore (renderer_comm#connect#edited - ~callback:(fun (path:Gtk.tree_path) (s:string) -> - store#set - ~row:(store#get_iter path) - ~column:command_col s)); - let first = - GTree.view_column ~title:"Coq Command to try" - ~renderer:(renderer_comm,["text",command_col]) - () - in ignore (view#append_column first); - - let renderer_coq = GTree.cell_renderer_text [`EDITABLE true] in - ignore(renderer_coq#connect#edited - ~callback:(fun (path:Gtk.tree_path) (s:string) -> - store#set - ~row:(store#get_iter path) - ~column:coq_col s)); - let second = - GTree.view_column ~title:"Coq Command to insert" - ~renderer:(renderer_coq,["text",coq_col]) - () - in ignore (view#append_column second); - - let vbox = GPack.button_box `VERTICAL ~packing:hbox#pack ~layout:`SPREAD () - in - let up = GButton.button ~stock:`GO_UP ~label:"Up" ~packing:(vbox#pack ~expand:true ~fill:false) () in - let down = GButton.button - ~stock:`GO_DOWN - ~label:"Down" - ~packing:(vbox#pack ~expand:true ~fill:false) () - in - let add = GButton.button ~stock:`ADD - ~label:"Add" - ~packing:(vbox#pack ~expand:true ~fill:false) - () - in - let remove = GButton.button ~stock:`REMOVE - ~label:"Remove" - ~packing:(vbox#pack ~expand:true ~fill:false) () - in - - ignore (add#connect#clicked - ~callback:(fun b -> - let n = store#append () in - view#selection#select_iter n)); - ignore (remove#connect#clicked - ~callback:(fun b -> match view#selection#get_selected_rows with - | [] -> () - | path::_ -> - let iter = store#get_iter path in - ignore (store#remove iter); - )); - ignore (up#connect#clicked - ~callback:(fun b -> - match view#selection#get_selected_rows with - | [] -> () - | path::_ -> - let iter = store#get_iter path in - ignore (GtkTree.TreePath.prev path); - let upiter = store#get_iter path in - ignore (store#swap iter upiter); - )); - ignore (down#connect#clicked - ~callback:(fun b -> - match view#selection#get_selected_rows with - | [] -> () - | path::_ -> - let iter = store#get_iter path in - GtkTree.TreePath.next path; - try let upiter = store#get_iter path in - ignore (store#swap iter upiter) - with _ -> () - )); - let get_data () = - let start_path = GtkTree.TreePath.from_string "0" in - let start_iter = store#get_iter start_path in - let rec all acc = - let new_acc = (store#get ~row:start_iter ~column:command_col, - store#get ~row:start_iter ~column:coq_col)::acc - in - if store#iter_next start_iter then all new_acc else List.rev new_acc - in all [] - in - (hbox,get_data) - diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml deleted file mode 100644 index 8f6cb382a..000000000 --- a/ide/utils/okey.ml +++ /dev/null @@ -1,169 +0,0 @@ -(*********************************************************************************) -(* Cameleon *) -(* *) -(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. *) -(* *) -(* This program is free software; you can redistribute it and/or modify *) -(* it under the terms of the GNU Library General Public License as *) -(* published by the Free Software Foundation; either version 2 of the *) -(* License, or any later version. *) -(* *) -(* This program 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 Library General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU Library General Public *) -(* License along with this program; if not, write to the Free Software *) -(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) -(* 02111-1307 USA *) -(* *) -(* Contact: Maxence.Guesdon@inria.fr *) -(* *) -(*********************************************************************************) - -type modifier = Gdk.Tags.modifier - -type handler = { - cond : (unit -> bool) ; - cback : (unit -> unit) ; - } - -type handler_spec = int * int * Gdk.keysym - (** mods * mask * key *) - -let int_of_modifier = function - `SHIFT -> 1 - | `LOCK -> 2 - | `CONTROL -> 4 - | `MOD1 -> 8 - | `MOD2 -> 16 - | `MOD3 -> 32 - | `MOD4 -> 64 - | `MOD5 -> 128 - | `BUTTON1 -> 256 - | `BUTTON2 -> 512 - | `BUTTON3 -> 1024 - | `BUTTON4 -> 2048 - | `BUTTON5 -> 4096 - | `HYPER -> 1 lsl 22 - | `META -> 1 lsl 20 - | `RELEASE -> 1 lsl 30 - | `SUPER -> 1 lsl 21 - -let int_of_modifiers l = - List.fold_left (fun acc -> fun m -> acc + (int_of_modifier m)) 0 l - -module H = - struct - type t = handler_spec * handler - let equal (m,k) (mods, mask, key) = - (k = key) && ((m land mask) = mods) - - let filter_with_mask mods mask key l = - List.filter (fun a -> (fst a) <> (mods, mask, key)) l - - let find_handlers mods key l = - List.map snd - (List.filter - (fun ((m,ma,k),_) -> equal (mods,key) (m,ma,k)) - l - ) - - end - -let (table : (int, H.t list ref) Hashtbl.t) = Hashtbl.create 13 - -let key_press w ev = - let key = GdkEvent.Key.keyval ev in - let modifiers = GdkEvent.Key.state ev in - try - let (r : H.t list ref) = Hashtbl.find table (Oo.id w) in - let l = H.find_handlers (int_of_modifiers modifiers) key !r in - match l with - [] -> false - | _ -> - List.iter - (fun h -> - if h.cond () then - try h.cback () - with e -> Minilib.log (Printexc.to_string e) - else () - ) - l; - true - with - Not_found -> - false - -let associate_key_press w = - ignore ((w#event#connect#key_press ~callback: (key_press w)) : GtkSignal.id) - -let default_modifiers = ref ([] : modifier list) -let default_mask = ref ([`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] : modifier list) - -let set_default_modifiers l = default_modifiers := l -let set_default_mask l = default_mask := l - -let remove_widget (w : < event : GObj.event_ops ; ..>) () = - try - let r = Hashtbl.find table (Oo.id w) in - r := [] - with - Not_found -> - () - -let add1 ?(remove=false) w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k callback = - - let r = - try Hashtbl.find table (Oo.id w) - with Not_found -> - let r = ref [] in - Hashtbl.add table (Oo.id w) r; - ignore (w#connect#destroy ~callback: (remove_widget w)); - associate_key_press w; - r - in - let n_mods = int_of_modifiers mods in - let n_mask = lnot (int_of_modifiers mask) in - let new_h = { cond = cond ; cback = callback } in - if remove then - ( - let l = H.filter_with_mask n_mods n_mask k !r in - r := ((n_mods, n_mask, k), new_h) :: l - ) - else - r := ((n_mods, n_mask, k), new_h) :: !r - -let add w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k callback = - add1 w ~cond ~mods ~mask k callback - -let add_list w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k_list callback = - List.iter (fun k -> add w ~cond ~mods ~mask k callback) k_list - -let set w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k callback = - add1 ~remove: true w ~cond ~mods ~mask k callback - -let set_list w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k_list callback = - List.iter (fun k -> set w ~cond ~mods ~mask k callback) k_list diff --git a/ide/utils/okey.mli b/ide/utils/okey.mli deleted file mode 100644 index 84ea4df44..000000000 --- a/ide/utils/okey.mli +++ /dev/null @@ -1,115 +0,0 @@ -(*********************************************************************************) -(* Cameleon *) -(* *) -(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. *) -(* *) -(* This program is free software; you can redistribute it and/or modify *) -(* it under the terms of the GNU Library General Public License as *) -(* published by the Free Software Foundation; either version 2 of the *) -(* License, or any later version. *) -(* *) -(* This program 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 Library General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU Library General Public *) -(* License along with this program; if not, write to the Free Software *) -(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) -(* 02111-1307 USA *) -(* *) -(* Contact: Maxence.Guesdon@inria.fr *) -(* *) -(*********************************************************************************) - -(** Okey interface. - - Once the lib is compiled and installed, you can use it by referencing - it with the [Okey] module. You must add [okey.cmo] or [okey.cmx] - on the commande line when you link. -*) - -type modifier = Gdk.Tags.modifier - -(** Set the default modifier list. The first default value is [[]].*) -val set_default_modifiers : modifier list -> unit - -(** Set the default modifier mask. The first default value is - [[`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK]]. - The mask defines the modifiers not taken into account - when looking for the handler of a key press event. -*) -val set_default_mask : modifier list -> unit - -(** [add widget key callback] associates the [callback] function to the event - "key_press" with the given [key] for the given [widget]. - - @param remove when true, the previous handlers for the given key and modifier - list are not kept. - @param cond this function is a guard: the [callback] function is not called - if the [cond] function returns [false]. - The default [cond] function always returns [true]. - - @param mods the list of modifiers. If not given, the default modifiers - are used. - You can set the default modifiers with function {!Okey.set_default_modifiers}. - - @param mask the list of modifiers which must not be taken - into account to trigger the given handler. [mods] - and [mask] must not have common modifiers. If not given, the default mask - is used. - You can set the default modifiers mask with function {!Okey.set_default_mask}. -*) -val add : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym -> - (unit -> unit) -> - unit - -(** It calls {!Okey.add} for each given key.*) -val add_list : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym list -> - (unit -> unit) -> - unit - -(** Like {!Okey.add} but the previous handlers for the - given modifiers and key are not kept.*) -val set : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym -> - (unit -> unit) -> - unit - -(** It calls {!Okey.set} for each given key.*) -val set_list : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym list -> - (unit -> unit) -> - unit - -(** Remove the handlers associated to the given widget. - This is automatically done when a widget is destroyed but - you can do it yourself. *) -val remove_widget : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - unit -> - unit diff --git a/interp/constrarg.ml b/interp/constrarg.ml deleted file mode 100644 index ca828102b..000000000 --- a/interp/constrarg.ml +++ /dev/null @@ -1,74 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Loc -open Tacexpr -open Misctypes -open Genarg -open Geninterp - -let make0 ?dyn name = - let wit = Genarg.make0 name in - let () = Geninterp.register_val0 wit dyn in - wit - -(** This is a hack for now, to break the dependency of Genarg on constr-related - types. We should use dedicated functions someday. *) - -let loc_of_or_by_notation f = function - | AN c -> f c - | ByNotation (loc,s,_) -> loc - -let wit_int_or_var = - make0 ~dyn:(val_tag (topwit Stdarg.wit_int)) "int_or_var" - -let wit_intro_pattern : (Constrexpr.constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type = - make0 "intropattern" - -let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = - make0 "tactic" - -let wit_ltac = make0 ~dyn:(val_tag (topwit Stdarg.wit_unit)) "ltac" - -let wit_ident = - make0 "ident" - -let wit_var = - make0 ~dyn:(val_tag (topwit wit_ident)) "var" - -let wit_ref = make0 "ref" - -let wit_quant_hyp = make0 "quant_hyp" - -let wit_constr = - make0 "constr" - -let wit_uconstr = make0 "uconstr" - -let wit_open_constr = make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr" - -let wit_constr_with_bindings = make0 "constr_with_bindings" - -let wit_bindings = make0 "bindings" - -let wit_red_expr = make0 "redexpr" - -let wit_clause_dft_concl = - make0 "clause_dft_concl" - -let wit_destruction_arg = - make0 "destruction_arg" - -(** Aliases *) - -let wit_reference = wit_ref -let wit_global = wit_ref -let wit_clause = wit_clause_dft_concl -let wit_quantified_hypothesis = wit_quant_hyp -let wit_intropattern = wit_intro_pattern -let wit_redexpr = wit_red_expr diff --git a/interp/constrarg.mli b/interp/constrarg.mli deleted file mode 100644 index 6ccd944d4..000000000 --- a/interp/constrarg.mli +++ /dev/null @@ -1,87 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** Generic arguments based on [constr]. We put them here to avoid a dependency - of Genarg in [constr]-related interfaces. *) - -open Loc -open Names -open Term -open Libnames -open Globnames -open Genredexpr -open Pattern -open Constrexpr -open Tacexpr -open Misctypes -open Genarg - -(** FIXME: nothing to do there. *) -val loc_of_or_by_notation : ('a -> Loc.t) -> 'a or_by_notation -> Loc.t - -(** {5 Additional generic arguments} *) - -val wit_int_or_var : (int or_var, int or_var, int) genarg_type - -val wit_intro_pattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type - -val wit_ident : Id.t uniform_genarg_type - -val wit_var : (Id.t located, Id.t located, Id.t) genarg_type - -val wit_ref : (reference, global_reference located or_var, global_reference) genarg_type - -val wit_quant_hyp : quantified_hypothesis uniform_genarg_type - -val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type - -val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type - -val wit_open_constr : - (constr_expr, glob_constr_and_expr, constr) genarg_type - -val wit_constr_with_bindings : - (constr_expr with_bindings, - glob_constr_and_expr with_bindings, - constr with_bindings delayed_open) genarg_type - -val wit_bindings : - (constr_expr bindings, - glob_constr_and_expr bindings, - constr bindings delayed_open) genarg_type - -val wit_red_expr : - ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, - (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, - (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type - -val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Geninterp.Val.t) genarg_type - -(** [wit_ltac] is subtly different from [wit_tactic]: they only change for their - toplevel interpretation. The one of [wit_ltac] forces the tactic and - discards the result. *) -val wit_ltac : (raw_tactic_expr, glob_tactic_expr, unit) genarg_type - -val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type - -val wit_destruction_arg : - (constr_expr with_bindings destruction_arg, - glob_constr_and_expr with_bindings destruction_arg, - delayed_open_constr_with_bindings destruction_arg) genarg_type - -(** Aliases for compatibility *) - -val wit_reference : (reference, global_reference located or_var, global_reference) genarg_type -val wit_global : (reference, global_reference located or_var, global_reference) genarg_type -val wit_clause : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type -val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type -val wit_intropattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type -val wit_redexpr : - ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, - (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, - (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 04429851f..59c24900d 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -382,18 +382,18 @@ let rec prod_constr_expr c = function let coerce_reference_to_id = function | Ident (_,id) -> id | Qualid (loc,_) -> - CErrors.user_err_loc (loc, "coerce_reference_to_id", - str "This expression should be a simple identifier.") + CErrors.user_err ~loc ~hdr:"coerce_reference_to_id" + (str "This expression should be a simple identifier.") let coerce_to_id = function | CRef (Ident (loc,id),_) -> (loc,id) - | a -> CErrors.user_err_loc - (constr_loc a,"coerce_to_id", - str "This expression should be a simple identifier.") + | a -> CErrors.user_err ~loc:(constr_loc a) + ~hdr:"coerce_to_id" + (str "This expression should be a simple identifier.") let coerce_to_name = function | CRef (Ident (loc,id),_) -> (loc,Name id) | CHole (loc,_,_,_) -> (loc,Anonymous) - | a -> CErrors.user_err_loc - (constr_loc a,"coerce_to_name", - str "This expression should be a name.") + | a -> CErrors.user_err + ~loc:(constr_loc a) ~hdr:"coerce_to_name" + (str "This expression should be a name.") diff --git a/interp/constrextern.ml b/interp/constrextern.ml index dd8a48b85..3077231be 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -94,8 +94,8 @@ let is_record indsp = let encode_record r = let indsp = global_inductive r in if not (is_record indsp) then - user_err_loc (loc_of_reference r,"encode_record", - str "This type is not a structure type."); + user_err ~loc:(loc_of_reference r) ~hdr:"encode_record" + (str "This type is not a structure type."); indsp module PrintingRecordRecord = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index e6340646f..235e6e24f 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -154,17 +154,17 @@ let explain_internalization_error e = | BadPatternsNumber (n1,n2) -> explain_bad_patterns_number n1 n2 in pp ++ str "." -let error_bad_inductive_type loc = - user_err_loc (loc,"",str +let error_bad_inductive_type ?loc = + user_err ?loc (str "This should be an inductive type applied to patterns.") -let error_parameter_not_implicit loc = - user_err_loc (loc,"", str +let error_parameter_not_implicit ?loc = + user_err ?loc (str "The parameters do not bind in patterns;" ++ spc () ++ str "they must be replaced by '_'.") -let error_ldots_var loc = - user_err_loc (loc,"",str "Special token " ++ pr_id ldots_var ++ +let error_ldots_var ?loc = + user_err ?loc (str "Special token " ++ pr_id ldots_var ++ str " is for use in the Notation command.") (**********************************************************************) @@ -262,15 +262,15 @@ let pr_scope_stack = function | l -> str "scope stack " ++ str "[" ++ prlist_with_sep pr_comma str l ++ str "]" -let error_inconsistent_scope loc id scopes1 scopes2 = - user_err_loc (loc,"set_var_scope", - pr_id id ++ str " is here used in " ++ +let error_inconsistent_scope ?loc id scopes1 scopes2 = + user_err ?loc ~hdr:"set_var_scope" + (pr_id id ++ str " is here used in " ++ pr_scope_stack scopes2 ++ strbrk " while it was elsewhere used in " ++ pr_scope_stack scopes1) -let error_expect_binder_notation_type loc id = - user_err_loc (loc,"", - pr_id id ++ +let error_expect_binder_notation_type ?loc id = + user_err ?loc + (pr_id id ++ str " is expected to occur in binding position in the right-hand side.") let set_var_scope loc id istermvar env ntnvars = @@ -284,12 +284,12 @@ let set_var_scope loc id istermvar env ntnvars = | Some (tmp, scope) -> let s1 = make_current_scope tmp scope in let s2 = make_current_scope env.tmp_scope env.scopes in - if not (List.equal String.equal s1 s2) then error_inconsistent_scope loc id s1 s2 + if not (List.equal String.equal s1 s2) then error_inconsistent_scope ~loc id s1 s2 end in match typ with | NtnInternTypeBinder -> - if istermvar then error_expect_binder_notation_type loc id + if istermvar then error_expect_binder_notation_type ~loc id | NtnInternTypeConstr -> (* We need sometimes to parse idents at a constr level for factorization and we cannot enforce this constraint: @@ -366,19 +366,19 @@ let check_hidden_implicit_parameters id impls = | (Inductive indparams,_,_,_) -> Id.List.mem id indparams | _ -> false) impls then - errorlabstrm "" (strbrk "A parameter of an inductive type " ++ + user_err (strbrk "A parameter of an inductive type " ++ pr_id id ++ strbrk " is not allowed to be used as a bound variable in the type of its constructor.") let push_name_env ?(global_level=false) ntnvars implargs env = function | loc,Anonymous -> if global_level then - user_err_loc (loc,"", str "Anonymous variables not allowed"); + user_err ~loc (str "Anonymous variables not allowed"); env | loc,Name id -> check_hidden_implicit_parameters id env.impls ; if Id.Map.is_empty ntnvars && Id.equal id ldots_var - then error_ldots_var loc; + then error_ldots_var ~loc; set_var_scope loc id false env ntnvars; if global_level then Dumpglob.dump_definition (loc,id) true "var" else Dumpglob.dump_binding loc id; @@ -660,23 +660,13 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = let arg = match arg with | None -> None | Some arg -> - let open Tacexpr in - let open Genarg in - let wit = glbwit Constrarg.wit_tactic in - let body = - if has_type arg wit then out_gen wit arg - else assert false (** FIXME *) - in - let mk_env id (c, (tmp_scope, subscopes)) accu = + let mk_env (c, (tmp_scope, subscopes)) = let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in let gc = intern nenv c in - let c = ConstrMayEval (Genredexpr.ConstrTerm (gc, Some c)) in - ((loc, id), c) :: accu + (gc, Some c) in - let bindings = Id.Map.fold mk_env terms [] in - let tac = TacLetIn (false, bindings, body) in - let arg = in_gen wit tac in - Some arg + let bindings = Id.Map.map mk_env terms in + Some (Genintern.generic_substitute_notation bindings arg) in GHole (loc, knd, naming, arg) | NBinderList (x,y,iter,terminator) -> @@ -764,7 +754,7 @@ let string_of_ty = function let gvar (loc, id) us = match us with | None -> GVar (loc, id) | Some _ -> - user_err_loc (loc, "", str "Variable " ++ pr_id id ++ + user_err ~loc (str "Variable " ++ pr_id id ++ str " cannot have a universe instance") let intern_var genv (ltacvars,ntnvars) namedctx loc id us = @@ -788,12 +778,12 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id us = (* Is [id] the special variable for recursive notations *) else if Id.equal id ldots_var then if Id.Map.is_empty ntnvars - then error_ldots_var loc + then error_ldots_var ~loc else gvar (loc,id) us, [], [], [] else if Id.Set.mem id ltacvars.ltac_bound then (* Is [id] bound to a free name in ltac (this is an ltac error message) *) - user_err_loc (loc,"intern_var", - str "variable " ++ pr_id id ++ str " should be bound to a term.") + user_err ~loc ~hdr:"intern_var" + (str "variable " ++ pr_id id ++ str " should be bound to a term.") else (* Is [id] a goal or section variable *) let _ = Context.Named.lookup id namedctx in @@ -825,7 +815,7 @@ let find_appl_head_data c = | x -> x,[],[],[] let error_not_enough_arguments loc = - user_err_loc (loc,"",str "Abbreviation is not applied enough.") + user_err ~loc (str "Abbreviation is not applied enough.") let check_no_explicitation l = let is_unset (a, b) = match b with None -> false | Some _ -> true in @@ -834,7 +824,7 @@ let check_no_explicitation l = | [] -> () | (_, None) :: _ -> assert false | (_, Some (loc, _)) :: _ -> - user_err_loc (loc,"",str"Unexpected explicitation of the argument of an abbreviation.") + user_err ~loc (str"Unexpected explicitation of the argument of an abbreviation.") let dump_extended_global loc = function | TrueGlobal ref -> (*feedback_global loc ref;*) Dumpglob.add_glob loc ref @@ -847,7 +837,7 @@ let intern_reference ref = let qid = qualid_of_reference ref in let r = try intern_extended_global_of_qualid qid - with Not_found -> error_global_not_found_loc (fst qid) (snd qid) + with Not_found -> error_global_not_found ~loc:(fst qid) (snd qid) in Smartlocate.global_of_extended_global r @@ -872,7 +862,7 @@ let intern_qualid loc qid intern env lvar us args = | Some _, GApp (loc, GRef (loc', ref, None), arg) -> GApp (loc, GRef (loc', ref, us), arg) | Some _, _ -> - user_err_loc (loc, "", str "Notation " ++ pr_qualid qid ++ + user_err ~loc (str "Notation " ++ pr_qualid qid ++ str " cannot have a universe instance, its expanded head does not start with a reference") in @@ -888,7 +878,7 @@ let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = | Qualid (loc, qid) -> let r,projapp,args2 = try intern_qualid loc qid intern env ntnvars us args - with Not_found -> error_global_not_found_loc loc qid + with Not_found -> error_global_not_found ~loc qid in let x, imp, scopes, l = find_appl_head_data r in (x,imp,scopes,l), args2 @@ -904,7 +894,7 @@ let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then (gvar (loc,id) us, [], [], []), args - else error_global_not_found_loc loc qid + else error_global_not_found ~loc qid let interp_reference vars r = let (r,_,_,_),_ = @@ -982,7 +972,7 @@ let check_number_of_pattern loc n l = let check_or_pat_variables loc ids idsl = if List.exists (fun ids' -> not (List.eq_set Id.equal ids ids')) idsl then - user_err_loc (loc, "", str + user_err ~loc (str "The components of this disjunctive pattern must bind the same variables.") (** Use only when params were NOT asked to the user. @@ -991,7 +981,7 @@ let check_constructor_length env loc cstr len_pl pl0 = let n = len_pl + List.length pl0 in if Int.equal n (Inductiveops.constructor_nallargs cstr) then false else (Int.equal n (Inductiveops.constructor_nalldecls cstr) || - (error_wrong_numarg_constructor_loc loc env cstr + (error_wrong_numarg_constructor ~loc env cstr (Inductiveops.constructor_nrealargs cstr))) let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 = @@ -1016,14 +1006,14 @@ let add_implicits_check_constructor_length env loc c len_pl1 pl2 = let nargs = Inductiveops.constructor_nallargs c in let nargs' = Inductiveops.constructor_nalldecls c in let impls_st = implicits_of_global (ConstructRef c) in - add_implicits_check_length (error_wrong_numarg_constructor_loc loc env c) + add_implicits_check_length (error_wrong_numarg_constructor ~loc env c) nargs nargs' impls_st len_pl1 pl2 let add_implicits_check_ind_length env loc c len_pl1 pl2 = let nallargs = inductive_nallargs_env env c in let nalldecls = inductive_nalldecls_env env c in let impls_st = implicits_of_global (IndRef c) in - add_implicits_check_length (error_wrong_numarg_inductive_loc loc env c) + add_implicits_check_length (error_wrong_numarg_inductive ~loc env c) nallargs nalldecls impls_st len_pl1 pl2 (** Do not raise NotEnoughArguments thanks to preconditions*) @@ -1034,7 +1024,7 @@ let chop_params_pattern loc ind args with_letin = assert (nparams <= List.length args); let params,args = List.chop nparams args in List.iter (function PatVar(_,Anonymous) -> () - | PatVar (loc',_) | PatCstr(loc',_,_,_) -> error_parameter_not_implicit loc') params; + | PatVar (loc',_) | PatCstr(loc',_,_,_) -> error_parameter_not_implicit ~loc:loc') params; args let find_constructor loc add_params ref = @@ -1042,10 +1032,10 @@ let find_constructor loc add_params ref = | ConstructRef cstr -> cstr | IndRef _ -> let error = str "There is an inductive name deep in a \"in\" clause." in - user_err_loc (loc, "find_constructor", error) + user_err ~loc ~hdr:"find_constructor" error | ConstRef _ | VarRef _ -> let error = str "This reference is not a constructor." in - user_err_loc (loc, "find_constructor", error) + user_err ~loc ~hdr:"find_constructor" error in cstr, match add_params with | Some nb_args -> @@ -1067,7 +1057,7 @@ let check_duplicate loc fields = match dups with | [] -> () | (r, _) :: _ -> - user_err_loc (loc, "", str "This record defines several times the field " ++ + user_err ~loc (str "This record defines several times the field " ++ pr_reference r ++ str ".") (** [sort_fields ~complete loc fields completer] expects a list @@ -1092,8 +1082,8 @@ let sort_fields ~complete loc fields completer = let gr = global_reference_of_reference first_field_ref in (gr, Recordops.find_projection gr) with Not_found -> - user_err_loc (loc_of_reference first_field_ref, "intern", - pr_reference first_field_ref ++ str": Not a projection") + user_err ~loc:(loc_of_reference first_field_ref) ~hdr:"intern" + (pr_reference first_field_ref ++ str": Not a projection") in (* the number of parameters *) let nparams = record.Recordops.s_EXPECTEDPARAM in @@ -1123,7 +1113,7 @@ let sort_fields ~complete loc fields completer = by a let-in in the record declaration (its value is fixed from other fields). *) if first_field && not regular && complete then - user_err_loc (loc, "", str "No local fields allowed in a record construction.") + user_err ~loc (str "No local fields allowed in a record construction.") else if first_field then build_proj_list projs proj_kinds (idx+1) ~acc_first_idx:idx acc else if not regular && complete then @@ -1136,7 +1126,7 @@ let sort_fields ~complete loc fields completer = | None :: projs -> if complete then (* we don't want anonymous fields *) - user_err_loc (loc, "", str "This record contains anonymous fields.") + user_err ~loc (str "This record contains anonymous fields.") else (* anonymous arguments don't appear in proj_kinds *) build_proj_list projs proj_kinds (idx+1) ~acc_first_idx acc @@ -1150,15 +1140,14 @@ let sort_fields ~complete loc fields completer = | (field_ref, field_value) :: fields -> let field_glob_ref = try global_reference_of_reference field_ref with Not_found -> - user_err_loc (loc_of_reference field_ref, "intern", - str "The field \"" ++ pr_reference field_ref ++ str "\" does not exist.") in + user_err ~loc:(loc_of_reference field_ref) ~hdr:"intern" + (str "The field \"" ++ pr_reference field_ref ++ str "\" does not exist.") in let remaining_projs, (field_index, _) = let the_proj (idx, glob_ref) = eq_gr field_glob_ref glob_ref in try CList.extract_first the_proj remaining_projs with Not_found -> - user_err_loc - (loc, "", - str "This record contains fields of different records.") + user_err ~loc + (str "This record contains fields of different records.") in index_fields fields remaining_projs ((field_index, field_value) :: acc) | [] -> @@ -1229,7 +1218,7 @@ let drop_notations_pattern looked_for = if top then looked_for g else match g with ConstructRef _ -> () | _ -> raise Not_found with Not_found -> - error_invalid_pattern_notation loc + error_invalid_pattern_notation ~loc () in let test_kind top = if top then looked_for else function ConstructRef _ -> () | _ -> raise Not_found @@ -1354,8 +1343,8 @@ let drop_notations_pattern looked_for = List.map2 (fun x -> in_not false loc (x,snd scopes) fullsubst []) argscs1 pl @ List.map (in_pat false scopes) args, []) | NList (x,y,iter,terminator,lassoc) -> - if not (List.is_empty args) then user_err_loc - (loc,"",strbrk "Application of arguments to a recursive notation not supported in patterns."); + if not (List.is_empty args) then user_err ~loc + (strbrk "Application of arguments to a recursive notation not supported in patterns."); (try (* All elements of the list are in scopes (scopt,subscopes) *) let (l,(scopt,subscopes)) = Id.Map.find x substlist in @@ -1370,7 +1359,7 @@ let drop_notations_pattern looked_for = | NHole _ -> let () = assert (List.is_empty args) in RCPatAtom (loc, None) - | t -> error_invalid_pattern_notation loc + | t -> error_invalid_pattern_notation ~loc () in in_pat true let rec intern_pat genv aliases pat = @@ -1422,8 +1411,8 @@ let rec intern_pat genv aliases pat = [pattern] rule. *) let rec check_no_patcast = function | CPatCast (loc,_,_) -> - CErrors.user_err_loc (loc, "check_no_patcast", - Pp.strbrk "Casts are not supported here.") + CErrors.user_err ~loc ~hdr:"check_no_patcast" + (Pp.strbrk "Casts are not supported here.") | CPatDelimiters(_,_,p) | CPatAlias(_,p,_) -> check_no_patcast p | CPatCstr(_,_,opl,pl) -> @@ -1456,11 +1445,11 @@ let intern_ind_pattern genv scopes pat = let no_not = try drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) scopes pat - with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type loc + with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type ~loc in match no_not with | RCPatCstr (loc, head, expl_pl, pl) -> - let c = (function IndRef ind -> ind | _ -> error_bad_inductive_type loc) head in + let c = (function IndRef ind -> ind | _ -> error_bad_inductive_type ~loc) head in let with_letin, pl2 = add_implicits_check_ind_length genv loc c (List.length expl_pl) pl in let idslpl1 = List.rev_map (intern_pat genv empty_alias) expl_pl in @@ -1468,8 +1457,8 @@ let intern_ind_pattern genv scopes pat = (with_letin, match product_of_cases_patterns [] (List.rev_append idslpl1 idslpl2) with | _,[_,pl] -> (c,chop_params_pattern loc c pl with_letin) - | _ -> error_bad_inductive_type loc) - | x -> error_bad_inductive_type (raw_cases_pattern_expr_loc x) + | _ -> error_bad_inductive_type ~loc) + | x -> error_bad_inductive_type ~loc:(raw_cases_pattern_expr_loc x) (**********************************************************************) (* Utilities for application *) @@ -1508,10 +1497,10 @@ let extract_explicit_arg imps args = let id = match pos with | ExplByName id -> if not (exists_implicit_name id imps) then - user_err_loc - (loc,"",str "Wrong argument name: " ++ pr_id id ++ str "."); + user_err ~loc + (str "Wrong argument name: " ++ pr_id id ++ str "."); if Id.Map.mem id eargs then - user_err_loc (loc,"",str "Argument name " ++ pr_id id + user_err ~loc (str "Argument name " ++ pr_id id ++ str " occurs more than once."); id | ExplByPos (p,_id) -> @@ -1521,11 +1510,11 @@ let extract_explicit_arg imps args = if not (is_status_implicit imp) then failwith "imp"; name_of_implicit imp with Failure _ (* "nth" | "imp" *) -> - user_err_loc - (loc,"",str"Wrong argument position: " ++ int p ++ str ".") + user_err ~loc + (str"Wrong argument position: " ++ int p ++ str ".") in if Id.Map.mem id eargs then - user_err_loc (loc,"",str"Argument at position " ++ int p ++ + user_err ~loc (str"Argument at position " ++ int p ++ str " is mentioned more than once."); id in (Id.Map.add id (loc, a) eargs, rargs) @@ -1576,7 +1565,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = (function | BDRawDef a -> a | BDPattern (loc,_,_,_,_) -> - Loc.raise loc (Stream.Error "pattern with quote not allowed after fix")) rbl in + Loc.raise ~loc (Stream.Error "pattern with quote not allowed after fix")) rbl in ((n, ro), bl, intern_type env' ty, env')) dl in let idl = Array.map2 (fun (_,_,_,_,bd) (a,b,c,env') -> let env'' = List.fold_left_i (fun i en name -> @@ -1680,7 +1669,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = in begin match fields with - | None -> user_err_loc (loc, "intern", str"No constructor inference.") + | None -> user_err ~loc ~hdr:"intern" (str"No constructor inference.") | Some (n, constrname, args) -> let pars = List.make n (CHole (loc, None, Misctypes.IntroAnonymous, None)) in let app = CAppExpl (loc, (None, constrname,None), List.rev_append pars args) in @@ -1903,7 +1892,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = | (imp::impl', []) -> if not (Id.Map.is_empty eargs) then (let (id,(loc,_)) = Id.Map.choose eargs in - user_err_loc (loc,"",str "Not enough non implicit \ + user_err ~loc (str "Not enough non implicit \ arguments to accept the argument bound to " ++ pr_id id ++ str".")); [] @@ -1934,8 +1923,8 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = intern env c with InternalizationError (loc,e) -> - user_err_loc (loc,"internalize", - explain_internalization_error e) + user_err ~loc ~hdr:"internalize" + (explain_internalization_error e) (**************************************************************************) (* Functions to translate constr_expr into glob_constr *) @@ -1974,7 +1963,7 @@ let intern_pattern globalenv patt = intern_cases_pattern globalenv (None,[]) empty_alias patt with InternalizationError (loc,e) -> - user_err_loc (loc,"internalize",explain_internalization_error e) + user_err ~loc ~hdr:"internalize" (explain_internalization_error e) (*********************************************************************) @@ -2085,13 +2074,13 @@ let intern_context global_level env impl_env binders = (function | BDRawDef a -> a | BDPattern (loc,_,_,_,_) -> - Loc.raise loc (Stream.Error "pattern with quote not allowed here")) bl in + Loc.raise ~loc (Stream.Error "pattern with quote not allowed here")) bl in (env, bl)) ({ids = extract_ids env; unb = false; tmp_scope = None; scopes = []; impls = impl_env}, []) binders in (lenv.impls, List.map snd bl) with InternalizationError (loc,e) -> - user_err_loc (loc,"internalize", explain_internalization_error e) + user_err ~loc ~hdr:"internalize" (explain_internalization_error e) let interp_rawcontext_evars env evdref k bl = let (env, par, _, impls) = diff --git a/interp/coqlib.ml b/interp/coqlib.ml index 588637b76..9539980f0 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -86,7 +86,7 @@ let check_required_library d = (Loc.ghost,make_qualid (DirPath.make (List.rev prefix)) m) *) (* or failing ...*) - errorlabstrm "Coqlib.check_required_library" + user_err ~hdr:"Coqlib.check_required_library" (str "Library " ++ pr_dirpath dir ++ str " has to be required first.") (************************************************************************) diff --git a/interp/genintern.ml b/interp/genintern.ml index d6bfd347f..be7abfa99 100644 --- a/interp/genintern.ml +++ b/interp/genintern.ml @@ -16,6 +16,7 @@ type glob_sign = { type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb type 'glb subst_fun = substitution -> 'glb -> 'glb +type 'glb ntn_subst_fun = Tactypes.glob_constr_and_expr Id.Map.t -> 'glb -> 'glb module InternObj = struct @@ -31,8 +32,16 @@ struct let default _ = None end +module NtnSubstObj = +struct + type ('raw, 'glb, 'top) obj = 'glb ntn_subst_fun + let name = "notation_subst" + let default _ = None +end + module Intern = Register (InternObj) module Subst = Register (SubstObj) +module NtnSubst = Register (NtnSubstObj) let intern = Intern.obj let register_intern0 = Intern.register0 @@ -50,3 +59,12 @@ let generic_substitute subs (GenArg (Glbwit wit, v)) = in_gen (glbwit wit) (substitute wit subs v) let () = Hook.set Detyping.subst_genarg_hook generic_substitute + +(** Notation substitution *) + +let substitute_notation = NtnSubst.obj +let register_ntn_subst0 = NtnSubst.register0 + +let generic_substitute_notation env (GenArg (Glbwit wit, v)) = + let v = substitute_notation wit env v in + in_gen (glbwit wit) v diff --git a/interp/genintern.mli b/interp/genintern.mli index 4b244b38d..4b0354be3 100644 --- a/interp/genintern.mli +++ b/interp/genintern.mli @@ -32,6 +32,14 @@ val substitute : ('raw, 'glb, 'top) genarg_type -> 'glb subst_fun val generic_substitute : glob_generic_argument subst_fun +(** {5 Notation functions} *) + +type 'glb ntn_subst_fun = Tactypes.glob_constr_and_expr Id.Map.t -> 'glb -> 'glb + +val substitute_notation : ('raw, 'glb, 'top) genarg_type -> 'glb ntn_subst_fun + +val generic_substitute_notation : glob_generic_argument ntn_subst_fun + (** Registering functions *) val register_intern0 : ('raw, 'glb, 'top) genarg_type -> @@ -39,3 +47,6 @@ val register_intern0 : ('raw, 'glb, 'top) genarg_type -> val register_subst0 : ('raw, 'glb, 'top) genarg_type -> 'glb subst_fun -> unit + +val register_ntn_subst0 : ('raw, 'glb, 'top) genarg_type -> + 'glb ntn_subst_fun -> unit diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 10cfbe58f..77a8ed680 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -21,18 +21,20 @@ open Libobject open Nameops open Misctypes open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration (*i*) let generalizable_table = Summary.ref Id.Pred.empty ~name:"generalizable-ident" let declare_generalizable_ident table (loc,id) = if not (Id.equal id (root_of_id id)) then - user_err_loc(loc,"declare_generalizable_ident", - (pr_id id ++ str + user_err ~loc ~hdr:"declare_generalizable_ident" + ((pr_id id ++ str " is not declarable as generalizable identifier: it must have no trailing digits, quote, or _")); if Id.Pred.mem id table then - user_err_loc(loc,"declare_generalizable_ident", - (pr_id id++str" is already declared as a generalizable identifier")) + user_err ~loc ~hdr:"declare_generalizable_ident" + ((pr_id id++str" is already declared as a generalizable identifier")) else Id.Pred.add id table let add_generalizable gen table = @@ -78,8 +80,8 @@ let is_freevar ids env x = (* Auxiliary functions for the inference of implicitly quantified variables. *) let ungeneralizable loc id = - user_err_loc (loc, "Generalization", - str "Unbound and ungeneralizable variable " ++ pr_id id) + user_err ~loc ~hdr:"Generalization" + (str "Unbound and ungeneralizable variable " ++ pr_id id) let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = let found loc id bdvars l = @@ -186,7 +188,7 @@ let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.emp vars let rec make_fresh ids env x = - if is_freevar ids env x then x else make_fresh ids env (Nameops.lift_subscript x) + if is_freevar ids env x then x else make_fresh ids env (Nameops.increment_subscript x) let next_name_away_from na avoid = match na with @@ -198,12 +200,12 @@ let combine_params avoid fn applied needed = List.partition (function (t, Some (loc, ExplByName id)) -> - let is_id (_, decl) = match get_name decl with + let is_id (_, decl) = match RelDecl.get_name decl with | Name id' -> Id.equal id id' | Anonymous -> false in if not (List.exists is_id needed) then - user_err_loc (loc,"",str "Wrong argument name: " ++ Nameops.pr_id id); + user_err ~loc (str "Wrong argument name: " ++ Nameops.pr_id id); true | _ -> false) applied in @@ -237,12 +239,12 @@ let combine_params avoid fn applied needed = aux (t' :: ids) avoid' app need | (x,_) :: _, [] -> - user_err_loc (Constrexpr_ops.constr_loc x,"",str "Typeclass does not expect more arguments") + user_err ~loc:(Constrexpr_ops.constr_loc x) (str "Typeclass does not expect more arguments") in aux [] avoid applied needed let combine_params_freevar = fun avoid (_, decl) -> - let id' = next_name_away_from (get_name decl) avoid in + let id' = next_name_away_from (RelDecl.get_name decl) avoid in (CRef (Ident (Loc.ghost, id'),None), Id.Set.add id' avoid) let destClassApp cl = diff --git a/interp/interp.mllib b/interp/interp.mllib index 96b52959a..607af82a0 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -1,5 +1,4 @@ Stdarg -Constrarg Genintern Constrexpr_ops Notation_ops diff --git a/interp/modintern.ml b/interp/modintern.ml index e5dce5ccf..d4ade7058 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -26,16 +26,16 @@ let error_not_a_module_loc kind loc qid = | ModType -> Modops.ModuleTypingError (Modops.NotAModuleType s) | ModAny -> ModuleInternalizationError (NotAModuleNorModtype s) in - Loc.raise loc e + Loc.raise ~loc e let error_application_to_not_path loc me = - Loc.raise loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me)) + Loc.raise ~loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me)) let error_incorrect_with_in_module loc = - Loc.raise loc (ModuleInternalizationError IncorrectWithInModule) + Loc.raise ~loc (ModuleInternalizationError IncorrectWithInModule) let error_application_to_module_type loc = - Loc.raise loc (ModuleInternalizationError IncorrectModuleApplication) + Loc.raise ~loc (ModuleInternalizationError IncorrectModuleApplication) (** Searching for a module name in the Nametab. diff --git a/interp/notation.ml b/interp/notation.ml index 389a1c9df..948d624a2 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -20,6 +20,9 @@ open Notation_term open Glob_term open Glob_ops open Ppextend +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (*i*) (*s A scope is a set of notations; it includes @@ -95,7 +98,7 @@ let declare_scope scope = scope_map := String.Map.add scope empty_scope !scope_map let error_unknown_scope sc = - errorlabstrm "Notation" + user_err ~hdr:"Notation" (str "Scope " ++ str sc ++ str " is not declared.") let find_scope scope = @@ -208,7 +211,7 @@ let remove_delimiters scope = let sc = find_scope scope in let newsc = { sc with delimiters = None } in match sc.delimiters with - | None -> CErrors.errorlabstrm "" (str "No bound key for scope " ++ str scope ++ str ".") + | None -> CErrors.user_err (str "No bound key for scope " ++ str scope ++ str ".") | Some key -> scope_map := String.Map.add scope newsc !scope_map; try @@ -220,8 +223,8 @@ let remove_delimiters scope = let find_delimiters_scope loc key = try String.Map.find key !delimiters_map with Not_found -> - user_err_loc - (loc, "find_delimiters", str "Unknown scope delimiting key " ++ str key ++ str ".") + user_err ~loc ~hdr:"find_delimiters" + (str "Unknown scope delimiting key " ++ str key ++ str ".") (* Uninterpretation tables *) @@ -337,8 +340,8 @@ let declare_string_interpreter sc dir interp (patl,uninterp,inpat) = let check_required_module loc sc (sp,d) = try let _ = Nametab.global_of_path sp in () with Not_found -> - user_err_loc (loc,"prim_token_interpreter", - str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") + user_err ~loc ~hdr:"prim_token_interpreter" + (str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") (* Look if some notation or numeral printer in [scope] can be used in the scope stack [scopes], and if yes, using delimiters or not *) @@ -458,8 +461,8 @@ let interp_prim_token_gen g loc p local_scopes = let p_as_ntn = try notation_of_prim_token p with Not_found -> "" in try find_interpretation p_as_ntn (find_prim_token g loc p) scopes with Not_found -> - user_err_loc (loc,"interp_prim_token", - (match p with + user_err ~loc ~hdr:"interp_prim_token" + ((match p with | Numeral n -> str "No interpretation for numeral " ++ str (to_string n) | String s -> str "No interpretation for string " ++ qs s) ++ str ".") @@ -483,8 +486,8 @@ let interp_notation loc ntn local_scopes = let scopes = make_current_scopes local_scopes in try find_interpretation ntn (find_notation ntn) scopes with Not_found -> - user_err_loc - (loc,"",str "Unknown interpretation for notation \"" ++ str ntn ++ str "\".") + user_err ~loc + (str "Unknown interpretation for notation \"" ++ str ntn ++ str "\".") let uninterp_notations c = List.map_append (fun key -> keymap_find key !notations_key_table) @@ -684,7 +687,7 @@ let discharge_arguments_scope (_,(req,r,n,l,_)) = let n = try let vars = Lib.variable_section_segment_of_reference r in - List.length (List.filter (fun (_,_,b,_) -> b = None) vars) + vars |> List.map fst |> List.filter is_local_assum |> List.length with Not_found (* Not a ref defined in this section *) -> 0 in Some (req,Lib.discharge_global r,n,l,[]) @@ -888,11 +891,11 @@ let global_reference_of_notation test (ntn,(sc,c,_)) = | _ -> None let error_ambiguous_notation loc _ntn = - user_err_loc (loc,"",str "Ambiguous notation.") + user_err ~loc (str "Ambiguous notation.") let error_notation_not_reference loc ntn = - user_err_loc (loc,"", - str "Unable to interpret " ++ quote (str ntn) ++ + user_err ~loc + (str "Unable to interpret " ++ quote (str ntn) ++ str " as a reference.") let interp_notation_as_global_reference loc test ntn sc = @@ -1018,8 +1021,8 @@ let add_notation_extra_printing_rule ntn k v = let p, pp, gr = String.Map.find ntn !notation_rules in String.Map.add ntn (p, (k,v) :: pp, gr) !notation_rules with Not_found -> - user_err_loc (Loc.ghost,"add_notation_extra_printing_rule", - str "No such Notation.") + user_err ~hdr:"add_notation_extra_printing_rule" + (str "No such Notation.") (**********************************************************************) (* Synchronisation with reset *) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 7b520c1c1..d7f283e95 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -242,8 +242,8 @@ let split_at_recursive_part c = let subtract_loc loc1 loc2 = Loc.make_loc (fst (Loc.unloc loc1),fst (Loc.unloc loc2)-1) let check_is_hole id = function GHole _ -> () | t -> - user_err_loc (loc_of_glob_constr t,"", - strbrk "In recursive notation with binders, " ++ pr_id id ++ + user_err ~loc:(loc_of_glob_constr t) + (strbrk "In recursive notation with binders, " ++ pr_id id ++ strbrk " is expected to come without type.") let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b' @@ -292,8 +292,8 @@ let compare_recursive_parts found f f' (iterator,subc) = let loc1 = loc_of_glob_constr iterator in let loc2 = loc_of_glob_constr (Option.get !terminator) in (* Here, we would need a loc made of several parts ... *) - user_err_loc (subtract_loc loc1 loc2,"", - str "Both ends of the recursive pattern are the same.") + user_err ~loc:(subtract_loc loc1 loc2) + (str "Both ends of the recursive pattern are the same.") | Some (x,y,Some lassoc) -> let newfound,x,y,lassoc = if List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi2 !found) || @@ -334,8 +334,8 @@ let notation_constr_and_vars_of_glob_constr a = | GApp (_,GVar (loc,f),[c]) when Id.equal f ldots_var -> (* Fall on the second part of the recursive pattern w/o having found the first part *) - user_err_loc (loc,"", - str "Cannot find where the recursive pattern starts.") + user_err ~loc + (str "Cannot find where the recursive pattern starts.") | c -> aux' c and aux' = function @@ -390,7 +390,7 @@ let check_variables_and_reversibility nenv (found,foundrec,foundrecbinding) = let vars = Id.Map.filter filter nenv.ninterp_var_type in let check_recvar x = if Id.List.mem x found then - errorlabstrm "" (pr_id x ++ + user_err (pr_id x ++ strbrk " should only be used in the recursive part of a pattern.") in let check (x, y) = check_recvar x; check_recvar y in let () = List.iter check foundrec in @@ -409,7 +409,7 @@ let check_variables_and_reversibility nenv (found,foundrec,foundrecbinding) = in let check_pair s x y where = if not (List.mem_f (pair_equal Id.equal Id.equal) (x,y) where) then - errorlabstrm "" (strbrk "in the right-hand side, " ++ pr_id x ++ + user_err (strbrk "in the right-hand side, " ++ pr_id x ++ str " and " ++ pr_id y ++ strbrk " should appear in " ++ str s ++ str " position as part of a recursive pattern.") in let check_type x typ = diff --git a/interp/reserve.ml b/interp/reserve.ml index 388ca0805..a4d4f4027 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -86,13 +86,13 @@ let in_reserved : Id.t * notation_constr -> obj = let declare_reserved_type_binding (loc,id) t = if not (Id.equal id (root_of_id id)) then - user_err_loc(loc,"declare_reserved_type", - (pr_id id ++ str + user_err ~loc ~hdr:"declare_reserved_type" + ((pr_id id ++ str " is not reservable: it must have no trailing digits, quote, or _")); begin try let _ = Id.Map.find id !reserve_table in - user_err_loc(loc,"declare_reserved_type", - (pr_id id++str" is already bound to a type")) + user_err ~loc ~hdr:"declare_reserved_type" + ((pr_id id++str" is already bound to a type")) with Not_found -> () end; add_anonymous_leaf (in_reserved (id,t)) diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 478774219..178c1c1f9 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -46,7 +46,7 @@ let locate_global_with_alias ?(head=false) (loc,qid) = if head then global_of_extended_global_head ref else global_of_extended_global ref with Not_found -> - user_err_loc (loc,"",pr_qualid qid ++ + user_err ~loc (pr_qualid qid ++ str " is bound to a notation that does not denote a reference.") let global_inductive_with_alias r = @@ -54,14 +54,14 @@ let global_inductive_with_alias r = try match locate_global_with_alias lqid with | IndRef ind -> ind | ref -> - user_err_loc (loc_of_reference r,"global_inductive", - pr_reference r ++ spc () ++ str "is not an inductive type.") - with Not_found -> Nametab.error_global_not_found_loc loc qid + user_err ~loc:(loc_of_reference r) ~hdr:"global_inductive" + (pr_reference r ++ spc () ++ str "is not an inductive type.") + with Not_found -> Nametab.error_global_not_found ~loc qid let global_with_alias ?head r = let (loc,qid as lqid) = qualid_of_reference r in try locate_global_with_alias ?head lqid - with Not_found -> Nametab.error_global_not_found_loc loc qid + with Not_found -> Nametab.error_global_not_found ~loc qid let smart_global ?head = function | AN r -> diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 2a7d52e3a..341ff5662 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -6,6 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Loc +open Misctypes +open Tactypes open Genarg open Geninterp @@ -29,7 +32,49 @@ let wit_string : string uniform_genarg_type = let wit_pre_ident : string uniform_genarg_type = make0 ~dyn:(val_tag (topwit wit_string)) "preident" +let loc_of_or_by_notation f = function + | AN c -> f c + | ByNotation (loc,s,_) -> loc + +let wit_int_or_var = + make0 ~dyn:(val_tag (topwit wit_int)) "int_or_var" + +let wit_intro_pattern = + make0 "intropattern" + +let wit_ident = + make0 "ident" + +let wit_var = + make0 ~dyn:(val_tag (topwit wit_ident)) "var" + +let wit_ref = make0 "ref" + +let wit_quant_hyp = make0 "quant_hyp" + +let wit_constr = + make0 "constr" + +let wit_uconstr = make0 "uconstr" + +let wit_open_constr = make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr" + +let wit_constr_with_bindings = make0 "constr_with_bindings" + +let wit_bindings = make0 "bindings" + +let wit_red_expr = make0 "redexpr" + +let wit_clause_dft_concl = + make0 "clause_dft_concl" + (** Aliases for compatibility *) let wit_integer = wit_int let wit_preident = wit_pre_ident +let wit_reference = wit_ref +let wit_global = wit_ref +let wit_clause = wit_clause_dft_concl +let wit_quantified_hypothesis = wit_quant_hyp +let wit_intropattern = wit_intro_pattern +let wit_redexpr = wit_red_expr diff --git a/interp/stdarg.mli b/interp/stdarg.mli index e1f648d7f..af3a73462 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -8,8 +8,21 @@ (** Basic generic arguments. *) +open Loc +open Names +open Term +open Libnames +open Globnames +open Genredexpr +open Pattern +open Constrexpr +open Misctypes +open Tactypes open Genarg +(** FIXME: nothing to do there. *) +val loc_of_or_by_notation : ('a -> Loc.t) -> 'a or_by_notation -> Loc.t + val wit_unit : unit uniform_genarg_type val wit_bool : bool uniform_genarg_type @@ -20,7 +33,54 @@ val wit_string : string uniform_genarg_type val wit_pre_ident : string uniform_genarg_type +(** {5 Additional generic arguments} *) + +val wit_int_or_var : (int or_var, int or_var, int) genarg_type + +val wit_intro_pattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type + +val wit_ident : Id.t uniform_genarg_type + +val wit_var : (Id.t located, Id.t located, Id.t) genarg_type + +val wit_ref : (reference, global_reference located or_var, global_reference) genarg_type + +val wit_quant_hyp : quantified_hypothesis uniform_genarg_type + +val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type + +val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type + +val wit_open_constr : + (constr_expr, glob_constr_and_expr, constr) genarg_type + +val wit_constr_with_bindings : + (constr_expr with_bindings, + glob_constr_and_expr with_bindings, + constr with_bindings delayed_open) genarg_type + +val wit_bindings : + (constr_expr bindings, + glob_constr_and_expr bindings, + constr bindings delayed_open) genarg_type + +val wit_red_expr : + ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, + (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, + (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type + +val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type + (** Aliases for compatibility *) val wit_integer : int uniform_genarg_type val wit_preident : string uniform_genarg_type +val wit_reference : (reference, global_reference located or_var, global_reference) genarg_type +val wit_global : (reference, global_reference located or_var, global_reference) genarg_type +val wit_clause : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type +val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type +val wit_intropattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type +val wit_redexpr : + ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, + (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, + (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 2523063e6..c3f4c4f30 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -30,7 +30,7 @@ let add_syntax_constant kn c onlyparse = let load_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = if Nametab.exists_cci sp then - errorlabstrm "cache_syntax_constant" + user_err ~hdr:"cache_syntax_constant" (pr_id (basename sp) ++ str " already exists"); add_syntax_constant kn pat onlyparse; Nametab.push_syndef (Nametab.Until i) sp kn diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 79eeacf35..b455381ea 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -31,8 +31,8 @@ let _ = Goptions.declare_bool_option { (**********************************************************************) (* Miscellaneous *) -let error_invalid_pattern_notation loc = - user_err_loc (loc,"",str "Invalid notation for pattern.") +let error_invalid_pattern_notation ?loc () = + user_err ?loc (str "Invalid notation for pattern.") (**********************************************************************) (* Functions on constr_expr *) @@ -174,8 +174,8 @@ let split_at_annot bl na = | LocalRawDef _ as x :: rest -> aux (x :: acc) rest | LocalPattern _ :: rest -> assert false | [] -> - user_err_loc(loc,"", - str "No parameter named " ++ Nameops.pr_id id ++ str".") + user_err ~loc + (str "No parameter named " ++ Nameops.pr_id id ++ str".") in aux [] bl (* Used in correctness and interface *) diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 58edd4ddf..95d702f8d 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -46,4 +46,4 @@ val patntn_loc : (** For cases pattern parsing errors *) -val error_invalid_pattern_notation : Loc.t -> 'a +val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a diff --git a/intf/genredexpr.mli b/intf/genredexpr.mli index 2df79673a..16f0c0c92 100644 --- a/intf/genredexpr.mli +++ b/intf/genredexpr.mli @@ -8,6 +8,8 @@ (** Reduction expressions *) +open Names + (** The parsing produces initially a list of [red_atom] *) type 'a red_atom = @@ -50,5 +52,15 @@ type ('a,'b,'c) red_expr_gen = type ('a,'b,'c) may_eval = | ConstrTerm of 'a | ConstrEval of ('a,'b,'c) red_expr_gen * 'a - | ConstrContext of (Loc.t * Names.Id.t) * 'a + | ConstrContext of (Loc.t * Id.t) * 'a | ConstrTypeOf of 'a + +open Libnames +open Constrexpr +open Misctypes + +type r_trm = constr_expr +type r_pat = constr_pattern_expr +type r_cst = reference or_by_notation + +type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen diff --git a/intf/misctypes.mli b/intf/misctypes.mli index 1452bbc34..e4f595ac4 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -108,3 +108,31 @@ type 'a or_by_notation = (** Kinds of modules *) type module_kind = Module | ModType | ModAny + +(** Various flags *) + +type direction_flag = bool (* true = Left-to-right false = right-to-right *) +type evars_flag = bool (* true = pose evars false = fail on evars *) +type rec_flag = bool (* true = recursive false = not recursive *) +type advanced_flag = bool (* true = advanced false = basic *) +type letin_flag = bool (* true = use local def false = use Leibniz *) +type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) + +type multi = + | Precisely of int + | UpTo of int + | RepeatStar + | RepeatPlus + +type 'a core_destruction_arg = + | ElimOnConstr of 'a + | ElimOnIdent of Id.t Loc.located + | ElimOnAnonHyp of int + +type 'a destruction_arg = + clear_flag * 'a core_destruction_arg + +type inversion_kind = + | SimpleInversion + | FullInversion + | FullInversionClear diff --git a/intf/tactypes.mli b/intf/tactypes.mli new file mode 100644 index 000000000..b96cb67df --- /dev/null +++ b/intf/tactypes.mli @@ -0,0 +1,35 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Tactic-related types that are not totally Ltac specific and still used in + lower API. It's not clear whether this is a temporary API or if this is + meant to stay. *) + +open Loc +open Names +open Constrexpr +open Glob_term +open Pattern +open Misctypes + +(** In globalize tactics, we need to keep the initial [constr_expr] to recompute + in the environment by the effective calls to Intro, Inversion, etc + The [constr_expr] field is [None] in TacDef though *) +type glob_constr_and_expr = Glob_term.glob_constr * constr_expr option +type glob_constr_pattern_and_expr = Id.Set.t * glob_constr_and_expr * constr_pattern + +type 'a delayed_open = + { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } + +type delayed_open_constr = Term.constr delayed_open +type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open + +type intro_pattern = delayed_open_constr intro_pattern_expr located +type intro_patterns = delayed_open_constr intro_pattern_expr located list +type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr located +type intro_pattern_naming = intro_pattern_naming_expr located diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 857287040..7424fd85a 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -8,7 +8,6 @@ open Loc open Names -open Tacexpr open Misctypes open Constrexpr open Decl_kinds @@ -27,7 +26,7 @@ type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation to print a goal that is out of focus (or already solved) it doesn't make sense to apply a tactic to it. Hence it the types may look very similar, they do not seem to mean the same thing. *) -type goal_selector = Tacexpr.goal_selector = +type goal_selector = | SelectNth of int | SelectList of (int * int) list | SelectId of Id.t @@ -130,7 +129,7 @@ type hints_expr = | HintsTransparency of reference list * bool | HintsMode of reference * hint_mode list | HintsConstructors of reference list - | HintsExtern of int * constr_expr option * raw_tactic_expr + | HintsExtern of int * constr_expr option * Genarg.raw_generic_argument type search_restriction = | SearchInside of reference list @@ -171,7 +170,7 @@ type sort_expr = glob_sort type definition_expr = | ProveBody of local_binder list * constr_expr - | DefineBody of local_binder list * raw_red_expr option * constr_expr + | DefineBody of local_binder list * Genredexpr.raw_red_expr option * constr_expr * constr_expr option type fixpoint_expr = @@ -434,9 +433,9 @@ type vernac_expr = | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list | VernacPrintOption of Goptions.option_name - | VernacCheckMayEval of raw_red_expr option * int option * constr_expr + | VernacCheckMayEval of Genredexpr.raw_red_expr option * int option * constr_expr | VernacGlobalCheck of constr_expr - | VernacDeclareReduction of string * raw_red_expr + | VernacDeclareReduction of string * Genredexpr.raw_red_expr | VernacPrint of printable | VernacSearch of searchable * int option * search_restriction | VernacLocate of locatable @@ -462,7 +461,7 @@ type vernac_expr = | VernacEndSubproof | VernacShow of showable | VernacCheckGuard - | VernacProof of raw_tactic_expr option * section_subset_expr option + | VernacProof of Genarg.raw_generic_argument option * section_subset_expr option | VernacProofMode of string (* Toplevel control *) | VernacToplevelControl of exn @@ -475,10 +474,6 @@ type vernac_expr = | VernacPolymorphic of bool * vernac_expr | VernacLocal of bool * vernac_expr -and tacdef_body = - | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) - | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) - and vernac_argument_status = { name : Name.t; recarg_like : bool; diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 7d08f9e2d..2fe917eca 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -903,7 +903,7 @@ let compile fail_on_error ?universes:(universes=0) env c = Feedback.msg_debug (dump_bytecodes init_code !fun_code fv)) ; Some (init_code,!fun_code, Array.of_list fv) with TooLargeInductive tname -> - let fn = if fail_on_error then CErrors.errorlabstrm "compile" else + let fn = if fail_on_error then CErrors.user_err ?loc:None ~hdr:"compile" else (fun x -> Feedback.msg_warning x) in (Pp.(fn (str "Cannot compile code for virtual machine as it uses inductive " ++ diff --git a/kernel/context.ml b/kernel/context.ml index 4e53b73a2..ae0388003 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -138,7 +138,7 @@ struct | LocalDef (_,v,ty) -> f v; f ty (** Reduce all terms in a given declaration to a single value. *) - let fold f decl acc = + let fold_constr f decl acc = match decl with | LocalAssum (n,ty) -> f ty acc | LocalDef (n,v,ty) -> f ty (f v acc) @@ -147,9 +147,6 @@ struct | LocalAssum (na, ty) -> na, None, ty | LocalDef (na, v, ty) -> na, Some v, ty - let of_tuple = function - | n, None, ty -> LocalAssum (n,ty) - | n, Some v, ty -> LocalDef (n,v,ty) end (** Rel-context is represented as a list of declarations. @@ -336,7 +333,7 @@ struct | LocalDef (_, v, ty) -> f v; f ty (** Reduce all terms in a given declaration to a single value. *) - let fold f decl a = + let fold_constr f decl a = match decl with | LocalAssum (_, ty) -> f ty a | LocalDef (_, v, ty) -> a |> f v |> f ty @@ -348,6 +345,18 @@ struct let of_tuple = function | id, None, ty -> LocalAssum (id, ty) | id, Some v, ty -> LocalDef (id, v, ty) + + let of_rel_decl f = function + | Rel.Declaration.LocalAssum (na,t) -> + LocalAssum (f na, t) + | Rel.Declaration.LocalDef (na,v,t) -> + LocalDef (f na, v, t) + + let to_rel_decl = function + | LocalAssum (id,t) -> + Rel.Declaration.LocalAssum (Name id, t) + | LocalDef (id,v,t) -> + Rel.Declaration.LocalDef (Name id,v,t) end (** Named-context is represented as a list of declarations. @@ -401,23 +410,39 @@ struct | _ -> None in List.map_filter filter - end +end -module NamedList = +module Compacted = struct module Declaration = struct - type t = Id.t list * Constr.t option * Constr.t - - let map_constr f (ids, copt, ty as decl) = - let copt' = Option.map f copt in - let ty' = f ty in - if copt == copt' && ty == ty' then decl else (ids, copt', ty') + type t = + | LocalAssum of Id.t list * Constr.t + | LocalDef of Id.t list * Constr.t * Constr.t + + let map_constr f = function + | LocalAssum (ids, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (ids, ty') + | LocalDef (ids, c, ty) as decl -> + let ty' = f ty in + let c' = f c in + if c == c' && ty == ty' then decl else LocalDef (ids,c',ty') + + let of_named_decl = function + | Named.Declaration.LocalAssum (id,t) -> + LocalAssum ([id],t) + | Named.Declaration.LocalDef (id,v,t) -> + LocalDef ([id],v,t) + + let to_named_context = function + | LocalAssum (ids, t) -> + List.map (fun id -> Named.Declaration.LocalAssum (id,t)) ids + | LocalDef (ids, v, t) -> + List.map (fun id -> Named.Declaration.LocalDef (id,v,t)) ids end type t = Declaration.t list let fold f l ~init = List.fold_right f l init end - -type section_context = Named.t diff --git a/kernel/context.mli b/kernel/context.mli index b5f3904d2..955e214cb 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -79,10 +79,9 @@ sig val iter_constr : (Constr.t -> unit) -> t -> unit (** Reduce all terms in a given declaration to a single value. *) - val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a + val fold_constr : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a val to_tuple : t -> Name.t * Constr.t option * Constr.t - val of_tuple : Name.t * Constr.t option * Constr.t -> t end (** Rel-context is represented as a list of declarations. @@ -193,10 +192,18 @@ sig val iter_constr : (Constr.t -> unit) -> t -> unit (** Reduce all terms in a given declaration to a single value. *) - val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a + val fold_constr : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a val to_tuple : t -> Id.t * Constr.t option * Constr.t val of_tuple : Id.t * Constr.t option * Constr.t -> t + + (** Convert [Rel.Declaration.t] value to the corresponding [Named.Declaration.t] value. + The function provided as the first parameter determines how to translate "names" to "ids". *) + val of_rel_decl : (Name.t -> Id.t) -> Rel.Declaration.t -> t + + (** Convert [Named.Declaration.t] value to the corresponding [Rel.Declaration.t] value. *) + (* TODO: Move this function to [Rel.Declaration] module and rename it to [of_named]. *) + val to_rel_decl : t -> Rel.Declaration.t end (** Rel-context is represented as a list of declarations. @@ -244,17 +251,20 @@ sig val to_instance : t -> Constr.t list end -module NamedList : +module Compacted : sig module Declaration : sig - type t = Id.t list * Constr.t option * Constr.t + type t = + | LocalAssum of Id.t list * Constr.t + | LocalDef of Id.t list * Constr.t * Constr.t + val map_constr : (Constr.t -> Constr.t) -> t -> t + val of_named_decl : Named.Declaration.t -> t + val to_named_context : t -> Named.t end type t = Declaration.t list val fold : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a end - -type section_context = Named.t diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 134599150..f5059cd75 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -21,6 +21,8 @@ open Declarations open Environ open Univ +module NamedDecl = Context.Named.Declaration + (*s Cooking the constants. *) let pop_dirpath p = match DirPath.repr p with @@ -152,7 +154,7 @@ type inline = bool type result = constant_def * constant_type * projection_body option * bool * constant_universes * inline - * Context.section_context option + * Context.Named.t option let on_body ml hy f = function | Undef _ as x -> x @@ -202,8 +204,7 @@ let cook_constant env { from = cb; info } = in let const_hyps = Context.Named.fold_outside (fun decl hyps -> - let open Context.Named.Declaration in - List.filter (fun decl' -> not (Id.equal (get_id decl) (get_id decl'))) + List.filter (fun decl' -> not (Id.equal (NamedDecl.get_id decl) (NamedDecl.get_id decl'))) hyps) hyps ~init:cb.const_hyps in let typ = match cb.const_type with diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 327e697d2..eb4073096 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -19,7 +19,7 @@ type inline = bool type result = constant_def * constant_type * projection_body option * bool * constant_universes * inline - * Context.section_context option + * Context.Named.t option val cook_constant : env -> recipe -> result val cook_constr : Opaqueproof.cooking_info -> Term.constr -> Term.constr diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index c27cb0487..40595f944 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -22,6 +22,8 @@ open Declarations open Pre_env open Cbytegen +module NamedDecl = Context.Named.Declaration +module RelDecl = Context.Rel.Declaration external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code" external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" @@ -189,18 +191,14 @@ and slot_for_fv env fv = let nv = Pre_env.lookup_named_val id env in begin match force_lazy_val nv with | None -> - let open Context.Named in - let open Declaration in - env |> Pre_env.lookup_named id |> get_value |> fill_fv_cache nv id val_of_named idfun + env |> Pre_env.lookup_named id |> NamedDecl.get_value |> fill_fv_cache nv id val_of_named idfun | Some (v, _) -> v end | FVrel i -> let rv = Pre_env.lookup_rel_val i env in begin match force_lazy_val rv with | None -> - let open Context.Rel in - let open Declaration in - env.env_rel_context |> lookup i |> get_value |> fill_fv_cache rv i val_of_rel env_of_rel + env.env_rel_context |> Context.Rel.lookup i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel | Some (v, _) -> v end | FVuniv_var idu -> diff --git a/kernel/declarations.mli b/kernel/declarations.mli index f89773fcc..fe2fa6d7f 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -78,7 +78,7 @@ type typing_flags = { (* some contraints are in constant_constraints, some other may be in * the OpaueDef *) type constant_body = { - const_hyps : Context.section_context; (** New: younger hyp at top *) + const_hyps : Context.Named.t; (** New: younger hyp at top *) const_body : constant_def; const_type : constant_type; const_body_code : Cemitcodes.to_patch_substituted option; @@ -177,7 +177,7 @@ type mutual_inductive_body = { mind_ntypes : int; (** Number of types in the block *) - mind_hyps : Context.section_context; (** Section hypotheses on which the block depends *) + mind_hyps : Context.Named.t; (** Section hypotheses on which the block depends *) mind_nparams : int; (** Number of expected parameters including non-uniform ones (i.e. length of mind_params_ctxt w/o let-in) *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 211e5e062..0a822d6fa 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -9,7 +9,8 @@ open Declarations open Mod_subst open Util -open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration (** Operations concernings types in [Declarations] : [constant_body], [mutual_inductive_body], [module_body] ... *) @@ -94,7 +95,7 @@ let is_opaque cb = match cb.const_body with (** {7 Constant substitutions } *) let subst_rel_declaration sub = - map_constr (subst_mps sub) + RelDecl.map_constr (subst_mps sub) let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) @@ -146,7 +147,7 @@ let subst_const_body sub cb = themselves. But would it really bring substantial gains ? *) let hcons_rel_decl = - map_type Term.hcons_types % map_value Term.hcons_constr % map_name Names.Name.hcons + RelDecl.map_name Names.Name.hcons %> RelDecl.map_value Term.hcons_constr %> RelDecl.map_type Term.hcons_types let hcons_rel_context l = List.smartmap hcons_rel_decl l diff --git a/kernel/entries.mli b/kernel/entries.mli index ea7c266bc..77081947e 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -61,7 +61,7 @@ type 'a const_entry_body = 'a proof_output Future.computation type 'a definition_entry = { const_entry_body : 'a const_entry_body; (* List of section variables *) - const_entry_secctx : Context.section_context option; + const_entry_secctx : Context.Named.t option; (* State id on which the completion of type checking is reported *) const_entry_feedback : Stateid.t option; const_entry_type : types option; @@ -73,7 +73,7 @@ type 'a definition_entry = { type inline = int option (* inlining level, None for no inlining *) type parameter_entry = - Context.section_context option * bool * types Univ.in_universe_context * inline + Context.Named.t option * bool * types Univ.in_universe_context * inline type projection_entry = { proj_entry_ind : mutual_inductive; diff --git a/kernel/environ.ml b/kernel/environ.ml index 16ddfac64..4a543f195 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -413,7 +413,7 @@ let global_vars_set env constr = Id.Set.union (vars_of_global env c) acc | _ -> acc in - fold_constr filtrec acc c + Term.fold_constr filtrec acc c in filtrec Id.Set.empty constr diff --git a/kernel/environ.mli b/kernel/environ.mli index 6ac00088b..ea570cb4a 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -231,7 +231,7 @@ val vars_of_global : env -> constr -> Id.Set.t val really_needed : env -> Id.Set.t -> Id.Set.t (** like [really_needed] but computes a well ordered named context *) -val keep_hyps : env -> Id.Set.t -> Context.section_context +val keep_hyps : env -> Id.Set.t -> Context.Named.t (** {5 Unsafe judgments. } We introduce here the pre-type of judgments, which is diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml index bd91c689d..dce4e9307 100644 --- a/kernel/fast_typeops.ml +++ b/kernel/fast_typeops.ml @@ -18,6 +18,9 @@ open Reduction open Inductive open Type_errors +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y let conv_leq_vecti env v1 v2 = @@ -73,8 +76,7 @@ let judge_of_type u = let judge_of_relative env n = try - let open Context.Rel.Declaration in - env |> lookup_rel n |> get_type |> lift n + env |> lookup_rel n |> RelDecl.get_type |> lift n with Not_found -> error_unbound_rel env n @@ -92,9 +94,8 @@ let judge_of_variable env id = let check_hyps_inclusion env f c sign = Context.Named.fold_outside (fun decl () -> - let open Context.Named.Declaration in - let id = get_id decl in - let ty1 = get_type decl in + let id = NamedDecl.get_id decl in + let ty1 = NamedDecl.get_type decl in try let ty2 = named_type id env in if not (eq_constr ty2 ty1) then raise Exit diff --git a/kernel/names.ml b/kernel/names.ml index 9267a64d6..1313bae7b 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -82,11 +82,14 @@ struct type t = Anonymous (** anonymous identifier *) | Name of Id.t (** non-anonymous identifier *) + let mk_name id = + Name id + let is_anonymous = function | Anonymous -> true | Name _ -> false - let is_name = not % is_anonymous + let is_name = is_anonymous %> not let compare n1 n2 = match n1, n2 with | Anonymous, Anonymous -> 0 diff --git a/kernel/names.mli b/kernel/names.mli index feaedc775..0af1cde8f 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -82,6 +82,9 @@ sig type t = Anonymous (** anonymous identifier *) | Name of Id.t (** non-anonymous identifier *) + val mk_name : Id.t -> t + (** constructor *) + val is_anonymous : t -> bool (** Return [true] iff a given name is [Anonymous]. *) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index eaddace4b..33bd7d8dd 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1848,10 +1848,9 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = auxdefs, MLlet(aux_name, ml, mkMLapp (MLlocal aux_name) (Array.of_list (fv_rel@fv_named))) and compile_rel env sigma univ auxdefs n = - let open Context.Rel in - let n = length env.env_rel_context - n in - let open Declaration in - match lookup n env.env_rel_context with + let n = Context.Rel.length env.env_rel_context - n in + let open Context.Rel.Declaration in + match Context.Rel.lookup n env.env_rel_context with | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 91b40be7e..366f9a0a6 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -14,6 +14,8 @@ open Pre_env open Nativevalues open Nativeinstr +module RelDecl = Context.Rel.Declaration + (** This file defines the lambda code generation phase of the native compiler *) exception NotClosed @@ -727,8 +729,7 @@ let optimize lam = let lambda_of_constr env sigma c = set_global_env env; let env = Renv.make () in - let open Context.Rel.Declaration in - let ids = List.rev_map get_name !global_env.env_rel_context in + let ids = List.rev_map RelDecl.get_name !global_env.env_rel_context in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env sigma c in (* if Flags.vm_draw_opt () then begin diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 1c58c7445..6bd82170e 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -35,7 +35,7 @@ let ( / ) = Filename.concat (* We have to delay evaluation of include_dirs because coqlib cannot be guessed until flags have been properly initialized *) let include_dirs () = - [Filename.temp_dir_name; coqlib () / "kernel"; coqlib () / "library"] + [Filename.get_temp_dir_name (); coqlib () / "kernel"; coqlib () / "library"] (* Pointer to the function linking an ML object into coq's toplevel *) let load_obj = ref (fun x -> () : string -> unit) diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 7be8606ef..72de2f1a6 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -17,7 +17,8 @@ open Util open Names open Term open Declarations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (* The type of environments. *) @@ -128,10 +129,10 @@ let env_of_rel n env = (* Named context *) let push_named_context_val_val d rval ctxt = -(* assert (not (Id.Map.mem (get_id d) ctxt.env_named_map)); *) +(* assert (not (Id.Map.mem (NamedDecl.get_id d) ctxt.env_named_map)); *) { env_named_ctx = Context.Named.add d ctxt.env_named_ctx; - env_named_map = Id.Map.add (get_id d) (d, rval) ctxt.env_named_map; + env_named_map = Id.Map.add (NamedDecl.get_id d) (d, rval) ctxt.env_named_map; } let push_named_context_val d ctxt = @@ -140,8 +141,8 @@ let push_named_context_val d ctxt = let match_named_context_val c = match c.env_named_ctx with | [] -> None | decl :: ctx -> - let (_, v) = Id.Map.find (get_id decl) c.env_named_map in - let map = Id.Map.remove (get_id decl) c.env_named_map in + let (_, v) = Id.Map.find (NamedDecl.get_id decl) c.env_named_map in + let map = Id.Map.remove (NamedDecl.get_id decl) c.env_named_map in let cval = { env_named_ctx = ctx; env_named_map = map } in Some (decl, v, cval) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 09f7bd75c..ae3679ddd 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -62,6 +62,8 @@ open Names open Declarations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + (** {6 Safe environments } Fields of [safe_environment] : @@ -361,7 +363,7 @@ let check_required current_libs needed = cost too much. *) let safe_push_named d env = - let id = get_id d in + let id = NamedDecl.get_id d in let _ = try let _ = Environ.lookup_named id env in @@ -816,7 +818,7 @@ let export ?except senv dir = try join_safe_environment ?except senv with e -> let e = CErrors.push e in - CErrors.errorlabstrm "export" (CErrors.iprint e) + CErrors.user_err ~hdr:"export" (CErrors.iprint e) in assert(senv.future_cst = []); let () = check_current_library dir senv in @@ -852,7 +854,7 @@ let import lib cst vodigest senv = check_required senv.required lib.comp_deps; check_engagement senv.env lib.comp_enga; if DirPath.equal (ModPath.dp senv.modpath) lib.comp_name then - CErrors.errorlabstrm "Safe_typing.import" + CErrors.user_err ~hdr:"Safe_typing.import" (Pp.strbrk "Cannot load a library with the same name as the current one."); let mp = MPfile lib.comp_name in let mb = lib.comp_mod in diff --git a/kernel/term.ml b/kernel/term.ml index 15f187e5c..08f888868 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -465,7 +465,7 @@ let rec to_lambda n prod = match kind_of_term prod with | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) | Cast (c,_,_) -> to_lambda n c - | _ -> errorlabstrm "to_lambda" (mt ()) + | _ -> user_err ~hdr:"to_lambda" (mt ()) let rec to_prod n lam = if Int.equal n 0 then @@ -474,7 +474,7 @@ let rec to_prod n lam = match kind_of_term lam with | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) | Cast (c,_,_) -> to_prod n c - | _ -> errorlabstrm "to_prod" (mt ()) + | _ -> user_err ~hdr:"to_prod" (mt ()) let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 749b5dbaf..d8774944e 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -22,6 +22,9 @@ open Entries open Typeops open Fast_typeops +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + let constrain_type env j poly subst = function | `None -> if not poly then (* Old-style polymorphism *) @@ -249,18 +252,17 @@ let global_vars_set_constant_type env = function | RegularArity t -> global_vars_set env t | TemplateArity (ctx,_) -> Context.Rel.fold_outside - (Context.Rel.Declaration.fold + (RelDecl.fold_constr (fun t c -> Id.Set.union (global_vars_set env t) c)) ctx ~init:Id.Set.empty let record_aux env s_ty s_bo suggested_expr = - let open Context.Named.Declaration in let in_ty = keep_hyps env s_ty in let v = String.concat " " (CList.map_filter (fun decl -> - let id = get_id decl in - if List.exists (Id.equal id % get_id) in_ty then None + let id = NamedDecl.get_id decl in + if List.exists (NamedDecl.get_id %> Id.equal id) in_ty then None else Some (Id.to_string id)) (keep_hyps env s_bo)) in Aux_file.record_in_aux "context_used" (v ^ ";" ^ suggested_expr) @@ -269,26 +271,25 @@ let suggest_proof_using = ref (fun _ _ _ _ _ -> "") let set_suggest_proof_using f = suggest_proof_using := f let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) = - let open Context.Named.Declaration in let check declared inferred = - let mk_set l = List.fold_right Id.Set.add (List.map get_id l) Id.Set.empty in + let mk_set l = List.fold_right Id.Set.add (List.map NamedDecl.get_id l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in if not (Id.Set.subset inferred_set declared_set) then let l = Id.Set.elements (Idset.diff inferred_set declared_set) in let n = List.length l in - errorlabstrm "" (Pp.(str "The following section " ++ + user_err (Pp.(str "The following section " ++ str (String.plural n "variable") ++ str " " ++ str (String.conjugate_verb_to_be n) ++ str " used but not declared:" ++ fnl () ++ pr_sequence Id.print (List.rev l) ++ str ".")) in let sort evn l = List.filter (fun decl -> - let id = get_id decl in - List.exists (Names.Id.equal id % get_id) l) + let id = NamedDecl.get_id decl in + List.exists (NamedDecl.get_id %> Names.Id.equal id) l) (named_context env) in (* We try to postpone the computation of used section variables *) let hyps, def = - let context_ids = List.map get_id (named_context env) in + let context_ids = List.map NamedDecl.get_id (named_context env) in match ctx with | None when not (List.is_empty context_ids) -> (* No declared section vars, and non-empty section context: @@ -482,8 +483,7 @@ let translate_local_def mb env id centry = | Undef _ -> () | Def _ -> () | OpaqueDef lc -> - let open Context.Named.Declaration in - let context_ids = List.map get_id (named_context env) in + let context_ids = List.map NamedDecl.get_id (named_context env) in let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Opaqueproof.force_proof (opaque_tables env) lc) in diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 0059111c0..24018ab31 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -20,6 +20,9 @@ open Inductive open Type_errors open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y let conv_leq_vecti env v1 v2 = @@ -79,7 +82,7 @@ let judge_of_type u = let judge_of_relative env n = try - let typ = get_type (lookup_rel n env) in + let typ = RelDecl.get_type (lookup_rel n env) in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> @@ -102,7 +105,7 @@ let check_hyps_inclusion env c sign = Context.Named.fold_outside (fun d1 () -> let open Context.Named.Declaration in - let id = get_id d1 in + let id = NamedDecl.get_id d1 in try let d2 = lookup_named id env in conv env (get_type d2) (get_type d1); diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 2112284ea..81fd1427d 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -127,4 +127,4 @@ val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> constant_type (** Check that hyps are included in env and fails with error otherwise *) -val check_hyps_inclusion : env -> constr -> Context.section_context -> unit +val check_hyps_inclusion : env -> constr -> Context.Named.t -> unit diff --git a/kernel/vars.ml b/kernel/vars.ml index 2ca749d50..b27e27fda 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -8,7 +8,8 @@ open Names open Esubst -open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration (*********************) (* Occurring *) @@ -160,14 +161,15 @@ let substnl laml n c = substn_many (make_subst laml) n c let substl laml c = substn_many (make_subst laml) 0 c let subst1 lam c = substn_many [|make_substituend lam|] 0 c -let substnl_decl laml k r = map_constr (fun c -> substnl laml k c) r -let substl_decl laml r = map_constr (fun c -> substnl laml 0 c) r -let subst1_decl lam r = map_constr (fun c -> subst1 lam c) r +let substnl_decl laml k r = RelDecl.map_constr (fun c -> substnl laml k c) r +let substl_decl laml r = RelDecl.map_constr (fun c -> substnl laml 0 c) r +let subst1_decl lam r = RelDecl.map_constr (fun c -> subst1 lam c) r (* Build a substitution from an instance, inserting missing let-ins *) let subst_of_rel_context_instance sign l = let rec aux subst sign l = + let open RelDecl in match sign, l with | LocalAssum _ :: sign', a::args' -> aux (a::subst) sign' args' | LocalDef (_,c,_)::sign', args' -> diff --git a/lib/cErrors.ml b/lib/cErrors.ml index c69c7e400..48a8305bc 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -26,25 +26,24 @@ let _ = let make_anomaly ?label pp = Anomaly (label, pp) -let anomaly ?loc ?label pp = match loc with - | None -> raise (Anomaly (label, pp)) - | Some loc -> Loc.raise loc (Anomaly (label, pp)) +let anomaly ?loc ?label pp = + Loc.raise ?loc (Anomaly (label, pp)) let is_anomaly = function | Anomaly _ -> true | _ -> false -exception UserError of string * std_ppcmds (* User errors *) -let error string = raise (UserError("_", str string)) -let errorlabstrm l pps = raise (UserError(l,pps)) - -exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *) -let alreadydeclared pps = raise (AlreadyDeclared(pps)) +exception UserError of string option * std_ppcmds (* User errors *) let todo s = prerr_string ("TODO: "^s^"\n") -let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm)) -let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s) +let user_err ?loc ?hdr strm = Loc.raise ?loc (UserError (hdr, strm)) +let error string = user_err (str string) + +let invalid_arg ?loc s = Loc.raise ?loc (Invalid_argument s) + +exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *) +let alreadydeclared pps = raise (AlreadyDeclared(pps)) exception Timeout exception Drop @@ -115,7 +114,7 @@ let iprint_no_report (e, info) = let _ = register_handler begin function | UserError(s, pps) -> - hov 0 (str "Error: " ++ where (Some s) ++ pps) + hov 0 (str "Error: " ++ where s ++ pps) | _ -> raise Unhandled end diff --git a/lib/cErrors.mli b/lib/cErrors.mli index e5dad93fd..5cffc725d 100644 --- a/lib/cErrors.mli +++ b/lib/cErrors.mli @@ -33,15 +33,21 @@ val is_anomaly : exn -> bool This is mostly provided for compatibility. Please avoid doing specific tricks with anomalies thanks to it. See rather [noncritical] below. *) -exception UserError of string * std_ppcmds +exception UserError of string option * std_ppcmds +(** Main error signaling exception. It carries a header plus a pretty printing + doc *) + +val user_err : ?loc:Loc.t -> ?hdr:string -> std_ppcmds -> 'a +(** Main error raising primitive. [user_err ?loc ?hdr pp] signals an + error [pp] with optional header and location [hdr] [loc] *) + val error : string -> 'a -val errorlabstrm : string -> std_ppcmds -> 'a -val user_err_loc : Loc.t * string * std_ppcmds -> 'a +(** [error s] just calls [user_error "_" (str s)] *) exception AlreadyDeclared of std_ppcmds val alreadydeclared : std_ppcmds -> 'a -val invalid_arg_loc : Loc.t * string -> 'a +val invalid_arg : ?loc:Loc.t -> string -> 'a (** [todo] is for running of an incomplete code its implementation is "do nothing" (or print a message), but this function should not be diff --git a/lib/cString.ml b/lib/cString.ml index 0c2ed2e7c..61ed03083 100644 --- a/lib/cString.ml +++ b/lib/cString.ml @@ -17,7 +17,6 @@ sig val explode : string -> string list val implode : string list -> string val strip : string -> string - val map : (char -> char) -> string -> string val drop_simple_quotes : string -> string val string_index_from : string -> int -> string -> int val string_contains : where:string -> what:string -> bool @@ -78,12 +77,6 @@ let strip s = let a = lstrip_rec 0 and b = rstrip_rec (n-1) in String.sub s a (b-a+1) -let map f s = - let l = String.length s in - let r = String.create l in - for i = 0 to (l - 1) do r.[i] <- f (s.[i]) done; - r - let drop_simple_quotes s = let n = String.length s in if n > 2 && s.[0] = '\'' && s.[n-1] = '\'' then String.sub s 1 (n-2) else s diff --git a/lib/cString.mli b/lib/cString.mli index 5292b34d0..65edfbbe6 100644 --- a/lib/cString.mli +++ b/lib/cString.mli @@ -32,9 +32,6 @@ sig val strip : string -> string (** Remove the surrounding blank characters from a string *) - val map : (char -> char) -> string -> string - (** Apply a function on a string character-wise. *) - val drop_simple_quotes : string -> string (** Remove the eventual first surrounding simple quotes of a string. *) diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index 720f54606..3c851d3fa 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -45,7 +45,7 @@ let create ~name ~category ?(default=Enabled) pp = | Disabled -> () | AsError -> let loc = Option.default !current_loc loc in - CErrors.user_err_loc (loc,"_",pp x) + CErrors.user_err ~loc (pp x) | Enabled -> let msg = pp x ++ spc () ++ str "[" ++ str name ++ str "," ++ diff --git a/lib/flags.ml b/lib/flags.ml index 0e2f7e5a6..5b080151c 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -108,24 +108,27 @@ let we_are_parsing = ref false (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current +type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | V8_6 | Current let compat_version = ref Current let version_compare v1 v2 = match v1, v2 with | V8_2, V8_2 -> 0 -| V8_2, (V8_3 | V8_4 | V8_5 | Current) -> -1 +| V8_2, (V8_3 | V8_4 | V8_5 | V8_6 | Current) -> -1 | V8_3, V8_2 -> 1 | V8_3, V8_3 -> 0 -| V8_3, (V8_4 | V8_5 | Current) -> -1 +| V8_3, (V8_4 | V8_5 | V8_6 | Current) -> -1 | V8_4, (V8_2 | V8_3) -> 1 | V8_4, V8_4 -> 0 -| V8_4, (V8_5 | Current) -> -1 +| V8_4, (V8_5 | V8_6 | Current) -> -1 | V8_5, (V8_2 | V8_3 | V8_4) -> 1 | V8_5, V8_5 -> 0 -| V8_5, Current -> -1 +| V8_5, (V8_6 | Current) -> -1 +| V8_6, (V8_2 | V8_3 | V8_4 | V8_5) -> 1 +| V8_6, V8_6 -> 0 +| V8_6, Current -> -1 | Current, Current -> 0 -| Current, (V8_2 | V8_3 | V8_4 | V8_5) -> 1 +| Current, (V8_2 | V8_3 | V8_4 | V8_5 | V8_6) -> 1 let version_strictly_greater v = version_compare !compat_version v > 0 let version_less_or_equal v = not (version_strictly_greater v) @@ -135,6 +138,7 @@ let pr_version = function | V8_3 -> "8.3" | V8_4 -> "8.4" | V8_5 -> "8.5" + | V8_6 -> "8.6" | Current -> "current" (* Translate *) diff --git a/lib/flags.mli b/lib/flags.mli index 897602641..bd365e653 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -62,7 +62,7 @@ val raw_print : bool ref val record_print : bool ref val univ_print : bool ref -type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current +type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | V8_6 | Current val compat_version : compat_version ref val version_compare : compat_version -> compat_version -> int val version_strictly_greater : compat_version -> bool diff --git a/lib/future.mli b/lib/future.mli index 114c59176..c780faf32 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -87,7 +87,7 @@ val from_val : ?fix_exn:fix_exn -> 'a -> 'a computation the value is not just the 'a but also the global system state *) val from_here : ?fix_exn:fix_exn -> 'a -> 'a computation -(* To get the fix_exn of a computation and build a Tacexpr.declaration_hook. +(* To get the fix_exn of a computation and build a Lemmas.declaration_hook. * When a future enters the environment a corresponding hook is run to perform * some work. If this fails, then its failure has to be annotated with the * same state id that corresponds to the future computation end. I.e. Qed diff --git a/lib/loc.ml b/lib/loc.ml index 0f9864a9a..e373a760c 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -71,6 +71,9 @@ let add_loc e loc = Exninfo.add e location loc let get_loc e = Exninfo.get e location -let raise loc e = - let info = Exninfo.add Exninfo.null location loc in - Exninfo.iraise (e, info) +let raise ?loc e = + match loc with + | None -> raise e + | Some loc -> + let info = Exninfo.add Exninfo.null location loc in + Exninfo.iraise (e, info) diff --git a/lib/loc.mli b/lib/loc.mli index c08e097a8..bb88f8642 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -51,7 +51,7 @@ val add_loc : Exninfo.info -> t -> Exninfo.info val get_loc : Exninfo.info -> t option (** Retrieving the optional location of an exception *) -val raise : t -> exn -> 'a +val raise : ?loc:t -> exn -> 'a (** [raise loc e] is the same as [Pervasives.raise (add_loc e loc)]. *) (** {5 Location utilities} *) diff --git a/lib/system.ml b/lib/system.ml index af9aa5c07..0f610b8d5 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -132,7 +132,7 @@ let find_file_in_path ?(warn=true) paths filename = let root = Filename.dirname filename in root, filename else - CErrors.errorlabstrm "System.find_file_in_path" + CErrors.user_err ~hdr:"System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename)) else (* the name is considered to be the transcription as a relative @@ -140,7 +140,7 @@ let find_file_in_path ?(warn=true) paths filename = to be locate respecting case *) try where_in_path ~warn paths filename with Not_found -> - CErrors.errorlabstrm "System.find_file_in_path" + CErrors.user_err ~hdr:"System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ str "on loadpath")) @@ -163,7 +163,7 @@ let is_in_system_path filename = let open_trapping_failure name = try open_out_bin name with e when CErrors.noncritical e -> - CErrors.errorlabstrm "System.open" (str "Can't open " ++ str name) + CErrors.user_err ~hdr:"System.open" (str "Can't open " ++ str name) let warn_cannot_remove_file = CWarnings.create ~name:"cannot-remove-file" ~category:"filesystem" @@ -175,7 +175,7 @@ let try_remove filename = warn_cannot_remove_file filename let error_corrupted file s = - CErrors.errorlabstrm "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") + CErrors.user_err ~hdr:"System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") let input_binary_int f ch = try input_binary_int ch @@ -252,7 +252,7 @@ let extern_state magic filename val_0 = let () = try_remove filename in iraise reraise with Sys_error s -> - CErrors.errorlabstrm "System.extern_state" (str "System error: " ++ str s) + CErrors.user_err ~hdr:"System.extern_state" (str "System error: " ++ str s) let intern_state magic filename = try @@ -261,12 +261,12 @@ let intern_state magic filename = close_in channel; v with Sys_error s -> - CErrors.errorlabstrm "System.intern_state" (str "System error: " ++ str s) + CErrors.user_err ~hdr:"System.intern_state" (str "System error: " ++ str s) let with_magic_number_check f a = try f a with Bad_magic_number {filename=fname;actual=actual;expected=expected} -> - CErrors.errorlabstrm "with_magic_number_check" + CErrors.user_err ~hdr:"with_magic_number_check" (str"File " ++ str fname ++ strbrk" has bad magic number " ++ int actual ++ str" (expected " ++ int expected ++ str")." ++ spc () ++ diff --git a/lib/util.ml b/lib/util.ml index 009dfbe1c..9fb0d48ee 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -87,13 +87,17 @@ let matrix_transpose mat = let identity x = x -(** Function composition: the mathematical [∘] operator. +(** Left-to-right function composition: + + [f1 %> f2] is [fun x -> f2 (f1 x)]. - So [g % f] is a synonym for [fun x -> g (f x)]. + [f1 %> f2 %> f3] is [fun x -> f3 (f2 (f1 x))]. - Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))]. - *) -let (%) f g x = f (g x) + [f1 %> f2 %> f3 %> f4] is [fun x -> f4 (f3 (f2 (f1 x)))] + + etc. +*) +let (%>) f g x = g (f x) let const x _ = x diff --git a/lib/util.mli b/lib/util.mli index 6bed7e355..cf8041a0d 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -84,13 +84,17 @@ val matrix_transpose : 'a list list -> 'a list list val identity : 'a -> 'a -(** Function composition: the mathematical [∘] operator. +(** Left-to-right function composition: + + [f1 %> f2] is [fun x -> f2 (f1 x)]. - So [g % f] is a synonym for [fun x -> g (f x)]. + [f1 %> f2 %> f3] is [fun x -> f3 (f2 (f1 x))]. - Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))]. + [f1 %> f2 %> f3 %> f4] is [fun x -> f4 (f3 (f2 (f1 x)))] + + etc. *) -val (%) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b +val ( %> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c val const : 'a -> 'b -> 'a val iterate : ('a -> 'a) -> int -> 'a -> 'a diff --git a/library/declare.ml b/library/declare.ml index c9992fff3..8298ddbc8 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -478,8 +478,8 @@ let do_universe poly l = let in_section = Lib.sections_are_opened () in let () = if poly && not in_section then - user_err_loc (Loc.ghost, "Constraint", - str"Cannot declare polymorphic universes outside sections") + user_err ~hdr:"Constraint" + (str"Cannot declare polymorphic universes outside sections") in let l = List.map (fun (l, id) -> @@ -515,27 +515,27 @@ let do_constraint poly l = | GProp -> Loc.dummy_loc, (false, Univ.Level.prop) | GSet -> Loc.dummy_loc, (false, Univ.Level.set) | GType None -> - user_err_loc (Loc.dummy_loc, "Constraint", - str "Cannot declare constraints on anonymous universes") + user_err ~hdr:"Constraint" + (str "Cannot declare constraints on anonymous universes") | GType (Some (loc, id)) -> let id = Id.of_string id in let names, _ = Universes.global_universe_names () in try loc, Idmap.find id names with Not_found -> - user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) + user_err ~loc ~hdr:"Constraint" (str "Undeclared universe " ++ pr_id id) in let in_section = Lib.sections_are_opened () in let () = if poly && not in_section then - user_err_loc (Loc.ghost, "Constraint", - str"Cannot declare polymorphic constraints outside sections") + user_err ~hdr:"Constraint" + (str"Cannot declare polymorphic constraints outside sections") in let check_poly loc p loc' p' = if poly then () else if p || p' then let loc = if p then loc else loc' in - user_err_loc (loc, "Constraint", - str "Cannot declare a global constraint on " ++ + user_err ~loc ~hdr:"Constraint" + (str "Cannot declare a global constraint on " ++ str "a polymorphic universe, use " ++ str "Polymorphic Constraint instead") in diff --git a/library/declaremods.ml b/library/declaremods.ml index b2806a1ac..3a263b1e1 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -166,13 +166,13 @@ let consistency_checks exists dir dirinfo = let globref = try Nametab.locate_dir (qualid_of_dirpath dir) with Not_found -> - errorlabstrm "consistency_checks" + user_err ~hdr:"consistency_checks" (pr_dirpath dir ++ str " should already exist!") in assert (eq_global_dir_reference globref dirinfo) else if Nametab.exists_dir dir then - errorlabstrm "consistency_checks" + user_err ~hdr:"consistency_checks" (pr_dirpath dir ++ str " already exists") let compute_visibility exists i = diff --git a/library/decls.ml b/library/decls.ml index 6e21880f1..2952c258a 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -14,6 +14,8 @@ open Names open Decl_kinds open Libnames +module NamedDecl = Context.Named.Declaration + (** Datas associated to section variables and local definitions *) type variable_data = @@ -46,20 +48,18 @@ let constant_kind kn = Cmap.find kn !csttab (** Miscellaneous functions. *) -open Context.Named.Declaration - let initialize_named_context_for_proof () = let sign = Global.named_context () in List.fold_right (fun d signv -> - let id = get_id d in - let d = if variable_opacity id then LocalAssum (id, get_type d) else d in + let id = NamedDecl.get_id d in + let d = if variable_opacity id then NamedDecl.LocalAssum (id, NamedDecl.get_type d) else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val let last_section_hyps dir = Context.Named.fold_outside (fun d sec_ids -> - let id = get_id d in + let id = NamedDecl.get_id d in try if DirPath.equal dir (variable_path id) then id::sec_ids else sec_ids with Not_found -> sec_ids) (Environ.named_context (Global.env())) diff --git a/library/goptions.ml b/library/goptions.ml index 35616558a..8f2f06925 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -36,7 +36,7 @@ type option_state = { let nickname table = String.concat " " table let error_undeclared_key key = - errorlabstrm "Goptions" (str (nickname key) ++ str ": no table or option of this type") + user_err ~hdr:"Goptions" (str (nickname key) ++ str ": no table or option of this type") (****************************************************************************) (* 1- Tables *) diff --git a/library/impargs.ml b/library/impargs.ml index bce7a15cb..ea2805b67 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -22,6 +22,9 @@ open Constrexpr open Termops open Namegen open Decl_kinds +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (*s Flags governing the computation of implicit arguments *) @@ -164,7 +167,6 @@ let update pos rig (na,st) = (* modified is_rigid_reference with a truncated env *) let is_flexible_reference env bound depth f = - let open Context.Named.Declaration in match kind_of_term f with | Rel n when n >= bound+depth -> (* inductive type *) false | Rel n when n >= depth -> (* previous argument *) true @@ -173,7 +175,7 @@ let is_flexible_reference env bound depth f = let cb = Environ.lookup_constant kn env in (match cb.const_body with Def _ -> true | _ -> false) | Var id -> - Environ.lookup_named id env |> is_local_def + env |> Environ.lookup_named id |> is_local_def | Ind _ | Construct _ -> false | _ -> true @@ -338,14 +340,14 @@ let check_correct_manual_implicits autoimps l = List.iter (function | ExplByName id,(b,fi,forced) -> if not forced then - errorlabstrm "" + user_err (str "Wrong or non-dependent implicit argument name: " ++ pr_id id ++ str ".") | ExplByPos (i,_id),_t -> if i<1 || i>List.length autoimps then - errorlabstrm "" + user_err (str "Bad implicit argument number: " ++ int i ++ str ".") else - errorlabstrm "" + user_err (str "Cannot set implicit argument number " ++ int i ++ str ": it has no name.")) l @@ -449,8 +451,7 @@ let compute_all_mib_implicits flags manual kn = let compute_var_implicits flags manual id = let env = Global.env () in - let open Context.Named.Declaration in - compute_semi_auto_implicits env flags manual (get_type (lookup_named id env)) + compute_semi_auto_implicits env flags manual (NamedDecl.get_type (lookup_named id env)) (* Implicits of a global reference. *) @@ -515,15 +516,11 @@ let subst_implicits (subst,(req,l)) = (ImplLocal,List.smartmap (subst_implicits_decl subst) l) let impls_of_context ctx = - let map (id, impl, _, _) = match impl with - | Implicit -> Some (id, Manual, (true, true)) + let map (decl, impl) = match impl with + | Implicit -> Some (NamedDecl.get_id decl, Manual, (true, true)) | _ -> None in - let is_set (_, _, b, _) = match b with - | None -> true - | Some _ -> false - in - List.rev_map map (List.filter is_set ctx) + List.rev_map map (List.filter (fst %> is_local_assum) ctx) let adjust_side_condition p = function | LessArgsThan n -> LessArgsThan (n+p) @@ -664,7 +661,7 @@ let check_inclusion l = let check_rigidity isrigid = if not isrigid then - errorlabstrm "" (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") + user_err (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") let projection_implicits env p impls = let pb = Environ.lookup_projection p env in diff --git a/library/lib.ml b/library/lib.ml index f680ecee3..4fd29a94d 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -13,6 +13,9 @@ open Libnames open Globnames open Nameops open Libobject +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration type is_type = bool (* Module Type or just Module *) type export = bool option (* None for a Module Type *) @@ -75,7 +78,7 @@ let classify_segment seg = | (_,ClosedModule _) :: stk -> clean acc stk | (_,OpenedSection _) :: _ -> error "there are still opened sections" | (_,OpenedModule (ty,_,_,_)) :: _ -> - errorlabstrm "Lib.classify_segment" + user_err ~hdr:"Lib.classify_segment" (str "there are still opened " ++ str (module_kind ty) ++ str "s") | (_,FrozenState _) :: stk -> clean acc stk in @@ -272,7 +275,7 @@ let start_mod is_type export id mp fs = else Nametab.exists_module dir in if exists then - errorlabstrm "open_module" (pr_id id ++ str " already exists"); + user_err ~hdr:"open_module" (pr_id id ++ str " already exists"); add_entry (make_oname id) (OpenedModule (is_type,export,prefix,fs)); path_prefix := prefix; prefix @@ -282,7 +285,7 @@ let start_modtype = start_mod true None let error_still_opened string oname = let id = basename (fst oname) in - errorlabstrm "" + user_err (str "The " ++ str string ++ str " " ++ pr_id id ++ str " is still opened.") let end_mod is_type = @@ -327,7 +330,7 @@ let end_compilation_checks dir = try match snd (find_entry_p is_opening_node) with | OpenedSection _ -> error "There are some open sections." | OpenedModule (ty,_,_,_) -> - errorlabstrm "Lib.end_compilation_checks" + user_err ~hdr:"Lib.end_compilation_checks" (str "There are some open " ++ str (module_kind ty) ++ str "s.") | _ -> assert false with Not_found -> () @@ -379,7 +382,7 @@ let find_opening_node id = let oname,entry = find_entry_p is_opening_node in let id' = basename (fst oname) in if not (Names.Id.equal id id') then - errorlabstrm "Lib.find_opening_node" + user_err ~hdr:"Lib.find_opening_node" (str "Last block to end has name " ++ pr_id id' ++ str "."); entry with Not_found -> error "There is nothing to end." @@ -393,7 +396,7 @@ let find_opening_node id = - the list of substitution to do at section closing *) -type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types +type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind type variable_context = variable_info list type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t @@ -433,12 +436,10 @@ let add_section_context ctx = sectab := (Context ctx :: vars,repl,abs)::sl let extract_hyps (secs,ohyps) = - let open Context.Named.Declaration in let rec aux = function - | (Variable (id,impl,poly,ctx)::idl, decl::hyps) when Names.Id.equal id (get_id decl) -> - let (id',b,t) = to_tuple decl in + | (Variable (id,impl,poly,ctx)::idl, decl::hyps) when Names.Id.equal id (NamedDecl.get_id decl) -> let l, r = aux (idl,hyps) in - (id',impl,b,t) :: l, if poly then Univ.ContextSet.union r ctx else r + (decl,impl) :: l, if poly then Univ.ContextSet.union r ctx else r | (Variable (_,_,poly,ctx)::idl,hyps) -> let l, r = aux (idl,hyps) in l, if poly then Univ.ContextSet.union r ctx else r @@ -448,17 +449,11 @@ let extract_hyps (secs,ohyps) = | [], _ -> [],Univ.ContextSet.empty in aux (secs,ohyps) -let instance_from_variable_context sign = - let rec inst_rec = function - | (id,b,None,_) :: sign -> id :: inst_rec sign - | _ :: sign -> inst_rec sign - | [] -> [] in - Array.of_list (inst_rec sign) - -let named_of_variable_context ctx = let open Context.Named.Declaration in - List.map (function id,_,None,t -> LocalAssum (id,t) - | id,_,Some b,t -> LocalDef (id,b,t)) - ctx +let instance_from_variable_context = + List.map fst %> List.filter is_local_assum %> List.map NamedDecl.get_id %> Array.of_list + +let named_of_variable_context = + List.map fst let add_section_replacement f g poly hyps = match !sectab with @@ -523,7 +518,7 @@ let open_section id = let dir = add_dirpath_suffix olddir id in let prefix = dir, (mp, add_dirpath_suffix oldsec id) in if Nametab.exists_section dir then - errorlabstrm "open_section" (pr_id id ++ str " already exists."); + user_err ~hdr:"open_section" (pr_id id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:`No in add_entry (make_oname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) diff --git a/library/lib.mli b/library/lib.mli index a8e110c67..9f9d8c7e5 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -160,8 +160,7 @@ val xml_open_section : (Names.Id.t -> unit) Hook.t val xml_close_section : (Names.Id.t -> unit) Hook.t (** {6 Section management for discharge } *) -type variable_info = Names.Id.t * Decl_kinds.binding_kind * - Term.constr option * Term.types +type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind type variable_context = variable_info list type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t diff --git a/library/library.ml b/library/library.ml index d44f796a7..3086e3d18 100644 --- a/library/library.ml +++ b/library/library.ml @@ -131,7 +131,7 @@ let find_library dir = let try_find_library dir = try find_library dir with Not_found -> - errorlabstrm "Library.find_library" + user_err ~hdr:"Library.find_library" (str "Unknown library " ++ pr_dirpath dir) let register_library_filename dir f = @@ -329,12 +329,12 @@ let locate_qualified_library ?root ?(warn = true) qid = let error_unmapped_dir qid = let prefix, _ = repr_qualid qid in - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ()) let error_lib_not_found qid = - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str"Cannot find library " ++ pr_qualid qid ++ str" in loadpath") let try_locate_absolute_library dir = @@ -378,7 +378,7 @@ let access_table what tables dp i = let t = try fetch_delayed f with Faulty f -> - errorlabstrm "Library.access_table" + user_err ~hdr:"Library.access_table" (str "The file " ++ str f ++ str " (bound to " ++ str dir_path ++ str ") is inaccessible or corrupted,\ncannot load some " ++ str what ++ str " in it.\n") @@ -463,7 +463,7 @@ let rec intern_library (needed, contents) (dir, f) from = let f = match f with Some f -> f | None -> try_locate_absolute_library dir in let m = intern_from_file f in if not (DirPath.equal dir m.library_name) then - errorlabstrm "load_physical_library" + user_err ~hdr:"load_physical_library" (str "The file " ++ str f ++ str " contains library" ++ spc () ++ pr_dirpath m.library_name ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir); @@ -477,7 +477,7 @@ and intern_library_deps libs dir m from = and intern_mandatory_library caller from libs (dir,d) = let digest, libs = intern_library libs (dir, None) (Some from) in if not (Safe_typing.digest_match ~actual:digest ~required:d) then - errorlabstrm "" (str "Compiled library " ++ pr_dirpath caller ++ + user_err (str "Compiled library " ++ pr_dirpath caller ++ str " (in file " ++ str from ++ str ") makes inconsistent assumptions \ over library " ++ pr_dirpath dir); libs @@ -582,8 +582,8 @@ let require_library_from_dirpath modrefl export = let safe_locate_module (loc,qid) = try Nametab.locate_module qid with Not_found -> - user_err_loc - (loc,"import_library", pr_qualid qid ++ str " is not a module") + user_err ~loc ~hdr:"import_library" + (pr_qualid qid ++ str " is not a module") let import_module export modl = (* Optimization: libraries in a raw in the list are imported @@ -607,8 +607,8 @@ let import_module export modl = flush acc; try Declaremods.import_module export mp; aux [] l with Not_found -> - user_err_loc (loc,"import_library", - pr_qualid dir ++ str " is not a module")) + user_err ~loc ~hdr:"import_library" + (pr_qualid dir ++ str " is not a module")) | [] -> flush acc in aux [] modl @@ -619,7 +619,7 @@ let check_coq_overwriting p id = let l = DirPath.repr p in let is_empty = match l with [] -> true | _ -> false in if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then - errorlabstrm "" + user_err (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") @@ -632,7 +632,7 @@ let check_module_name s = (if c = '\'' then str "\"'\"" else (str "'" ++ str (String.make 1 c) ++ str "'")) ++ strbrk " is not allowed in module names\n" in - let err c = errorlabstrm "" (msg c) in + let err c = user_err (msg c) in match String.get s 0 with | 'a' .. 'z' | 'A' .. 'Z' -> for i = 1 to (String.length s)-1 do @@ -668,10 +668,10 @@ let load_library_todo f = let tasks, _, _ = System.marshal_in_segment f ch in let (s5 : seg_proofs), _, _ = System.marshal_in_segment f ch in close_in ch; - if tasks = None then errorlabstrm "restart" (str"not a .vio file"); - if s2 = None then errorlabstrm "restart" (str"not a .vio file"); - if s3 = None then errorlabstrm "restart" (str"not a .vio file"); - if pi3 (Option.get s2) then errorlabstrm "restart" (str"not a .vio file"); + if tasks = None then user_err ~hdr:"restart" (str"not a .vio file"); + if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); + if s3 = None then user_err ~hdr:"restart" (str"not a .vio file"); + if pi3 (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); longf, s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 (************************************************************************) @@ -687,7 +687,7 @@ let current_deps () = let current_reexports () = !libraries_exports_list let error_recursively_dependent_library dir = - errorlabstrm "" + user_err (strbrk "Unable to use logical name " ++ pr_dirpath dir ++ strbrk " to save current library because" ++ strbrk " it already depends on a library of this name.") @@ -734,7 +734,7 @@ let save_library_to ?todo dir f otab = except Int.Set.empty in let is_done_or_todo i x = Future.is_val x || Int.Set.mem i except in Array.iteri (fun i x -> - if not(is_done_or_todo i x) then CErrors.errorlabstrm "library" + if not(is_done_or_todo i x) then CErrors.user_err ~hdr:"library" Pp.(str"Proof object "++int i++str" is not checked nor to be checked")) opaque_table; let sd = { diff --git a/library/nameops.ml b/library/nameops.ml index 71405d024..6020db33d 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -67,9 +67,21 @@ let root_of_id id = let suffixstart = cut_ident true id in Id.of_string (String.sub (Id.to_string id) 0 suffixstart) -(* Rem: semantics is a bit different, if an ident starts with toto00 then - after successive renamings it comes to toto09, then it goes on with toto10 *) -let lift_subscript id = +(* Return the same identifier as the original one but whose {i subscript} is incremented. + If the original identifier does not have a suffix, [0] is appended to it. + + Example mappings: + + [bar] ↦ [bar0] + [bar0] ↦ [bar1] + [bar00] ↦ [bar01] + [bar1] ↦ [bar2] + [bar01] ↦ [bar01] + [bar9] ↦ [bar10] + [bar09] ↦ [bar10] + [bar99] ↦ [bar100] +*) +let increment_subscript id = let id = Id.to_string id in let len = String.length id in let rec add carrypos = diff --git a/library/nameops.mli b/library/nameops.mli index 39ce409bc..3a67b61a1 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -21,9 +21,34 @@ val root_of_id : Id.t -> Id.t (** remove trailing digits, ' and _ *) val add_suffix : Id.t -> string -> Id.t val add_prefix : string -> Id.t -> Id.t -val has_subscript : Id.t -> bool -val lift_subscript : Id.t -> Id.t -val forget_subscript : Id.t -> Id.t +(** Below, by {i subscript} we mean a suffix composed solely from (decimal) digits. *) + +val has_subscript : Id.t -> bool + +val increment_subscript : Id.t -> Id.t +(** Return the same identifier as the original one but whose {i subscript} is incremented. + If the original identifier does not have a suffix, [0] is appended to it. + + Example mappings: + + [bar] ↦ [bar0] + + [bar0] ↦ [bar1] + + [bar00] ↦ [bar01] + + [bar1] ↦ [bar2] + + [bar01] ↦ [bar01] + + [bar9] ↦ [bar10] + + [bar09] ↦ [bar10] + + [bar99] ↦ [bar100] +*) + +val forget_subscript : Id.t -> Id.t val out_name : Name.t -> Id.t (** [out_name] associates [id] to [Name id]. Raises [Failure "Nameops.out_name"] diff --git a/library/nametab.ml b/library/nametab.ml index fa5db37ed..b76048e89 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -16,10 +16,8 @@ open Globnames exception GlobalizationError of qualid -let error_global_not_found_loc loc q = - Loc.raise loc (GlobalizationError q) - -let error_global_not_found q = raise (GlobalizationError q) +let error_global_not_found ?loc q = + Loc.raise ?loc (GlobalizationError q) (* Kinds of global names *) @@ -455,11 +453,11 @@ let global r = try match locate_extended qid with | TrueGlobal ref -> ref | SynDef _ -> - user_err_loc (loc,"global", - str "Unexpected reference to a notation: " ++ - pr_qualid qid) + user_err ~loc ~hdr:"global" + (str "Unexpected reference to a notation: " ++ + pr_qualid qid) with Not_found -> - error_global_not_found_loc loc qid + error_global_not_found ~loc qid (* Exists functions ********************************************************) @@ -534,8 +532,8 @@ let global_inductive r = match global r with | IndRef ind -> ind | ref -> - user_err_loc (loc_of_reference r,"global_inductive", - pr_reference r ++ spc () ++ str "is not an inductive type") + user_err ~loc:(loc_of_reference r) ~hdr:"global_inductive" + (pr_reference r ++ spc () ++ str "is not an inductive type") (********************************************************************) diff --git a/library/nametab.mli b/library/nametab.mli index a8a0572b3..d20c399b6 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -60,8 +60,7 @@ open Globnames exception GlobalizationError of qualid (** Raises a globalization error *) -val error_global_not_found_loc : Loc.t -> qualid -> 'a -val error_global_not_found : qualid -> 'a +val error_global_not_found : ?loc:Loc.t -> qualid -> 'a (** {6 Register visibility of things } *) diff --git a/library/universes.ml b/library/universes.ml index 112b20a4c..0ccb6b8d2 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -337,7 +337,7 @@ let existing_instance ctx inst = and a2 = Instance.to_array (UContext.instance ctx) in let len1 = Array.length a1 and len2 = Array.length a2 in if not (len1 == len2) then - CErrors.errorlabstrm "Universes" + CErrors.user_err ~hdr:"Universes" (str "Polymorphic constant expected " ++ int len2 ++ str" levels but was given " ++ int len1) else () diff --git a/ltac/coretactics.ml4 b/ltac/coretactics.ml4 index 618666758..28ff6df83 100644 --- a/ltac/coretactics.ml4 +++ b/ltac/coretactics.ml4 @@ -13,7 +13,7 @@ open Names open Locus open Misctypes open Genredexpr -open Constrarg +open Stdarg open Extraargs open Sigma.Notations diff --git a/ltac/evar_tactics.ml b/ltac/evar_tactics.ml index 30aeba3bb..c5b26e6d5 100644 --- a/ltac/evar_tactics.ml +++ b/ltac/evar_tactics.ml @@ -18,6 +18,8 @@ open Sigma.Notations open Proofview.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + (* The instantiate tactic *) let instantiate_evar evk (ist,rawc) sigma = @@ -48,7 +50,7 @@ let instantiate_tac n c ido = | _ -> error "Please be more specific: in type or value?") | InHypTypeOnly -> - evar_list (get_type decl) + evar_list (NamedDecl.get_type decl) | InHypValueOnly -> (match decl with | LocalDef (_,body,_) -> evar_list body diff --git a/ltac/extraargs.ml4 b/ltac/extraargs.ml4 index 0db1cd7ba..53b726432 100644 --- a/ltac/extraargs.ml4 +++ b/ltac/extraargs.ml4 @@ -11,7 +11,7 @@ open Pp open Genarg open Stdarg -open Constrarg +open Tacarg open Pcoq.Prim open Pcoq.Constr open Names @@ -31,15 +31,15 @@ let create_generic_quotation name e wit = let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string -let () = create_generic_quotation "ident" Pcoq.Prim.ident Constrarg.wit_ident -let () = create_generic_quotation "reference" Pcoq.Prim.reference Constrarg.wit_ref -let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Constrarg.wit_uconstr -let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Constrarg.wit_constr -let () = create_generic_quotation "ipattern" Pcoq.Tactic.simple_intropattern Constrarg.wit_intro_pattern -let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Constrarg.wit_open_constr +let () = create_generic_quotation "ident" Pcoq.Prim.ident Stdarg.wit_ident +let () = create_generic_quotation "reference" Pcoq.Prim.reference Stdarg.wit_ref +let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Stdarg.wit_uconstr +let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Stdarg.wit_constr +let () = create_generic_quotation "ipattern" Pltac.simple_intropattern Stdarg.wit_intro_pattern +let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Stdarg.wit_open_constr let () = let inject (loc, v) = Tacexpr.Tacexp v in - Tacentries.create_ltac_quotation "ltac" inject (Pcoq.Tactic.tactic_expr, Some 5) + Tacentries.create_ltac_quotation "ltac" inject (Pltac.tactic_expr, Some 5) (** Backward-compatible tactic notation entry names *) @@ -262,7 +262,7 @@ let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl -let in_clause' = Pcoq.Tactic.in_clause +let in_clause' = Pltac.in_clause ARGUMENT EXTEND in_clause TYPED AS clause_dft_concl diff --git a/ltac/extratactics.ml4 b/ltac/extratactics.ml4 index d0318fb5f..8ea60b39a 100644 --- a/ltac/extratactics.ml4 +++ b/ltac/extratactics.ml4 @@ -11,10 +11,10 @@ open Pp open Genarg open Stdarg -open Constrarg +open Tacarg open Extraargs open Pcoq.Prim -open Pcoq.Tactic +open Pltac open Mod_subst open Names open Tacexpr @@ -27,7 +27,6 @@ open Equality open Misctypes open Sigma.Notations open Proofview.Notations -open Constrarg DECLARE PLUGIN "extratactics" @@ -53,7 +52,7 @@ let replace_in_clause_maybe_by ist c1 c2 cl tac = let replace_term ist dir_opt c cl = with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) -let clause = Pcoq.Tactic.clause_dft_concl +let clause = Pltac.clause_dft_concl TACTIC EXTEND replace ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] @@ -986,7 +985,7 @@ let pr_cmp' _prc _prlc _prt = pr_cmp let pr_test_gen f (Test(c,x,y)) = Pp.(f x ++ pr_cmp c ++ f y) -let pr_test = pr_test_gen (Pptactic.pr_or_var Pp.int) +let pr_test = pr_test_gen (Pputils.pr_or_var Pp.int) let pr_test' _prc _prlc _prt = pr_test diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4 index 8bc2ffd65..82ba63871 100644 --- a/ltac/g_auto.ml4 +++ b/ltac/g_auto.ml4 @@ -11,10 +11,10 @@ open Pp open Genarg open Stdarg -open Constrarg open Pcoq.Prim open Pcoq.Constr -open Pcoq.Tactic +open Pltac +open Hints open Tacexpr DECLARE PLUGIN "g_auto" diff --git a/ltac/g_class.ml4 b/ltac/g_class.ml4 index 18df596eb..f8654d390 100644 --- a/ltac/g_class.ml4 +++ b/ltac/g_class.ml4 @@ -10,9 +10,9 @@ open Misctypes open Class_tactics -open Pcoq.Tactic +open Pltac open Stdarg -open Constrarg +open Tacarg DECLARE PLUGIN "g_class" diff --git a/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 index a3ca4ebc4..54229bb2a 100644 --- a/ltac/g_ltac.ml4 +++ b/ltac/g_ltac.ml4 @@ -19,8 +19,10 @@ open Genredexpr open Tok (* necessary for camlp4 *) open Pcoq +open Pcoq.Constr +open Pcoq.Vernac_ open Pcoq.Prim -open Pcoq.Tactic +open Pltac let fail_default_value = ArgArg 0 @@ -30,14 +32,15 @@ let arg_of_expr = function let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n -let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat -let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c +let genarg_of_ipattern pat = in_gen (rawwit Stdarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c +let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac let reference_to_id = function | Libnames.Ident (loc, id) -> (loc, id) | Libnames.Qualid (loc,_) -> - CErrors.user_err_loc (loc, "", - str "This expression should be a simple identifier.") + CErrors.user_err ~loc + (str "This expression should be a simple identifier.") let tactic_mode = Gram.entry_create "vernac:tactic_command" @@ -71,14 +74,17 @@ let test_bracket_ident = (* Tactics grammar rules *) +let hint = G_proofs.hint + let warn_deprecated_appcontext = CWarnings.create ~name:"deprecated-appcontext" ~category:"deprecated" (fun () -> strbrk "appcontext is deprecated and will be removed " ++ strbrk "in a future version") GEXTEND Gram - GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg - tactic_mode constr_may_eval constr_eval toplevel_selector; + GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint + tactic_mode constr_may_eval constr_eval toplevel_selector + operconstr; tactic_then_last: [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> @@ -286,15 +292,15 @@ GEXTEND Gram (* Definitions for tactics *) tacdef_body: [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> - if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) + if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) else let id = reference_to_id name in - Vernacexpr.TacticDefinition (id, TacFun (it, body)) + Tacexpr.TacticDefinition (id, TacFun (it, body)) | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - if redef then Vernacexpr.TacticRedefinition (name, body) + if redef then Tacexpr.TacticRedefinition (name, body) else let id = reference_to_id name in - Vernacexpr.TacticDefinition (id, body) + Tacexpr.TacticDefinition (id, body) ] ] ; tactic: @@ -329,9 +335,28 @@ GEXTEND Gram tactic_mode: [ [ g = OPT toplevel_selector; tac = G_vernac.subgoal_command -> tac g ] ] ; + command: + [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; + l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> + Vernacexpr.VernacProof (Some (in_tac ta), G_proofs.hint_proof_using G_vernac.section_subset_expr l) + | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; + ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] -> + Vernacexpr.VernacProof (ta,Some l) ] ] + ; + hint: + [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; + tac = Pltac.tactic -> + Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] + ; + operconstr: LEVEL "0" + [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> + let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in + CHole (!@loc, None, IntroAnonymous, Some arg) ] ] + ; END -open Constrarg +open Stdarg +open Tacarg open Vernacexpr open Vernac_classifier open Goptions diff --git a/ltac/g_obligations.ml4 b/ltac/g_obligations.ml4 index 987b9d538..d286a5870 100644 --- a/ltac/g_obligations.ml4 +++ b/ltac/g_obligations.ml4 @@ -17,7 +17,7 @@ open Libnames open Constrexpr open Constrexpr_ops open Stdarg -open Constrarg +open Tacarg open Extraargs let (set_default_tactic, get_default_tactic, print_default_tactic) = @@ -30,12 +30,23 @@ let () = end in Obligations.default_tactic := tac +let with_tac f tac = + let env = { Genintern.genv = Global.env (); ltacvars = Names.Id.Set.empty } in + let tac = match tac with + | None -> None + | Some tac -> + let tac = Genarg.in_gen (Genarg.rawwit wit_ltac) tac in + let _, tac = Genintern.generic_intern env tac in + Some tac + in + f tac + (* We define new entries for programs, with the use of this module * Subtac. These entries are named Subtac.<foo> *) module Gram = Pcoq.Gram -module Tactic = Pcoq.Tactic +module Tactic = Pltac open Pcoq @@ -66,6 +77,9 @@ GEXTEND Gram open Obligations +let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac +let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac + let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl diff --git a/ltac/g_rewrite.ml4 b/ltac/g_rewrite.ml4 index 28078efd6..b1c4f58eb 100644 --- a/ltac/g_rewrite.ml4 +++ b/ltac/g_rewrite.ml4 @@ -21,10 +21,10 @@ open Tacmach open Tacticals open Rewrite open Stdarg -open Constrarg +open Pcoq.Vernac_ open Pcoq.Prim open Pcoq.Constr -open Pcoq.Tactic +open Pltac DECLARE PLUGIN "g_rewrite" @@ -64,13 +64,13 @@ let subst_strategy s str = str let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" let pr_raw_strategy prc prlc _ (s : raw_strategy) = - let prr = Pptactic.pr_red_expr (prc, prlc, Pptactic.pr_or_by_notation Libnames.pr_reference, prc) in + let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_reference, prc) in Rewrite.pr_strategy prc prr s let pr_glob_strategy prc prlc _ (s : glob_strategy) = let prr = Pptactic.pr_red_expr (Ppconstr.pr_constr_expr, Ppconstr.pr_lconstr_expr, - Pptactic.pr_or_by_notation Libnames.pr_reference, + Pputils.pr_or_by_notation Libnames.pr_reference, Ppconstr.pr_constr_expr) in Rewrite.pr_strategy prc prr s diff --git a/parsing/g_tactic.ml4 b/ltac/g_tactic.ml4 index 3152afb28..685c07c9a 100644 --- a/parsing/g_tactic.ml4 +++ b/ltac/g_tactic.ml4 @@ -120,7 +120,7 @@ let lookup_at_as_comma = open Constr open Prim -open Tactic +open Pltac let mk_fix_tac (loc,id,bl,ann,ty) = let n = @@ -135,9 +135,9 @@ let mk_fix_tac (loc,id,bl,ann,ty) = let mk_cofix_tac (loc,id,bl,ann,ty) = let _ = Option.map (fun (aloc,_) -> - user_err_loc - (aloc,"Constr:mk_cofix_tac", - Pp.str"Annotation forbidden in cofix expression.")) ann in + user_err ~loc:aloc + ~hdr:"Constr:mk_cofix_tac" + (Pp.str"Annotation forbidden in cofix expression.")) ann in (id,CProdN(loc,bl,ty)) (* Functions overloaded by quotifier *) @@ -192,7 +192,7 @@ let merge_occurrences loc cl = function | None -> if Locusops.clause_with_generic_occurrences cl then (None, cl) else - user_err_loc (loc,"",str "Found an \"at\" clause without \"with\" clause.") + user_err ~loc (str "Found an \"at\" clause without \"with\" clause.") | Some (occs, p) -> let ans = match occs with | AllOccurrences -> cl @@ -204,9 +204,9 @@ let merge_occurrences loc cl = function { cl with onhyps = Some [(occs, id), l] } | _ -> if Locusops.clause_with_generic_occurrences cl then - user_err_loc (loc,"",str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") + user_err ~loc (str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") else - user_err_loc (loc,"",str "Cannot use clause \"at\" twice.") + user_err ~loc (str "Cannot use clause \"at\" twice.") end in (Some p, ans) @@ -217,6 +217,8 @@ let warn_deprecated_eqn_syntax = (* Auxiliary grammar rules *) +open Vernac_ + GEXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis bindings red_expr int_or_var open_constr uconstr diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib index fc51e48ae..af1c7149d 100644 --- a/ltac/ltac.mllib +++ b/ltac/ltac.mllib @@ -1,3 +1,6 @@ +Tacarg +Pptactic +Pltac Taccoerce Tacsubst Tacenv @@ -5,6 +8,7 @@ Tactic_debug Tacintern Tacentries Profile_ltac +Tactic_matching Tacinterp Evar_tactics Tactic_option @@ -19,4 +23,5 @@ Rewrite G_rewrite Tauto G_eqdecide +G_tactic G_ltac diff --git a/ltac/pltac.ml b/ltac/pltac.ml new file mode 100644 index 000000000..1d21118ae --- /dev/null +++ b/ltac/pltac.ml @@ -0,0 +1,65 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Pcoq + +(* Main entry for extensions *) +let simple_tactic = Gram.entry_create "tactic:simple_tactic" + +let make_gen_entry _ name = Gram.entry_create ("tactic:" ^ name) + +(* Entries that can be referred via the string -> Gram.entry table *) +(* Typically for tactic user extensions *) +let open_constr = + make_gen_entry utactic "open_constr" +let constr_with_bindings = + make_gen_entry utactic "constr_with_bindings" +let bindings = + make_gen_entry utactic "bindings" +let hypident = Gram.entry_create "hypident" +let constr_may_eval = make_gen_entry utactic "constr_may_eval" +let constr_eval = make_gen_entry utactic "constr_eval" +let uconstr = + make_gen_entry utactic "uconstr" +let quantified_hypothesis = + make_gen_entry utactic "quantified_hypothesis" +let destruction_arg = make_gen_entry utactic "destruction_arg" +let int_or_var = make_gen_entry utactic "int_or_var" +let simple_intropattern = + make_gen_entry utactic "simple_intropattern" +let in_clause = make_gen_entry utactic "in_clause" +let clause_dft_concl = + make_gen_entry utactic "clause" + + +(* Main entries for ltac *) +let tactic_arg = Gram.entry_create "tactic:tactic_arg" +let tactic_expr = make_gen_entry utactic "tactic_expr" +let binder_tactic = make_gen_entry utactic "binder_tactic" + +let tactic = make_gen_entry utactic "tactic" + +(* Main entry for quotations *) +let tactic_eoi = eoi_entry tactic + +let () = + let open Stdarg in + let open Tacarg in + register_grammar wit_int_or_var (int_or_var); + register_grammar wit_intro_pattern (simple_intropattern); + register_grammar wit_quant_hyp (quantified_hypothesis); + register_grammar wit_uconstr (uconstr); + register_grammar wit_open_constr (open_constr); + register_grammar wit_constr_with_bindings (constr_with_bindings); + register_grammar wit_bindings (bindings); + register_grammar wit_tactic (tactic); + register_grammar wit_ltac (tactic); + register_grammar wit_clause_dft_concl (clause_dft_concl); + register_grammar wit_destruction_arg (destruction_arg); + () diff --git a/ltac/pltac.mli b/ltac/pltac.mli new file mode 100644 index 000000000..810e1ec39 --- /dev/null +++ b/ltac/pltac.mli @@ -0,0 +1,38 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Ltac parsing entries *) + +open Loc +open Names +open Pcoq +open Libnames +open Constrexpr +open Tacexpr +open Genredexpr +open Misctypes + +val open_constr : constr_expr Gram.entry +val constr_with_bindings : constr_expr with_bindings Gram.entry +val bindings : constr_expr bindings Gram.entry +val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry +val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry +val constr_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry +val uconstr : constr_expr Gram.entry +val quantified_hypothesis : quantified_hypothesis Gram.entry +val destruction_arg : constr_expr with_bindings destruction_arg Gram.entry +val int_or_var : int or_var Gram.entry +val simple_tactic : raw_tactic_expr Gram.entry +val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry +val in_clause : Names.Id.t Loc.located Locus.clause_expr Gram.entry +val clause_dft_concl : Names.Id.t Loc.located Locus.clause_expr Gram.entry +val tactic_arg : raw_tactic_arg Gram.entry +val tactic_expr : raw_tactic_expr Gram.entry +val binder_tactic : raw_tactic_expr Gram.entry +val tactic : raw_tactic_expr Gram.entry +val tactic_eoi : raw_tactic_expr Gram.entry diff --git a/printing/pptactic.ml b/ltac/pptactic.ml index 1e618b59e..6230fa060 100644 --- a/printing/pptactic.ml +++ b/ltac/pptactic.ml @@ -15,13 +15,15 @@ open Constrexpr open Tacexpr open Genarg open Geninterp -open Constrarg +open Stdarg +open Tacarg open Libnames open Ppextend open Misctypes open Locus open Decl_kinds open Genredexpr +open Pputils open Ppconstr open Printer @@ -62,19 +64,6 @@ type 'a extra_genarg_printer = (tolerability -> Val.t -> std_ppcmds) -> 'a -> std_ppcmds -let genarg_pprule = ref String.Map.empty - -let declare_extra_genarg_pprule wit f g h = - let s = match wit with - | ExtraArg s -> ArgT.repr s - | _ -> error - "Can declare a pretty-printing rule only for extra argument types." - in - let f prc prlc prtac x = f prc prlc prtac (out_gen (rawwit wit) x) in - let g prc prlc prtac x = g prc prlc prtac (out_gen (glbwit wit) x) in - let h prc prlc prtac x = h prc prlc prtac (out_gen (topwit wit) x) in - genarg_pprule := String.Map.add s (f,g,h) !genarg_pprule - module Make (Ppconstr : Ppconstrsig.Pp) (Taggers : sig @@ -135,80 +124,8 @@ module Make end | _ -> default - let pr_with_occurrences pr (occs,c) = - match occs with - | AllOccurrences -> - pr c - | NoOccurrences -> - failwith "pr_with_occurrences: no occurrences" - | OnlyOccurrences nl -> - hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++ - hov 0 (prlist_with_sep spc (pr_or_var int) nl)) - | AllOccurrencesBut nl -> - hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++ - hov 0 (prlist_with_sep spc (pr_or_var int) nl)) - - exception ComplexRedFlag - - let pr_short_red_flag pr r = - if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then - raise ComplexRedFlag - else if List.is_empty r.rConst then - if r.rDelta then mt () else raise ComplexRedFlag - else (if r.rDelta then str "-" else mt ()) ++ - hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]") - - let pr_red_flag pr r = - try pr_short_red_flag pr r - with complexRedFlags -> - (if r.rBeta then pr_arg str "beta" else mt ()) ++ - (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else - (if r.rMatch then pr_arg str "match" else mt ()) ++ - (if r.rFix then pr_arg str "fix" else mt ()) ++ - (if r.rCofix then pr_arg str "cofix" else mt ())) ++ - (if r.rZeta then pr_arg str "zeta" else mt ()) ++ - (if List.is_empty r.rConst then - if r.rDelta then pr_arg str "delta" - else mt () - else - pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++ - hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) - - let pr_union pr1 pr2 = function - | Inl a -> pr1 a - | Inr b -> pr2 b - - let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) = function - | Red false -> keyword "red" - | Hnf -> keyword "hnf" - | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f) - ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o - | Cbv f -> - if f.rBeta && f.rMatch && f.rFix && f.rCofix && - f.rZeta && f.rDelta && List.is_empty f.rConst then - keyword "compute" - else - hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f) - | Lazy f -> - hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f) - | Cbn f -> - hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f) - | Unfold l -> - hov 1 (keyword "unfold" ++ spc() ++ - prlist_with_sep pr_comma (pr_with_occurrences pr_ref) l) - | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l) - | Pattern l -> - hov 1 (keyword "pattern" ++ - pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr)) l) - - | Red true -> - error "Shouldn't be accessible from user." - | ExtraRedExpr s -> - str s - | CbvVm o -> - keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o - | CbvNative o -> - keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o + let pr_with_occurrences pr c = pr_with_occurrences pr keyword c + let pr_red_expr pr c = pr_red_expr pr keyword c let pr_may_eval test prc prlc pr2 pr3 = function | ConstrEval (r,c) -> @@ -232,10 +149,6 @@ module Make let pr_arg pr x = spc () ++ pr x - let pr_or_var pr = function - | ArgArg x -> pr x - | ArgVar (_,s) -> pr_id s - let pr_and_short_name pr (c,_) = pr c let pr_or_by_notation f = function @@ -300,52 +213,6 @@ module Make let with_evars ev s = if ev then "e" ^ s else s - let hov_if_not_empty n p = if Pp.ismt p then p else hov n p - - let rec pr_raw_generic_rec prc prlc prtac prpat prref (GenArg (Rawwit wit, x)) = - match wit with - | ListArg wit -> - let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in - let ans = pr_sequence map x in - hov_if_not_empty 0 ans - | OptArg wit -> - let ans = match x with - | None -> mt () - | Some x -> pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) - in - hov_if_not_empty 0 ans - | PairArg (wit1, wit2) -> - let p, q = x in - let p = in_gen (rawwit wit1) p in - let q = in_gen (rawwit wit2) q in - hov_if_not_empty 0 (pr_sequence (pr_raw_generic_rec prc prlc prtac prpat prref) [p; q]) - | ExtraArg s -> - try pi1 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (rawwit wit) x) - with Not_found -> Genprint.generic_raw_print (in_gen (rawwit wit) x) - - - let rec pr_glb_generic_rec prc prlc prtac prpat (GenArg (Glbwit wit, x)) = - match wit with - | ListArg wit -> - let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in - let ans = pr_sequence map x in - hov_if_not_empty 0 ans - | OptArg wit -> - let ans = match x with - | None -> mt () - | Some x -> pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) - in - hov_if_not_empty 0 ans - | PairArg (wit1, wit2) -> - let p, q = x in - let p = in_gen (glbwit wit1) p in - let q = in_gen (glbwit wit2) q in - let ans = pr_sequence (pr_glb_generic_rec prc prlc prtac prpat) [p; q] in - hov_if_not_empty 0 ans - | ExtraArg s -> - try pi2 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (glbwit wit) x) - with Not_found -> Genprint.generic_glb_print (in_gen (glbwit wit) x) - let rec tacarg_using_rule_token pr_gen = function | [] -> [] | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l @@ -1243,7 +1110,7 @@ module Make pr_constant = pr_or_by_notation pr_reference; pr_reference = pr_reference; pr_name = pr_lident; - pr_generic = pr_raw_generic_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference; + pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg); pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; } in @@ -1273,9 +1140,7 @@ module Make pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env)); pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); pr_name = pr_lident; - pr_generic = pr_glb_generic_rec - (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) - prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); + pr_generic = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg); pr_extend = pr_glob_extend_rec (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); @@ -1323,12 +1188,9 @@ module Make in prtac n t - let pr_raw_generic env = pr_raw_generic_rec - pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference + let pr_raw_generic = Pputils.pr_raw_generic - let pr_glb_generic env = pr_glb_generic_rec - (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) - (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) + let pr_glb_generic = Pputils.pr_glb_generic let pr_raw_extend env = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr @@ -1376,6 +1238,26 @@ include Make (Ppconstr) (struct let tag_atomic_tactic_expr = do_not_tag end) +let declare_extra_genarg_pprule wit + (f : 'a raw_extra_genarg_printer) + (g : 'b glob_extra_genarg_printer) + (h : 'c extra_genarg_printer) = + let s = match wit with + | ExtraArg s -> ArgT.repr s + | _ -> error + "Can declare a pretty-printing rule only for extra argument types." + in + let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in + let g x = + let env = Global.env () in + g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x + in + let h x = + let env = Global.env () in + h (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) (fun _ _ -> str "<tactic>") x + in + Genprint.register_print0 wit f g h + (** Registering *) let run_delayed c = @@ -1390,57 +1272,57 @@ let () = let pr_bool b = if b then str "true" else str "false" in let pr_unit _ = str "()" in let pr_string s = str "\"" ++ str s ++ str "\"" in - Genprint.register_print0 Constrarg.wit_int_or_var + Genprint.register_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int; - Genprint.register_print0 Constrarg.wit_ref + Genprint.register_print0 wit_ref pr_reference (pr_or_var (pr_located pr_global)) pr_global; - Genprint.register_print0 Constrarg.wit_ident + Genprint.register_print0 wit_ident pr_id pr_id pr_id; - Genprint.register_print0 Constrarg.wit_var + Genprint.register_print0 wit_var (pr_located pr_id) (pr_located pr_id) pr_id; Genprint.register_print0 - Constrarg.wit_intro_pattern + wit_intro_pattern (Miscprint.pr_intro_pattern pr_constr_expr) (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c)) (Miscprint.pr_intro_pattern (fun c -> pr_constr (fst (run_delayed c)))); Genprint.register_print0 - Constrarg.wit_clause_dft_concl + wit_clause_dft_concl (pr_clauses (Some true) pr_lident) (pr_clauses (Some true) pr_lident) (pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id))) ; Genprint.register_print0 - Constrarg.wit_constr + wit_constr Ppconstr.pr_constr_expr (fun (c, _) -> Printer.pr_glob_constr c) Printer.pr_constr ; Genprint.register_print0 - Constrarg.wit_uconstr + wit_uconstr Ppconstr.pr_constr_expr (fun (c,_) -> Printer.pr_glob_constr c) Printer.pr_closed_glob ; Genprint.register_print0 - Constrarg.wit_open_constr + wit_open_constr Ppconstr.pr_constr_expr (fun (c, _) -> Printer.pr_glob_constr c) Printer.pr_constr ; - Genprint.register_print0 Constrarg.wit_red_expr + Genprint.register_print0 wit_red_expr (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)) - (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) + (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_and_constr_expr pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) (pr_red_expr (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern)); - Genprint.register_print0 Constrarg.wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; - Genprint.register_print0 Constrarg.wit_bindings + Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; + Genprint.register_print0 wit_bindings (pr_bindings_no_with pr_constr_expr pr_lconstr_expr) (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) (fun it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it))); - Genprint.register_print0 Constrarg.wit_constr_with_bindings + Genprint.register_print0 wit_constr_with_bindings (pr_with_bindings pr_constr_expr pr_lconstr_expr) (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) (fun it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it))); - Genprint.register_print0 Constrarg.wit_destruction_arg + Genprint.register_print0 Tacarg.wit_destruction_arg (pr_destruction_arg pr_constr_expr pr_lconstr_expr) (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) (fun it -> pr_destruction_arg pr_constr pr_lconstr (run_delayed_destruction_arg it)); @@ -1463,16 +1345,17 @@ module Richpp = struct include Make (Ppconstr.Richpp) (struct open Ppannotation + open Genarg let do_not_tag _ x = x let tag e s = Pp.tag (Pp.Tag.inj e tag) s let tag_keyword = tag AKeyword let tag_primitive = tag AKeyword let tag_string = do_not_tag () - let tag_glob_tactic_expr e = tag (AGlobTacticExpr e) - let tag_glob_atomic_tactic_expr a = tag (AGlobAtomicTacticExpr a) - let tag_raw_tactic_expr e = tag (ARawTacticExpr e) - let tag_raw_atomic_tactic_expr a = tag (ARawAtomicTacticExpr a) - let tag_atomic_tactic_expr a = tag (AAtomicTacticExpr a) + let tag_glob_tactic_expr e = tag (AGlbGenArg (in_gen (glbwit wit_ltac) e)) + let tag_glob_atomic_tactic_expr = do_not_tag + let tag_raw_tactic_expr e = tag (ARawGenArg (in_gen (rawwit wit_ltac) e)) + let tag_raw_atomic_tactic_expr = do_not_tag + let tag_atomic_tactic_expr = do_not_tag end) end diff --git a/printing/pptactic.mli b/ltac/pptactic.mli index 86e3ea548..86e3ea548 100644 --- a/printing/pptactic.mli +++ b/ltac/pptactic.mli diff --git a/printing/pptacticsig.mli b/ltac/pptacticsig.mli index 665e055f2..74ddd377a 100644 --- a/printing/pptacticsig.mli +++ b/ltac/pptacticsig.mli @@ -25,9 +25,7 @@ module type Pp = sig ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds - val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds - val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds val pr_in_clause : ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml index 4d7c5d0e4..217f5f42e 100644 --- a/ltac/rewrite.ml +++ b/ltac/rewrite.ml @@ -36,6 +36,9 @@ open Sigma.Notations open Proofview.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration +module RelDecl = Context.Rel.Declaration + (** Typeclass-based generalized rewriting. *) (** Constants used by the tactic. *) @@ -1499,7 +1502,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul Evar.Set.fold (fun ev acc -> if not (Evd.is_defined acc ev) then - errorlabstrm "rewrite" + user_err ~hdr:"rewrite" (str "Unsolved constraint remaining: " ++ spc () ++ Evd.pr_evar_info (Evd.find acc ev)) else Evd.remove acc ev) @@ -1527,7 +1530,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul let rec insert_dependent env decl accu hyps = match hyps with | [] -> List.rev_append accu [decl] | ndecl :: rem -> - if occur_var_in_decl env (get_id ndecl) decl then + if occur_var_in_decl env (NamedDecl.get_id ndecl) decl then List.rev_append accu (decl :: hyps) else insert_dependent env decl (ndecl :: accu) rem @@ -1537,17 +1540,17 @@ let assert_replacing id newt tac = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let ctx = Environ.named_context env in - let after, before = List.split_when (Id.equal id % get_id) ctx in + let after, before = List.split_when (NamedDecl.get_id %> Id.equal id) ctx in let nc = match before with | [] -> assert false - | d :: rem -> insert_dependent env (LocalAssum (get_id d, newt)) [] after @ rem + | d :: rem -> insert_dependent env (LocalAssum (NamedDecl.get_id d, newt)) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Refine.refine ~unsafe:false { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in let map d = - let n = get_id d in + let n = NamedDecl.get_id d in if Id.equal n id then ev' else mkVar n in let (e, _) = destEvar ev in @@ -2121,9 +2124,8 @@ let setoid_proof ty fn fallback = begin try let rel, _, _ = decompose_app_rel env sigma concl in - let open Context.Rel.Declaration in let (sigma, t) = Typing.type_of env sigma rel in - let car = get_type (List.hd (fst (Reduction.dest_prod env t))) in + let car = RelDecl.get_type (List.hd (fst (Reduction.dest_prod env t))) in (try init_relation_classes () with _ -> raise Not_found); fn env sigma car rel with e -> Proofview.tclZERO e diff --git a/ltac/tacarg.ml b/ltac/tacarg.ml new file mode 100644 index 000000000..42552c484 --- /dev/null +++ b/ltac/tacarg.ml @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Generic arguments based on Ltac. *) + +open Genarg +open Geninterp +open Tacexpr + +let make0 ?dyn name = + let wit = Genarg.make0 name in + let () = Geninterp.register_val0 wit dyn in + wit + +let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = + make0 "tactic" + +let wit_ltac = make0 ~dyn:(val_tag (topwit Stdarg.wit_unit)) "ltac" + +let wit_destruction_arg = + make0 "destruction_arg" diff --git a/ltac/tacarg.mli b/ltac/tacarg.mli new file mode 100644 index 000000000..bfa423db2 --- /dev/null +++ b/ltac/tacarg.mli @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Genarg +open Tacexpr +open Constrexpr +open Misctypes + +(** Generic arguments based on Ltac. *) + +val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Geninterp.Val.t) genarg_type + +(** [wit_ltac] is subtly different from [wit_tactic]: they only change for their + toplevel interpretation. The one of [wit_ltac] forces the tactic and + discards the result. *) +val wit_ltac : (raw_tactic_expr, glob_tactic_expr, unit) genarg_type + +val wit_destruction_arg : + (constr_expr with_bindings Tacexpr.destruction_arg, + glob_constr_and_expr with_bindings Tacexpr.destruction_arg, + delayed_open_constr_with_bindings Tacexpr.destruction_arg) genarg_type + diff --git a/ltac/taccoerce.ml b/ltac/taccoerce.ml index b0a80ef73..df38a42cb 100644 --- a/ltac/taccoerce.ml +++ b/ltac/taccoerce.ml @@ -13,7 +13,6 @@ open Pattern open Misctypes open Genarg open Stdarg -open Constrarg open Geninterp exception CannotCoerceTo of string diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml index 673ac832a..2e2b55be7 100644 --- a/ltac/tacentries.ml +++ b/ltac/tacentries.ml @@ -43,8 +43,8 @@ let coincide s pat off = !break let atactic n = - if n = 5 then Aentry Tactic.binder_tactic - else Aentryl (Tactic.tactic_expr, n) + if n = 5 then Aentry Pltac.binder_tactic + else Aentryl (Pltac.tactic_expr, n) type entry_name = EntryName : 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name @@ -56,9 +56,9 @@ let get_tacentry n m = && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) in - if check_lvl n then EntryName (rawwit Constrarg.wit_tactic, Aself) - else if check_lvl (n + 1) then EntryName (rawwit Constrarg.wit_tactic, Anext) - else EntryName (rawwit Constrarg.wit_tactic, atactic n) + if check_lvl n then EntryName (rawwit Tacarg.wit_tactic, Aself) + else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Anext) + else EntryName (rawwit Tacarg.wit_tactic, atactic n) let get_separator = function | None -> error "Missing separator." @@ -108,11 +108,11 @@ let interp_entry_name interp symb = let get_tactic_entry n = if Int.equal n 0 then - Tactic.simple_tactic, None + Pltac.simple_tactic, None else if Int.equal n 5 then - Tactic.binder_tactic, None + Pltac.binder_tactic, None else if 1<=n && n<5 then - Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) + Pltac.tactic_expr, Some (Extend.Level (string_of_int n)) else error ("Invalid Tactic Notation level: "^(string_of_int n)^".") @@ -163,7 +163,7 @@ let add_tactic_entry (kn, ml, tg) state = let mkact loc l = let map arg = (** HACK to handle especially the tactic(...) entry *) - let wit = Genarg.rawwit Constrarg.wit_tactic in + let wit = Genarg.rawwit Tacarg.wit_tactic in if Genarg.has_type arg wit && not ml then Tacexp (Genarg.out_gen wit arg) else @@ -218,7 +218,7 @@ let interp_prod_item = function | Some n -> (** FIXME: do better someday *) assert (String.equal s "tactic"); - begin match Constrarg.wit_tactic with + begin match Tacarg.wit_tactic with | ExtraArg tag -> ArgT.Any tag | _ -> assert false end @@ -405,7 +405,7 @@ let create_ltac_quotation name cast (e, l) = in let action _ v _ _ _ loc = cast (loc, v) in let gram = (level, assoc, [Rule (rule, action)]) in - Pcoq.grammar_extend Tactic.tactic_arg None (None, [gram]) + Pcoq.grammar_extend Pltac.tactic_arg None (None, [gram]) (** Command *) @@ -425,29 +425,29 @@ let warn_unusable_identifier = let register_ltac local tacl = let map tactic_body = match tactic_body with - | TacticDefinition ((loc,id), body) -> + | Tacexpr.TacticDefinition ((loc,id), body) -> let kn = Lib.make_kn id in let id_pp = pr_id id in let () = if is_defined_tac kn then - CErrors.user_err_loc (loc, "", - str "There is already an Ltac named " ++ id_pp ++ str".") + CErrors.user_err ~loc + (str "There is already an Ltac named " ++ id_pp ++ str".") in let is_shadowed = try - match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with + match Pcoq.parse_string Pltac.tactic (Id.to_string id) with | Tacexpr.TacArg _ -> false | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) with e when CErrors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) in let () = if is_shadowed then warn_unusable_identifier id in NewTac id, body - | TacticRedefinition (ident, body) -> + | Tacexpr.TacticRedefinition (ident, body) -> let loc = loc_of_reference ident in let kn = try Nametab.locate_tactic (snd (qualid_of_reference ident)) with Not_found -> - CErrors.user_err_loc (loc, "", - str "There is no Ltac named " ++ pr_reference ident ++ str ".") + CErrors.user_err ~loc + (str "There is no Ltac named " ++ pr_reference ident ++ str ".") in UpdateTac kn, body in @@ -511,3 +511,15 @@ let print_ltacs () = hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) in Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) + +(** Grammar *) + +let () = + let open Metasyntax in + let entries = [ + AnyEntry Pltac.tactic_expr; + AnyEntry Pltac.binder_tactic; + AnyEntry Pltac.simple_tactic; + AnyEntry Pltac.tactic_arg; + ] in + register_grammar "tactic" entries diff --git a/ltac/tacentries.mli b/ltac/tacentries.mli index 27df819ee..969c118fb 100644 --- a/ltac/tacentries.mli +++ b/ltac/tacentries.mli @@ -13,7 +13,7 @@ open Tacexpr (** {5 Tactic Definitions} *) -val register_ltac : locality_flag -> Vernacexpr.tacdef_body list -> unit +val register_ltac : locality_flag -> Tacexpr.tacdef_body list -> unit (** Adds new Ltac definitions to the environment. *) (** {5 Tactic Notations} *) diff --git a/ltac/tacenv.ml b/ltac/tacenv.ml index c709ab114..e3c2b4ad5 100644 --- a/ltac/tacenv.ml +++ b/ltac/tacenv.ml @@ -65,7 +65,7 @@ let interp_ml_tactic { mltac_name = s; mltac_index = i } = let () = if Array.length tacs <= i then raise Not_found in tacs.(i) with Not_found -> - CErrors.errorlabstrm "" + CErrors.user_err (str "The tactic " ++ pr_tacname s ++ str " is not installed.") (***************************************************************************) diff --git a/intf/tacexpr.mli b/ltac/tacexpr.mli index 5b5957bef..9c25a1645 100644 --- a/intf/tacexpr.mli +++ b/ltac/tacexpr.mli @@ -32,15 +32,13 @@ type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) -type debug = Debug | Info | Off (* for trivial / auto / eauto ... *) - -type goal_selector = +type goal_selector = Vernacexpr.goal_selector = | SelectNth of int | SelectList of (int * int) list | SelectId of Id.t | SelectAll -type 'a core_destruction_arg = +type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg = | ElimOnConstr of 'a | ElimOnIdent of Id.t located | ElimOnAnonHyp of int @@ -48,7 +46,7 @@ type 'a core_destruction_arg = type 'a destruction_arg = clear_flag * 'a core_destruction_arg -type inversion_kind = +type inversion_kind = Misctypes.inversion_kind = | SimpleInversion | FullInversion | FullInversionClear @@ -79,12 +77,6 @@ type ('constr,'dconstr,'id) induction_clause_list = type 'a with_bindings_arg = clear_flag * 'a with_bindings -type multi = - | Precisely of int - | UpTo of int - | RepeatStar - | RepeatPlus - (* Type of patterns *) type 'a match_pattern = | Term of 'a @@ -117,18 +109,15 @@ type ml_tactic_entry = { (** Composite types *) -(** In globalize tactics, we need to keep the initial [constr_expr] to recompute - in the environment by the effective calls to Intro, Inversion, etc - The [constr_expr] field is [None] in TacDef though *) -type glob_constr_and_expr = Glob_term.glob_constr * constr_expr option +type glob_constr_and_expr = Tactypes.glob_constr_and_expr type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr -type binding_bound_vars = Id.Set.t +type binding_bound_vars = Constr_matching.binding_bound_vars type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * constr_pattern -type 'a delayed_open = 'a Pretyping.delayed_open = +type 'a delayed_open = 'a Tactypes.delayed_open = { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open @@ -401,3 +390,7 @@ type ltac_call_kind = | LtacConstrInterp of Glob_term.glob_constr * Pretyping.ltac_var_map type ltac_trace = (Loc.t * ltac_call_kind) list + +type tacdef_body = + | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) + | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) diff --git a/ltac/tacintern.ml b/ltac/tacintern.ml index c5bb0ed07..763e0dc22 100644 --- a/ltac/tacintern.ml +++ b/ltac/tacintern.ml @@ -23,7 +23,8 @@ open Constrexpr open Termops open Tacexpr open Genarg -open Constrarg +open Stdarg +open Tacarg open Misctypes open Locus @@ -32,11 +33,8 @@ open Locus let dloc = Loc.ghost -let error_global_not_found_loc (loc,qid) = - error_global_not_found_loc loc qid - -let error_tactic_expected loc = - user_err_loc (loc,"",str "Tactic expected.") +let error_tactic_expected ?loc = + user_err ?loc (str "Tactic expected.") (** Generic arguments *) @@ -85,7 +83,7 @@ let intern_hyp ist (loc,id as locid) = else if find_ident id ist then (dloc,id) else - Pretype_errors.error_var_not_found_loc loc id + Pretype_errors.error_var_not_found ~loc id let intern_or_var f ist = function | ArgVar locid -> ArgVar (intern_hyp ist locid) @@ -99,7 +97,7 @@ let intern_global_reference ist = function | r -> let loc,_ as lqid = qualid_of_reference r in try ArgArg (loc,locate_global_with_alias lqid) - with Not_found -> error_global_not_found_loc lqid + with Not_found -> error_global_not_found (snd lqid) let intern_ltac_variable ist = function | Ident (loc,id) -> @@ -143,7 +141,7 @@ let intern_isolated_tactic_reference strict ist r = try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) with Not_found -> (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) + error_global_not_found (snd (qualid_of_reference r)) (* Internalize an applied tactic reference *) @@ -159,7 +157,7 @@ let intern_applied_tactic_reference ist r = try intern_applied_global_tactic_reference r with Not_found -> (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) + error_global_not_found (snd (qualid_of_reference r)) (* Intern a reference parsed in a non-tactic entry *) @@ -180,7 +178,7 @@ let intern_non_tactic_reference strict ist r = TacGeneric ipat | _ -> (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) + error_global_not_found (snd (qualid_of_reference r)) let intern_message_token ist = function | (MsgString _ | MsgInt _ as x) -> x @@ -291,7 +289,7 @@ let intern_evaluable_global_reference ist r = with Not_found -> match r with | Ident (loc,id) when not !strict_check -> EvalVarRef id - | _ -> error_global_not_found_loc lqid + | _ -> error_global_not_found (snd lqid) let intern_evaluable_reference_or_by_notation ist = function | AN r -> intern_evaluable_global_reference ist r @@ -463,8 +461,8 @@ let rec intern_match_goal_hyps ist ?(as_type=false) lfun = function (* Utilities *) let extract_let_names lrc = let fold accu ((loc, name), _) = - if Id.Set.mem name accu then user_err_loc - (loc, "glob_tactic", str "This variable is bound several times.") + if Id.Set.mem name accu then user_err ~loc + ~hdr:"glob_tactic" (str "This variable is bound several times.") else Id.Set.add name accu in List.fold_left fold Id.Set.empty lrc @@ -641,7 +639,7 @@ and intern_tactic_as_arg loc onlytac ist a = | TacGeneric _ as a -> TacArg (loc,a) | Tacexp a -> a | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> - if onlytac then error_tactic_expected loc else TacArg (loc,a) + if onlytac then error_tactic_expected ~loc else TacArg (loc,a) and intern_tactic_or_tacarg ist = intern_tactic false ist @@ -751,7 +749,7 @@ let print_ltac id = ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined with Not_found -> - errorlabstrm "print_ltac" + user_err ~hdr:"print_ltac" (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") (** Registering *) @@ -778,13 +776,16 @@ let intern_ident' ist id = let lf = ref Id.Set.empty in (ist, intern_ident lf ist id) +let intern_ltac ist tac = + Flags.with_option strict_check (fun () -> intern_pure_tactic ist tac) () + let () = Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); Genintern.register_intern0 wit_ref (lift intern_global_reference); Genintern.register_intern0 wit_ident intern_ident'; Genintern.register_intern0 wit_var (lift intern_hyp); Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); - Genintern.register_intern0 wit_ltac (lift intern_tactic_or_tacarg); + Genintern.register_intern0 wit_ltac (lift intern_ltac); Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c)); Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); @@ -795,15 +796,17 @@ let () = Genintern.register_intern0 wit_destruction_arg (lift intern_destruction_arg); () -(***************************************************************************) -(* Backwarding recursive needs of tactic glob/interp/eval functions *) +(** Substitution for notations containing tactic-in-terms *) -let _ = - let f l = - let ltacvars = - List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l - in - Flags.with_option strict_check - (intern_pure_tactic { (make_empty_glob_sign()) with ltacvars }) +let notation_subst bindings tac = + let fold id c accu = + let loc = Glob_ops.loc_of_glob_constr (fst c) in + let c = ConstrMayEval (ConstrTerm c) in + ((loc, id), c) :: accu in - Hook.set Hints.extern_intern_tac f + let bindings = Id.Map.fold fold bindings [] in + (** This is theoretically not correct due to potential variable capture, but + Ltac has no true variables so one cannot simply substitute *) + TacLetIn (false, bindings, tac) + +let () = Genintern.register_ntn_subst0 wit_tactic notation_subst diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml index 52208979c..e927ea064 100644 --- a/ltac/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -31,7 +31,7 @@ open Tacexpr open Genarg open Geninterp open Stdarg -open Constrarg +open Tacarg open Printer open Pretyping open Misctypes @@ -168,7 +168,7 @@ module Value = struct let pr_v = Pptactic.pr_value Pptactic.ltop v in let Val.Dyn (tag, _) = v in let tag = Val.pr tag in - errorlabstrm "" (str "Type error: value " ++ pr_v ++ str " is a " ++ tag + user_err (str "Type error: value " ++ pr_v ++ str " is a " ++ tag ++ str " while type " ++ Val.pr wit ++ str " was expected.") let unbox wit v ans = match ans with @@ -315,8 +315,8 @@ let append_trace trace v = (* Dynamically check that an argument is a tactic *) let coerce_to_tactic loc id v = let v = Value.normalize v in - let fail () = user_err_loc - (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") + let fail () = user_err ~loc + (str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") in let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then @@ -371,7 +371,7 @@ let debugging_exception_step ist signal_anomaly e pp = pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) let error_ltac_variable loc id env v s = - user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ + user_err ~loc (str "Ltac variable " ++ pr_id id ++ strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ strbrk "which cannot be coerced to " ++ str s ++ str".") @@ -388,8 +388,6 @@ let interp_ident ist env sigma id = try try_interp_ltac_var (coerce_var_to_ident false env) ist (Some (env,sigma)) (dloc,id) with Not_found -> id -let pf_interp_ident id gl = interp_ident id (pf_env gl) (project gl) - (* Interprets an optional identifier, bound or fresh *) let interp_name ist env sigma = function | Anonymous -> Anonymous @@ -406,8 +404,8 @@ let interp_intro_pattern_naming_var loc ist env sigma id = let interp_int ist locid = try try_interp_ltac_var coerce_to_int ist None locid with Not_found -> - user_err_loc(fst locid,"interp_int", - str "Unbound variable " ++ pr_id (snd locid) ++ str".") + user_err ~loc:(fst locid) ~hdr:"interp_int" + (str "Unbound variable " ++ pr_id (snd locid) ++ str".") let interp_int_or_var ist = function | ArgVar locid -> interp_int ist locid @@ -429,7 +427,7 @@ let interp_hyp ist env sigma (loc,id as locid) = with Not_found -> (* Then look if bound in the proof context at calling time *) if is_variable env id then id - else Loc.raise loc (Logic.RefinerError (Logic.NoSuchHyp id)) + else Loc.raise ~loc (Logic.RefinerError (Logic.NoSuchHyp id)) let interp_hyp_list_as_list ist env sigma (loc,id as x) = try coerce_to_hyp_list env (Id.Map.find id ist.lfun) @@ -451,7 +449,7 @@ let interp_reference ist env sigma = function with Not_found -> try VarRef (get_id (Environ.lookup_named id env)) - with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) + with Not_found -> error_global_not_found ~loc (qualid_of_ident id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in @@ -467,14 +465,14 @@ let interp_evaluable ist env sigma = function with Not_found -> match r with | EvalConstRef _ -> r - | _ -> error_global_not_found_loc loc (qualid_of_ident id) + | _ -> error_global_not_found ~loc (qualid_of_ident id) end | ArgArg (r,None) -> r | ArgVar (loc, id) -> try try_interp_ltac_var (coerce_to_evaluable_ref env) ist (Some (env,sigma)) (loc, id) with Not_found -> try try_interp_evaluable env (loc, id) - with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) + with Not_found -> error_global_not_found ~loc (qualid_of_ident id) (* Interprets an hypothesis name *) let interp_occurrences ist occs = @@ -696,9 +694,6 @@ let interp_typed_pattern ist env sigma (_,c,_) = pattern_of_constr env sigma c (* Interprets a constr expression *) -let pf_interp_constr ist gl = - interp_constr ist (pf_env gl) (project gl) - let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = let try_expand_ltac_var sigma x = try match dest_fun x with @@ -720,10 +715,6 @@ let interp_constr_list ist env sigma c = let interp_open_constr_list = interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr -(* Interprets a type expression *) -let pf_interp_type ist env sigma = - interp_type ist env sigma - (* Interprets a reduction expression *) let interp_unfold ist env sigma (occs,qid) = (interp_occurrences ist occs,interp_evaluable ist env sigma qid) @@ -748,7 +739,7 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = Inr (pattern_of_constr env sigma c) in (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) with Not_found -> - error_global_not_found_loc loc (qualid_of_ident id)) + error_global_not_found ~loc (qualid_of_ident id)) | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p @@ -804,8 +795,8 @@ let interp_may_eval f ist env sigma = function !evdref , c with | Not_found -> - user_err_loc (loc, "interp_may_eval", - str "Unbound context identifier" ++ pr_id s ++ str".")) + user_err ~loc ~hdr:"interp_may_eval" + (str "Unbound context identifier" ++ pr_id s ++ str".")) | ConstrTypeOf c -> let (sigma,c_interp) = f ist env sigma c in Typing.type_of ~refresh:true env sigma c_interp @@ -1044,8 +1035,8 @@ let interp_destruction_arg ist gl arg = } | keep,ElimOnAnonHyp n as x -> x | keep,ElimOnIdent (loc,id) -> - let error () = user_err_loc (loc, "", - strbrk "Cannot coerce " ++ pr_id id ++ + let error () = user_err ~loc + (strbrk "Cannot coerce " ++ pr_id id ++ strbrk " neither to a quantified hypothesis nor to a term.") in let try_cast_id id' = @@ -1055,7 +1046,7 @@ let interp_destruction_arg ist gl arg = (keep, ElimOnConstr { delayed = begin fun env sigma -> try Sigma.here (constr_of_id env id', NoBindings) sigma with Not_found -> - user_err_loc (loc, "interp_destruction_arg", + user_err ~loc ~hdr:"interp_destruction_arg" ( pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") end }) in @@ -1123,7 +1114,7 @@ let read_pattern lfun ist env sigma = function (* Reads the hypotheses of a Match Context rule *) let cons_and_check_name id l = if Id.List.mem id l then - user_err_loc (dloc,"read_match_goal_hyps", + user_err ~hdr:"read_match_goal_hyps" ( str "Hypothesis pattern-matching variable " ++ pr_id id ++ str " used twice in the same pattern.") else id::l @@ -1223,7 +1214,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with end | TacAbstract (tac,ido) -> Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT - (Option.map (pf_interp_ident ist gl) ido) (interp_tactic ist tac) + (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac) end } | TacThen (t1,t) -> Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) @@ -1709,7 +1700,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = - let (sigma,c_interp) = pf_interp_type ist env sigma c in + let (sigma,c_interp) = interp_type ist env sigma c in sigma , (interp_ident ist env sigma id,n,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) @@ -1724,7 +1715,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = pf_env gl in let f sigma (id,c) = - let (sigma,c_interp) = pf_interp_type ist env sigma c in + let (sigma,c_interp) = interp_type ist env sigma c in sigma , (interp_ident ist env sigma id,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) @@ -1766,7 +1757,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in if Locusops.is_nowhere clp then (* We try to fully-typecheck the term *) - let (sigma,c_interp) = pf_interp_constr ist gl c in + let (sigma,c_interp) = interp_constr ist env sigma c in let let_tac b na c cl eqpat = let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in @@ -1879,7 +1870,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let (sigma, c) = interp_constr ist env sigma c in Sigma.Unsafe.of_pair (c, sigma) with e when to_catch e (* Hack *) -> - errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") + user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") end } in Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) end } @@ -1914,7 +1905,7 @@ and interp_atomic ist tac : unit Proofview.tactic = match c with | None -> sigma , None | Some c -> - let (sigma,c_interp) = pf_interp_constr ist gl c in + let (sigma,c_interp) = interp_constr ist env sigma c in sigma , Some c_interp in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in @@ -1981,7 +1972,6 @@ let interp_tac_gen lfun avoid_ids debug t = end } let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t -let _ = Proof_global.set_interp_tac interp (* Used to hide interpretation for pretty-print, now just launch tactics *) (* [global] means that [t] should be internalized outside of goals. *) diff --git a/ltac/tacsubst.ml b/ltac/tacsubst.ml index cce4382c2..55de58361 100644 --- a/ltac/tacsubst.ml +++ b/ltac/tacsubst.ml @@ -10,7 +10,8 @@ open Util open Tacexpr open Mod_subst open Genarg -open Constrarg +open Stdarg +open Tacarg open Misctypes open Globnames open Term diff --git a/tactics/tactic_matching.ml b/ltac/tactic_matching.ml index 004492e78..ef45ee47e 100644 --- a/tactics/tactic_matching.ml +++ b/ltac/tactic_matching.ml @@ -13,6 +13,8 @@ open Names open Tacexpr open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + (** [t] is the type of matching successes. It ultimately contains a {!Tacexpr.glob_tactic_expr} representing the left-hand side of the corresponding matching rule, a matching substitution to be @@ -103,7 +105,7 @@ let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = (merged, Id.Map.merge merge lcm lm) let matching_error = - CErrors.UserError ("tactic matching" , Pp.str "No matching clauses for match.") + CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") let imatching_error = (matching_error, Exninfo.null) @@ -280,9 +282,9 @@ module PatternMatching (E:StaticEnvironment) = struct the name of the matched hypothesis. *) let hyp_match_type hypname pat hyps = pick hyps >>= fun decl -> - let id = get_id decl in + let id = NamedDecl.get_id decl in let refresh = is_local_def decl in - pattern_match_term refresh pat (get_type decl) () <*> + pattern_match_term refresh pat (NamedDecl.get_type decl) () <*> put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> return id @@ -319,7 +321,7 @@ module PatternMatching (E:StaticEnvironment) = struct (* spiwack: alternatively it is possible to return the list with the matched hypothesis removed directly in [hyp_match]. *) - let select_matched_hyp decl = Id.equal (get_id decl) matched_hyp in + let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in let hyps = CList.remove_first select_matched_hyp hyps in hyp_pattern_list_match pats hyps lhs | [] -> return lhs diff --git a/tactics/tactic_matching.mli b/ltac/tactic_matching.mli index 090207bcc..090207bcc 100644 --- a/tactics/tactic_matching.mli +++ b/ltac/tactic_matching.mli diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 79771f3f6..8e12e4525 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -110,7 +110,7 @@ module Error = struct end open Error -let err loc str = Loc.raise (Compat.to_coqloc loc) (Error.E str) +let err loc str = Loc.raise ~loc:(Compat.to_coqloc loc) (Error.E str) let bad_token str = raise (Error.E (Bad_token str)) diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index befa0d01b..4a36af2d8 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -218,7 +218,7 @@ module GrammarMake (L:LexerSig) : GrammarSig = struct L.drop_lexer_state (); let loc' = Loc.get_loc (Exninfo.info e) in let loc = match loc' with None -> to_coqloc loc | Some loc -> loc in - Loc.raise loc e + Loc.raise ~loc e let with_parsable (p,state) f x = L.set_lexer_state !state; try @@ -253,7 +253,7 @@ end module GrammarMake (L:LexerSig) : GrammarSig = struct (* We need to refer to Coq's module Loc before it is hidden by include *) - let raise_coq_loc loc e = Loc.raise (to_coqloc loc) e + let raise_coq_loc loc e = Loc.raise ~loc:(to_coqloc loc) e include Camlp4.Struct.Grammar.Static.Make (L) type 'a entry = 'a Entry.t type action = Action.t diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index a292c7463..07e4ddf84 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -71,7 +71,7 @@ let error_level_assoc p current expected = | Extend.LeftA -> str "left" | Extend.RightA -> str "right" | Extend.NonA -> str "non" in - errorlabstrm "" + user_err (str "Level " ++ int p ++ str " is already declared " ++ pr_assoc current ++ str " associative while it is now expected to be " ++ pr_assoc expected ++ str " associative.") @@ -434,7 +434,7 @@ let make_act : type r. r target -> _ -> r gen_eval = function CNotation (loc, notation , env) | ForPattern -> fun notation loc env -> let invalid = List.exists (fun (_, b) -> not b) env.binders in - let () = if invalid then Topconstr.error_invalid_pattern_notation loc in + let () = if invalid then Topconstr.error_invalid_pattern_notation ~loc () in let env = (env.constrs, env.constrlists) in CPatNotation (loc, notation, env, []) diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 7f3a3d10c..47455f984 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -55,9 +55,9 @@ let mk_fixb (id,bl,ann,body,(loc,tyc)) = let mk_cofixb (id,bl,ann,body,(loc,tyc)) = let _ = Option.map (fun (aloc,_) -> - CErrors.user_err_loc - (aloc,"Constr:mk_cofixb", - Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in + CErrors.user_err ~loc:aloc + ~hdr:"Constr:mk_cofixb" + (Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in let ty = match tyc with Some ty -> ty | None -> CHole (loc, None, IntroAnonymous, None) in @@ -215,9 +215,6 @@ GEXTEND Gram CGeneralization (!@loc, Implicit, None, c) | "`("; c = operconstr LEVEL "200"; ")" -> CGeneralization (!@loc, Explicit, None, c) - | IDENT "ltac"; ":"; "("; tac = Tactic.tactic_expr; ")" -> - let arg = Genarg.in_gen (Genarg.rawwit Constrarg.wit_tactic) tac in - CHole (!@loc, None, IntroAnonymous, Some arg) ] ] ; record_declaration: @@ -380,14 +377,14 @@ GEXTEND Gram [ p = pattern; lp = LIST1 NEXT -> (match p with | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, None, lp) - | CPatCstr (_, r, None, l2) -> CErrors.user_err_loc - (cases_pattern_expr_loc p, "compound_pattern", - Pp.str "Nested applications not supported.") + | CPatCstr (_, r, None, l2) -> CErrors.user_err + ~loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" + (Pp.str "Nested applications not supported.") | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp) | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp) - | _ -> CErrors.user_err_loc - (cases_pattern_expr_loc p, "compound_pattern", - Pp.str "Such pattern cannot have arguments.")) + | _ -> CErrors.user_err + ~loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" + (Pp.str "Such pattern cannot have arguments.")) |"@"; r = Prim.reference; lp = LIST0 NEXT -> CPatCstr (!@loc, r, Some lp, []) ] | "1" LEFTA diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index b90e06cd3..820514b08 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -28,7 +28,7 @@ let my_int_of_string loc s = if n > 1024 * 2048 then raise Exit; n with Failure _ | Exit -> - CErrors.user_err_loc (loc,"",Pp.str "Cannot support a so large number.") + CErrors.user_err ~loc (Pp.str "Cannot support a so large number.") GEXTEND Gram GLOBAL: @@ -93,7 +93,7 @@ GEXTEND Gram ; ne_string: [ [ s = STRING -> - if s="" then CErrors.user_err_loc(!@loc, "", Pp.str"Empty string."); s + if s="" then CErrors.user_err ~loc:(!@loc) (Pp.str"Empty string."); s ] ] ; ne_lstring: diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 1e3c4b880..2adbf300e 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -13,7 +13,6 @@ open Misctypes open Tok open Pcoq -open Pcoq.Tactic open Pcoq.Prim open Pcoq.Constr open Pcoq.Vernac_ @@ -26,9 +25,11 @@ let hint_proof_using e = function | None -> None | Some s -> Some (Gram.entry_parse e (Gram.parsable (Stream.of_string s))) +let hint = Gram.entry_create "hint" + (* Proof commands *) GEXTEND Gram - GLOBAL: command; + GLOBAL: hint command; opt_hintbases: [ [ -> [] @@ -39,12 +40,6 @@ GEXTEND Gram | IDENT "Proof" -> VernacProof (None,hint_proof_using G_vernac.section_subset_expr None) | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn - | IDENT "Proof"; "with"; ta = tactic; - l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> - VernacProof (Some ta,hint_proof_using G_vernac.section_subset_expr l) - | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; - ta = OPT [ "with"; ta = tactic -> ta ] -> - VernacProof (ta,Some l) | IDENT "Proof"; c = lconstr -> VernacExactProof c | IDENT "Abort" -> VernacAbort None | IDENT "Abort"; IDENT "All" -> VernacAbortAll @@ -124,10 +119,7 @@ GEXTEND Gram | IDENT "Opaque"; lc = LIST1 global -> HintsTransparency (lc, false) | IDENT "Mode"; l = global; m = mode -> HintsMode (l, m) | IDENT "Unfold"; lqid = LIST1 global -> HintsUnfold lqid - | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc - | IDENT "Extern"; n = natural; c = OPT constr_pattern ; "=>"; - tac = tactic -> - HintsExtern (n,c,tac) ] ] + | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc ] ] ; constr_body: [ [ ":="; c = lconstr -> c diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index bc02a4621..cb521ec54 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -115,7 +115,7 @@ GEXTEND Gram | Some (SelectNth g) -> c (Some g) | None -> c None | _ -> - VernacError (UserError ("",str"Typing and evaluation commands, cannot be used with the \"all:\" selector.")) + VernacError (UserError (None,str"Typing and evaluation commands, cannot be used with the \"all:\" selector.")) end ] ] ; located_vernac: @@ -260,7 +260,7 @@ GEXTEND Gram ProveBody (bl, t) ] ] ; reduce: - [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r + [ [ IDENT "Eval"; r = red_expr; "in" -> Some r | -> None ] ] ; one_decl_notation: @@ -887,7 +887,7 @@ GEXTEND Gram VernacRemoveOption ([table], v) ]] ; query_command: (* TODO: rapprocher Eval et Check *) - [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr -> + [ [ IDENT "Eval"; r = red_expr; "in"; c = lconstr -> fun g -> VernacCheckMayEval (Some r, g, c) | IDENT "Compute"; c = lconstr -> fun g -> VernacCheckMayEval (Some (Genredexpr.CbvVm None), g, c) @@ -1044,7 +1044,7 @@ GEXTEND Gram (* registration of a custom reduction *) | IDENT "Declare"; IDENT "Reduction"; s = IDENT; ":="; - r = Tactic.red_expr -> + r = red_expr -> VernacDeclareReduction (s,r) ] ]; diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib index 8df519b56..05e2911c2 100644 --- a/parsing/highparsing.mllib +++ b/parsing/highparsing.mllib @@ -2,4 +2,3 @@ G_constr G_vernac G_prim G_proofs -G_tactic diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 9e9a7e723..9787af826 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -325,48 +325,6 @@ module Module = let module_type = Gram.entry_create "module_type" end -module Tactic = - struct - (* Main entry for extensions *) - let simple_tactic = Gram.entry_create "tactic:simple_tactic" - - (* Entries that can be referred via the string -> Gram.entry table *) - (* Typically for tactic user extensions *) - let open_constr = - make_gen_entry utactic "open_constr" - let constr_with_bindings = - make_gen_entry utactic "constr_with_bindings" - let bindings = - make_gen_entry utactic "bindings" - let hypident = Gram.entry_create "hypident" - let constr_may_eval = make_gen_entry utactic "constr_may_eval" - let constr_eval = make_gen_entry utactic "constr_eval" - let uconstr = - make_gen_entry utactic "uconstr" - let quantified_hypothesis = - make_gen_entry utactic "quantified_hypothesis" - let destruction_arg = make_gen_entry utactic "destruction_arg" - let int_or_var = make_gen_entry utactic "int_or_var" - let red_expr = make_gen_entry utactic "red_expr" - let simple_intropattern = - make_gen_entry utactic "simple_intropattern" - let in_clause = make_gen_entry utactic "in_clause" - let clause_dft_concl = - make_gen_entry utactic "clause" - - - (* Main entries for ltac *) - let tactic_arg = Gram.entry_create "tactic:tactic_arg" - let tactic_expr = make_gen_entry utactic "tactic_expr" - let binder_tactic = make_gen_entry utactic "binder_tactic" - - let tactic = make_gen_entry utactic "tactic" - - (* Main entry for quotations *) - let tactic_eoi = eoi_entry tactic - - end - module Vernac_ = struct let gec_vernac s = Gram.entry_create ("vernac:" ^ s) @@ -379,6 +337,7 @@ module Vernac_ = let vernac = gec_vernac "Vernac.vernac" let vernac_eoi = eoi_entry vernac let rec_definition = gec_vernac "Vernac.rec_definition" + let red_expr = make_gen_entry utactic "red_expr" (* Main vernac entry *) let main_entry = Gram.entry_create "vernac" let noedit_mode = gec_vernac "noedit_command" @@ -500,27 +459,12 @@ let with_grammar_rule_protection f x = let () = let open Stdarg in - let open Constrarg in -(* Grammar.register0 wit_unit; *) -(* Grammar.register0 wit_bool; *) Grammar.register0 wit_int (Prim.integer); Grammar.register0 wit_string (Prim.string); Grammar.register0 wit_pre_ident (Prim.preident); - Grammar.register0 wit_int_or_var (Tactic.int_or_var); - Grammar.register0 wit_intro_pattern (Tactic.simple_intropattern); Grammar.register0 wit_ident (Prim.ident); Grammar.register0 wit_var (Prim.var); Grammar.register0 wit_ref (Prim.reference); - Grammar.register0 wit_quant_hyp (Tactic.quantified_hypothesis); Grammar.register0 wit_constr (Constr.constr); - Grammar.register0 wit_uconstr (Tactic.uconstr); - Grammar.register0 wit_open_constr (Tactic.open_constr); - Grammar.register0 wit_constr_with_bindings (Tactic.constr_with_bindings); - Grammar.register0 wit_bindings (Tactic.bindings); -(* Grammar.register0 wit_hyp_location_flag; *) - Grammar.register0 wit_red_expr (Tactic.red_expr); - Grammar.register0 wit_tactic (Tactic.tactic); - Grammar.register0 wit_ltac (Tactic.tactic); - Grammar.register0 wit_clause_dft_concl (Tactic.clause_dft_concl); - Grammar.register0 wit_destruction_arg (Tactic.destruction_arg); + Grammar.register0 wit_red_expr (Vernac_.red_expr); () diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 7f6caf63f..55868900a 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -12,7 +12,6 @@ open Extend open Vernacexpr open Genarg open Constrexpr -open Tacexpr open Libnames open Misctypes open Genredexpr @@ -178,30 +177,6 @@ module Module : val module_type : module_ast Gram.entry end -module Tactic : - sig - val open_constr : constr_expr Gram.entry - val constr_with_bindings : constr_expr with_bindings Gram.entry - val bindings : constr_expr bindings Gram.entry - val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry - val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry - val constr_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry - val uconstr : constr_expr Gram.entry - val quantified_hypothesis : quantified_hypothesis Gram.entry - val destruction_arg : constr_expr with_bindings destruction_arg Gram.entry - val int_or_var : int or_var Gram.entry - val red_expr : raw_red_expr Gram.entry - val simple_tactic : raw_tactic_expr Gram.entry - val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry - val in_clause : Names.Id.t Loc.located Locus.clause_expr Gram.entry - val clause_dft_concl : Names.Id.t Loc.located Locus.clause_expr Gram.entry - val tactic_arg : raw_tactic_arg Gram.entry - val tactic_expr : raw_tactic_expr Gram.entry - val binder_tactic : raw_tactic_expr Gram.entry - val tactic : raw_tactic_expr Gram.entry - val tactic_eoi : raw_tactic_expr Gram.entry - end - module Vernac_ : sig val gallina : vernac_expr Gram.entry @@ -213,6 +188,7 @@ module Vernac_ : val vernac_eoi : vernac_expr Gram.entry val noedit_mode : vernac_expr Gram.entry val command_entry : vernac_expr Gram.entry + val red_expr : raw_red_expr Gram.entry end (** The main entry: reads an optional vernac command *) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index fd46d8069..aedecc15c 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -23,7 +23,9 @@ open Pp open CErrors open Util open Proofview.Notations -open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration let reference dir s = lazy (Coqlib.gen_reference "CC" dir s) @@ -155,7 +157,7 @@ let rec quantified_atom_of_constr env sigma nrels term = let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else - quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma (succ nrels) ff + quantified_atom_of_constr (Environ.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma (succ nrels) ff | _ -> let patts=patterns_of_constr env sigma nrels term in `Rule patts @@ -170,7 +172,7 @@ let litteral_of_constr env sigma term= else begin try - quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma 1 ff + quantified_atom_of_constr (Environ.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end @@ -192,10 +194,10 @@ let make_prb gls depth additionnal_terms = ignore (add_term state t)) additionnal_terms; List.iter (fun decl -> - let (id,_,e) = Context.Named.Declaration.to_tuple decl in + let id = NamedDecl.get_id decl in begin let cid=mkVar id in - match litteral_of_constr env sigma e with + match litteral_of_constr env sigma (NamedDecl.get_type decl) with `Eq (t,a,b) -> add_equality state cid a b | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b | `Other ph -> @@ -456,7 +458,7 @@ let cc_tactic depth additionnal_terms = end } let cc_fail gls = - errorlabstrm "Congruence" (Pp.str "congruence failed.") + user_err ~hdr:"Congruence" (Pp.str "congruence failed.") let congruence_tac depth l = Tacticals.New.tclORELSE diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index 52a135119..6f6811334 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -10,7 +10,6 @@ open Cctac open Stdarg -open Constrarg DECLARE PLUGIN "cc_plugin" diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index a862423e9..f68c01b18 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -90,8 +90,8 @@ let rec add_vars_of_simple_pattern globs = function (* Loc.raise loc (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) | CPatOr (loc, _)-> - Loc.raise loc - (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) + Loc.raise ~loc + (UserError (Some "simple_pattern",str "\"(_ | _)\" is not allowed here")) | CPatDelimiters (_,_,p) -> add_vars_of_simple_pattern globs p | CPatCstr (_,_,pl1,pl2) -> @@ -328,7 +328,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = let _ = let expected = mib.Declarations.mind_nparams - num_params in if not (Int.equal (List.length params) expected) then - errorlabstrm "suppose it is" + user_err ~hdr:"suppose it is" (str "Wrong number of extra arguments: " ++ (if Int.equal expected 0 then str "none" else int expected) ++ spc () ++ str "expected.") in @@ -348,7 +348,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = Thesis (Plain) -> Glob_term.GSort(Loc.ghost,GProp) | Thesis (For rec_occ) -> if not (Id.List.mem rec_occ pat_vars) then - errorlabstrm "suppose it is" + user_err ~hdr:"suppose it is" (str "Variable " ++ Nameops.pr_id rec_occ ++ str " does not occur in pattern."); Glob_term.GSort(Loc.ghost,GProp) diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index d30fcf603..e19dc86c4 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -32,6 +32,9 @@ open Misctypes open Sigma.Notations open Context.Named.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (* Strictness option *) let clear ids { it = goal; sigma } = @@ -43,7 +46,7 @@ let clear ids { it = goal; sigma } = let (hyps, concl) = try Evarutil.clear_hyps_in_evi env evdref sign cl ids with Evarutil.ClearDependencyError (id, _) -> - errorlabstrm "" (str "Cannot clear " ++ pr_id id) + user_err (str "Cannot clear " ++ pr_id id) in let sigma = !evdref in let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in @@ -247,7 +250,7 @@ let close_previous_case pts = let filter_hyps f gls = let filter_aux id = - let id = get_id id in + let id = NamedDecl.get_id id in if f id then tclIDTAC else @@ -357,8 +360,7 @@ let enstack_subsubgoals env se stack gls= let nlast=succ last in let (llast,holes,metas) = meta_aux nlast (mkMeta nlast :: lenv) q in - let open Context.Rel.Declaration in - (llast,holes,(nlast,special_nf gls (substl lenv (get_type decl)))::metas) in + (llast,holes,(nlast,special_nf gls (substl lenv (RelDecl.get_type decl)))::metas) in let (nlast,holes,nmetas) = meta_aux se.se_last_meta [] (List.rev rc) in let refiner = applist (appterm,List.rev holes) in @@ -821,9 +823,8 @@ let define_tac id args body gls = let cast_tac id_or_thesis typ gls = match id_or_thesis with - This id -> - let body = pf_get_hyp gls id |> get_value in - Proofview.V82.of_tactic (convert_hyp (of_tuple (id,body,typ))) gls + | This id -> + Proofview.V82.of_tactic (id |> pf_get_hyp gls |> NamedDecl.set_id id |> NamedDecl.set_type typ |> convert_hyp) gls | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> @@ -1082,12 +1083,12 @@ let thesis_for obj typ per_info env= let cind,all_args=decompose_app typ in let ind,u = destInd cind in let _ = if not (eq_ind ind per_info.per_ind) then - errorlabstrm "thesis_for" + user_err ~hdr:"thesis_for" ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str"cannot give an induction hypothesis (wrong inductive type).") in let params,args = List.chop per_info.per_nparams all_args in let _ = if not (List.for_all2 eq_constr params per_info.per_params) then - errorlabstrm "thesis_for" + user_err ~hdr:"thesis_for" ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 6c17dcc4f..18a35c6cf 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -19,7 +19,7 @@ open Vernacexpr open Tok (* necessary for camlp4 *) open Pcoq.Constr -open Pcoq.Tactic +open Pltac open Ppdecl_proof let pr_goal gs = diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.ml4 index d4dc7e0ee..deadb3b4d 100644 --- a/plugins/derive/g_derive.ml4 +++ b/plugins/derive/g_derive.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Constrarg +open Stdarg (*i camlp4deps: "grammar/grammar.cma" i*) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 3c5f6cb72..9446cf667 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -145,7 +145,7 @@ type env = Id.t list * Id.Set.t (*s Generic renaming issues for local variable names. *) let rec rename_id id avoid = - if Id.Set.mem id avoid then rename_id (lift_subscript id) avoid else id + if Id.Set.mem id avoid then rename_id (increment_subscript id) avoid else id let rec rename_vars avoid = function | [] -> diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index 19fda4aea..e1d6bb4a8 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -14,7 +14,6 @@ DECLARE PLUGIN "extraction_plugin" open Genarg open Stdarg -open Constrarg open Pcoq.Prim open Pp open Names diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index ff66d915f..5e7d810c9 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -293,7 +293,7 @@ let pr_long_global ref = pr_path (Nametab.path_of_global ref) (*S Warning and Error messages. *) -let err s = errorlabstrm "Extraction" s +let err s = user_err ~hdr:"Extraction" s let warn_extraction_axiom_to_realize = CWarnings.create ~name:"extraction-axiom-to-realize" ~category:"extraction" diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 58744b575..b34a36492 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -15,7 +15,8 @@ open Tacmach open Util open Declarations open Globnames -open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration let qflag=ref true @@ -141,7 +142,7 @@ let build_atoms gl metagen side cciterm = end; let v = ind_hyps 0 i l gl in let g i _ decl = - build_rec env polarity (lift i (get_type decl)) in + build_rec env polarity (lift i (RelDecl.get_type decl)) in let f l = List.fold_left_i g (1-(List.length l)) () l in if polarity && (* we have a constant constructor *) @@ -152,7 +153,7 @@ let build_atoms gl metagen side cciterm = let var=mkMeta (metagen true) in let v =(ind_hyps 1 i l gl).(0) in let g i _ decl = - build_rec (var::env) polarity (lift i (get_type decl)) in + build_rec (var::env) polarity (lift i (RelDecl.get_type decl)) in List.fold_left_i g (2-(List.length l)) () v | Forall(_,b)-> let var=mkMeta (metagen true) in @@ -225,7 +226,7 @@ let build_formula side nam typ gl metagen= | And(_,_,_) -> Rand | Or(_,_,_) -> Ror | Exists (i,l) -> - let d = get_type (List.last (ind_hyps 0 i l gl).(0)) in + let d = RelDecl.get_type (List.last (ind_hyps 0 i l gl).(0)) in Rexists(m,d,trivial) | Forall (_,a) -> Rforall | Arrow (a,b) -> Rarrow in diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 95095b09c..344a04a6a 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -15,8 +15,8 @@ open Goptions open Tacticals open Tacinterp open Libnames -open Constrarg open Stdarg +open Tacarg open Pcoq.Prim DECLARE PLUGIN "ground_plugin" diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index ffb63af07..7ffc78928 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -19,7 +19,8 @@ open Formula open Sequent open Globnames open Locus -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic @@ -36,12 +37,12 @@ let wrap n b continue seq gls= match nc with []->anomaly (Pp.str "Not the expected number of hyps") | nd::q-> - let id = get_id nd in + let id = NamedDecl.get_id nd in if occur_var env id (pf_concl gls) || List.exists (occur_var_in_decl env id) ctx then (aux (i-1) q (nd::ctx)) else - add_formula Hyp (VarRef id) (get_type nd) (aux (i-1) q (nd::ctx)) gls in + add_formula Hyp (VarRef id) (NamedDecl.get_type nd) (aux (i-1) q (nd::ctx)) gls in let seq1=aux n nc [] in let seq2=if b then add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index b0ffc775b..527f4f0b1 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -16,6 +16,8 @@ open Libnames open Globnames open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (* let msgnl = Pp.msgnl *) (* @@ -307,7 +309,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = try let witness = Int.Map.find i sub in if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (Termops.pop end_of_type,ctxt_size,mkLetIn (get_name decl, witness, get_type decl, witness_fun)) + (Termops.pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) @@ -938,8 +940,8 @@ let generalize_non_dep hyp g = ((* observe_tac "thin" *) (thin to_revert)) g -let id_of_decl decl = Nameops.out_name (get_name decl) -let var_of_decl decl = mkVar (id_of_decl decl) +let id_of_decl = RelDecl.get_name %> Nameops.out_name +let var_of_decl = id_of_decl %> mkVar let revert idl = tclTHEN (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) @@ -1072,7 +1074,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (Name new_id) ) in - let fresh_decl = map_name fresh_id in + let fresh_decl = RelDecl.map_name fresh_id in let princ_info : elim_scheme = { princ_info with params = List.map fresh_decl princ_info.params; @@ -1119,11 +1121,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam ) in observe (str "full_params := " ++ - prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) + prlist_with_sep spc (RelDecl.get_name %> Nameops.out_name %> Ppconstr.pr_id) full_params ); observe (str "princ_params := " ++ - prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) + prlist_with_sep spc (RelDecl.get_name %> Nameops.out_name %> Ppconstr.pr_id) princ_params ); observe (str "fbody_with_full_params := " ++ @@ -1165,7 +1167,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let pte_to_fix,rev_info = List.fold_left_i (fun i (acc_map,acc_info) decl -> - let pte = get_name decl in + let pte = RelDecl.get_name decl in let infos = info_array.(i) in let type_args,_ = decompose_prod infos.types in let nargs = List.length type_args in @@ -1277,7 +1279,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (do_replace evd full_params (fix_info.idx + List.length princ_params) - (args_id@(List.map (fun decl -> Nameops.out_name (get_name decl)) princ_params)) + (args_id@(List.map (RelDecl.get_name %> Nameops.out_name) princ_params)) (all_funs.(fix_info.num_in_block)) fix_info.num_in_block all_funs @@ -1556,7 +1558,7 @@ let prove_principle_for_gen | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (fun decl -> mkVar (Nameops.out_name (get_name decl))) (pre_rec_arg@princ_info.params) in + let subst_constrs = List.map (get_name %> Nameops.out_name %> mkVar) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in @@ -1584,7 +1586,7 @@ let prove_principle_for_gen ) g in - let args_ids = List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.args in + let args_ids = List.map (get_name %> Nameops.out_name) princ_info.args in let lemma = match !tcc_lemma_ref with | None -> error "No tcc proof !!" @@ -1631,7 +1633,7 @@ let prove_principle_for_gen [ observe_tac "start_tac" start_tac; h_intros - (List.rev_map (fun decl -> Nameops.out_name (get_name decl)) + (List.rev_map (get_name %> Nameops.out_name) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by @@ -1669,7 +1671,7 @@ let prove_principle_for_gen in let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in let predicates_names = - List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.predicates + List.map (get_name %> Nameops.out_name) princ_info.predicates in let pte_info = { proving_tac = @@ -1685,7 +1687,7 @@ let prove_principle_for_gen is_mes acc_inv fix_id (!tcc_list@(List.map - (fun decl -> (Nameops.out_name (get_name decl))) + (get_name %> Nameops.out_name) (princ_info.args@princ_info.params) )@ ([acc_rec_arg_id])) eqs ) @@ -1714,7 +1716,7 @@ let prove_principle_for_gen (* observe_tac "instanciate_hyps_with_args" *) (instanciate_hyps_with_args make_proof - (List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.branches) + (List.map (get_name %> Nameops.out_name) princ_info.branches) (List.rev args_ids) ) gl' diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 5e72b8672..cc699e5d3 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -14,6 +14,8 @@ open Functional_principles_proofs open Misctypes open Sigma.Notations +module RelDecl = Context.Rel.Declaration + exception Toberemoved_with_rel of int*constr exception Toberemoved @@ -38,7 +40,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | Name x -> let id = Namegen.next_ident_away x avoid in Hashtbl.add tbl id x; - set_name (Name id) decl :: change_predicates_names (id::avoid) predicates + RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates | Anonymous -> anomaly (Pp.str "Anonymous property binder ")) in let avoid = (Termops.ids_of_context env_with_params ) in @@ -51,7 +53,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod (get_type decl) in + let args,_ = decompose_prod (RelDecl.get_type decl) in let real_args = if princ_type_info.indarg_in_concl then List.tl args @@ -609,7 +611,7 @@ let build_scheme fas = try Smartlocate.global_with_alias f with Not_found -> - errorlabstrm "FunInd.build_scheme" + user_err ~hdr:"FunInd.build_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in @@ -643,7 +645,7 @@ let build_case_scheme fa = let (_,f,_) = fa in try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f)) with Not_found -> - errorlabstrm "FunInd.build_case_scheme" + user_err ~hdr:"FunInd.build_case_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in let first_fun,u = destConst funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 42e490315..6603a95a8 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -14,11 +14,11 @@ open Constrexpr open Indfun_common open Indfun open Genarg -open Constrarg +open Stdarg open Misctypes open Pcoq.Prim open Pcoq.Constr -open Pcoq.Tactic +open Pltac DECLARE PLUGIN "recdef_plugin" @@ -143,7 +143,7 @@ END module Gram = Pcoq.Gram module Vernac = Pcoq.Vernac_ -module Tactic = Pcoq.Tactic +module Tactic = Pltac type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 52179ae50..de2e5ea4e 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -12,6 +12,9 @@ open Util open Glob_termops open Misctypes +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + let observe strm = if do_observe () then Feedback.msg_debug strm @@ -333,19 +336,20 @@ let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> - let value = Option.map (fun x-> fst (Pretyping.understand env (Evd.from_env env) x)) raw_value in - let typ,ctx = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in - let open Context.Named.Declaration in - Environ.push_named (of_tuple (id,value,typ)) env + let typ,_ = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in + (match raw_value with + | None -> + Environ.push_named (NamedDecl.LocalAssum (id,typ)) env + | Some value -> + Environ.push_named (NamedDecl.LocalDef (id, value, typ)) env) let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = - let open Context.Rel.Declaration in observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); match pat with - | PatVar(_,na) -> Environ.push_rel (LocalAssum (na,typ)) env + | PatVar(_,na) -> Environ.push_rel (RelDecl.LocalAssum (na,typ)) env | PatCstr(_,c,patl,na) -> let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env (Evd.from_env env) typ @@ -353,7 +357,7 @@ let add_pat_variables pat typ env : Environ.env = in let constructors = Inductiveops.get_constructors env indf in let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in - let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in + let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in @@ -361,20 +365,28 @@ let add_pat_variables pat typ env : Environ.env = fst ( Context.Rel.fold_outside (fun decl (env,ctxt) -> - let _,v,t = Context.Rel.Declaration.to_tuple decl in - match Context.Rel.Declaration.get_name decl with - | Anonymous -> assert false - | Name id -> + let open Context.Rel.Declaration in + match decl with + | LocalAssum (Anonymous,_) | LocalDef (Anonymous,_,_) -> assert false + | LocalAssum (Name id, t) -> + let new_t = substl ctxt t in + observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ + str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ + str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () + ); + let open Context.Named.Declaration in + (Environ.push_named (LocalAssum (id,new_t)) env,mkVar id::ctxt) + | LocalDef (Name id, v, t) -> let new_t = substl ctxt t in - let new_v = Option.map (substl ctxt) v in + let new_v = substl ctxt v in observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ - Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ - Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) + str "old value := " ++ Printer.pr_lconstr v ++ fnl () ++ + str "new value := " ++ Printer.pr_lconstr new_v ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (of_tuple (id,new_v,new_t)) env,mkVar id::ctxt) + (Environ.push_named (LocalDef (id,new_v,new_t)) env,mkVar id::ctxt) ) (Environ.rel_context new_env) ~init:(env,[]) @@ -402,8 +414,7 @@ let rec pattern_to_term_and_type env typ = function in let constructors = Inductiveops.get_constructors env indf in let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in - let open Context.Rel.Declaration in - let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in + let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in let _,cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = @@ -602,10 +613,9 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in let new_env = - let open Context.Named.Declaration in match n with Anonymous -> env - | Name id -> Environ.push_named (of_tuple (id,Some v_as_constr,v_type)) env + | Name id -> Environ.push_named (NamedDecl.LocalDef (id,v_as_constr,v_type)) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_letin n) v_res b_res @@ -621,7 +631,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ + user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in @@ -653,7 +663,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ + user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in @@ -976,8 +986,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (fun acc var_as_constr arg -> if isRel var_as_constr then - let open Context.Rel.Declaration in - let na = get_name (Environ.lookup_rel (destRel var_as_constr) env) in + let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in match na with | Anonymous -> acc | Name id' -> @@ -1189,7 +1198,7 @@ let rec compute_cst_params relnames params = function | GSort _ -> params | GHole _ -> params | GIf _ | GRec _ | GCast _ -> - raise (UserError("compute_cst_params", str "Not handled case")) + raise (UserError(Some "compute_cst_params", str "Not handled case")) and compute_cst_params_from_app acc (params,rtl) = match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 01e5ef7fb..4e561fc7e 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -406,7 +406,7 @@ let is_free_in id = | GIf(_,cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 - | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GRec _ -> raise (UserError(None,str "Not handled GRec")) | GSort _ -> false | GHole _ -> false | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t @@ -502,7 +502,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern lhs, replace_var_by_pattern rhs ) - | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GRec _ -> raise (UserError(None,str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> @@ -655,7 +655,7 @@ let zeta_normalize = zeta_normalize_term lhs, zeta_normalize_term rhs ) - | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GRec _ -> raise (UserError(None,str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 18817f504..99b04898b 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,4 +1,3 @@ -open Context.Rel.Declaration open CErrors open Util open Names @@ -13,11 +12,13 @@ open Misctypes open Decl_kinds open Sigma.Notations +module RelDecl = Context.Rel.Declaration + let is_rec_info scheme_info = let test_branche min acc decl = acc || ( let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (get_type decl))) in + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (RelDecl.get_type decl))) in let free_rels_in_br = Termops.free_rels new_branche in let max = min + scheme_info.Tactics.npredicates in Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br @@ -42,7 +43,7 @@ let functional_induction with_clean c princl pat = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' with Not_found -> - errorlabstrm "" (str "Cannot find induction information on "++ + user_err (str "Cannot find induction information on "++ Printer.pr_lconstr (mkConst c') ) in match Tacticals.elimination_sort_of_goal g with @@ -70,11 +71,11 @@ let functional_induction with_clean c princl pat = (b,a) (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) with Not_found -> (* This one is neither defined ! *) - errorlabstrm "" (str "Cannot find induction principle for " + user_err (str "Cannot find induction principle for " ++Printer.pr_lconstr (mkConst c') ) in (princ,NoBindings, Tacmach.pf_unsafe_type_of g' princ,g') - | _ -> raise (UserError("",str "functional induction must be used with a function" )) + | _ -> raise (UserError(None,str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> princ,binding,Tacmach.pf_unsafe_type_of g princ,g @@ -175,7 +176,7 @@ let build_newrecursive l = match body_opt with | Some body -> (fixna,bll,ar,body) - | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") + | None -> user_err ~hdr:"Function" (str "Body of Function must be given") ) l in build_newrecursive l' @@ -321,7 +322,7 @@ let error_error names e = in match e with | Building_graph e -> - errorlabstrm "" + user_err (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) @@ -391,7 +392,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [(((_,fname),pl),_,bl,ret_type,body),_] when not is_rec -> - let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in Command.do_definition fname (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl @@ -630,7 +631,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook pconstants = @@ -656,7 +657,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let fixpoint_exprl = [fixpoint_expr] in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in - let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) @@ -834,9 +835,9 @@ let make_graph (f_ref:global_reference) = | ConstRef c -> begin try c,Global.lookup_constant c with Not_found -> - raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) + raise (UserError (None,str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) end - | _ -> raise (UserError ("", str "Not a function reference") ) + | _ -> raise (UserError (None, str "Not a function reference") ) in (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom !" diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index f56e92414..a45effb16 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -49,7 +49,7 @@ let locate_constant ref = let locate_with_msg msg f x = try f x - with Not_found -> raise (CErrors.UserError("", msg)) + with Not_found -> raise (CErrors.UserError(None, msg)) let filter_map filter f = @@ -73,7 +73,7 @@ let chop_rlambda_n = | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b | _ -> - raise (CErrors.UserError("chop_rlambda_n", + raise (CErrors.UserError(Some "chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) in chop_lambda_n [] @@ -85,7 +85,7 @@ let chop_rprod_n = else match rt with | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> raise (CErrors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) + | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] @@ -110,7 +110,7 @@ let const_of_id id = in try Constrintern.locate_reference princ_ref with Not_found -> - CErrors.errorlabstrm "IndFun.const_of_id" + CErrors.user_err ~hdr:"IndFun.const_of_id" (str "cannot find " ++ Nameops.pr_id id) let def_of_const t = diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 26fc88a60..c8b4e4833 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -23,6 +23,8 @@ open Misctypes open Termops open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (* Some pretty printing function for debugging purpose *) let pr_binding prc = @@ -137,7 +139,7 @@ let generate_type evd g_to_f f graph i = let fun_ctxt,res_type = match ctxt with | [] | [_] -> anomaly (Pp.str "Not a valid context") - | decl :: fun_ctxt -> fun_ctxt, get_type decl + | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl in let rec args_from_decl i accu = function | [] -> accu @@ -148,7 +150,7 @@ let generate_type evd g_to_f f graph i = args_from_decl (succ i) (t :: accu) l in (*i We need to name the vars [res] and [fv] i*) - let filter = fun decl -> match get_name decl with + let filter = fun decl -> match RelDecl.get_name decl with | Name id -> Some id | Anonymous -> None in @@ -269,7 +271,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (fun decl -> List.map (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (get_type decl))))) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (RelDecl.get_type decl))))) ) branches in @@ -399,7 +401,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes | hres::res::decl::ctxt -> let res = Termops.it_mkLambda_or_LetIn (Termops.it_mkProd_or_LetIn concl [hres;res]) - (LocalAssum (get_name decl, get_type decl) :: ctxt) + (LocalAssum (RelDecl.get_name decl, RelDecl.get_type decl) :: ctxt) in res ) @@ -415,7 +417,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let params_bindings,avoid = List.fold_left2 (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.out_name (RelDecl.get_name decl)) avoid in p::bindings,id::avoid ) ([],pf_ids_of_hyps g) @@ -425,7 +427,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let lemmas_bindings = List.rev (fst (List.fold_left2 (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.out_name (RelDecl.get_name decl)) avoid in (nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates @@ -682,7 +684,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (fun decl -> List.map (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (nb_prod (get_type decl))) + (generate_fresh_id (Id.of_string "y") ids (nb_prod (RelDecl.get_type decl))) ) branches in @@ -998,7 +1000,7 @@ let invfun qhyp f = let f = match f with | ConstRef f -> f - | _ -> raise (CErrors.UserError("",str "Not a function")) + | _ -> raise (CErrors.UserError(None,str "Not a function")) in try let finfos = find_Function_infos f in @@ -1043,19 +1045,19 @@ let invfun qhyp f g = functional_inversion kn hid f2 f_correct g with | Failure "" -> - errorlabstrm "" (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") + user_err (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") | Option.IsNone -> if do_observe () then error "Cannot use equivalence with graph for any side of the equality" - else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) | Not_found -> if do_observe () then error "No graph found for any side of equality" - else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) end - | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") + | _ -> user_err (Ppconstr.pr_id hid ++ str " must be an equality ") end) qhyp end diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index de4210af5..19c2ed417 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -26,6 +26,8 @@ open Glob_termops open Decl_kinds open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (** {1 Utilities} *) (** {2 Useful operations on constr and glob_constr} *) @@ -57,8 +59,8 @@ let understand = Pretyping.understand (Global.env()) Evd.empty let id_of_name = function Anonymous -> Id.of_string "H" | Name id -> id;; -let name_of_string str = Name (Id.of_string str) -let string_of_name nme = Id.to_string (id_of_name nme) +let name_of_string = Id.of_string %> Name.mk_name +let string_of_name = id_of_name %> Id.to_string (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) let isVarf f x = @@ -79,7 +81,7 @@ let ident_global_exist id = global env) with base [id]. *) let next_ident_fresh (id:Id.t) = let res = ref id in - while ident_global_exist !res do res := Nameops.lift_subscript !res done; + while ident_global_exist !res do res := Nameops.increment_subscript !res done; !res @@ -137,7 +139,7 @@ let showind (id:Id.t) = let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in List.iter (fun decl -> print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":"); - prconstr (get_type decl); print_string "\n") + prconstr (RelDecl.get_type decl); print_string "\n") ib1.mind_arity_ctxt; Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1); Array.iteri @@ -460,12 +462,12 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in let _ = prstr "\notherprms1:\n" in let _ = - List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); - prconstr (get_type decl); prstr "\n") + List.iter (fun decl -> prstr (string_of_name (RelDecl.get_name decl) ^ " : "); + prconstr (RelDecl.get_type decl); prstr "\n") otherprms1 in let _ = prstr "\notherprms2:\n" in let _ = - List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); prconstr (get_type decl); prstr "\n") + List.iter (fun decl -> prstr (string_of_name (RelDecl.get_name decl) ^ " : "); prconstr (RelDecl.get_type decl); prstr "\n") otherprms2 in { ident=id; @@ -827,7 +829,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = List.fold_left (fun (acc,env) decl -> let nm = Context.Rel.Declaration.get_name decl in - let c = get_type decl in + let c = RelDecl.get_type decl in let typ = Constrextern.extern_constr false env Evd.empty c in let newenv = Environ.push_rel (LocalAssum (nm,c)) env in CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv) @@ -901,7 +903,7 @@ let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = locate_constant f_ref in try find_Function_infos (kn_of_id id) with Not_found -> - errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme") + user_err ~hdr:"indfun" (Nameops.pr_id id ++ str " has no functional scheme") (** [merge id1 id2 args1 args2 id] builds and declares a new inductive type called [id], representing the merged graphs of both graphs diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 62f307115..f43251bc5 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -307,7 +307,7 @@ let check_not_nested forbidden e = | Rel _ -> () | Var x -> if Id.List.mem x forbidden - then errorlabstrm "Recdef.check_not_nested" + then user_err ~hdr:"Recdef.check_not_nested" (str "check_not_nested: failure " ++ pr_id x) | Meta _ | Evar _ | Sort _ -> () | Cast(e,_,t) -> check_not_nested e;check_not_nested t @@ -327,7 +327,7 @@ let check_not_nested forbidden e = try check_not_nested e with UserError(_,p) -> - errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) + user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = @@ -377,7 +377,7 @@ type journey_info = let rec add_vars forbidden e = match kind_of_term e with | Var x -> x::forbidden - | _ -> fold_constr add_vars forbidden e + | _ -> Term.fold_constr add_vars forbidden e let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = @@ -442,7 +442,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info with e when CErrors.noncritical e -> - errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Lambda(n,t,b) -> begin @@ -450,7 +450,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info with e when CErrors.noncritical e -> - errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Case(ci,t,a,l) -> begin @@ -478,7 +478,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo expr_info.is_main_branch new_continuation_tac new_infos - | Case _ -> errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") + | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_lconstr expr_info.info) end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} @@ -723,8 +723,8 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) )) with - | UserError("Refiner.thensn_tac3",_) - | UserError("Refiner.tclFAIL_s",_) -> + | UserError(Some "Refiner.thensn_tac3",_) + | UserError(Some "Refiner.tclFAIL_s",_) -> (observe_tac (str "is computable " ++ Printer.pr_lconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) )) g diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 027f690fc..79020ed03 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -16,7 +16,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open Constrarg +open Stdarg +open Tacarg DECLARE PLUGIN "micromega_plugin" diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index d625e3076..1afc6500b 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -30,6 +30,7 @@ open Misctypes open Proofview.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration module OmegaSolver = Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -1697,8 +1698,8 @@ let destructure_hyps = let rec loop = function | [] -> (Tacticals.New.tclTHEN nat_inject coq_omega) | decl::lit -> - let (i,_,t) = to_tuple decl in - begin try match destructurate_prop t with + let i = NamedDecl.get_id decl in + begin try match destructurate_prop (NamedDecl.get_type decl) with | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> @@ -1808,13 +1809,13 @@ let destructure_hyps = match destructurate_type (pf_nf typ) with | Kapp(Nat,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) - decl)) + (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) + decl)) (loop lit)) | Kapp(Z,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) - decl)) + (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) + decl)) (loop lit)) | _ -> loop lit end diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index 5647fbf9f..27115abec 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -19,7 +19,7 @@ DECLARE PLUGIN "omega_plugin" open Names open Coq_omega -open Constrarg +open Stdarg let eval_tactic name = let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index fd87d5b7d..e7e6ecef9 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -13,7 +13,8 @@ open Misctypes open Tacexpr open Geninterp open Quote -open Constrarg +open Stdarg +open Tacarg DECLARE PLUGIN "quote_plugin" diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 830dc54dd..2f38688d1 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -12,7 +12,7 @@ DECLARE PLUGIN "romega_plugin" open Names open Refl_omega -open Constrarg +open Stdarg let eval_tactic name = let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 4ed907951..367a13333 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -263,7 +263,7 @@ let rtauto_tac gls= let _= if Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) gl != InProp - then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in + then user_err ~hdr:"rtauto" (Pp.str "goal should be in Prop") in let glf=make_form gamma gls gl in let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in let formula= @@ -282,7 +282,7 @@ let rtauto_tac gls= let prf = try project (search_fun (init_state [] formula)) with Not_found -> - errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in + user_err ~hdr:"rtauto" (Pp.str "rtauto couldn't find any proof") in let search_end_time = System.get_time () in let _ = if !verbose then begin diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 216eb8b37..0987c44ae 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -15,9 +15,9 @@ open Printer open Newring_ast open Newring open Stdarg -open Constrarg +open Tacarg open Pcoq.Constr -open Pcoq.Tactic +open Pltac DECLARE PLUGIN "newring_plugin" diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 90f5f8e63..657efe175 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -79,7 +79,7 @@ let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = try String.Map.find map !protect_maps with Not_found -> - errorlabstrm"lookup_map"(str"map "++qs map++str"not found") + user_err ~hdr:"lookup_map" (str"map "++qs map++str"not found") let protect_red map env sigma c = kl (create_clos_infos all env) @@ -124,8 +124,8 @@ let closed_term_ast l = let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in TacFun([Some(Id.of_string"t")], TacML(Loc.ghost,tacname, - [TacGeneric (Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); - TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l)])) + [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); + TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)])) (* let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" *) @@ -348,13 +348,13 @@ let find_ring_structure env sigma l = let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then - errorlabstrm "ring" + user_err ~hdr:"ring" (str"arguments of ring_simplify do not have all the same type") in List.iter check cl'; (try ring_for_carrier ty with Not_found -> - errorlabstrm "ring" + user_err ~hdr:"ring" (str"cannot find a declared ring structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false @@ -828,13 +828,13 @@ let find_field_structure env sigma l = let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then - errorlabstrm "field" + user_err ~hdr:"field" (str"arguments of field_simplify do not have all the same type") in List.iter check cl'; (try field_for_carrier ty with Not_found -> - errorlabstrm "field" + user_err ~hdr:"field" (str"cannot find a declared field structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 41eb5826b..610c4c92d 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -19,7 +19,8 @@ open Names open Pp open Pcoq open Genarg -open Constrarg +open Stdarg +open Tacarg open Term open Vars open Topconstr @@ -41,7 +42,7 @@ open Proofview.Notations open Tacinterp open Pretyping open Constr -open Tactic +open Pltac open Extraargs open Ppconstr open Printer @@ -61,8 +62,8 @@ DECLARE PLUGIN "ssrmatching_plugin" type loc = Loc.t let dummy_loc = Loc.ghost -let errorstrm = CErrors.errorlabstrm "ssrmatching" -let loc_error loc msg = CErrors.user_err_loc (loc, msg, str msg) +let errorstrm = CErrors.user_err ~hdr:"ssrmatching" +let loc_error loc msg = CErrors.user_err ~loc ~hdr:msg (str msg) let ppnl = Feedback.msg_info (* 0 cost pp function. Active only if env variable SSRDEBUG is set *) diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index e18d19ced..ed8cc6ab0 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -52,8 +52,8 @@ let interp_ascii_string dloc s = if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] then int_of_string s else - user_err_loc (dloc,"interp_ascii_string", - str "Expects a single character or a three-digits ascii code.") in + user_err ~loc:dloc ~hdr:"interp_ascii_string" + (str "Expects a single character or a three-digits ascii code.") in interp_ascii dloc p let uninterp_ascii r = diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index a9eb126b4..ab262fea7 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -47,8 +47,8 @@ let nat_of_int dloc n = mk_nat ref_O n end else - user_err_loc (dloc, "nat_of_int", - str "Cannot interpret a negative number as a number of type nat") + user_err ~hdr:"nat_of_int" + (str "Cannot interpret a negative number as a number of type nat") (************************************************************************) (* Printing via scopes *) diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index f65f9b791..a25ddb062 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -100,7 +100,7 @@ let int31_of_pos_bigint dloc n = GApp (dloc, ref_construct, List.rev (args 31 n)) let error_negative dloc = - CErrors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.") + CErrors.user_err ~loc:dloc ~hdr:"interp_int31" (Pp.str "int31 are only non-negative numbers.") let interp_int31 dloc n = if is_pos_or_zero n then @@ -189,7 +189,7 @@ let bigN_of_pos_bigint dloc n = GApp (dloc, ref_constructor, args) let bigN_error_negative dloc = - CErrors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") + CErrors.user_err ~loc:dloc ~hdr:"interp_bigN" (Pp.str "bigN are only non-negative numbers.") let interp_bigN dloc n = if is_pos_or_zero n then diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index 60803a369..b7b5fb8a5 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -57,8 +57,8 @@ let pos_of_bignat dloc x = pos_of x let error_non_positive dloc = - user_err_loc (dloc, "interp_positive", - str "Only strictly positive numbers in type \"positive\".") + user_err ~loc:dloc ~hdr:"interp_positive" + (str "Only strictly positive numbers in type \"positive\".") let interp_positive dloc n = if is_strictly_pos n then pos_of_bignat dloc n @@ -113,7 +113,7 @@ let n_of_binnat dloc pos_or_neg n = GRef (dloc, glob_N0, None) let error_negative dloc = - user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".") + user_err ~loc:dloc ~hdr:"interp_N" (str "No negative numbers in type \"N\".") let n_of_int dloc n = if is_pos_or_zero n then n_of_binnat dloc true n diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index ca1d0b7fb..077ee4e15 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -13,6 +13,8 @@ open Term open Environ open Util open Libobject + +module NamedDecl = Context.Named.Declaration (*i*) let name_table = @@ -48,7 +50,7 @@ let discharge_rename_args = function (try let vars,_,_ = section_segment_of_reference c in let c' = pop_global_reference c in - let var_names = List.map (fun (id, _,_,_) -> Name id) vars in + let var_names = List.map (fst %> NamedDecl.get_id %> Name.mk_name) vars in let names' = List.map (fun l -> var_names @ l) names in Some (ReqGlobal (c', names), (c', names')) with Not_found -> Some req) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 5c9ce2624..934cefbfe 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -32,6 +32,9 @@ open Evd open Sigma.Notations open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (* Pattern-matching errors *) type pattern_matching_error = @@ -45,22 +48,22 @@ type pattern_matching_error = exception PatternMatchingError of env * evar_map * pattern_matching_error -let raise_pattern_matching_error (loc,env,sigma,te) = - Loc.raise loc (PatternMatchingError(env,sigma,te)) +let raise_pattern_matching_error ?loc (env,sigma,te) = + Loc.raise ?loc (PatternMatchingError(env,sigma,te)) -let error_bad_pattern_loc loc env sigma cstr ind = - raise_pattern_matching_error - (loc, env, sigma, BadPattern (cstr,ind)) +let error_bad_pattern ?loc env sigma cstr ind = + raise_pattern_matching_error ?loc + (env, sigma, BadPattern (cstr,ind)) -let error_bad_constructor_loc loc env cstr ind = - raise_pattern_matching_error - (loc, env, Evd.empty, BadConstructor (cstr,ind)) +let error_bad_constructor ?loc env cstr ind = + raise_pattern_matching_error ?loc + (env, Evd.empty, BadConstructor (cstr,ind)) -let error_wrong_numarg_constructor_loc loc env c n = - raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargConstructor(c,n)) +let error_wrong_numarg_constructor ?loc env c n = + raise_pattern_matching_error ?loc (env, Evd.empty, WrongNumargConstructor(c,n)) -let error_wrong_numarg_inductive_loc loc env c n = - raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargInductive(c,n)) +let error_wrong_numarg_inductive ?loc env c n = + raise_pattern_matching_error ?loc (env, Evd.empty, WrongNumargInductive(c,n)) let list_try_compile f l = let rec aux errors = function @@ -480,32 +483,31 @@ let check_and_adjust_constructor env ind cstrs = function let args' = adjust_local_defs loc (args, List.rev ci.cs_args) in PatCstr (loc, cstr, args', alias) with NotAdjustable -> - error_wrong_numarg_constructor_loc loc env cstr nb_args_constr + error_wrong_numarg_constructor ~loc env cstr nb_args_constr else (* Try to insert a coercion *) try Coercion.inh_pattern_coerce_to loc env pat ind' ind with Not_found -> - error_bad_constructor_loc loc env cstr ind + error_bad_constructor ~loc env cstr ind let check_all_variables env sigma typ mat = List.iter (fun eqn -> match current_pattern eqn with | PatVar (_,id) -> () | PatCstr (loc,cstr_sp,_,_) -> - error_bad_pattern_loc loc env sigma cstr_sp typ) + error_bad_pattern ~loc env sigma cstr_sp typ) mat let check_unused_pattern env eqn = if not !(eqn.used) then - raise_pattern_matching_error - (eqn.eqn_loc, env, Evd.empty, UnusedClause eqn.patterns) + raise_pattern_matching_error ~loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns) let set_used_pattern eqn = eqn.used := true let extract_rhs pb = match pb.mat with - | [] -> errorlabstrm "build_leaf" (msg_may_need_inversion()) + | [] -> user_err ~hdr:"build_leaf" (msg_may_need_inversion()) | eqn::_ -> set_used_pattern eqn; eqn.rhs @@ -606,7 +608,7 @@ let relocate_index_tomatch n1 n2 = NonDepAlias :: genrec depth rest | Abstract (i,d) :: rest -> let i = relocate_rel n1 n2 depth i in - Abstract (i, map_constr (relocate_index n1 n2 depth) d) + Abstract (i, RelDecl.map_constr (relocate_index n1 n2 depth) d) :: genrec (depth+1) rest in genrec 0 @@ -639,7 +641,7 @@ let replace_tomatch n c = | NonDepAlias :: rest -> NonDepAlias :: replrec depth rest | Abstract (i,d) :: rest -> - Abstract (i, map_constr (replace_term n c depth) d) + Abstract (i, RelDecl.map_constr (replace_term n c depth) d) :: replrec (depth+1) rest in replrec 0 @@ -664,7 +666,7 @@ let rec liftn_tomatch_stack n depth = function NonDepAlias :: liftn_tomatch_stack n depth rest | Abstract (i,d)::rest -> let i = if i<depth then i else i+n in - Abstract (i, map_constr (liftn n depth) d) + Abstract (i, RelDecl.map_constr (liftn n depth) d) ::(liftn_tomatch_stack n (depth+1) rest) let lift_tomatch_stack n = liftn_tomatch_stack n 1 @@ -732,7 +734,7 @@ let get_names env sign eqns = (* We now replace the names y1 .. yn y by the actual names *) (* xi1 .. xin xi to be found in the i-th clause of the matrix *) -let recover_initial_subpattern_names = List.map2 set_name +let recover_initial_subpattern_names = List.map2 RelDecl.set_name let recover_and_adjust_alias_names names sign = let rec aux = function @@ -757,11 +759,11 @@ let push_rels_eqn_with_names sign eqn = push_rels_eqn sign eqn let push_generalized_decl_eqn env n decl eqn = - match get_name decl with + match RelDecl.get_name decl with | Anonymous -> push_rels_eqn [decl] eqn | Name _ -> - push_rels_eqn [set_name (get_name (Environ.lookup_rel n eqn.rhs.rhs_env)) decl] eqn + push_rels_eqn [RelDecl.set_name (RelDecl.get_name (Environ.lookup_rel n eqn.rhs.rhs_env)) decl] eqn let drop_alias_eqn eqn = { eqn with alias_stack = List.tl eqn.alias_stack } @@ -769,7 +771,7 @@ let drop_alias_eqn eqn = let push_alias_eqn alias eqn = let aliasname = List.hd eqn.alias_stack in let eqn = drop_alias_eqn eqn in - let alias = set_name aliasname alias in + let alias = RelDecl.set_name aliasname alias in push_rels_eqn [alias] eqn (**********************************************************************) @@ -1196,7 +1198,7 @@ let rec generalize_problem names pb = function | LocalDef (Anonymous,_,_) -> pb', deps | _ -> (* for better rendering *) - let d = map_type (whd_betaiota !(pb.evdref)) d in + let d = RelDecl.map_type (whd_betaiota !(pb.evdref)) d in let tomatch = lift_tomatch_stack 1 pb'.tomatch in let tomatch = relocate_index_tomatch (i+1) 1 tomatch in { pb' with @@ -1224,7 +1226,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* that had matched constructor C *) let cs_args = const_info.cs_args in let names,aliasname = get_names pb.env cs_args eqns in - let typs = List.map2 set_name names cs_args + let typs = List.map2 RelDecl.set_name names cs_args in (* We build the matrix obtained by expanding the matching on *) @@ -1274,7 +1276,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let typs' = List.map2 (fun (tm, (tmtyp,_), decl) deps -> - let na = get_name decl in + let na = RelDecl.get_name decl in let na = match curname, na with | Name _, Anonymous -> curname | Name _, Name _ -> na @@ -1306,8 +1308,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let submat = adjust_impossible_cases pb pred tomatch submat in let () = match submat with | [] -> - raise_pattern_matching_error - (Loc.ghost, pb.env, Evd.empty, NonExhaustive (complete_history history)) + raise_pattern_matching_error (pb.env, Evd.empty, NonExhaustive (complete_history history)) | _ -> () in @@ -1659,8 +1660,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = List.map (fun a -> not (isRel a) || dependent a u || Int.Set.mem (destRel a) depvl) inst in let named_filter = - let open Context.Named.Declaration in - List.map (fun d -> dependent (mkVar (get_id d)) u) + List.map (fun d -> dependent (mkVar (NamedDecl.get_id d)) u) (named_context extenv) in let filter = Filter.make (rel_filter @ named_filter) in let candidates = u :: List.map mkRel vl in @@ -1756,7 +1756,7 @@ let build_inversion_problem loc env sigma tms t = let sub_tms = List.map2 (fun deps (tm, (tmtyp,_), decl) -> - let na = if List.is_empty deps then Anonymous else force_name (get_name decl) in + let na = if List.is_empty deps then Anonymous else force_name (RelDecl.get_name decl) in Pushed (true,((tm,tmtyp),deps,na))) dep_sign decls in let subst = List.map (fun (na,t) -> (na,lift n t)) subst in @@ -1819,7 +1819,7 @@ let build_initial_predicate arsign pred = let rec buildrec n pred tmnames = function | [] -> List.rev tmnames,pred | (decl::realdecls)::lnames -> - let na = get_name decl in + let na = RelDecl.get_name decl in let n' = n + List.length realdecls in buildrec (n'+1) pred (force_name na::tmnames) lnames | _ -> assert false @@ -1835,8 +1835,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = | None -> [LocalAssum (na, lift n typ)] | Some b -> [LocalDef (na, lift n b, lift n typ)]) | Some (loc,_,_) -> - user_err_loc (loc,"", - str"Unexpected type annotation for a term of non inductive type.")) + user_err ~loc + (str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in let ((ind,u),_) = dest_ind_family indf' in @@ -1846,13 +1846,13 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = match t with | Some (loc,ind',realnal) -> if not (eq_ind ind ind') then - user_err_loc (loc,"",str "Wrong inductive type."); + user_err ~loc (str "Wrong inductive type."); if not (Int.equal nrealargs_ctxt (List.length realnal)) then anomaly (Pp.str "Ill-formed 'in' clause in cases"); List.rev realnal | None -> List.make nrealargs_ctxt Anonymous in LocalAssum (na, build_dependent_inductive env0 indf') - ::(List.map2 set_name realnal arsign) in + ::(List.map2 RelDecl.set_name realnal arsign) in let rec buildrec n = function | [],[] -> [] | (_,tm)::ltm, (_,x)::tmsign -> @@ -2037,11 +2037,11 @@ let constr_of_pat env evdref arsign pat avoid = let cind = inductive_of_constructor cstr in let IndType (indf, _) = try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty) - with Not_found -> error_case_not_inductive env + with Not_found -> error_case_not_inductive env !evdref {uj_val = ty; uj_type = Typing.unsafe_type_of env !evdref ty} in let (ind,u), params = dest_ind_family indf in - if not (eq_ind ind cind) then error_bad_constructor_loc l env cstr ind; + if not (eq_ind ind cind) then error_bad_constructor ~loc:l env cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in @@ -2049,7 +2049,7 @@ let constr_of_pat env evdref arsign pat avoid = let patargs, args, sign, env, n, m, avoid = List.fold_right2 (fun decl ua (patargs, args, sign, env, n, m, avoid) -> - let t = get_type decl in + let t = RelDecl.get_type decl in let pat', sign', arg', typ', argtypargs, n', avoid = let liftt = liftn (List.length sign) (succ (List.length args)) t in typ env (substl args liftt, []) ua avoid @@ -2089,8 +2089,8 @@ let constr_of_pat env evdref arsign pat avoid = (* Mark the equality as a hole *) pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in - let pat', sign, patc, patty, args, z, avoid = typ env (get_type (List.hd arsign), List.tl arsign) pat avoid in - pat', (sign, patc, (get_type (List.hd arsign), args), pat'), avoid + let pat', sign, patc, patty, args, z, avoid = typ env (RelDecl.get_type (List.hd arsign), List.tl arsign) pat avoid in + pat', (sign, patc, (RelDecl.get_type (List.hd arsign), args), pat'), avoid (* shadows functional version *) @@ -2121,7 +2121,7 @@ let vars_of_ctx ctx = (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), [hole; GVar (Loc.ghost, prev)])) :: vars | _ -> - match get_name decl with + match RelDecl.get_name decl with Anonymous -> invalid_arg "vars_of_ctx" | Name n -> n, GVar (Loc.ghost, n) :: vars) ctx (Id.of_string "vars_of_ctx_error", []) @@ -2298,7 +2298,7 @@ let abstract_tomatch env tomatchs tycon = let build_dependent_signature env evdref avoid tomatchs arsign = let avoid = ref avoid in let arsign = List.rev arsign in - let allnames = List.rev_map (List.map get_name) arsign in + let allnames = List.rev_map (List.map RelDecl.get_name) arsign in let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in let eqs, neqs, refls, slift, arsign' = List.fold_left2 @@ -2315,14 +2315,14 @@ let build_dependent_signature env evdref avoid tomatchs arsign = as much as possible *) let argsign = List.tl arsign in (* arguments in inverse application order *) let app_decl = List.hd arsign in (* The matched argument *) - let appn = get_name app_decl in - let appt = get_type app_decl in + let appn = RelDecl.get_name app_decl in + let appt = RelDecl.get_type app_decl in let argsign = List.rev argsign in (* arguments in application order *) let env', nargeqs, argeqs, refl_args, slift, argsign' = List.fold_left2 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl -> - let name = get_name decl in - let t = get_type decl in + let name = RelDecl.get_name decl in + let t = RelDecl.get_type decl in let argt = Retyping.get_type_of env !evdref arg in let eq, refl_arg = if Reductionops.is_conv env !evdref argt t then @@ -2340,7 +2340,7 @@ let build_dependent_signature env evdref avoid tomatchs arsign = let previd, id = let name = match kind_of_term arg with - Rel n -> get_name (lookup_rel n env) + Rel n -> RelDecl.get_name (lookup_rel n env) | _ -> name in make_prime avoid name @@ -2349,7 +2349,7 @@ let build_dependent_signature env evdref avoid tomatchs arsign = (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs, refl_arg :: refl_args, pred slift, - set_name (Name id) decl :: argsign')) + RelDecl.set_name (Name id) decl :: argsign')) (env, neqs, [], [], slift, []) args argsign in let eq = mk_JMeq evdref @@ -2364,13 +2364,13 @@ let build_dependent_signature env evdref avoid tomatchs arsign = succ nargeqs, refl_eq :: refl_args, pred slift, - ((set_name (Name id) app_decl :: argsign') :: arsigns)) + ((RelDecl.set_name (Name id) app_decl :: argsign') :: arsigns)) | _ -> (* Non dependent inductive or not inductive, just use a regular equality *) let decl = match arsign with [x] -> x | _ -> assert(false) in - let name = get_name decl in + let name = RelDecl.get_name decl in let previd, id = make_prime avoid name in - let arsign' = set_name (Name id) decl in + let arsign' = RelDecl.set_name (Name id) decl in let tomatch_ty = type_of_tomatch ty in let eq = mk_eq evdref (lift nar tomatch_ty) diff --git a/pretyping/cases.mli b/pretyping/cases.mli index ba566f374..6bc61f6dd 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -28,9 +28,9 @@ type pattern_matching_error = exception PatternMatchingError of env * evar_map * pattern_matching_error -val error_wrong_numarg_constructor_loc : Loc.t -> env -> constructor -> int -> 'a +val error_wrong_numarg_constructor : ?loc:Loc.t -> env -> constructor -> int -> 'a -val error_wrong_numarg_inductive_loc : Loc.t -> env -> inductive -> int -> 'a +val error_wrong_numarg_inductive : ?loc:Loc.t -> env -> inductive -> int -> 'a val irrefutable : env -> cases_pattern -> bool diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 4f265e76c..30d100af9 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -538,7 +538,7 @@ let inheritance_graph () = let coercion_of_reference r = let ref = Nametab.global r in if not (coercion_exists ref) then - errorlabstrm "try_add_coercion" + user_err ~hdr:"try_add_coercion" (Nametab.pr_global_env Id.Set.empty ref ++ str" is not a coercion."); ref diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 913e80f39..2b860ae9c 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -153,7 +153,6 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) and coerce' env x y : (Term.constr -> Term.constr) option = let subco () = subset_coerce env evdref x y in let dest_prod c = - let open Context.Rel.Declaration in match Reductionops.splay_prod_n env ( !evdref) 1 c with | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na,t), c | _ -> raise NoSubtacCoercion @@ -412,7 +411,7 @@ let inh_tosort_force loc env evd j = let j2 = on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env j2) with Not_found | NoCoercion -> - error_not_a_type_loc loc env evd j + error_not_a_type ~loc env evd j let inh_coerce_to_sort loc env evd j = let typ = whd_all env evd j.uj_type in @@ -506,16 +505,16 @@ let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t = else raise NoSubtacCoercion with | NoSubtacCoercion when not resolve_tc || not !use_typeclasses_for_conversion -> - error_actual_type_loc loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj t e | NoSubtacCoercion -> let evd' = saturate_evd env evd in try if evd' == evd then - error_actual_type_loc loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj t e else inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (_evd,_error) -> - error_actual_type_loc loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj t e in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 886a98263..5ec44a68d 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -45,6 +45,7 @@ open Context.Rel.Declaration *) +type binding_bound_vars = Id.Set.t type bound_ident_map = Id.t Id.Map.t exception PatternMatchingFailure diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli index 8d8166f22..ee6c5141b 100644 --- a/pretyping/constr_matching.mli +++ b/pretyping/constr_matching.mli @@ -13,6 +13,8 @@ open Term open Environ open Pattern +type binding_bound_vars = Id.Set.t + (** [PatternMatchingFailure] is the exception raised when pattern matching fails *) exception PatternMatchingFailure @@ -41,7 +43,7 @@ val matches_head : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map variables or metavariables have the same name, the metavariable, or else the rightmost bound variable, takes precedence *) val extended_matches : - env -> Evd.evar_map -> Tacexpr.binding_bound_vars * constr_pattern -> + env -> Evd.evar_map -> binding_bound_vars * constr_pattern -> constr -> bound_ident_map * extended_patvar_map (** [is_matching pat c] just tells if [c] matches against [pat] *) @@ -75,7 +77,7 @@ val match_appsubterm : env -> Evd.evar_map -> constr_pattern -> constr -> matchi (** [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *) val match_subterm_gen : env -> Evd.evar_map -> bool (** true = with app context *) -> - Tacexpr.binding_bound_vars * constr_pattern -> constr -> + binding_bound_vars * constr_pattern -> constr -> matching_result IStream.t (** [is_matching_appsubterm pat c] tells if a subterm of [c] matches diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 85125a502..cad5551c1 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -67,15 +67,15 @@ let isomorphic_to_tuple lc = Int.equal (Array.length lc) 1 let encode_bool r = let (x,lc) = encode_inductive r in if not (has_two_constructors lc) then - user_err_loc (loc_of_reference r,"encode_if", - str "This type has not exactly two constructors."); + user_err ~loc:(loc_of_reference r) ~hdr:"encode_if" + (str "This type has not exactly two constructors."); x let encode_tuple r = let (x,lc) = encode_inductive r in if not (isomorphic_to_tuple lc) then - user_err_loc (loc_of_reference r,"encode_tuple", - str "This type cannot be seen as a tuple type."); + user_err ~loc:(loc_of_reference r) ~hdr:"encode_tuple" + (str "This type cannot be seen as a tuple type."); x module PrintingInductiveMake = diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 3680cd777..3045d66b8 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -24,7 +24,10 @@ open Globnames open Evd open Pretype_errors open Sigma.Notations -open Context.Rel.Declaration +open Context.Named.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration type unify_fun = transparent_state -> env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result @@ -53,14 +56,13 @@ let eval_flexible_term ts env evd c = else None | Rel n -> (try match lookup_rel n env with - | LocalAssum _ -> None - | LocalDef (_,v,_) -> Some (lift n v) + | RelDecl.LocalAssum _ -> None + | RelDecl.LocalDef (_,v,_) -> Some (lift n v) with Not_found -> None) | Var id -> (try if is_transparent_variable ts id then - let open Context.Named.Declaration in - lookup_named id env |> get_value + env |> lookup_named id |> NamedDecl.get_value else None with Not_found -> None) | LetIn (_,b,_,c) -> Some (subst1 b c) @@ -389,7 +391,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty assert (match sk with [] -> true | _ -> false); let (na,c1,c'1) = destLambda term in let c = nf_evar evd c1 in - let env' = push_rel (LocalAssum (na,c)) env in + let env' = push_rel (RelDecl.LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in let out2 = whd_nored_state evd @@ -597,7 +599,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let b = nf_evar i b1 in let t = nf_evar i t1 in let na = Nameops.name_max na1 na2 in - evar_conv_x ts (push_rel (LocalDef (na,b,t)) env) i pbty c'1 c'2); + evar_conv_x ts (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] and f2 i = let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) @@ -712,7 +714,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> let c = nf_evar i c1 in let na = Nameops.name_max na1 na2 in - evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i CONV c'1 c'2)] + evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2)] | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 @@ -771,7 +773,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> let c = nf_evar i c1 in let na = Nameops.name_max n1 n2 in - evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i pbty c'1 c'2)] + evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> if Int.equal x1 x2 then @@ -948,7 +950,6 @@ let choose_less_dependent_instance evk evd term args = | [] -> None | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd) -open Context.Named.Declaration let apply_on_subterm env evdref f c t = let rec applyrec (env,(k,c) as acc) t = (* By using eq_constr, we make an approximation, for instance, we *) @@ -979,14 +980,16 @@ let filter_possible_projections c ty ctxt args = List.map_i (fun i decl -> let () = assert (i < len) in let a = Array.unsafe_get args i in - (match decl with LocalAssum _ -> false | LocalDef (_,c,_) -> not (isRel c || isVar c)) || + (match decl with + | NamedDecl.LocalAssum _ -> false + | NamedDecl.LocalDef (_,c,_) -> not (isRel c || isVar c)) || a == c || (* Here we make an approximation, for instance, we could also be *) (* interested in finding a term u convertible to c such that a occurs *) (* in u *) isRel a && Int.Set.mem (destRel a) fv1 || isVar a && Id.Set.mem (destVar a) fv2 || - Id.Set.mem (get_id decl) tyvars) + Id.Set.mem (NamedDecl.get_id decl) tyvars) 0 ctxt let solve_evars = ref (fun _ -> failwith "solve_evars not installed") @@ -1017,10 +1020,10 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let env_evar = evar_filtered_env evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in - let instance = List.map mkVar (List.map get_id ctxt) in + let instance = List.map mkVar (List.map NamedDecl.get_id ctxt) in let rec make_subst = function - | decl'::ctxt', c::l, occs::occsl when isVarId (get_id decl') c -> + | decl'::ctxt', c::l, occs::occsl when isVarId (NamedDecl.get_id decl') c -> begin match occs with | Some _ -> error "Cannot force abstraction on identity instance." @@ -1028,7 +1031,8 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = make_subst (ctxt',l,occsl) end | decl'::ctxt', c::l, occs::occsl -> - let (id,_,t) = to_tuple decl' in + let id = NamedDecl.get_id decl' in + let t = NamedDecl.get_type decl' in let evs = ref [] in let ty = Retyping.get_type_of env_rhs evd c in let filter' = filter_possible_projections c ty ctxt args in @@ -1246,7 +1250,7 @@ let consider_remaining_unif_problems env aux evd pbs progress (pb :: stuck) end | UnifFailure (evd,reason) -> - Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb) + Pretype_errors.error_cannot_unify ~loc:(loc_of_conv_pb evd pb) env evd ~reason (t1, t2)) | _ -> if progress then aux evd stuck false [] @@ -1255,7 +1259,7 @@ let consider_remaining_unif_problems env | [] -> (* We're finished *) evd | (pbty,env,t1,t2 as pb) :: _ -> (* There remains stuck problems *) - Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb) + Pretype_errors.error_cannot_unify ~loc:(loc_of_conv_pb evd pb) env evd (t1, t2) in let (evd,pbs) = extract_all_conv_pbs evd in diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index f9ab75cea..06f619410 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -19,21 +19,21 @@ open Evarutil open Pretype_errors open Sigma.Notations +module RelDecl = Context.Rel.Declaration + let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in (Sigma.to_evar_map evd, evk) let env_nf_evar sigma env = - let open Context.Rel.Declaration in process_rel_context - (fun d e -> push_rel (map_constr (nf_evar sigma) d) e) env + (fun d e -> push_rel (RelDecl.map_constr (nf_evar sigma) d) e) env let env_nf_betaiotaevar sigma env = - let open Context.Rel.Declaration in process_rel_context (fun d e -> - push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env + push_rel (RelDecl.map_constr (Reductionops.nf_betaiota sigma) d) e) env (****************************************) (* Operations on value/type constraints *) @@ -135,7 +135,7 @@ let define_pure_evar_as_lambda env evd evk = let evd1,(na,dom,rng) = match kind_of_term typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ - | _ -> error_not_product_loc Loc.ghost env evd typ in + | _ -> error_not_product env evd typ in let avoid = ids_of_named_context (evar_context evi) in let id = next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in @@ -191,7 +191,7 @@ let split_tycon loc env evd tycon = | App (c,args) when isEvar c -> let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in real_split evd' (mkApp (lam,args)) - | _ -> error_not_product_loc loc env evd c + | _ -> error_not_product ~loc env evd c in match tycon with | None -> evd,(Anonymous,None,None) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index f1526facc..bafb009f5 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -169,7 +169,7 @@ type 'a update = | NoUpdate open Context.Named.Declaration -let inst_of_vars sign = Array.map_of_list (mkVar % get_id) sign +let inst_of_vars sign = Array.map_of_list (get_id %> mkVar) sign let restrict_evar_key evd evk filter candidates = match filter, candidates with @@ -638,13 +638,13 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env in - let evd,b_in_sign = match d with - | LocalAssum _ -> evd,None + let evd,d' = match d with + | LocalAssum _ -> evd, Context.Named.Declaration.LocalAssum (id,t_in_sign) | LocalDef (_,b,_) -> let evd,b = define_evar_from_virtual_equation define_fun env evd src b t_in_sign sign filter inst_in_env in - evd,Some b in - (push_named_context_val (Context.Named.Declaration.of_tuple (id,b_in_sign,t_in_sign)) sign, Filter.extend 1 filter, + evd, Context.Named.Declaration.LocalDef (id,b,t_in_sign) in + (push_named_context_val d' sign, Filter.extend 1 filter, (mkRel 1)::(List.map (lift 1) inst_in_env), (mkRel 1)::(List.map (lift 1) inst_in_sign), push_rel d env,evd,id::avoid)) diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 4caa1e992..4b9cf415f 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -16,6 +16,8 @@ open Nameops open Termops open Pretype_errors +module NamedDecl = Context.Named.Declaration + (** Processing occurrences *) type occurrence_error = @@ -35,7 +37,7 @@ let explain_occurrence_error = function | IncorrectInValueOccurrence id -> explain_incorrect_in_value_occurrence id let error_occurrences_error e = - errorlabstrm "" (explain_occurrence_error e) + user_err (explain_occurrence_error e) let error_invalid_occurrence occ = error_occurrences_error (InvalidOccurrence occ) @@ -61,7 +63,7 @@ let proceed_with_occurrences f occs x = let map_named_declaration_with_hyploc f hyploc acc decl = let open Context.Named.Declaration in - let f = f (Some (get_id decl, hyploc)) in + let f = f (Some (NamedDecl.get_id decl, hyploc)) in match decl,hyploc with | LocalAssum (id,_), InHypValueOnly -> error_occurrences_error (IncorrectInValueOccurrence id) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 39aeb41f7..9cf91a947 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -55,7 +55,7 @@ let is_private mib = let check_privacy_block mib = if is_private mib then - errorlabstrm ""(str"case analysis on a private inductive type") + user_err (str"case analysis on a private inductive type") (**********************************************************************) (* Building case analysis schemes *) @@ -594,7 +594,7 @@ let lookup_eliminator ind_sp s = (* using short name (e.g. for "eq_rec") *) try Nametab.locate (qualid_of_ident id) with Not_found -> - errorlabstrm "default_elim" + user_err ~hdr:"default_elim" (strbrk "Cannot find the elimination combinator " ++ pr_id id ++ strbrk ", the elimination of the inductive definition " ++ pr_global_env Id.Set.empty (IndRef ind_sp) ++ diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 214e19fec..29f57144a 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -355,7 +355,7 @@ let make_case_or_project env indf ci pred c branches = let mib, _ = Inductive.lookup_mind_specif env ind in if (* dependent *) not (noccurn 1 t) && not (has_dependent_elim mib) then - errorlabstrm "make_case_or_project" + user_err ~hdr:"make_case_or_project" Pp.(str"Dependent case analysis not allowed" ++ str" on inductive type " ++ Names.MutInd.print (fst ind)) in diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 0dd64697c..1e5f12b20 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -20,6 +20,8 @@ open Nativecode open Nativevalues open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (** This module implements normalization by evaluation to OCaml code *) exception Find_at of int @@ -122,7 +124,7 @@ let build_case_type dep p realargs c = (* TODO move this function *) let type_of_rel env n = - lookup_rel n env |> get_type |> lift n + env |> lookup_rel n |> RelDecl.get_type |> lift n let type_of_prop = mkSort type1_sort @@ -133,7 +135,7 @@ let type_of_sort s = let type_of_var env id = let open Context.Named.Declaration in - try lookup_named id env |> get_type + try env |> lookup_named id |> get_type with Not_found -> anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound") diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index fe73b6105..9dcb5d2a5 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -204,7 +204,7 @@ let error_instantiate_pattern id l = | [_] -> "is" | _ -> "are" in - errorlabstrm "" (str "Cannot substitute the term bound to " ++ pr_id id + user_err (str "Cannot substitute the term bound to " ++ pr_id id ++ strbrk " in pattern because the term refers to " ++ pr_enum pr_id l ++ strbrk " which " ++ str is ++ strbrk " not bound in the pattern.") @@ -315,7 +315,7 @@ let rec subst_pattern subst pat = let mkPLambda na b = PLambda(na,PMeta None,b) let rev_it_mkPLambda = List.fold_right mkPLambda -let err loc pp = user_err_loc (loc,"pattern_of_glob_constr", pp) +let err ?loc pp = user_err ?loc ~hdr:"pattern_of_glob_constr" pp let warn_cast_in_pattern = CWarnings.create ~name:"cast-in-pattern" ~category:"automation" @@ -387,7 +387,7 @@ let rec pat_of_raw metas vars = function rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p)) | (None | Some (GHole _)), _ -> PMeta None | Some p, None -> - user_err_loc (loc,"",strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") + user_err ~loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") in let info = { cip_style = sty; @@ -400,12 +400,12 @@ let rec pat_of_raw metas vars = function one non-trivial branch. These facts are used in [Constrextern]. *) PCase (info, pred, pat_of_raw metas vars c, brs) - | r -> err (loc_of_glob_constr r) (Pp.str "Non supported pattern.") + | r -> err ~loc:(loc_of_glob_constr r) (Pp.str "Non supported pattern.") and pats_of_glob_branches loc metas vars ind brs = let get_arg = function | PatVar(_,na) -> na - | PatCstr(loc,_,_,_) -> err loc (Pp.str "Non supported pattern.") + | PatCstr(loc,_,_,_) -> err ~loc (Pp.str "Non supported pattern.") in let rec get_pat indexes = function | [] -> false, [] @@ -414,10 +414,10 @@ and pats_of_glob_branches loc metas vars ind brs = let () = match ind with | Some sp when eq_ind sp indsp -> () | _ -> - err loc (Pp.str "All constructors must be in the same inductive type.") + err ~loc (Pp.str "All constructors must be in the same inductive type.") in if Int.Set.mem (j-1) indexes then - err loc + err ~loc (str "No unique branch for " ++ int j ++ str"-th constructor."); let lna = List.map get_arg lv in let vars' = List.rev lna @ vars in @@ -425,7 +425,7 @@ and pats_of_glob_branches loc metas vars ind brs = let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in ext, ((j-1, tags, pat) :: pats) - | (loc,_,_,_) :: _ -> err loc (Pp.str "Non supported pattern.") + | (loc,_,_,_) :: _ -> err ~loc (Pp.str "Non supported pattern.") in get_pat Int.Set.empty brs diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 00b6100c0..5b0958695 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -64,43 +64,42 @@ let precatchable_exception = function | Nametab.GlobalizationError _ -> true | _ -> false -let raise_pretype_error (loc,env,sigma,te) = - Loc.raise loc (PretypeError(env,sigma,te)) +let raise_pretype_error ?loc (env,sigma,te) = + Loc.raise ?loc (PretypeError(env,sigma,te)) -let raise_located_type_error (loc,env,sigma,te) = - Loc.raise loc (PretypeError(env,sigma,TypingError te)) +let raise_type_error ?loc (env,sigma,te) = + Loc.raise ?loc (PretypeError(env,sigma,TypingError te)) - -let error_actual_type_loc loc env sigma {uj_val=c;uj_type=actty} expty reason = +let error_actual_type ?loc env sigma {uj_val=c;uj_type=actty} expty reason = let j = {uj_val=c;uj_type=actty} in - raise_pretype_error - (loc, env, sigma, ActualTypeNotCoercible (j, expty, reason)) + raise_pretype_error ?loc + (env, sigma, ActualTypeNotCoercible (j, expty, reason)) -let error_cant_apply_not_functional_loc loc env sigma rator randl = - raise_located_type_error - (loc, env, sigma, CantApplyNonFunctional (rator, Array.of_list randl)) +let error_cant_apply_not_functional ?loc env sigma rator randl = + raise_type_error ?loc + (env, sigma, CantApplyNonFunctional (rator, Array.of_list randl)) -let error_cant_apply_bad_type_loc loc env sigma (n,c,t) rator randl = - raise_located_type_error - (loc, env, sigma, +let error_cant_apply_bad_type ?loc env sigma (n,c,t) rator randl = + raise_type_error ?loc + (env, sigma, CantApplyBadType ((n,c,t), rator, Array.of_list randl)) -let error_ill_formed_branch_loc loc env sigma c i actty expty = - raise_located_type_error - (loc, env, sigma, IllFormedBranch (c, i, actty, expty)) +let error_ill_formed_branch ?loc env sigma c i actty expty = + raise_type_error + ?loc (env, sigma, IllFormedBranch (c, i, actty, expty)) -let error_number_branches_loc loc env sigma cj expn = - raise_located_type_error (loc, env, sigma, NumberBranches (cj, expn)) +let error_number_branches ?loc env sigma cj expn = + raise_type_error ?loc (env, sigma, NumberBranches (cj, expn)) -let error_case_not_inductive_loc loc env sigma cj = - raise_located_type_error (loc, env, sigma, CaseNotInductive cj) +let error_case_not_inductive ?loc env sigma cj = + raise_type_error ?loc (env, sigma, CaseNotInductive cj) -let error_ill_typed_rec_body_loc loc env sigma i na jl tys = - raise_located_type_error - (loc, env, sigma, IllTypedRecBody (i, na, jl, tys)) +let error_ill_typed_rec_body ?loc env sigma i na jl tys = + raise_type_error ?loc + (env, sigma, IllTypedRecBody (i, na, jl, tys)) -let error_not_a_type_loc loc env sigma j = - raise_located_type_error (loc, env, sigma, NotAType j) +let error_not_a_type ?loc env sigma j = + raise_type_error ?loc (env, sigma, NotAType j) (*s Implicit arguments synthesis errors. It is hard to find a precise location. *) @@ -108,15 +107,12 @@ let error_not_a_type_loc loc env sigma j = let error_occur_check env sigma ev c = raise (PretypeError (env, sigma, UnifOccurCheck (ev,c))) -let error_unsolvable_implicit loc env sigma evk explain = - Loc.raise loc +let error_unsolvable_implicit ?loc env sigma evk explain = + Loc.raise ?loc (PretypeError (env, sigma, UnsolvableImplicit (evk, explain))) -let error_cannot_unify_loc loc env sigma ?reason (m,n) = - Loc.raise loc (PretypeError (env, sigma,CannotUnify (m,n,reason))) - -let error_cannot_unify env sigma ?reason (m,n) = - raise (PretypeError (env, sigma,CannotUnify (m,n,reason))) +let error_cannot_unify ?loc env sigma ?reason (m,n) = + Loc.raise ?loc (PretypeError (env, sigma,CannotUnify (m,n,reason))) let error_cannot_unify_local env sigma (m,n,sn) = raise (PretypeError (env, sigma,CannotUnifyLocal (m,n,sn))) @@ -140,21 +136,21 @@ let error_non_linear_unification env sigma hdmeta t = (*s Ml Case errors *) -let error_cant_find_case_type_loc loc env sigma expr = - raise_pretype_error (loc, env, sigma, CantFindCaseType expr) +let error_cant_find_case_type ?loc env sigma expr = + raise_pretype_error ?loc (env, sigma, CantFindCaseType expr) (*s Pretyping errors *) -let error_unexpected_type_loc loc env sigma actty expty = - raise_pretype_error (loc, env, sigma, UnexpectedType (actty, expty)) +let error_unexpected_type ?loc env sigma actty expty = + raise_pretype_error ?loc (env, sigma, UnexpectedType (actty, expty)) -let error_not_product_loc loc env sigma c = - raise_pretype_error (loc, env, sigma, NotProduct c) +let error_not_product ?loc env sigma c = + raise_pretype_error ?loc (env, sigma, NotProduct c) (*s Error in conversion from AST to glob_constr *) -let error_var_not_found_loc loc s = - raise_pretype_error (loc, empty_env, Evd.empty, VarNotFound s) +let error_var_not_found ?loc s = + raise_pretype_error ?loc (empty_env, Evd.empty, VarNotFound s) (*s Typeclass errors *) @@ -166,7 +162,7 @@ let unsatisfiable_constraints env evd ev comp = | Some ev -> let loc, kind = Evd.evar_source ev evd in let err = UnsatisfiableConstraints (Some (ev, kind), comp) in - Loc.raise loc (PretypeError (env,evd,err)) + Loc.raise ~loc (PretypeError (env,evd,err)) let unsatisfiable_exception exn = match exn with diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 880f48e5f..73f81923f 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -64,35 +64,35 @@ exception PretypeError of env * Evd.evar_map * pretype_error val precatchable_exception : exn -> bool (** Raising errors *) -val error_actual_type_loc : - Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> +val error_actual_type : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> unification_error -> 'b -val error_cant_apply_not_functional_loc : - Loc.t -> env -> Evd.evar_map -> +val error_cant_apply_not_functional : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> unsafe_judgment list -> 'b -val error_cant_apply_bad_type_loc : - Loc.t -> env -> Evd.evar_map -> int * constr * constr -> +val error_cant_apply_bad_type : + ?loc:Loc.t -> env -> Evd.evar_map -> int * constr * constr -> unsafe_judgment -> unsafe_judgment list -> 'b -val error_case_not_inductive_loc : - Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b +val error_case_not_inductive : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b -val error_ill_formed_branch_loc : - Loc.t -> env -> Evd.evar_map -> +val error_ill_formed_branch : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> pconstructor -> constr -> constr -> 'b -val error_number_branches_loc : - Loc.t -> env -> Evd.evar_map -> +val error_number_branches : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> int -> 'b -val error_ill_typed_rec_body_loc : - Loc.t -> env -> Evd.evar_map -> +val error_ill_typed_rec_body : + ?loc:Loc.t -> env -> Evd.evar_map -> int -> Name.t array -> unsafe_judgment array -> types array -> 'b -val error_not_a_type_loc : - Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b +val error_not_a_type : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b @@ -101,15 +101,12 @@ val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b val error_unsolvable_implicit : - Loc.t -> env -> Evd.evar_map -> existential_key -> + ?loc:Loc.t -> env -> Evd.evar_map -> existential_key -> Evd.unsolvability_explanation option -> 'b -val error_cannot_unify_loc : Loc.t -> env -> Evd.evar_map -> +val error_cannot_unify : ?loc:Loc.t -> env -> Evd.evar_map -> ?reason:unification_error -> constr * constr -> 'b -val error_cannot_unify : env -> Evd.evar_map -> ?reason:unification_error -> - constr * constr -> 'b - val error_cannot_unify_local : env -> Evd.evar_map -> constr * constr * constr -> 'b val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map -> @@ -126,20 +123,20 @@ val error_non_linear_unification : env -> Evd.evar_map -> (** {6 Ml Case errors } *) -val error_cant_find_case_type_loc : - Loc.t -> env -> Evd.evar_map -> constr -> 'b +val error_cant_find_case_type : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b (** {6 Pretyping errors } *) -val error_unexpected_type_loc : - Loc.t -> env -> Evd.evar_map -> constr -> constr -> 'b +val error_unexpected_type : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> constr -> 'b -val error_not_product_loc : - Loc.t -> env -> Evd.evar_map -> constr -> 'b +val error_not_product : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b (** {6 Error in conversion from AST to glob_constr } *) -val error_var_not_found_loc : Loc.t -> Id.t -> 'b +val error_var_not_found : ?loc:Loc.t -> Id.t -> 'b (** {6 Typeclass errors } *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 6afa55862..2f13121ad 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -43,8 +43,10 @@ open Glob_ops open Evarconv open Pattern open Misctypes +open Tactypes open Sigma.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration type typing_constraint = OfType of types | IsType | WithoutTypeConstraint type var_map = constr_under_binders Id.Map.t @@ -58,8 +60,6 @@ type ltac_var_map = { } type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * constr -type 'a delayed_open = - { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } (************************************************************************) (* This concerns Cases *) @@ -104,7 +104,7 @@ let lookup_named id env = lookup_named id env.env let e_new_evar env evdref ?src ?naming typ = let subst2 subst vsubst c = csubst_subst subst (replace_vars vsubst c) in let open Context.Named.Declaration in - let inst_vars = List.map (fun d -> mkVar (get_id d)) (named_context env.env) in + let inst_vars = List.map (get_id %> mkVar) (named_context env.env) in let inst_rels = List.rev (rel_list 0 (nb_rel env.env)) in let (subst, vsubst, _, nc) = Lazy.force env.extra in let typ' = subst2 subst vsubst typ in @@ -160,7 +160,7 @@ let search_guard loc env possible_indexes fixdefs = with TypeError _ -> ()) (List.combinations possible_indexes); let errmsg = "Cannot guess decreasing argument of fix." in - user_err_loc (loc,"search_guard", Pp.str errmsg) + user_err ~loc ~hdr:"search_guard" (Pp.str errmsg) with Found indexes -> indexes) (* To force universe name declaration before use *) @@ -211,8 +211,8 @@ let interp_universe_level_name evd (loc,s) = with Not_found -> if not (is_strict_universe_declarations ()) then new_univ_level_variable ~loc ~name:s univ_rigid evd - else user_err_loc (loc, "interp_universe_level_name", - Pp.(str "Undeclared universe: " ++ str s)) + else user_err ~loc ~hdr:"interp_universe_level_name" + (Pp.(str "Undeclared universe: " ++ str s)) let interp_universe ?loc evd = function | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in @@ -307,7 +307,7 @@ let check_extra_evars_are_solved env current_sigma pending = match k with | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () | _ -> - error_unsolvable_implicit loc env current_sigma evk None) pending + error_unsolvable_implicit ~loc env current_sigma evk None) pending (* [check_evars] fails if some unresolved evar remains *) @@ -322,7 +322,7 @@ let check_evars env initial_sigma sigma c = let (loc,k) = evar_source evk sigma in match k with | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () - | _ -> Pretype_errors.error_unsolvable_implicit loc env sigma evk None) + | _ -> Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None) | _ -> Constr.iter proc_rec c in proc_rec c @@ -365,9 +365,9 @@ let check_instance loc subst = function | [] -> () | (id,_) :: _ -> if List.mem_assoc id subst then - user_err_loc (loc,"",pr_id id ++ str "appears more than once.") + user_err ~loc (pr_id id ++ str "appears more than once.") else - user_err_loc (loc,"",str "No such variable in the signature of the existential variable: " ++ pr_id id ++ str ".") + user_err ~loc (str "No such variable in the signature of the existential variable: " ++ pr_id id ++ str ".") (* used to enforce a name in Lambda when the type constraints itself is named, hence possibly dependent *) @@ -382,7 +382,7 @@ let ltac_interp_name { ltac_idents ; ltac_genargs } = function try Name (Id.Map.find id ltac_idents) with Not_found -> if Id.Map.mem id ltac_genargs then - errorlabstrm "" (str"Ltac variable"++spc()++ pr_id id ++ + user_err (str"Ltac variable"++spc()++ pr_id id ++ spc()++str"is not bound to an identifier."++spc()++ str"It cannot be used in a binder.") else n @@ -404,14 +404,14 @@ let invert_ltac_bound_name lvar env id0 id = let id' = Id.Map.find id lvar.ltac_idents in try mkRel (pi1 (lookup_rel_id id' (rel_context env))) with Not_found -> - errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++ + user_err (str "Ltac variable " ++ pr_id id0 ++ str " depends on pattern variable name " ++ pr_id id ++ str " which is not bound in current context.") let protected_get_type_of env sigma c = try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c with Retyping.RetypeError _ -> - errorlabstrm "" + user_err (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.") @@ -447,16 +447,16 @@ let pretype_id pretype k0 loc env evdref lvar id = (* and build a nice error message *) if Id.Map.mem id lvar.ltac_genargs then begin let Geninterp.Val.Dyn (typ, _) = Id.Map.find id lvar.ltac_genargs in - user_err_loc (loc,"", - str "Variable " ++ pr_id id ++ str " should be bound to a term but is \ + user_err ~loc + (str "Variable " ++ pr_id id ++ str " should be bound to a term but is \ bound to a " ++ Geninterp.Val.pr typ ++ str ".") end; (* Check if [id] is a section or goal variable *) try - { uj_val = mkVar id; uj_type = (get_type (lookup_named id env)) } + { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id env) } with Not_found -> (* [id] not found, standard error message *) - error_var_not_found_loc loc id + error_var_not_found ~loc id let evar_kind_of_term sigma c = kind_of_term (whd_evar sigma c) @@ -479,16 +479,16 @@ let pretype_global loc rigid env evd gr us = let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in let len = Array.length arr in if len != List.length l then - user_err_loc (loc, "pretype", - str "Universe instance should have length " ++ int len) + user_err ~loc ~hdr:"pretype" + (str "Universe instance should have length " ++ int len) else let evd, l' = List.fold_left (fun (evd, univs) l -> let evd, l = interp_universe_level_name loc evd l in (evd, l :: univs)) (evd, []) l in if List.exists (fun l -> Univ.Level.is_prop l) l' then - user_err_loc (loc, "pretype", - str "Universe instances cannot contain Prop, polymorphic" ++ + user_err ~loc ~hdr:"pretype" + (str "Universe instances cannot contain Prop, polymorphic" ++ str " universe instances must be greater or equal to Set."); evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) in @@ -498,12 +498,12 @@ let pretype_ref loc evdref env ref us = match ref with | VarRef id -> (* Section variable *) - (try make_judge (mkVar id) (get_type (lookup_named id env)) + (try make_judge (mkVar id) (NamedDecl.get_type (lookup_named id env)) with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal variables *) - Pretype_errors.error_var_not_found_loc loc id) + Pretype_errors.error_var_not_found ~loc id) | ref -> let evd, c = pretype_global loc univ_flexible env !evdref ref us in let () = evdref := evd in @@ -559,7 +559,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let evk = try Evd.evar_key id !evdref with Not_found -> - user_err_loc (loc,"",str "Unknown existential variable.") in + user_err ~loc (str "Unknown existential variable.") in let hyps = evar_filtered_context (Evd.find !evdref evk) in let args = pretype_instance k0 resolve_tc env evdref lvar loc hyps evk inst in let c = mkEvar (evk, args) in @@ -742,9 +742,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | _ -> let hj = pretype empty_tycon env evdref lvar c in - error_cant_apply_not_functional_loc - (Loc.merge floc argloc) env.ExtraEnv.env !evdref - resj [hj] + error_cant_apply_not_functional + ~loc:(Loc.merge floc argloc) env.ExtraEnv.env !evdref + resj [hj] in let resj = apply_rec env 1 fj candargs args in let resj = @@ -837,15 +837,15 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre try find_rectype env.ExtraEnv.env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj + error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 1) then - user_err_loc (loc,"",str "Destructing let is only for inductive types" ++ + user_err ~loc (str "Destructing let is only for inductive types" ++ str " with one constructor."); let cs = cstrs.(0) in if not (Int.equal (List.length nal) cs.cs_nargs) then - user_err_loc (loc,"", str "Destructing let on this type expects " ++ + user_err ~loc:loc (str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables."); let fsign, record = match get_projections env.ExtraEnv.env indf with @@ -911,7 +911,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre if noccur_between 1 cs.cs_nargs ccl then lift (- cs.cs_nargs) ccl else - error_cant_find_case_type_loc loc env.ExtraEnv.env !evdref + error_cant_find_case_type ~loc env.ExtraEnv.env !evdref cj.uj_val in (* let ccl = refresh_universes ccl in *) let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in @@ -927,11 +927,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre try find_rectype env.ExtraEnv.env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj in + error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 2) then - user_err_loc (loc,"", - str "If is only for inductive types with two constructors."); + user_err ~loc + (str "If is only for inductive types with two constructors."); let arsgn = let arsgn,_ = get_arity env.ExtraEnv.env indf in @@ -1013,9 +1013,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let (evd,b) = Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval + error_actual_type ~loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) - else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ + else user_err ~loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> let cj = pretype empty_tycon env evdref lvar c in @@ -1024,7 +1024,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval + error_actual_type ~loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) end | _ -> @@ -1036,8 +1036,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = let f decl (subst,update) = - let id = get_id decl in - let t = replace_vars subst (get_type decl) in + let id = NamedDecl.get_id decl in + let t = replace_vars subst (NamedDecl.get_type decl) in let c, update = try let c = List.assoc id update in @@ -1049,10 +1049,10 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = if is_conv env.ExtraEnv.env !evdref t t' then mkRel n, update else raise Not_found with Not_found -> try - let t' = lookup_named id env |> get_type in + let t' = env |> lookup_named id |> NamedDecl.get_type in if is_conv env.ExtraEnv.env !evdref t t' then mkVar id, update else raise Not_found with Not_found -> - user_err_loc (loc,"",str "Cannot interpret " ++ + user_err ~loc (str "Cannot interpret " ++ pr_existential_key !evdref evk ++ str " in current context: no binding for " ++ pr_id id ++ str ".") in ((id,c)::subst, update) in @@ -1090,8 +1090,8 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function | Some v -> if e_cumul env.ExtraEnv.env evdref v tj.utj_val then tj else - error_unexpected_type_loc - (loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v + error_unexpected_type + ~loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v let ise_pretype_gen flags env sigma lvar kind c = let env = make_env env in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index eead48a54..e09648ec3 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -57,9 +57,6 @@ type inference_flags = { expand_evars : bool } -type 'a delayed_open = - { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } - val default_inference_flags : bool -> inference_flags val no_classes_no_fail_inference_flags : inference_flags @@ -122,7 +119,7 @@ val understand_judgment_tcc : env -> evar_map ref -> val type_uconstr : ?flags:inference_flags -> ?expected_type:typing_constraint -> - Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open + Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr Tactypes.delayed_open (** Trying to solve remaining evars and remaining conversion problems possibly using type classes, heuristics, external tactic solver diff --git a/pretyping/program.ml b/pretyping/program.ml index 62aedcfbf..4b6137b53 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -19,7 +19,7 @@ let find_reference locstr dir s = let sp = Libnames.make_path dp (Id.of_string s) in try Nametab.global_of_path sp with Not_found -> - user_err_loc (Loc.ghost, "", str "Library " ++ Libnames.pr_dirpath dp ++ + user_err (str "Library " ++ Libnames.pr_dirpath dp ++ str " has to be required first.") let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 284af0cb1..cda052b79 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -291,7 +291,7 @@ let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) (*s High-level declaration of a canonical structure *) let error_not_structure ref = - errorlabstrm "object_declare" + user_err ~hdr:"object_declare" (Nameops.pr_id (basename_of_global ref) ++ str" is not a structure object.") let check_and_decompose_canonical_structure ref = diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 332d4e0b2..0ab941b34 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1230,7 +1230,7 @@ let pb_equal = function | Reduction.CONV -> Reduction.CONV let report_anomaly _ = - let e = UserError ("", Pp.str "Conversion test raised an anomaly") in + let e = UserError (None, Pp.str "Conversion test raised an anomaly") in let e = CErrors.push e in iraise e diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 98b36fb92..5b67af3e7 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -20,6 +20,9 @@ open Termops open Arguments_renaming open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + type retype_error = | NotASort | NotAnArity @@ -78,8 +81,7 @@ let sort_of_atomic_type env sigma ft args = in concl_of_arity env 0 ft (Array.to_list args) let type_of_var env id = - let open Context.Named.Declaration in - try get_type (lookup_named id env) + try NamedDecl.get_type (lookup_named id env) with Not_found -> retype_error (BadVariable id) let decomp_sort env sigma t = @@ -94,7 +96,7 @@ let retype ?(polyprop=true) sigma = (try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus with Not_found -> retype_error (BadMeta n)) | Rel n -> - let ty = get_type (lookup_rel n env) in + let ty = RelDecl.get_type (lookup_rel n env) in lift n ty | Var id -> type_of_var env id | Const cst -> rename_type_of_constant env cst @@ -239,7 +241,7 @@ let sorts_of_context env evc ctxt = | [] -> env,[] | d :: ctxt -> let env,sorts = aux ctxt in - let s = get_sort_of env evc (get_type d) in + let s = get_sort_of env evc (RelDecl.get_type d) in (push_rel d env,s::sorts) in snd (aux ctxt) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 820a81b5d..7da738508 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -25,6 +25,9 @@ open Patternops open Locus open Sigma.Notations +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (* Errors *) type reduction_tactic_error = @@ -38,7 +41,7 @@ exception Elimconst exception Redelimination let error_not_evaluable r = - errorlabstrm "error_not_evaluable" + user_err ~hdr:"error_not_evaluable" (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r ++ spc () ++ str "to an evaluable reference.") @@ -54,13 +57,12 @@ let is_evaluable env = function | EvalVarRef id -> is_evaluable_var env id let value_of_evaluable_ref env evref u = - let open Context.Named.Declaration in match evref with | EvalConstRef con -> (try constant_value_in env (con,u) with NotEvaluableConst IsProj -> raise (Invalid_argument "value_of_evaluable_ref")) - | EvalVarRef id -> lookup_named id env |> get_value |> Option.get + | EvalVarRef id -> env |> lookup_named id |> NamedDecl.get_value |> Option.get let evaluable_of_global_reference env = function | ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst @@ -112,22 +114,18 @@ let unsafe_reference_opt_value env sigma eval = | Declarations.Def c -> Some (Mod_subst.force_constr c) | _ -> None) | EvalVar id -> - let open Context.Named.Declaration in - lookup_named id env |> get_value + env |> lookup_named id |> NamedDecl.get_value | EvalRel n -> - let open Context.Rel.Declaration in - lookup_rel n env |> map_value (lift n) |> get_value + env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value | EvalEvar ev -> Evd.existential_opt_value sigma ev let reference_opt_value env sigma eval u = match eval with | EvalConst cst -> constant_opt_value_in env (cst,u) | EvalVar id -> - let open Context.Named.Declaration in - lookup_named id env |> get_value + env |> lookup_named id |> NamedDecl.get_value | EvalRel n -> - let open Context.Rel.Declaration in - lookup_rel n env |> map_value (lift n) |> get_value + env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value | EvalEvar ev -> Evd.existential_opt_value sigma ev exception NotEvaluable @@ -541,11 +539,9 @@ let match_eval_ref_value env sigma constr = | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> Some (constant_value_in env (sp, u)) | Var id when is_evaluable env (EvalVarRef id) -> - let open Context.Named.Declaration in - lookup_named id env |> get_value + env |> lookup_named id |> NamedDecl.get_value | Rel n -> - let open Context.Rel.Declaration in - lookup_rel n env |> map_value (lift n) |> get_value + env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value | Evar ev -> Evd.existential_opt_value sigma ev | _ -> None @@ -993,7 +989,7 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> incr pos; if ok then begin if Option.has_some nested then - errorlabstrm "" (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (!pos-1) ++ str "."); + user_err (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (!pos-1) ++ str "."); (* Skip inner occurrences for stable counting of occurrences *) if locs != [] then ignore (traverse_below (Some (!pos-1)) envc t); @@ -1159,13 +1155,13 @@ let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> let check_privacy env ind = let spec = Inductive.lookup_mind_specif env (fst ind) in if Inductive.is_private spec then - errorlabstrm "" (str "case analysis on a private type.") + user_err (str "case analysis on a private type.") else ind let check_not_primitive_record env ind = let spec = Inductive.lookup_mind_specif env (fst ind) in if Inductive.is_primitive_record spec then - errorlabstrm "" (str "case analysis on a primitive record type: " ++ + user_err (str "case analysis on a primitive record type: " ++ str "use projections or let instead.") else ind @@ -1182,14 +1178,14 @@ let reduce_to_ind_gen allow_product env sigma t = if allow_product then elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) else - errorlabstrm "" (str"Not an inductive definition.") + user_err (str"Not an inductive definition.") | _ -> (* Last chance: we allow to bypass the Opaque flag (as it was partially the case between V5.10 and V8.1 *) let t' = whd_all env sigma t in match kind_of_term (fst (decompose_app t')) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) - | _ -> errorlabstrm "" (str"Not an inductive product.") + | _ -> user_err (str"Not an inductive product.") in elimrec env t [] @@ -1239,7 +1235,7 @@ let one_step_reduce env sigma c = applist (redrec (c,[])) let error_cannot_recognize ref = - errorlabstrm "" + user_err (str "Cannot recognize a statement based on " ++ Nametab.pr_global_env Id.Set.empty ref ++ str".") diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 31ef3dfdd..4207eccb9 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -17,6 +17,9 @@ open Util open Typeclasses_errors open Libobject open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration (*i*) let typeclasses_unique_solutions = ref false @@ -181,7 +184,7 @@ let subst_class (subst,cl) = let do_subst_con c = Mod_subst.subst_constant subst c and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in - let do_subst_ctx = List.smartmap (map_constr do_subst) in + let do_subst_ctx = List.smartmap (RelDecl.map_constr do_subst) in let do_subst_context (grs,ctx) = List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, do_subst_ctx ctx in @@ -197,19 +200,16 @@ let subst_class (subst,cl) = let discharge_class (_,cl) = let repl = Lib.replacement_context () in let rel_of_variable_context ctx = List.fold_right - ( fun (n,_,b,t) (ctx', subst) -> - let decl = match b with - | None -> LocalAssum (Name n, substn_vars 1 subst t) - | Some b -> LocalDef (Name n, substn_vars 1 subst b, substn_vars 1 subst t) - in - (decl :: ctx', n :: subst) + ( fun (decl,_) (ctx', subst) -> + let decl' = decl |> NamedDecl.map_constr (substn_vars 1 subst) |> NamedDecl.to_rel_decl in + (decl' :: ctx', NamedDecl.get_id decl :: subst) ) ctx ([], []) in let discharge_rel_context subst n rel = let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in let ctx, _ = List.fold_right (fun decl (ctx, k) -> - map_constr (substn_vars k subst) decl :: ctx, succ k + RelDecl.map_constr (substn_vars k subst) decl :: ctx, succ k ) rel ([], n) in ctx @@ -222,7 +222,7 @@ let discharge_class (_,cl) = let discharge_context ctx' subst (grs, ctx) = let grs' = let newgrs = List.map (fun decl -> - match decl |> get_type |> class_of_constr with + match decl |> RelDecl.get_type |> class_of_constr with | None -> None | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) ctx' diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 9e9997f73..e79e3d46f 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -132,7 +132,7 @@ let check_type_fixpoint loc env evdref lna lar vdefj = for i = 0 to lt-1 do if not (Evarconv.e_cumul env evdref (vdefj.(i)).uj_type (lift lt lar.(i))) then - Pretype_errors.error_ill_typed_rec_body_loc loc env !evdref + Pretype_errors.error_ill_typed_rec_body ~loc env !evdref i lna vdefj lar done diff --git a/pretyping/unification.ml b/pretyping/unification.ml index e0a81cfbb..e73c5ffaf 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -29,7 +29,9 @@ open Locus open Locusops open Find_subterm open Sigma.Notations -open Context.Named.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration let keyed_unification = ref (false) let _ = Goptions.declare_bool_option { @@ -78,9 +80,8 @@ let occur_meta_evd sigma mv c = let abstract_scheme env evd c l lname_typ = List.fold_left2 (fun (t,evd) (locc,a) decl -> - let open Context.Rel.Declaration in - let na = get_name decl in - let ta = get_type decl in + let na = RelDecl.get_name decl in + let ta = RelDecl.get_type decl in let na = match kind_of_term a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... @@ -1476,10 +1477,10 @@ let indirectly_dependent c d decls = it is needed otherwise, as e.g. when abstracting over "2" in "forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious way to see that the second hypothesis depends indirectly over 2 *) - List.exists (fun d' -> dependent_in_decl (mkVar (get_id d')) d) decls + List.exists (fun d' -> dependent_in_decl (mkVar (NamedDecl.get_id d')) d) decls let indirect_dependency d decls = - decls |> List.filter (fun d' -> dependent_in_decl (mkVar (get_id d')) d) |> List.hd |> get_id + decls |> List.filter (fun d' -> dependent_in_decl (mkVar (NamedDecl.get_id d')) d) |> List.hd |> NamedDecl.get_id let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = let current_sigma = Sigma.to_evar_map current_sigma in @@ -1590,7 +1591,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else if mem_named_context_val x (named_context_val env) then - errorlabstrm "Unification.make_abstraction_core" + user_err ~hdr:"Unification.make_abstraction_core" (str "The variable " ++ Nameops.pr_id x ++ str " is already declared.") else x @@ -1598,7 +1599,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let likefirst = clause_with_generic_occurrences occs in let mkvarid () = mkVar id in let compute_dependency _ d (sign,depdecls) = - let hyp = get_id d in + let hyp = NamedDecl.get_id d in match occurrences_of_hyp hyp occs with | NoOccurrences, InHyp -> (push_named_context_val d sign,depdecls) @@ -1628,7 +1629,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = replace_term_occ_modulo occ test mkvarid concl in let lastlhyp = - if List.is_empty depdecls then None else Some (get_id (List.last depdecls)) in + if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in let res = match out test with | None -> None | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma)) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index e281f22df..75159bf8b 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -17,6 +17,9 @@ open Reduction open Vm open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (*******************************************) (* Calcul de la forme normal d'un terme *) (*******************************************) @@ -207,12 +210,11 @@ and constr_type_of_idkey env (idkey : Vars.id_key) stk = in nf_univ_args ~nb_univs mk env stk | VarKey id -> - let open Context.Named.Declaration in - let ty = get_type (lookup_named id env) in + let ty = NamedDecl.get_type (lookup_named id env) in nf_stk env (mkVar id) ty stk | RelKey i -> let n = (nb_rel env - i) in - let ty = get_type (lookup_rel n env) in + let ty = RelDecl.get_type (lookup_rel n env) in nf_stk env (mkRel n) (lift n ty) stk and nf_stk ?from:(from=0) env c t stk = diff --git a/printing/genprint.ml b/printing/genprint.ml index 0ec35e07b..6505a8f82 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -9,15 +9,17 @@ open Pp open Genarg -type ('raw, 'glb, 'top) printer = { - raw : 'raw -> std_ppcmds; - glb : 'glb -> std_ppcmds; - top : 'top -> std_ppcmds; +type 'a printer = 'a -> std_ppcmds + +type ('raw, 'glb, 'top) genprinter = { + raw : 'raw printer; + glb : 'glb printer; + top : 'top printer; } module PrintObj = struct - type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) printer + type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) genprinter let name = "printer" let default wit = match wit with | ExtraArg tag -> diff --git a/printing/genprint.mli b/printing/genprint.mli index 6e6626f2f..5381fc5bd 100644 --- a/printing/genprint.mli +++ b/printing/genprint.mli @@ -11,6 +11,8 @@ open Pp open Genarg +type 'a printer = 'a -> std_ppcmds + val raw_print : ('raw, 'glb, 'top) genarg_type -> 'raw -> std_ppcmds (** Printer for raw level generic arguments. *) @@ -20,9 +22,9 @@ val glb_print : ('raw, 'glb, 'top) genarg_type -> 'glb -> std_ppcmds val top_print : ('raw, 'glb, 'top) genarg_type -> 'top -> std_ppcmds (** Printer for top level generic arguments. *) -val generic_raw_print : rlevel generic_argument -> std_ppcmds -val generic_glb_print : glevel generic_argument -> std_ppcmds -val generic_top_print : tlevel generic_argument -> std_ppcmds +val generic_raw_print : rlevel generic_argument printer +val generic_glb_print : glevel generic_argument printer +val generic_top_print : tlevel generic_argument printer val register_print0 : ('raw, 'glb, 'top) genarg_type -> - ('raw -> std_ppcmds) -> ('glb -> std_ppcmds) -> ('top -> std_ppcmds) -> unit + 'raw printer -> 'glb printer -> 'top printer -> unit diff --git a/printing/ppannotation.ml b/printing/ppannotation.ml index 511f93569..726c0ffcf 100644 --- a/printing/ppannotation.ml +++ b/printing/ppannotation.ml @@ -9,29 +9,23 @@ open Ppextend open Constrexpr open Vernacexpr -open Tacexpr +open Genarg type t = | AKeyword | AUnparsing of unparsing | AConstrExpr of constr_expr | AVernac of vernac_expr - | AGlobTacticExpr of glob_tactic_expr - | AGlobAtomicTacticExpr of glob_atomic_tactic_expr - | ARawTacticExpr of raw_tactic_expr - | ARawAtomicTacticExpr of raw_atomic_tactic_expr - | AAtomicTacticExpr of atomic_tactic_expr + | AGlbGenArg of glob_generic_argument + | ARawGenArg of raw_generic_argument let tag_of_annotation = function | AKeyword -> "keyword" | AUnparsing _ -> "unparsing" | AConstrExpr _ -> "constr_expr" | AVernac _ -> "vernac_expr" - | AGlobTacticExpr _ -> "glob_tactic_expr" - | AGlobAtomicTacticExpr _ -> "glob_atomic_tactic_expr" - | ARawTacticExpr _ -> "raw_tactic_expr" - | ARawAtomicTacticExpr _ -> "raw_atomic_tactic_expr" - | AAtomicTacticExpr _ -> "atomic_tactic_expr" + | AGlbGenArg _ -> "glob_generic_argument" + | ARawGenArg _ -> "raw_generic_argument" let attributes_of_annotation a = [] diff --git a/printing/ppannotation.mli b/printing/ppannotation.mli index a0fef1a75..b0e0facef 100644 --- a/printing/ppannotation.mli +++ b/printing/ppannotation.mli @@ -12,18 +12,15 @@ open Ppextend open Constrexpr open Vernacexpr -open Tacexpr +open Genarg type t = | AKeyword | AUnparsing of unparsing | AConstrExpr of constr_expr | AVernac of vernac_expr - | AGlobTacticExpr of glob_tactic_expr - | AGlobAtomicTacticExpr of glob_atomic_tactic_expr - | ARawTacticExpr of raw_tactic_expr - | ARawAtomicTacticExpr of raw_atomic_tactic_expr - | AAtomicTacticExpr of atomic_tactic_expr + | AGlbGenArg of glob_generic_argument + | ARawGenArg of raw_generic_argument val tag_of_annotation : t -> string diff --git a/printing/pputils.ml b/printing/pputils.ml index 50ce56fb0..50630fb9b 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -6,7 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Util open Pp +open Genarg +open Nameops +open Misctypes +open Locus +open Genredexpr let pr_located pr (loc, x) = if !Flags.beautify && loc <> Loc.ghost then @@ -17,3 +23,130 @@ let pr_located pr (loc, x) = let after = Pp.comment (CLexer.extract_comments e) in before ++ x ++ after else pr x + +let pr_or_var pr = function + | ArgArg x -> pr x + | ArgVar (_,s) -> pr_id s + +let pr_with_occurrences pr keyword (occs,c) = + match occs with + | AllOccurrences -> + pr c + | NoOccurrences -> + failwith "pr_with_occurrences: no occurrences" + | OnlyOccurrences nl -> + hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++ + hov 0 (prlist_with_sep spc (pr_or_var int) nl)) + | AllOccurrencesBut nl -> + hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++ + hov 0 (prlist_with_sep spc (pr_or_var int) nl)) + +exception ComplexRedFlag + +let pr_short_red_flag pr r = + if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then + raise ComplexRedFlag + else if List.is_empty r.rConst then + if r.rDelta then mt () else raise ComplexRedFlag + else (if r.rDelta then str "-" else mt ()) ++ + hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]") + +let pr_red_flag pr r = + try pr_short_red_flag pr r + with complexRedFlags -> + (if r.rBeta then pr_arg str "beta" else mt ()) ++ + (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else + (if r.rMatch then pr_arg str "match" else mt ()) ++ + (if r.rFix then pr_arg str "fix" else mt ()) ++ + (if r.rCofix then pr_arg str "cofix" else mt ())) ++ + (if r.rZeta then pr_arg str "zeta" else mt ()) ++ + (if List.is_empty r.rConst then + if r.rDelta then pr_arg str "delta" + else mt () + else + pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++ + hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) + +let pr_union pr1 pr2 = function + | Inl a -> pr1 a + | Inr b -> pr2 b + +let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function + | Red false -> keyword "red" + | Hnf -> keyword "hnf" + | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f) + ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + | Cbv f -> + if f.rBeta && f.rMatch && f.rFix && f.rCofix && + f.rZeta && f.rDelta && List.is_empty f.rConst then + keyword "compute" + else + hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f) + | Lazy f -> + hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f) + | Cbn f -> + hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f) + | Unfold l -> + hov 1 (keyword "unfold" ++ spc() ++ + prlist_with_sep pr_comma (pr_with_occurrences pr_ref keyword) l) + | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l) + | Pattern l -> + hov 1 (keyword "pattern" ++ + pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr keyword)) l) + + | Red true -> + CErrors.error "Shouldn't be accessible from user." + | ExtraRedExpr s -> + str s + | CbvVm o -> + keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + | CbvNative o -> + keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + +let pr_or_by_notation f = function + | AN v -> f v + | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + +let hov_if_not_empty n p = if Pp.ismt p then p else hov n p + +let rec pr_raw_generic env (GenArg (Rawwit wit, x)) = + match wit with + | ListArg wit -> + let map x = pr_raw_generic env (in_gen (rawwit wit) x) in + let ans = pr_sequence map x in + hov_if_not_empty 0 ans + | OptArg wit -> + let ans = match x with + | None -> mt () + | Some x -> pr_raw_generic env (in_gen (rawwit wit) x) + in + hov_if_not_empty 0 ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = in_gen (rawwit wit1) p in + let q = in_gen (rawwit wit2) q in + hov_if_not_empty 0 (pr_sequence (pr_raw_generic env) [p; q]) + | ExtraArg s -> + Genprint.generic_raw_print (in_gen (rawwit wit) x) + + +let rec pr_glb_generic env (GenArg (Glbwit wit, x)) = + match wit with + | ListArg wit -> + let map x = pr_glb_generic env (in_gen (glbwit wit) x) in + let ans = pr_sequence map x in + hov_if_not_empty 0 ans + | OptArg wit -> + let ans = match x with + | None -> mt () + | Some x -> pr_glb_generic env (in_gen (glbwit wit) x) + in + hov_if_not_empty 0 ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = in_gen (glbwit wit1) p in + let q = in_gen (glbwit wit2) q in + let ans = pr_sequence (pr_glb_generic env) [p; q] in + hov_if_not_empty 0 ans + | ExtraArg s -> + Genprint.generic_glb_print (in_gen (glbwit wit) x) diff --git a/printing/pputils.mli b/printing/pputils.mli index a0f2c7728..b236fed70 100644 --- a/printing/pputils.mli +++ b/printing/pputils.mli @@ -7,7 +7,25 @@ (************************************************************************) open Pp +open Genarg +open Misctypes +open Locus +open Genredexpr val pr_located : ('a -> std_ppcmds) -> 'a Loc.located -> std_ppcmds (** Prints an object surrounded by its commented location *) +val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds +val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds +val pr_with_occurrences : + ('a -> std_ppcmds) -> (string -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds + +val pr_short_red_flag : ('a -> std_ppcmds) -> 'a glob_red_flag -> std_ppcmds +val pr_red_flag : ('a -> std_ppcmds) -> 'a glob_red_flag -> std_ppcmds +val pr_red_expr : + ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> + (string -> std_ppcmds) -> + ('a,'b,'c) red_expr_gen -> std_ppcmds + +val pr_raw_generic : Environ.env -> rlevel generic_argument -> std_ppcmds +val pr_glb_generic : Environ.env -> glevel generic_argument -> std_ppcmds diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index cfb4e79f0..5d7249aff 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -21,7 +21,6 @@ open Decl_kinds module Make (Ppconstr : Ppconstrsig.Pp) - (Pptactic : Pptacticsig.Pp) (Taggers : sig val tag_keyword : std_ppcmds -> std_ppcmds val tag_vernac : vernac_expr -> std_ppcmds -> std_ppcmds @@ -30,7 +29,6 @@ module Make open Taggers open Ppconstr - open Pptactic let keyword s = tag_keyword (str s) @@ -67,7 +65,7 @@ module Make | (loc,Name id) -> pr_lident (loc,id) | lna -> pr_located pr_name lna - let pr_smart_global = pr_or_by_notation pr_reference + let pr_smart_global = Pputils.pr_or_by_notation pr_reference let pr_ltac_ref = Libnames.pr_reference @@ -81,7 +79,7 @@ module Make | VernacEndSubproof -> str"" | _ -> str"." - let pr_gen t = pr_raw_generic (Global.env ()) t + let pr_gen t = Pputils.pr_raw_generic (Global.env ()) t let sep = fun _ -> spc() let sep_v2 = fun _ -> str"," ++ spc() @@ -195,7 +193,7 @@ module Make | HintsExtern (n,c,tac) -> let pat = match c with None -> mt () | Some pat -> pr_pat pat in keyword "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++ - spc() ++ pr_raw_tactic tac + spc() ++ Pputils.pr_raw_generic (Global.env ()) tac in hov 2 (keyword "Hint "++ pph ++ opth) @@ -703,7 +701,7 @@ module Make | None -> mt() | Some r -> keyword "Eval" ++ spc() ++ - pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) r ++ + pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ keyword " in" ++ spc() in let pr_def_body = function @@ -1135,7 +1133,7 @@ module Make let pr_mayeval r c = match r with | Some r0 -> hov 2 (keyword "Eval" ++ spc() ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r0 ++ + pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ spc() ++ keyword "in" ++ spc () ++ pr_lconstr c) | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c) in @@ -1146,7 +1144,7 @@ module Make | VernacDeclareReduction (s,r) -> return ( keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r + pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r ) | VernacPrint p -> return (pr_printable p) @@ -1187,12 +1185,12 @@ module Make return (keyword "Proof " ++ spc () ++ keyword "using" ++ spc() ++ pr_using e) | VernacProof (Some te, None) -> - return (keyword "Proof with" ++ spc() ++ pr_raw_tactic te) + return (keyword "Proof with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te) | VernacProof (Some te, Some e) -> return ( keyword "Proof" ++ spc () ++ keyword "using" ++ spc() ++ pr_using e ++ spc() ++ - keyword "with" ++ spc() ++pr_raw_tactic te + keyword "with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te ) | VernacProofMode s -> return (keyword "Proof Mode" ++ str s) @@ -1231,7 +1229,7 @@ module Make end -include Make (Ppconstr) (Pptactic) (struct +include Make (Ppconstr) (struct let do_not_tag _ x = x let tag_keyword = do_not_tag () let tag_vernac = do_not_tag @@ -1241,7 +1239,6 @@ module Richpp = struct include Make (Ppconstr.Richpp) - (Pptactic.Richpp) (struct open Ppannotation let tag_keyword s = Pp.tag (Pp.Tag.inj AKeyword tag) s diff --git a/printing/prettyp.ml b/printing/prettyp.ml index f71719cb9..3d0b07a1e 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -27,6 +27,10 @@ open Recordops open Misctypes open Printer open Printmod +open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration type object_pr = { print_inductive : mutual_inductive -> std_ppcmds; @@ -132,7 +136,6 @@ let print_renames_list prefix l = let need_expansion impl ref = let typ = Global.type_of_global_unsafe ref in let ctx = prod_assum typ in - let open Context.Rel.Declaration in let nprods = List.count is_local_assum ctx in not (List.is_empty impl) && List.length impl >= nprods && let _,lastimpl = List.chop nprods impl in @@ -170,9 +173,8 @@ type opacity = | TransparentMaybeOpacified of Conv_oracle.level let opacity env = - let open Context.Named.Declaration in function - | VarRef v when is_local_def (Environ.lookup_named v env) -> + | VarRef v when NamedDecl.is_local_def (Environ.lookup_named v env) -> Some(TransparentMaybeOpacified (Conv_oracle.get_strategy (Environ.oracle env) (VarKey v))) | ConstRef cst -> @@ -700,7 +702,7 @@ let read_sec_context r = let dir = try Nametab.locate_section qid with Not_found -> - user_err_loc (loc,"read_sec_context", str "Unknown section.") in + user_err ~loc ~hdr:"read_sec_context" (str "Unknown section.") in let rec get_cxt in_cxt = function | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest -> if DirPath.equal dir dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest @@ -733,11 +735,10 @@ let print_any_name = function try (* Var locale de but, pas var de section... donc pas d'implicits *) let dir,str = repr_qualid qid in if not (DirPath.is_empty dir) then raise Not_found; - let open Context.Named.Declaration in - str |> Global.lookup_named |> set_id str |> print_named_decl + str |> Global.lookup_named |> NamedDecl.set_id str |> print_named_decl with Not_found -> - errorlabstrm - "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") + user_err + ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") let print_name = function | ByNotation (loc,ntn,sc) -> @@ -762,8 +763,7 @@ let print_opaque_name qid = let ty = Universes.unsafe_type_of_global gr in print_typed_value (mkConstruct cstr, ty) | VarRef id -> - let open Context.Named.Declaration in - lookup_named id env |> set_id id |> print_named_decl + env |> lookup_named id |> NamedDecl.set_id id |> print_named_decl let print_about_any loc k = match k with @@ -831,7 +831,7 @@ let index_of_class cl = try fst (class_info cl) with Not_found -> - errorlabstrm "index_of_class" + user_err ~hdr:"index_of_class" (pr_class cl ++ spc() ++ str "not a defined class.") let print_path_between cls clt = @@ -841,7 +841,7 @@ let print_path_between cls clt = try lookup_path_between_class (i,j) with Not_found -> - errorlabstrm "index_cl_of_id" + user_err ~hdr:"index_cl_of_id" (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt ++ str ".") in diff --git a/printing/printer.ml b/printing/printer.ml index 608bca62a..3c8ad4255 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -22,6 +22,10 @@ open Constrextern open Ppconstr open Declarations +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration +module CompactedDecl = Context.Compacted.Declaration + let emacs_str s = if !Flags.print_emacs then s else "" let delayed_emacs_cmd s = @@ -248,31 +252,30 @@ let pr_pattern t = pr_pattern_env (Global.env()) empty_names_context t*) (**********************************************************************) (* Contexts and declarations *) -let pr_var_decl_skel pr_id env sigma (id,c,typ) = - let pbody = match c with - | None -> (mt ()) - | Some c -> - (* Force evaluation *) - let pb = pr_lconstr_env env sigma c in - let pb = if isCast c then surround pb else pb in - (str" := " ++ pb ++ cut () ) in +let pr_compacted_decl env sigma decl = + let ids, pbody, typ = match decl with + | CompactedDecl.LocalAssum (ids, typ) -> + ids, mt (), typ + | CompactedDecl.LocalDef (ids,c,typ) -> + (* Force evaluation *) + let pb = pr_lconstr_env env sigma c in + let pb = if isCast c then surround pb else pb in + ids, (str" := " ++ pb ++ cut ()), typ + in + let pids = prlist_with_sep pr_comma pr_id ids in let pt = pr_ltype_env env sigma typ in let ptyp = (str" : " ++ pt) in - (pr_id id ++ hov 0 (pbody ++ ptyp)) - -let pr_var_decl env sigma d = - pr_var_decl_skel pr_id env sigma (Context.Named.Declaration.to_tuple d) + hov 0 (pids ++ pbody ++ ptyp) -let pr_var_list_decl env sigma (l,c,typ) = - hov 0 (pr_var_decl_skel (fun ids -> prlist_with_sep pr_comma pr_id ids) env sigma (l,c,typ)) +let pr_named_decl env sigma decl = + decl |> CompactedDecl.of_named_decl |> pr_compacted_decl env sigma let pr_rel_decl env sigma decl = - let open Context.Rel.Declaration in - let na = get_name decl in - let typ = get_type decl in + let na = RelDecl.get_name decl in + let typ = RelDecl.get_type decl in let pbody = match decl with - | LocalAssum _ -> mt () - | LocalDef (_,c,_) -> + | RelDecl.LocalAssum _ -> mt () + | RelDecl.LocalDef (_,c,_) -> (* Force evaluation *) let pb = pr_lconstr_env env sigma c in let pb = if isCast c then surround pb else pb in @@ -289,13 +292,13 @@ let pr_rel_decl env sigma decl = (* Prints a signature, all declarations on the same line if possible *) let pr_named_context_of env sigma = - let make_decl_list env d pps = pr_var_decl env sigma d :: pps in + let make_decl_list env d pps = pr_named_decl env sigma d :: pps in let psl = List.rev (fold_named_context make_decl_list env ~init:[]) in hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl) let pr_named_context env sigma ne_context = hv 0 (Context.Named.fold_outside - (fun d pps -> pps ++ ws 2 ++ pr_var_decl env sigma d) + (fun d pps -> pps ++ ws 2 ++ pr_named_decl env sigma d) ne_context ~init:(mt ())) let pr_rel_context env sigma rel_context = @@ -307,9 +310,9 @@ let pr_rel_context_of env sigma = (* Prints an env (variables and de Bruijn). Separator: newline *) let pr_context_unlimited env sigma = let sign_env = - Context.NamedList.fold + Context.Compacted.fold (fun d pps -> - let pidt = pr_var_list_decl env sigma d in + let pidt = pr_compacted_decl env sigma d in (pps ++ fnl () ++ pidt)) (Termops.compact_named_context (named_context env)) ~init:(mt ()) in @@ -334,12 +337,12 @@ let pr_context_limit n env sigma = else let k = lgsign-n in let _,sign_env = - Context.NamedList.fold + Context.Compacted.fold (fun d (i,pps) -> if i < k then (i+1, (pps ++str ".")) else - let pidt = pr_var_list_decl env sigma d in + let pidt = pr_compacted_decl env sigma d in (i+1, (pps ++ fnl () ++ str (emacs_str "") ++ pidt))) @@ -417,8 +420,7 @@ let pr_evgl_sign sigma evi = | None -> [], [] | Some f -> List.filter2 (fun b c -> not b) f (evar_context evi) in - let open Context.Named.Declaration in - let ids = List.rev_map get_id l in + let ids = List.rev_map NamedDecl.get_id l in let warn = if List.is_empty ids then mt () else (str "(" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)") diff --git a/printing/printer.mli b/printing/printer.mli index 695ab33b2..20032012a 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -108,8 +108,8 @@ val pr_pconstructor : env -> pconstructor -> std_ppcmds val pr_context_unlimited : env -> evar_map -> std_ppcmds val pr_ne_context_of : std_ppcmds -> env -> evar_map -> std_ppcmds -val pr_var_decl : env -> evar_map -> Context.Named.Declaration.t -> std_ppcmds -val pr_var_list_decl : env -> evar_map -> Context.NamedList.Declaration.t -> std_ppcmds +val pr_named_decl : env -> evar_map -> Context.Named.Declaration.t -> std_ppcmds +val pr_compacted_decl : env -> evar_map -> Context.Compacted.Declaration.t -> std_ppcmds val pr_rel_decl : env -> evar_map -> Context.Rel.Declaration.t -> std_ppcmds val pr_named_context : env -> evar_map -> Context.Named.t -> std_ppcmds diff --git a/printing/printing.mllib b/printing/printing.mllib index bc8f0750e..b0141b6d3 100644 --- a/printing/printing.mllib +++ b/printing/printing.mllib @@ -3,7 +3,6 @@ Pputils Ppannotation Ppconstr Printer -Pptactic Printmod Prettyp Ppvernac diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 0a90e0dbd..fad656223 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -155,7 +155,7 @@ let error_incompatible_inst clenv mv = let na = meta_name clenv.evd mv in match na with Name id -> - errorlabstrm "clenv_assign" + user_err ~hdr:"clenv_assign" (str "An incompatible instantiation has already been found for " ++ pr_id id) | _ -> @@ -417,11 +417,11 @@ let qhyp_eq h1 h2 = match h1, h2 with let check_bindings bl = match List.duplicates qhyp_eq (List.map pi2 bl) with | NamedHyp s :: _ -> - errorlabstrm "" + user_err (str "The variable " ++ pr_id s ++ str " occurs more than once in binding list."); | AnonHyp n :: _ -> - errorlabstrm "" + user_err (str "The position " ++ int n ++ str " occurs more than once in binding list.") | [] -> () @@ -435,7 +435,7 @@ let explain_no_such_bound_variable evd id = if na != Anonymous then out_name na :: l else l in let mvl = List.fold_left fold [] (Evd.meta_list evd) in - errorlabstrm "Evd.meta_with_name" + user_err ~hdr:"Evd.meta_with_name" (str"No such bound variable " ++ pr_id id ++ (if mvl == [] then str " (no bound variables at all in the expression)." else @@ -460,7 +460,7 @@ let meta_with_name evd id = | ([n],_|_,[n]) -> n | _ -> - errorlabstrm "Evd.meta_with_name" + user_err ~hdr:"Evd.meta_with_name" (str "Binder name \"" ++ pr_id id ++ strbrk "\" occurs more than once in clause.") @@ -469,12 +469,12 @@ let meta_of_binder clause loc mvs = function | AnonHyp n -> try List.nth mvs (n-1) with (Failure _|Invalid_argument _) -> - errorlabstrm "" (str "No such binder.") + user_err (str "No such binder.") let error_already_defined b = match b with | NamedHyp id -> - errorlabstrm "" + user_err (str "Binder name \"" ++ pr_id id ++ str"\" already defined with incompatible value.") | AnonHyp n -> @@ -527,7 +527,7 @@ let clenv_constrain_last_binding c clenv = clenv_assign_binding clenv k c let error_not_right_number_missing_arguments n = - errorlabstrm "" + user_err (strbrk "Not the right number of missing arguments (expected " ++ int n ++ str ").") @@ -641,7 +641,7 @@ let explain_no_such_bound_variable holes id = | [id] -> str "(possible name is: " ++ pr_id id ++ str ")." | _ -> str "(possible names are: " ++ pr_enum pr_id mvl ++ str ")." in - errorlabstrm "" (str "No such bound variable " ++ pr_id id ++ expl) + user_err (str "No such bound variable " ++ pr_id id ++ expl) let evar_with_name holes id = let map h = match h.hole_name with @@ -653,7 +653,7 @@ let evar_with_name holes id = | [] -> explain_no_such_bound_variable holes id | [h] -> h.hole_evar | _ -> - errorlabstrm "" + user_err (str "Binder name \"" ++ pr_id id ++ str "\" occurs more than once in clause.") @@ -664,7 +664,7 @@ let evar_of_binder holes = function let h = List.nth holes (pred n) in h.hole_evar with e when CErrors.noncritical e -> - errorlabstrm "" (str "No such binder.") + user_err (str "No such binder.") let define_with_type sigma env ev c = let t = Retyping.get_type_of env sigma ev in diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli index aa091aecd..8a096b645 100644 --- a/proofs/clenvtac.mli +++ b/proofs/clenvtac.mli @@ -10,8 +10,8 @@ open Term open Clenv -open Tacexpr open Unification +open Misctypes (** Tactics *) val unify : ?flags:unify_flags -> constr -> unit Proofview.tactic diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 5f0cc73d2..ff0df9179 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -54,8 +54,8 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc with e when CErrors.noncritical e -> let loc = Glob_ops.loc_of_glob_constr rawc in - user_err_loc - (loc,"", str "Instance is not well-typed in the environment of " ++ + user_err ~loc + (str "Instance is not well-typed in the environment of " ++ pr_existential_key sigma evk ++ str ".") in define_and_solve_constraints evk typed_c env (evars_reset_evd sigma' sigma) diff --git a/proofs/goal.ml b/proofs/goal.ml index 111a947a9..a141708c2 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -10,7 +10,8 @@ open Util open Pp open Term open Sigma.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (* This module implements the abstract interface to goals *) (* A general invariant of the module, is that a goal whose associated @@ -77,7 +78,7 @@ module V82 = struct let evars = Sigma.to_evar_map evars in let evars = Evd.restore_future_goals evars prev_future_goals prev_principal_goal in let ctxt = Environ.named_context_of_val hyps in - let inst = Array.map_of_list (mkVar % get_id) ctxt in + let inst = Array.map_of_list (NamedDecl.get_id %> mkVar) ctxt in let ev = Term.mkEvar (evk,inst) in (evk, ev, evars) @@ -148,7 +149,7 @@ module V82 = struct let env = env sigma gl in let genv = Global.env () in let is_proof_var decl = - try ignore (Environ.lookup_named (get_id decl) genv); false + try ignore (Environ.lookup_named (NamedDecl.get_id decl) genv); false with Not_found -> true in Environ.fold_named_context_reverse (fun t decl -> if is_proof_var decl then diff --git a/proofs/logic.ml b/proofs/logic.ml index 65497c80d..44c629484 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -24,6 +24,8 @@ open Retyping open Misctypes open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + type refiner_error = (* Errors raised by the refiner *) @@ -151,7 +153,7 @@ let reorder_context env sign ord = | top::ord' when mem_q top moved_hyps -> let ((d,h),mh) = find_q top moved_hyps in if occur_vars_in_decl env h d then - errorlabstrm "reorder_context" + user_err ~hdr:"reorder_context" (str "Cannot move declaration " ++ pr_id top ++ spc() ++ str "before " ++ pr_sequence pr_id @@ -162,7 +164,7 @@ let reorder_context env sign ord = (match ctxt_head with | [] -> error_no_such_hypothesis (List.hd ord) | d :: ctxt -> - let x = get_id d in + let x = NamedDecl.get_id d in if Id.Set.mem x expected then step ord (Id.Set.remove x expected) ctxt (push_item x d moved_hyps) ctxt_tail @@ -178,11 +180,11 @@ let reorder_val_context env sign ord = let check_decl_position env sign d = - let x = get_id d in + let x = NamedDecl.get_id d in let needed = global_vars_set_of_decl env d in let deps = dependency_closure env (named_context_of_val sign) needed in if Id.List.mem x deps then - errorlabstrm "Logic.check_decl_position" + user_err ~hdr:"Logic.check_decl_position" (str "Cannot create self-referring hypothesis " ++ pr_id x); x::deps @@ -204,8 +206,8 @@ let move_location_eq m1 m2 = match m1, m2 with let rec get_hyp_after h = function | [] -> error_no_such_hypothesis h | d :: right -> - if Id.equal (get_id d) h then - match right with d' ::_ -> MoveBefore (get_id d') | [] -> MoveFirst + if Id.equal (NamedDecl.get_id d) h then + match right with d' ::_ -> MoveBefore (NamedDecl.get_id d') | [] -> MoveFirst else get_hyp_after h right @@ -213,7 +215,7 @@ let split_sign hfrom hto l = let rec splitrec left toleft = function | [] -> error_no_such_hypothesis hfrom | d :: right -> - let hyp,_,typ = to_tuple d in + let hyp = NamedDecl.get_id d in if Id.equal hyp hfrom then (left,right,d, toleft || move_location_eq hto MoveLast) else @@ -235,24 +237,24 @@ let move_hyp toleft (left,declfrom,right) hto = let env = Global.env() in let test_dep d d2 = if toleft - then occur_var_in_decl env (get_id d2) d - else occur_var_in_decl env (get_id d) d2 + then occur_var_in_decl env (NamedDecl.get_id d2) d + else occur_var_in_decl env (NamedDecl.get_id d) d2 in let rec moverec first middle = function | [] -> if match hto with MoveFirst | MoveLast -> false | _ -> true then error_no_such_hypothesis (hyp_of_move_location hto); List.rev first @ List.rev middle - | d :: _ as right when move_location_eq hto (MoveBefore (get_id d)) -> + | d :: _ as right when move_location_eq hto (MoveBefore (NamedDecl.get_id d)) -> List.rev first @ List.rev middle @ right | d :: right -> - let hyp = get_id d in + let hyp = NamedDecl.get_id d in let (first',middle') = if List.exists (test_dep d) middle then if not (move_location_eq hto (MoveAfter hyp)) then (first, d::middle) else - errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id (get_id declfrom) ++ + user_err ~hdr:"move_hyp" (str "Cannot move " ++ pr_id (NamedDecl.get_id declfrom) ++ Miscprint.pr_move_location pr_id hto ++ str (if toleft then ": it occurs in " else ": it depends on ") ++ pr_id hyp ++ str ".") @@ -292,7 +294,7 @@ let move_hyp_in_named_context hfrom hto sign = variables only in Application and Case *) let error_unsupported_deep_meta c = - errorlabstrm "" (strbrk "Application of lemmas whose beta-iota normal " ++ + user_err (strbrk "Application of lemmas whose beta-iota normal " ++ strbrk "form contains metavariables deep inside the term is not " ++ strbrk "supported; try \"refine\" instead.") @@ -300,9 +302,9 @@ let collect_meta_variables c = let rec collrec deep acc c = match kind_of_term c with | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc | Cast(c,_,_) -> collrec deep acc c - | (App _| Case _) -> fold_constr (collrec deep) acc c + | (App _| Case _) -> Term.fold_constr (collrec deep) acc c | Proj (_, c) -> collrec deep acc c - | _ -> fold_constr (collrec true) acc c + | _ -> Term.fold_constr (collrec true) acc c in List.rev (collrec false [] c) @@ -494,19 +496,20 @@ and mk_casegoals sigma goal goalacc p c = let convert_hyp check sign sigma d = - let id,b,bt = to_tuple d in + let id = NamedDecl.get_id d in + let b = NamedDecl.get_value d in let env = Global.env() in let reorder = ref [] in let sign' = apply_to_hyp check sign id (fun _ d' _ -> - let _,c,ct = to_tuple d' in + let c = NamedDecl.get_value d' in let env = Global.env_of_context sign in - if check && not (is_conv env sigma bt ct) then - errorlabstrm "Logic.convert_hyp" + if check && not (is_conv env sigma (NamedDecl.get_type d) (NamedDecl.get_type d')) then + user_err ~hdr:"Logic.convert_hyp" (str "Incorrect change of the type of " ++ pr_id id ++ str "."); if check && not (Option.equal (is_conv env sigma) b c) then - errorlabstrm "Logic.convert_hyp" + user_err ~hdr:"Logic.convert_hyp" (str "Incorrect change of the body of "++ pr_id id ++ str "."); if check then reorder := check_decl_position env sign d; d) in @@ -539,7 +542,7 @@ let prim_refiner r sigma goal = t,cl,sigma else (if !check && mem_named_context_val id sign then - errorlabstrm "Logic.prim_refiner" + user_err ~hdr:"Logic.prim_refiner" (str "Variable " ++ pr_id id ++ str " is already declared."); push_named_context_val (LocalAssum (id,t)) sign,t,cl,sigma) in let (sg2,ev2,sigma) = diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index a3ece1913..c7f5efd5a 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -131,7 +131,7 @@ let solve ?with_end_tac gi info_lvl tac pr = | CList.IndexOutOfRange -> match gi with | Vernacexpr.SelectNth i -> let msg = str "No such goal: " ++ int i ++ str "." in - CErrors.errorlabstrm "" msg + CErrors.user_err msg | _ -> assert false let by tac = Proof_global.with_current_proof (fun _ -> solve (Vernacexpr.SelectNth 1) None tac) @@ -229,7 +229,7 @@ let solve_by_implicit_tactic env sigma evk = when Context.Named.equal (Environ.named_context_of_val evi.evar_hyps) (Environ.named_context env) -> - let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.UserError ("",Pp.str"Proof is not complete."))) []) in + let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.UserError (None,Pp.str"Proof is not complete."))) []) in (try let c = Evarutil.nf_evars_universes sigma evi.evar_concl in if Evarutil.has_undefined_evars sigma c then raise Exit; diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index ea604e08e..7458109fa 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -124,14 +124,14 @@ val get_all_proof_names : unit -> Id.t list (** [set_end_tac tac] applies tactic [tac] to all subgoal generate by [solve] *) -val set_end_tac : Tacexpr.raw_tactic_expr -> unit +val set_end_tac : Genarg.glob_generic_argument -> unit (** {6 ... } *) (** [set_used_variables l] declares that section variables [l] will be used in the proof *) val set_used_variables : - Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list -val get_used_variables : unit -> Context.section_context option + Id.t list -> Context.Named.t * (Loc.t * Names.Id.t) list +val get_used_variables : unit -> Context.Named.t option (** {6 Universe binders } *) val get_universe_binders : unit -> universe_binders option diff --git a/proofs/proof.ml b/proofs/proof.ml index 5c963d53e..0a3b08c04 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -68,9 +68,9 @@ let _ = CErrors.register_handler begin function | CannotUnfocusThisWay -> CErrors.error "This proof is focused, but cannot be unfocused this way" | NoSuchGoals (i,j) when Int.equal i j -> - CErrors.errorlabstrm "Focus" Pp.(str"No such goal (" ++ int i ++ str").") + CErrors.user_err ~hdr:"Focus" Pp.(str"No such goal (" ++ int i ++ str").") | NoSuchGoals (i,j) -> - CErrors.errorlabstrm "Focus" Pp.( + CErrors.user_err ~hdr:"Focus" Pp.( str"Not every goal in range ["++ int i ++ str","++int j++str"] exist." ) | FullyUnfocused -> CErrors.error "The proof is not focused" diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 7605f6387..2956d623f 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -18,6 +18,8 @@ open Util open Pp open Names +module NamedDecl = Context.Named.Declaration + (*** Proof Modes ***) (* Type of proof modes : @@ -88,8 +90,8 @@ type closed_proof = proof_object * proof_terminator type pstate = { pid : Id.t; terminator : proof_terminator CEphemeron.key; - endline_tactic : Tacexpr.raw_tactic_expr option; - section_vars : Context.section_context option; + endline_tactic : Genarg.glob_generic_argument option; + section_vars : Context.Named.t option; proof : Proof.proof; strength : Decl_kinds.goal_kind; mode : proof_mode CEphemeron.key; @@ -146,9 +148,6 @@ let cur_pstate () = let give_me_the_proof () = (cur_pstate ()).proof let get_current_proof_name () = (cur_pstate ()).pid -let interp_tac = ref (fun _ -> assert false) -let set_interp_tac f = interp_tac := f - let with_current_proof f = match !pstates with | [] -> raise NoCurrentProof @@ -156,7 +155,13 @@ let with_current_proof f = let et = match p.endline_tactic with | None -> Proofview.tclUNIT () - | Some tac -> !interp_tac tac in + | Some tac -> + let open Geninterp in + let ist = { lfun = Id.Map.empty; extra = TacStore.empty } in + let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in + let tac = Geninterp.interp tag ist tac in + Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) + in let (newpr,ret) = f et p.proof in let p = { p with proof = newpr } in pstates := p :: rest; @@ -202,8 +207,8 @@ let discard (loc,id) = let n = List.length !pstates in discard_gen id; if Int.equal (List.length !pstates) n then - CErrors.user_err_loc - (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs ()) + CErrors.user_err ~loc + ~hdr:"Pfedit.delete_proof" (str"No such proof" ++ msg_proofs ()) let discard_current () = if List.is_empty !pstates then raise NoCurrentProof else pstates := List.tl !pstates @@ -276,7 +281,7 @@ let set_used_variables l = let ids = List.fold_right Id.Set.add l Id.Set.empty in let ctx = Environ.keep_hyps env ids in let ctx_set = - List.fold_right Id.Set.add (List.map get_id ctx) Id.Set.empty in + List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in let vars_of = Environ.global_vars_set in let aux env entry (ctx, all_safe, to_clear as orig) = match entry with @@ -408,7 +413,7 @@ let return_proof ?(allow_partial=false) () = let evd = let error s = let prf = str " (in proof " ++ Id.print pid ++ str ")" in - raise (CErrors.UserError("last tactic before Qed",s ++ prf)) + raise (CErrors.UserError(Some "last tactic before Qed",s ++ prf)) in try Proof.return proof with | Proof.UnfinishedProof -> @@ -519,7 +524,7 @@ module Bullet = struct (function | FailedBullet (b,sugg) -> let prefix = str"Wrong bullet " ++ pr_bullet b ++ str" : " in - CErrors.errorlabstrm "Focus" (prefix ++ suggest_on_error sugg) + CErrors.user_err ~hdr:"Focus" (prefix ++ suggest_on_error sugg) | _ -> raise CErrors.Unhandled) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 59daa2968..97a21cf22 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -134,17 +134,14 @@ val simple_with_current_proof : (unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit (** Sets the tactic to be used when a tactic line is closed with [...] *) -val set_endline_tactic : Tacexpr.raw_tactic_expr -> unit -val set_interp_tac : - (Tacexpr.raw_tactic_expr -> unit Proofview.tactic) - -> unit +val set_endline_tactic : Genarg.glob_generic_argument -> unit (** Sets the section variables assumed by the proof, returns its closure * (w.r.t. type dependencies and let-ins covered by it) + a list of * ids to be cleared *) val set_used_variables : - Names.Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list -val get_used_variables : unit -> Context.section_context option + Names.Id.t list -> Context.Named.t * (Loc.t * Names.Id.t) list +val get_used_variables : unit -> Context.Named.t option val get_universe_binders : unit -> universe_binders option diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index c12079622..03bc5e471 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -11,7 +11,6 @@ open Evd open Names open Term -open Tacexpr open Glob_term open Nametab open Misctypes diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml index caa9b328a..a125fb10d 100644 --- a/proofs/proof_using.ml +++ b/proofs/proof_using.ml @@ -12,6 +12,8 @@ open Util open Vernacexpr open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + let to_string e = let rec aux = function | SsEmpty -> "()" @@ -35,12 +37,14 @@ let in_nameset = let rec close_fwd e s = let s' = List.fold_left (fun s decl -> - let (id,b,ty) = Context.Named.Declaration.to_tuple decl in - let vb = Option.(default Id.Set.empty (map (global_vars_set e) b)) in - let vty = global_vars_set e ty in + let vb = match decl with + | LocalAssum _ -> Id.Set.empty + | LocalDef (_,b,_) -> global_vars_set e b + in + let vty = global_vars_set e (NamedDecl.get_type decl) in let vbty = Id.Set.union vb vty in if Id.Set.exists (fun v -> Id.Set.mem v s) vbty - then Id.Set.add id (Id.Set.union s vbty) else s) + then Id.Set.add (NamedDecl.get_id decl) (Id.Set.union s vbty) else s) s (named_context e) in if Id.Set.equal s s' then s else close_fwd e s' @@ -63,13 +67,13 @@ and set_of_id env ty id = Id.Set.union (global_vars_set env ty) acc) Id.Set.empty ty else if Id.to_string id = "All" then - List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty + List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty else if CList.mem_assoc_f Id.equal id !known_names then process_expr env (CList.assoc_f Id.equal id !known_names) [] else Id.Set.singleton id and full_set env = - List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty + List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty let process_expr env e ty = let ty_expr = SsSingl(Loc.ghost, Id.of_string "Type") in diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 72cb05f1b..34443b93d 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -73,7 +73,7 @@ let set_strategy_one ref l = let cb = Global.lookup_constant sp in (match cb.const_body with | OpaqueDef _ -> - errorlabstrm "set_transparent_const" + user_err ~hdr:"set_transparent_const" (str "Cannot make" ++ spc () ++ Nametab.pr_global_env Id.Set.empty (ConstRef sp) ++ spc () ++ str "transparent because it was declared opaque."); @@ -175,19 +175,19 @@ let red_expr_tab = Summary.ref String.Map.empty ~name:"Declare Reduction" let declare_reduction s f = if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab - then errorlabstrm "Redexpr.declare_reduction" + then user_err ~hdr:"Redexpr.declare_reduction" (str "There is already a reduction expression of name " ++ str s) else reduction_tab := String.Map.add s f !reduction_tab let check_custom = function | ExtraRedExpr s -> if not (String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab) - then errorlabstrm "Redexpr.check_custom" (str "Reference to undefined reduction expression " ++ str s) + then user_err ~hdr:"Redexpr.check_custom" (str "Reference to undefined reduction expression " ++ str s) |_ -> () let decl_red_expr s e = if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab - then errorlabstrm "Redexpr.decl_red_expr" + then user_err ~hdr:"Redexpr.decl_red_expr" (str "There is already a reduction expression of name " ++ str s) else begin check_custom e; @@ -247,7 +247,7 @@ let reduction_of_red_expr env = with Not_found -> (try reduction_of_red_expr (String.Map.find s !red_expr_tab) with Not_found -> - errorlabstrm "Redexpr.reduction_of_red_expr" + user_err ~hdr:"Redexpr.reduction_of_red_expr" (str "unknown user-defined reduction \"" ++ str s ++ str "\""))) | CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast) | CbvNative o -> (contextualize cbv_native cbv_native o, NATIVEcast) diff --git a/proofs/refine.ml b/proofs/refine.ml index e5114a2ec..d4920e505 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -11,6 +11,8 @@ open Sigma.Notations open Proofview.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + let extract_prefix env info = let ctx1 = List.rev (Environ.named_context env) in let ctx2 = List.rev (Evd.evar_context info) in @@ -26,7 +28,7 @@ let typecheck_evar ev env sigma = let info = Evd.find sigma ev in (** Typecheck the hypotheses. *) let type_hyp (sigma, env) decl = - let t = get_type decl in + let t = NamedDecl.get_type decl in let evdref = ref sigma in let _ = Typing.e_sort_of env evdref t in let () = match decl with diff --git a/proofs/refiner.ml b/proofs/refiner.ml index ea8543b02..9a0b56b84 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -13,7 +13,8 @@ open Evd open Environ open Proof_type open Logic -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration let sig_it x = x.it let project x = x.sigma @@ -60,7 +61,7 @@ let tclIDTAC_MESSAGE s gls = Feedback.msg_info (hov 0 s); tclIDTAC gls (* General failure tactic *) -let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s) +let tclFAIL_s s gls = user_err ~hdr:"Refiner.tclFAIL_s" (str s) (* A special exception for levels for the Fail tactic *) exception FailError of int * std_ppcmds Lazy.t @@ -82,7 +83,7 @@ let thens3parts_tac tacfi tac tacli (sigr,gs) = let nf = Array.length tacfi in let nl = Array.length tacli in let ng = List.length gs in - if ng<nf+nl then errorlabstrm "Refiner.thensn_tac" (str "Not enough subgoals."); + if ng<nf+nl then user_err ~hdr:"Refiner.thensn_tac" (str "Not enough subgoals."); let gll = (List.map_i (fun i -> apply_sig_tac sigr (if i<nf then tacfi.(i) else if i>=ng-nl then tacli.(nl-ng+i) else tac)) @@ -164,14 +165,14 @@ the goal unchanged *) let tclWEAK_PROGRESS tac ptree = let rslt = tac ptree in if Goal.V82.weak_progress rslt ptree then rslt - else errorlabstrm "Refiner.WEAK_PROGRESS" (str"Failed to progress.") + else user_err ~hdr:"Refiner.WEAK_PROGRESS" (str"Failed to progress.") (* PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves the goal unchanged *) let tclPROGRESS tac ptree = let rslt = tac ptree in if Goal.V82.progress rslt ptree then rslt - else errorlabstrm "Refiner.PROGRESS" (str"Failed to progress.") + else user_err ~hdr:"Refiner.PROGRESS" (str"Failed to progress.") (* Same as tclWEAK_PROGRESS but fails also if tactics generates several goals, one of them being identical to the original goal *) @@ -182,7 +183,7 @@ let tclNOTSAMEGOAL (tac : tactic) goal = let rslt = tac goal in let {it=gls;sigma=sigma} = rslt in if List.exists (same_goal goal sigma) gls - then errorlabstrm "Refiner.tclNOTSAMEGOAL" + then user_err ~hdr:"Refiner.tclNOTSAMEGOAL" (str"Tactic generated a subgoal identical to the original goal.") else rslt @@ -202,7 +203,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) let { it = gls; sigma = sigma; } = rslt in let hyps:Context.Named.t list = List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in - let cmp d1 d2 = Names.Id.equal (get_id d1) (get_id d2) in + let cmp d1 d2 = Names.Id.equal (NamedDecl.get_id d1) (NamedDecl.get_id d2) in let newhyps = List.map (fun hypl -> List.subtract cmp hypl oldhyps) @@ -215,7 +216,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) List.fold_left (fun acc lh -> acc ^ (if !frst then (frst:=false;"") else " | ") ^ (List.fold_left - (fun acc d -> (Names.Id.to_string (get_id d)) ^ " " ^ acc) + (fun acc d -> (Names.Id.to_string (NamedDecl.get_id d)) ^ " " ^ acc) "" lh)) "" newhyps in Feedback.msg_notice @@ -316,7 +317,7 @@ let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl) let tclDO n t = let rec dorec k = - if k < 0 then errorlabstrm "Refiner.tclDO" + if k < 0 then user_err ~hdr:"Refiner.tclDO" (str"Wrong argument : Do needs a positive integer."); if Int.equal k 0 then tclIDTAC else if Int.equal k 1 then t else (tclTHEN t (dorec (k-1))) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 2b129ad89..e41fb94cc 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -21,6 +21,8 @@ open Refiner open Sigma.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + let re_sig it gc = { it = it; sigma = gc; } (**************************************************************) @@ -46,7 +48,7 @@ let pf_hyps_types gls = | LocalDef (id,_,x) -> id, x) sign -let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> get_id +let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> NamedDecl.get_id let pf_last_hyp gl = List.hd (pf_hyps gl) @@ -57,7 +59,7 @@ let pf_get_hyp gls id = raise (RefinerError (NoSuchHyp id)) let pf_get_hyp_typ gls id = - pf_get_hyp gls id |> get_type + id |> pf_get_hyp gls |> NamedDecl.get_type let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls) @@ -101,7 +103,7 @@ let pf_const_value = pf_reduce (fun env _ -> constant_value_in env) let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind -let pf_hnf_type_of gls = pf_whd_all gls % pf_get_type_of gls +let pf_hnf_type_of gls = pf_get_type_of gls %> pf_whd_all gls let pf_is_matching = pf_apply Constr_matching.is_matching_conv let pf_matches = pf_apply Constr_matching.matches_conv @@ -195,7 +197,7 @@ module New = struct sign let pf_get_hyp_typ id gl = - pf_get_hyp id gl |> get_type + pf_get_hyp id gl |> NamedDecl.get_type let pf_hyps_types gl = let env = Proofview.Goal.env gl in diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 022c89ad9..55f33be39 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -33,6 +33,9 @@ open Constrintern open Impargs open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + type 'a declaration_hook = Decl_kinds.locality -> Globnames.global_reference -> 'a let mk_hook hook = hook let call_hook fix_exn hook l c = @@ -45,8 +48,7 @@ let call_hook fix_exn hook l c = let retrieve_first_recthm = function | VarRef id -> - let open Context.Named.Declaration in - (get_value (Global.lookup_named id),variable_opacity id) + (NamedDecl.get_value (Global.lookup_named id),variable_opacity id) | ConstRef cst -> let cb = Global.lookup_constant cst in (Global.body_of_constant_body cb, is_opaque cb) @@ -110,7 +112,7 @@ let find_mutually_recursive_statements thms = (Global.env()) hyps in let ind_hyps = List.flatten (List.map_i (fun i decl -> - let t = get_type decl in + let t = RelDecl.get_type decl in match kind_of_term t with | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in @@ -222,7 +224,7 @@ let compute_proof_name locality = function if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) then - user_err_loc (loc,"",pr_id id ++ str " already exists."); + user_err ~loc (pr_id id ++ str " already exists."); id, pl | None -> next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()), None @@ -335,7 +337,7 @@ let get_proof proof do_guard hook opacity = let check_exist = List.iter (fun (loc,id) -> if not (Nametab.exists_cci (Lib.make_path id)) then - user_err_loc (loc,"",pr_id id ++ str " does not exist.") + user_err ~loc (pr_id id ++ str " does not exist.") ) let universe_proof_terminator compute_guard hook = @@ -462,7 +464,7 @@ let start_proof_com ?inference_hook kind thms hook = let flags = all_and_fail_flags in let flags = { flags with use_hook = inference_hook } in evdref := solve_remaining_evars flags env !evdref (Evd.empty,!evdref); - let ids = List.map get_name ctx in + let ids = List.map RelDecl.get_name ctx in (compute_proof_name (pi1 kind) sopt, (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), (ids, imps @ lift_implicits (List.length ids) imps'), diff --git a/stm/stm.ml b/stm/stm.ml index 32185247f..1850c3020 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1040,7 +1040,7 @@ end = struct (* {{{ *) | _ -> VtUnknown, VtNow with | Not_found -> - CErrors.errorlabstrm "undo_vernac_classifier" + CErrors.user_err ~hdr:"undo_vernac_classifier" (str "Cannot undo") end (* }}} *) @@ -1108,7 +1108,7 @@ let proof_block_delimiters = ref [] let register_proof_block_delimiter name static dynamic = if List.mem_assoc name !proof_block_delimiters then - CErrors.errorlabstrm "STM" (str "Duplicate block delimiter " ++ str name); + CErrors.user_err ~hdr:"STM" (str "Duplicate block delimiter " ++ str name); proof_block_delimiters := (name, (static,dynamic)) :: !proof_block_delimiters let mk_doc_node id = function @@ -1143,7 +1143,7 @@ let detect_proof_block id name = VCS.create_proof_block decl name end with Not_found -> - CErrors.errorlabstrm "STM" + CErrors.user_err ~hdr:"STM" (str "Unknown proof block delimiter " ++ str name) ) (****************************** THE SCHEDULER *********************************) @@ -1708,7 +1708,7 @@ end = struct (* {{{ *) List.for_all (Context.Named.Declaration.for_all (Evarutil.is_ground_term sigma0)) Evd.(evar_context g)) then - CErrors.errorlabstrm "STM" (strbrk("the par: goal selector supports ground "^ + CErrors.user_err ~hdr:"STM" (strbrk("the par: goal selector supports ground "^ "goals only")) else begin let (i, ast) = r_ast in @@ -1721,7 +1721,7 @@ end = struct (* {{{ *) let t = Evarutil.nf_evar sigma t in if Evarutil.is_ground_term sigma t then RespBuiltSubProof (t, Evd.evar_universe_context sigma) - else CErrors.errorlabstrm "STM" (str"The solution is not ground") + else CErrors.user_err ~hdr:"STM" (str"The solution is not ground") end) () with e when CErrors.noncritical e -> RespError (CErrors.print e) @@ -2058,7 +2058,7 @@ let known_state ?(redefine_qed=false) ~cache id = | _ -> assert false end with Not_found -> - CErrors.errorlabstrm "STM" + CErrors.user_err ~hdr:"STM" (str "Unknown proof block delimiter " ++ str name) in @@ -2410,7 +2410,7 @@ let handle_failure (e, info) vcs tty = let snapshot_vio ldir long_f_dot_vo = finish (); if List.length (VCS.branches ()) > 1 then - CErrors.errorlabstrm "stm" (str"Cannot dump a vio with open proofs"); + CErrors.user_err ~hdr:"stm" (str"Cannot dump a vio with open proofs"); Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_vo (Global.opaque_tables ()) diff --git a/tactics/auto.ml b/tactics/auto.ml index 0f5b74d9d..63f85114e 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -20,7 +20,6 @@ open Genredexpr open Tactics open Tacticals open Clenv -open Tacexpr open Locus open Proofview.Notations open Hints @@ -146,7 +145,7 @@ let conclPattern concl pat tac = constr_bindings env sigma >>= fun constr_bindings -> let open Genarg in let open Geninterp in - let inj c = match val_tag (topwit Constrarg.wit_constr) with + let inj c = match val_tag (topwit Stdarg.wit_constr) with | Val.Base tag -> Val.Dyn (tag, c) | _ -> assert false in diff --git a/tactics/auto.mli b/tactics/auto.mli index 5384140c2..3ee96353f 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -14,6 +14,7 @@ open Clenv open Pattern open Decl_kinds open Hints +open Tactypes val default_search_depth : int ref @@ -37,45 +38,45 @@ val conclPattern : constr -> constr_pattern option -> Genarg.glob_generic_argume (** The use of the "core" database can be de-activated by passing "nocore" amongst the databases. *) -val auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic +val auto : ?debug:debug -> + int -> delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** Auto with more delta. *) -val new_auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic +val new_auto : ?debug:debug -> + int -> delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** auto with default search depth and with the hint database "core" *) val default_auto : unit Proofview.tactic (** auto with all hint databases except the "v62" compatibility database *) -val full_auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic +val full_auto : ?debug:debug -> + int -> delayed_open_constr list -> unit Proofview.tactic (** auto with all hint databases except the "v62" compatibility database and doing delta *) -val new_full_auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic +val new_full_auto : ?debug:debug -> + int -> delayed_open_constr list -> unit Proofview.tactic (** auto with default search depth and with all hint databases except the "v62" compatibility database *) val default_full_auto : unit Proofview.tactic (** The generic form of auto (second arg [None] means all bases) *) -val gen_auto : ?debug:Tacexpr.debug -> - int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val gen_auto : ?debug:debug -> + int option -> delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** The hidden version of auto *) -val h_auto : ?debug:Tacexpr.debug -> - int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val h_auto : ?debug:debug -> + int option -> delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** Trivial *) -val trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic -val gen_trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic -val full_trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> unit Proofview.tactic -val h_trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val trivial : ?debug:debug -> + delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic +val gen_trivial : ?debug:debug -> + delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val full_trivial : ?debug:debug -> + delayed_open_constr list -> unit Proofview.tactic +val h_trivial : ?debug:debug -> + delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 475005648..dae1cc9f1 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -65,7 +65,7 @@ let raw_find_base bas = String.Map.find bas !rewtab let find_base bas = try raw_find_base bas with Not_found -> - errorlabstrm "AutoRewrite" + user_err ~hdr:"AutoRewrite" (str "Rewriting base " ++ str bas ++ str " does not exist.") let find_rewrites bas = @@ -83,7 +83,7 @@ let print_rewrite_hintdb bas = str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ Option.cata (fun tac -> str " then use tactic " ++ - Pptactic.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) + Pputils.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option @@ -294,8 +294,8 @@ let find_applied_relation metas loc env sigma c left2right = match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c | None -> - user_err_loc (loc, "decompose_applied_relation", - str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ + user_err ~loc ~hdr:"decompose_applied_relation" + (str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 070657179..49e8588da 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -9,7 +9,6 @@ (** This files implements the autorewrite tactic. *) open Term -open Tacexpr open Equality (** Rewriting rules before tactic interpretation *) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 0944cbe38..96767e7f6 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -32,6 +32,8 @@ open Misctypes open Proofview.Notations open Hints +module NamedDecl = Context.Named.Declaration + (** Hint database named "typeclass_instances", now created directly in Auto *) (** Options handling *) @@ -518,9 +520,8 @@ let evars_to_goals p evm = (** Making local hints *) let make_resolve_hyp env sigma st flags only_classes pri decl = - let open Context.Named.Declaration in - let id = get_id decl in - let cty = Evarutil.nf_evar sigma (get_type decl) in + let id = NamedDecl.get_id decl in + let cty = Evarutil.nf_evar sigma (NamedDecl.get_type decl) in let rec iscl env ty = let ctx, ar = decompose_prod_assum ty in match kind_of_term (fst (decompose_app ar)) with @@ -559,10 +560,9 @@ let make_hints g st only_classes sign = List.fold_left (fun hints hyp -> let consider = - let open Context.Named.Declaration in - try let t = Global.lookup_named (get_id hyp) |> get_type in + try let t = hyp |> NamedDecl.get_id |> Global.lookup_named |> NamedDecl.get_type in (* Section variable, reindex only if the type changed *) - not (Term.eq_constr t (get_type hyp)) + not (Term.eq_constr t (NamedDecl.get_type hyp)) with Not_found -> true in if consider then diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 445a104d6..6b29f574c 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -13,7 +13,8 @@ open Coqlib open Reductionops open Misctypes open Proofview.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (* Absurd *) @@ -48,7 +49,7 @@ let use_negated_unit_or_eq_type () = Flags.version_strictly_greater Flags.V8_5 let filter_hyp f tac = let rec seek = function | [] -> Proofview.tclZERO Not_found - | d::rest when f (get_type d) -> tac (get_id d) + | d::rest when f (NamedDecl.get_type d) -> tac (NamedDecl.get_id d) | _::rest -> seek rest in Proofview.Goal.enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in @@ -62,8 +63,8 @@ let contradiction_context = let rec seek_neg l = match l with | [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction") | d :: rest -> - let id = get_id d in - let typ = nf_evar sigma (get_type d) in + let id = NamedDecl.get_id d in + let typ = nf_evar sigma (NamedDecl.get_type d) in let typ = whd_all env sigma typ in if is_empty_type typ then simplest_elim (mkVar id) diff --git a/tactics/eauto.ml b/tactics/eauto.ml index c6d244867..c6b7de32d 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -20,7 +20,7 @@ open Tactics open Clenv open Auto open Genredexpr -open Tacexpr +open Tactypes open Locus open Locusops open Hints @@ -97,8 +97,8 @@ let prolog_tac l n = in let l = List.map map l in try (prolog l n gl) - with UserError ("Refiner.tclFIRST",_) -> - errorlabstrm "Prolog.prolog" (str "Prolog failed.") + with UserError (Some "Refiner.tclFIRST",_) -> + user_err ~hdr:"Prolog.prolog" (str "Prolog failed.") end open Auto @@ -203,7 +203,7 @@ type search_state = { dblist : hint_db list; localdb : hint_db list; prev : prev_search_state; - local_lemmas : Tacexpr.delayed_open_constr list; + local_lemmas : delayed_open_constr list; } and prev_search_state = (* for info eauto *) @@ -432,7 +432,7 @@ let cons a l = a :: l let autounfolds db occs cls gl = let unfolds = List.concat (List.map (fun dbname -> let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in let hyps = pf_ids_of_hyps gl in @@ -499,7 +499,7 @@ let autounfold_one db cl = let st = List.fold_left (fun (i,c) dbname -> let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 8812093d5..1f69e4ab3 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -9,6 +9,7 @@ open Term open Proof_type open Hints +open Tactypes val e_assumption : unit Proofview.tactic @@ -16,15 +17,15 @@ val registered_e_assumption : unit Proofview.tactic val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic -val prolog_tac : Tacexpr.delayed_open_constr list -> int -> unit Proofview.tactic +val prolog_tac : delayed_open_constr list -> int -> unit Proofview.tactic -val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> +val gen_eauto : ?debug:debug -> bool * int -> delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic val eauto_with_bases : - ?debug:Tacexpr.debug -> + ?debug:debug -> bool * int -> - Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic + delayed_open_constr list -> hint_db list -> Proof_type.tactic val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic diff --git a/tactics/elim.ml b/tactics/elim.ml index f2b9eec4b..3f0c01a29 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -16,7 +16,8 @@ open Tacmach.New open Tacticals.New open Tactics open Proofview.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (* Supposed to be called without as clause *) let introElimAssumsThen tac ba = @@ -139,7 +140,7 @@ let induction_trailer abs_i abs_j bargs = let (hyps,_) = List.fold_left (fun (bring_ids,leave_ids) d -> - let cid = get_id d in + let cid = NamedDecl.get_id d in if not (List.mem cid leave_ids) then (d::bring_ids,leave_ids) else (bring_ids,cid::leave_ids)) diff --git a/tactics/elim.mli b/tactics/elim.mli index ae9cf85f3..29c441463 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -10,11 +10,12 @@ open Names open Term open Tacticals open Misctypes +open Tactypes (** Eliminations tactics. *) -val introCaseAssumsThen : Tacexpr.evars_flag -> - (Tacexpr.intro_patterns -> branch_assumptions -> unit Proofview.tactic) -> +val introCaseAssumsThen : evars_flag -> + (intro_patterns -> branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic val h_decompose : inductive list -> constr -> unit Proofview.tactic diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index b1d3290aa..1a67bedc2 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -22,6 +22,7 @@ open Tacticals.New open Auto open Constr_matching open Misctypes +open Tactypes open Hipattern open Pretyping open Tacmach.New @@ -73,7 +74,7 @@ let mkBranches c1 c2 = let discrHyp id = let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in - let tac c = Equality.discr_tac false (Some (None, Tacexpr.ElimOnConstr c)) in + let tac c = Equality.discr_tac false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac let solveNoteqBranch side = @@ -121,7 +122,7 @@ let eqCase tac = let injHyp id = let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in - let tac c = Equality.injClause None false (Some (None, Tacexpr.ElimOnConstr c)) in + let tac c = Equality.injClause None false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac let diseqCase hyps eqonleft = diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 1a45217a4..c94dcfa9d 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -60,6 +60,8 @@ open Indrec open Sigma.Notations open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + let hid = Id.of_string "H" let xid = Id.of_string "X" let default_id_of_sort = function InProp | InSet -> hid | InType -> xid @@ -600,9 +602,9 @@ let fix_r2l_forward_rew_scheme (c, ctx') = | hp :: p :: ind :: indargs -> let c' = my_it_mkLambda_or_LetIn indargs - (mkLambda_or_LetIn (map_constr (liftn (-1) 1) p) - (mkLambda_or_LetIn (map_constr (liftn (-1) 2) hp) - (mkLambda_or_LetIn (map_constr (lift 2) ind) + (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 1) p) + (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 2) hp) + (mkLambda_or_LetIn (RelDecl.map_constr (lift 2) ind) (Reductionops.whd_beta Evd.empty (applist (c, Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) @@ -741,7 +743,7 @@ let build_congr env (eq,refl,ctx) ind = if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported."; let env_with_arity = push_rel_context arityctxt env in - let ty = get_type (lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity) in + let ty = RelDecl.get_type (lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity) in let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in if Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt) then diff --git a/tactics/equality.ml b/tactics/equality.ml index e9d08d737..7c819edad 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -26,7 +26,6 @@ open Retyping open Tacmach.New open Logic open Hipattern -open Tacexpr open Tacticals.New open Tactics open Tacred @@ -45,6 +44,8 @@ open Proofview.Notations open Unification open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + (* Options *) let discriminate_introduction = ref true @@ -359,7 +360,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = let _ = Global.lookup_constant c1' in c1' with Not_found -> - errorlabstrm "Equality.find_elim" + user_err ~hdr:"Equality.find_elim" (str "Cannot find rewrite principle " ++ pr_label l' ++ str ".") end | _ -> destConstRef pr1 @@ -888,7 +889,7 @@ let build_selector env sigma dirn c ind special default = on (c bool true) = (c bool false) CP : changed assert false in a more informative error *) - errorlabstrm "Equality.construct_discriminator" + user_err ~hdr:"Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in let (indp,_) = dest_ind_family indf in @@ -974,7 +975,7 @@ let apply_on_clause (f,t) clause = let argmv = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv - | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in + | _ -> user_err (str "Ill-formed clause applicator.")) in clenv_fchain ~with_univs:false argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = @@ -1052,7 +1053,7 @@ let discrEverywhere with_evars = else (* <= 8.2 compat *) tryAllHypsAndConcl (discrSimpleClause with_evars)) (* (fun gls -> - errorlabstrm "DiscrEverywhere" (str"No discriminable equalities.")) + user_err ~hdr:"DiscrEverywhere" (str"No discriminable equalities.")) *) let discr_tac with_evars = function | None -> discrEverywhere with_evars @@ -1665,13 +1666,13 @@ exception FoundHyp of (Id.t * constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occurring in [t] *) let is_eq_x gl x d = - let id = get_id d in + let id = NamedDecl.get_id d in try let is_var id c = match kind_of_term c with | Var id' -> Id.equal id id' | _ -> false in - let c = pf_nf_evar gl (get_type d) in + let c = pf_nf_evar gl (NamedDecl.get_type d) in let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in if (is_var x lhs) && not (local_occur_var x rhs) then raise (FoundHyp (id,rhs,true)); if (is_var x rhs) && not (local_occur_var x lhs) then raise (FoundHyp (id,lhs,false)) @@ -1689,7 +1690,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = (* The set of hypotheses using x *) let dephyps = List.rev (pi3 (List.fold_right (fun dcl (dest,deps,allhyps) -> - let id = get_id dcl in + let id = NamedDecl.get_id dcl in if not (Id.equal id hyp) && List.exists (fun y -> occur_var_in_decl env y dcl) deps then @@ -1718,9 +1719,9 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = let subst_one_var dep_proof_ok x = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in - let xval = pf_get_hyp x gl |> get_value in + let decl = pf_get_hyp x gl in (* If x has a body, simply replace x with body and clear x *) - if not (Option.is_empty xval) then tclTHEN (unfold_body x) (clear [x]) else + if is_local_def decl then tclTHEN (unfold_body x) (clear [x]) else (* Find a non-recursive definition for x *) let res = try @@ -1728,7 +1729,7 @@ let subst_one_var dep_proof_ok x = let hyps = Proofview.Goal.hyps gl in let test hyp _ = is_eq_x gl x hyp in Context.Named.fold_outside test ~init:() hyps; - errorlabstrm "Subst" + user_err ~hdr:"Subst" (str "Cannot find any non-recursive equality over " ++ pr_id x ++ str".") with FoundHyp res -> res in @@ -1766,14 +1767,14 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let find_eq_data_decompose = find_eq_data_decompose gl in let select_equation_name decl = try - let lbeq,u,(_,x,y) = find_eq_data_decompose (get_type decl) in + let lbeq,u,(_,x,y) = find_eq_data_decompose (NamedDecl.get_type decl) in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match kind_of_term x, kind_of_term y with | Var z, _ when not (is_evaluable env (EvalVarRef z)) -> - Some (get_id decl) + Some (NamedDecl.get_id decl) | _, Var z when not (is_evaluable env (EvalVarRef z)) -> - Some (get_id decl) + Some (NamedDecl.get_id decl) | _ -> None with Constr_matching.PatternMatchingFailure -> None @@ -1788,7 +1789,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in - let c = pf_get_hyp hyp gl |> get_type in + let c = pf_get_hyp hyp gl |> NamedDecl.get_type in let _,_,(_,x,y) = find_eq_data_decompose c in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then Proofview.tclUNIT () else @@ -1857,10 +1858,10 @@ let rewrite_assumption_cond cond_eq_term cl = let rec arec hyps gl = match hyps with | [] -> error "No such assumption." | hyp ::rest -> - let id = get_id hyp in + let id = NamedDecl.get_id hyp in begin try - let dir = cond_eq_term (get_type hyp) gl in + let dir = cond_eq_term (NamedDecl.get_type hyp) gl in general_rewrite_clause dir false (mkVar id,NoBindings) cl with | Failure _ | UserError _ -> arec rest gl end diff --git a/tactics/equality.mli b/tactics/equality.mli index 47cb6b82f..6a4a8126e 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -11,10 +11,10 @@ open Names open Term open Evd open Environ -open Tacexpr open Ind_tables open Locus open Misctypes +open Tactypes (*i*) type dep_proof_flag = bool (* true = support rewriting dependent proofs *) diff --git a/tactics/hints.ml b/tactics/hints.ml index 89ecc6c0b..3d5be5441 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -20,11 +20,11 @@ open Namegen open Libnames open Smartlocate open Misctypes +open Tactypes open Evd open Termops open Inductiveops open Typing -open Tacexpr open Decl_kinds open Pattern open Patternops @@ -34,12 +34,15 @@ open Tacred open Printer open Vernacexpr open Sigma.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (****************************************) (* General functions *) (****************************************) +type debug = Debug | Info | Off + exception Bound let head_constr_bound t = @@ -661,7 +664,7 @@ let current_pure_db () = List.map snd (Hintdbmap.bindings (Hintdbmap.remove "v62" !searchtable)) let error_no_such_hint_database x = - errorlabstrm "Hints" (str "No such Hint database: " ++ str x ++ str ".") + user_err ~hdr:"Hints" (str "No such Hint database: " ++ str x ++ str ".") (**************************************************************************) (* Definition of the summary *) @@ -806,7 +809,7 @@ let make_resolves env sigma flags pri poly ?name cr = [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name] in if List.is_empty ents then - errorlabstrm "Hint" + user_err ~hdr:"Hint" (pr_lconstr c ++ spc() ++ (if pi1 flags then str"cannot be used as a hint." else str "can be used as a hint only for eauto.")); @@ -814,11 +817,11 @@ let make_resolves env sigma flags pri poly ?name cr = (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma decl = - let hname = get_id decl in + let hname = NamedDecl.get_id decl in try [make_apply_entry env sigma (true, true, false) None false ~name:(PathHints [VarRef hname]) - (mkVar hname, get_type decl, Univ.ContextSet.empty)] + (mkVar hname, NamedDecl.get_type decl, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") @@ -835,7 +838,6 @@ let make_unfold eref = code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = - let tacast = Genarg.in_gen (Genarg.glbwit Constrarg.wit_ltac) tacast in let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri = pri; @@ -851,7 +853,7 @@ let make_mode ref m = let n = List.length ctx in let m' = Array.of_list m in if not (n == Array.length m') then - errorlabstrm "Hint" + user_err ~hdr:"Hint" (pr_global ref ++ str" has " ++ int n ++ str" arguments while the mode declares " ++ int (Array.length m')) else m' @@ -1115,8 +1117,6 @@ let add_trivials env sigma l local dbnames = Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let (forward_intern_tac, extern_intern_tac) = Hook.make () - type hnf = bool type hints_entry = @@ -1127,7 +1127,7 @@ type hints_entry = | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsModeEntry of global_reference * hint_mode list | HintsExternEntry of - int * (patvar list * constr_pattern) option * glob_tactic_expr + int * (patvar list * constr_pattern) option * Genarg.glob_generic_argument let default_prepare_hint_ident = Id.of_string "H" @@ -1217,7 +1217,9 @@ let interp_hints poly = | HintsExtern (pri, patcom, tacexp) -> let pat = Option.map fp patcom in let l = match pat with None -> [] | Some (l, _) -> l in - let tacexp = Hook.get forward_intern_tac l tacexp in + let ltacvars = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in + let env = Genintern.({ genv = env; ltacvars }) in + let _, tacexp = Genintern.generic_intern env tacexp in HintsExternEntry (pri, pat, tacexp) let add_hints local dbnames0 h = @@ -1310,7 +1312,7 @@ let pr_hint h = match h.obj with env with e when CErrors.noncritical e -> Global.env () in - (str "(*external*) " ++ Pptactic.pr_glb_generic env tac) + (str "(*external*) " ++ Pputils.pr_glb_generic env tac) let pr_id_hint (id, v) = (pr_hint v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ()) @@ -1446,6 +1448,6 @@ let run_hint tac k = match !warn_hint with else Proofview.tclBIND (k tac.obj) (fun x -> warn tac x) | `STRICT -> if is_imported tac then k tac.obj - else Proofview.tclZERO (UserError ("", (str "Tactic failure."))) + else Proofview.tclZERO (UserError (None, (str "Tactic failure."))) let repr_hint h = h.obj diff --git a/tactics/hints.mli b/tactics/hints.mli index 411540aa1..48351a317 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -15,6 +15,7 @@ open Globnames open Decl_kinds open Evd open Misctypes +open Tactypes open Clenv open Pattern open Vernacexpr @@ -25,6 +26,8 @@ exception Bound val decompose_app_bound : constr -> global_reference * constr array +type debug = Debug | Info | Off + (** Pre-created hint databases *) type 'a hint_ast = @@ -133,7 +136,7 @@ type hints_entry = | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsModeEntry of global_reference * hint_mode list | HintsExternEntry of - int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr + int * (patvar list * constr_pattern) option * Genarg.glob_generic_argument val searchtable_map : hint_db_name -> hint_db @@ -200,7 +203,7 @@ val make_resolve_hyp : (** [make_extern pri pattern tactic_expr] *) val make_extern : - int -> constr_pattern option -> Tacexpr.glob_tactic_expr + int -> constr_pattern option -> Genarg.glob_generic_argument -> hint_entry val run_hint : hint -> @@ -210,14 +213,11 @@ val run_hint : hint -> written code. *) val repr_hint : hint -> (raw_hint * clausenv) hint_ast -val extern_intern_tac : - (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr) Hook.t - (** Create a Hint database from the pairs (name, constr). Useful to take the current goal hypotheses as hints; Boolean tells if lemmas with evars are allowed *) -val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> Tacexpr.delayed_open_constr list -> hint_db +val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> delayed_open_constr list -> hint_db val make_db_list : hint_db_name list -> hint_db list diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 7b52a9cee..27af7200b 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -19,6 +19,8 @@ open Declarations open Tacmach.New open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (* I implemented the following functions which test whether a term t is an inductive but non-recursive type, a general conjuction, a general disjunction, or a type with no constructors. @@ -100,7 +102,7 @@ let match_with_one_constructor style onlybinary allow_rec t = (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in if List.for_all - (fun decl -> let c = get_type decl in + (fun decl -> let c = RelDecl.get_type decl in is_local_assum decl && isRel c && Int.equal (destRel c) mib.mind_nparams) ctx @@ -109,7 +111,7 @@ let match_with_one_constructor style onlybinary allow_rec t = else None else let ctyp = prod_applist mip.mind_nf_lc.(0) args in - let cargs = List.map get_type (prod_assum ctyp) in + let cargs = List.map RelDecl.get_type (prod_assum ctyp) in if not (is_lax_conjunction style) || has_nodep_prod ctyp then (* Record or non strict conjunction *) Some (hdapp,List.rev cargs) @@ -450,7 +452,7 @@ let find_this_eq_data_decompose gl eqn = try (*first_match (match_eq eqn) inversible_equalities*) find_eq_data eqn with PatternMatchingFailure -> - errorlabstrm "" (str "No primitive equality found.") in + user_err (str "No primitive equality found.") in let eq_args = try extract_eq_args gl eq_args with PatternMatchingFailure -> diff --git a/tactics/inv.ml b/tactics/inv.ml index bda16b01c..e7d8249e4 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -25,10 +25,10 @@ open Tactics open Elim open Equality open Misctypes -open Tacexpr open Sigma.Notations open Proofview.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration let var_occurs_in_pf gl id = let env = Proofview.Goal.env gl in @@ -76,7 +76,7 @@ let make_inv_predicate env evd indf realargs id status concl = (hyps_arity,concl) | Dep dflt_concl -> if not (occur_var env id concl) then - errorlabstrm "make_inv_predicate" + user_err ~hdr:"make_inv_predicate" (str "Current goal does not depend on " ++ pr_id id ++ str"."); (* We abstract the conclusion of goal with respect to realargs and c to * be concl in order to rewrite and have @@ -182,7 +182,7 @@ let dependent_hyps env id idlist gl = | [] -> [] | d::l -> (* Update the type of id1: it may have been subject to rewriting *) - let d = pf_get_hyp (get_id d) gl in + let d = pf_get_hyp (NamedDecl.get_id d) gl in if occur_var_in_decl env id d then d :: dep_rec l else dep_rec l @@ -192,7 +192,7 @@ let dependent_hyps env id idlist gl = let split_dep_and_nodep hyps gl = List.fold_right (fun d (l1,l2) -> - if var_occurs_in_pf gl (get_id d) then (d::l1,l2) else (l1,d::l2)) + if var_occurs_in_pf gl (NamedDecl.get_id d) then (d::l1,l2) else (l1,d::l2)) hyps ([],[]) (* Computation of dids is late; must have been done in rewrite_equations*) @@ -383,7 +383,7 @@ let rewrite_equations as_mode othin neqns names ba = Proofview.Goal.nf_enter { enter = begin fun gl -> let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in let first_eq = ref MoveLast in - let avoid = if as_mode then List.map get_id nodepids else [] in + let avoid = if as_mode then List.map NamedDecl.get_id nodepids else [] in match othin with | Some thin -> tclTHENLIST @@ -399,10 +399,10 @@ let rewrite_equations as_mode othin neqns names ba = tclTRY (projectAndApply as_mode thin avoid id first_eq names depids))))) names; tclMAP (fun d -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) - let idopt = if as_mode then Some (get_id d) else None in + let idopt = if as_mode then Some (NamedDecl.get_id d) else None in intro_move idopt (if thin then MoveLast else !first_eq)) nodepids; - (tclMAP (fun d -> tclTRY (clear [get_id d])) depids)] + (tclMAP (fun d -> tclTRY (clear [NamedDecl.get_id d])) depids)] | None -> (* simple inversion *) if as_mode then @@ -440,7 +440,7 @@ let raw_inversion inv_kind id status names = try pf_apply Tacred.reduce_to_atomic_ind gl (pf_unsafe_type_of gl c) with UserError _ -> let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in - CErrors.errorlabstrm "" msg + CErrors.user_err msg in let IndType (indf,realargs) = find_rectype env sigma t in let evdref = ref sigma in @@ -496,8 +496,6 @@ let inversion inv_kind status names id = let inv_gen thin status names = try_intros_until (inversion thin status names) -open Tacexpr - let inv k = inv_gen k NoDep let inv_tac id = inv FullInversion None (NamedHyp id) diff --git a/tactics/inv.mli b/tactics/inv.mli index af1cb996a..df629e7c9 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -9,7 +9,7 @@ open Names open Term open Misctypes -open Tacexpr +open Tactypes type inversion_status = Dep of constr option | NoDep diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 40b600c89..10fc5076c 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -29,6 +29,8 @@ open Decl_kinds open Proofview.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + let no_inductive_inconstr env sigma constr = (str "Cannot recognize an inductive predicate in " ++ pr_lconstr_env env sigma constr ++ @@ -156,7 +158,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let revargs,ownsign = fold_named_context (fun env d (revargs,hyps) -> - let id = get_id d in + let id = NamedDecl.get_id d in if Id.List.mem id ivars then ((mkVar id)::revargs, Context.Named.add d hyps) else @@ -183,7 +185,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let ind = try find_rectype env sigma i with Not_found -> - errorlabstrm "inversion_scheme" (no_inductive_inconstr env sigma i) + user_err ~hdr:"inversion_scheme" (no_inductive_inconstr env sigma i) in let (invEnv,invGoal) = compute_first_inversion_scheme env sigma ind sort dep_option @@ -193,7 +195,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = (global_vars env invGoal) (ids_of_named_context (named_context invEnv))); (* - errorlabstrm "lemma_inversion" + user_err ~hdr:"lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) let pf = Proof.start (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in @@ -206,7 +208,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let ownSign = ref begin fold_named_context (fun env d sign -> - if mem_named_context_val (get_id d) global_named_context then sign + if mem_named_context_val (NamedDecl.get_id d) global_named_context then sign else Context.Named.add d sign) invEnv ~init:Context.Named.empty end in @@ -247,8 +249,8 @@ let add_inversion_lemma_exn na com comsort bool tac = try add_inversion_lemma na env sigma c sort bool tac with - | UserError ("Case analysis",s) -> (* Reference to Indrec *) - errorlabstrm "Inv needs Nodep Prop Set" s + | UserError (Some "Case analysis",s) -> (* Reference to Indrec *) + user_err ~hdr:"Inv needs Nodep Prop Set" s (* ================================= *) (* Applying a given inversion lemma *) @@ -261,10 +263,10 @@ let lemInv id c gls = Proofview.V82.of_tactic (Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false) gls with | NoSuchBinding -> - errorlabstrm "" + user_err (hov 0 (pr_constr c ++ spc () ++ str "does not refer to an inversion lemma.")) | UserError (a,b) -> - errorlabstrm "LemInv" + user_err ~hdr:"LemInv" (str "Cannot refine current goal with the lemma " ++ pr_lconstr_env (Refiner.pf_env gls) (Refiner.project gls) c) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 66da9ee18..93c04e373 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -15,8 +15,10 @@ open Termops open Declarations open Tacmach open Clenv +open Tactypes open Sigma.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (************************************************************************) (* Tacticals re-exported from the Refiner module *) @@ -70,7 +72,7 @@ let nthDecl m gl = try List.nth (pf_hyps gl) (m-1) with Failure _ -> error "No such assumption." -let nthHypId m gl = nthDecl m gl |> get_id +let nthHypId m gl = nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = mkVar (nthHypId m gl) let lastDecl gl = nthDecl 1 gl @@ -81,7 +83,7 @@ let nLastDecls n gl = try List.firstn n (pf_hyps gl) with Failure _ -> error "Not enough hypotheses in the goal." -let nLastHypsId n gl = List.map get_id (nLastDecls n gl) +let nLastHypsId n gl = List.map NamedDecl.get_id (nLastDecls n gl) let nLastHyps n gl = List.map mkVar (nLastHypsId n gl) let onNthDecl m tac gl = tac (nthDecl m gl) gl @@ -99,7 +101,7 @@ let onNLastHypsId n tac = onHyps (nLastHypsId n) tac let onNLastHyps n tac = onHyps (nLastHyps n) tac let afterHyp id gl = - fst (List.split_when (Id.equal id % get_id) (pf_hyps gl)) + fst (List.split_when (NamedDecl.get_id %> Id.equal id) (pf_hyps gl)) (***************************************) (* Clause Tacticals *) @@ -151,7 +153,7 @@ type branch_args = { nassums : int; (* number of assumptions/letin to be introduced *) branchsign : bool list; (* the signature of the branch. true=assumption, false=let-in *) - branchnames : Tacexpr.intro_patterns} + branchnames : intro_patterns} type branch_assumptions = { ba : branch_args; (* the branch args *) @@ -172,14 +174,14 @@ let check_or_and_pattern_size check_and loc names branchsigns = let n = Array.length branchsigns in let msg p1 p2 = strbrk "a conjunctive pattern made of " ++ int p1 ++ (if p1 == p2 then mt () else str " or " ++ int p2) ++ str " patterns" in let err1 p1 p2 = - user_err_loc (loc,"",str "Expects " ++ msg p1 p2 ++ str ".") in + user_err ~loc (str "Expects " ++ msg p1 p2 ++ str ".") in let errn n = - user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n + user_err ~loc (str "Expects a disjunctive pattern with " ++ int n ++ str " branches.") in let err1' p1 p2 = - user_err_loc (loc,"",strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in + user_err ~loc (strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in let errforthcoming loc = - user_err_loc (loc,"",strbrk "Unexpected non atomic pattern.") in + user_err ~loc (strbrk "Unexpected non atomic pattern.") in match names with | IntroAndPattern l -> if not (Int.equal n 1) then errn n; @@ -311,7 +313,7 @@ module New = struct tclZERO (Refiner.FailError (lvl,lazy msg)) let tclZEROMSG ?loc msg = - let err = UserError ("", msg) in + let err = UserError (None, msg) in let info = match loc with | None -> Exninfo.null | Some loc -> Loc.add_loc Exninfo.null loc @@ -478,10 +480,10 @@ module New = struct (* Select a subset of the goals *) let tclSELECT = function - | Tacexpr.SelectNth i -> Proofview.tclFOCUS i i - | Tacexpr.SelectList l -> Proofview.tclFOCUSLIST l - | Tacexpr.SelectId id -> Proofview.tclFOCUSID id - | Tacexpr.SelectAll -> fun tac -> tac + | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i + | Vernacexpr.SelectList l -> Proofview.tclFOCUSLIST l + | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id + | Vernacexpr.SelectAll -> fun tac -> tac (* Check that holes in arguments have been resolved *) @@ -508,7 +510,7 @@ module New = struct | [] -> () | (evk,evi) :: _ -> let (loc,_) = evi.Evd.evar_source in - Pretype_errors.error_unsolvable_implicit loc env sigma evk None + Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None let tclWITHHOLES accept_unresolved_holes tac sigma = tclEVARMAP >>= fun sigma_initial -> @@ -532,7 +534,7 @@ module New = struct Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let Sigma (x, sigma, _) = x.Tacexpr.delayed env sigma in + let Sigma (x, sigma, _) = x.delayed env sigma in tclWITHHOLES check (tac x) (Sigma.to_evar_map sigma) end } @@ -560,7 +562,7 @@ module New = struct let nthHypId m gl = (** We only use [id] *) let gl = Proofview.Goal.assume gl in - nthDecl m gl |> get_id + nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = mkVar (nthHypId m gl) @@ -592,7 +594,7 @@ module New = struct let afterHyp id tac = Proofview.Goal.enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let rem, _ = List.split_when (Id.equal id % get_id) hyps in + let rem, _ = List.split_when (NamedDecl.get_id %> Id.equal id) hyps in tac rem end } @@ -643,7 +645,7 @@ module New = struct | Var id -> string_of_id id | _ -> "\b" in - errorlabstrm "Tacticals.general_elim_then_using" + user_err ~hdr:"Tacticals.general_elim_then_using" (str "The elimination combinator " ++ str name_elim ++ str " is unknown.") in let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index cfdc2cffd..18cf03c51 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -11,9 +11,9 @@ open Names open Term open Tacmach open Proof_type -open Tacexpr open Locus open Misctypes +open Tactypes (** Tacticals i.e. functions from tactics to tactics. *) @@ -221,7 +221,7 @@ module New : sig val tclCOMPLETE : 'a tactic -> 'a tactic val tclSOLVE : unit tactic list -> unit tactic val tclPROGRESS : unit tactic -> unit tactic - val tclSELECT : goal_selector -> 'a tactic -> 'a tactic + val tclSELECT : Vernacexpr.goal_selector -> 'a tactic -> 'a tactic val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic val tclDELAYEDWITHHOLES : bool -> 'a delayed_open -> ('a -> unit tactic) -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 893f33f1a..de328e23f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -32,7 +32,6 @@ open Refiner open Tacticals open Hipattern open Coqlib -open Tacexpr open Decl_kinds open Evarutil open Indrec @@ -41,8 +40,13 @@ open Unification open Locus open Locusops open Misctypes +open Tactypes open Proofview.Notations open Sigma.Notations +open Context.Named.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration let inj_with_occurrences e = (AllOccurrences,e) @@ -52,7 +56,7 @@ let typ_of env sigma c = let open Retyping in try get_type_of ~lax:true env (Sigma.to_evar_map sigma) c with RetypeError e -> - user_err_loc (Loc.ghost, "", print_retype_error e) + user_err (print_retype_error e) open Goptions @@ -166,19 +170,17 @@ let _ = (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) let unsafe_intro env store decl b = - let open Context.Named.Declaration in Refine.refine ~unsafe:true { run = begin fun sigma -> let ctx = named_context_val env in let nctx = push_named_context_val decl ctx in - let inst = List.map (mkVar % get_id) (named_context env) in + let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in let ninst = mkRel 1 :: inst in - let nb = subst1 (mkVar (get_id decl)) b in + let nb = subst1 (mkVar (NamedDecl.get_id decl)) b in let Sigma (ev, sigma, p) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in Sigma (mkNamedLambda_or_LetIn decl ev, sigma, p) end } let introduction ?(check=true) id = - let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in @@ -187,9 +189,10 @@ let introduction ?(check=true) id = let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in let () = if check && mem_named_context_val id hyps then - errorlabstrm "Tactics.introduction" + user_err ~hdr:"Tactics.introduction" (str "Variable " ++ pr_id id ++ str " is already declared.") in + let open Context.Named.Declaration in match kind_of_term (whd_evar sigma concl) with | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b @@ -259,7 +262,7 @@ let clear_dependency_msg env sigma id = function Printer.pr_existential env sigma ev ++ str"." let error_clear_dependency env sigma id err = - errorlabstrm "" (clear_dependency_msg env sigma id err) + user_err (clear_dependency_msg env sigma id err) let replacing_dependency_msg env sigma id = function | Evarutil.OccurHypInSimpleClause None -> @@ -273,7 +276,7 @@ let replacing_dependency_msg env sigma id = function Printer.pr_existential env sigma ev ++ str"." let error_replacing_dependency env sigma id err = - errorlabstrm "" (replacing_dependency_msg env sigma id err) + user_err (replacing_dependency_msg env sigma id err) (* This tactic enables the user to remove hypotheses from the signature. * Some care is taken to prevent him from removing variables that are @@ -332,7 +335,6 @@ let move_hyp id dest = (* Renaming hypotheses *) let rename_hyp repl = - let open Context.Named.Declaration in let fold accu (src, dst) = match accu with | None -> None | Some (srcs, dsts) -> @@ -354,7 +356,7 @@ let rename_hyp repl = let concl = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in (** Check that we do not mess variables *) - let fold accu decl = Id.Set.add (get_id decl) accu in + let fold accu decl = Id.Set.add (NamedDecl.get_id decl) accu in let vars = List.fold_left fold Id.Set.empty hyps in let () = if not (Id.Set.subset src vars) then @@ -365,7 +367,7 @@ let rename_hyp repl = let () = try let elt = Id.Set.choose (Id.Set.inter dst mods) in - CErrors.errorlabstrm "" (pr_id elt ++ str " is already used") + CErrors.user_err (pr_id elt ++ str " is already used") with Not_found -> () in (** All is well *) @@ -373,13 +375,13 @@ let rename_hyp repl = let subst = List.map make_subst repl in let subst c = Vars.replace_vars subst c in let map decl = - decl |> map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) - |> map_constr subst + decl |> NamedDecl.map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) + |> NamedDecl.map_constr subst in let nhyps = List.map map hyps in let nconcl = subst concl in let nctx = Environ.val_of_named_context nhyps in - let instance = List.map (mkVar % get_id) hyps in + let instance = List.map (NamedDecl.get_id %> mkVar) hyps in Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance end } @@ -438,7 +440,7 @@ let find_name mayrepl decl naming gl = match naming with let ids_of_hyps = Tacmach.New.pf_ids_of_hyps gl in let id' = next_ident_away id ids_of_hyps in if not mayrepl && not (Id.equal id' id) then - user_err_loc (loc,"",pr_id id ++ str" is already used."); + user_err ~loc (pr_id id ++ str" is already used."); id (**************************************************************) @@ -523,7 +525,7 @@ let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> if not (eq_mind sp sp') then error "Fixpoints should be on the same mutual inductive declaration."; if mem_named_context_val f sign then - errorlabstrm "Logic.prim_refiner" + user_err ~hdr:"Logic.prim_refiner" (str "Name " ++ pr_id f ++ str " already used in the environment"); mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in @@ -614,7 +616,7 @@ let pf_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); LocalAssum (id,redfun' ty) | LocalDef (id,b,ty) -> let b' = if where != InHypTypeOnly then redfun' b else b in @@ -715,7 +717,7 @@ let pf_e_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = redfun sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> @@ -755,7 +757,7 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> @@ -793,12 +795,12 @@ let check_types env sigma mayneedglobalcheck deep newc origc = isSort (whd_all env sigma t2) then (mayneedglobalcheck := true; sigma) else - errorlabstrm "convert-check-hyp" (str "Types are incompatible.") + user_err ~hdr:"convert-check-hyp" (str "Types are incompatible.") else sigma end else if not (isSort (whd_all env sigma t1)) then - errorlabstrm "convert-check-hyp" (str "Not a type.") + user_err ~hdr:"convert-check-hyp" (str "Not a type.") else sigma (* Now we introduce different instances of the previous tacticals *) @@ -807,7 +809,7 @@ let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun en let sigma = Sigma.to_evar_map sigma in let sigma = check_types env sigma mayneedglobalcheck deep t' c in let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in - if not b then errorlabstrm "convert-check-hyp" (str "Not convertible."); + if not b then user_err ~hdr:"convert-check-hyp" (str "Not convertible."); Sigma.Unsafe.of_pair (t', sigma) end } @@ -884,7 +886,11 @@ let reduction_clause redexp cl = (None, bind_red_expr_occurrences occs nbcl redexp)) cl let reduce redexp cl = - let trace () = Pp.(hov 2 (Pptactic.pr_atomic_tactic (Global.env()) (TacReduce (redexp,cl)))) in + let trace () = + let open Printer in + let pr = (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern) in + Pp.(hov 2 (Pputils.pr_red_expr pr str redexp)) + in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter { enter = begin fun gl -> let cl' = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in @@ -901,7 +907,7 @@ let reduce redexp cl = let unfold_constr = function | ConstRef sp -> unfold_in_concl [AllOccurrences,EvalConstRef sp] | VarRef id -> unfold_in_concl [AllOccurrences,EvalVarRef id] - | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.") + | _ -> user_err ~hdr:"unfold_constr" (str "Cannot unfold a non-constant.") (*******************************************) (* Introduction tactics *) @@ -1000,23 +1006,21 @@ let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = aux n [] let get_next_hyp_position id gl = - let open Context.Named.Declaration in let rec aux = function | [] -> raise (RefinerError (NoSuchHyp id)) | decl :: right -> - if Id.equal (get_id decl) id then - match right with decl::_ -> MoveBefore (get_id decl) | [] -> MoveLast + if Id.equal (NamedDecl.get_id decl) id then + match right with decl::_ -> MoveBefore (NamedDecl.get_id decl) | [] -> MoveLast else aux right in aux (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let get_previous_hyp_position id gl = - let open Context.Named.Declaration in let rec aux dest = function | [] -> raise (RefinerError (NoSuchHyp id)) | decl :: right -> - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if Id.equal hyp id then dest else aux (MoveAfter hyp) right in aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) @@ -1096,7 +1100,7 @@ let depth_of_quantified_hypothesis red h gl = match lookup_hypothesis_as_renamed_gen red h gl with | Some depth -> depth | None -> - errorlabstrm "lookup_quantified_hypothesis" + user_err ~hdr:"lookup_quantified_hypothesis" (str "No " ++ msg_quantified_hypothesis h ++ strbrk " in current goal" ++ (if red then strbrk " even after head-reduction" else mt ()) ++ @@ -1245,7 +1249,7 @@ let cut c = let error_uninstantiated_metas t clenv = let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta") - in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".") + in user_err (str "Cannot find an instance for " ++ pr_id id ++ str".") let check_unresolved_evars_of_metas sigma clenv = (* This checks that Metas turned into Evars by *) @@ -1378,7 +1382,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags let indmv = (match kind_of_term (nth_arg i elimclause.templval.rebus) with | Meta mv -> mv - | _ -> errorlabstrm "elimination_clause" + | _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.")) in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in @@ -1543,7 +1547,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) try match List.remove Int.equal indmv (clenv_independent elimclause) with | [a] -> a | _ -> failwith "" - with Failure _ -> errorlabstrm "elimination_clause" + with Failure _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.") in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in let hyp = mkVar id in @@ -1552,7 +1556,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in if Term.eq_constr hyp_typ new_hyp_typ then - errorlabstrm "general_rewrite_in" + user_err ~hdr:"general_rewrite_in" (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id id sigma elimclause'' (fun id -> Proofview.tclUNIT ()) @@ -1577,7 +1581,7 @@ let make_projection env sigma params cstr sign elim i n c u = | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) let decl = List.nth cstr.cs_args i in - let t = get_type decl in + let t = RelDecl.get_type decl in let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> b in let branch = it_mkLambda_or_LetIn b cstr.cs_args in if @@ -1959,7 +1963,6 @@ let exact_proof c = end } let assumption = - let open Context.Named.Declaration in let rec arec gl only_eq = function | [] -> if only_eq then @@ -1967,7 +1970,7 @@ let assumption = arec gl false hyps else Tacticals.New.tclZEROMSG (str "No such assumption.") | decl::rest -> - let t = get_type decl in + let t = NamedDecl.get_type decl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let (sigma, is_same_type) = @@ -1978,7 +1981,7 @@ let assumption = in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> - exact_no_check (mkVar (get_id decl)) + exact_no_check (mkVar (NamedDecl.get_id decl)) else arec gl only_eq rest in let assumption_tac = { enter = begin fun gl -> @@ -2008,7 +2011,7 @@ let check_is_type env sigma ty = let check_decl env sigma decl = let open Context.Named.Declaration in - let ty = get_type decl in + let ty = NamedDecl.get_type decl in let evdref = ref sigma in try let _ = Typing.e_sort_of env evdref ty in @@ -2018,7 +2021,7 @@ let check_decl env sigma decl = in !evdref with e when CErrors.noncritical e -> - let id = get_id decl in + let id = NamedDecl.get_id decl in raise (DependsOnBody (Some id)) let clear_body ids = @@ -2031,7 +2034,7 @@ let clear_body ids = let map = function | LocalAssum (id,t) as decl -> let () = if List.mem_f Id.equal id ids then - errorlabstrm "" (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") + user_err (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") in decl | LocalDef (id,_,t) as decl -> @@ -2050,7 +2053,7 @@ let clear_body ids = check_decl env sigma decl else sigma in - let seen = seen || List.mem_f Id.equal (get_id decl) ids in + let seen = seen || List.mem_f Id.equal (NamedDecl.get_id decl) ids in (push_named decl env, sigma, seen) in let (env, sigma, _) = List.fold_left check (base_env, sigma, false) (List.rev ctx) in @@ -2090,13 +2093,12 @@ let rec intros_clearing = function (* Keeping only a few hypotheses *) let keep hyps = - let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in let cl,_ = fold_named_context_reverse (fun (clear,keep) decl -> - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if Id.List.mem hyp hyps || List.exists (occur_var_in_decl env hyp) keep || occur_var env hyp ccl @@ -2162,7 +2164,7 @@ let check_number_of_constructors expctdnumopt i nconstr = if Int.equal i 0 then error "The constructors are numbered starting from 1."; begin match expctdnumopt with | Some n when not (Int.equal n nconstr) -> - errorlabstrm "Tactics.check_number_of_constructors" + user_err ~hdr:"Tactics.check_number_of_constructors" (str "Not an inductive goal with " ++ int n ++ str (String.plural n " constructor") ++ str ".") | _ -> () end; @@ -2251,7 +2253,7 @@ let error_unexpected_extra_pattern loc bound pat = | IntroNaming (IntroIdentifier _) -> "name", (String.plural nb " introduction pattern"), "no" | _ -> "introduction pattern", "", "none" in - user_err_loc (loc,"",str "Unexpected " ++ str s1 ++ str " (" ++ + user_err ~loc (str "Unexpected " ++ str s1 ++ str " (" ++ (if Int.equal nb 0 then (str s3 ++ str s2) else (str "at most " ++ int nb ++ str s2)) ++ spc () ++ str (if Int.equal nb 1 then "was" else "were") ++ @@ -2491,8 +2493,8 @@ and prepare_intros_loc loc with_evars dft destopt = function (fun _ l -> clear_wildcards l) in fun id -> intro_pattern_action loc with_evars true true ipat [] destopt tac id) - | IntroForthcoming _ -> user_err_loc - (loc,"",str "Introduction pattern for one hypothesis expected.") + | IntroForthcoming _ -> user_err ~loc + (str "Introduction pattern for one hypothesis expected.") let intro_patterns_bound_to with_evars n destopt = intro_patterns_core with_evars true [] [] [] destopt @@ -2634,13 +2636,12 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = end } let insert_before decls lasthyp env = - let open Context.Named.Declaration in match lasthyp with | None -> push_named_context decls env | Some id -> Environ.fold_named_context (fun _ d env -> - let env = if Id.equal id (get_id d) then push_named_context decls env else env in + let env = if Id.equal id (NamedDecl.get_id d) then push_named_context decls env else env in push_named d env) ~init:(reset_context env) env @@ -2659,7 +2660,7 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = | IntroFresh heq_base -> fresh_id_in_env [id] heq_base env | IntroIdentifier id -> if List.mem id (ids_of_named_context (named_context env)) then - user_err_loc (loc,"",pr_id id ++ str" is already used."); + user_err ~loc (pr_id id ++ str" is already used."); id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in @@ -2741,7 +2742,7 @@ let enough_by na t tac = forward false (Some (Some tac)) (ipat_of_name na) t let generalized_name c t ids cl = function | Name id as na -> if Id.List.mem id ids then - errorlabstrm "" (pr_id id ++ str " is already used."); + user_err (pr_id id ++ str " is already used."); na | Anonymous -> match kind_of_term c with @@ -2779,19 +2780,18 @@ let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = generalize_goal_gen env sigma ids i o t cl let old_generalize_dep ?(with_let=false) c gl = - let open Context.Named.Declaration in let env = pf_env gl in let sign = pf_hyps gl in let init_ids = ids_of_named_context (Global.named_context()) in let seek (d:Context.Named.Declaration.t) (toquant:Context.Named.t) = - if List.exists (fun d' -> occur_var_in_decl env (get_id d') d) toquant + if List.exists (fun d' -> occur_var_in_decl env (NamedDecl.get_id d') d) toquant || dependent_in_decl c d then d::toquant else toquant in let to_quantify = Context.Named.fold_outside seek sign ~init:[] in let to_quantify_rev = List.rev to_quantify in - let qhyps = List.map get_id to_quantify_rev in + let qhyps = List.map NamedDecl.get_id to_quantify_rev in let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in let tothin' = match kind_of_term c with @@ -2803,7 +2803,7 @@ let old_generalize_dep ?(with_let=false) c gl = let body = if with_let then match kind_of_term c with - | Var id -> Tacmach.pf_get_hyp gl id |> get_value + | Var id -> id |> Tacmach.pf_get_hyp gl |> NamedDecl.get_value | _ -> None else None in @@ -2906,7 +2906,7 @@ let specialize (c,lbind) ipat = let tstack = chk tstack in let term = applist(thd,List.map (nf_evar clause.evd) tstack) in if occur_meta term then - errorlabstrm "" (str "Cannot infer an instance for " ++ + user_err (str "Cannot infer an instance for " ++ pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ str "."); @@ -2951,12 +2951,12 @@ let unfold_body x = (** We normalize the given hypothesis immediately. *) let env = Proofview.Goal.env (Proofview.Goal.assume gl) in let xval = match Environ.lookup_named x env with - | LocalAssum _ -> errorlabstrm "unfold_body" + | LocalAssum _ -> user_err ~hdr:"unfold_body" (pr_id x ++ str" is not a defined hypothesis.") | LocalDef (_,xval,_) -> xval in Tacticals.New.afterHyp x begin fun aft -> - let hl = List.fold_right (fun decl cl -> (get_id decl, InHyp) :: cl) aft [] in + let hl = List.fold_right (fun decl cl -> (NamedDecl.get_id decl, InHyp) :: cl) aft [] in let rfun _ _ c = replace_vars [x, xval] c in let reducth h = reduct_in_hyp rfun h in let reductc = reduct_in_concl (rfun, DEFAULTcast) in @@ -3048,7 +3048,7 @@ let safe_dest_intro_patterns with_evars avoid thin dest pat tac = Proofview.tclORELSE (dest_intro_patterns with_evars avoid thin dest pat tac) begin function (e, info) -> match e with - | UserError ("move_hyp",_) -> + | UserError (Some "move_hyp",_) -> (* May happen e.g. with "destruct x using s" with an hypothesis which is morally an induction hypothesis to be "MoveLast" if known as such but which is considered instead as a subterm of @@ -3275,7 +3275,6 @@ exception Shunt of Id.t move_location let cook_sign hyp0_opt inhyps indvars env = (* First phase from L to R: get [toclear], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) - let open Context.Named.Declaration in let toclear = ref [] in let avoid = ref [] in let decldeps = ref [] in @@ -3285,7 +3284,7 @@ let cook_sign hyp0_opt inhyps indvars env = let before = ref true in let maindep = ref false in let seek_deps env decl rhyp = - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then begin before:=false; @@ -3304,7 +3303,7 @@ let cook_sign hyp0_opt inhyps indvars env = in let depother = List.is_empty inhyps && (List.exists (fun id -> occur_var_in_decl env id decl) indvars || - List.exists (fun decl' -> occur_var_in_decl env (get_id decl') decl) !decldeps) + List.exists (fun decl' -> occur_var_in_decl env (NamedDecl.get_id decl') decl) !decldeps) in if not (List.is_empty inhyps) && Id.List.mem hyp inhyps || dephyp0 || depother @@ -3327,7 +3326,7 @@ let cook_sign hyp0_opt inhyps indvars env = let _ = fold_named_context seek_deps env ~init:MoveFirst in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) let compute_lstatus lhyp decl = - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then raise (Shunt lhyp); if Id.List.mem hyp !ldeps then begin @@ -3448,7 +3447,7 @@ let make_up_names n ind_opt cname = let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in - errorlabstrm "Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") + user_err ~hdr:"Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") let glob = Universes.constr_of_global @@ -3495,8 +3494,8 @@ let ids_of_constr ?(all=false) vars c = Array.fold_left_from (if all then 0 else mib.Declarations.mind_nparams) aux vars args - | _ -> fold_constr aux vars c) - | _ -> fold_constr aux vars c + | _ -> Term.fold_constr aux vars c) + | _ -> Term.fold_constr aux vars c in aux vars c let decompose_indapp f args = @@ -3551,13 +3550,12 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = end } let hyps_of_vars env sign nogen hyps = - let open Context.Named.Declaration in if Id.Set.is_empty hyps then [] else let (_,lh) = Context.Named.fold_inside (fun (hs,hl) d -> - let x = get_id d in + let x = NamedDecl.get_id d in if Id.Set.mem x nogen then (hs,hl) else if Id.Set.mem x hs then (hs,x::hl) else @@ -3587,8 +3585,7 @@ let linear vars args = with Seen -> false let is_defined_variable env id = - let open Context.Named.Declaration in - lookup_named id env |> is_local_def + env |> lookup_named id |> is_local_def let abstract_args gl generalize_vars dep id defined f args = let open Context.Rel.Declaration in @@ -3611,7 +3608,7 @@ let abstract_args gl generalize_vars dep id defined f args = let name, ty, arity = let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in let decl = List.hd rel in - get_name decl, get_type decl, c + RelDecl.get_name decl, RelDecl.get_type decl, c in let argty = Tacmach.pf_unsafe_type_of gl arg in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in @@ -4046,14 +4043,15 @@ let is_functional_induction elimc gl = need a dependent one or not *) let get_eliminator elim dep s gl = - let open Context.Rel.Declaration in match elim with | ElimUsing (elim,indsign) -> Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in - let branchlengthes = List.map (fun d -> assert (is_local_assum d); pi1 (decompose_prod_letin (get_type d))) (List.rev s.branches) in + let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (RelDecl.get_type d))) + (List.rev s.branches) + in evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l (* Instantiate all meta variables of elimclause using lid, some elts @@ -4066,7 +4064,7 @@ let recolle_clenv i params args elimclause gl = (fun x -> match kind_of_term x with | Meta mv -> mv - | _ -> errorlabstrm "elimination_clause" + | _ -> user_err ~hdr:"elimination_clause" (str "The type of the elimination clause is not well-formed.")) arr in let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in @@ -4115,7 +4113,6 @@ let induction_tac with_evars params indvars elim = induction applies with the induction hypotheses *) let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_tac = - let open Context.Named.Declaration in Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in @@ -4128,7 +4125,7 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let s = Retyping.get_sort_family_of env sigma tmpcl in let deps_cstr = List.fold_left - (fun a decl -> if is_local_assum decl then (mkVar (get_id decl))::a else a) [] deps in + (fun a decl -> if NamedDecl.is_local_assum decl then (mkVar (NamedDecl.get_id decl))::a else a) [] deps in let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in let branchletsigns = let f (_,is_not_let,_,_) = is_not_let in @@ -4210,16 +4207,15 @@ let induction_without_atomization isrec with_evars elim names lid = (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls = Proofview.Goal.nf_enter { enter = begin fun gl -> - let open Context.Named.Declaration in if occur_var (Tacmach.New.pf_env gl) id (Tacmach.New.pf_concl gl) && cls.concl_occs == NoOccurrences - then errorlabstrm "" + then user_err (str "Conclusion must be mentioned: it depends on " ++ pr_id id ++ str "."); match cls.onhyps with | Some hyps -> let to_erase d = - let id' = get_id d in + let id' = NamedDecl.get_id d in if Id.List.mem id' inhyps then (* if selected, do not erase *) None else (* erase if not selected and dependent on id or selected hyps *) @@ -4412,7 +4408,7 @@ let induction_gen_l isrec with_evars elim names lc = let lc = List.map (function | (c,None) -> c | (c,Some(loc,eqname)) -> - user_err_loc (loc,"",str "Do not know what to do with " ++ + user_err ~loc (str "Do not know what to do with " ++ Miscprint.pr_intro_pattern_naming eqname)) lc in let rec atomize_list l = match l with @@ -4786,7 +4782,7 @@ let interpretable_as_section_decl evd d1 d2 = | LocalDef _, LocalAssum _ -> false | LocalDef (_,b1,t1), LocalDef (_,b2,t2) -> e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2 - | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (get_type d2) + | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (NamedDecl.get_type d2) let rec decompose len c t accu = let open Context.Rel.Declaration in @@ -4799,7 +4795,6 @@ let rec decompose len c t accu = | _ -> assert false let rec shrink ctx sign c t accu = - let open Context.Rel.Declaration in match ctx, sign with | [], [] -> (c, t, accu) | p :: ctx, decl :: sign -> @@ -4810,9 +4805,9 @@ let rec shrink ctx sign c t accu = else let c = mkLambda_or_LetIn p c in let t = mkProd_or_LetIn p t in - let accu = if is_local_assum p then let open Context.Named.Declaration in - mkVar (get_id decl) :: accu - else accu + let accu = if RelDecl.is_local_assum p + then mkVar (NamedDecl.get_id decl) :: accu + else accu in shrink ctx sign c t accu | _ -> assert false @@ -4838,7 +4833,6 @@ let abstract_subproof id gk tac = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in - let open Context.Named.Declaration in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let current_sign = Global.named_context_val () @@ -4848,7 +4842,7 @@ let abstract_subproof id gk tac = let sign,secsign = List.fold_right (fun d (s1,s2) -> - let id = get_id d in + let id = NamedDecl.get_id d in if mem_named_context_val id current_sign && interpretable_as_section_decl evdref (lookup_named_val id current_sign) d then (s1,push_named_context_val d s2) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index fb033363e..7acfb6286 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -15,10 +15,10 @@ open Evd open Clenv open Redexpr open Globnames -open Tacexpr open Pattern open Unification open Misctypes +open Tactypes open Locus (** Main tactics defined in ML. This file is huge and should probably be split diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 093302608..f54ad86a3 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -16,7 +16,6 @@ Hints Auto Eauto Class_tactics -Tactic_matching Term_dnet Eqdecide Autorewrite diff --git a/test-suite/output/FunExt.out b/test-suite/output/FunExt.out new file mode 100644 index 000000000..c6786c72f --- /dev/null +++ b/test-suite/output/FunExt.out @@ -0,0 +1,19 @@ +The command has indeed failed with message: +Ltac call to "extensionality in (var)" failed. +Tactic failure: Not an extensional equality. +The command has indeed failed with message: +Ltac call to "extensionality in (var)" failed. +Tactic failure: Not an extensional equality. +The command has indeed failed with message: +Ltac call to "extensionality in (var)" failed. +Tactic failure: Not an extensional equality. +The command has indeed failed with message: +Ltac call to "extensionality in (var)" failed. +Tactic failure: Not an extensional equality. +The command has indeed failed with message: +Ltac call to "extensionality in (var)" failed. +Tactic failure: Already an intensional equality. +The command has indeed failed with message: +In nested Ltac calls to "extensionality in (var)" and +"clearbody (ne_var_list)", last call failed. +Error: Hypothesis e depends on the body of H' diff --git a/test-suite/output/FunExt.v b/test-suite/output/FunExt.v new file mode 100644 index 000000000..7658ce718 --- /dev/null +++ b/test-suite/output/FunExt.v @@ -0,0 +1,168 @@ +Require Import FunctionalExtensionality. + +(* Basic example *) +Goal (forall x y z, x+y+z = z+y+x) -> (fun x y z => z+y+x) = (fun x y z => x+y+z). +intro H. +extensionality in H. +symmetry in H. +assumption. +Qed. + +(* Test rejection of non-equality *) +Goal forall H:(forall A:Prop, A), H=H -> forall H'':True, H''=H''. +intros H H' H''. +Fail extensionality in H. +clear H'. +Fail extensionality in H. +Fail extensionality in H''. +Abort. + +(* Test success on dependent equality *) +Goal forall (p : forall x, S x = x + 1), p = p -> S = fun x => x + 1. +intros p H. +extensionality in p. +assumption. +Qed. + +(* Test dependent functional extensionality *) +Goal forall (P:nat->Type) (Q:forall a, P a -> Type) (f g:forall a (b:P a), Q a b), + (forall x y, f x y = g x y) -> f = g. +intros * H. +extensionality in H. +assumption. +Qed. + +(* Other tests, courtesy of Jason Gross *) + +Goal forall A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c), (forall a b c, f a b c = g a b c) -> f = g. +Proof. + intros A B C D f g H. + extensionality in H. + match type of H with f = g => idtac end. + exact H. +Qed. + +Section test_section. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall a b c, f a b c = g a b c). + Goal f = g. + Proof. + extensionality in H. + match type of H with f = g => idtac end. + exact H. + Qed. +End test_section. + +Section test2. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall b a c, f a b c = g a b c). + Goal (fun b a c => f a b c) = (fun b a c => g a b c). + Proof. + extensionality in H. + match type of H with (fun b a => f a b) = (fun b' a' => g a' b') => idtac end. + exact H. + Qed. +End test2. + +Section test3. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall a c, (fun b => f a b c) = (fun b => g a b c)). + Goal (fun a c b => f a b c) = (fun a c b => g a b c). + Proof. + extensionality in H. + match type of H with (fun a c b => f a b c) = (fun a' c' b' => g a' b' c') => idtac end. + exact H. + Qed. +End test3. + +Section test4. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c -> Type) + (H : forall b, (forall a c d, f a b c d) = (forall a c d, g a b c d)). + Goal (fun b => forall a c d, f a b c d) = (fun b => forall a c d, g a b c d). + Proof. + extensionality in H. + exact H. + Qed. +End test4. + +Section test5. + Goal nat -> True. + Proof. + intro n. + Fail extensionality in n. + constructor. + Qed. +End test5. + +Section test6. + Goal let f := fun A (x : A) => x in let pf := fun A x => @eq_refl _ (f A x) in f = f. + Proof. + intros f pf. + extensionality in pf. + match type of pf with f = f => idtac end. + exact pf. + Qed. +End test6. + +Section test7. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall a b c, True -> f a b c = g a b c). + Goal True. + Proof. + extensionality in H. + match type of H with (fun a b c (_ : True) => f a b c) = (fun a' b' c' (_ : True) => g a' b' c') => idtac end. + constructor. + Qed. +End test7. + +Section test8. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : True -> forall a b c, f a b c = g a b c). + Goal True. + Proof. + extensionality in H. + match type of H with (fun (_ : True) => f) = (fun (_ : True) => g) => idtac end. + constructor. + Qed. +End test8. + +Section test9. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall b a c, f a b c = g a b c). + Goal (fun b a c => f a b c) = (fun b a c => g a b c). + Proof. + pose H as H'. + extensionality in H. + extensionality in H'. + let T := type of H in let T' := type of H' in constr_eq T T'. + match type of H with (fun b a => f a b) = (fun b' a' => g a' b') => idtac end. + exact H'. + Qed. +End test9. + +Section test10. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : f = g). + Goal True. + Proof. + Fail extensionality in H. + constructor. + Qed. +End test10. + +Section test11. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall a b c, f a b c = f a b c). + Goal True. + Proof. + pose H as H'. + pose (eq_refl : H = H') as e. + extensionality in H. + Fail extensionality in H'. + clear e. + extensionality in H'. + let T := type of H in let T' := type of H' in constr_eq T T'. + lazymatch type of H with f = f => idtac end. + constructor. + Qed. +End test11. diff --git a/test-suite/output/ShowProof.out b/test-suite/output/ShowProof.out new file mode 100644 index 000000000..2d4be8bce --- /dev/null +++ b/test-suite/output/ShowProof.out @@ -0,0 +1 @@ +(fun x : Type => conj I ?Goal) diff --git a/test-suite/output/ShowProof.v b/test-suite/output/ShowProof.v new file mode 100644 index 000000000..73ecaf220 --- /dev/null +++ b/test-suite/output/ShowProof.v @@ -0,0 +1,6 @@ +(* Was #4524 *) +Definition foo (x : Type) : True /\ True. +Proof. +split. +- exact I. + Show Proof. (* Was not finding an evar name at some time *) diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v index 04d9a6704..9551fea1a 100644 --- a/theories/Logic/FunctionalExtensionality.v +++ b/theories/Logic/FunctionalExtensionality.v @@ -56,6 +56,78 @@ Proof. apply functional_extensionality in H. destruct H. reflexivity. Defined. +(** A version of [functional_extensionality_dep] which is provably + equal to [eq_refl] on [fun _ => eq_refl] *) +Definition functional_extensionality_dep_good + {A} {B : A -> Type} + (f g : forall x : A, B x) + (H : forall x, f x = g x) + : f = g + := eq_trans (eq_sym (functional_extensionality_dep f f (fun _ => eq_refl))) + (functional_extensionality_dep f g H). + +Lemma functional_extensionality_dep_good_refl {A B} f + : @functional_extensionality_dep_good A B f f (fun _ => eq_refl) = eq_refl. +Proof. + unfold functional_extensionality_dep_good; edestruct functional_extensionality_dep; reflexivity. +Defined. + +Opaque functional_extensionality_dep_good. + +Lemma forall_sig_eq_rect + {A B} (f : forall a : A, B a) + (P : { g : _ | (forall a, f a = g a) } -> Type) + (k : P (exist (fun g => forall a, f a = g a) f (fun a => eq_refl))) + g +: P g. +Proof. + destruct g as [g1 g2]. + set (g' := fun x => (exist _ (g1 x) (g2 x))). + change g2 with (fun x => proj2_sig (g' x)). + change g1 with (fun x => proj1_sig (g' x)). + clearbody g'; clear g1 g2. + cut (forall x, (exist _ (f x) eq_refl) = g' x). + { intro H'. + apply functional_extensionality_dep_good in H'. + destruct H'. + exact k. } + { intro x. + destruct (g' x) as [g'x1 g'x2]. + destruct g'x2. + reflexivity. } +Defined. + +Definition forall_eq_rect + {A B} (f : forall a : A, B a) + (P : forall g, (forall a, f a = g a) -> Type) + (k : P f (fun a => eq_refl)) + g H + : P g H + := @forall_sig_eq_rect A B f (fun g => P (proj1_sig g) (proj2_sig g)) k (exist _ g H). + +Definition forall_eq_rect_comp {A B} f P k + : @forall_eq_rect A B f P k f (fun _ => eq_refl) = k. +Proof. + unfold forall_eq_rect, forall_sig_eq_rect; simpl. + rewrite functional_extensionality_dep_good_refl; reflexivity. +Qed. + +Definition f_equal__functional_extensionality_dep_good + {A B f g} H a + : f_equal (fun h => h a) (@functional_extensionality_dep_good A B f g H) = H a. +Proof. + apply forall_eq_rect with (H := H); clear H g. + change (eq_refl (f a)) with (f_equal (fun h => h a) (eq_refl f)). + apply f_equal, functional_extensionality_dep_good_refl. +Defined. + +Definition f_equal__functional_extensionality_dep_good__fun + {A B f g} H + : (fun a => f_equal (fun h => h a) (@functional_extensionality_dep_good A B f g H)) = H. +Proof. + apply functional_extensionality_dep_good; intro a; apply f_equal__functional_extensionality_dep_good. +Defined. + (** Apply [functional_extensionality], introducing variable x. *) Tactic Notation "extensionality" ident(x) := @@ -68,6 +140,87 @@ Tactic Notation "extensionality" ident(x) := apply forall_extensionality) ; intro x end. +(** Iteratively apply [functional_extensionality] on an hypothesis + until finding an equality statement *) +(* Note that you can write [Ltac extensionality_in_checker tac ::= tac tt.] to get a more informative error message. *) +Ltac extensionality_in_checker tac := + first [ tac tt | fail 1 "Anomaly: Unexpected error in extensionality tactic. Please report." ]. +Tactic Notation "extensionality" "in" hyp(H) := + let rec check_is_extensional_equality H := + lazymatch type of H with + | _ = _ => constr:(Prop) + | forall a : ?A, ?T + => let Ha := fresh in + constr:(forall a : A, match H a with Ha => ltac:(let v := check_is_extensional_equality Ha in exact v) end) + end in + let assert_is_extensional_equality H := + first [ let dummy := check_is_extensional_equality H in idtac + | fail 1 "Not an extensional equality" ] in + let assert_not_intensional_equality H := + lazymatch type of H with + | _ = _ => fail "Already an intensional equality" + | _ => idtac + end in + let enforce_no_body H := + (tryif (let dummy := (eval unfold H in H) in idtac) + then clearbody H + else idtac) in + let rec extensionality_step_make_type H := + lazymatch type of H with + | forall a : ?A, ?f = ?g + => constr:({ H' | (fun a => f_equal (fun h => h a) H') = H }) + | forall a : ?A, _ + => let H' := fresh in + constr:(forall a : A, match H a with H' => ltac:(let ret := extensionality_step_make_type H' in exact ret) end) + end in + let rec eta_contract T := + lazymatch (eval cbv beta in T) with + | context T'[fun a : ?A => ?f a] + => let T'' := context T'[f] in + eta_contract T'' + | ?T => T + end in + let rec lift_sig_extensionality H := + lazymatch type of H with + | sig _ => H + | forall a : ?A, _ + => let Ha := fresh in + let ret := constr:(fun a : A => match H a with Ha => ltac:(let v := lift_sig_extensionality Ha in exact v) end) in + lazymatch type of ret with + | forall a : ?A, sig (fun b : ?B => @?f a b = @?g a b) + => eta_contract (exist (fun b : (forall a : A, B) => (fun a : A => f a (b a)) = (fun a : A => g a (b a))) + (fun a : A => proj1_sig (ret a)) + (@functional_extensionality_dep_good _ _ _ _ (fun a : A => proj2_sig (ret a)))) + end + end in + let extensionality_pre_step H H_out Heq := + let T := extensionality_step_make_type H in + let H' := fresh in + assert (H' : T) by (intros; eexists; apply f_equal__functional_extensionality_dep_good__fun); + let H''b := lift_sig_extensionality H' in + case H''b; clear H'; + intros H_out Heq in + let rec extensionality_rec H H_out Heq := + lazymatch type of H with + | forall a, _ = _ + => extensionality_pre_step H H_out Heq + | _ + => let pre_H_out' := fresh H_out in + let H_out' := fresh pre_H_out' in + extensionality_pre_step H H_out' Heq; + let Heq' := fresh Heq in + extensionality_rec H_out' H_out Heq'; + subst H_out' + end in + first [ assert_is_extensional_equality H | fail 1 "Not an extensional equality" ]; + first [ assert_not_intensional_equality H | fail 1 "Already an intensional equality" ]; + (tryif enforce_no_body H then idtac else clearbody H); + let H_out := fresh in + let Heq := fresh "Heq" in + extensionality_in_checker ltac:(fun tt => extensionality_rec H H_out Heq); + (* If we [subst H], things break if we already have another equation of the form [_ = H] *) + destruct Heq; rename H_out into H. + (** Eta expansion follows from extensionality. *) Lemma eta_expansion_dep {A} {B : A -> Type} (f : forall x : A, B x) : diff --git a/tools/coqdep.ml b/tools/coqdep.ml index a7c32e1d6..a9f1b7376 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -526,5 +526,5 @@ let _ = try coqdep () with CErrors.UserError(s,p) -> - let pp = if s <> "_" then Pp.(str s ++ str ": " ++ p) else p in + let pp = (match s with | None -> p | Some s -> Pp.(str s ++ str ": " ++ p)) in Feedback.msg_error pp diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml index 45c539e22..8865cd646 100644 --- a/toplevel/assumptions.ml +++ b/toplevel/assumptions.ml @@ -25,6 +25,8 @@ open Globnames open Printer open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + (** For a constant c in a module sealed by an interface (M:T and not M<:T), [Global.lookup_constant] may return a [constant_body] without body. We fix this by looking in the implementation @@ -144,7 +146,7 @@ let label_of = function let rec traverse current ctx accu t = match kind_of_term t with | Var id -> - let body () = Global.lookup_named id |> get_value in + let body () = id |> Global.lookup_named |> NamedDecl.get_value in traverse_object accu body (VarRef id) | Const (kn, _) -> let body () = Global.body_of_constant_body (lookup_constant kn) in diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 0561fc4b8..b1811d6a6 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -25,7 +25,8 @@ open Tactics open Ind_tables open Misctypes open Proofview.Notations -open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration let out_punivs = Univ.out_punivs @@ -150,14 +151,14 @@ let build_beq_scheme mode kn = ( fun a b decl -> (* mkLambda(n,b,a) ) *) (* here I leave the Naming thingy so that the type of the function is more readable for the user *) - mkNamedLambda (eqName (get_name decl)) b a ) + mkNamedLambda (eqName (RelDecl.get_name decl)) b a ) c (List.rev eqs_typ) lnamesparrec in List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *) (* Same here , hoping the auto renaming will do something good ;) *) mkNamedLambda - (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (get_type decl) a) eq_input lnamesparrec + (match RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_type decl) a) eq_input lnamesparrec in let make_one_eq cur = let u = Univ.Instance.empty in @@ -255,7 +256,7 @@ let build_beq_scheme mode kn = | 0 -> Lazy.force tt | _ -> let eqs = Array.make nb_cstr_args (Lazy.force tt) in for ndx = 0 to nb_cstr_args-1 do - let cc = get_type (List.nth constrsi.(i).cs_args ndx) in + let cc = RelDecl.get_type (List.nth constrsi.(i).cs_args ndx) in let eqA, eff' = compute_A_equality rel_list nparrec (nparrec+3+2*nb_cstr_args) @@ -274,14 +275,14 @@ let build_beq_scheme mode kn = (Array.sub eqs 1 (nb_cstr_args - 1)) ) in - (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a)) cc + (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) cc (constrsj.(j).cs_args) ) else ar2.(j) <- (List.fold_left (fun a decl -> - mkLambda (get_name decl, get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) ) + mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) ) done; - ar.(i) <- (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a)) + ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) (mkCase (ci,do_predicate rel_list nb_cstr_args, mkVar (Id.of_string "Y") ,ar2)) (constrsi.(i).cs_args)) @@ -346,7 +347,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = let rec find i = if Id.equal avoid.(n-i) s then avoid.(n-i-x) else (if i<n then find (i+1) - else errorlabstrm "AutoIndDecl.do_replace_lb" + else user_err ~hdr:"AutoIndDecl.do_replace_lb" (str "Var " ++ pr_id s ++ str " seems unknown.") ) in mkVar (find 1) @@ -404,7 +405,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let rec find i = if Id.equal avoid.(n-i) s then avoid.(n-i-x) else (if i<n then find (i+1) - else errorlabstrm "AutoIndDecl.do_replace_bl" + else user_err ~hdr:"AutoIndDecl.do_replace_bl" (str "Var " ++ pr_id s ++ str " seems unknown.") ) in mkVar (find 1) @@ -495,7 +496,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = [(in,eq_in,in_bl,in_al),,...,(i1,eq_i1,i1_bl_i1_al )] *) let list_id l = List.fold_left ( fun a decl -> let s' = - match get_name decl with + match RelDecl.get_name decl with Name s -> Id.to_string s | Anonymous -> "A" in (Id.of_string s',Id.of_string ("eq_"^s'), @@ -512,7 +513,7 @@ let eqI ind l = (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) and e, eff = try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff - with Not_found -> errorlabstrm "AutoIndDecl.eqI" + with Not_found -> user_err ~hdr:"AutoIndDecl.eqI" (str "The boolean equality on " ++ pr_mind (fst ind) ++ str " is needed."); in (if Array.equal eq_constr eA [||] then e else mkApp(e,eA)), eff @@ -543,8 +544,8 @@ let compute_bl_goal ind lnamesparrec nparrec = mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a decl -> mkNamedProd - (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (get_type decl) a) eq_input lnamesparrec + (match RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_type decl) a) eq_input lnamesparrec in let n = Id.of_string "x" and m = Id.of_string "y" in @@ -639,7 +640,7 @@ let side_effect_of_mode = function let make_bl_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then - errorlabstrm "" + user_err (str "Automatic building of boolean->Leibniz lemmas not supported"); let ind = (mind,0) in let nparams = mib.mind_nparams in @@ -686,8 +687,8 @@ let compute_lb_goal ind lnamesparrec nparrec = mkNamedProd seq b a ) lb_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a decl -> mkNamedProd - (match (get_name decl) with Name s -> s | Anonymous -> Id.of_string "A") - (get_type decl) a) eq_input lnamesparrec + (match (RelDecl.get_name decl) with Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_type decl) a) eq_input lnamesparrec in let n = Id.of_string "x" and m = Id.of_string "y" in @@ -762,7 +763,7 @@ let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") let make_lb_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then - errorlabstrm "" + user_err (str "Automatic building of Leibniz->boolean lemmas not supported"); let ind = (mind,0) in let nparams = mib.mind_nparams in @@ -827,8 +828,8 @@ let compute_dec_goal ind lnamesparrec nparrec = mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a decl -> mkNamedProd - (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (get_type decl) a) eq_input lnamesparrec + (match RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_type decl) a) eq_input lnamesparrec in let n = Id.of_string "x" and m = Id.of_string "y" in diff --git a/toplevel/class.ml b/toplevel/class.ml index 6d53ec9d8..0dc799014 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -98,7 +98,7 @@ let class_of_global = function | IndRef sp -> CL_IND sp | VarRef id -> CL_SECVAR id | ConstructRef _ as c -> - errorlabstrm "class_of_global" + user_err ~hdr:"class_of_global" (str "Constructors, such as " ++ Printer.pr_global c ++ str ", cannot be used as a class.") @@ -177,7 +177,7 @@ let ident_key_of_class = function (* Identity coercion *) let error_not_transparent source = - errorlabstrm "build_id_coercion" + user_err ~hdr:"build_id_coercion" (pr_class source ++ str " must be a transparent constant.") let build_id_coercion idf_opt source poly = @@ -208,7 +208,7 @@ let build_id_coercion idf_opt source poly = (Reductionops.is_conv_leq env sigma (Typing.unsafe_type_of env sigma val_f) typ_f) then - errorlabstrm "" (strbrk + user_err (strbrk "Cannot be defined as coercion (maybe a bad number of arguments).") in let idf = @@ -284,7 +284,7 @@ let add_new_coercion_core coef stre poly source target isid = let try_add_new_coercion_core ref ~local c d e f = try add_new_coercion_core ref (loc_of_bool local) c d e f with CoercionError e -> - errorlabstrm "try_add_new_coercion_core" + user_err ~hdr:"try_add_new_coercion_core" (explain_coercion_error ref e ++ str ".") let try_add_new_coercion ref ~local poly = diff --git a/toplevel/classes.ml b/toplevel/classes.ml index d6a6162f9..ad4a13c21 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -22,6 +22,8 @@ open Constrintern open Constrexpr open Sigma.Notations open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration (*i*) open Decl_kinds @@ -66,8 +68,9 @@ let existing_instance glob g pri = match class_of_constr r with | Some (_, ((tc,u), _)) -> add_instance (new_instance tc pri glob (*FIXME*) (Flags.use_polymorphic_flag ()) c) - | None -> user_err_loc (loc_of_reference g, "declare_instance", - Pp.str "Constant does not build instances of a declared type class.") + | None -> user_err ~loc:(loc_of_reference g) + ~hdr:"declare_instance" + (Pp.str "Constant does not build instances of a declared type class.") let mismatched_params env n m = mismatched_ctx_inst env Parameters n m let mismatched_props env n m = mismatched_ctx_inst env Properties n m @@ -77,13 +80,13 @@ let mismatched_props env n m = mismatched_ctx_inst env Properties n m let type_ctx_instance evars env ctx inst subst = let rec aux (subst, instctx) l = function decl :: ctx -> - let t' = substl subst (get_type decl) in + let t' = substl subst (RelDecl.get_type decl) in let c', l = match decl with | LocalAssum _ -> interp_casted_constr_evars env evars (List.hd l) t', List.tl l | LocalDef (_,b,_) -> substl subst b, l in - let d = get_name decl, Some c', t' in + let d = RelDecl.get_name decl, Some c', t' in aux (c' :: subst, d :: instctx) l ctx | [] -> subst in aux (subst, []) inst (List.rev ctx) @@ -156,7 +159,6 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p let cl, u = Typeclasses.typeclass_univ_instance k in let _, args = List.fold_right (fun decl (args, args') -> - let open Context.Rel.Declaration in match decl with | LocalAssum _ -> (List.tl args, List.hd args :: args') | LocalDef (_,b,_) -> (args, substl args' b :: args')) @@ -169,7 +171,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p Name id -> let sp = Lib.make_path id in if Nametab.exists_cci sp then - errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists."); + user_err ~hdr:"new_instance" (Nameops.pr_id id ++ Pp.str " already exists."); id | Anonymous -> let i = Nameops.add_suffix (id_of_class k) "_instance_0" in @@ -229,7 +231,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p (fun (props, rest) decl -> if is_local_assum decl then try - let is_id (id', _) = match get_name decl, get_id id' with + let is_id (id', _) = match RelDecl.get_name decl, get_id id' with | Name id, (_, id') -> Id.equal id id' | Anonymous, _ -> false in @@ -347,7 +349,7 @@ let named_of_rel_context l = let acc, ctx = List.fold_right (fun decl (subst, ctx) -> - let id = match get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in + let id = match RelDecl.get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in let d = match decl with | LocalAssum (_,t) -> id, None, substl subst t | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in diff --git a/toplevel/command.ml b/toplevel/command.ml index 12c387dcf..ef918ef8d 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -39,6 +39,8 @@ open Sigma.Notations open Context.Rel.Declaration open Entries +module RelDecl = Context.Rel.Declaration + let do_universe poly l = Declare.do_universe poly l let do_constraint poly l = Declare.do_constraint poly l @@ -57,8 +59,8 @@ let rec complete_conclusion a cs = function | CHole (loc, k, _, _) -> let (has_no_args,name,params) = a in if not has_no_args then - user_err_loc (loc,"", - strbrk"Cannot infer the non constant arguments of the conclusion of " + user_err ~loc + (strbrk"Cannot infer the non constant arguments of the conclusion of " ++ pr_id cs ++ str "."); let args = List.map (fun id -> CRef(Ident(loc,id),None)) params in CAppExpl (loc,(None,Ident(loc,name),None),List.rev args) @@ -330,7 +332,7 @@ let do_assumptions kind nl l = match l with | (Discharge, _, _) when Lib.sections_are_opened () -> let loc = fst id in let msg = Pp.str "Section variables cannot be polymorphic." in - user_err_loc (loc, "", msg) + user_err ~loc msg | _ -> () in do_assumptions_bound_univs coe kind nl id (Some pl) c @@ -342,7 +344,7 @@ let do_assumptions kind nl l = match l with let loc = fst id in let msg = Pp.str "Assumptions with bound universes can only be defined one at a time." in - user_err_loc (loc, "", msg) + user_err ~loc msg in (coe, (List.map map idl, c)) in @@ -438,7 +440,7 @@ let interp_ind_arity env evdref ind = let t, impls = understand_tcc_evars env evdref ~expected_type:IsType c, imps in let pseudo_poly = check_anonymous_type c in let () = if not (Reduction.is_arity env t) then - user_err_loc (constr_loc ind.ind_arity, "", str "Not an arity") + user_err ~loc:(constr_loc ind.ind_arity) (str "Not an arity") in t, pseudo_poly, impls @@ -457,7 +459,7 @@ let sign_level env evd sign = | LocalDef _ -> lev, push_rel d env | LocalAssum _ -> let s = destSort (Reduction.whd_all env - (nf_evar evd (Retyping.get_type_of env evd (get_type d)))) + (nf_evar evd (Retyping.get_type_of env evd (RelDecl.get_type d)))) in let u = univ_of_sort s in (Univ.sup u lev, push_rel d env)) @@ -553,7 +555,7 @@ let check_named (loc, na) = match na with | Name _ -> () | Anonymous -> let msg = str "Parameters must be named." in - user_err_loc (loc, "", msg) + user_err ~loc msg let check_param = function @@ -576,7 +578,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = (* Names of parameters as arguments of the inductive type (defs removed) *) let assums = List.filter is_local_assum ctx_params in - let params = List.map (fun decl -> out_name (get_name decl)) assums in + let params = List.map (RelDecl.get_name %> out_name) assums in (* Interpret the arities *) let arities = List.map (interp_ind_arity env_params evdref) indl in @@ -909,8 +911,8 @@ let rec telescope = function let ty, tys, (k, constr) = List.fold_left (fun (ty, tys, (k, constr)) decl -> - let t = get_type decl in - let pred = mkLambda (get_name decl, t, ty) in + let t = RelDecl.get_type decl in + let pred = mkLambda (RelDecl.get_name decl, t, ty) in let ty = Universes.constr_of_global (Lazy.force sigT).typ in let intro = Universes.constr_of_global (Lazy.force sigT).intro in let sigty = mkApp (ty, [|t; pred|]) in @@ -920,7 +922,7 @@ let rec telescope = function in let (last, subst) = List.fold_right2 (fun pred decl (prev, subst) -> - let t = get_type decl in + let t = RelDecl.get_type decl in let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in let proj1 = applistc p1 [t; pred; prev] in @@ -954,9 +956,9 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let relty = Typing.unsafe_type_of env !evdref rel in let relargty = let error () = - user_err_loc (constr_loc r, - "Command.build_wellfounded", - Printer.pr_constr_env env !evdref rel ++ str " is not an homogeneous binary relation.") + user_err ~loc:(constr_loc r) + ~hdr:"Command.build_wellfounded" + (Printer.pr_constr_env env !evdref rel ++ str " is not an homogeneous binary relation.") in try let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in @@ -1133,7 +1135,7 @@ let interp_recursive isfix fixl notations = let evd, nf = nf_evars_and_universes evd in let fixdefs = List.map (Option.map nf) fixdefs in let fixtypes = List.map nf fixtypes in - let fixctxnames = List.map (fun (_,ctx) -> List.map get_name ctx) fixctxs in + let fixctxnames = List.map (fun (_,ctx) -> List.map RelDecl.get_name ctx) fixctxs in (* Build the fix declaration block *) (env,rec_sign,all_universes,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxnames fiximps fixannots @@ -1312,7 +1314,7 @@ let do_program_fixpoint local poly l = match n with | Some n -> mkIdentC (snd n) | None -> - errorlabstrm "do_program_fixpoint" + user_err ~hdr:"do_program_fixpoint" (str "Recursive argument required for well-founded fixpoints") in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn @@ -1326,7 +1328,7 @@ let do_program_fixpoint local poly l = do_program_recursive local poly fixkind fixl ntns | _, _ -> - errorlabstrm "do_program_fixpoint" + user_err ~hdr:"do_program_fixpoint" (str "Well-founded fixpoints not allowed in mutually recursive blocks") let check_safe () = diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index acbf909cc..98f60924b 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -130,13 +130,14 @@ let init_ocaml_path () = [ "grammar" ]; [ "ide" ]; [ "ltac" ]; ] let get_compat_version = function - | "8.6" -> Flags.Current + | "8.7" -> Flags.Current + | "8.6" -> Flags.V8_6 | "8.5" -> Flags.V8_5 | "8.4" -> Flags.V8_4 | "8.3" -> Flags.V8_3 | "8.2" -> Flags.V8_2 | ("8.1" | "8.0") as s -> - CErrors.errorlabstrm "get_compat_version" + CErrors.user_err ~hdr:"get_compat_version" (str "Compatibility with version " ++ str s ++ str " not supported.") - | s -> CErrors.errorlabstrm "get_compat_version" + | s -> CErrors.user_err ~hdr:"get_compat_version" (str "Unknown compatibility version \"" ++ str s ++ str "\".") diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 56b477955..f7fafab49 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -25,6 +25,8 @@ open Printer open Evd open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (* This simplifies the typing context of Cases clauses *) (* hope it does not disturb other typing contexts *) let contract env lc = @@ -35,13 +37,10 @@ let contract env lc = l := (Vars.substl !l c') :: !l; env | _ -> - let t' = Vars.substl !l (get_type decl) in - let c' = Option.map (Vars.substl !l) (get_value decl) in - let na' = named_hd env t' (get_name decl) in + let t = Vars.substl !l (RelDecl.get_type decl) in + let decl = decl |> RelDecl.map_name (named_hd env t) |> RelDecl.map_value (Vars.substl !l) |> RelDecl.set_type t in l := (mkRel 1) :: List.map (Vars.lift 1) !l; - match c' with - | None -> push_rel (LocalAssum (na',t')) env - | Some c' -> push_rel (LocalDef (na',c',t')) env + push_rel decl env in let env = process_rel_context contract_context env in (env, List.map (Vars.substl !l) lc) @@ -149,7 +148,7 @@ let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags let pr_db env i = try - match lookup_rel i env |> get_name with + match env |> lookup_rel i |> get_name with | Name id -> pr_id id | Anonymous -> str "<>" with Not_found -> str "UNBOUND_REL_" ++ int i diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 6d57a21dc..85d0b6194 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -87,7 +87,7 @@ let declare_scheme_object s aux f = try let _ = Hashtbl.find scheme_object_table key in (* let aux_msg = if aux="" then "" else " (with key "^aux^")" in*) - errorlabstrm "IndTables.declare_scheme_object" + user_err ~hdr:"IndTables.declare_scheme_object" (str "Scheme object " ++ str key ++ str " already declared.") with Not_found -> Hashtbl.add scheme_object_table key (s,f); diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index e8ea617f4..48521a8e5 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -193,7 +193,7 @@ let try_declare_scheme what f internal names kn = in match msg with | None -> () - | Some msg -> iraise (UserError ("", msg), snd e) + | Some msg -> iraise (UserError (None, msg), snd e) let beq_scheme_msg mind = let mib = Global.lookup_mind mind in diff --git a/toplevel/locality.ml b/toplevel/locality.ml index 154f787ef..03640676e 100644 --- a/toplevel/locality.ml +++ b/toplevel/locality.ml @@ -18,7 +18,7 @@ let check_locality locality_flag = match locality_flag with | Some b -> let s = if b then "Local" else "Global" in - CErrors.errorlabstrm "Locality.check_locality" + CErrors.user_err ~hdr:"Locality.check_locality" (str "This command does not support the \"" ++ str s ++ str "\" prefix.") | None -> () diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 008d5cf9f..f28ef3f65 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -46,12 +46,30 @@ let add_token_obj s = Lib.add_anonymous_leaf (inToken s) let entry_buf = Buffer.create 64 +type any_entry = AnyEntry : 'a Gram.entry -> any_entry + +let grammars : any_entry list String.Map.t ref = ref String.Map.empty + +let register_grammar name grams = + grammars := String.Map.add name grams !grammars + let pr_entry e = let () = Buffer.clear entry_buf in let ft = Format.formatter_of_buffer entry_buf in let () = Gram.entry_print ft e in str (Buffer.contents entry_buf) +let pr_registered_grammar name = + let gram = try Some (String.Map.find name !grammars) with Not_found -> None in + match gram with + | None -> error "Unknown or unprintable grammar entry." + | Some entries -> + let pr_one (AnyEntry e) = + str "Entry " ++ str (Gram.Entry.name e) ++ str " is" ++ fnl () ++ + pr_entry e + in + prlist pr_one entries + let pr_grammar = function | "constr" | "operconstr" | "binder_constr" -> str "Entry constr is" ++ fnl () ++ @@ -64,15 +82,6 @@ let pr_grammar = function pr_entry Pcoq.Constr.operconstr | "pattern" -> pr_entry Pcoq.Constr.pattern - | "tactic" -> - str "Entry tactic_expr is" ++ fnl () ++ - pr_entry Pcoq.Tactic.tactic_expr ++ - str "Entry binder_tactic is" ++ fnl () ++ - pr_entry Pcoq.Tactic.binder_tactic ++ - str "Entry simple_tactic is" ++ fnl () ++ - pr_entry Pcoq.Tactic.simple_tactic ++ - str "Entry tactic_arg is" ++ fnl () ++ - pr_entry Pcoq.Tactic.tactic_arg | "vernac" -> str "Entry vernac is" ++ fnl () ++ pr_entry Pcoq.Vernac_.vernac ++ @@ -84,7 +93,7 @@ let pr_grammar = function pr_entry Pcoq.Vernac_.gallina ++ str "Entry gallina_ext is" ++ fnl () ++ pr_entry Pcoq.Vernac_.gallina_ext - | _ -> error "Unknown or unprintable grammar entry." + | name -> pr_registered_grammar name (**********************************************************************) (* Parse a format (every terminal starting with a letter or a single @@ -238,7 +247,7 @@ let rec find_pattern nt xl = function | _, Break s :: _ | Break s :: _, _ -> error ("A break occurs on one side of \"..\" but not on the other side.") | _, Terminal s :: _ | Terminal s :: _, _ -> - errorlabstrm "Metasyntax.find_pattern" + user_err ~hdr:"Metasyntax.find_pattern" (str "The token \"" ++ str s ++ str "\" occurs on one side of \"..\" but not on the other side.") | _, [] -> error msg_expected_form_of_recursive_notation @@ -300,7 +309,7 @@ let rec get_notation_vars = function let vars = get_notation_vars sl in if Id.equal id ldots_var then vars else if Id.List.mem id vars then - errorlabstrm "Metasyntax.get_notation_vars" + user_err ~hdr:"Metasyntax.get_notation_vars" (str "Variable " ++ pr_id id ++ str " occurs more than once.") else id::vars @@ -314,7 +323,7 @@ let analyze_notation_tokens l = recvars, List.subtract Id.equal vars (List.map snd recvars), l let error_not_same_scope x y = - errorlabstrm "Metasyntax.error_not_name_scope" + user_err ~hdr:"Metasyntax.error_not_name_scope" (str "Variables " ++ pr_id x ++ str " and " ++ pr_id y ++ str " must be in the same scope.") (**********************************************************************) @@ -390,7 +399,7 @@ let check_open_binder isopen sl m = | _ -> assert false in if isopen && not (List.is_empty sl) then - errorlabstrm "" (str "as " ++ pr_id m ++ + user_err (str "as " ++ pr_id m ++ str " is a non-closed binder, no such \"" ++ prlist_with_sep spc pr_token sl ++ strbrk "\" is allowed to occur.") @@ -661,7 +670,7 @@ let pr_level ntn (from,args) = prlist_with_sep pr_comma (pr_arg_level from) args let error_incompatible_level ntn oldprec prec = - errorlabstrm "" + user_err (str "Notation " ++ str ntn ++ str " is already defined" ++ spc() ++ pr_level ntn oldprec ++ spc() ++ str "while it is now required to be" ++ spc() ++ @@ -739,7 +748,7 @@ let interp_modifiers modl = | SetEntryType (s,typ) :: l -> let id = Id.of_string s in if Id.List.mem_assoc id etyps then - errorlabstrm "Metasyntax.interp_modifiers" + user_err ~hdr:"Metasyntax.interp_modifiers" (str s ++ str " is already assigned to an entry or constr level."); interp assoc level ((id,typ)::etyps) format extra l | SetItemLevel ([],n) :: l -> @@ -747,7 +756,7 @@ let interp_modifiers modl = | SetItemLevel (s::idl,n) :: l -> let id = Id.of_string s in if Id.List.mem_assoc id etyps then - errorlabstrm "Metasyntax.interp_modifiers" + user_err ~hdr:"Metasyntax.interp_modifiers" (str s ++ str " is already assigned to an entry or constr level."); let typ = ETConstr (n,()) in interp assoc level ((id,typ)::etyps) format extra (SetItemLevel (idl,n)::l) @@ -781,7 +790,7 @@ let check_infix_modifiers modifiers = let check_useless_entry_types recvars mainvars etyps = let vars = let (l1,l2) = List.split recvars in l1@l2@mainvars in match List.filter (fun (x,etyp) -> not (List.mem x vars)) etyps with - | (x,_)::_ -> errorlabstrm "Metasyntax.check_useless_entry_types" + | (x,_)::_ -> user_err ~hdr:"Metasyntax.check_useless_entry_types" (pr_id x ++ str " is unbound in the notation.") | _ -> () @@ -829,7 +838,7 @@ let join_auxiliary_recursive_types recvars etyps = | None, Some ytyp -> (x,ytyp)::typs | Some xtyp, Some ytyp when Pervasives.(=) xtyp ytyp -> typs (* FIXME *) | Some xtyp, Some ytyp -> - errorlabstrm "" + user_err (strbrk "In " ++ pr_id x ++ str " .. " ++ pr_id y ++ strbrk ", both ends have incompatible types.")) recvars etyps diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index 085cc87c8..57c120402 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -7,7 +7,6 @@ (************************************************************************) open Names -open Tacexpr open Vernacexpr open Notation open Constrexpr @@ -55,6 +54,10 @@ val add_syntactic_definition : Id.t -> Id.t list * constr_expr -> val pr_grammar : string -> Pp.std_ppcmds +type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry + +val register_grammar : string -> any_entry list -> unit + val check_infix_modifiers : syntax_modifier list -> unit val with_syntax_protection : ('a -> 'b) -> 'a -> 'b diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml index b6690fe47..2396cf04a 100644 --- a/toplevel/mltop.ml +++ b/toplevel/mltop.ml @@ -124,13 +124,13 @@ let ml_load s = | (UserError _ | Failure _ | Not_found as u) -> Exninfo.iraise (u, snd e) | exc -> let msg = report_on_load_obj_error exc in - errorlabstrm "Mltop.load_object" (str"Cannot link ml-object " ++ + user_err ~hdr:"Mltop.load_object" (str"Cannot link ml-object " ++ str s ++ str" to Coq code (" ++ msg ++ str ").")) | WithoutTop -> try Dynlink.loadfile s; s with Dynlink.Error a -> - errorlabstrm "Mltop.load_object" + user_err ~hdr:"Mltop.load_object" (strbrk "while loading " ++ str s ++ strbrk ": " ++ str (Dynlink.error_message a)) @@ -151,7 +151,7 @@ let dir_ml_use s = if Dynlink.is_native then " Loading ML code works only in bytecode." else "" in - errorlabstrm "Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo) + user_err ~hdr:"Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo) (* Adds a path to the ML paths *) let add_ml_dir s = @@ -226,7 +226,7 @@ let get_ml_object_suffix name = let file_of_name name = let suffix = get_ml_object_suffix name in let fail s = - errorlabstrm "Mltop.load_object" + user_err ~hdr:"Mltop.load_object" (str"File not found on loadpath : " ++ str s ++ str"\n" ++ str"Loadpath: " ++ str(String.concat ":" !coq_mlpath_copy)) in if not (Filename.is_relative name) then @@ -360,7 +360,7 @@ let trigger_ml_object verb cache reinit ?path name = add_loaded_module name (known_module_path name); if cache then perform_cache_obj name end else if not has_dynlink then - errorlabstrm "Mltop.trigger_ml_object" + user_err ~hdr:"Mltop.trigger_ml_object" (str "Dynamic link not supported (module " ++ str name ++ str ")") else begin let file = file_of_name (Option.default name path) in diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 29d745732..aa1a489c2 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -20,6 +20,8 @@ open Pp open CErrors open Util +module NamedDecl = Context.Named.Declaration + let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false) let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false) @@ -34,7 +36,7 @@ let check_evars env evm = | Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_,_,false) -> () | _ -> - Pretype_errors.error_unsolvable_implicit loc env evm key None) + Pretype_errors.error_unsolvable_implicit ~loc env evm key None) (Evd.undefined_map evm) type oblinfo = @@ -51,7 +53,6 @@ type oblinfo = where n binders were passed through. *) let subst_evar_constr evs n idf t = - let open Context.Named.Declaration in let seen = ref Int.Set.empty in let transparent = ref Id.Set.empty in let evar_info id = List.assoc_f Evar.equal id evs in @@ -74,6 +75,7 @@ let subst_evar_constr evs n idf t = in let args = let rec aux hyps args acc = + let open Context.Named.Declaration in match hyps, args with (LocalAssum _ :: tlh), (c :: tla) -> aux tlh tla ((substrec (depth, fixrels) c) :: acc) @@ -116,9 +118,9 @@ let etype_of_evar evs hyps concl = let open Context.Named.Declaration in let rec aux acc n = function decl :: tl -> - let t', s, trans = subst_evar_constr evs n mkVar (get_type decl) in + let t', s, trans = subst_evar_constr evs n mkVar (NamedDecl.get_type decl) in let t'' = subst_vars acc 0 t' in - let rest, s', trans' = aux (get_id decl :: acc) (succ n) tl in + let rest, s', trans' = aux (NamedDecl.get_id decl :: acc) (succ n) tl in let s' = Int.Set.union s s' in let trans' = Id.Set.union trans trans' in (match decl with @@ -258,7 +260,7 @@ let safe_init_constant md name () = Coqlib.gen_constant "Obligations" md name let hide_obligation = safe_init_constant tactics_module "obligation" -let pperror cmd = CErrors.errorlabstrm "Program" cmd +let pperror cmd = CErrors.user_err ~hdr:"Program" cmd let error s = pperror (str s) let reduce c = @@ -398,7 +400,7 @@ let rec prod_app t n = | Prod (_,_,b) -> subst1 n b | LetIn (_, b, t, b') -> prod_app (subst1 b b') n | _ -> - errorlabstrm "prod_app" + user_err ~hdr:"prod_app" (str"Needed a product, but didn't find one" ++ fnl ()) @@ -444,7 +446,7 @@ let from_prg : program_info ProgMap.t ref = let close sec = if not (ProgMap.is_empty !from_prg) then let keys = map_keys !from_prg in - errorlabstrm "Program" + user_err ~hdr:"Program" (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++ prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++ (str (if Int.equal (List.length keys) 1 then " has " else " have ") ++ @@ -598,7 +600,6 @@ let decompose_lam_prod c ty = in aux Context.Rel.empty c ty let shrink_body c ty = - let open Context.Rel.Declaration in let ctx, b, ty = match ty with | None -> @@ -613,6 +614,7 @@ let shrink_body c ty = if noccurn 1 b && Option.cata (noccurn 1) true ty then subst1 mkProp b, Option.map (subst1 mkProp) ty, succ i, args else + let open Context.Rel.Declaration in let args = if is_local_assum decl then mkRel i :: args else args in mkLambda_or_LetIn decl b, Option.map (mkProd_or_LetIn decl) ty, succ i, args) @@ -718,7 +720,7 @@ let get_prog name = let progs = Id.Set.elements (ProgMap.domain prg_infos) in let prog = List.hd progs in let progs = prlist_with_sep pr_comma Nameops.pr_id progs in - errorlabstrm "" + user_err (str "More than one program with unsolved obligations: " ++ progs ++ str "; use the \"of\" clause to specify, as in \"Obligation 1 of " ++ Nameops.pr_id prog ++ str "\"")) @@ -985,7 +987,7 @@ and solve_obligation_by_tac prg obls i tac = let (e, _) = CErrors.push e in match e with | Refiner.FailError (_, s) -> - user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s) + user_err ~loc:(fst obl.obl_location) ~hdr:"solve_obligation" (Lazy.force s) | e -> None (* FIXME really ? *) and solve_prg_obligations prg ?oblset tac = diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index 69d206961..80b689144 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -87,9 +87,9 @@ val add_mutual_definitions : fixpoint_kind -> unit val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> - Tacexpr.raw_tactic_expr option -> unit + Genarg.glob_generic_argument option -> unit -val next_obligation : Names.Id.t option -> Tacexpr.raw_tactic_expr option -> unit +val next_obligation : Names.Id.t option -> Genarg.glob_generic_argument option -> unit val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress (* Number of remaining obligations to be solved for this program *) diff --git a/toplevel/record.ml b/toplevel/record.ml index 9c4d41ea5..a8f8c9293 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -27,6 +27,8 @@ open Goptions open Sigma.Notations open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (********** definition d'un record (structure) **************) (** Flag governing use of primitive projections. Disabled by default. *) @@ -82,7 +84,7 @@ let compute_constructor_level evars env l = List.fold_right (fun d (env, univ) -> let univ = if is_local_assum d then - let s = Retyping.get_sort_of env evars (get_type d) in + let s = Retyping.get_sort_of env evars (RelDecl.get_type d) in Univ.sup (univ_of_sort s) univ else univ in (push_rel d env, univ)) @@ -102,7 +104,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = let error bk (loc, name) = match bk, name with | Default _, Anonymous -> - user_err_loc (loc, "record", str "Record parameters must be named") + user_err ~loc ~hdr:"record" (str "Record parameters must be named") | _ -> () in List.iter @@ -127,7 +129,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = sred, true | None -> s, false else s, false) - | _ -> user_err_loc (constr_loc t,"", str"Sort expected.")) + | _ -> user_err ~loc:(constr_loc t) (str"Sort expected.")) | None -> let uvarkind = Evd.univ_flexible_alg in mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), true @@ -167,7 +169,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = Evd.universe_context ?names:pl evars, nf arity, template, imps, newps, impls, newfs let degenerate_decl decl = - let id = match get_name decl with + let id = match RelDecl.get_name decl with | Name id -> id | Anonymous -> anomaly (Pp.str "Unnamed record variable") in match decl with @@ -208,7 +210,7 @@ let warning_or_error coe indsp err = | _ -> (pr_id fi ++ strbrk " cannot be defined because it is not typable.") in - if coe then errorlabstrm "structure" st; + if coe then user_err ~hdr:"structure" st; Flags.if_verbose Feedback.msg_info (hov 0 st) type field_status = @@ -235,7 +237,7 @@ let subst_projection fid l c = | Projection t -> lift depth t | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k | NoProjection Anonymous -> - errorlabstrm "" (str "Field " ++ pr_id fid ++ + user_err (str "Field " ++ pr_id fid ++ str " depends on the " ++ pr_nth (k-depth-1) ++ str " field which has no name.") else @@ -288,8 +290,8 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let (_,_,kinds,sp_projs,_) = List.fold_left3 (fun (nfi,i,kinds,sp_projs,subst) coe decl impls -> - let fi = get_name decl in - let ti = get_type decl in + let fi = RelDecl.get_name decl in + let ti = RelDecl.get_type decl in let (sp_projs,i,subst) = match fi with | Anonymous -> @@ -362,17 +364,17 @@ let structure_signature ctx = | [decl] -> let env = Environ.empty_named_context_val in let evm = Sigma.Unsafe.of_evar_map evm in - let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in + let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm (RelDecl.get_type decl) in let evm = Sigma.to_evar_map evm in evm | decl::tl -> let env = Environ.empty_named_context_val in let evm = Sigma.Unsafe.of_evar_map evm in - let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in + let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm (RelDecl.get_type decl) in let evm = Sigma.to_evar_map evm in let new_tl = Util.List.map_i (fun pos decl -> - map_type (fun t -> Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) decl) 1 tl in + RelDecl.map_type (fun t -> Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) decl) 1 tl in deps_to_evar evm new_tl in deps_to_evar Evd.empty (List.rev ctx) @@ -422,7 +424,7 @@ let implicits_of_context ctx = | Name n -> Some n | Anonymous -> None in ExplByPos (i, explname), (true, true, true)) - 1 (List.rev (Anonymous :: (List.map get_name ctx))) + 1 (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) let declare_class finite def poly ctx id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities sign = @@ -476,13 +478,13 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity if b then Backward, pri else Forward, pri) coe) coers priorities in - let l = List.map3 (fun decl b y -> get_name decl, b, y) + let l = List.map3 (fun decl b y -> RelDecl.get_name decl, b, y) (List.rev fields) coers (Recordops.lookup_projections ind) in IndRef ind, l in let ctx_context = List.map (fun decl -> - match Typeclasses.class_of_constr (get_type decl) with + match Typeclasses.class_of_constr (RelDecl.get_type decl) with | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true) | None -> None) params, params @@ -537,8 +539,8 @@ let declare_existing_class g = match g with | ConstRef x -> add_constant_class x | IndRef x -> add_inductive_class x - | _ -> user_err_loc (Loc.dummy_loc, "declare_existing_class", - Pp.str"Unsupported class type, only constants and inductives are allowed") + | _ -> user_err ~hdr:"declare_existing_class" + (Pp.str"Unsupported class type, only constants and inductives are allowed") open Vernacexpr diff --git a/toplevel/search.ml b/toplevel/search.ml index ff3c7a4f4..46daacb58 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -20,6 +20,8 @@ open Globnames open Nametab open Goptions +module NamedDecl = Context.Named.Declaration + type filter_function = global_reference -> env -> constr -> bool type display_function = global_reference -> env -> constr -> unit @@ -57,8 +59,7 @@ let iter_constructors indsp u fn env nconstr = done let iter_named_context_name_type f = - let open Context.Named.Declaration in - List.iter (fun decl -> f (get_id decl) (get_type decl)) + List.iter (fun decl -> f (NamedDecl.get_id decl) (NamedDecl.get_type decl)) (* General search over hypothesis of a goal *) let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = @@ -70,13 +71,12 @@ let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = (* General search over declarations *) let iter_declarations (fn : global_reference -> env -> constr -> unit) = - let open Context.Named.Declaration in let env = Global.env () in let iter_obj (sp, kn) lobj = match object_tag lobj with | "VARIABLE" -> begin try let decl = Global.lookup_named (basename sp) in - fn (VarRef (get_id decl)) env (get_type decl) + fn (VarRef (NamedDecl.get_id decl)) env (NamedDecl.get_type decl) with Not_found -> (* we are in a section *) () end | "CONSTANT" -> let cst = Global.constant_of_delta_kn kn in diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index b453dbc46..74adf497e 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -18,7 +18,7 @@ open Vernacexpr Use the module Coqtoplevel, which catches these exceptions (the exceptions are explained only at the toplevel). *) -let user_error loc s = CErrors.user_err_loc (loc,"_",str s) +let user_error loc s = CErrors.user_err ~loc (str s) (* Navigation commands are allowed in a coqtop session but not in a .v file *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index f69bac437..27da3f36c 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -33,6 +33,8 @@ open Misctypes open Locality open Sigma.Notations +module NamedDecl = Context.Named.Declaration + (** TODO: make this function independent of Ltac *) let (f_interp_redexp, interp_redexp_hook) = Hook.make () @@ -383,9 +385,9 @@ let err_unmapped_library loc ?from qid = | Some from -> str " and prefix " ++ pr_dirpath from ++ str "." in - user_err_loc - (loc,"locate_library", - strbrk "Cannot find a physical path bound to logical path matching suffix " ++ + user_err ~loc + ~hdr:"locate_library" + (strbrk "Cannot find a physical path bound to logical path matching suffix " ++ pr_dirpath dir ++ prefix) let err_notfound_library loc ?from qid = @@ -394,9 +396,8 @@ let err_notfound_library loc ?from qid = | Some from -> str " with prefix " ++ pr_dirpath from ++ str "." in - user_err_loc - (loc,"locate_library", - strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) + user_err ~loc ~hdr:"locate_library" + (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) let print_located_library r = let (loc,qid) = qualid_of_reference r in @@ -407,13 +408,13 @@ let print_located_library r = let smart_global r = let gr = Smartlocate.smart_global r in - Dumpglob.add_glob (Constrarg.loc_of_or_by_notation loc_of_reference r) gr; + Dumpglob.add_glob (Stdarg.loc_of_or_by_notation loc_of_reference r) gr; gr let dump_global r = try let gr = Smartlocate.smart_global r in - Dumpglob.add_glob (Constrarg.loc_of_or_by_notation loc_of_reference r) gr + Dumpglob.add_glob (Stdarg.loc_of_or_by_notation loc_of_reference r) gr with e when CErrors.noncritical e -> () (**********) (* Syntax *) @@ -507,7 +508,7 @@ let vernac_start_proof locality p kind l lettop = | None -> ()) l; if not(refining ()) then if lettop then - errorlabstrm "Vernacentries.StartProof" + user_err ~hdr:"Vernacentries.StartProof" (str "Let declarations can only be used in proof editing mode."); start_proof_and_print (local, p, Proof kind) l no_hook @@ -628,15 +629,15 @@ let vernac_combined_scheme lid l = let vernac_universe loc poly l = if poly && not (Lib.sections_are_opened ()) then - user_err_loc (loc, "vernac_universe", - str"Polymorphic universes can only be declared inside sections, " ++ + user_err ~loc ~hdr:"vernac_universe" + (str"Polymorphic universes can only be declared inside sections, " ++ str "use Monomorphic Universe instead"); do_universe poly l let vernac_constraint loc poly l = if poly && not (Lib.sections_are_opened ()) then - user_err_loc (loc, "vernac_constraint", - str"Polymorphic universe constraints can only be declared" + user_err ~loc ~hdr:"vernac_constraint" + (str"Polymorphic universe constraints can only be declared" ++ str " inside sections, use Monomorphic Constraint instead"); do_constraint poly l @@ -863,23 +864,23 @@ let focus_command_cond = Proof.no_cond command_focus let vernac_solve_existential = instantiate_nth_evar_com let vernac_set_end_tac tac = + let open Genintern in + let env = { genv = Global.env (); ltacvars = Id.Set.empty } in + let _, tac = Genintern.generic_intern env tac in if not (refining ()) then error "Unknown command of the non proof-editing mode."; - match tac with - | Tacexpr.TacId [] -> () - | _ -> set_end_tac tac + set_end_tac tac (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) let vernac_set_used_variables e = - let open Context.Named.Declaration in let env = Global.env () in let tys = List.map snd (Proof.initial_goals (Proof_global.give_me_the_proof ())) in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in List.iter (fun id -> - if not (List.exists (Id.equal id % get_id) vars) then - errorlabstrm "vernac_set_used_variables" + if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then + user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ pr_id id)) l; let _, to_clear = set_used_variables l in @@ -1004,9 +1005,9 @@ let vernac_declare_arguments locality r l nargs flags = | [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls | [], _::_, (Some _)::ls when extra_scope_flag -> error "Extra notation scopes can be set on anonymous arguments only" - | [], x::_, _ -> errorlabstrm "vernac_declare_arguments" + | [], x::_, _ -> user_err ~hdr:"vernac_declare_arguments" (str "Extra argument " ++ pr_name x ++ str ".") - | l, [], _ -> errorlabstrm "vernac_declare_arguments" + | l, [], _ -> user_err ~hdr:"vernac_declare_arguments" (str "The following arguments are not declared: " ++ prlist_with_sep pr_comma pr_name l ++ str ".") | _::li, _::ld, _::ls -> check li ld ls @@ -1064,7 +1065,7 @@ let vernac_declare_arguments locality r l nargs flags = | { name = Name x; implicit_status = (`Implicit|`MaximallyImplicit)} :: _, Anonymous :: _ -> - errorlabstrm "vernac_declare_arguments" + user_err ~hdr:"vernac_declare_arguments" (str"Argument "++ pr_id x ++str " cannot be declared implicit.") | { name = Name iid; implicit_status = (`Implicit|`MaximallyImplicit as i)} :: impl, @@ -1095,7 +1096,7 @@ let vernac_declare_arguments locality r l nargs flags = match implicits with [[]] -> false | _ -> true in if some_renaming_specified then if not (List.mem `Rename flags) then - errorlabstrm "vernac_declare_arguments" + user_err ~hdr:"vernac_declare_arguments" (str "To rename arguments the \"rename\" flag must be specified." ++ match !renamed_arg with | None -> mt () @@ -1138,7 +1139,7 @@ let vernac_declare_arguments locality r l nargs flags = | ConstRef _ as c -> Reductionops.ReductionBehaviour.set (make_section_locality locality) c (rargs, nargs, flags) - | _ -> errorlabstrm "" + | _ -> user_err (strbrk "Modifiers of the behavior of the simpl tactic "++ strbrk "are relevant for constants only.") end; @@ -1563,7 +1564,7 @@ let print_about_hyp_globs ref_or_by_not glnumopt = | Some n,AN (Ident (_loc,id)) -> (* goal number given, catch if wong *) (try get_nth_goal n,id with - Failure _ -> errorlabstrm "print_about_hyp_globs" + Failure _ -> user_err ~hdr:"print_about_hyp_globs" (str "No such goal: " ++ int n ++ str ".")) | _ , _ -> raise NoHyp in let hyps = pf_hyps gl in @@ -1571,7 +1572,7 @@ let print_about_hyp_globs ref_or_by_not glnumopt = let natureofid = match decl with | LocalAssum _ -> "Hypothesis" | LocalDef (_,bdy,_) ->"Constant (let in)" in - v 0 (pr_id id ++ str":" ++ pr_constr (get_type decl) ++ fnl() ++ fnl() + v 0 (pr_id id ++ str":" ++ pr_constr (NamedDecl.get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) | NoHyp | Not_found -> print_about ref_or_by_not @@ -1639,8 +1640,8 @@ let global_module r = let (loc,qid) = qualid_of_reference r in try Nametab.full_name_module qid with Not_found -> - user_err_loc (loc, "global_module", - str "Module/section " ++ pr_qualid qid ++ str " not found.") + user_err ~loc ~hdr:"global_module" + (str "Module/section " ++ pr_qualid qid ++ str " not found.") let interp_search_restriction = function | SearchOutside l -> (List.map global_module l, true) @@ -1662,7 +1663,7 @@ let interp_search_about_item env = (fun _ -> true) s sc in GlobSearchSubPattern (Pattern.PRef ref) with UserError _ -> - errorlabstrm "interp_search_about_item" + user_err ~hdr:"interp_search_about_item" (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component") (* 05f22a5d6d5b8e3e80f1a37321708ce401834430 introduced the @@ -1974,12 +1975,12 @@ let interp ?proof ~loc locality poly c = | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n") (* The STM should handle that, but LOAD bypasses the STM... *) - | VernacAbort id -> CErrors.errorlabstrm "" (str "Abort cannot be used through the Load command") - | VernacAbortAll -> CErrors.errorlabstrm "" (str "AbortAll cannot be used through the Load command") - | VernacRestart -> CErrors.errorlabstrm "" (str "Restart cannot be used through the Load command") - | VernacUndo _ -> CErrors.errorlabstrm "" (str "Undo cannot be used through the Load command") - | VernacUndoTo _ -> CErrors.errorlabstrm "" (str "UndoTo cannot be used through the Load command") - | VernacBacktrack _ -> CErrors.errorlabstrm "" (str "Backtrack cannot be used through the Load command") + | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") + | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") + | VernacRestart -> CErrors.user_err (str "Restart cannot be used through the Load command") + | VernacUndo _ -> CErrors.user_err (str "Undo cannot be used through the Load command") + | VernacUndoTo _ -> CErrors.user_err (str "UndoTo cannot be used through the Load command") + | VernacBacktrack _ -> CErrors.user_err (str "Backtrack cannot be used through the Load command") (* Proof management *) | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false @@ -2111,7 +2112,7 @@ let with_fail b f = let (e, _) = CErrors.push e in match e with | HasNotFailed -> - errorlabstrm "Fail" (str "The command has not failed!") + user_err ~hdr:"Fail" (str "The command has not failed!") | HasFailed msg -> if is_verbose () || !test_mode || !ide_slave then Feedback.msg_info (str "The command has indeed failed with message:" ++ fnl () ++ msg) diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 4e7fa4a08..7cdc8dd06 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -62,5 +62,5 @@ val with_fail : bool -> (unit -> unit) -> unit val command_focus : unit Proof.focus_kind -val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Tacexpr.raw_red_expr -> +val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index d81e3d6b5..f26ef460d 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -22,7 +22,7 @@ let vinterp_add depr s f = try Hashtbl.add vernac_tab s (depr, f) with Failure _ -> - errorlabstrm "vinterp_add" + user_err ~hdr:"vinterp_add" (str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.") let overwriting_vinterp_add s f = @@ -37,7 +37,7 @@ let vinterp_map s = try Hashtbl.find vernac_tab s with Failure _ | Not_found -> - errorlabstrm "Vernac Interpreter" + user_err ~hdr:"Vernac Interpreter" (str"Cannot find vernac command " ++ str (fst s) ++ str".") let vinterp_init () = Hashtbl.clear vernac_tab |