diff options
335 files changed, 14119 insertions, 6850 deletions
diff --git a/.gitignore b/.gitignore index c55ad24f8..84b9844a5 100644 --- a/.gitignore +++ b/.gitignore @@ -66,9 +66,12 @@ test-suite/coq-makefile/*/Makefile test-suite/coq-makefile/*/Makefile.conf test-suite/coq-makefile/*/src test-suite/coq-makefile/*/theories +test-suite/coq-makefile/*/theories2 test-suite/coq-makefile/*/html test-suite/coq-makefile/*/mlihtml test-suite/coq-makefile/*/subdir/done +test-suite/coq-makefile/latex1/all.pdf +test-suite/coq-makefile/merlin1/.merlin # documentation @@ -172,3 +175,7 @@ user-contrib .*.sw* test-suite/.lia.cache test-suite/.nra.cache + +# these files are generated from plugins/micromega/MExtraction.v +plugins/micromega/micromega.ml +plugins/micromega/micromega.mli diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9ba39abdb..a6a27194a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -100,13 +100,15 @@ before_script: .test-suite-template: &test-suite-template stage: test script: - - set -e - cd test-suite - make clean # careful with the ending / - make -j ${NJOBS} BIN=$(readlink -f ../install/bin)/ LIB=$(readlink -f ../install/lib/coq)/ all - - cat summary.log - - set +e + artifacts: + name: "$CI_JOB_NAME.logs" + when: on_failure + paths: + - test-suite/logs .validate-template: &validate-template stage: test @@ -44,4 +44,7 @@ B tools/coqdoc S dev B dev +S plugins/** +B plugins/** + PKG threads.posix camlp5 diff --git a/.travis.yml b/.travis.yml index 14bafd345..e79498124 100644 --- a/.travis.yml +++ b/.travis.yml @@ -31,6 +31,7 @@ env: # system is == 4.02.3 - COMPILER="system" - CAMLP5_VER="6.14" + - NATIVE_COMP="yes" # Main test suites matrix: - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" @@ -133,6 +134,16 @@ matrix: - avsm packages: *coqide-packages + - os: osx + env: + - TEST_TARGET="test-suite" + - COMPILER="system" + - CAMLP5_VER="6.17" + - NATIVE_COMP="no" + before_install: + - brew update + - brew install opam + install: - opam init -j ${NJOBS} --compiler=${COMPILER} -n -y - eval $(opam config env) @@ -144,7 +155,7 @@ script: - set -e - echo 'Configuring Coq...' && echo -en 'travis_fold:start:coq.config\\r' -- ./configure -local -usecamlp5 -native-compiler yes ${EXTRA_CONF} +- ./configure -local -usecamlp5 -native-compiler ${NATIVE_COMP} ${EXTRA_CONF} - echo -en 'travis_fold:end:coq.config\\r' - echo 'Building Coq...' && echo -en 'travis_fold:start:coq.build\\r' @@ -6,6 +6,9 @@ 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. +- Tactic "specialize with ..." now accepts any partial bindings. + Missing bindings are either solved by unification or left quantified + in the hypothesis. - New representation of terms that statically ensure stability by evar-expansion. This has several consequences. * In terms of performance, this adds a cost to every term destructuration, @@ -26,6 +29,10 @@ Tactics now uses type classes and rejects terms with unresolved holes, like entry "constr" does. To get the former behavior use "open_constr_with_bindings" (possible source of incompatibility. +- New e-variants eassert, eenough, epose proof, eset, eremember, epose + which behave like the corresponding variants with no "e" but turn + unresolved implicit arguments into existential variables, on the + shelf, rather than failing. Vernacular Commands diff --git a/Makefile.build b/Makefile.build index 8aedd9cec..da736345c 100644 --- a/Makefile.build +++ b/Makefile.build @@ -70,6 +70,29 @@ include Makefile.ide ## provides the 'coqide' rule include Makefile.install include Makefile.dev ## provides the 'printers' and 'revision' rules +########################################################################### +# Adding missing pieces of information not discovered by ocamldep +# due to the fact that: +# - plugins/micromega/micromega_plugin.ml +# - plugins/micromega/micromega_plugin.mli +# are generated (and not yet present when we run "ocamldep"). +########################################################################### + +plugins/micromega/micromega_plugin.cmo : plugins/micromega/micromega.cmo +plugins/micromega/micromega_plugin.cmx : plugins/micromega/micromega.cmx + +plugins/micromega/certificate.cmo plugins/micromega/coq_micromega.cmo plugins/micromega/csdpcert.cmo plugins/micromega/mfourier.cmo plugins/micromega/mutils.cmo plugins/micromega/polynomial.cmo : plugins/micromega/micromega.cmo + +plugins/micromega/certificate.cmx plugins/micromega/coq_micromega.cmx plugins/micromega/csdpcert.cmx plugins/micromega/mfourier.cmx plugins/micromega/mutils.cmx plugins/micromega/polynomial.cmx : plugins/micromega/micromega.cmx + +plugins/micromega/micromega.cmx plugins/micromega/micromega.cmo : plugins/micromega/micromega.cmi +plugins/micromega/micromega.cmi : plugins/micromega/micromega.mli + +plugins/micromega/micromega.mli plugins/micromega/micromega.ml : plugins/micromega/MExtraction.vo + @: + +########################################################################### + # This include below will lauch the build of all .d. # The - at front is for disabling warnings about currently missing ones. # For creating the missing .d, make will recursively build things like @@ -80,6 +103,8 @@ DEPENDENCIES := \ -include $(DEPENDENCIES) +plugins/micromega/micromega_FORPACK:= -for-pack Micromega_plugin + # All dependency includes must be declared secondary, otherwise make will # delete them if it decided to build them by dependency instead of because # of include, and they will then be automatically deleted, leading to an @@ -454,7 +479,6 @@ check: validate test-suite test-suite: world $(ALLSTDLIB).v $(MAKE) $(MAKE_TSOPTS) clean $(MAKE) $(MAKE_TSOPTS) all - $(MAKE) $(MAKE_TSOPTS) report ########################################################################### # Default rules for compiling ML code diff --git a/Makefile.ci b/Makefile.ci index 013685218..e4c63af9d 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -1,7 +1,24 @@ -CI_TARGETS=ci-all ci-hott ci-math-comp ci-compcert ci-sf ci-cpdt \ - ci-color ci-math-classes ci-tlc ci-fiat-crypto ci-fiat-parsers \ - ci-coquelicot ci-flocq ci-iris-coq ci-metacoq ci-geocoq \ - ci-unimath ci-vst ci-bedrock-src ci-bedrock-facade ci-formal-topology +CI_TARGETS=ci-all \ + ci-bedrock-facade \ + ci-bedrock-src \ + ci-color \ + ci-compcert \ + ci-coquelicot \ + ci-cpdt \ + ci-fiat-crypto \ + ci-fiat-parsers \ + ci-flocq \ + ci-formal-topology \ + ci-geocoq \ + ci-hott \ + ci-iris-coq \ + ci-math-classes \ + ci-math-comp \ + ci-metacoq \ + ci-sf \ + ci-tlc \ + ci-unimath \ + ci-vst .PHONY: $(CI_TARGETS) diff --git a/Makefile.common b/Makefile.common index d5f79d76b..4545fad05 100644 --- a/Makefile.common +++ b/Makefile.common @@ -62,7 +62,7 @@ PLUGINDIRS:=\ setoid_ring extraction fourier \ cc funind firstorder derive \ rtauto nsatz syntax btauto \ - ssrmatching ltac + ssrmatching ltac ssr SRCDIRS:=\ $(CORESRCDIRS) \ @@ -120,13 +120,14 @@ OTHERSYNTAXCMO:=$(addprefix plugins/syntax/, \ DERIVECMO:=plugins/derive/derive_plugin.cmo LTACCMO:=plugins/ltac/ltac_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo +SSRCMO:=plugins/ssr/ssreflect_plugin.cmo PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) \ $(QUOTECMO) $(RINGCMO) \ $(FOURIERCMO) $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(NATSYNTAXCMO) $(OTHERSYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) + $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) @@ -146,14 +147,16 @@ LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cmo=.cmx) ## we now retrieve the names of .vo file to compile in */vo.itarget files -THEORIESVO:= $(foreach f, $(wildcard theories/*/vo.itarget), \ - $(addprefix $(dir $(f)),$(shell cat $(f)))) +GENVOFILES := $(GENVFILES:.v=.vo) -PLUGINSVO:= $(foreach f, $(wildcard plugins/*/vo.itarget), \ - $(addprefix $(dir $(f)),$(shell cat $(f)))) +THEORIESVO := $(patsubst %.v,%.vo,$(shell find theories -type f -name "*.v")) \ + $(filter theories/%, $(GENVOFILES)) -ALLVO:= $(THEORIESVO) $(PLUGINSVO) -VFILES:= $(ALLVO:.vo=.v) +PLUGINSVO := $(patsubst %.v,%.vo,$(shell find plugins -type f -name "*.v")) \ + $(filter plugins/%, $(GENVOFILES)) + +ALLVO := $(THEORIESVO) $(PLUGINSVO) +VFILES := $(ALLVO:.vo=.v) ## More specific targets @@ -175,11 +178,10 @@ vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theo vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.vo=.o))))) -LIBFILES:=$(THEORIESVO) $(PLUGINSVO) $(call vo_to_cm,$(THEORIESVO)) \ - $(call vo_to_cm,$(PLUGINSVO)) $(call vo_to_obj,$(THEORIESVO)) \ - $(call vo_to_obj,$(PLUGINSVO)) \ - $(PLUGINSVO:.vo=.v) $(THEORIESVO:.vo=.v) \ - $(PLUGINSVO:.vo=.glob) $(THEORIESVO:.vo=.glob) +GLOBFILES:=$(ALLVO:.vo=.glob) +LIBFILES:=$(ALLVO) $(call vo_to_cm,$(ALLVO)) \ + $(call vo_to_obj,$(ALLVO)) \ + $(VFILES) $(GLOBFILES) # For emacs: # Local Variables: diff --git a/README.ci b/README.ci.md index 43e1bd740..9e25390d7 100644 --- a/README.ci +++ b/README.ci.md @@ -24,11 +24,11 @@ the latest Coq changes validated against your development? If so, keep reading! Getting Coq changes tested against your library is easy, all that you need to do is: -1.- Put you development in a public repository tracking coq trunk. -2.- Make sure that your development builds in less than 35 minutes. -3.- Submit a PR adding your development. -4.- ? -5.- Profit! Your library is now part of Coq's continous integration! +1. Put you development in a public repository tracking coq trunk. +2. Make sure that your development builds in less than 35 minutes. +3. Submit a PR adding your development. +4. ? +5. Profit! Your library is now part of Coq's continous integration! Note that by partipating in this program, you assume a reasonable compromise to discuss and eventually integrate compatibility changes diff --git a/checker/check.ml b/checker/check.ml index 6d93c11ea..b3b403425 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -165,7 +165,7 @@ let find_logical_path phys_dir = match List.filter2 (fun p d -> p = phys_dir) physical logical with | _,[dir] -> dir | _,[] -> default_root_prefix - | _,l -> anomaly (Pp.str ("Two logical paths are associated to "^phys_dir)) + | _,l -> anomaly (Pp.str ("Two logical paths are associated to "^phys_dir^".")) let remove_load_path dir = let physical, logical = !load_paths in @@ -197,7 +197,7 @@ let add_load_path (phys_path,coq_path) = end | _,[] -> load_paths := (phys_path :: fst !load_paths, coq_path :: snd !load_paths) - | _ -> anomaly (Pp.str ("Two logical paths are associated to "^phys_path)) + | _ -> anomaly (Pp.str ("Two logical paths are associated to "^phys_path^".")) let load_paths_of_dir_path dir = let physical, logical = !load_paths in diff --git a/checker/environ.ml b/checker/environ.ml index bce40861c..22d1eec17 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -106,7 +106,7 @@ let anomaly s = anomaly (Pp.str s) let add_constant kn cs env = if Cmap_env.mem kn env.env_globals.env_constants then - Printf.ksprintf anomaly ("Constant %s is already defined") + Printf.ksprintf anomaly ("Constant %s is already defined.") (Constant.to_string kn); let new_constants = Cmap_env.add kn cs env.env_globals.env_constants in @@ -161,7 +161,7 @@ let is_projection cst env = let lookup_projection p env = match (lookup_constant (Projection.constant p) env).const_proj with | Some pb -> pb - | None -> anomaly ("lookup_projection: constant is not a projection") + | None -> anomaly ("lookup_projection: constant is not a projection.") (* Mutual Inductives *) let scrape_mind env kn= @@ -182,7 +182,7 @@ let lookup_mind kn env = let add_mind kn mib env = if Mindmap_env.mem kn env.env_globals.env_inductives then - Printf.ksprintf anomaly ("Inductive %s is already defined") + Printf.ksprintf anomaly ("Inductive %s is already defined.") (MutInd.to_string kn); let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in let kn1,kn2 = MutInd.user kn, MutInd.canonical kn in @@ -201,7 +201,7 @@ let add_mind kn mib env = let add_modtype ln mtb env = if MPmap.mem ln env.env_globals.env_modtypes then - Printf.ksprintf anomaly ("Module type %s is already defined") + Printf.ksprintf anomaly ("Module type %s is already defined.") (ModPath.to_string ln); let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in let new_globals = @@ -211,7 +211,7 @@ let add_modtype ln mtb env = let shallow_add_module mp mb env = if MPmap.mem mp env.env_globals.env_modules then - Printf.ksprintf anomaly ("Module %s is already defined") + Printf.ksprintf anomaly ("Module %s is already defined.") (ModPath.to_string mp); let new_mods = MPmap.add mp mb env.env_globals.env_modules in let new_globals = @@ -221,7 +221,7 @@ let shallow_add_module mp mb env = let shallow_remove_module mp env = if not (MPmap.mem mp env.env_globals.env_modules) then - Printf.ksprintf anomaly ("Module %s is unknown") + Printf.ksprintf anomaly ("Module %s is unknown.") (ModPath.to_string mp); let new_mods = MPmap.remove mp env.env_globals.env_modules in let new_globals = diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 0482912b0..c9ee326cb 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -100,7 +100,7 @@ let rec sorts_of_constr_args env t = let env1 = push_rel (LocalDef (name,def,ty)) env in sorts_of_constr_args env1 c | _ when is_constructor_head t -> [] - | _ -> anomaly ~label:"infos_and_sort" (Pp.str "not a positive constructor") + | _ -> anomaly ~label:"infos_and_sort" (Pp.str "not a positive constructor.") (* Prop and Set are small *) @@ -302,11 +302,11 @@ let failwith_non_pos n ntypes c = let failwith_non_pos_vect n ntypes v = Array.iter (failwith_non_pos n ntypes) v; - anomaly ~label:"failwith_non_pos_vect" (Pp.str "some k in [n;n+ntypes-1] should occur") + anomaly ~label:"failwith_non_pos_vect" (Pp.str "some k in [n;n+ntypes-1] should occur.") let failwith_non_pos_list n ntypes l = List.iter (failwith_non_pos n ntypes) l; - anomaly ~label:"failwith_non_pos_list" (Pp.str "some k in [n;n+ntypes-1] should occur") + anomaly ~label:"failwith_non_pos_list" (Pp.str "some k in [n;n+ntypes-1] should occur.") (* Conclusion of constructors: check the inductive type is called with the expected parameters *) diff --git a/checker/inductive.ml b/checker/inductive.ml index 9e417a8eb..f890adba9 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -75,7 +75,7 @@ let constructor_instantiate mind u mib c = let instantiate_params full t u args sign = let fail () = - anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in + anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch.") in let (rem_args, subs, ty) = fold_rel_context (fun decl (largs,subs,ty) -> @@ -986,7 +986,7 @@ let check_one_fix renv recpos trees def = List.iter (check_rec_call renv []) l; check_rec_call renv [] c - | Var _ -> anomaly (Pp.str "Section variable in Coqchk !") + | Var _ -> anomaly (Pp.str "Section variable in Coqchk!") | Sort _ -> assert (l = []) @@ -1004,7 +1004,7 @@ let check_one_fix renv recpos trees def = check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in check_nested_fix_body renv' (decr-1) recArgsDecrArg b - | _ -> anomaly (Pp.str "Not enough abstractions in fix body") + | _ -> anomaly (Pp.str "Not enough abstractions in fix body.") in check_rec_call renv [] def @@ -1018,7 +1018,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = || Array.length names <> nbfix || bodynum < 0 || bodynum >= nbfix - then anomaly (Pp.str "Ill-formed fix term"); + then anomaly (Pp.str "Ill-formed fix term."); let fixenv = push_rec_types recdef env in let raise_err env i err = error_ill_formed_rec_body env err names i in @@ -1039,7 +1039,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = raise_err env i (RecursionNotOnInductiveType a) in (mind, (env', b)) else check_occur env' (n+1) b - else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call") + else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call.") | _ -> raise_err env i NotEnoughAbstractionInFixBody in check_occur fixenv 1 def in (* Do it on every fixpoint *) @@ -1073,7 +1073,7 @@ let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; exception CoFixGuardError of env * guard_error let anomaly_ill_typed () = - anomaly ~label:"check_one_cofix" (Pp.str "too many arguments applied to constructor") + anomaly ~label:"check_one_cofix" (Pp.str "too many arguments applied to constructor.") let rec codomain_is_coind env c = let b = whd_all env c in diff --git a/checker/reduction.ml b/checker/reduction.ml index 82f09cf4b..ba0b01784 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -333,13 +333,13 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = (* Eta-expansion on the fly *) | (FLambda _, _) -> if v1 <> [] then - anomaly (Pp.str "conversion was given unreduced term (FLambda)"); + anomaly (Pp.str "conversion was given unreduced term (FLambda)."); let (_,_ty1,bd1) = destFLambda mk_clos hd1 in eqappr univ CONV infos (el_lift lft1,(bd1,[])) (el_lift lft2,(hd2,eta_expand_stack v2)) | (_, FLambda _) -> if v2 <> [] then - anomaly (Pp.str "conversion was given unreduced term (FLambda)"); + anomaly (Pp.str "conversion was given unreduced term (FLambda)."); let (_,_ty2,bd2) = destFLambda mk_clos hd2 in eqappr univ CONV infos (el_lift lft1,(hd1,eta_expand_stack v1)) (el_lift lft2,(bd2,[])) @@ -479,7 +479,7 @@ let vm_conv cv_pb = fconv cv_pb true let hnf_prod_app env t n = match whd_all env t with | Prod (_,_,b) -> subst1 n b - | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product") + | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product.") let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl diff --git a/checker/term.ml b/checker/term.ml index 8cac78375..75c566aeb 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -333,7 +333,7 @@ let destArity = | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t)::l) c | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s - | _ -> anomaly ~label:"destArity" (Pp.str "not an arity") + | _ -> anomaly ~label:"destArity" (Pp.str "not an arity.") in prodec_rec [] diff --git a/checker/typeops.ml b/checker/typeops.ml index 1396d56df..0163db334 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -262,7 +262,7 @@ let rec execute env cstr = | Rel n -> judge_of_relative env n - | Var _ -> anomaly (Pp.str "Section variable in Coqchk !") + | Var _ -> anomaly (Pp.str "Section variable in Coqchk!") | Const c -> judge_of_constant env c @@ -344,10 +344,10 @@ let rec execute env cstr = (* Partial proofs: unsupported by the kernel *) | Meta _ -> - anomaly (Pp.str "the kernel does not support metavariables") + anomaly (Pp.str "the kernel does not support metavariables.") | Evar _ -> - anomaly (Pp.str "the kernel does not support existential variables") + anomaly (Pp.str "the kernel does not support existential variables.") and execute_type env constr = let j = execute env constr in diff --git a/checker/univ.ml b/checker/univ.ml index fb1a0faa7..571743231 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -545,7 +545,7 @@ let repr g u = let a = try UMap.find u g with Not_found -> anomaly ~label:"Univ.repr" - (str"Universe " ++ Level.pr u ++ str" undefined") + (str"Universe " ++ Level.pr u ++ str" undefined.") in match a with | Equiv v -> repr_rec v @@ -848,7 +848,7 @@ let merge g arcu arcv = else (max_rank, old_max_rank, best_arc, arc::rest) in match between g arcu arcv with - | [] -> anomaly (str "Univ.between") + | [] -> anomaly (str "Univ.between.") | arc::rest -> let (max_rank, old_max_rank, best_arc, rest) = List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in @@ -911,7 +911,7 @@ let enforce_univ_eq u v g = | FastLT -> error_inconsistency Eq u v | FastLE -> merge g arcv arcu | FastNLE -> merge_disc g arcu arcv - | FastEQ -> anomaly (Pp.str "Univ.compare")) + | FastEQ -> anomaly (Pp.str "Univ.compare.")) (* enforce_univ_leq : Level.t -> Level.t -> unit *) (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) @@ -924,7 +924,7 @@ let enforce_univ_leq u v g = | FastLT -> error_inconsistency Le u v | FastLE -> merge g arcv arcu | FastNLE -> fst (setleq g arcu arcv) - | FastEQ -> anomaly (Pp.str "Univ.compare") + | FastEQ -> anomaly (Pp.str "Univ.compare.") (* enforce_univ_lt u v will force u<v if possible, will fail otherwise *) let enforce_univ_lt u v g = @@ -937,7 +937,7 @@ let enforce_univ_lt u v g = | FastNLE -> match fast_compare_neq false g arcv arcu with FastNLE -> fst (setlt g arcu arcv) - | FastEQ -> anomaly (Pp.str "Univ.compare") + | FastEQ -> anomaly (Pp.str "Univ.compare.") | FastLE | FastLT -> error_inconsistency Lt u v (* Prop = Set is forbidden here. *) @@ -995,13 +995,13 @@ let constraint_add_leq v u c = else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then if Level.equal x y then (* u+(k+1) <= u *) raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u)) - else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints") + else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints.") else if j = 0 then Constraint.add (x,Le,y) c else (* j >= 1 *) (* m = n + k, u <= v+k *) if Level.equal x y then c (* u <= u+k, trivial *) else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) - else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints") + else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints.") let check_univ_leq_one u v = Universe.exists (Expr.leq u) v @@ -1012,7 +1012,7 @@ let enforce_leq u v c = match v with | Universe.Huniv.Cons (v, _, Universe.Huniv.Nil) -> Universe.Huniv.fold (fun u -> constraint_add_leq u v) u c - | _ -> anomaly (Pp.str"A universe bound can only be a variable") + | _ -> anomaly (Pp.str"A universe bound can only be a variable.") let enforce_leq u v c = if check_univ_leq u v then c diff --git a/config/coq_config.mli b/config/coq_config.mli index c171bd355..2b3bc2c25 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -8,11 +8,19 @@ val local : bool (* local use (no installation) *) -val coqlib : string option (* where the std library is installed *) -val configdir : string option (* where configuration files are installed *) -val datadir : string option (* where extra data files are installed *) +(* The fields below are absolute paths *) +val coqlib : string (* where the std library is installed *) +val configdir : string (* where configuration files are installed *) +val datadir : string (* where extra data files are installed *) val docdir : string (* where the doc is installed *) +(* The fields below are paths relative to the installation prefix *) +(* However, if an absolute path, it means discarding the actual prefix *) +val coqlibsuffix : string (* std library relative to installation prefix *) +val configdirsuffix : string (* config files relative to installation prefix *) +val datadirsuffix : string (* data files relative to installation prefix *) +val docdirsuffix : string (* doc directory relative to installation prefix *) + val ocaml : string (* names of ocaml binaries *) val ocamlfind : string val ocamllex : string @@ -26,7 +26,7 @@ done ## We check that $cmd is ok before the real exec $cmd -`$cmd -version > /dev/null 2>&1` && exec $cmd -w "-3" $script "$@" +`$cmd -version > /dev/null 2>&1` && exec $cmd $script "$@" ## If we're still here, something is wrong with $cmd diff --git a/configure.ml b/configure.ml index 7af18cb85..a5204d5b5 100644 --- a/configure.ml +++ b/configure.ml @@ -425,11 +425,11 @@ let arch = match !Prefs.arch with else if arch <> "" then arch else try_archs arch_progs -(** NB: [arch_win32] is broader than [os_type_win32], cf. cygwin *) +(** NB: [arch_is_win32] is broader than [os_type_win32], cf. cygwin *) -let arch_win32 = (arch = "win32") +let arch_is_win32 = (arch = "win32") -let exe = exe := if arch_win32 then ".exe" else ""; !exe +let exe = exe := if arch_is_win32 then ".exe" else ""; !exe let dll = if os_type_win32 then ".dll" else ".so" (** * VCS @@ -449,7 +449,7 @@ let vcs = let browser = match !Prefs.browser with | Some b -> b - | None when arch_win32 -> "start %s" + | None when arch_is_win32 -> "start %s" | None when arch = "Darwin" -> "open %s" | _ -> "firefox -remote \"OpenURL(%s,new-tab)\" || firefox %s &" @@ -515,7 +515,6 @@ let camltag = match caml_version_list with | _ -> assert false (** Explanation of disabled warnings: - 3: deprecated warning (not error for non minimum supported ocaml) 4: fragile pattern matching: too common in the code and too annoying to avoid in general 9: missing fields in a record pattern: too common in the code and not worth the bother 27: innocuous unused variable: innocuous @@ -533,7 +532,7 @@ let coq_warn_flags = if !Prefs.warn_error then "-warn-error +a" ^ (if caml_version_nums > [4;2;3] - then "-3-56" + then "-56" else "") else "" in @@ -598,9 +597,11 @@ let config_camlpX () = let camlp5mod = "gramlib" in let camlp5libdir, camlp5o = check_camlp5 (camlp5mod^".cma") in let camlp5_version = check_camlp5_version camlp5o in - "camlp5", camlp5o, Filename.dirname camlp5o, camlp5libdir, camlp5mod, camlp5_version + "camlp5", "Camlp5", camlp5o, Filename.dirname camlp5o, camlp5libdir, camlp5mod, camlp5_version -let camlpX, camlpXo, camlpXbindir, fullcamlpXlibdir, camlpXmod, camlpX_version = config_camlpX () +let camlpX, capitalized_camlpX, camlpXo, + camlpXbindir, fullcamlpXlibdir, + camlpXmod, camlpX_version = config_camlpX () let shorten_camllib s = if starts_with s (camllib^"/") then @@ -854,73 +855,91 @@ let withdoc = check_doc () let coqtop = Sys.getcwd () -let unix = os_type_cygwin || not arch_win32 +let unix = os_type_cygwin || not arch_is_win32 (** Variable name, description, ref in Prefs, default dir, prefix-relative *) +type path_style = + | Absolute of string (* Should start with a "/" *) + | Relative of string (* Should not start with a "/" *) + let install = [ "BINDIR", "the Coq binaries", Prefs.bindir, - (if unix then "/usr/local/bin" else "C:/coq/bin"), - "/bin"; + Relative "bin", Relative "bin", Relative "bin"; "COQLIBINSTALL", "the Coq library", Prefs.libdir, - (if unix then "/usr/local/lib/coq" else "C:/coq/lib"), - (if arch_win32 then "" else "/lib/coq"); + Relative "lib", Relative "lib/coq", Relative ""; "CONFIGDIR", "the Coqide configuration files", Prefs.configdir, - (if unix then "/etc/xdg/coq" else "C:/coq/config"), - (if arch_win32 then "/config" else "/etc/xdg/coq"); + Relative "config", Absolute "/etc/xdg/coq", Relative "ide"; "DATADIR", "the Coqide data files", Prefs.datadir, - (if unix then "/usr/local/share/coq" else "C:/coq/share"), - "/share/coq"; + Relative "share", Relative "share/coq", Relative "ide"; "MANDIR", "the Coq man pages", Prefs.mandir, - (if unix then "/usr/local/share/man" else "C:/coq/man"), - "/share/man"; + Relative "man", Relative "share/man", Relative "man"; "DOCDIR", "the Coq documentation", Prefs.docdir, - (if unix then "/usr/local/share/doc/coq" else "C:/coq/doc"), - "/share/doc/coq"; + Relative "doc", Relative "share/doc/coq", Relative "doc"; "EMACSLIB", "the Coq Emacs mode", Prefs.emacslib, - (if unix then "/usr/local/share/emacs/site-lisp" else "C:/coq/emacs"), - (if arch_win32 then "/emacs" else "/share/emacs/site-lisp"); + Relative "emacs", Relative "share/emacs/site-lisp", Relative "tools"; "COQDOCDIR", "the Coqdoc LaTeX files", Prefs.coqdocdir, - (if unix then "/usr/local/share/texmf/tex/latex/misc" else "C:/coq/latex"), - (if arch_win32 then "/latex" else "/share/emacs/site-lisp"); + Relative "latex", Relative "share/texmf/tex/latex/misc", Relative "tools/coqdoc"; ] -let do_one_instdir (var,msg,r,dflt,suff) = - let dir = match !r, !Prefs.prefix with - | Some d, _ -> d - | _, Some p -> p^suff - | _ -> +let strip_trailing_slash_if_any p = + if p.[String.length p - 1] = '/' then String.sub p 0 (String.length p - 1) else p + +let use_suffix prefix = function + | Relative "" -> prefix + | Relative suff -> prefix ^ "/" ^ suff + | Absolute path -> path + +let relativize = function + (* Turn a global layout based on some prefix to a relative layout *) + | Relative _ as suffix -> suffix + | Absolute path -> Relative (String.sub path 1 (String.length path - 1)) + +let find_suffix prefix path = match prefix with + | None -> Absolute path + | Some p -> + let p = strip_trailing_slash_if_any p in + let lpath = String.length path in + let lp = String.length p in + if lpath > lp && String.sub path 0 lp = p then + Relative (String.sub path (lp+1) (lpath - lp - 1)) + else + Absolute path + +let do_one_instdir (var,msg,uservalue,selfcontainedlayout,unixlayout,locallayout) = + let dir,suffix = + if !Prefs.local then (use_suffix coqtop locallayout,locallayout) + else match !uservalue, !Prefs.prefix with + | Some d, p -> d,find_suffix p d + | _, Some p -> + let suffix = if arch_is_win32 then selfcontainedlayout else relativize unixlayout in + use_suffix p suffix, suffix + | _, p -> + let suffix = if unix then unixlayout else selfcontainedlayout in + let base = if unix then "/usr/local" else "C:/coq" in + let dflt = use_suffix base suffix in let () = printf "Where should I install %s [%s]? " msg dflt in let line = read_line () in - if line = "" then dflt else line - in (var,msg,dir,dir<>dflt) - -let do_one_noinst (var,msg,_,_,_) = - if var="CONFIGDIR" || var="DATADIR" then (var,msg,coqtop^"/ide",true) - else (var,msg,coqtop^"/doc",false) + if line = "" then (dflt,suffix) else (line,find_suffix p line) + in (var,msg,dir,suffix) -let install_dirs = - let f = if !Prefs.local then do_one_noinst else do_one_instdir in - List.map f install +let install_dirs = List.map do_one_instdir install let select var = List.find (fun (v,_,_,_) -> v=var) install_dirs -let libdir = let (_,_,d,_) = select "COQLIBINSTALL" in d - -let docdir = let (_,_,d,_) = select "DOCDIR" in d +let coqlib,coqlibsuffix = let (_,_,d,s) = select "COQLIBINSTALL" in d,s -let configdir = - let (_,_,d,b) = select "CONFIGDIR" in if b then Some d else None +let docdir,docdirsuffix = let (_,_,d,s) = select "DOCDIR" in d,s -let datadir = - let (_,_,d,b) = select "DATADIR" in if b then Some d else None +let configdir,configdirsuffix = let (_,_,d,s) = select "CONFIGDIR" in d,s +let datadir,datadirsuffix = let (_,_,d,s) = select "DATADIR" in d,s (** * OCaml runtime flags *) (** Do we use -custom (yes by default on Windows and MacOS) *) -let custom_os = arch_win32 || arch = "Darwin" +let custom_os = arch_is_win32 || arch = "Darwin" let use_custom = match !Prefs.custom with | Some b -> b @@ -940,7 +959,7 @@ let config_runtime () = | _ -> let ld="CAML_LD_LIBRARY_PATH" in build_loadpath := sprintf "export %s:='%s/kernel/byterun':$(%s)" ld coqtop ld; - ["-dllib";"-lcoqrun";"-dllpath";libdir/"kernel/byterun"] + ["-dllib";"-lcoqrun";"-dllpath";coqlib/"kernel/byterun"] let vmbyteflags = config_runtime () @@ -959,9 +978,9 @@ let print_summary () = pr " OCaml version : %s\n" caml_version; pr " OCaml binaries in : %s\n" camlbin; pr " OCaml library in : %s\n" camllib; - pr " %s version : %s\n" (String.capitalize camlpX) camlpX_version; - pr " %s binaries in : %s\n" (String.capitalize camlpX) camlpXbindir; - pr " %s library in : %s\n" (String.capitalize camlpX) camlpXlibdir; + pr " %s version : %s\n" capitalized_camlpX camlpX_version; + pr " %s binaries in : %s\n" capitalized_camlpX camlpXbindir; + pr " %s library in : %s\n" capitalized_camlpX camlpXlibdir; if best_compiler = "opt" then pr " Native dynamic link support : %B\n" hasnatdynlink; if coqide <> "no" then @@ -1018,18 +1037,22 @@ let write_configml f = let pr_s = pr "let %s = %S\n" in let pr_b = pr "let %s = %B\n" in let pr_i = pr "let %s = %d\n" in - let pr_o s o = pr "let %s = %s\n" s - (match o with None -> "None" | Some d -> sprintf "Some %S" d) + let pr_p s o = pr "let %s = %S\n" s + (match o with Relative s -> s | Absolute s -> s) in pr "(* DO NOT EDIT THIS FILE: automatically generated by ../configure *)\n"; pr "(* Exact command that generated this file: *)\n"; pr "(* %s *)\n\n" (String.concat " " (Array.to_list Sys.argv)); pr_b "local" !Prefs.local; pr "let vmbyteflags = ["; List.iter (pr "%S;") vmbyteflags; pr "]\n"; - pr_o "coqlib" (if !Prefs.local then None else Some libdir); - pr_o "configdir" configdir; - pr_o "datadir" datadir; + pr_s "coqlib" coqlib; + pr_s "configdir" configdir; + pr_s "datadir" datadir; pr_s "docdir" docdir; + pr_p "coqlibsuffix" coqlibsuffix; + pr_p "configdirsuffix" configdirsuffix; + pr_p "datadirsuffix" datadirsuffix; + pr_p "docdirsuffix" docdirsuffix; pr_s "ocaml" camlexec.top; pr_s "ocamlfind" camlexec.find; pr_s "ocamllex" camlexec.lex; @@ -1048,7 +1071,7 @@ let write_configml f = pr_s "date" short_date; pr_s "compile_date" full_date; pr_s "arch" arch; - pr_b "arch_is_win32" arch_win32; + pr_b "arch_is_win32" arch_is_win32; pr_s "exec_extension" exe; pr_s "coqideincl" !lablgtkincludes; pr_s "has_coqide" coqide; diff --git a/dev/ci/ci-fiat-parsers.sh b/dev/ci/ci-fiat-parsers.sh index c62aa1d85..a0cb008a3 100755 --- a/dev/ci/ci-fiat-parsers.sh +++ b/dev/ci/ci-fiat-parsers.sh @@ -7,4 +7,4 @@ fiat_parsers_CI_DIR=${CI_BUILD_DIR}/fiat git_checkout ${fiat_parsers_CI_BRANCH} ${fiat_parsers_CI_GITURL} ${fiat_parsers_CI_DIR} -( cd ${fiat_parsers_CI_DIR} && make -j ${NJOBS} parsers ) +( cd ${fiat_parsers_CI_DIR} && make -j ${NJOBS} parsers && make -j ${NJOBS} fiat-core ) diff --git a/dev/ci/ci-user-overlay.sh b/dev/ci/ci-user-overlay.sh index bfa43cde1..195ede6d0 100644 --- a/dev/ci/ci-user-overlay.sh +++ b/dev/ci/ci-user-overlay.sh @@ -25,10 +25,8 @@ echo $TRAVIS_PULL_REQUEST echo $TRAVIS_BRANCH echo $TRAVIS_COMMIT -if [ $TRAVIS_PULL_REQUEST == "678" ] || [ $TRAVIS_BRANCH == "coqlib-part-02" ]; then - - mathcomp_CI_BRANCH=coqlib-part-02 - mathcomp_CI_GITURL=https://github.com/ejgallego/math-comp.git - +if [ $TRAVIS_PULL_REQUEST == "669" ] || [ $TRAVIS_BRANCH == "ssr-merge" ]; then + mathcomp_CI_BRANCH=ssr-merge + mathcomp_CI_GITURL=https://github.com/maximedenes/math-comp.git fi diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 7fad65bf0..bcda4ff50 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -51,6 +51,12 @@ In Constrexpr_ops: interpreting "(x y z:_)" as "(x:_) (y:_) (z:_)" while the second ones were preserving the original sharing of the type. +In Nameops: + + The API has been made more uniform. New combinators added in the + "Name" space name. Function "out_name" now fails with IsAnonymous + rather than with Failure "Nameops.out_name". + Location handling and AST attributes: Location handling has been reworked. First, Loc.ghost has been @@ -113,13 +119,17 @@ In Coqlib / reference location: We have removed from Coqlib functions returning `constr` from names. Now it is only possible to obtain references, that must be processed wrt the particular needs of the client. + We have changed in constrintern the functions returnin `constr` as + well to return global references instead. Users of `coq_constant/gen_constant` can do `Universes.constr_of_global (find_reference dir r)` _however_ note the warnings in the `Universes.constr_of_global` in the documentation. It is very likely that you were previously suffering from problems with polymorphic universes due to using - `Coqlib.coq_constant` that used to do this. + `Coqlib.coq_constant` that used to do this. You must rather use + `pf_constr_of_global` in tactics and `Evarutil.new_global` variants + when constructing terms in ML (see univpoly.txt for more information). ** Tactic API ** @@ -127,6 +137,10 @@ In Coqlib / reference location: Thus it only generates one instance of the global reference, and it is the caller's responsibility to perform a focus on the goal. +- pf_global, construct_reference, global_reference, + global_reference_in_absolute_module now return a global_reference + instead of a constr. + - The tclWEAK_PROGRESS and tclNOTSAMEGOAL tacticals were removed. Their usecase was very specific. Use tclPROGRESS instead. diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index fc3fdd002..253eb7f01 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -1155,6 +1155,15 @@ Section~\ref{Occurrences_clauses}. These are the general forms that combine the previous possibilities. +\item {\tt eset ( {\ident$_0$} \nelistnosep{\binder} := {\term} ) in {\occgoalset}}\tacindex{eset}\\ + {\tt eset {\term} in {\occgoalset}} + + While the different variants of \texttt{set} expect that no + existential variables are generated by the tactic, \texttt{eset} + removes this constraint. In practice, this is relevant only when + \texttt{eset} is used as a synonym of \texttt{epose}, i.e. when the + term does not occur in the goal. + \item {\tt remember {\term} as {\ident}}\tacindex{remember} This behaves as {\tt set ( {\ident} := {\term} ) in *} and using a @@ -1170,6 +1179,15 @@ Section~\ref{Occurrences_clauses}. This is a more general form of {\tt remember} that remembers the occurrences of {\term} specified by an occurrences set. +\item + {\tt eremember {\term} as {\ident}}\tacindex{eremember}\\ + {\tt eremember {\term} as {\ident} in {\occgoalset}}\\ + {\tt eremember {\term} as {\ident} eqn:{\ident}} + + While the different variants of \texttt{remember} expect that no + existential variables are generated by the tactic, \texttt{eremember} + removes this constraint. + \item {\tt pose ( {\ident} := {\term} )}\tacindex{pose} This adds the local definition {\ident} := {\term} to the current @@ -1187,6 +1205,14 @@ Section~\ref{Occurrences_clauses}. This behaves as {\tt pose ( {\ident} := {\term} )} but {\ident} is generated by {\Coq}. +\item {\tt epose ( {\ident} := {\term} )}\tacindex{epose}\\ + {\tt epose ( {\ident} \nelistnosep{\binder} := {\term} )}\\ + {\tt epose {\term}} + + While the different variants of \texttt{pose} expect that no + existential variables are generated by the tactic, \texttt{epose} + removes this constraint. + \end{Variants} \subsection{\tt decompose [ {\qualid$_1$} \dots\ {\qualid$_n$} ] \term} @@ -1284,6 +1310,14 @@ in the list of subgoals remaining to prove. \ErrMsg \errindex{Variable {\ident} is already declared} +\item \texttt{eassert {\form} as {\intropattern} by {\tac}}\tacindex{eassert}\tacindex{eassert as}\tacindex{eassert by}\\ + {\tt assert ( {\ident} := {\term} )} + + While the different variants of \texttt{assert} expect that no + existential variables are generated by the tactic, \texttt{eassert} + removes this constraint. This allows not to specify the asserted + statement completely before starting to prove it. + \item \texttt{pose proof {\term} \zeroone{as {\intropattern}}\tacindex{pose proof}} This tactic behaves like \texttt{assert T \zeroone{as {\intropattern}} by @@ -1294,6 +1328,11 @@ in the list of subgoals remaining to prove. as {\intropattern}} is the same as applying the {\intropattern} to {\term}. +\item \texttt{epose proof {\term} \zeroone{as {\intropattern}}\tacindex{epose proof}} + + While \texttt{pose proof} expects that no existential variables are generated by the tactic, + \texttt{epose proof} removes this constraint. + \item \texttt{enough ({\ident} :\ {\form})}\tacindex{enough} This adds a new hypothesis of name {\ident} asserting {\form} to the @@ -1320,6 +1359,14 @@ in the list of subgoals remaining to prove. destructed. If the \texttt{as} {\intropattern} clause generates more than one subgoal, {\tac} is applied to all of them. +\item \texttt{eenough ({\ident} :\ {\form}) by {\tac}}\tacindex{eenough}\tacindex{eenough as}\tacindex{eenough by}\\ + \texttt{eenough {\form} by {\tac}}\tacindex{enough by}\\ + \texttt{eenough {\form} as {\intropattern} by {\tac}} + + While the different variants of \texttt{enough} expect that no + existential variables are generated by the tactic, \texttt{eenough} + removes this constraint. + \item {\tt cut {\form}}\tacindex{cut} This tactic applies to any goal. It implements the non-dependent @@ -1337,12 +1384,16 @@ in the list of subgoals remaining to prove. quantifications or non-dependent implications) are instantiated by concrete terms coming either from arguments \term$_1$ $\ldots$ \term$_n$ or from a bindings list (see - Section~\ref{Binding-list} for more about bindings lists). In the - second form, all instantiation elements must be given, whereas - in the first form the application to \term$_1$ {\ldots} + Section~\ref{Binding-list} for more about bindings lists). + In the first form the application to \term$_1$ {\ldots} \term$_n$ can be partial. The first form is equivalent to {\tt assert ({\ident} := {\ident} {\term$_1$} \dots\ \term$_n$)}. + In the second form, instantiation elements can also be partial. + In this case the uninstantiated arguments are inferred by + unification if possible or left quantified in the hypothesis + otherwise. + With the {\tt as} clause, the local hypothesis {\ident} is left unchanged and instead, the modified hypothesis is introduced as specified by the {\intropattern}. diff --git a/engine/eConstr.ml b/engine/eConstr.ml index c0485e4e7..078f2fc33 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -45,6 +45,7 @@ val of_named_decl : (Constr.t, Constr.types) Context.Named.Declaration.pt -> (t, val unsafe_to_named_decl : (t, t) Context.Named.Declaration.pt -> (Constr.t, Constr.types) Context.Named.Declaration.pt val unsafe_to_rel_decl : (t, t) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, t) Context.Rel.Declaration.pt +val to_rel_decl : Evd.evar_map -> (t, t) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt end = struct @@ -131,6 +132,7 @@ let of_named_decl d = d let unsafe_to_named_decl d = d let of_rel_decl d = d let unsafe_to_rel_decl d = d +let to_rel_decl sigma d = Context.Rel.Declaration.map_constr (to_constr sigma) d end @@ -778,9 +780,11 @@ let lookup_named n e = cast_named_decl (sym unsafe_eq) (lookup_named n e) let lookup_named_val n e = cast_named_decl (sym unsafe_eq) (lookup_named_val n e) let fresh_global ?loc ?rigid ?names env sigma reference = - let Sigma.Sigma (t,sigma,p) = - Sigma.fresh_global ?loc ?rigid ?names env sigma reference in - Sigma.Sigma (of_constr t,sigma,p) + let (evd,t) = Evd.fresh_global ?loc ?rigid ?names env sigma reference in + evd, of_constr t + +let is_global sigma gr c = + Globnames.is_global gr (to_constr sigma c) module Unsafe = struct diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 9d705b4d5..07a4dc8e2 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -259,13 +259,17 @@ val lookup_named_val : variable -> named_context_val -> named_declaration (* XXX Missing Sigma proxy *) val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> - 'r Sigma.t -> Globnames.global_reference -> (t, 'r) Sigma.sigma + Evd.evar_map -> Globnames.global_reference -> Evd.evar_map * t + +val is_global : Evd.evar_map -> Globnames.global_reference -> t -> bool (** {5 Extra} *) val of_named_decl : (Constr.t, Constr.types) Context.Named.Declaration.pt -> (t, types) Context.Named.Declaration.pt val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, types) Context.Rel.Declaration.pt +val to_rel_decl : Evd.evar_map -> (t, types) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt + (** {5 Unsafe operations} *) module Unsafe : diff --git a/engine/engine.mllib b/engine/engine.mllib index 1b670d366..afc02d7f6 100644 --- a/engine/engine.mllib +++ b/engine/engine.mllib @@ -2,7 +2,6 @@ Logic_monad Universes UState Evd -Sigma EConstr Namegen Termops diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 6cba6f607..e8d184632 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -15,7 +15,6 @@ open Namegen open Pre_env open Environ open Evd -open Sigma.Notations module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -45,8 +44,8 @@ let e_new_global evdref x = EConstr.of_constr (evd_comb1 (Evd.fresh_global (Global.env())) evdref x) let new_global evd x = - let Sigma (c, sigma, p) = Sigma.fresh_global (Global.env()) evd x in - Sigma (EConstr.of_constr c, sigma, p) + let (evd, c) = Evd.fresh_global (Global.env()) evd x in + (evd, EConstr.of_constr c) (****************************************************) (* Expanding/testing/exposing existential variables *) @@ -220,7 +219,7 @@ let make_pure_subst evi args = (fun decl (args,l) -> match args with | a::rest -> (rest, (NamedDecl.get_id decl, a)::l) - | _ -> anomaly (Pp.str "Instance does not match its signature")) + | _ -> anomaly (Pp.str "Instance does not match its signature.")) (evar_filtered_context evi) (Array.rev_to_list args,[])) (*------------------------------------* @@ -367,21 +366,18 @@ let push_rel_context_to_named_context env sigma typ = let default_source = Loc.tag @@ Evar_kinds.InternalHole -let restrict_evar evd evk filter candidates = - let evd = Sigma.to_evar_map evd in +let restrict_evar evd evk filter ?src candidates = let candidates = Option.map (fun l -> List.map EConstr.Unsafe.to_constr l) candidates in - let evd, evk' = Evd.restrict evk filter ?candidates evd in - Sigma.Unsafe.of_pair (evk', Evd.declare_future_goal evk' evd) + let evd, evk' = Evd.restrict evk filter ?candidates ?src evd in + Evd.declare_future_goal evk' evd, evk' let new_pure_evar_full evd evi = - let evd = Sigma.to_evar_map evd in let (evd, evk) = Evd.new_evar evd evi in let evd = Evd.declare_future_goal evk evd in - Sigma.Unsafe.of_pair (evk, evd) + (evd, evk) let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ = let typ = EConstr.Unsafe.to_constr typ in - let evd = Sigma.to_evar_map evd in let candidates = Option.map (fun l -> List.map EConstr.Unsafe.to_constr l) candidates in let default_naming = Misctypes.IntroAnonymous in let naming = Option.default default_naming naming in @@ -407,19 +403,19 @@ let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?ca if principal then Evd.declare_principal_goal newevk evd else Evd.declare_future_goal newevk evd in - Sigma.Unsafe.of_pair (newevk, evd) + (evd, newevk) let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance = let open EConstr in assert (not !Flags.debug || List.distinct (ids_of_named_context (named_context_of_val sign))); - let Sigma (newevk, evd, p) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in - Sigma (mkEvar (newevk,Array.of_list instance), evd, p) + let (evd, newevk) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in + evd, mkEvar (newevk,Array.of_list instance) (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = - let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env (Sigma.to_evar_map evd) typ in + let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env evd typ in let map c = subst2 subst vsubst c in let candidates = Option.map (fun l -> List.map map l) candidates in let instance = @@ -428,27 +424,20 @@ let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = | Some filter -> Filter.filter_list filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance -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 new_type_evar env evd ?src ?filter ?naming ?principal rigid = - let Sigma (s, evd', p) = Sigma.new_sort_variable rigid evd in - let Sigma (e, evd', q) = new_evar env evd' ?src ?filter ?naming ?principal (EConstr.mkSort s) in - Sigma ((e, s), evd', p +> q) + let (evd', s) = new_sort_variable rigid evd in + let (evd', e) = new_evar env evd' ?src ?filter ?naming ?principal (EConstr.mkSort s) in + evd', (e, s) let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid = - let sigma = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (c, sigma, _) = new_type_evar env sigma ?src ?filter ?naming ?principal rigid in - let sigma = Sigma.to_evar_map sigma in - evdref := sigma; + let (evd, c) = new_type_evar env !evdref ?src ?filter ?naming ?principal rigid in + evdref := evd; c let new_Type ?(rigid=Evd.univ_flexible) env evd = let open EConstr in - let Sigma (s, sigma, p) = Sigma.new_sort_variable rigid evd in - Sigma (mkSort s, sigma, p) + let (evd, s) = new_sort_variable rigid evd in + (evd, mkSort s) let e_new_Type ?(rigid=Evd.univ_flexible) env evdref = let evd', s = new_sort_variable rigid !evdref in @@ -456,7 +445,7 @@ let e_new_Type ?(rigid=Evd.univ_flexible) env evdref = (* The same using side-effect *) let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty = - let (evd',ev) = new_evar_unsafe env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in + let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in evdref := evd'; ev @@ -552,9 +541,8 @@ let rec check_and_clear_in_constr env evdref err ids global c = else let origfilter = Evd.evar_filter evi in let filter = Evd.Filter.apply_subfilter origfilter filter in - let evd = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (_, evd, _) = restrict_evar evd evk filter None in - let evd = Sigma.to_evar_map evd in + let evd = !evdref in + let (evd,_) = restrict_evar evd evk filter None in evdref := evd; (* spiwack: hacking session to mark the old [evk] as having been "cleared" *) let evi = Evd.find !evdref evk in @@ -723,8 +711,8 @@ let occur_evar_upto sigma n c = let judge_of_new_Type evd = let open EConstr in - let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in - Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p) + let (evd', s) = new_univ_variable univ_rigid evd in + (evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }) let subterm_source evk (loc,k) = let evk = match k with diff --git a/engine/evarutil.mli b/engine/evarutil.mli index fcc435a2e..90c5c3dc0 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -22,18 +22,18 @@ val mk_new_meta : unit -> constr (** {6 Creating a fresh evar given their type and context} *) val new_evar : - env -> 'r Sigma.t -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + env -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> (constr, 'r) Sigma.sigma + ?principal:bool -> types -> evar_map * EConstr.t val new_pure_evar : - named_context_val -> 'r Sigma.t -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + named_context_val -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> (evar, 'r) Sigma.sigma + ?principal:bool -> types -> evar_map * evar -val new_pure_evar_full : 'r Sigma.t -> evar_info -> (evar, 'r) Sigma.sigma +val new_pure_evar_full : evar_map -> evar_info -> evar_map * evar (** the same with side-effects *) val e_new_evar : @@ -45,23 +45,23 @@ val e_new_evar : (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : - env -> 'r Sigma.t -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + env -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> - (constr * sorts, 'r) Sigma.sigma + evar_map * (constr * sorts) val e_new_type_evar : env -> evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts -val new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma +val new_Type : ?rigid:rigid -> env -> evar_map -> evar_map * constr val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr -val restrict_evar : 'r Sigma.t -> existential_key -> Filter.t -> - constr list option -> (existential_key, 'r) Sigma.sigma +val restrict_evar : evar_map -> existential_key -> Filter.t -> + ?src:Evar_kinds.t Loc.located -> constr list option -> evar_map * existential_key (** Polymorphic constants *) -val new_global : 'r Sigma.t -> Globnames.global_reference -> (constr, 'r) Sigma.sigma +val new_global : evar_map -> Globnames.global_reference -> evar_map * constr val e_new_global : evar_map ref -> Globnames.global_reference -> constr (** Create a fresh evar in a context different from its definition context: @@ -71,11 +71,11 @@ val e_new_global : evar_map ref -> Globnames.global_reference -> constr of [inst] are typed in the occurrence context and their type (seen as a telescope) is [sign] *) val new_evar_instance : - named_context_val -> 'r Sigma.t -> types -> + named_context_val -> evar_map -> types -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> - constr list -> (constr, 'r) Sigma.sigma + constr list -> evar_map * constr val make_pure_subst : evar_info -> 'a array -> (Id.t * 'a) list @@ -133,7 +133,7 @@ val occur_evar_upto : evar_map -> Evar.t -> constr -> bool (** {6 Value/Type constraints} *) -val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma +val judge_of_new_Type : evar_map -> evar_map * unsafe_judgment (***********************************************************) diff --git a/engine/evd.ml b/engine/evd.ml index b677705bc..08d26f40d 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -155,7 +155,7 @@ let make_evar hyps ccl = { } let instance_mismatch () = - anomaly (Pp.str "Signature and its instance do not match") + anomaly (Pp.str "Signature and its instance do not match.") let evar_concl evi = evi.evar_concl @@ -400,7 +400,7 @@ let rename evk id (evtoid, idtoev) = match id' with | None -> (EvMap.add evk id evtoid, Idmap.add id evk idtoev) | Some id' -> - if Idmap.mem id idtoev then anomaly (str "Evar name already in use"); + if Idmap.mem id idtoev then anomaly (str "Evar name already in use."); (EvMap.update evk id evtoid (* overwrite old name *), Idmap.add id evk (Idmap.remove id' idtoev)) let reassign_name_defined evk evk' (evtoid, idtoev as names) = @@ -553,7 +553,7 @@ let existential_type d (n, args) = let info = try find d n with Not_found -> - anomaly (str "Evar " ++ str (string_of_existential n) ++ str " was not declared") in + anomaly (str "Evar " ++ str (string_of_existential n) ++ str " was not declared.") in instantiate_evar_array info info.evar_concl args let add_constraints d c = @@ -635,9 +635,9 @@ let define_aux def undef evk body = try EvMap.find evk undef with Not_found -> if EvMap.mem evk def then - anomaly ~label:"Evd.define" (Pp.str "cannot define an evar twice") + anomaly ~label:"Evd.define" (Pp.str "cannot define an evar twice.") else - anomaly ~label:"Evd.define" (Pp.str "cannot define undeclared evar") + anomaly ~label:"Evd.define" (Pp.str "cannot define undeclared evar.") in let () = assert (oldinfo.evar_body == Evar_empty) in let newinfo = { oldinfo with evar_body = Evar_defined body } in @@ -653,12 +653,13 @@ let define evk body evd = let evar_names = EvNames.remove_name_defined evk evd.evar_names in { evd with defn_evars; undf_evars; last_mods; evar_names } -let restrict evk filter ?candidates evd = +let restrict evk filter ?candidates ?src evd = let evk' = new_untyped_evar () in let evar_info = EvMap.find evk evd.undf_evars in let evar_info' = { evar_info with evar_filter = filter; evar_candidates = candidates; + evar_source = (match src with None -> evar_info.evar_source | Some src -> src); evar_extra = Store.empty } in let last_mods = match evd.conv_pbs with | [] -> evd.last_mods @@ -1021,7 +1022,7 @@ let try_meta_fvalue evd mv = let meta_fvalue evd mv = try try_meta_fvalue evd mv - with Not_found -> anomaly ~label:"meta_fvalue" (Pp.str "meta has no value") + with Not_found -> anomaly ~label:"meta_fvalue" (Pp.str "meta has no value.") let meta_value evd mv = (fst (try_meta_fvalue evd mv)).rebus @@ -1040,7 +1041,7 @@ let meta_declare mv v ?(name=Anonymous) evd = let meta_assign mv (v, pb) evd = let modify _ = function | Cltyp (na, ty) -> Clval (na, (mk_freelisted v, pb), ty) - | _ -> anomaly ~label:"meta_assign" (Pp.str "already defined") + | _ -> anomaly ~label:"meta_assign" (Pp.str "already defined.") in let metas = Metamap.modify mv modify evd.metas in set_metas evd metas @@ -1048,7 +1049,7 @@ let meta_assign mv (v, pb) evd = let meta_reassign mv (v, pb) evd = let modify _ = function | Clval(na, _, ty) -> Clval (na, (mk_freelisted v, pb), ty) - | _ -> anomaly ~label:"meta_reassign" (Pp.str "not yet defined") + | _ -> anomaly ~label:"meta_reassign" (Pp.str "not yet defined.") in let metas = Metamap.modify mv modify evd.metas in set_metas evd metas @@ -1089,7 +1090,7 @@ let dependent_evar_ident ev evd = let evi = find evd ev in match evi.evar_source with | (_,Evar_kinds.VarInstance id) -> id - | _ -> anomaly (str "Not an evar resulting of a dependent binding") + | _ -> anomaly (str "Not an evar resulting of a dependent binding.") (**********************************************************) (* Extra data *) diff --git a/engine/evd.mli b/engine/evd.mli index 005332470..86755c360 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -240,7 +240,7 @@ val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> (** {6 Misc} *) val restrict : evar -> Filter.t -> ?candidates:constr list -> - evar_map -> evar_map * evar + ?src:Evar_kinds.t located -> evar_map -> evar_map * evar (** Restrict an undefined evar into a new evar by filtering context and possibly limiting the instances to a set of candidates *) diff --git a/engine/ftactic.ml b/engine/ftactic.ml index aeaaea7e4..68368e38f 100644 --- a/engine/ftactic.ml +++ b/engine/ftactic.ml @@ -53,31 +53,17 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function Proofview.tclUNIT (Depends filtered) let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) -let set_sigma r = - let Sigma.Sigma (ans, sigma, _) = r in - Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> ans let nf_enter f = bind goals (fun gl -> gl >>= fun gl -> Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> f.enter nfgl)) - -let nf_s_enter f = - bind goals - (fun gl -> - gl >>= fun gl -> - Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter nfgl))) + Proofview.V82.wrap_exceptions (fun () -> f nfgl)) let enter f = bind goals - (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f.enter gl)) - -let s_enter f = - bind goals - (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter gl))) + (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f gl)) let with_env t = t >>= function diff --git a/engine/ftactic.mli b/engine/ftactic.mli index 5db373199..97bebe9da 100644 --- a/engine/ftactic.mli +++ b/engine/ftactic.mli @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Proofview.Notations - (** This module defines potentially focussing tactics. They are used by Ltac to emulate the historical behaviour of always-focussed tactics while still allowing to remain global when the goal is not needed. *) @@ -41,20 +39,13 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** {5 Focussing} *) -val nf_enter : ([ `NF ], 'a t) enter -> 'a t +val nf_enter : ([ `NF ] Proofview.Goal.t -> 'a t) -> 'a t (** Enter a goal. The resulting tactic is focussed. *) -val enter : ([ `LZ ], 'a t) enter -> 'a t +val enter : ([ `LZ ] Proofview.Goal.t -> 'a t) -> 'a t (** Enter a goal, without evar normalization. The resulting tactic is focussed. *) -val s_enter : ([ `LZ ], 'a t) s_enter -> 'a t -(** Enter a goal and put back an evarmap. The resulting tactic is focussed. *) - -val nf_s_enter : ([ `NF ], 'a t) s_enter -> 'a t -(** Enter a goal, without evar normalization and put back an evarmap. The - resulting tactic is focussed. *) - val with_env : 'a t -> (Environ.env*'a) t (** [with_env t] returns, in addition to the return type of [t], an environment, which is the global environment if [t] does not focus on diff --git a/engine/proofview.ml b/engine/proofview.ml index ddfc0e39d..39ef65dab 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -16,7 +16,6 @@ open Pp open Util open Proofview_monad -open Sigma.Notations open Context.Named.Declaration (** Main state of tactics *) @@ -71,10 +70,8 @@ let dependent_init = let rec aux = function | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } | TCons (env, sigma, typ, t) -> - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in - let (gl, _) = EConstr.destEvar (Sigma.to_evar_map sigma) econstr in - let sigma = Sigma.to_evar_map sigma in + let (sigma, econstr) = Evarutil.new_evar env sigma ~src ~store typ in + let (gl, _) = EConstr.destEvar sigma econstr in let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in let entry = (econstr, typ) :: ret in entry, { solution = sol; comb = gl :: comb; shelf = [] } @@ -696,6 +693,12 @@ let mark_in_evm ~goal evd content = let info = if goal then { info with Evd.evar_source = match info.Evd.evar_source with + (* Two kinds for goal evars: + - GoalEvar (morally not dependent) + - VarInstance (morally dependent of some name). + This is a heuristic for naming these evars. *) + | loc, (Evar_kinds.QuestionMark (_,Names.Name id) | + Evar_kinds.ImplicitArg (_,(_,Some id),_)) -> loc, Evar_kinds.VarInstance id | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x | loc,_ -> loc,Evar_kinds.GoalEvar } else info @@ -1006,20 +1009,17 @@ let catchable_exception = function module Goal = struct - type ('a, 'r) t = { + type 'a t = { env : Environ.env; sigma : Evd.evar_map; concl : EConstr.constr ; self : Evar.t ; (* for compatibility with old-style definitions *) } - type ('a, 'b) enter = - { enter : 'r. ('a, 'r) t -> 'b } - - let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t) + let assume (gl : 'a t) = (gl :> [ `NF ] t) let env {env} = env - let sigma {sigma} = Sigma.Unsafe.of_evar_map sigma + let sigma {sigma} = sigma let hyps {env} = EConstr.named_context env let concl {concl} = concl let extra {sigma; self} = goal_extra sigma self @@ -1042,7 +1042,7 @@ module Goal = struct tclEVARMAP >>= fun sigma -> try let (gl, sigma) = nf_gmake env sigma goal in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl)) + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f gl)) with e when catchable_exception e -> let (e, info) = CErrors.push e in tclZERO ~info e @@ -1060,7 +1060,7 @@ module Goal = struct gmake_with info env sigma goal let enter f = - let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in + let f gl = InfoL.tag (Info.DBranch) (f gl) in InfoL.tag (Info.Dispatch) begin iter_goal begin fun goal -> Env.get >>= fun env -> @@ -1085,48 +1085,13 @@ module Goal = struct | [goal] -> begin Env.get >>= fun env -> tclEVARMAP >>= fun sigma -> - try f.enter (gmake env sigma goal) + try f (gmake env sigma goal) with e when catchable_exception e -> let (e, info) = CErrors.push e in tclZERO ~info e end | _ -> tclZERO NotExactlyOneSubgoal - type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } - - let s_enter f = - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try - let gl = gmake env sigma goal in - let Sigma (tac, sigma, _) = f.s_enter gl in - let sigma = Sigma.to_evar_map sigma in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) - with e when catchable_exception e -> - let (e, info) = CErrors.push e in - tclZERO ~info e - end - end - - let nf_s_enter f = - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try - let (gl, sigma) = nf_gmake env sigma goal in - let Sigma (tac, sigma, _) = f.s_enter gl in - let sigma = Sigma.to_evar_map sigma in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) - with e when catchable_exception e -> - let (e, info) = CErrors.push e in - tclZERO ~info e - end - end - let goals = Pv.get >>= fun step -> let sigma = step.solution in @@ -1150,8 +1115,6 @@ module Goal = struct (* compatibility *) let goal { self=self } = self - let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t) - end @@ -1275,8 +1238,4 @@ module Notations = struct let (>>=) = tclBIND let (<*>) = tclTHEN let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) - type ('a, 'b) enter = ('a, 'b) Goal.enter = - { enter : 'r. ('a, 'r) Goal.t -> 'b } - type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } end diff --git a/engine/proofview.mli b/engine/proofview.mli index da8a8fecd..aae25b6f8 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -469,67 +469,48 @@ module Goal : sig data using {!assume} if you known you do not rely on the assumption of being normalized, at your own risk. - The second parameter is a stage indicating where the goal belongs. See - module {!Sigma}. *) - type ('a, 'r) t + type 'a t (** Assume that you do not need the goal to be normalized. *) - val assume : ('a, 'r) t -> ([ `NF ], 'r) t + val assume : 'a t -> [ `NF ] t (** Normalises the argument goal. *) - val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic + val normalize : 'a t -> [ `NF ] t tactic (** [concl], [hyps], [env] and [sigma] given a goal [gl] return respectively the conclusion of [gl], the hypotheses of [gl], the environment of [gl] (i.e. the global environment and the hypotheses) and the current evar map. *) - val concl : ('a, 'r) t -> constr - val hyps : ('a, 'r) t -> named_context - val env : ('a, 'r) t -> Environ.env - val sigma : ('a, 'r) t -> 'r Sigma.t - val extra : ('a, 'r) t -> Evd.Store.t - - type ('a, 'b) enter = - { enter : 'r. ('a, 'r) t -> 'b } + val concl : 'a t -> constr + val hyps : 'a t -> named_context + val env : 'a t -> Environ.env + val sigma : 'a t -> Evd.evar_map + val extra : 'a t -> Evd.Store.t (** [nf_enter t] applies the goal-dependent tactic [t] in each goal independently, in the manner of {!tclINDEPENDENT} except that the current goal is also given as an argument to [t]. The goal is normalised with respect to evars. *) - val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic + val nf_enter : ([ `NF ] t -> unit tactic) -> unit tactic (** Like {!nf_enter}, but does not normalize the goal beforehand. *) - val enter : ([ `LZ ], unit tactic) enter -> unit tactic + val enter : ([ `LZ ] t -> unit tactic) -> unit tactic (** Like {!enter}, but assumes exactly one goal under focus, raising *) (** an error otherwise. *) - val enter_one : ([ `LZ ], 'a tactic) enter -> 'a tactic - - type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } - - (** A variant of {!enter} allows to work with a monotonic state. The evarmap - returned by the argument is put back into the current state before firing - the returned tactic. *) - val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic - - (** Like {!s_enter}, but normalizes the goal beforehand. *) - val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic + val enter_one : ([ `LZ ] t -> 'a tactic) -> 'a tactic (** Recover the list of current goals under focus, without evar-normalization. FIXME: encapsulate the level in an existential type. *) - val goals : ([ `LZ ], 'r) t tactic list tactic + val goals : [ `LZ ] t tactic list tactic (** [unsolved g] is [true] if [g] is still unsolved in the current proof state. *) - val unsolved : ('a, 'r) t -> bool tactic + val unsolved : 'a t -> bool tactic (** Compatibility: avoid if possible *) - val goal : ([ `NF ], 'r) t -> Evar.t - - (** Every goal is valid at a later stage. FIXME: take a later evarmap *) - val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t + val goal : [ `NF ] t -> Evar.t end @@ -616,8 +597,4 @@ module Notations : sig (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - type ('a, 'b) enter = ('a, 'b) Goal.enter = - { enter : 'r. ('a, 'r) Goal.t -> 'b } - type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } end diff --git a/engine/sigma.ml b/engine/sigma.ml deleted file mode 100644 index 001f8be80..000000000 --- a/engine/sigma.ml +++ /dev/null @@ -1,117 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -type 'a t = Evd.evar_map - -type ('a, 'b) le = unit - -let refl = () -let cons _ _ = () -let (+>) = fun _ _ -> () - -type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma - -type 'a evar = Evar.t - -let lift_evar evk () = evk - -let to_evar_map evd = evd -let to_evar evk = evk - -let here x s = Sigma (x, s, ()) - -(** API *) - -type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh - -let new_evar sigma ?name info = - let (sigma, evk) = Evd.new_evar sigma ?name info in - Fresh (evk, sigma, ()) - -let define evk c sigma = - Sigma ((), Evd.define evk c sigma, ()) - -let new_univ_level_variable ?loc ?name rigid sigma = - let (sigma, u) = Evd.new_univ_level_variable ?loc ?name rigid sigma in - Sigma (u, sigma, ()) - -let new_univ_variable ?loc ?name rigid sigma = - let (sigma, u) = Evd.new_univ_variable ?loc ?name rigid sigma in - Sigma (u, sigma, ()) - -let new_sort_variable ?loc ?name rigid sigma = - let (sigma, u) = Evd.new_sort_variable ?loc ?name rigid sigma in - Sigma (u, sigma, ()) - -let fresh_sort_in_family ?loc ?rigid env sigma s = - let (sigma, s) = Evd.fresh_sort_in_family ?loc ?rigid env sigma s in - Sigma (s, sigma, ()) - -let fresh_constant_instance ?loc env sigma cst = - let (sigma, cst) = Evd.fresh_constant_instance ?loc env sigma cst in - Sigma (cst, sigma, ()) - -let fresh_inductive_instance ?loc env sigma ind = - let (sigma, ind) = Evd.fresh_inductive_instance ?loc env sigma ind in - Sigma (ind, sigma, ()) - -let fresh_constructor_instance ?loc env sigma pc = - let (sigma, c) = Evd.fresh_constructor_instance ?loc env sigma pc in - Sigma (c, sigma, ()) - -let fresh_global ?loc ?rigid ?names env sigma r = - let (sigma, c) = Evd.fresh_global ?loc ?rigid ?names env sigma r in - Sigma (c, sigma, ()) - -(** Run *) - -type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } - -let run sigma f : 'a * Evd.evar_map = - let Sigma (x, sigma, ()) = f.run sigma in - (x, sigma) - -(** Monotonic references *) - -type evdref = Evd.evar_map ref - -let apply evdref f = - let Sigma (x, sigma, ()) = f.run !evdref in - evdref := sigma; - x - -let purify f = - let f (sigma : Evd.evar_map) = - let evdref = ref sigma in - let ans = f evdref in - Sigma (ans, !evdref, ()) - in - { run = f } - -(** Unsafe primitives *) - -module Unsafe = -struct - -let le = () -let of_evar_map sigma = sigma -let of_evar evk = evk -let of_ref ref = ref -let of_pair (x, sigma) = Sigma (x, sigma, ()) - -end - -module Notations = -struct - type ('a, 'r) sigma_ = ('a, 'r) sigma = - Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_ - - let (+>) = fun _ _ -> () - - type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } -end diff --git a/engine/sigma.mli b/engine/sigma.mli deleted file mode 100644 index 8e8df02f2..000000000 --- a/engine/sigma.mli +++ /dev/null @@ -1,131 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Names -open Constr - -(** Monotonous state enforced by typing. - - This module allows to constrain uses of evarmaps in a monotonous fashion, - and in particular statically suppress evar leaks and the like. To this - ends, it defines a type of indexed evarmaps whose phantom typing ensures - monotonous use. -*) - -(** {5 Stages} *) - -type ('a, 'b) le -(** Relationship stating that stage ['a] is anterior to stage ['b] *) - -val refl : ('a, 'a) le -(** Reflexivity of anteriority *) - -val cons : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le -(** Transitivity of anteriority *) - -val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le -(** Alias for {!cons} *) - -(** {5 Monotonous evarmaps} *) - -type 'r t -(** Stage-indexed evarmaps. This is just a plain evarmap with a phantom type. *) - -type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma -(** Return values at a later stage *) - -type 'r evar -(** Stage-indexed evars *) - -(** {5 Constructors} *) - -val here : 'a -> 'r t -> ('a, 'r) sigma -(** [here x s] is a shorthand for [Sigma (x, s, refl)] *) - -(** {5 Postponing} *) - -val lift_evar : 'r evar -> ('r, 's) le -> 's evar -(** Any evar existing at stage ['r] is also valid at any later stage. *) - -(** {5 Downcasting} *) - -val to_evar_map : 'r t -> Evd.evar_map -val to_evar : 'r evar -> Evar.t - -(** {5 Monotonous API} *) - -type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh - -val new_evar : 'r t -> ?name:Id.t -> - Evd.evar_info -> 'r fresh - -val define : 'r evar -> Constr.t -> 'r t -> (unit, 'r) sigma - -(** Polymorphic universes *) - -val new_univ_level_variable : ?loc:Loc.t -> ?name:string -> - Evd.rigid -> 'r t -> (Univ.universe_level, 'r) sigma -val new_univ_variable : ?loc:Loc.t -> ?name:string -> - Evd.rigid -> 'r t -> (Univ.universe, 'r) sigma -val new_sort_variable : ?loc:Loc.t -> ?name:string -> - Evd.rigid -> 'r t -> (Sorts.t, 'r) sigma - -val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:Evd.rigid -> Environ.env -> - 'r t -> Term.sorts_family -> (Term.sorts, 'r) sigma -val fresh_constant_instance : - ?loc:Loc.t -> Environ.env -> 'r t -> constant -> (pconstant, 'r) sigma -val fresh_inductive_instance : - ?loc:Loc.t -> Environ.env -> 'r t -> inductive -> (pinductive, 'r) sigma -val fresh_constructor_instance : ?loc:Loc.t -> Environ.env -> 'r t -> constructor -> - (pconstructor, 'r) sigma - -val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> - 'r t -> Globnames.global_reference -> (constr, 'r) sigma - -(** FILLME *) - -(** {5 Run} *) - -type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } - -val run : Evd.evar_map -> 'a run -> 'a * Evd.evar_map - -(** {5 Imperative monotonic functions} *) - -type evdref -(** Monotonic references over evarmaps *) - -val apply : evdref -> 'a run -> 'a -(** Apply a monotonic function on a reference. *) - -val purify : (evdref -> 'a) -> 'a run -(** Converse of {!apply}. *) - -(** {5 Unsafe primitives} *) - -module Unsafe : -sig - val le : ('a, 'b) le - val of_evar_map : Evd.evar_map -> 'r t - val of_evar : Evd.evar -> 'r evar - val of_ref : Evd.evar_map ref -> evdref - val of_pair : ('a * Evd.evar_map) -> ('a, 'r) sigma -end - -(** {5 Notations} *) - -module Notations : -sig - type ('a, 'r) sigma_ = ('a, 'r) sigma = - Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_ - - type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } - - val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le - (** Alias for {!cons} *) -end diff --git a/engine/termops.ml b/engine/termops.ml index ca32c06a7..92016d4af 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -31,10 +31,6 @@ let pr_sort_family = function | InProp -> (str "Prop") | InType -> (str "Type") -let pr_name = function - | Name id -> pr_id id - | Anonymous -> str "_" - let pr_con sp = str(string_of_con sp) let pr_fix pr_constr ((t,i),(lna,tl,bl)) = @@ -42,7 +38,7 @@ let pr_fix pr_constr ((t,i),(lna,tl,bl)) = hov 1 (str"fix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,i,ty,bd) -> - pr_name na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++ + Name.print na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++ cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") @@ -65,10 +61,10 @@ let rec pr_constr c = match kind_of_term c with (str"(" ++ pr_constr t ++ str " ->" ++ spc() ++ pr_constr c ++ str")") | Lambda (na,t,c) -> hov 1 - (str"fun " ++ pr_name na ++ str":" ++ + (str"fun " ++ Name.print na ++ str":" ++ pr_constr t ++ str" =>" ++ spc() ++ pr_constr c) | LetIn (na,b,t,c) -> hov 0 - (str"let " ++ pr_name na ++ str":=" ++ pr_constr b ++ + (str"let " ++ Name.print na ++ str":=" ++ pr_constr b ++ str":" ++ brk(1,2) ++ pr_constr t ++ cut() ++ pr_constr c) | App (c,l) -> hov 1 @@ -93,7 +89,7 @@ let rec pr_constr c = match kind_of_term c with hov 1 (str"cofix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,ty,bd) -> - pr_name na ++ str":" ++ pr_constr ty ++ + Name.print na ++ str":" ++ pr_constr ty ++ cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") @@ -112,6 +108,7 @@ let pr_evar_suggested_name evk sigma = | None -> match evi.evar_source with | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id | _,Evar_kinds.VarInstance id -> id + | _,Evar_kinds.QuestionMark (_,Name id) -> id | _,Evar_kinds.GoalEvar -> Id.of_string "Goal" | _ -> let env = reset_with_named_context evi.evar_hyps (Global.env()) in @@ -308,8 +305,8 @@ let pr_evar_universe_context ctx = let print_env_short env = let print_constr = print_kconstr 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 ")" + | RelDecl.LocalAssum (n,_) -> Name.print n + | RelDecl.LocalDef (n,b,_) -> str "(" ++ Name.print 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 @@ -506,7 +503,7 @@ let push_named_rec_types (lna,typarray,_) env = (fun i na t -> match na with | Name id -> LocalAssum (id, lift i t) - | Anonymous -> anomaly (Pp.str "Fix declarations must be named")) + | Anonymous -> anomaly (Pp.str "Fix declarations must be named.")) lna typarray in Array.fold_left (fun e assum -> push_named assum e) env ctxt @@ -582,7 +579,7 @@ let rec drop_extra_implicit_args sigma c = match EConstr.kind sigma c with (* Get the last arg of an application *) let last_arg sigma c = match EConstr.kind sigma c with | App (f,cl) -> Array.last cl - | _ -> anomaly (Pp.str "last_arg") + | _ -> anomaly (Pp.str "last_arg.") (* Get the last arg of an application *) let decompose_app_vect sigma c = @@ -1289,7 +1286,7 @@ let rec eta_reduce_head sigma c = (match EConstr.kind sigma (eta_reduce_head sigma c') with | App (f,cl) -> let lastn = (Array.length cl) - 1 in - if lastn < 0 then anomaly (Pp.str "application without arguments") + if lastn < 0 then anomaly (Pp.str "application without arguments.") else (match EConstr.kind sigma cl.(lastn) with | Rel 1 -> @@ -1442,7 +1439,7 @@ let prod_applist sigma c l = match EConstr.kind sigma c, l with | Prod(_,_,c), arg::l -> app (arg::subst) c l | _, [] -> Vars.substl subst c - | _ -> anomaly (Pp.str "Not enough prod's") in + | _ -> anomaly (Pp.str "Not enough prod's.") in app [] c l (* Combinators on judgments *) @@ -1458,7 +1455,7 @@ let context_chop k ctx = | (0, l2) -> (List.rev acc, l2) | (n, (RelDecl.LocalDef _ as h)::t) -> chop_aux (h::acc) (n, t) | (n, (h::t)) -> chop_aux (h::acc) (pred n, t) - | (_, []) -> anomaly (Pp.str "context_chop") + | (_, []) -> anomaly (Pp.str "context_chop.") in chop_aux [] (k,ctx) (* Do not skip let-in's *) diff --git a/engine/universes.ml b/engine/universes.ml index 1900112dd..f20108186 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -101,7 +101,7 @@ let enforce_eq_instances_univs strict x y c = let ax = Instance.to_array x and ay = Instance.to_array y in if Array.length ax != Array.length ay then CErrors.anomaly (Pp.str "Invalid argument: enforce_eq_instances_univs called with" ++ - Pp.str " instances of different lengths"); + Pp.str " instances of different lengths."); CArray.fold_right2 (fun x y -> Constraints.add (Universe.make x, d, Universe.make y)) ax ay c diff --git a/grammar/argextend.mlp b/grammar/argextend.mlp index c736e1a74..5068ba8a6 100644 --- a/grammar/argextend.mlp +++ b/grammar/argextend.mlp @@ -137,11 +137,11 @@ let declare_tactic_argument loc s (typ, f, g, h) cl = let typ = match globtyp with None -> ExtraArgType s | Some typ -> typ in <:expr< let f = $lid:f$ in - fun ist v -> Ftactic.nf_s_enter { Proofview.Goal.s_enter = fun gl -> + fun ist v -> Ftactic.nf_enter (fun gl -> let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in let v = Geninterp.Val.inject (Geninterp.val_tag $make_topwit loc typ$) v in - Sigma.Unsafe.of_pair (Ftactic.return v, sigma) - } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return v) + ) >> in let subst = match h with | None -> @@ -188,8 +188,8 @@ let declare_vernac_argument loc s pr cl = <:str_item< do { Pptactic.declare_extra_genarg_pprule $wit$ $pr_rules$ - (fun _ _ _ _ -> CErrors.anomaly (Pp.str "vernac argument needs not globwit printer")) - (fun _ _ _ _ -> CErrors.anomaly (Pp.str "vernac argument needs not wit printer")) } + (fun _ _ _ _ -> CErrors.anomaly (Pp.str "vernac argument needs not globwit printer.")) + (fun _ _ _ _ -> CErrors.anomaly (Pp.str "vernac argument needs not wit printer.")) } >> ] open Pcaml diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 4e613f163..9c771cbef 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -357,7 +357,7 @@ let handle_exn (e, info) = let init = let initialized = ref false in fun file -> - if !initialized then anomaly (str "Already initialized") + if !initialized then anomaly (str "Already initialized.") else begin let init_sid = Stm.get_current_state () in initialized := true; diff --git a/ide/ideutils.ml b/ide/ideutils.ml index a08ab07b5..8a0e507c0 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -422,7 +422,7 @@ let browse prerr url = let doc_url () = if doc_url#get = use_default_doc_url || doc_url#get = "" then - let addr = List.fold_left Filename.concat (Coq_config.docdir) + let addr = List.fold_left Filename.concat (Envars.docdir ()) ["html";"refman";"index.html"] in if Sys.file_exists addr then "file://"^addr else Coq_config.wwwrefman diff --git a/ide/minilib.ml b/ide/minilib.ml index 2c24e46f8..2b278fac6 100644 --- a/ide/minilib.ml +++ b/ide/minilib.ml @@ -54,12 +54,12 @@ let coqide_config_home () = let coqide_data_dirs () = coqify (Glib.get_user_data_dir ()) :: List.map coqify (Glib.get_system_data_dirs ()) - @ Option.List.cons Coq_config.datadir [] + @ [Envars.datadir ()] let coqide_config_dirs () = coqide_config_home () :: List.map coqify (Glib.get_system_config_dirs ()) - @ Option.List.cons Coq_config.configdir [] + @ [Envars.configdir ()] let is_prefix_of pre s = let i = ref 0 in diff --git a/ide/preferences.ml b/ide/preferences.ml index 9fe9c6337..08739d013 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -643,6 +643,10 @@ let pmodifiers ?(all = false) name p = modifiers name (str_to_mod_list p#get) +[@@@ocaml.warning "-3"] (* String.uppercase_ascii since 4.03.0 GPR#124 *) +let uppercase = String.uppercase +[@@@ocaml.warning "+3"] + let configure ?(apply=(fun () -> ())) () = let cmd_coqtop = string @@ -918,7 +922,7 @@ let configure ?(apply=(fun () -> ())) () = in let doc_url = let predefined = [ - "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["refman";"html"]); + "file://"^(List.fold_left Filename.concat (Envars.docdir ()) ["refman";"html"]); Coq_config.wwwrefman; use_default_doc_url ] in @@ -931,7 +935,7 @@ let configure ?(apply=(fun () -> ())) () = doc_url#get in let library_url = let predefined = [ - "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["stdlib";"html"]); + "file://"^(List.fold_left Filename.concat (Envars.docdir ()) ["stdlib";"html"]); Coq_config.wwwstdlib ] in combo @@ -969,7 +973,7 @@ let configure ?(apply=(fun () -> ())) () = let k = if Int.equal (CString.length k) 1 && Util.is_letter k.[0] then k else "" in - let k = CString.uppercase k in + let k = uppercase k in [q, k] in diff --git a/ide/texmacspp.ml b/ide/texmacspp.ml deleted file mode 100644 index ddb62313f..000000000 --- a/ide/texmacspp.ml +++ /dev/null @@ -1,769 +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 Xml_datatype -open Vernacexpr -open Constrexpr -open Names -open Misctypes -open Bigint -open Decl_kinds -open Extend -open Libnames -open Constrexpr_ops - -let unlock ?loc = - let start, stop = Option.cata Loc.unloc (0,0) loc in - (string_of_int start, string_of_int stop) - -let xmlWithLoc ?loc ename attr xml = - let start, stop = unlock ?loc in - Element(ename, [ "begin", start; "end", stop ] @ attr, xml) - -let get_fst_attr_in_xml_list attr xml_list = - let attrs_list = - List.map (function - | Element (_, attrs, _) -> (List.filter (fun (a,_) -> a = attr) attrs) - | _ -> []) - xml_list in - match List.flatten attrs_list with - | [] -> (attr, "") - | l -> (List.hd l) - -let backstep_loc xmllist = - let start_att = get_fst_attr_in_xml_list "begin" xmllist in - let stop_att = get_fst_attr_in_xml_list "end" (List.rev xmllist) in - [start_att ; stop_att] - -let compare_begin_att xml1 xml2 = - let att1 = get_fst_attr_in_xml_list "begin" [xml1] in - let att2 = get_fst_attr_in_xml_list "begin" [xml2] in - match att1, att2 with - | (_, s1), (_, s2) when s1 == "" || s2 == "" -> 0 - | (_, s1), (_, s2) when int_of_string s1 > int_of_string s2 -> 1 - | (_, s1), (_, s2) when int_of_string s1 < int_of_string s2 -> -1 - | _ -> 0 - -let xmlBeginSection ?loc name = xmlWithLoc ?loc "beginsection" ["name", name] [] - -let xmlEndSegment ?loc name = xmlWithLoc ?loc "endsegment" ["name", name] [] - -let xmlThm ?loc typ name xml = - xmlWithLoc ?loc "theorem" ["type", typ; "name", name] xml - -let xmlDef ?loc typ name xml = - xmlWithLoc ?loc "definition" ["type", typ; "name", name] xml - -let xmlNotation ?loc attr name xml = - xmlWithLoc ?loc "notation" (("name", name) :: attr) xml - -let xmlReservedNotation ?loc attr name = - xmlWithLoc ?loc "reservednotation" (("name", name) :: attr) [] - -let xmlCst ?loc ?(attr=[]) name = - xmlWithLoc ?loc "constant" (("name", name) :: attr) [] - -let xmlOperator ?loc ?(attr=[]) ?(pprules=[]) name = - xmlWithLoc ?loc "operator" - (("name", name) :: List.map (fun (a,b) -> "format"^a,b) pprules @ attr) [] - -let xmlApply ?loc ?(attr=[]) xml = xmlWithLoc ?loc "apply" attr xml - -let xmlToken ?loc ?(attr=[]) xml = xmlWithLoc ?loc "token" attr xml - -let xmlTyped xml = Element("typed", (backstep_loc xml), xml) - -let xmlReturn ?(attr=[]) xml = Element("return", attr, xml) - -let xmlCase xml = Element("case", [], xml) - -let xmlScrutinee ?(attr=[]) xml = Element("scrutinee", attr, xml) - -let xmlWith xml = Element("with", [], xml) - -let xmlAssign id xml = Element("assign", ["target",string_of_id id], [xml]) - -let xmlInductive ?loc kind xml = xmlWithLoc ?loc "inductive" ["kind",kind] xml - -let xmlCoFixpoint xml = Element("cofixpoint", [], xml) - -let xmlFixpoint xml = Element("fixpoint", [], xml) - -let xmlCheck ?loc xml = xmlWithLoc ?loc "check" [] xml - -let xmlAssumption ?loc kind xml = xmlWithLoc ?loc "assumption" ["kind",kind] xml - -let xmlComment ?loc xml = xmlWithLoc ?loc "comment" [] xml - -let xmlCanonicalStructure ?loc attr = xmlWithLoc ?loc "canonicalstructure" attr [] - -let xmlQed ?loc ?(attr=[]) = xmlWithLoc ?loc "qed" attr [] - -let xmlPatvar ?loc id = xmlWithLoc ?loc "patvar" ["id", id] [] - -let xmlReference ref = - let name = Libnames.string_of_reference ref in - let i, j = Option.cata Loc.unloc (0,0) (Libnames.loc_of_reference ref) in - let b, e = string_of_int i, string_of_int j in - Element("reference",["name", name; "begin", b; "end", e] ,[]) - -let xmlRequire ?loc ?(attr=[]) xml = xmlWithLoc ?loc "require" attr xml -let xmlImport ?loc ?(attr=[]) xml = xmlWithLoc ?loc "import" attr xml - -let xmlAddLoadPath ?loc ?(attr=[]) xml = xmlWithLoc ?loc "addloadpath" attr xml -let xmlRemoveLoadPath ?loc ?(attr=[]) = xmlWithLoc ?loc "removeloadpath" attr -let xmlAddMLPath ?loc ?(attr=[]) = xmlWithLoc ?loc "addmlpath" attr - -let xmlExtend ?loc xml = xmlWithLoc ?loc "extend" [] xml - -let xmlScope ?loc ?(attr=[]) action name xml = - xmlWithLoc ?loc "scope" (["name",name;"action",action] @ attr) xml - -let xmlProofMode ?loc name = xmlWithLoc ?loc "proofmode" ["name",name] [] - -let xmlProof ?loc xml = xmlWithLoc ?loc "proof" [] xml - -let xmlSectionSubsetDescr name ssd = - Element("sectionsubsetdescr",["name",name], - [PCData (Proof_using.to_string ssd)]) - -let xmlDeclareMLModule ?loc s = - xmlWithLoc ?loc "declarexmlmodule" [] - (List.map (fun x -> Element("path",["value",x],[])) s) - -(* tactics *) -let xmlLtac ?loc xml = xmlWithLoc ?loc "ltac" [] xml - -(* toplevel commands *) -let xmlGallina ?loc xml = xmlWithLoc ?loc "gallina" [] xml - -let xmlTODO ?loc x = - xmlWithLoc ?loc "todo" [] [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] - -let string_of_name n = - match n with - | Anonymous -> "_" - | Name id -> Id.to_string id - -let string_of_glob_sort s = - match s with - | GProp -> "Prop" - | GSet -> "Set" - | GType _ -> "Type" - -let string_of_cast_sort c = - match c with - | CastConv _ -> "CastConv" - | CastVM _ -> "CastVM" - | CastNative _ -> "CastNative" - | CastCoerce -> "CastCoerce" - -let string_of_case_style s = - match s with - | LetStyle -> "Let" - | IfStyle -> "If" - | LetPatternStyle -> "LetPattern" - | MatchStyle -> "Match" - | RegularStyle -> "Regular" - -let attribute_of_syntax_modifier sm = -match sm with - | SetItemLevel (sl, NumLevel n) -> - List.map (fun s -> ("itemlevel", s)) sl @ ["level", string_of_int n] - | SetItemLevel (sl, NextLevel) -> - List.map (fun s -> ("itemlevel", s)) sl @ ["level", "next"] - | SetLevel i -> ["level", string_of_int i] - | SetAssoc a -> - begin match a with - | NonA -> ["",""] - | RightA -> ["associativity", "right"] - | LeftA -> ["associativity", "left"] - end - | SetEntryType (s, _) -> ["entrytype", s] - | SetOnlyPrinting -> ["onlyprinting", ""] - | SetOnlyParsing -> ["onlyparsing", ""] - | SetCompatVersion v -> ["compat", Flags.pr_version v] - | SetFormat (system, (loc, s)) -> - let start, stop = unlock ?loc in - ["format-"^system, s; "begin", start; "end", stop] - -let string_of_assumption_kind l a many = - match l, a, many with - | (Discharge, Logical, true) -> "Hypotheses" - | (Discharge, Logical, false) -> "Hypothesis" - | (Discharge, Definitional, true) -> "Variables" - | (Discharge, Definitional, false) -> "Variable" - | (Global, Logical, true) -> "Axioms" - | (Global, Logical, false) -> "Axiom" - | (Global, Definitional, true) -> "Parameters" - | (Global, Definitional, false) -> "Parameter" - | (Local, Logical, true) -> "Local Axioms" - | (Local, Logical, false) -> "Local Axiom" - | (Local, Definitional, true) -> "Local Parameters" - | (Local, Definitional, false) -> "Local Parameter" - | (Global, Conjectural, _) -> "Conjecture" - | ((Discharge | Local), Conjectural, _) -> assert false - -let rec pp_bindlist bl = - let tlist = - List.flatten - (List.map - (fun (loc_names, _, e) -> - let names = - (List.map - (fun (loc, name) -> - xmlCst ?loc (string_of_name name)) loc_names) in - match e.CAst.v with - | CHole _ -> names - | _ -> names @ [pp_expr e]) - bl) in - match tlist with - | [e] -> e - | l -> xmlTyped l -and pp_decl_notation ((_, s), ce, sc) = (* don't know what it is for now *) - Element ("decl_notation", ["name", s], [pp_expr ce]) -and pp_local_binder lb = (* don't know what it is for now *) - match lb with - | CLocalDef ((loc, nam), ce, ty) -> - let attrs = ["name", string_of_name nam] in - let value = match ty with - Some t -> CAst.make ?loc:(Loc.merge_opt (constr_loc ce) (constr_loc t)) @@ CCast (ce, CastConv t) - | None -> ce in - pp_expr ~attr:attrs value - | CLocalAssum (namll, _, ce) -> - let ppl = - List.map (fun (loc, nam) -> (xmlCst ?loc (string_of_name nam))) namll in - xmlTyped (ppl @ [pp_expr ce]) - | CLocalPattern _ -> - assert false -and pp_local_decl_expr lde = (* don't know what it is for now *) - match lde with - | AssumExpr (_, ce) -> pp_expr ce - | DefExpr (_, ce, _) -> pp_expr ce -and pp_inductive_expr ((_, ((l, id),_)), lbl, ceo, _, cl_or_rdexpr) = - (* inductive_expr *) - let b,e = Option.cata Loc.unloc (0,0) l in - let location = ["begin", string_of_int b; "end", string_of_int e] in - [Element ("lident", ["name", Id.to_string id] @ location, [])] @ (* inductive name *) - begin match cl_or_rdexpr with - | Constructors coel -> List.map (fun (_, (_, ce)) -> pp_expr ce) coel - | RecordDecl (_, ldewwwl) -> - List.map (fun (((_, x), _), _) -> pp_local_decl_expr x) ldewwwl - end @ - begin match ceo with (* don't know what it is for now *) - | Some ce -> [pp_expr ce] - | None -> [] - end @ - (List.map pp_local_binder lbl) -and pp_recursion_order_expr optid roe = (* don't know what it is for now *) - let attrs = - match optid with - | None -> [] - | Some (loc, id) -> - let start, stop = unlock ?loc in - ["begin", start; "end", stop ; "name", Id.to_string id] in - let kind, expr = - match roe with - | CStructRec -> "struct", [] - | CWfRec e -> "rec", [pp_expr e] - | CMeasureRec (e, None) -> "mesrec", [pp_expr e] - | CMeasureRec (e, Some rel) -> "mesrec", [pp_expr e] @ [pp_expr rel] in - Element ("recursion_order", ["kind", kind] @ attrs, expr) -and pp_fixpoint_expr (((loc, id), pl), (optid, roe), lbl, ce, ceo) = - (* fixpoint_expr *) - let start, stop = unlock ?loc in - let id = Id.to_string id in - [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @ - (* fixpoint name *) - [pp_recursion_order_expr optid roe] @ - (List.map pp_local_binder lbl) @ - [pp_expr ce] @ - begin match ceo with (* don't know what it is for now *) - | Some ce -> [pp_expr ce] - | None -> [] - end -and pp_cofixpoint_expr (((loc, id), pl), lbl, ce, ceo) = (* cofixpoint_expr *) - (* Nota: it is like fixpoint_expr without (optid, roe) - * so could be merged if there is no more differences *) - let start, stop = unlock ?loc in - let id = Id.to_string id in - [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @ - (* cofixpoint name *) - (List.map pp_local_binder lbl) @ - [pp_expr ce] @ - begin match ceo with (* don't know what it is for now *) - | Some ce -> [pp_expr ce] - | None -> [] - end -and pp_lident (loc, id) = xmlCst ?loc (Id.to_string id) -and pp_simple_binder (idl, ce) = List.map pp_lident idl @ [pp_expr ce] -and pp_cases_pattern_expr {loc ; CAst.v = cpe} = - match cpe with - | CPatAlias (cpe, id) -> - xmlApply ?loc - (xmlOperator ?loc ~attr:["name", string_of_id id] "alias" :: - [pp_cases_pattern_expr cpe]) - | CPatCstr (ref, None, cpel2) -> - xmlApply ?loc - (xmlOperator ?loc "reference" - ~attr:["name", Libnames.string_of_reference ref] :: - [Element ("impargs", [], []); - Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) - | CPatCstr (ref, Some cpel1, cpel2) -> - xmlApply ?loc - (xmlOperator ?loc "reference" - ~attr:["name", Libnames.string_of_reference ref] :: - [Element ("impargs", [], (List.map pp_cases_pattern_expr cpel1)); - Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) - | CPatAtom optr -> - let attrs = match optr with - | None -> [] - | Some r -> ["name", Libnames.string_of_reference r] in - xmlApply ?loc (xmlOperator ?loc "atom" ~attr:attrs :: []) - | CPatOr cpel -> - xmlApply ?loc (xmlOperator ?loc "or" :: List.map pp_cases_pattern_expr cpel) - | CPatNotation (n, (subst_constr, subst_rec), cpel) -> - xmlApply ?loc - (xmlOperator ?loc "notation" :: - [xmlOperator ?loc n; - Element ("subst", [], - [Element ("subterms", [], - List.map pp_cases_pattern_expr subst_constr); - Element ("recsubterms", [], - List.map - (fun (cpel) -> - Element ("recsubterm", [], - List.map pp_cases_pattern_expr cpel)) - subst_rec)]); - Element ("args", [], (List.map pp_cases_pattern_expr cpel))]) - | CPatPrim tok -> pp_token ?loc tok - | CPatRecord rcl -> - xmlApply ?loc - (xmlOperator ?loc "record" :: - List.map (fun (r, cpe) -> - Element ("field", - ["reference", Libnames.string_of_reference r], - [pp_cases_pattern_expr cpe])) - rcl) - | CPatDelimiters (delim, cpe) -> - xmlApply ?loc - (xmlOperator ?loc "delimiter" ~attr:["name", delim] :: - [pp_cases_pattern_expr cpe]) - | CPatCast _ -> assert false -and pp_case_expr (e, name, pat) = - match name, pat with - | None, None -> xmlScrutinee [pp_expr e] - | Some (loc, name), None -> - let start, stop= unlock ?loc in - xmlScrutinee ~attr:["name", string_of_name name; - "begin", start; "end", stop] [pp_expr e] - | Some (loc, name), Some p -> - let start, stop= unlock ?loc in - xmlScrutinee ~attr:["name", string_of_name name; - "begin", start; "end", stop] - [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e] - | None, Some p -> - xmlScrutinee [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e] -and pp_branch_expr_list bel = - xmlWith - (List.map - (fun (_, (cpel, e)) -> - let ppcepl = - List.map pp_cases_pattern_expr (List.flatten (List.map snd cpel)) in - let ppe = [pp_expr e] in - xmlCase (ppcepl @ ppe)) - bel) -and pp_token ?loc tok = - let tokstr = - match tok with - | String s -> PCData s - | Numeral n -> PCData (to_string n) in - xmlToken ?loc [tokstr] -and pp_local_binder_list lbl = - let l = (List.map pp_local_binder lbl) in - Element ("recurse", (backstep_loc l), l) -and pp_const_expr_list cel = - let l = List.map pp_expr cel in - Element ("recurse", (backstep_loc l), l) -and pp_expr ?(attr=[]) { loc; CAst.v = e } = - match e with - | CRef (r, _) -> - xmlCst ?loc:(Libnames.loc_of_reference r) ~attr (Libnames.string_of_reference r) - | CProdN (bl, e) -> - xmlApply ?loc - (xmlOperator ?loc "forall" :: [pp_bindlist bl] @ [pp_expr e]) - | CApp ((_, hd), args) -> - xmlApply ?loc ~attr (pp_expr hd :: List.map (fun (e,_) -> pp_expr e) args) - | CAppExpl ((_, r, _), args) -> - xmlApply ?loc ~attr - (xmlCst ?loc:(Libnames.loc_of_reference r) (Libnames.string_of_reference r) - :: List.map pp_expr args) - | CNotation (notation, ([],[],[])) -> - xmlOperator ?loc notation - | CNotation (notation, (args, cell, lbll)) -> - let fmts = Notation.find_notation_extra_printing_rules notation in - let oper = xmlOperator ?loc notation ~pprules:fmts in - let cels = List.map pp_const_expr_list cell in - let lbls = List.map pp_local_binder_list lbll in - let args = List.map pp_expr args in - xmlApply ?loc (oper :: (List.sort compare_begin_att (args @ cels @ lbls))) - | CSort(s) -> - xmlOperator ?loc (string_of_glob_sort s) - | CDelimiters (scope, ce) -> - xmlApply ?loc (xmlOperator ?loc "delimiter" ~attr:["name", scope] :: - [pp_expr ce]) - | CPrim tok -> pp_token ?loc tok - | CGeneralization (kind, _, e) -> - let kind= match kind with - | Explicit -> "explicit" - | Implicit -> "implicit" in - xmlApply ?loc - (xmlOperator ?loc ~attr:["kind", kind] "generalization" :: [pp_expr e]) - | CCast (e, tc) -> - begin match tc with - | CastConv t | CastVM t |CastNative t -> - xmlApply ?loc - (xmlOperator ?loc ":" ~attr:["kind", (string_of_cast_sort tc)] :: - [pp_expr e; pp_expr t]) - | CastCoerce -> - xmlApply ?loc - (xmlOperator ?loc ":" ~attr:["kind", "CastCoerce"] :: - [pp_expr e]) - end - | CEvar (ek, cel) -> - let ppcel = List.map (fun (id,e) -> xmlAssign id (pp_expr e)) cel in - xmlApply ?loc - (xmlOperator ?loc "evar" ~attr:["id", string_of_id ek] :: - ppcel) - | CPatVar id -> xmlPatvar ?loc (string_of_id id) - | CHole (_, _, _) -> xmlCst ?loc ~attr "_" - | CIf (test, (_, ret), th, el) -> - let return = match ret with - | None -> [] - | Some r -> [xmlReturn [pp_expr r]] in - xmlApply ?loc - (xmlOperator ?loc "if" :: - return @ [pp_expr th] @ [pp_expr el]) - | CLetTuple (names, (_, ret), value, body) -> - let return = match ret with - | None -> [] - | Some r -> [xmlReturn [pp_expr r]] in - xmlApply ?loc - (xmlOperator ?loc "lettuple" :: - return @ - (List.map (fun (loc, var) -> xmlCst ?loc (string_of_name var)) names) @ - [pp_expr value; pp_expr body]) - | CCases (sty, ret, cel, bel) -> - let return = match ret with - | None -> [] - | Some r -> [xmlReturn [pp_expr r]] in - xmlApply ?loc - (xmlOperator ?loc ~attr:["style", (string_of_case_style sty)] "match" :: - (return @ - [Element ("scrutinees", [], List.map pp_case_expr cel)] @ - [pp_branch_expr_list bel])) - | CRecord _ -> assert false - | CLetIn ((varloc, var), value, typ, body) -> - let value = match typ with - | Some t -> - CAst.make ?loc:(Loc.merge_opt (constr_loc value) (constr_loc t)) (CCast (value, CastConv t)) - | None -> value in - xmlApply ?loc - (xmlOperator ?loc "let" :: - [xmlCst ?loc:varloc (string_of_name var) ; pp_expr value; pp_expr body]) - | CLambdaN (bl, e) -> - xmlApply ?loc - (xmlOperator ?loc "lambda" :: [pp_bindlist bl] @ [pp_expr e]) - | CCoFix (_, _) -> assert false - | CFix (lid, fel) -> - xmlApply ?loc - (xmlOperator ?loc "fix" :: - List.flatten (List.map - (fun (a,b,cl,c,d) -> pp_fixpoint_expr ((a,None),b,cl,c,Some d)) - fel)) - -let pp_comment c = - match c with - | CommentConstr e -> [pp_expr e] - | CommentString s -> [Element ("string", [], [PCData s])] - | CommentInt i -> [PCData (string_of_int i)] - -let rec tmpp ?loc v = - match v with - (* Control *) - | VernacLoad (verbose,f) -> - xmlWithLoc ?loc "load" ["verbose",string_of_bool verbose;"file",f] [] - | VernacTime (loc,e) -> - xmlApply ?loc (Element("time",[],[]) :: - [tmpp ?loc e]) - | VernacRedirect (s, (loc,e)) -> - xmlApply ?loc (Element("redirect",["path", s],[]) :: - [tmpp ?loc e]) - | VernacTimeout (s,e) -> - xmlApply ?loc (Element("timeout",["val",string_of_int s],[]) :: - [tmpp ?loc e]) - | VernacFail e -> xmlApply ?loc (Element("fail",[],[]) :: [tmpp ?loc e]) - - (* Syntax *) - | VernacSyntaxExtension (_, ((_, name), sml)) -> - let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in - xmlReservedNotation ?loc attrs name - - | VernacOpenCloseScope (_,(true,name)) -> xmlScope ?loc "open" name [] - | VernacOpenCloseScope (_,(false,name)) -> xmlScope ?loc "close" name [] - | VernacDelimiters (name,Some tag) -> - xmlScope ?loc "delimit" name ~attr:["delimiter",tag] [] - | VernacDelimiters (name,None) -> - xmlScope ?loc "undelimit" name ~attr:[] [] - | VernacInfix (_,((_,name),sml),ce,sn) -> - let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in - let sc_attr = - match sn with - | Some scope -> ["scope", scope] - | None -> [] in - xmlNotation ?loc (sc_attr @ attrs) name [pp_expr ce] - | VernacNotation (_, ce, (lstr, sml), sn) -> - let name = snd lstr in - let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in - let sc_attr = - match sn with - | Some scope -> ["scope", scope] - | None -> [] in - xmlNotation ?loc (sc_attr @ attrs) name [pp_expr ce] - | VernacBindScope _ as x -> xmlTODO ?loc x - | VernacNotationAddFormat _ as x -> xmlTODO ?loc x - | VernacUniverse _ - | VernacConstraint _ - | VernacPolymorphic (_, _) as x -> xmlTODO ?loc x - (* Gallina *) - | VernacDefinition (ldk, ((_,id),_), de) -> - let l, dk = - match ldk with - | Some l, dk -> (l, dk) - | None, dk -> (Global, dk) in (* Like in ppvernac.ml, l 585 *) - let e = - match de with - | ProveBody (_, ce) -> ce - | DefineBody (_, Some _, ce, None) -> ce - | DefineBody (_, None , ce, None) -> ce - | DefineBody (_, Some _, ce, Some _) -> ce - | DefineBody (_, None , ce, Some _) -> ce in - let str_dk = Kindops.string_of_definition_kind (l, false, dk) in - let str_id = Id.to_string id in - (xmlDef ?loc str_dk str_id [pp_expr e]) - | VernacStartTheoremProof (tk, [ Some ((_,id),_), ([], statement, None) ], b) -> - let str_tk = Kindops.string_of_theorem_kind tk in - let str_id = Id.to_string id in - (xmlThm ?loc str_tk str_id [pp_expr statement]) - | VernacStartTheoremProof _ as x -> xmlTODO ?loc x - | VernacEndProof pe -> - begin - match pe with - | Admitted -> xmlQed ?loc ?attr:None - | Proved (_, Some ((_, id), Some tk)) -> - let nam = Id.to_string id in - let typ = Kindops.string_of_theorem_kind tk in - xmlQed ?loc ~attr:["name", nam; "type", typ] - | Proved (_, Some ((_, id), None)) -> - let nam = Id.to_string id in - xmlQed ?loc ~attr:["name", nam] - | Proved _ -> xmlQed ?loc ?attr:None - end - | VernacExactProof _ as x -> xmlTODO ?loc x - | VernacAssumption ((l, a), _, sbwcl) -> - let binders = List.map (fun (_, (id, c)) -> (List.map fst id, c)) sbwcl in - let many = - List.length (List.flatten (List.map fst binders)) > 1 in - let exprs = - List.flatten (List.map pp_simple_binder binders) in - let l = match l with Some x -> x | None -> Decl_kinds.Global in - let kind = string_of_assumption_kind l a many in - xmlAssumption ?loc kind exprs - | VernacInductive (_, _, iednll) -> - let kind = - let (_, _, _, k, _), _ = List.hd iednll in - begin - match k with - | Record -> "Record" - | Structure -> "Structure" - | Inductive_kw -> "Inductive" - | CoInductive -> "CoInductive" - | Class _ -> "Class" - | Variant -> "Variant" - end in - let exprs = - List.flatten (* should probably not be flattened *) - (List.map - (fun (ie, dnl) -> (pp_inductive_expr ie) @ - (List.map pp_decl_notation dnl)) iednll) in - xmlInductive ?loc kind exprs - | VernacFixpoint (_, fednll) -> - let exprs = - List.flatten (* should probably not be flattened *) - (List.map - (fun (fe, dnl) -> (pp_fixpoint_expr fe) @ - (List.map pp_decl_notation dnl)) fednll) in - xmlFixpoint exprs - | VernacCoFixpoint (_, cfednll) -> - (* Nota: it is like VernacFixpoint without so could be merged *) - let exprs = - List.flatten (* should probably not be flattened *) - (List.map - (fun (cfe, dnl) -> (pp_cofixpoint_expr cfe) @ - (List.map pp_decl_notation dnl)) cfednll) in - xmlCoFixpoint exprs - | VernacScheme _ as x -> xmlTODO ?loc x - | VernacCombinedScheme _ as x -> xmlTODO ?loc x - - (* Gallina extensions *) - | VernacBeginSection (_, id) -> xmlBeginSection ?loc (Id.to_string id) - | VernacEndSegment (_, id) -> xmlEndSegment ?loc (Id.to_string id) - | VernacNameSectionHypSet _ as x -> xmlTODO ?loc x - | VernacRequire (from, import, l) -> - let import = match import with - | None -> [] - | Some true -> ["export","true"] - | Some false -> ["import","true"] - in - let from = match from with - | None -> [] - | Some r -> ["from", Libnames.string_of_reference r] - in - xmlRequire ?loc ~attr:(from @ import) (List.map (fun ref -> - xmlReference ref) l) - | VernacImport (true,l) -> - xmlImport ?loc ~attr:["export","true"] (List.map (fun ref -> - xmlReference ref) l) - | VernacImport (false,l) -> - xmlImport ?loc (List.map (fun ref -> xmlReference ref) l) - | VernacCanonical r -> - let attr = - match r with - | AN (Qualid (_, q)) -> ["qualid", string_of_qualid q] - | AN (Ident (_, id)) -> ["id", Id.to_string id] - | ByNotation (_, (s, _)) -> ["notation", s] in - xmlCanonicalStructure ?loc attr - | VernacCoercion _ as x -> xmlTODO ?loc x - | VernacIdentityCoercion _ as x -> xmlTODO ?loc x - - (* Type classes *) - | VernacInstance _ as x -> xmlTODO ?loc x - - | VernacContext _ as x -> xmlTODO ?loc x - - | VernacDeclareInstances _ as x -> xmlTODO ?loc x - - | VernacDeclareClass _ as x -> xmlTODO ?loc x - - (* Modules and Module Types *) - | VernacDeclareModule _ as x -> xmlTODO ?loc x - | VernacDefineModule _ as x -> xmlTODO ?loc x - | VernacDeclareModuleType _ as x -> xmlTODO ?loc x - | VernacInclude _ as x -> xmlTODO ?loc x - - (* Solving *) - - | (VernacSolveExistential _) as x -> - xmlLtac ?loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] - - (* Auxiliary file and library management *) - | VernacAddLoadPath (recf,name,None) -> - xmlAddLoadPath ?loc ~attr:["rec",string_of_bool recf;"path",name] [] - | VernacAddLoadPath (recf,name,Some dp) -> - xmlAddLoadPath ?loc ~attr:["rec",string_of_bool recf;"path",name] - [PCData (Names.DirPath.to_string dp)] - | VernacRemoveLoadPath name -> xmlRemoveLoadPath ?loc ~attr:["path",name] [] - | VernacAddMLPath (recf,name) -> - xmlAddMLPath ?loc ~attr:["rec",string_of_bool recf;"path",name] [] - | VernacDeclareMLModule sl -> xmlDeclareMLModule ?loc sl - | VernacChdir _ as x -> xmlTODO ?loc x - - (* State management *) - | VernacWriteState _ as x -> xmlTODO ?loc x - | VernacRestoreState _ as x -> xmlTODO ?loc x - - (* Resetting *) - | VernacResetName _ as x -> xmlTODO ?loc x - | VernacResetInitial as x -> xmlTODO ?loc x - | VernacBack _ as x -> xmlTODO ?loc x - | VernacBackTo _ -> PCData "VernacBackTo" - - (* Commands *) - | VernacCreateHintDb _ as x -> xmlTODO ?loc x - | VernacRemoveHints _ as x -> xmlTODO ?loc x - | VernacHints _ as x -> xmlTODO ?loc x - | VernacSyntacticDefinition ((_, name), (idl, ce), _, _) -> - let name = Id.to_string name in - let attrs = List.map (fun id -> ("id", Id.to_string id)) idl in - xmlNotation ?loc attrs name [pp_expr ce] - | VernacDeclareImplicits _ as x -> xmlTODO ?loc x - | VernacArguments _ as x -> xmlTODO ?loc x - | VernacArgumentsScope _ as x -> xmlTODO ?loc x - | VernacReserve _ as x -> xmlTODO ?loc x - | VernacGeneralizable _ as x -> xmlTODO ?loc x - | VernacSetOpacity _ as x -> xmlTODO ?loc x - | VernacSetStrategy _ as x -> xmlTODO ?loc x - | VernacUnsetOption _ as x -> xmlTODO ?loc x - | VernacSetOption _ as x -> xmlTODO ?loc x - | VernacSetAppendOption _ as x -> xmlTODO ?loc x - | VernacAddOption _ as x -> xmlTODO ?loc x - | VernacRemoveOption _ as x -> xmlTODO ?loc x - | VernacMemOption _ as x -> xmlTODO ?loc x - | VernacPrintOption _ as x -> xmlTODO ?loc x - | VernacCheckMayEval (_,_,e) -> xmlCheck ?loc [pp_expr e] - | VernacGlobalCheck _ as x -> xmlTODO ?loc x - | VernacDeclareReduction _ as x -> xmlTODO ?loc x - | VernacPrint _ as x -> xmlTODO ?loc x - | VernacSearch _ as x -> xmlTODO ?loc x - | VernacLocate _ as x -> xmlTODO ?loc x - | VernacRegister _ as x -> xmlTODO ?loc x - | VernacComments (cl) -> - xmlComment ?loc (List.flatten (List.map pp_comment cl)) - - (* Stm backdoor *) - | VernacStm _ as x -> xmlTODO ?loc x - - (* Proof management *) - | VernacGoal _ as x -> xmlTODO ?loc x - | VernacAbort _ as x -> xmlTODO ?loc x - | VernacAbortAll -> PCData "VernacAbortAll" - | VernacRestart as x -> xmlTODO ?loc x - | VernacUndo _ as x -> xmlTODO ?loc x - | VernacUndoTo _ as x -> xmlTODO ?loc x - | VernacBacktrack _ as x -> xmlTODO ?loc x - | VernacFocus _ as x -> xmlTODO ?loc x - | VernacUnfocus as x -> xmlTODO ?loc x - | VernacUnfocused as x -> xmlTODO ?loc x - | VernacBullet _ as x -> xmlTODO ?loc x - | VernacSubproof _ as x -> xmlTODO ?loc x - | VernacEndSubproof as x -> xmlTODO ?loc x - | VernacShow _ as x -> xmlTODO ?loc x - | VernacCheckGuard as x -> xmlTODO ?loc x - | VernacProof (tac,using) -> - 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 - - (* Toplevel control *) - | VernacToplevelControl _ as x -> xmlTODO ?loc x - - (* For extension *) - | VernacExtend _ as x -> - xmlExtend ?loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] - - (* Flags *) - | VernacProgram e -> xmlApply ?loc (Element("program",[],[]) :: [tmpp ?loc e]) - | VernacLocal (b,e) -> - xmlApply ?loc (Element("local",["flag",string_of_bool b],[]) :: - [tmpp ?loc e]) - -let tmpp ?loc v = - match tmpp ?loc v with - | Element("ltac",_,_) as x -> x - | xml -> xmlGallina ?loc [xml] diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml index 70133fb9f..d16efa603 100644 --- a/ide/utils/configwin_ihm.ml +++ b/ide/utils/configwin_ihm.ml @@ -411,7 +411,7 @@ class text_param_box param (tt:GData.tooltips) = let v = param.string_of_string (buffer#get_text ()) in if v <> param.string_value then ( - dbg "apply new value !"; + dbg "apply new value!"; let _ = param.string_f_apply v in param.string_value <- v ) diff --git a/ide/xml_lexer.mll b/ide/xml_lexer.mll index 290f2c89a..4a52147e1 100644 --- a/ide/xml_lexer.mll +++ b/ide/xml_lexer.mll @@ -83,6 +83,9 @@ let error lexbuf e = last_pos := lexeme_start lexbuf; raise (Error e) +[@@@ocaml.warning "-3"] (* String.lowercase_ascii since 4.03.0 GPR#124 *) +let lowercase = String.lowercase +[@@@ocaml.warning "+3"] } let newline = ['\n'] @@ -219,7 +222,7 @@ and entity = parse { let ident = lexeme lexbuf in try - Hashtbl.find idents (String.lowercase ident) + Hashtbl.find idents (lowercase ident) with Not_found -> "&" ^ ident } diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 4c29fc809..19ca8d50b 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -663,9 +663,11 @@ let rec extern inctx scopes vars r = | GEvar (n,l) -> extern_evar n (List.map (on_snd (extern false scopes vars)) l) - | GPatVar (b,n) -> + | GPatVar kind -> if !print_meta_as_hole then CHole (None, Misctypes.IntroAnonymous, None) else - if b then CPatVar n else CEvar (n,[]) + (match kind with + | Evar_kinds.SecondOrderPatVar n -> CPatVar n + | Evar_kinds.FirstOrderPatVar n -> CEvar (n,[])) | GApp (f,args) -> (match f with @@ -698,7 +700,7 @@ let rec extern inctx scopes vars r = | None :: q -> raise No_match | Some c :: q -> match locs with - | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern]") + | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].") | (_, false) :: locs' -> (* we don't want to print locals *) ip q locs' args acc @@ -740,7 +742,7 @@ let rec extern inctx scopes vars r = | GCases (sty,rtntypopt,tml,eqns) -> let vars' = - List.fold_right (name_fold Id.Set.add) + List.fold_right (Name.fold_right Id.Set.add) (cases_predicate_names tml) vars in let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in let tml = List.map (fun (tm,(na,x)) -> @@ -790,12 +792,12 @@ let rec extern inctx scopes vars r = let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in let bl = List.map (extended_glob_local_binder_of_decl ?loc) bl in let (assums,ids,bl) = extern_local_binder scopes vars bl in - let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in - let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in + let vars0 = List.fold_right (Name.fold_right Id.Set.add) ids vars in + let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in let n = match fst nv.(i) with | None -> None - | Some x -> Some (Loc.tag @@ out_name (List.nth assums x)) + | Some x -> Some (Loc.tag @@ Name.get_id (List.nth assums x)) in let ro = extern_recursion_order scopes vars (snd nv.(i)) in ((Loc.tag fi), (n, ro), bl, extern_typ scopes vars0 ty, @@ -807,8 +809,8 @@ let rec extern inctx scopes vars r = Array.mapi (fun i fi -> let bl = List.map (extended_glob_local_binder_of_decl ?loc) blv.(i) in let (_,ids,bl) = extern_local_binder scopes vars bl in - let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in - let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in + let vars0 = List.fold_right (Name.fold_right Id.Set.add) ids vars in + let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in ((Loc.tag fi),bl,extern_typ scopes vars0 tyv.(i), sub_extern false scopes vars1 bv.(i))) idv in @@ -852,14 +854,14 @@ and extern_local_binder scopes vars = function [] -> ([],[],[]) | { v = GLocalDef (na,bk,bd,ty)}::l -> let (assums,ids,l) = - extern_local_binder scopes (name_fold Id.Set.add na vars) l in + extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l in (assums,na::ids, CLocalDef((Loc.tag na), extern false scopes vars bd, Option.map (extern false scopes vars) ty) :: l) | { v = GLocalAssum (na,bk,ty)}::l -> let ty = extern_typ scopes vars ty in - (match extern_local_binder scopes (name_fold Id.Set.add na vars) l with + (match extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l with (assums,ids,CLocalAssum(nal,k,ty')::l) when constr_expr_eq ty ty' && match na with Name id -> not (occur_var_constr_expr id ty') @@ -1033,17 +1035,17 @@ let rec glob_of_pat env sigma pat = CAst.make @@ match pat with let id = try match lookup_name_of_rel n env with | Name id -> id | Anonymous -> - anomaly ~label:"glob_constr_of_pattern" (Pp.str "index to an anonymous variable") + anomaly ~label:"glob_constr_of_pattern" (Pp.str "index to an anonymous variable.") with Not_found -> Id.of_string ("_UNBOUND_REL_"^(string_of_int n)) in GVar id | PMeta None -> GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous,None) - | PMeta (Some n) -> GPatVar (false,n) + | PMeta (Some n) -> GPatVar (Evar_kinds.FirstOrderPatVar n) | PProj (p,c) -> GApp (CAst.make @@ GRef (ConstRef (Projection.constant p),None), [glob_of_pat env sigma c]) | PApp (f,args) -> GApp (glob_of_pat env sigma f,Array.map_to_list (glob_of_pat env sigma) args) | PSoApp (n,args) -> - GApp (CAst.make @@ GPatVar (true,n), + GApp (CAst.make @@ GPatVar (Evar_kinds.SecondOrderPatVar n), List.map (glob_of_pat env sigma) args) | PProd (na,t,c) -> GProd (na,Explicit,glob_of_pat env sigma t,glob_of_pat (na::env) sigma c) @@ -1064,7 +1066,7 @@ let rec glob_of_pat env sigma pat = CAst.make @@ match pat with | _, Some ind -> let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat env sigma c)) bl in simple_cases_matrix_of_branches ind bl' - | _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive") + | _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive.") in let mat = if info.cip_extensible then mat @ [any_any_branch] else mat in @@ -1072,7 +1074,7 @@ let rec glob_of_pat env sigma pat = CAst.make @@ match pat with | PMeta None, _, _ -> (Anonymous,None),None | _, Some ind, Some nargs -> return_type_of_predicate ind nargs (glob_of_pat env sigma p) - | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive") + | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") in GCases (RegularStyle,rtn,[glob_of_pat env sigma tm,indnames],mat) | PFix f -> (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkFix f))).v (** FIXME bad env *) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 4dcf287ef..6f17324a1 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -46,7 +46,7 @@ open Context.Rel.Declaration types and recursive definitions and of projection names in records *) type var_internalization_type = - | Inductive of Id.t list (* list of params *) + | Inductive of Id.t list (* list of params *) * bool (* true = check for possible capture *) | Recursive | Method | Variable @@ -98,16 +98,16 @@ let global_reference_of_reference ref = locate_reference (snd (qualid_of_reference ref)) let global_reference id = - Universes.constr_of_global (locate_reference (qualid_of_ident id)) + locate_reference (qualid_of_ident id) let construct_reference ctx id = try - Term.mkVar (let _ = Context.Named.lookup id ctx in id) + VarRef (let _ = Context.Named.lookup id ctx in id) with Not_found -> global_reference id let global_reference_in_absolute_module dir id = - Universes.constr_of_global (Nametab.global_of_path (Libnames.make_path dir id)) + Nametab.global_of_path (Libnames.make_path dir id) (**********************************************************************) (* Internalization errors *) @@ -176,7 +176,7 @@ let parsing_explicit = ref false let empty_internalization_env = Id.Map.empty let compute_explicitable_implicit imps = function - | Inductive params -> + | Inductive (params,_) -> (* In inductive types, the parameters are fixed implicit arguments *) let sub_impl,_ = List.chop (List.length params) imps in let sub_impl' = List.filter is_status_implicit sub_impl in @@ -190,10 +190,10 @@ let compute_internalization_data env ty typ impl = let expls_impl = compute_explicitable_implicit impl ty in (ty, expls_impl, impl, compute_arguments_scope typ) -let compute_internalization_env env ty = +let compute_internalization_env env ?(impls=empty_internalization_env) ty = List.fold_left3 (fun map id typ impl -> Id.Map.add id (compute_internalization_data env ty typ impl) map) - empty_internalization_env + impls (**********************************************************************) (* Contracting "{ _ }" in notations *) @@ -358,16 +358,17 @@ let locate_if_hole ?loc na = function let reset_hidden_inductive_implicit_test env = { env with impls = Id.Map.map (function - | (Inductive _,b,c,d) -> (Inductive [],b,c,d) + | (Inductive (params,_),b,c,d) -> (Inductive (params,false),b,c,d) | x -> x) env.impls } -let check_hidden_implicit_parameters id impls = +let check_hidden_implicit_parameters ?loc id impls = if Id.Map.exists (fun _ -> function - | (Inductive indparams,_,_,_) -> Id.List.mem id indparams + | (Inductive (indparams,check),_,_,_) when check -> Id.List.mem id indparams | _ -> false) impls then - 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.") + user_err ?loc (pr_id id ++ strbrk " is already used as name of " ++ + strbrk "a parameter of the inductive type; bound variables in " ++ + strbrk "the type of a constructor shall use a different name.") let push_name_env ?(global_level=false) ntnvars implargs env = function @@ -376,7 +377,7 @@ let push_name_env ?(global_level=false) ntnvars implargs env = user_err ?loc (str "Anonymous variables not allowed"); env | loc,Name id -> - check_hidden_implicit_parameters id env.impls ; + check_hidden_implicit_parameters ?loc id env.impls ; if Id.Map.is_empty ntnvars && Id.equal id ldots_var then error_ldots_var ?loc; set_var_scope ?loc id false env ntnvars; @@ -536,7 +537,7 @@ let traverse_binder (terms,_,_ as subst) avoid (renaming,env) = function try (* Binders bound in the notation are considered first-order objects *) let _,na = coerce_to_name (fst (Id.Map.find id terms)) in - (renaming,{env with ids = name_fold Id.Set.add na env.ids}), na + (renaming,{env with ids = Name.fold_right Id.Set.add na env.ids}), na with Not_found -> (* Binders not bound in the notation do not capture variables *) (* outside the notation (i.e. in the substitution) *) @@ -616,7 +617,7 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = let env,bl' = List.fold_left (intern_local_binder_aux intern ntnvars) (env,[]) bl in terms_of_binders (if lassoc then bl' else List.rev bl'),(None,[]) with Not_found -> - anomaly (Pp.str "Inconsistent substitution of recursive notation") in + anomaly (Pp.str "Inconsistent substitution of recursive notation.") in let termin = aux (terms,None,None) subinfos terminator in let fold a t = let nterms = Id.Map.add y (a, (scopt, subscopes)) terms in @@ -659,7 +660,7 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = termin bl in make_letins letins res with Not_found -> - anomaly (Pp.str "Inconsistent substitution of recursive notation")) + anomaly (Pp.str "Inconsistent substitution of recursive notation.")) | NProd (Name id, NHole _, c') when option_mem_assoc id binderopt -> let a,letins = snd (Option.get binderopt) in let e = make_letins letins (aux subst' infos c') in @@ -1070,7 +1071,7 @@ let sort_fields ~complete loc fields completer = let global_record_id = ConstructRef record.Recordops.s_CONST in try Qualid (loc, shortest_qualid_of_global Id.Set.empty global_record_id) with Not_found -> - anomaly (str "Environment corruption for records") in + anomaly (str "Environment corruption for records.") in let () = check_duplicate loc fields in let (end_index, (* one past the last field index *) first_field_index, (* index of the first field of the record *) @@ -1081,11 +1082,11 @@ let sort_fields ~complete loc fields completer = let rec build_proj_list projs proj_kinds idx ~acc_first_idx acc = match projs with | [] -> (idx, acc_first_idx, acc) - | (Some name) :: projs -> - let field_glob_ref = ConstRef name in + | (Some field_glob_id) :: projs -> + let field_glob_ref = ConstRef field_glob_id in let first_field = eq_gr field_glob_ref first_field_glob_ref in begin match proj_kinds with - | [] -> anomaly (Pp.str "Number of projections mismatch") + | [] -> anomaly (Pp.str "Number of projections mismatch.") | (_, regular) :: proj_kinds -> (* "regular" is false when the field is defined by a let-in in the record declaration @@ -1099,7 +1100,7 @@ let sort_fields ~complete loc fields completer = build_proj_list projs proj_kinds idx ~acc_first_idx acc else build_proj_list projs proj_kinds (idx+1) ~acc_first_idx - ((idx, field_glob_ref) :: acc) + ((idx, field_glob_id) :: acc) end | None :: projs -> if complete then @@ -1121,7 +1122,7 @@ let sort_fields ~complete loc fields completer = 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 + let the_proj (idx, glob_id) = eq_gr field_glob_ref (ConstRef glob_id) in try CList.extract_first the_proj remaining_projs with Not_found -> user_err ?loc @@ -1218,7 +1219,7 @@ let drop_notations_pattern looked_for = | GHole (_,_,_) -> RCPatAtom (None) | GRef (g,_) -> RCPatCstr (g,[],[]) | GApp ({ v = GRef (g,_) }, l) -> RCPatCstr (g, List.map rcp_of_glob l,[]) - | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr "))) x + | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr."))) x in let rec drop_syndef top scopes re pats = let (loc,qid) = qualid_of_reference re in @@ -1345,7 +1346,7 @@ let drop_notations_pattern looked_for = in_pat top (scopt,subscopes@snd scopes) a with Not_found -> if Id.equal id ldots_var then CAst.make ?loc @@ RCPatAtom (Some id) else - anomaly (str "Unbound pattern notation variable: " ++ Id.print id) + anomaly (str "Unbound pattern notation variable: " ++ Id.print id ++ str ".") end | NRef g -> ensure_kind top loc g; @@ -1370,7 +1371,7 @@ let drop_notations_pattern looked_for = subst_pat_iterator ldots_var t u) (if lassoc then List.rev l else l) termin with Not_found -> - anomaly (Pp.str "Inconsistent substitution of recursive notation")) + anomaly (Pp.str "Inconsistent substitution of recursive notation.")) | NHole _ -> let () = assert (List.is_empty args) in CAst.make ?loc @@ RCPatAtom None @@ -1464,7 +1465,7 @@ let get_implicit_name n imps = let set_hole_implicit i b = function | {loc; v = GRef (r,_) } | { v = GApp ({loc; v = GRef (r,_)},_) } -> Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) | {loc; v = GVar id } -> Loc.tag ?loc (Evar_kinds.ImplicitArg (VarRef id,i,b),Misctypes.IntroAnonymous,None) - | _ -> anomaly (Pp.str "Only refs have implicits") + | _ -> anomaly (Pp.str "Only refs have implicits.") let exists_implicit_name id = List.exists (fun imp -> is_status_implicit imp && Id.equal id (name_of_implicit imp)) @@ -1506,7 +1507,7 @@ let extract_explicit_arg imps args = (**********************************************************************) (* Main loop *) -let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = +let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let rec intern env = CAst.with_loc_val (fun ?loc -> function | CRef (ref,us) -> let (c,imp,subscopes,l),_ = @@ -1646,7 +1647,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in let fields = sort_fields ~complete:true loc fs - (fun _idx -> CAst.make ?loc @@ CHole (Some (Evar_kinds.QuestionMark st), + (fun _idx -> CAst.make ?loc @@ CHole (Some (Evar_kinds.QuestionMark (st,Anonymous)), Misctypes.IntroAnonymous, None)) in begin @@ -1660,7 +1661,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = | CCases (sty, rtnpo, tms, eqns) -> let as_in_vars = List.fold_left (fun acc (_,na,inb) -> Option.fold_left (fun acc tt -> Id.Set.union (ids_of_cases_indtype tt) acc) - (Option.fold_left (fun acc (_,y) -> name_fold Id.Set.add y acc) acc na) + (Option.fold_left (fun acc (_,y) -> Name.fold_right Id.Set.add y acc) acc na) inb) Id.Set.empty tms in (* as, in & return vars *) let forbidden_vars = Option.cata free_vars_of_constr_expr as_in_vars rtnpo in @@ -1726,7 +1727,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in (match naming with | Misctypes.IntroIdentifier id -> Evar_kinds.NamedHole id - | _ -> Evar_kinds.QuestionMark st) + | _ -> Evar_kinds.QuestionMark (st,Anonymous)) | Some k -> k in let solve = match solve with @@ -1749,12 +1750,12 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = CAst.make ?loc @@ GHole (k, naming, solve) (* Parsing pattern variables *) - | CPatVar n when allow_patvar -> + | CPatVar n when pattern_mode -> CAst.make ?loc @@ - GPatVar (true,n) - | CEvar (n, []) when allow_patvar -> + GPatVar (Evar_kinds.SecondOrderPatVar n) + | CEvar (n, []) when pattern_mode -> CAst.make ?loc @@ - GPatVar (false,n) + GPatVar (Evar_kinds.FirstOrderPatVar n) (* end *) (* Parsing existential variables *) | CEvar (n, l) -> @@ -1944,13 +1945,13 @@ let empty_ltac_sign = { } let intern_gen kind env - ?(impls=empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=empty_ltac_sign) + ?(impls=empty_internalization_env) ?(pattern_mode=false) ?(ltacvars=empty_ltac_sign) c = let tmp_scope = scope_of_type_kind kind in internalize env {ids = extract_ids env; unb = false; tmp_scope = tmp_scope; scopes = []; impls = impls} - allow_patvar (ltacvars, Id.Map.empty) c + pattern_mode (ltacvars, Id.Map.empty) c let intern_constr env c = intern_gen WithoutTypeConstraint env c @@ -2023,7 +2024,7 @@ let interp_type_evars env evdref ?(impls=empty_internalization_env) c = let intern_constr_pattern env ?(as_type=false) ?(ltacvars=empty_ltac_sign) c = let c = intern_gen (if as_type then IsType else WithoutTypeConstraint) - ~allow_patvar:true ~ltacvars env c in + ~pattern_mode:true ~ltacvars env c in pattern_of_glob_constr c let interp_notation_constr ?(impls=empty_internalization_env) nenv a = @@ -2071,7 +2072,7 @@ let intern_context global_level env impl_env binders = with InternalizationError (loc,e) -> user_err ?loc ~hdr:"internalize" (explain_internalization_error e) -let interp_rawcontext_evars env evdref k bl = +let interp_glob_context_evars env evdref k bl = let open EConstr in let (env, par, _, impls) = List.fold_left @@ -2100,6 +2101,6 @@ let interp_rawcontext_evars env evdref k bl = let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env evdref params = let int_env,bl = intern_context global_level env impl_env params in - let x = interp_rawcontext_evars env evdref shift bl in + let x = interp_glob_context_evars env evdref shift bl in int_env, x diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 644cafe57..a92e94d97 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -38,7 +38,7 @@ open Misctypes of [env] *) type var_internalization_type = - | Inductive of Id.t list (* list of params *) + | Inductive of Id.t list (* list of params *) * bool (* true = check for possible capture *) | Recursive | Method | Variable @@ -61,7 +61,7 @@ val empty_internalization_env : internalization_env val compute_internalization_data : env -> var_internalization_type -> types -> Impargs.manual_explicitation list -> var_internalization_data -val compute_internalization_env : env -> var_internalization_type -> +val compute_internalization_env : env -> ?impls:internalization_env -> var_internalization_type -> Id.t list -> types list -> Impargs.manual_explicitation list list -> internalization_env @@ -83,7 +83,7 @@ val intern_constr : env -> constr_expr -> glob_constr val intern_type : env -> constr_expr -> glob_constr val intern_gen : typing_constraint -> env -> - ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign -> + ?impls:internalization_env -> ?pattern_mode:bool -> ?ltacvars:ltac_sign -> constr_expr -> glob_constr val intern_pattern : env -> cases_pattern_expr -> @@ -176,9 +176,9 @@ val interp_context_evars : val locate_reference : Libnames.qualid -> Globnames.global_reference val is_global : Id.t -> bool -val construct_reference : ('c, 't) Context.Named.pt -> Id.t -> constr -val global_reference : Id.t -> constr -val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr +val construct_reference : ('c, 't) Context.Named.pt -> Id.t -> Globnames.global_reference +val global_reference : Id.t -> Globnames.global_reference +val global_reference_in_absolute_module : DirPath.t -> Id.t -> Globnames.global_reference (** Interprets a term as the left-hand side of a notation. The returned map is guaranteed to have the same domain as the input one. *) diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index cfc6e6c2a..ade524141 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -264,7 +264,7 @@ let implicits_of_glob_constr ?(with_products=true) l = let () = match bk with | Implicit -> Feedback.msg_warning (strbrk "Ignoring implicit status of product binder " ++ - pr_name na ++ strbrk " and following binders") + Name.print na ++ strbrk " and following binders") | _ -> () in [] | GLambda (na, bk, t, b) -> abs na bk b diff --git a/interp/notation.ml b/interp/notation.ml index d19654b10..23332f7c4 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -381,7 +381,7 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function let declare_notation_level ntn level = if String.Map.mem ntn !notation_level_map then - anomaly (str "Notation " ++ str ntn ++ str " is already assigned a level"); + anomaly (str "Notation " ++ str ntn ++ str " is already assigned a level."); notation_level_map := String.Map.add ntn level !notation_level_map let level_of_notation ntn = @@ -1004,13 +1004,13 @@ let declare_notation_rule ntn ~extra unpl gram = let find_notation_printing_rule ntn = try pi1 (String.Map.find ntn !notation_rules) - with Not_found -> anomaly (str "No printing rule found for " ++ str ntn) + with Not_found -> anomaly (str "No printing rule found for " ++ str ntn ++ str ".") let find_notation_extra_printing_rules ntn = try pi2 (String.Map.find ntn !notation_rules) with Not_found -> [] let find_notation_parsing_rules ntn = try pi3 (String.Map.find ntn !notation_rules) - with Not_found -> anomaly (str "No parsing rule found for " ++ str ntn) + with Not_found -> anomaly (str "No parsing rule found for " ++ str ntn ++ str ".") let get_defined_notations () = String.Set.elements @@ String.Map.domain !notation_rules diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 6f9100911..08b9fbe8e 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -22,31 +22,6 @@ open Notation_term (**********************************************************************) (* Utilities *) -let on_true_do b f c = if b then (f c; b) else b - -let compare_glob_constr f add t1 t2 = match CAst.(t1.v,t2.v) with - | GRef (r1,_), GRef (r2,_) -> eq_gr r1 r2 - | GVar v1, GVar v2 -> on_true_do (Id.equal v1 v2) add (Name v1) - | GApp (f1,l1), GApp (f2,l2) -> f f1 f2 && List.for_all2eq f l1 l2 - | GLambda (na1,bk1,ty1,c1), GLambda (na2,bk2,ty2,c2) - when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> - on_true_do (f ty1 ty2 && f c1 c2) add na1 - | GProd (na1,bk1,ty1,c1), GProd (na2,bk2,ty2,c2) - when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> - on_true_do (f ty1 ty2 && f c1 c2) add na1 - | GHole _, GHole _ -> true - | GSort s1, GSort s2 -> Miscops.glob_sort_eq s1 s2 - | GLetIn (na1,b1,t1,c1), GLetIn (na2,b2,t2,c2) when Name.equal na1 na2 -> - on_true_do (f b1 b2 && f c1 c2) add na1 - | (GCases _ | GRec _ - | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _),_ - | _,(GCases _ | GRec _ - | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _) - -> user_err Pp.(str "Unsupported construction in recursive notations.") - | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _ - | GHole _ | GSort _ | GLetIn _), _ - -> false - let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with | NRef gr1, NRef gr2 -> eq_gr gr1 gr2 | NVar id1, NVar id2 -> Int.equal (List.index Id.equal id1 vars1) (List.index Id.equal id2 vars2) @@ -184,7 +159,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = e',Some (Loc.tag ?loc (ind,nal')) in let e',na' = g e' na in (e',(f e tm,(na',t'))::tml')) tml (e,[]) in - let fold (idl,e) na = let (e,na) = g e na in ((name_cons na idl,e),na) in + let fold (idl,e) na = let (e,na) = g e na in ((Name.cons na idl,e),na) in let eqnl' = List.map (fun (patl,rhs) -> let ((idl,e),patl) = List.fold_map (cases_pattern_fold_map ?loc fold) ([],e) patl in @@ -287,7 +262,7 @@ let compare_recursive_parts found f f' (iterator,subc) = | Some _ -> false end | GLambda (Name x,_,t_x,c), GLambda (Name y,_,t_y,term) - | GProd (Name x,_,t_x,c), GProd (Name y,_,t_y,term) -> + | GProd (Name x,_,t_x,c), GProd (Name y,_,t_y,term) when not (Id.equal x y) -> (* We found a binding position where it differs *) begin match !diff with | None -> @@ -296,7 +271,7 @@ let compare_recursive_parts found f f' (iterator,subc) = | Some _ -> false end | _ -> - compare_glob_constr aux (add_name found) c1 c2 in + mk_glob_constr_eq aux c1 c2 in if aux iterator subc then match !diff with | None -> @@ -715,7 +690,7 @@ let bind_term_as_binding_env alp (terms,onlybinders,termlists,binderlists as sig | { CAst.v = GVar id' } -> (if not (Id.equal id id') then (fst alp,(id,id')::snd alp) else alp), sigma - | _ -> anomaly (str "A term which can be a binder has to be a variable") + | _ -> anomaly (str "A term which can be a binder has to be a variable.") with Not_found -> (* The matching against a term allowing to find the instance has not been found yet *) (* If it will be a different name, we shall unfortunately fail *) @@ -855,7 +830,7 @@ let bind_bindinglist_as_term_env alp (terms,onlybinders,termlists,binderlists) v let sigma = (terms,onlybinders,termlists,Id.List.remove_assoc var binderlists) in add_bindinglist_env sigma var bl with Not_found -> - anomaly (str "There should be a binder list bindings this list of terms") + anomaly (str "There should be a binder list bindings this list of terms.") let match_fix_kind fk1 fk2 = match (fk1,fk2) with diff --git a/interp/topconstr.ml b/interp/topconstr.ml index a79f10df6..94bbc60ea 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -83,13 +83,13 @@ let ids_of_cases_tomatch tms = (fun (_, ona, indnal) l -> Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t) indnal - (Option.fold_right (down_located (name_fold Id.Set.add)) ona l)) + (Option.fold_right (down_located (Name.fold_right Id.Set.add)) ona l)) tms Id.Set.empty let rec fold_constr_expr_binders g f n acc b = function | (nal,bk,t)::l -> let nal = snd (List.split nal) in - let n' = List.fold_right (name_fold g) nal n in + let n' = List.fold_right (Name.fold_right g) nal n in f n (fold_constr_expr_binders g f n' acc b l) t | [] -> f n acc b @@ -97,10 +97,10 @@ let rec fold_constr_expr_binders g f n acc b = function let rec fold_local_binders g f n acc b = function | CLocalAssum (nal,bk,t)::l -> let nal = snd (List.split nal) in - let n' = List.fold_right (name_fold g) nal n in + let n' = List.fold_right (Name.fold_right g) nal n in f n (fold_local_binders g f n' acc b l) t | CLocalDef ((_,na),c,t)::l -> - Option.fold_left (f n) (f n (fold_local_binders g f (name_fold g na n) acc b l) c) t + Option.fold_left (f n) (f n (fold_local_binders g f (Name.fold_right g na n) acc b l) c) t | CLocalPattern (_,(pat,t))::l -> let acc = fold_local_binders g f (cases_pattern_fold_names g n pat) acc b l in Option.fold_left (f n) acc t @@ -112,7 +112,7 @@ let fold_constr_expr_with_binders g f n acc = CAst.with_val (function | CApp ((_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) | CProdN (l,b) | CLambdaN (l,b) -> fold_constr_expr_binders g f n acc b l | CLetIn (na,a,t,b) -> - f (name_fold g (snd na) n) (Option.fold_left (f n) (f n acc a) t) b + f (Name.fold_right g (snd na) n) (Option.fold_left (f n) (f n acc a) t) b | CCast (a,(CastConv b|CastVM b|CastNative b)) -> f n (f n acc a) b | CCast (a,CastCoerce) -> f n acc a | CNotation (_,(l,ll,bll)) -> @@ -133,12 +133,12 @@ let fold_constr_expr_with_binders g f n acc = CAst.with_val (function let ids = ids_of_pattern_list patl in f (Id.Set.fold g ids n) acc rhs) bl acc | CLetTuple (nal,(ona,po),b,c) -> - let n' = List.fold_right (down_located (name_fold g)) nal n in - f (Option.fold_right (down_located (name_fold g)) ona n') (f n acc b) c + let n' = List.fold_right (down_located (Name.fold_right g)) nal n in + f (Option.fold_right (down_located (Name.fold_right g)) ona n') (f n acc b) c | CIf (c,(ona,po),b1,b2) -> let acc = f n (f n (f n acc b1) b2) c in Option.fold_left - (f (Option.fold_right (down_located (name_fold g)) ona n)) acc po + (f (Option.fold_right (down_located (Name.fold_right g)) ona n)) acc po | CFix (_,l) -> let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in List.fold_right (fun (_,(_,o),lb,t,c) acc -> @@ -198,7 +198,7 @@ let split_at_annot bl na = (* Used in correctness and interface *) -let map_binder g e nal = List.fold_right (down_located (name_fold g)) nal e +let map_binder g e nal = List.fold_right (down_located (Name.fold_right g)) nal e let map_binders f g e bl = (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) @@ -212,7 +212,7 @@ let map_local_binders f g e bl = CLocalAssum(nal,k,ty) -> (map_binder g e nal, CLocalAssum(nal,k,f e ty)::bl) | CLocalDef((loc,na),c,ty) -> - (name_fold g na e, CLocalDef((loc,na),f e c,Option.map (f e) ty)::bl) + (Name.fold_right g na e, CLocalDef((loc,na),f e c,Option.map (f e) ty)::bl) | CLocalPattern (loc,(pat,t)) -> let ids = ids_of_pattern pat in (Id.Set.fold g ids e, CLocalPattern (loc,(pat,Option.map (f e) t))::bl) in @@ -228,7 +228,7 @@ let map_constr_expr_with_binders g f e = CAst.map (function | CLambdaN (bl,b) -> let (e,bl) = map_binders f g e bl in CLambdaN (bl,f e b) | CLetIn (na,a,t,b) -> - CLetIn (na,f e a,Option.map (f e) t,f (name_fold g (snd na) e) b) + CLetIn (na,f e a,Option.map (f e) t,f (Name.fold_right g (snd na) e) b) | CCast (a,c) -> CCast (f e a, Miscops.map_cast_type (f e) c) | CNotation (n,(l,ll,bll)) -> (* This is an approximation because we don't know what binds what *) @@ -247,11 +247,11 @@ let map_constr_expr_with_binders g f e = CAst.map (function let po = Option.map (f (Id.Set.fold g ids e)) rtnpo in CCases (sty, po, List.map (fun (tm,x,y) -> f e tm,x,y) a,bl) | CLetTuple (nal,(ona,po),b,c) -> - let e' = List.fold_right (down_located (name_fold g)) nal e in - let e'' = Option.fold_right (down_located (name_fold g)) ona e in + let e' = List.fold_right (down_located (Name.fold_right g)) nal e in + let e'' = Option.fold_right (down_located (Name.fold_right g)) ona e in CLetTuple (nal,(ona,Option.map (f e'') po),f e b,f e' c) | CIf (c,(ona,po),b1,b2) -> - let e' = Option.fold_right (down_located (name_fold g)) ona e in + let e' = Option.fold_right (down_located (Name.fold_right g)) ona e in CIf (f e c,(ona,Option.map (f e') po),f e b1,f e b2) | CFix (id,dl) -> CFix (id,List.map (fun (id,n,bl,t,d) -> diff --git a/intf/evar_kinds.mli b/intf/evar_kinds.mli index 470ad2a23..ac0d96e96 100644 --- a/intf/evar_kinds.mli +++ b/intf/evar_kinds.mli @@ -8,6 +8,7 @@ open Names open Globnames +open Misctypes (** The kinds of existential variable *) @@ -16,17 +17,19 @@ open Globnames type obligation_definition_status = Define of bool | Expand +type matching_var_kind = FirstOrderPatVar of patvar | SecondOrderPatVar of patvar + type t = | ImplicitArg of global_reference * (int * Id.t option) * bool (** Force inference *) | BinderType of Name.t | NamedHole of Id.t (* coming from some ?[id] syntax *) - | QuestionMark of obligation_definition_status + | QuestionMark of obligation_definition_status * Name.t | CasesType of bool (* true = a subterm of the type *) | InternalHole | TomatchTypeParameter of inductive * int | GoalEvar | ImpossibleCase - | MatchingVar of bool * Id.t + | MatchingVar of matching_var_kind | VarInstance of Id.t | SubEvar of Constr.existential_key diff --git a/intf/glob_term.mli b/intf/glob_term.mli index 33c71884a..5da20c9d1 100644 --- a/intf/glob_term.mli +++ b/intf/glob_term.mli @@ -39,7 +39,7 @@ type glob_constr_r = (** An identifier that cannot be regarded as "GRef". Bound variables are typically represented this way. *) | GEvar of existential_name * (Id.t * glob_constr) list - | GPatVar of bool * patvar (** Used for patterns only *) + | GPatVar of Evar_kinds.matching_var_kind (** Used for patterns only *) | GApp of glob_constr * glob_constr list | GLambda of Name.t * binding_kind * glob_constr * glob_constr | GProd of Name.t * binding_kind * glob_constr * glob_constr diff --git a/intf/tactypes.mli b/intf/tactypes.mli index ef90b911c..5c1d31946 100644 --- a/intf/tactypes.mli +++ b/intf/tactypes.mli @@ -22,8 +22,7 @@ open Misctypes 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 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a type delayed_open_constr = EConstr.constr delayed_open type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 8515d51b0..8bd4b5bfe 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -794,7 +794,7 @@ let drop_parameters depth n argstk = try try_drop_parameters depth n argstk with Not_found -> (* we know that n < stack_args_size(argstk) (if well-typed term) *) - anomaly (Pp.str "ill-typed term: found a match on a partially applied constructor") + anomaly (Pp.str "ill-typed term: found a match on a partially applied constructor.") (** [eta_expand_ind_stack env ind c s t] computes stacks corresponding to the conversion of the eta expansion of t, considered as an inhabitant diff --git a/kernel/cooking.ml b/kernel/cooking.ml index a9f212393..4deadff0a 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -26,7 +26,7 @@ module NamedDecl = Context.Named.Declaration (*s Cooking the constants. *) let pop_dirpath p = match DirPath.repr p with - | [] -> anomaly ~label:"dirpath_prefix" (Pp.str "empty dirpath") + | [] -> anomaly ~label:"dirpath_prefix" (Pp.str "empty dirpath.") | _::l -> DirPath.make l let pop_mind kn = diff --git a/kernel/environ.ml b/kernel/environ.ml index 9986f439a..5727bf2ea 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -342,7 +342,7 @@ let template_polymorphic_pconstant (cst,u) env = let lookup_projection cst env = match (lookup_constant (Projection.constant cst) env).const_proj with | Some pb -> pb - | None -> anomaly (Pp.str "lookup_projection: constant is not a projection") + | None -> anomaly (Pp.str "lookup_projection: constant is not a projection.") let is_projection cst env = match (lookup_constant cst env).const_proj with @@ -546,7 +546,7 @@ let register env field entry = | KInt31 (grp, Int31Type) -> let i31c = match kind_of_term entry with | Ind i31t -> mkConstructUi (i31t, 1) - | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type") + | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type.") in register_one (register_one env (KInt31 (grp,Int31Constructor)) i31c) field entry | field -> register_one env field entry @@ -592,7 +592,7 @@ fun rk value field -> let int31_op_from_const n op prim = match kind_of_term value with | Const kn -> int31_op n op prim kn - | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant") + | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant.") in let int31_binop_from_const op prim = int31_op_from_const 2 op prim in let int31_unop_from_const op prim = int31_op_from_const 1 op prim in @@ -604,20 +604,20 @@ fun rk value field -> match field with | KInt31 (grp, Int31Type) -> Retroknowledge.find rk (KInt31 (grp,Int31Bits)) | _ -> anomaly ~label:"Environ.register" - (Pp.str "add_int31_decompilation_from_type called with an abnormal field") + (Pp.str "add_int31_decompilation_from_type called with an abnormal field.") in let i31bit_type = match kind_of_term int31bit with | Ind (i31bit_type,_) -> i31bit_type | _ -> anomaly ~label:"Environ.register" - (Pp.str "Int31Bits should be an inductive type") + (Pp.str "Int31Bits should be an inductive type.") in let int31_decompilation = match kind_of_term value with | Ind (i31t,_) -> constr_of_int31 i31t i31bit_type | _ -> anomaly ~label:"Environ.register" - (Pp.str "should be an inductive type") + (Pp.str "should be an inductive type.") in { empty_reactive_info with vm_decompile_const = Some int31_decompilation; diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 2ff419338..1e13239bf 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -214,7 +214,7 @@ let param_ccls paramsctxt = *) let typecheck_inductive env mie = let () = match mie.mind_entry_inds with - | [] -> anomaly (Pp.str "empty inductive types declaration") + | [] -> anomaly (Pp.str "empty inductive types declaration.") | _ -> () in (* Check unicity of names *) @@ -313,7 +313,7 @@ let typecheck_inductive env mie = anomaly ~label:"check_inductive" (Pp.str"Incorrect universe " ++ Universe.pr defu ++ Pp.str " declared for inductive type, inferred level is " - ++ Universe.pr infu) + ++ Universe.pr infu ++ Pp.str ".") in RegularArity (not is_natural,full_arity,defu) in @@ -333,7 +333,7 @@ let typecheck_inductive env mie = anomaly ~label:"check_inductive" (Pp.str"Incorrect universe " ++ Universe.pr u ++ Pp.str " declared for inductive type, inferred level is " - ++ Universe.pr clev) + ++ Universe.pr clev ++ Pp.str ".") else TemplateArity (param_ccls paramsctxt, infu) | _ (* Not an explicit occurrence of Type *) -> @@ -389,11 +389,11 @@ let failwith_non_pos n ntypes c = let failwith_non_pos_vect n ntypes v = Array.iter (failwith_non_pos n ntypes) v; - anomaly ~label:"failwith_non_pos_vect" (Pp.str "some k in [n;n+ntypes-1] should occur") + anomaly ~label:"failwith_non_pos_vect" (Pp.str "some k in [n;n+ntypes-1] should occur.") let failwith_non_pos_list n ntypes l = List.iter (failwith_non_pos n ntypes) l; - anomaly ~label:"failwith_non_pos_list" (Pp.str "some k in [n;n+ntypes-1] should occur") + anomaly ~label:"failwith_non_pos_list" (Pp.str "some k in [n;n+ntypes-1] should occur.") (* Check the inductive type is called with the expected parameters *) (* [n] is the index of the last inductive type in [env] *) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 4f4b641b4..f3b03252d 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -75,7 +75,7 @@ let constructor_instantiate mind u mib c = let instantiate_params full t u args sign = let fail () = - anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in + anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch.") in let (rem_args, subs, ty) = Context.Rel.fold_outside (fun decl (largs,subs,ty) -> @@ -1023,7 +1023,7 @@ let check_one_fix renv recpos trees def = check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in check_nested_fix_body renv' (decr-1) recArgsDecrArg b - | _ -> anomaly (Pp.str "Not enough abstractions in fix body") + | _ -> anomaly (Pp.str "Not enough abstractions in fix body.") in check_rec_call renv [] def @@ -1039,7 +1039,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = || not (Int.equal (Array.length names) nbfix) || bodynum < 0 || bodynum >= nbfix - then anomaly (Pp.str "Ill-formed fix term"); + then anomaly (Pp.str "Ill-formed fix term."); let fixenv = push_rec_types recdef env in let vdefj = judgment_of_fixpoint recdef in let raise_err env i err = @@ -1061,7 +1061,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = raise_err env i (RecursionNotOnInductiveType a) in (mind, (env', b)) else check_occur env' (n+1) b - else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call") + else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call.") | _ -> raise_err env i NotEnoughAbstractionInFixBody in check_occur fixenv 1 def in (* Do it on every fixpoint *) @@ -1100,7 +1100,7 @@ let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; exception CoFixGuardError of env * guard_error let anomaly_ill_typed () = - anomaly ~label:"check_one_cofix" (Pp.str "too many arguments applied to constructor") + anomaly ~label:"check_one_cofix" (Pp.str "too many arguments applied to constructor.") let rec codomain_is_coind env c = let b = whd_all env c in diff --git a/kernel/modops.ml b/kernel/modops.ml index 0f0056ed4..1f8b97ae6 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -265,7 +265,7 @@ let add_retroknowledge mp = Environ.register env f e |_ -> CErrors.anomaly ~label:"Modops.add_retroknowledge" - (Pp.str "had to import an unsupported kind of term") + (Pp.str "had to import an unsupported kind of term.") in fun lclrk env -> (* The order of the declaration matters, for instance (and it's at the diff --git a/kernel/names.ml b/kernel/names.ml index afdbe0c0d..d7c0a5e98 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -104,8 +104,12 @@ struct | _ -> false let hash = function - | Anonymous -> 0 - | Name id -> Id.hash id + | Anonymous -> 0 + | Name id -> Id.hash id + + let print = function + | Anonymous -> str "_" + | Name id -> Id.print id module Self_Hashcons = struct @@ -586,7 +590,7 @@ module Constant = KerPair module Cmap = HMap.Make(Constant.CanOrd) (** A map whose keys are constants (values of the {!Constant.t} type). - Keys are ordered wrt. "cannonical form" of the constant. *) + Keys are ordered wrt. "canonical form" of the constant. *) module Cmap_env = HMap.Make(Constant.UserOrd) (** A map whose keys are constants (values of the {!Constant.t} type). diff --git a/kernel/names.mli b/kernel/names.mli index 5b0163aa5..004d52d4b 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -105,6 +105,9 @@ sig val hcons : t -> t (** Hashconsing over names. *) + val print : t -> Pp.std_ppcmds + (** Pretty-printer (print "_" for [Anonymous]. *) + end (** {6 Type aliases} *) @@ -376,9 +379,9 @@ module Cset_env : CSig.SetS with type elt = Constant.t module Cmap : Map.ExtS with type key = Constant.t and module Set := Cset (** A map whose keys are constants (values of the {!Constant.t} type). - Keys are ordered wrt. "cannonical form" of the constant. *) + Keys are ordered wrt. "canonical form" of the constant. *) -module Cmap_env : Map.ExtS with type key = Constant.t and module Set := Cset_env +module Cmap_env : Map.ExtS with type key = Constant.t and module Set := Cset_env (** A map whose keys are constants (values of the {!Constant.t} type). Keys are ordered wrt. "user form" of the constant. *) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 5130aa9a4..d3cd6b62a 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -201,47 +201,47 @@ let empty_symbols = [||] let get_value tbl i = match tbl.(i) with | SymbValue v -> v - | _ -> anomaly (Pp.str "get_value failed") + | _ -> anomaly (Pp.str "get_value failed.") let get_sort tbl i = match tbl.(i) with | SymbSort s -> s - | _ -> anomaly (Pp.str "get_sort failed") + | _ -> anomaly (Pp.str "get_sort failed.") let get_name tbl i = match tbl.(i) with | SymbName id -> id - | _ -> anomaly (Pp.str "get_name failed") + | _ -> anomaly (Pp.str "get_name failed.") let get_const tbl i = match tbl.(i) with | SymbConst kn -> kn - | _ -> anomaly (Pp.str "get_const failed") + | _ -> anomaly (Pp.str "get_const failed.") let get_match tbl i = match tbl.(i) with | SymbMatch case_info -> case_info - | _ -> anomaly (Pp.str "get_match failed") + | _ -> anomaly (Pp.str "get_match failed.") let get_ind tbl i = match tbl.(i) with | SymbInd ind -> ind - | _ -> anomaly (Pp.str "get_ind failed") + | _ -> anomaly (Pp.str "get_ind failed.") let get_meta tbl i = match tbl.(i) with | SymbMeta m -> m - | _ -> anomaly (Pp.str "get_meta failed") + | _ -> anomaly (Pp.str "get_meta failed.") let get_evar tbl i = match tbl.(i) with | SymbEvar ev -> ev - | _ -> anomaly (Pp.str "get_evar failed") + | _ -> anomaly (Pp.str "get_evar failed.") let get_level tbl i = match tbl.(i) with | SymbLevel u -> u - | _ -> anomaly (Pp.str "get_level failed") + | _ -> anomaly (Pp.str "get_level failed.") let push_symbol x = try HashtblSymbol.find symb_tbl x diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 3593d94c2..fe9f393f6 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -144,7 +144,7 @@ let native_conv_gen pb sigma env univs t1 t2 = (* TODO change 0 when we can have de Bruijn *) fst (conv_val env pb 0 !rt1 !rt2 univs) end - | _ -> anomaly (Pp.str "Compilation failure") + | _ -> anomaly (Pp.str "Compilation failure.") let warn_no_native_compiler = let open Pp in diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 26d061768..f6c94158f 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -15,7 +15,7 @@ open Envars used by the native compiler. *) let get_load_paths = - ref (fun _ -> anomaly (Pp.str "get_load_paths not initialized") : unit -> string list) + ref (fun _ -> anomaly (Pp.str "get_load_paths not initialized.") : unit -> string list) let open_header = ["Nativevalues"; "Nativecode"; diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 8d5f6388c..7ffb48221 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -200,7 +200,7 @@ let mk_block tag args = (* Two instances of dummy_value should not be pointer equal, otherwise comparing them as terms would succeed *) let dummy_value : unit -> t = - fun () _ -> anomaly ~label:"native" (Pp.str "Evaluation failed") + fun () _ -> anomaly ~label:"native" (Pp.str "Evaluation failed.") let cast_accu v = (Obj.magic v:accumulator) diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 502a10113..59e90ca2e 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -54,8 +54,8 @@ let create cu = Direct ([],cu) let turn_indirect dp o tab = match o with | Indirect (_,_,i) -> if not (Int.Map.mem i tab.opaque_val) - then CErrors.anomaly (Pp.str "Indirect in a different table") - else CErrors.anomaly (Pp.str "Already an indirect opaque") + then CErrors.anomaly (Pp.str "Indirect in a different table.") + else CErrors.anomaly (Pp.str "Already an indirect opaque.") | Direct (d,cu) -> (** Uncomment to check dynamically that all terms turned into indirections are hashconsed. *) @@ -67,21 +67,21 @@ let turn_indirect dp o tab = match o with if DirPath.equal dp tab.opaque_dir then tab.opaque_dir else if DirPath.equal tab.opaque_dir DirPath.initial then dp else CErrors.anomaly - (Pp.str "Using the same opaque table for multiple dirpaths") in + (Pp.str "Using the same opaque table for multiple dirpaths.") in let ntab = { opaque_val; opaque_dir; opaque_len = id + 1 } in Indirect ([],dp,id), ntab let subst_opaque sub = function | Indirect (s,dp,i) -> Indirect (sub::s,dp,i) - | Direct _ -> CErrors.anomaly (Pp.str "Substituting a Direct opaque") + | Direct _ -> CErrors.anomaly (Pp.str "Substituting a Direct opaque.") let iter_direct_opaque f = function - | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque") + | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") | Direct (d,cu) -> Direct (d,Future.chain ~pure:true cu (fun (c, u) -> f c; c, u)) let discharge_direct_opaque ~cook_constr ci = function - | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque") + | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") | Direct (d,cu) -> Direct (ci::d,Future.chain ~pure:true cu (fun (c, u) -> cook_constr c, u)) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index ba714ada2..427ce04c5 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -324,7 +324,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (match kind_of_term a1, kind_of_term a2 with | (Sort s1, Sort s2) -> if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (Sort)"); + anomaly (Pp.str "conversion was given ill-typed terms (Sort)."); sort_cmp_universes (env_of_infos infos) cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if Int.equal n m @@ -421,7 +421,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* Inconsistency: we tolerate that v1, v2 contain shift and update but we throw them away *) if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (FLambda)"); + anomaly (Pp.str "conversion was given ill-typed terms (FLambda)."); let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in @@ -429,7 +429,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (FProd)"); + anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); (* Luo's system *) let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv @@ -439,7 +439,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let () = match v1 with | [] -> () | _ -> - anomaly (Pp.str "conversion was given unreduced term (FLambda)") + anomaly (Pp.str "conversion was given unreduced term (FLambda).") in let (_,_ty1,bd1) = destFLambda mk_clos hd1 in eqappr CONV l2r infos @@ -448,7 +448,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let () = match v2 with | [] -> () | _ -> - anomaly (Pp.str "conversion was given unreduced term (FLambda)") + anomaly (Pp.str "conversion was given unreduced term (FLambda).") in let (_,_ty2,bd2) = destFLambda mk_clos hd2 in eqappr CONV l2r infos @@ -767,7 +767,7 @@ let betazeta_appvect = lambda_appvect_assum let hnf_prod_app env t n = match kind_of_term (whd_all env t) with | Prod (_,_,b) -> subst1 n b - | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product") + | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product.") let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl diff --git a/kernel/term.ml b/kernel/term.ml index a4296a530..07a85329e 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -456,7 +456,7 @@ let lambda_applist c l = match kind_of_term c, l with | Lambda(_,_,c), arg::l -> app (arg::subst) c l | _, [] -> substl subst c - | _ -> anomaly (Pp.str "Not enough lambda's") in + | _ -> anomaly (Pp.str "Not enough lambda's.") in app [] c l let lambda_appvect c v = lambda_applist c (Array.to_list v) @@ -465,11 +465,11 @@ let lambda_applist_assum n c l = let rec app n subst t l = if Int.equal n 0 then if l == [] then substl subst t - else anomaly (Pp.str "Not enough arguments") + else anomaly (Pp.str "Not enough arguments.") else match kind_of_term t, l with | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l - | _ -> anomaly (Pp.str "Not enough lambda/let's") in + | _ -> anomaly (Pp.str "Not enough lambda/let's.") in app n [] c l let lambda_appvect_assum n c v = lambda_applist_assum n c (Array.to_list v) @@ -480,7 +480,7 @@ let prod_applist c l = match kind_of_term c, l with | Prod(_,_,c), arg::l -> app (arg::subst) c l | _, [] -> substl subst c - | _ -> anomaly (Pp.str "Not enough prod's") in + | _ -> anomaly (Pp.str "Not enough prod's.") in app [] c l (* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) @@ -490,11 +490,11 @@ let prod_applist_assum n c l = let rec app n subst t l = if Int.equal n 0 then if l == [] then substl subst t - else anomaly (Pp.str "Not enough arguments") + else anomaly (Pp.str "Not enough arguments.") else match kind_of_term t, l with | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l - | _ -> anomaly (Pp.str "Not enough prod/let's") in + | _ -> anomaly (Pp.str "Not enough prod/let's.") in app n [] c l let prod_appvect_assum n c v = prod_applist_assum n c (Array.to_list v) @@ -660,7 +660,7 @@ let destArity = | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s - | _ -> anomaly ~label:"destArity" (Pp.str "not an arity") + | _ -> anomaly ~label:"destArity" (Pp.str "not an arity.") in prodec_rec [] diff --git a/kernel/typeops.ml b/kernel/typeops.ml index dbc0dcb73..1a07bb2fc 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -430,10 +430,10 @@ let rec execute env cstr = (* Partial proofs: unsupported by the kernel *) | Meta _ -> - anomaly (Pp.str "the kernel does not support metavariables") + anomaly (Pp.str "the kernel does not support metavariables.") | Evar _ -> - anomaly (Pp.str "the kernel does not support existential variables") + anomaly (Pp.str "the kernel does not support existential variables.") and execute_is_type env constr = let t = execute env constr in diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 6971c0a2b..487257a77 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -132,7 +132,7 @@ let rec repr g u = let a = try UMap.find u g.entries with Not_found -> CErrors.anomaly ~label:"Univ.repr" - (str"Universe " ++ Level.pr u ++ str" undefined") + (str"Universe " ++ Level.pr u ++ str" undefined.") in match a with | Equiv v -> repr g v diff --git a/kernel/univ.ml b/kernel/univ.ml index afe9cbe8d..d53dd8e73 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -781,7 +781,7 @@ let enforce_eq_level u v c = let enforce_eq u v c = match Universe.level u, Universe.level v with | Some u, Some v -> enforce_eq_level u v c - | _ -> anomaly (Pp.str "A universe comparison can only happen between variables") + | _ -> anomaly (Pp.str "A universe comparison can only happen between variables.") let check_univ_eq u v = Universe.equal u v @@ -801,13 +801,13 @@ let constraint_add_leq v u c = else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then if Level.equal x y then (* u+(k+1) <= u *) raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u, None)) - else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints") + else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints.") else if j = 0 then Constraint.add (x,Le,y) c else (* j >= 1 *) (* m = n + k, u <= v+k *) if Level.equal x y then c (* u <= u+k, trivial *) else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) - else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints") + else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints.") let check_univ_leq_one u v = Universe.exists (Expr.leq u) v @@ -982,7 +982,7 @@ let enforce_eq_instances x y = let ax = Instance.to_array x and ay = Instance.to_array y in if Array.length ax != Array.length ay then anomaly (Pp.(++) (Pp.str "Invalid argument: enforce_eq_instances called with") - (Pp.str " instances of different lengths")); + (Pp.str " instances of different lengths.")); CArray.fold_right2 enforce_eq_level ax ay type universe_instance = Instance.t diff --git a/kernel/vars.ml b/kernel/vars.ml index f1c0a4f08..629de80f7 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -175,7 +175,7 @@ let subst_of_rel_context_instance sign l = | LocalDef (_,c,_)::sign', args' -> aux (substl subst c :: subst) sign' args' | [], [] -> subst - | _ -> CErrors.anomaly (Pp.str "Instance and signature do not match") + | _ -> CErrors.anomaly (Pp.str "Instance and signature do not match.") in aux [] (List.rev sign) l let adjust_subst_to_rel_context sign l = diff --git a/kernel/vm.ml b/kernel/vm.ml index 53483a222..21c1225cc 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -236,7 +236,7 @@ let uni_lvl_val (v : values) : Univ.universe_level = in CErrors.anomaly Pp.( strbrk "Parsing virtual machine value expected universe level, got " - ++ pr) + ++ pr ++ str ".") let rec whd_accu a stk = let stk = @@ -285,7 +285,7 @@ let rec whd_accu a stk = end | tg -> CErrors.anomaly - Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg) + Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg ++ str ".") external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" @@ -308,7 +308,7 @@ let whd_val : values -> whd = | 1 -> Vfix(Obj.obj o, None) | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) - | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work")) + | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) else Vconstr_block(Obj.obj o) diff --git a/lib/cEphemeron.ml b/lib/cEphemeron.ml index a38ea11e1..890e02dc4 100644 --- a/lib/cEphemeron.ml +++ b/lib/cEphemeron.ml @@ -35,10 +35,10 @@ end) would make the key always reachable) *) let values : Obj.t HT.t = HT.create 1001 -(* To avoid a race contidion between the finalization function and +(* To avoid a race condition between the finalization function and get/create on the values hashtable, the finalization function just enqueues in an imperative list the item to be collected. Being the list - imperative, even if the Gc enqueue an item while run_collection is operating, + imperative, even if the Gc enqueues an item while run_collection is operating, the tail of the list is eventually set to Empty on completion. Kudos to the authors of Why3 that came up with this solution for their implementation of weak hash tables! *) diff --git a/lib/cEphemeron.mli b/lib/cEphemeron.mli index 1200e4e20..76cd7a5a8 100644 --- a/lib/cEphemeron.mli +++ b/lib/cEphemeron.mli @@ -26,7 +26,7 @@ Proposed solution: Turn all occurrences of [bad] into [bad key] in your data structure. - Use [crate bad_val] to obtain a unique key [k] for [bad_val], and store + Use [create bad_val] to obtain a unique key [k] for [bad_val], and store [k] in the data structure. Use [get k] to obtain [bad_val]. An ['a key] can always be marshalled. When marshalled, a key loses its diff --git a/lib/cErrors.ml b/lib/cErrors.ml index b0e77a4c9..8ef11a2cd 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -77,7 +77,7 @@ let where = function if !Flags.debug then str "in " ++ str s ++ str ":" ++ spc () else mt () let raw_anomaly e = match e with - | Anomaly (s, pps) -> where s ++ pps ++ str "." + | Anomaly (s, pps) -> where s ++ pps | Assert_failure _ | Match_failure _ -> str (Printexc.to_string e) ++ str "." | _ -> str "Uncaught exception " ++ str (Printexc.to_string e) ++ str "." diff --git a/lib/cString.ml b/lib/cString.ml index 61ed03083..7048dbb81 100644 --- a/lib/cString.ml +++ b/lib/cString.ml @@ -11,7 +11,9 @@ module type S = module type of String module type ExtS = sig include S + [@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) external equal : string -> string -> bool = "caml_string_equal" "noalloc" + [@@@ocaml.warning "+3"] val hash : string -> int val is_empty : string -> bool val explode : string -> string list @@ -33,7 +35,9 @@ end include String +[@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) external equal : string -> string -> bool = "caml_string_equal" "noalloc" +[@@@ocaml.warning "+3"] let rec hash len s i accu = if i = len then accu diff --git a/lib/cString.mli b/lib/cString.mli index 65edfbbe6..b30f26abe 100644 --- a/lib/cString.mli +++ b/lib/cString.mli @@ -14,7 +14,10 @@ sig include S (** We include the standard library *) + [@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) external equal : string -> string -> bool = "caml_string_equal" "noalloc" + [@@@ocaml.warning "+3"] + (** Equality on strings *) val hash : string -> int diff --git a/lib/envars.ml b/lib/envars.ml index 79516bb1b..bc8012297 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -23,8 +23,6 @@ let ( / ) a b = let coqify d = d / "coq" -let opt2list = function None -> [] | Some x -> [x] - let home ~warn = getenv_else "HOME" (fun () -> try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found -> @@ -81,9 +79,6 @@ let expand_path_macros ~warn s = (** {2 Coq paths} *) -let relative_base = - Filename.dirname (Filename.dirname Sys.executable_name) - let coqbin = CUnix.canonical_path_name (Filename.dirname Sys.executable_name) @@ -98,25 +93,26 @@ let _ = if Coq_config.arch_is_win32 then Unix.putenv "PATH" (coqbin ^ ";" ^ getenv_else "PATH" (fun () -> "")) +(** Add a local installation suffix (unless the suffix is itself + absolute in which case the prefix does not matter) *) +let use_suffix prefix suffix = + if String.length suffix > 0 && suffix.[0] = '/' then suffix else prefix / suffix + (** [check_file_else ~dir ~file oth] checks if [file] exists in - the installation directory [dir] given relatively to [coqroot]. - If this Coq is only locally built, then [file] must be in [coqroot]. + the installation directory [dir] given relatively to [coqroot], + which maybe has been relocated. If the check fails, then [oth ()] is evaluated. Using file system equality seems well enough for this heuristic *) let check_file_else ~dir ~file oth = - let path = if Coq_config.local then coqroot else coqroot / dir in + let path = use_suffix coqroot dir in if Sys.file_exists (path / file) then path else oth () let guess_coqlib fail = let prelude = "theories/Init/Prelude.vo" in - let dir = if Coq_config.arch_is_win32 then "lib" else "lib/coq" in - check_file_else ~dir ~file:prelude + check_file_else ~dir:Coq_config.coqlibsuffix ~file:prelude (fun () -> - let coqlib = match Coq_config.coqlib with - | Some coqlib -> coqlib - | None -> coqroot - in - if Sys.file_exists (coqlib / prelude) then coqlib + if not Coq_config.local && Sys.file_exists (Coq_config.coqlib / prelude) + then Coq_config.coqlib else fail "cannot guess a path for Coq libraries; please use -coqlib option") @@ -130,8 +126,19 @@ let set_coqlib ~fail = let coqlib () = !Flags.coqlib let docdir () = - let dir = if Coq_config.arch_is_win32 then "doc" else "share/doc/coq" in - check_file_else ~dir ~file:"html" (fun () -> Coq_config.docdir) + (* This assumes implicitly that the suffix is non-trivial *) + let path = use_suffix coqroot Coq_config.docdirsuffix in + if Sys.file_exists path then path else Coq_config.docdir + +let datadir () = + (* This assumes implicitly that the suffix is non-trivial *) + let path = use_suffix coqroot Coq_config.datadirsuffix in + if Sys.file_exists path then path else Coq_config.datadir + +let configdir () = + (* This assumes implicitly that the suffix is non-trivial *) + let path = use_suffix coqroot Coq_config.configdirsuffix in + if Sys.file_exists path then path else Coq_config.configdir let coqpath = let coqpath = getenv_else "COQPATH" (fun () -> "") in @@ -186,20 +193,9 @@ let xdg_data_dirs warn = try List.map coqify (path_to_list (Sys.getenv "XDG_DATA_DIRS")) with - | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "share"] - | Not_found -> ["/usr/local/share/coq";"/usr/share/coq"] - in - xdg_data_home warn :: sys_dirs @ opt2list Coq_config.datadir - -let xdg_config_dirs warn = - let sys_dirs = - try - List.map coqify (path_to_list (Sys.getenv "XDG_CONFIG_DIRS")) - with - | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "config"] - | Not_found -> ["/etc/xdg/coq"] + | Not_found -> [datadir ()] in - xdg_config_home warn :: sys_dirs @ opt2list Coq_config.configdir + xdg_data_home warn :: sys_dirs let xdg_dirs ~warn = List.filter Sys.file_exists (xdg_data_dirs warn) diff --git a/lib/envars.mli b/lib/envars.mli index b164e789d..c8bbf17d9 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -27,12 +27,18 @@ val home : warn:(string -> unit) -> string (** [coqlib] is the path to the Coq library. *) val coqlib : unit -> string +(** [docdir] is the path to the installed documentation. *) +val docdir : unit -> string + +(** [datadir] is the path to the installed data directory. *) +val datadir : unit -> string + +(** [configdir] is the path to the installed config directory. *) +val configdir : unit -> string + (** [set_coqlib] must be runned once before any access to [coqlib] *) val set_coqlib : fail:(string -> string) -> unit -(** [docdir] is the path to the Coq documentation. *) -val docdir : unit -> string - (** [coqbin] is the name of the current executable. *) val coqbin : string @@ -66,7 +72,6 @@ val camlp4 : unit -> string *) val xdg_config_home : (string -> unit) -> string val xdg_data_home : (string -> unit) -> string -val xdg_config_dirs : (string -> unit) -> string list val xdg_data_dirs : (string -> unit) -> string list val xdg_dirs : warn : (string -> unit) -> string list diff --git a/lib/flags.ml b/lib/flags.ml index b2671e5b6..6a3b7a426 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -87,7 +87,6 @@ let in_toplevel = ref false let profile = false -let print_emacs = ref false let xml_export = ref false let ide_slave = ref false diff --git a/lib/flags.mli b/lib/flags.mli index 7ce808041..e2cf09474 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -13,7 +13,9 @@ val boot : bool ref val load_init : bool ref +(* Will affect STM caching *) val batch_mode : bool ref + type compilation_mode = BuildVo | BuildVio | Vio2Vo val compilation_mode : compilation_mode ref val compilation_output_name : string option ref @@ -56,8 +58,6 @@ val profile : bool (* Legacy flags *) -(* -emacs option: printing includes emacs tags, will affect stm caching. *) -val print_emacs : bool ref (* -xml option: xml hooks will be called *) val xml_export : bool ref diff --git a/lib/future.ml b/lib/future.ml index 1360b7ac4..8bef1e58e 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -157,7 +157,7 @@ let chain ~pure ck f = | Val (v, None) -> match !ck with | Finished _ -> CErrors.anomaly(Pp.str - "Future.chain ~pure:false call on an already joined computation") + "Future.chain ~pure:false call on an already joined computation.") | Ongoing _ -> CErrors.anomaly(Pp.strbrk( "Future.chain ~pure:false call on a pure computation. "^ "This can happen if the computation was initial created with "^ @@ -171,7 +171,7 @@ let replace kx y = match !x with | Exn _ -> x := Closure (fun () -> force ~pure:false y) | _ -> CErrors.anomaly - (Pp.str "A computation can be replaced only if is_exn holds") + (Pp.str "A computation can be replaced only if is_exn holds.") let purify f x = let state = !freeze () in @@ -213,7 +213,7 @@ let map2 f x l = let xi = chain ~pure:true x (fun x -> try List.nth x i with Failure _ | Invalid_argument _ -> - CErrors.anomaly (Pp.str "Future.map2 length mismatch")) in + CErrors.anomaly (Pp.str "Future.map2 length mismatch.")) in f xi y) 0 l let print f kx = diff --git a/lib/genarg.ml b/lib/genarg.ml index 05c828d5f..377ff8182 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -159,7 +159,7 @@ let create_arg name = match ArgT.name name with | None -> ExtraArg (ArgT.create name) | Some _ -> - CErrors.anomaly (str "generic argument already declared: " ++ str name) + CErrors.anomaly (str "generic argument already declared: " ++ str name ++ str ".") let make0 = create_arg @@ -180,7 +180,7 @@ struct let register0 arg f = match arg with | ExtraArg s -> if GenMap.mem s !arg0_map then - let msg = str M.name ++ str " function already registered: " ++ str (ArgT.repr s) in + let msg = str M.name ++ str " function already registered: " ++ str (ArgT.repr s) ++ str "." in CErrors.anomaly msg else arg0_map := GenMap.add s (GenMap.Pack f) !arg0_map @@ -192,7 +192,7 @@ struct with Not_found -> match M.default (ExtraArg name) with | None -> - CErrors.anomaly (str M.name ++ str " function not found: " ++ str (ArgT.repr name)) + CErrors.anomaly (str M.name ++ str " function not found: " ++ str (ArgT.repr name) ++ str ".") | Some obj -> obj (** For now, the following function is quite dummy and should only be applied diff --git a/lib/hashcons.ml b/lib/hashcons.ml index 4eaacf914..0ee3ec627 100644 --- a/lib/hashcons.ml +++ b/lib/hashcons.ml @@ -130,7 +130,11 @@ module Hstring = Make( type t = string type u = unit let hashcons () s =(* incr accesstr;*) s + + [@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) external eq : string -> string -> bool = "caml_string_equal" "noalloc" + [@@@ocaml.warning "+3"] + (** Copy from CString *) let rec hash len s i accu = if i = len then accu diff --git a/lib/remoteCounter.ml b/lib/remoteCounter.ml index e7646fb79..11f151a60 100644 --- a/lib/remoteCounter.ml +++ b/lib/remoteCounter.ml @@ -25,7 +25,7 @@ let new_counter ~name a ~incr ~build = (* - in the main process there is a race condition between slave managers (that are threads) and the main thread, hence the mutex *) if Flags.async_proofs_is_worker () then - CErrors.anomaly(Pp.str"Slave processes must install remote counters"); + CErrors.anomaly(Pp.str"Slave processes must install remote counters."); Mutex.lock m; let x = f () in Mutex.unlock m; build x in let mk_thsafe_remote_getter f () = @@ -33,7 +33,7 @@ let new_counter ~name a ~incr ~build = let getter = ref(mk_thsafe_local_getter (fun () -> !data := incr !!data; !!data)) in let installer f = if not (Flags.async_proofs_is_worker ()) then - CErrors.anomaly(Pp.str"Only slave processes can install a remote counter"); + CErrors.anomaly(Pp.str"Only slave processes can install a remote counter."); getter := mk_thsafe_remote_getter f in (fun () -> !getter ()), installer diff --git a/lib/spawn.ml b/lib/spawn.ml index 479176973..4d7e78d86 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -200,7 +200,7 @@ let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ()) p, cout let stats { oob_req; oob_resp; alive } = - assert_ alive "This process is dead"; + assert_ alive "This process is dead."; output_value oob_req ReqStats; flush oob_req; input_value oob_resp @@ -251,7 +251,7 @@ let kill ({ pid = unixpid; oob_req; oob_resp; cin; cout; alive } as p) = with e -> prerr_endline ("kill: "^Printexc.to_string e) end let stats { oob_req; oob_resp; alive } = - assert_ alive "This process is dead"; + assert_ alive "This process is dead."; output_value oob_req ReqStats; flush oob_req; let RespStats g = input_value oob_resp in g diff --git a/library/coqlib.ml b/library/coqlib.ml index 955ff4c08..0cb8c7afc 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -52,14 +52,14 @@ let gen_reference_in_modules locstr dirs s = | [] -> anomaly ~label:locstr (str "cannot find " ++ str s ++ str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ - prlist_with_sep pr_comma pr_dirpath dirs) + prlist_with_sep pr_comma pr_dirpath dirs ++ str ".") | l -> anomaly ~label:locstr (str "ambiguous name " ++ str s ++ str " can represent " ++ prlist_with_sep pr_comma (fun x -> Libnames.pr_path (Nametab.path_of_global x)) l ++ str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ - prlist_with_sep pr_comma pr_dirpath dirs) + prlist_with_sep pr_comma pr_dirpath dirs ++ str ".") (* For tactics/commands requiring vernacular libraries *) @@ -185,7 +185,7 @@ let build_bool_type () = andb_prop = init_reference ["Datatypes"] "andb_prop"; andb_true_intro = init_reference ["Datatypes"] "andb_true_intro" } -let build_sigma_set () = anomaly (Pp.str "Use build_sigma_type") +let build_sigma_set () = anomaly (Pp.str "Use build_sigma_type.") let build_sigma_type () = { proj1 = init_reference ["Specif"] "projT1"; @@ -368,7 +368,7 @@ let coq_eq_ref = lazy (init_reference ["Logic"] "eq") let coq_identity_ref = lazy (init_reference ["Datatypes"] "identity") let coq_jmeq_ref = lazy (find_reference "Coqlib" [coq;"Logic";"JMeq"] "JMeq") let coq_eq_true_ref = lazy (find_reference "Coqlib" [coq;"Init";"Datatypes"] "eq_true") -let coq_existS_ref = lazy (anomaly (Pp.str "use coq_existT_ref")) +let coq_existS_ref = lazy (anomaly (Pp.str "use coq_existT_ref.")) let coq_existT_ref = lazy (init_reference ["Specif"] "existT") let coq_exist_ref = lazy (init_reference ["Specif"] "exist") let coq_not_ref = lazy (init_reference ["Logic"] "not") diff --git a/library/declare.ml b/library/declare.ml index 95b3674c3..7d0edbc8b 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -149,7 +149,7 @@ let cache_constant ((sp,kn), obj) = obj.cst_was_seff <- false; if Global.exists_objlabel (Label.of_id (basename sp)) then constant_of_kn kn - else CErrors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp)) + else CErrors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp) ++ str".") end else let () = check_exists sp in let kn', exported = Global.add_constant dir id obj.cst_decl in @@ -385,7 +385,7 @@ let declare_projections mind = let declare_mind mie = let id = match mie.mind_entry_inds with | ind::_ -> ind.mind_entry_typename - | [] -> anomaly (Pp.str "cannot declare an empty list of inductives") in + | [] -> anomaly (Pp.str "cannot declare an empty list of inductives.") in let (sp,kn as oname) = add_leaf id (inInductive ([],mie)) in let mind = Global.mind_of_delta_kn kn in let isrecord,isprim = declare_projections mind in @@ -400,7 +400,7 @@ let pr_rank i = pr_nth (i+1) let fixpoint_message indexes l = Flags.if_verbose Feedback.msg_info (match l with - | [] -> anomaly (Pp.str "no recursive definition") + | [] -> anomaly (Pp.str "no recursive definition.") | [id] -> pr_id id ++ str " is recursively defined" ++ (match indexes with | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)" diff --git a/library/declaremods.ml b/library/declaremods.ml index 08c33b5c1..c98d4a7f3 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -252,7 +252,7 @@ let in_modkeep : Lib.lib_objects -> obj = let do_modtype i sp mp sobjs = if Nametab.exists_modtype sp then - anomaly (pr_path sp ++ str " already exists"); + anomaly (pr_path sp ++ str " already exists."); Nametab.push_modtype (Nametab.Until i) sp mp; ModSubstObjs.set mp sobjs @@ -883,7 +883,7 @@ let register_library dir cenv (objs:library_objects) digest univ = (* If not, let's do it now ... *) let mp' = Global.import cenv univ digest in if not (ModPath.equal mp mp') then - anomaly (Pp.str "Unexpected disk module name"); + anomaly (Pp.str "Unexpected disk module name."); in let sobjs,keepobjs = objs in do_module false Lib.load_objects 1 dir mp ([],Objs sobjs) keepobjs diff --git a/library/global.ml b/library/global.ml index 5fa710b36..1ba86699d 100644 --- a/library/global.ml +++ b/library/global.ml @@ -44,7 +44,7 @@ let () = let assert_not_parsing () = if !Flags.we_are_parsing then CErrors.anomaly ( - Pp.strbrk"The global environment cannot be accessed during parsing") + Pp.strbrk"The global environment cannot be accessed during parsing.") let safe_env () = assert_not_parsing(); !global_env diff --git a/library/globnames.ml b/library/globnames.ml index a78f5f13a..9aeb37973 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -242,4 +242,4 @@ let pop_global_reference = function | ConstRef con -> ConstRef (pop_con con) | IndRef (kn,i) -> IndRef (pop_kn kn,i) | ConstructRef ((kn,i),j) -> ConstructRef ((pop_kn kn,i),j) - | VarRef id -> anomaly (Pp.str "VarRef not poppable") + | VarRef id -> anomaly (Pp.str "VarRef not poppable.") diff --git a/library/goptions.ml b/library/goptions.ml index a803771cb..a305214e8 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -273,23 +273,23 @@ type 'a write_function = 'a -> unit let declare_int_option = declare_option (fun v -> IntValue v) - (function IntValue v -> v | _ -> anomaly (Pp.str "async_option")) - (fun _ _ -> anomaly (Pp.str "async_option")) + (function IntValue v -> v | _ -> anomaly (Pp.str "async_option.")) + (fun _ _ -> anomaly (Pp.str "async_option.")) let declare_bool_option = declare_option (fun v -> BoolValue v) - (function BoolValue v -> v | _ -> anomaly (Pp.str "async_option")) - (fun _ _ -> anomaly (Pp.str "async_option")) + (function BoolValue v -> v | _ -> anomaly (Pp.str "async_option.")) + (fun _ _ -> anomaly (Pp.str "async_option.")) let declare_string_option = declare_option (fun v -> StringValue v) - (function StringValue v -> v | _ -> anomaly (Pp.str "async_option")) + (function StringValue v -> v | _ -> anomaly (Pp.str "async_option.")) (fun x y -> x^","^y) let declare_stringopt_option = declare_option (fun v -> StringOptValue v) - (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option")) - (fun _ _ -> anomaly (Pp.str "async_option")) + (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option.")) + (fun _ _ -> anomaly (Pp.str "async_option.")) (* 3- User accessible commands *) diff --git a/library/heads.ml b/library/heads.ml index 02465f22f..6aee63c74 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -72,7 +72,8 @@ let kind_of_head env t = with Not_found -> CErrors.anomaly Pp.(str "constant not found in kind_of_head: " ++ - str (Names.Constant.to_string cst))) + Names.Constant.print cst ++ + str ".")) | Construct _ | CoFix _ -> if b then NotImmediatelyComputableHead else ConstructorHead | Sort _ | Ind _ | Prod _ -> RigidHead RigidType diff --git a/library/impargs.ml b/library/impargs.ml index 885185da1..8f3bfc17e 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -291,16 +291,16 @@ let is_status_implicit = function | _ -> true let name_of_implicit = function - | None -> anomaly (Pp.str "Not an implicit argument") + | None -> anomaly (Pp.str "Not an implicit argument.") | Some (id,_,_) -> id let maximal_insertion_of = function | Some (_,_,(b,_)) -> b - | None -> anomaly (Pp.str "Not an implicit argument") + | None -> anomaly (Pp.str "Not an implicit argument.") let force_inference_of = function | Some (_, _, (_, b)) -> b - | None -> anomaly (Pp.str "Not an implicit argument") + | None -> anomaly (Pp.str "Not an implicit argument.") (* [in_ctx] means we know the expected type, [n] is the index of the argument *) let is_inferable_implicit in_ctx n = function @@ -324,7 +324,7 @@ let positions_of_implicits (_,impls) = let rec prepare_implicits f = function | [] -> [] - | (Anonymous, Some _)::_ -> anomaly (Pp.str "Unnamed implicit") + | (Anonymous, Some _)::_ -> anomaly (Pp.str "Unnamed implicit.") | (Name id, Some imp)::imps -> let imps' = prepare_implicits f imps in Some (id,imp,(set_maximality imps' f.maximal,true)) :: imps' diff --git a/library/kindops.ml b/library/kindops.ml index 21b1bec33..623d2537a 100644 --- a/library/kindops.ml +++ b/library/kindops.ml @@ -25,7 +25,7 @@ let string_of_theorem_kind = function let string_of_definition_kind def = let (locality, poly, kind) = def in - let error () = CErrors.anomaly (Pp.str "Internal definition kind") in + let error () = CErrors.anomaly (Pp.str "Internal definition kind.") in match kind with | Definition -> begin match locality with @@ -64,4 +64,4 @@ let string_of_definition_kind def = | Global -> "Global Instance" end | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> - CErrors.anomaly (Pp.str "Internal definition kind") + CErrors.anomaly (Pp.str "Internal definition kind.") diff --git a/library/lib.ml b/library/lib.ml index 4ad4e261d..9d71a854f 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -350,7 +350,7 @@ let end_compilation_checks dir = try match find_entry_p is_opening_lib with | (oname, CompilingLibrary prefix) -> oname | _ -> assert false - with Not_found -> anomaly (Pp.str "No module declared") + with Not_found -> anomaly (Pp.str "No module declared.") in let _ = match !lib_state.comp_name with @@ -358,7 +358,7 @@ let end_compilation_checks dir = | Some m -> if not (Names.DirPath.equal m dir) then anomaly (str "The current open module has name" ++ spc () ++ pr_dirpath m ++ - spc () ++ str "and not" ++ spc () ++ pr_dirpath m); + spc () ++ str "and not" ++ spc () ++ pr_dirpath m ++ str "."); in oname @@ -547,7 +547,7 @@ let discharge_item ((sp,_ as oname),e) = | FrozenState _ -> None | ClosedSection _ | ClosedModule _ -> None | OpenedSection _ | OpenedModule _ | CompilingLibrary _ -> - anomaly (Pp.str "discharge_item") + anomaly (Pp.str "discharge_item.") let close_section () = let oname,fs = diff --git a/library/loadpath.ml b/library/loadpath.ml index 529b9502b..ad429ea84 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -29,7 +29,7 @@ let physical p = p.path_physical let get_load_paths () = !load_paths let anomaly_too_many_paths path = - anomaly (str "Several logical paths are associated to" ++ spc () ++ str path) + anomaly (str "Several logical paths are associated to" ++ spc () ++ str path ++ str ".") let find_load_path phys_dir = let phys_dir = CUnix.canonical_path_name phys_dir in diff --git a/library/nameops.ml b/library/nameops.ml index 098f5112f..0b5dfd8d0 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open Util open Names @@ -14,10 +13,6 @@ open Names let pr_id id = Id.print id -let pr_name = function - | Anonymous -> str "_" - | Name id -> pr_id id - (* Utilities *) let code_of_0 = Char.code '0' @@ -124,34 +119,82 @@ let atompart_of_id id = fst (repr_ident id) (* Names *) -let out_name = function - | Name id -> id - | Anonymous -> failwith "Nameops.out_name" +module type ExtName = +sig + + include module type of struct include Names.Name end + + exception IsAnonymous + + val fold_left : ('a -> Id.t -> 'a) -> 'a -> t -> 'a + val fold_right : (Id.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter : (Id.t -> unit) -> t -> unit + val map : (Id.t -> Id.t) -> t -> t + val fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> t -> 'a * t + val get_id : t -> Id.t + val pick : t -> t -> t + val cons : t -> Id.t list -> Id.t list + val to_option : Name.t -> Id.t option + +end + +module Name : ExtName = +struct + + include Names.Name + + exception IsAnonymous + + let fold_left f a = function + | Name id -> f a id + | Anonymous -> a + + let fold_right f na a = + match na with + | Name id -> f id a + | Anonymous -> a + + let iter f na = fold_right (fun x () -> f x) na () + + let map f = function + | Name id -> Name (f id) + | Anonymous -> Anonymous + + let fold_map f a = function + | Name id -> let (a, id) = f a id in (a, Name id) + | Anonymous -> a, Anonymous + + let get_id = function + | Name id -> id + | Anonymous -> raise IsAnonymous -let name_fold f na a = - match na with - | Name id -> f id a - | Anonymous -> a + let pick na1 na2 = + match na1 with + | Name _ -> na1 + | Anonymous -> na2 -let name_iter f na = name_fold (fun x () -> f x) na () + let cons na l = + match na with + | Anonymous -> l + | Name id -> id::l -let name_cons na l = - match na with - | Anonymous -> l - | Name id -> id::l + let to_option = function + | Anonymous -> None + | Name id -> Some id -let name_app f = function - | Name id -> Name (f id) - | Anonymous -> Anonymous +end -let name_fold_map f e = function - | Name id -> let (e,id) = f e id in (e,Name id) - | Anonymous -> e,Anonymous +open Name -let name_max na1 na2 = - match na1 with - | Name _ -> na1 - | Anonymous -> na2 +(* Compatibility *) +let out_name = get_id +let name_fold = fold_right +let name_iter = iter +let name_app = map +let name_fold_map = fold_map +let name_cons = cons +let name_max = pick +let pr_name = print let pr_lab l = Label.print l diff --git a/library/nameops.mli b/library/nameops.mli index 3a67b61a1..abfc09db8 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -9,8 +9,6 @@ open Names (** Identifiers and names *) -val pr_id : Id.t -> Pp.std_ppcmds -val pr_name : Name.t -> Pp.std_ppcmds val make_ident : string -> int option -> Id.t val repr_ident : Id.t -> string * int option @@ -50,16 +48,69 @@ val increment_subscript : Id.t -> Id.t val forget_subscript : Id.t -> Id.t +module Name : sig + + include module type of struct include Names.Name end + + exception IsAnonymous + + val fold_left : ('a -> Id.t -> 'a) -> 'a -> Name.t -> 'a + (** [fold_left f na a] is [f id a] if [na] is [Name id], and [a] otherwise. *) + + val fold_right : (Id.t -> 'a -> 'a) -> Name.t -> 'a -> 'a + (** [fold_right f a na] is [f a id] if [na] is [Name id], and [a] otherwise. *) + + val iter : (Id.t -> unit) -> Name.t -> unit + (** [iter f na] does [f id] if [na] equals [Name id], nothing otherwise. *) + + val map : (Id.t -> Id.t) -> Name.t -> t + (** [map f na] is [Anonymous] if [na] is [Anonymous] and [Name (f id)] if [na] is [Name id]. *) + + val fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t + (** [fold_map f na a] is [a',Name id'] when [na] is [Name id] and [f a id] is [(a',id')]. + It is [a,Anonymous] otherwise. *) + + val get_id : Name.t -> Id.t + (** [get_id] associates [id] to [Name id]. @raise IsAnonymous otherwise. *) + + val pick : Name.t -> Name.t -> Name.t + (** [pick na na'] returns [Anonymous] if both names are [Anonymous]. + Pick one of [na] or [na'] otherwise. *) + + val cons : Name.t -> Id.t list -> Id.t list + (** [cons na l] returns [id::l] if [na] is [Name id] and [l] otherwise. *) + + val to_option : Name.t -> Id.t option + (** [to_option Anonymous] is [None] and [to_option (Name id)] is [Some id] *) + +end + val out_name : Name.t -> Id.t -(** [out_name] associates [id] to [Name id]. Raises [Failure "Nameops.out_name"] - otherwise. *) +(** @deprecated Same as [Name.get_id] *) val name_fold : (Id.t -> 'a -> 'a) -> Name.t -> 'a -> 'a +(** @deprecated Same as [Name.fold_right] *) + val name_iter : (Id.t -> unit) -> Name.t -> unit -val name_cons : Name.t -> Id.t list -> Id.t list +(** @deprecated Same as [Name.iter] *) + val name_app : (Id.t -> Id.t) -> Name.t -> Name.t +(** @deprecated Same as [Name.map] *) + val name_fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t +(** @deprecated Same as [Name.fold_map] *) + val name_max : Name.t -> Name.t -> Name.t +(** @deprecated Same as [Name.pick] *) + +val name_cons : Name.t -> Id.t list -> Id.t list +(** @deprecated Same as [Name.cons] *) + +val pr_name : Name.t -> Pp.std_ppcmds +(** @deprecated Same as [Name.print] *) + +val pr_id : Id.t -> Pp.std_ppcmds +(** @deprecated Same as [Names.Id.print] *) val pr_lab : Label.t -> Pp.std_ppcmds diff --git a/library/nametab.ml b/library/nametab.ml index 2e4e98013..93e9c03ce 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -294,7 +294,7 @@ module DirPath' = struct include DirPath let repr dir = match DirPath.repr dir with - | [] -> anomaly (Pp.str "Empty dirpath") + | [] -> anomaly (Pp.str "Empty dirpath.") | id :: l -> (id, l) end diff --git a/library/summary.ml b/library/summary.ml index d9f644100..c7bf95fd4 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -46,7 +46,7 @@ let declare_summary sumname decl = let () = if Int.Map.mem hash !summaries then let (name, _) = Int.Map.find hash !summaries in anomaly ~label:"Summary.declare_summary" - (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str name) + (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str name ++ str ".") in all_declared_summaries := Int.Set.add hash !all_declared_summaries; summary_names := (hash, sumname) :: !summary_names; @@ -85,10 +85,10 @@ let unfreeze_summaries fs = * may modify the content of [summaries] ny loading new ML modules *) let (_, decl) = try Int.Map.find ml_modules_summary !summaries - with Not_found -> anomaly (str "Undeclared summary " ++ str ml_modules) + with Not_found -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".") in let () = match fs.ml_module with - | None -> anomaly (str "Undeclared summary " ++ str ml_modules) + | None -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".") | Some state -> decl.unfreeze_function state in let fold id (_, decl) states = diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 6940fd6fb..890ce2dec 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -298,7 +298,7 @@ let interp_entry forpat e = match e with | ETName -> TTAny TTName | ETReference -> TTAny TTReference | ETBigint -> TTAny TTBigint -| ETBinder true -> anomaly (Pp.str "Should occur only as part of BinderList") +| ETBinder true -> anomaly (Pp.str "Should occur only as part of BinderList.") | ETBinder false -> TTAny TTBinder | ETConstr p -> TTAny (TTConstr (p, forpat)) | ETPattern -> assert false (** not used *) diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 9a4766c0b..20601f900 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -338,7 +338,7 @@ module Gram = let rec remove_grammars n = if n>0 then (match !camlp4_state with - | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove") + | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove.") | ByGrammar (ExtendRule (g, reinit, ext)) :: t -> grammar_delete g reinit (of_coq_extend_statement ext); camlp4_state := t; diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 33a9dd4fd..6281b2675 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -1,5 +1,3 @@ -open Proofview.Notations - let contrib_name = "btauto" let init_constant dir s = @@ -219,7 +217,7 @@ module Btauto = struct Tacticals.tclFAIL 0 msg gl let try_unification env = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in let concl = EConstr.Unsafe.to_constr concl in @@ -232,10 +230,10 @@ module Btauto = struct | _ -> let msg = str "Btauto: Internal error" in Tacticals.New.tclFAIL 0 msg - end } + end let tac = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let concl = Proofview.Goal.concl gl in let concl = EConstr.Unsafe.to_constr concl in let sigma = Tacmach.New.project gl in @@ -262,6 +260,6 @@ module Btauto = struct | _ -> let msg = str "Cannot recognize a boolean equality" in Tacticals.New.tclFAIL 0 msg - end } + end end diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 5dea4631c..ba398c385 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -61,7 +61,7 @@ module ST=struct let enter t sign st= if IntPairTable.mem st.toterm sign then - anomaly ~label:"enter" (Pp.str "signature already entered") + anomaly ~label:"enter" (Pp.str "signature already entered.") else IntPairTable.replace st.toterm sign t; IntTable.replace st.tosign t sign @@ -321,7 +321,7 @@ let find uf i= find_aux uf [] i let get_representative uf i= match uf.map.(i).clas with Rep r -> r - | _ -> anomaly ~label:"get_representative" (Pp.str "not a representative") + | _ -> anomaly ~label:"get_representative" (Pp.str "not a representative.") let get_constructors uf i= uf.map.(i).constructors @@ -339,7 +339,7 @@ let rec find_oldest_pac uf i pac= let get_constructor_info uf i= match uf.map.(i).term with Constructor cinfo->cinfo - | _ -> anomaly ~label:"get_constructor" (Pp.str "not a constructor") + | _ -> anomaly ~label:"get_constructor" (Pp.str "not a constructor.") let size uf i= (get_representative uf i).weight @@ -384,7 +384,7 @@ let term uf i=uf.map.(i).term let subterms uf i= match uf.map.(i).vertex with Node(j,k) -> (j,k) - | _ -> anomaly ~label:"subterms" (Pp.str "not a node") + | _ -> anomaly ~label:"subterms" (Pp.str "not a node.") let signature uf i= let j,k=subterms uf i in (find uf j,find uf k) @@ -485,7 +485,7 @@ let build_subst uf subst = (fun i -> try term uf i with e when CErrors.noncritical e -> - anomaly (Pp.str "incomplete matching")) + anomaly (Pp.str "incomplete matching.")) subst let rec inst_pattern subst = function @@ -750,7 +750,7 @@ let process_constructor_mark t i rep pac state = state.combine; f (n-1) q1 q2 | _-> anomaly ~label:"add_pacs" - (Pp.str "weird error in injection subterms merge") + (Pp.str "weird error in injection subterms merge.") in f cinfo.ci_nhyps opac.args pac.args | Partial_applied | Partial _ -> (* add_pac state.uf.map.(i) pac t; *) @@ -841,7 +841,7 @@ let complete_one_class state i= let ct = app (term state.uf i) typ pac.arity in state.uf.epsilons <- pac :: state.uf.epsilons; ignore (add_term state ct) - | _ -> anomaly (Pp.str "wrong incomplete class") + | _ -> anomaly (Pp.str "wrong incomplete class.") let complete state = Int.Set.iter (complete_one_class state) state.pa_classes @@ -981,7 +981,7 @@ let find_instances state = Control.check_for_interrupt (); do_match state res pb_stack done; - anomaly (Pp.str "get out of here !") + anomaly (Pp.str "get out of here!") with Stack.Empty -> () in !res diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index f58847caf..642ceba3d 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -47,7 +47,7 @@ let rec ptrans p1 p3= {p_lhs=p1.p_lhs; p_rhs=p3.p_rhs; p_rule=Trans (p1,p3)} - else anomaly (Pp.str "invalid cc transitivity") + else anomaly (Pp.str "invalid cc transitivity.") let rec psym p = match p.p_rule with @@ -85,7 +85,7 @@ let rec nth_arg t n= if n>0 then nth_arg t1 (n-1) else t2 - | _ -> anomaly ~label:"nth_arg" (Pp.str "not enough args") + | _ -> anomaly ~label:"nth_arg" (Pp.str "not enough args.") let pinject p c n a = {p_lhs=nth_arg p.p_lhs (n-a); diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index b3017f359..b638f2360 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -231,9 +231,9 @@ let make_prb gls depth additionnal_terms = let build_projection intype (cstr:pconstructor) special default gls= let open Tacmach.New in let ci= (snd(fst cstr)) in - let body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in + let sigma, body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in let id=pf_get_new_id (Id.of_string "t") gls in - mkLambda(Name id,intype,body) + sigma, mkLambda(Name id,intype,body) (* generate an adhoc tactic following the proof tree *) @@ -241,24 +241,20 @@ let app_global f args k = Tacticals.New.pf_constr_of_global (Lazy.force f) >>= fun fc -> k (mkApp (fc, args)) let rec gen_holes env sigma t n accu = - let open Sigma in if Int.equal n 0 then (sigma, List.rev accu) else match EConstr.kind sigma t with | Prod (_, u, t) -> - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (ev, sigma, _) = Evarutil.new_evar env sigma u in - let sigma = Sigma.to_evar_map sigma in + let (sigma, ev) = Evarutil.new_evar env sigma u in let t = EConstr.Vars.subst1 ev t in gen_holes env sigma t (pred n) (ev :: accu) | _ -> assert false let app_global_with_holes f args n = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.pf_constr_of_global (Lazy.force f) >>= fun fc -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - Refine.refine { Sigma.run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in + Refine.refine begin fun sigma -> let t = Tacmach.New.pf_get_type_of gl fc in let t = Termops.prod_applist sigma t (Array.to_list args) in let ans = mkApp (fc, args) in @@ -266,32 +262,33 @@ let app_global_with_holes f args n = let ans = applist (ans, holes) in let evdref = ref sigma in let () = Typing.e_check env evdref ans concl in - Sigma.Unsafe.of_pair (ans, !evdref) - end } - end } + (!evdref, ans) + end + end let assert_before n c = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let evm, _ = Tacmach.New.pf_apply type_of gl c in - Sigma.Unsafe.of_pair (assert_before n c, evm) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) + (assert_before n c) + end let refresh_type env evm ty = Evarsolve.refresh_universes ~status:Evd.univ_flexible ~refreshset:true (Some false) env evm ty let refresh_universes ty k = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in let evm, ty = refresh_type env evm ty in - Sigma.Unsafe.of_pair (k ty, evm) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) (k ty) + end let constr_of_term c = EConstr.of_constr (constr_of_term c) let rec proof_tac p : unit Proofview.tactic = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of t = Tacmach.New.pf_unsafe_type_of gl t in try (* type_of can raise exceptions *) match p.p_rule with @@ -346,17 +343,18 @@ let rec proof_tac p : unit Proofview.tactic = let special=mkRel (1+nargs-argind) in refresh_universes (type_of ti) (fun intype -> refresh_universes (type_of default) (fun outtype -> - let proj = + let sigma, proj = build_projection intype cstr special default gl in let injt= app_global_with_holes _f_equal [|intype;outtype;proj;ti;tj|] 1 in - Tacticals.New.tclTHEN injt (proof_tac prf))) + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHEN injt (proof_tac prf)))) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e - end } + end let refute_tac c t1 t2 p = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let hid = Tacmach.New.pf_get_new_id (Id.of_string "Heq") gl in let false_t=mkApp (c,[|mkVar hid|]) in @@ -365,16 +363,16 @@ let refute_tac c t1 t2 p = Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; simplest_elim false_t] in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt1) k - end } + end let refine_exact_check c = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let evm, _ = Tacmach.New.pf_apply type_of gl c in - Sigma.Unsafe.of_pair (exact_check c, evm) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) (exact_check c) + end let convert_to_goal_tac c t1 t2 p = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let k sort = let neweq= app_global _eq [|sort;tt1;tt2|] in @@ -385,21 +383,21 @@ let convert_to_goal_tac c t1 t2 p = Tacticals.New.tclTHENS (neweq (assert_before (Name e))) [proof_tac p; endt refine_exact_check] in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k - end } + end let convert_to_hyp_tac c1 t1 c2 t2 p = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let tt2=constr_of_term t2 in let h = Tacmach.New.pf_get_new_id (Id.of_string "H") gl in let false_t=mkApp (c2,[|mkVar h|]) in Tacticals.New.tclTHENS (assert_before (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] - end } + end (* Essentially [assert (Heq : lhs = rhs) by proof_tac p; discriminate Heq] *) let discriminate_tac cstru p = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let lhs=constr_of_term p.p_lhs and rhs=constr_of_term p.p_rhs in let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in @@ -409,7 +407,7 @@ let discriminate_tac cstru p = Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) (Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; Equality.discrHyp hid]) - end } + end (* wrap everything *) @@ -420,7 +418,7 @@ let build_term_to_complete uf pac = (applist (mkConstructU (kn, EInstance.make u), real_args), pac.arity) let cc_tactic depth additionnal_terms = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in Coqlib.check_required_library Coqlib.logic_module_name; let _ = debug (fun () -> Pp.str "Reading subgoal ...") in @@ -476,7 +474,7 @@ let cc_tactic depth additionnal_terms = let ida = EConstr.of_constr ida in let idb = EConstr.of_constr idb in convert_to_hyp_tac ida ta idb tb p - end } + end let cc_fail = Tacticals.New.tclZEROMSG (Pp.str "congruence failed.") @@ -499,17 +497,17 @@ let congruence_tac depth l = let mk_eq f c1 c2 k = Tacticals.New.pf_constr_of_global (Lazy.force f) >>= fun fc -> - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let open Tacmach.New in let evm, ty = pf_apply type_of gl c1 in let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in let term = mkApp (fc, [| ty; c1; c2 |]) in let evm, _ = type_of (pf_env gl) evm term in - Sigma.Unsafe.of_pair (k term, evm) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) (k term) + end let f_equal = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let cut_eq c1 c2 = @@ -536,4 +534,4 @@ let f_equal = | Pretype_errors.PretypeError _ | Type_errors.TypeError _ -> Proofview.tclUNIT () | e -> Proofview.tclZERO ~info e end - end } + end diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index fc8d5356c..c498eb589 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -109,12 +109,17 @@ let pseudo_qualify = qualify "__" let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false -let lowercase_id id = Id.of_string (String.uncapitalize (ascii_of_id id)) +[@@@ocaml.warning "-3"] (* String.(un)capitalize_ascii since 4.03.0 GPR#124 *) +let capitalize = String.capitalize +let uncapitalize = String.uncapitalize +[@@@ocaml.warning "+3"] + +let lowercase_id id = Id.of_string (uncapitalize (ascii_of_id id)) let uppercase_id id = let s = ascii_of_id id in assert (not (String.is_empty s)); if s.[0] == '_' then Id.of_string ("Coq_"^s) - else Id.of_string (String.capitalize s) + else Id.of_string (capitalize s) type kind = Term | Type | Cons | Mod diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index b580fb592..eb13fd675 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -20,9 +20,10 @@ open Mlutil open Common (*s Haskell renaming issues. *) - +[@@@ocaml.warning "-3"] (* String.(un)capitalize_ascii since 4.03.0 GPR#124 *) let pr_lower_id id = str (String.uncapitalize (Id.to_string id)) let pr_upper_id id = str (String.capitalize (Id.to_string id)) +[@@@ocaml.warning "+3"] let keywords = List.fold_right (fun s -> Id.Set.add (Id.of_string s)) diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 60fe8e762..b67b9931e 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -19,7 +19,7 @@ open Mlutil let rec msid_of_mt = function | MTident mp -> mp | MTwith(mt,_)-> msid_of_mt mt - | _ -> anomaly ~label:"extraction" (Pp.str "the With operator isn't applied to a name") + | _ -> anomaly ~label:"extraction" (Pp.str "the With operator isn't applied to a name.") (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a [ml_structure]. *) @@ -231,7 +231,7 @@ let get_decl_in_structure r struc = | _ -> error_not_visible r in go ll sel with Not_found -> - anomaly (Pp.str "reference not found in extracted structure") + anomaly (Pp.str "reference not found in extracted structure.") (*s Optimization of a [ml_structure]. *) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index fc1ed335a..29dd8ff4f 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -20,6 +20,11 @@ open Util open Pp open Miniml +[@@@ocaml.warning "-3"] (* String.capitalize_ascii since 4.03.0 GPR#124 *) +let capitalize = String.capitalize +[@@@ocaml.warning "+3"] + + (** Sets and maps for [global_reference] that use the "user" [kernel_name] instead of the canonical one *) @@ -55,7 +60,7 @@ let is_modfile = function | _ -> false let raw_string_of_modfile = function - | MPfile f -> String.capitalize (Id.to_string (List.hd (DirPath.repr f))) + | MPfile f -> capitalize (Id.to_string (List.hd (DirPath.repr f))) | _ -> assert false let is_toplevel mp = @@ -256,7 +261,7 @@ let safe_basename_of_global r = let last_chance r = try Nametab.basename_of_global r with Not_found -> - anomaly (Pp.str "Inductive object unknown to extraction and not globally visible") + anomaly (Pp.str "Inductive object unknown to extraction and not globally visible.") in match r with | ConstRef kn -> Label.to_id (con_label kn) @@ -772,7 +777,7 @@ let file_of_modfile mp = let add_blacklist_entries l = blacklist_table := - List.fold_right (fun s -> Id.Set.add (Id.of_string (String.capitalize s))) + List.fold_right (fun s -> Id.Set.add (Id.of_string (capitalize s))) l !blacklist_table (* Registration of operations for rollback. *) diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index bbb9feae2..e3fab6d01 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -15,7 +15,6 @@ open Ground open Goptions open Tacmach.New open Tacticals.New -open Proofview.Notations open Tacinterp open Libnames open Stdarg @@ -84,24 +83,24 @@ let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") let gen_ground_tac flag taco ids bases = let backup= !qflag in Proofview.tclOR begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> qflag:=flag; let solver= match taco with Some tac-> tac | None-> snd (default_solver ()) in let startseq k = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let seq=empty_seq !ground_depth in let seq, sigma = extend_with_ref_list (pf_env gl) (project gl) ids seq in let seq, sigma = extend_with_auto_hints (pf_env gl) (project gl) bases seq in - Sigma.Unsafe.of_pair (k seq, sigma) - end } + tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k seq) + end in let result=ground_tac solver startseq in qflag := backup; result - end } + end end (fun (e, info) -> qflag := backup; Proofview.tclZERO ~info e) diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index ab1dd07c1..0fa3089e7 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -14,7 +14,6 @@ open Instances open Term open Tacmach.New open Tacticals.New -open Proofview.Notations let update_flags ()= let predref=ref Names.Cpred.empty in @@ -31,10 +30,10 @@ let update_flags ()= (Names.Id.Pred.full,Names.Cpred.complement !predref) let ground_tac solver startseq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> update_flags (); let rec toptac skipped seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let () = if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then @@ -127,7 +126,7 @@ let ground_tac solver startseq = end with Heap.EmptyHeap->solver end - end } in + end in let n = List.length (Proofview.Goal.hyps gl) in startseq (fun seq -> wrap n true (toptac []) seq) - end } + end diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 4c6355f61..e1d765a42 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -21,7 +21,6 @@ open Formula open Sequent open Names open Misctypes -open Sigma.Notations open Context.Rel.Declaration let compare_instance inst1 inst2= @@ -77,7 +76,7 @@ let match_one_quantified_hyp sigma setref seq lf= Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> if do_sequent sigma setref triv lf.id seq i dom lf.atoms then setref:=IS.add ((Phantom dom),lf.id) !setref - | _ -> anomaly (Pp.str "can't happen") + | _ -> anomaly (Pp.str "can't happen.") let give_instances sigma lf seq= let setref=ref IS.empty in @@ -114,9 +113,7 @@ let mk_open_instance env evmap id idc m t = let rec aux n avoid env evmap decls = if Int.equal n 0 then evmap, decls else let nid=(fresh_id_in_env avoid var_id env) in - let evmap = Sigma.Unsafe.of_evar_map evmap in - let Sigma ((c, _), evmap, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in - let evmap = Sigma.to_evar_map evmap in + let (evmap, (c, _)) = Evarutil.new_type_evar env evmap Evd.univ_flexible in let decl = LocalAssum (Name nid, c) in aux (n-1) (nid::avoid) (EConstr.push_rel decl env) evmap (decl::decls) in let evmap, decls = aux m [] env evmap [] in @@ -126,7 +123,7 @@ let mk_open_instance env evmap id idc m t = let left_instance_tac (inst,id) continue seq= let open EConstr in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in match inst with Phantom dom-> @@ -137,10 +134,10 @@ let left_instance_tac (inst,id) continue seq= [tclTHENLIST [introf; (pf_constr_of_global id >>= fun idc -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let id0 = List.nth (pf_ids_of_hyps gl) 0 in generalize [mkApp(idc, [|mkVar id0|])] - end }); + end); introf; tclSOLVE [wrap 1 false continue (deepen (record (id,None) seq))]]; @@ -153,7 +150,7 @@ let left_instance_tac (inst,id) continue seq= let special_generalize= if m>0 then (pf_constr_of_global id >>= fun idc -> - Proofview.Goal.s_enter { s_enter = begin fun gl-> + Proofview.Goal.enter begin fun gl-> let (evmap, rc, ot) = mk_open_instance (pf_env gl) (project gl) id idc m t in let gt= it_mkLambda_or_LetIn @@ -162,8 +159,9 @@ let left_instance_tac (inst,id) continue seq= try Typing.type_of (pf_env gl) evmap gt with e when CErrors.noncritical e -> user_err Pp.(str "Untypable instance, maybe higher-order non-prenex quantification") in - Sigma.Unsafe.of_pair (generalize [gt], evmap) - end }) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evmap) + (generalize [gt]) + end) else pf_constr_of_global id >>= fun idc -> generalize [mkApp(idc,[|t|])] in @@ -172,20 +170,20 @@ let left_instance_tac (inst,id) continue seq= introf; tclSOLVE [wrap 1 false continue (deepen (record (id,Some c) seq))]] - end } + end let right_instance_tac inst continue seq= let open EConstr in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> match inst with Phantom dom -> tclTHENS (cut dom) [tclTHENLIST [introf; - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let id0 = List.nth (pf_ids_of_hyps gl) 0 in split (ImplicitBindings [mkVar id0]) - end }; + end; tclSOLVE [wrap 0 true continue (deepen seq)]]; tclTRY assumption] | Real ((0,t),_) -> @@ -193,7 +191,7 @@ let right_instance_tac inst continue seq= (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") - end } + end let instance_tac inst= if (snd inst)==dummy_id then @@ -202,9 +200,9 @@ let instance_tac inst= left_instance_tac inst let quantified_tac lf backtrack continue seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let insts=give_instances (project gl) lf seq in tclORELSE (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) backtrack - end } + end diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 8c6b5b91d..b7fe25a32 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -32,7 +32,7 @@ type lseqtac= global_reference -> seqtac type 'a with_backtracking = tactic -> 'a let wrap n b continue seq = - Proofview.Goal.nf_enter { enter = begin fun gls -> + Proofview.Goal.nf_enter begin fun gls -> Control.check_for_interrupt (); let nc = Proofview.Goal.hyps gls in let env=pf_env gls in @@ -40,7 +40,7 @@ let wrap n b continue seq = let rec aux i nc ctx= if i<=0 then seq else match nc with - []->anomaly (Pp.str "Not the expected number of hyps") + []->anomaly (Pp.str "Not the expected number of hyps.") | nd::q-> let id = NamedDecl.get_id nd in if occur_var env sigma id (pf_concl gls) || @@ -52,7 +52,7 @@ let wrap n b continue seq = let seq2=if b then add_formula env sigma Concl dummy_id (pf_concl gls) seq1 else seq1 in continue seq2 - end } + end let basename_of_global=function VarRef id->id @@ -65,12 +65,12 @@ let clear_global=function (* connection rules *) let axiom_tac t seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> try pf_constr_of_global (find_left (project gl) t seq) >>= fun c -> exact_no_check c with Not_found -> tclFAIL 0 (Pp.str "No axiom link") - end } + end let ll_atom_tac a backtrack id continue seq = let open EConstr in @@ -107,7 +107,7 @@ let arrow_tac backtrack continue seq= (* left connectives rules *) let left_and_tac ind backtrack id continue seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let n=(construct_nhyps (pf_env gl) ind).(0) in tclIFTHENELSE (tclTHENLIST @@ -116,10 +116,10 @@ let left_and_tac ind backtrack id continue seq = tclDO n intro]) (wrap n false continue seq) backtrack - end } + end let left_or_tac ind backtrack id continue seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let v=construct_nhyps (pf_env gl) ind in let f n= tclTHENLIST @@ -130,7 +130,7 @@ let left_or_tac ind backtrack id continue seq = (pf_constr_of_global id >>= simplest_elim) (Array.map f v) backtrack - end } + end let left_false_tac id= Tacticals.New.pf_constr_of_global id >>= simplest_elim @@ -140,7 +140,7 @@ let left_false_tac id= (* We use this function for false, and, or, exists *) let ll_ind_tac (ind,u as indu) largs backtrack id continue seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let rcs=ind_hyps (pf_env gl) (project gl) 0 indu largs in let vargs=Array.of_list largs in (* construire le terme H->B, le generaliser etc *) @@ -161,7 +161,7 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq = clear_global id; tclDO lp intro]) (wrap lp false continue seq) backtrack - end } + end let ll_arrow_tac a b c backtrack id continue seq= let open EConstr in @@ -199,7 +199,7 @@ let forall_tac backtrack continue seq= backtrack) let left_exists_tac ind backtrack id continue seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let n=(construct_nhyps (pf_env gl) ind).(0) in tclIFTHENELSE (Tacticals.New.pf_constr_of_global id >>= simplest_elim) @@ -207,7 +207,7 @@ let left_exists_tac ind backtrack id continue seq = tclDO n intro; (wrap (n-1) false continue seq)]) backtrack - end } + end let ll_forall_tac prod backtrack id continue seq= tclORELSE @@ -215,12 +215,12 @@ let ll_forall_tac prod backtrack id continue seq= [tclTHENLIST [intro; (pf_constr_of_global id >>= fun idc -> - Proofview.Goal.enter { enter = begin fun gls-> + Proofview.Goal.enter begin fun gls-> let open EConstr in let id0 = List.nth (pf_ids_of_hyps gls) 0 in let term=mkApp(idc,[|mkVar(id0)|]) in tclTHEN (generalize [term]) (clear [id0]) - end }); + end); clear_global id; intro; tclCOMPLETE (wrap 1 false continue (deepen seq))]; @@ -239,9 +239,9 @@ let defined_connectives=lazy AllOccurrences,EvalConstRef (fst (Term.destConst (constant "iff")))] let normalize_evaluables= - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> unfold_in_concl (Lazy.force defined_connectives) <*> tclMAP (fun id -> unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)) (pf_ids_of_hyps gl) - end } + end diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index a6290cb00..317444cf1 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -469,7 +469,7 @@ exception GoalDone (* Résolution d'inéquations linéaires dans R *) let rec fourier () = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; @@ -633,7 +633,7 @@ let rec fourier () = (* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) !tac (* ((tclABSTRACT None !tac) gl) *) - end } + end ;; (* diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 434fb14a6..fd4962398 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -397,7 +397,7 @@ let rewrite_until_var arg_num eq_ids : tactic = then tclIDTAC g else match eq_ids with - | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property"); + | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property."); | eq_id::eq_ids -> tclTHEN (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) @@ -605,7 +605,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ pr_leconstr_env (pf_env g') (project g') new_term_value_eq ); - anomaly (Pp.str "cannot compute new term value") + anomaly (Pp.str "cannot compute new term value.") in let fun_body = mkLambda(Anonymous, @@ -838,7 +838,7 @@ let build_proof h_reduce_with_zeta Locusops.onConcl; build_proof do_finalize new_infos ] g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) observe_tac_stream (str "build_proof with " ++ Printer.pr_leconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g @@ -944,7 +944,7 @@ let generalize_non_dep hyp g = ((* observe_tac "thin" *) (thin to_revert)) g -let id_of_decl = RelDecl.get_name %> Nameops.out_name +let id_of_decl = RelDecl.get_name %> Nameops.Name.get_id let var_of_decl = id_of_decl %> mkVar let revert idl = tclTHEN @@ -1032,7 +1032,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant") + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } | _ -> () @@ -1127,11 +1127,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 (RelDecl.get_name %> Nameops.out_name %> Ppconstr.pr_id) + prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) full_params ); observe (str "princ_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.out_name %> Ppconstr.pr_id) + prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) princ_params ); observe (str "fbody_with_full_params := " ++ @@ -1158,7 +1158,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (fun i types -> let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in { idx = idxs.(i) - fix_offset; - name = Nameops.out_name (fresh_id names.(i)); + name = Nameops.Name.get_id (fresh_id names.(i)); types = types; offset = fix_offset; nb_realargs = @@ -1181,7 +1181,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in let app_f = mkApp(f,first_args) in let pte_args = (Array.to_list first_args)@[app_f] in - let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in + let app_pte = applist(mkVar (Nameops.Name.get_id pte),pte_args) in let body_with_param,num = let body = get_body fnames.(i) in let body_with_full_params = @@ -1208,9 +1208,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam num_in_block = num } in -(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) +(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) (* str " to " ++ Ppconstr.pr_id info.name); *) - (Id.Map.add (Nameops.out_name pte) info acc_map,info::acc_info) + (Id.Map.add (Nameops.Name.get_id pte) info acc_map,info::acc_info) ) 0 (Id.Map.empty,[]) @@ -1255,7 +1255,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam try let pte = try destVar (project gl) pte - with DestKO -> anomaly (Pp.str "Property is not a variable") + with DestKO -> anomaly (Pp.str "Property is not a variable.") in let fix_info = Id.Map.find pte ptes_to_fix in let nb_args = fix_info.nb_realargs in @@ -1284,7 +1284,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 (RelDecl.get_name %> Nameops.out_name) princ_params)) + (args_id@(List.map (RelDecl.get_name %> Nameops.Name.get_id) princ_params)) (all_funs.(fix_info.num_in_block)) fix_info.num_in_block all_funs @@ -1481,7 +1481,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = tclCOMPLETE( Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] [Hints.Hint_db.empty empty_transparent_state false] ) ) @@ -1563,17 +1563,17 @@ let prove_principle_for_gen | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (get_name %> Nameops.out_name %> mkVar) (pre_rec_arg@princ_info.params) in + let subst_constrs = List.map (get_name %> Nameops.Name.get_id %> 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 + let wf_thm_id = Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) in let acc_rec_arg_id = - Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) + Nameops.Name.get_id (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l)) in - let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in + let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = ((* observe_tac "prove_rec_arg_acc" *) (tclCOMPLETE @@ -1591,7 +1591,7 @@ let prove_principle_for_gen ) g in - let args_ids = List.map (get_name %> Nameops.out_name) princ_info.args in + let args_ids = List.map (get_name %> Nameops.Name.get_id) princ_info.args in let lemma = match !tcc_lemma_ref with | Undefined -> user_err Pp.(str "No tcc proof !!") @@ -1639,7 +1639,7 @@ let prove_principle_for_gen [ observe_tac "start_tac" start_tac; h_intros - (List.rev_map (get_name %> Nameops.out_name) + (List.rev_map (get_name %> Nameops.Name.get_id) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by @@ -1677,14 +1677,14 @@ 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 (get_name %> Nameops.out_name) princ_info.predicates + List.map (get_name %> Nameops.Name.get_id) princ_info.predicates in let pte_info = { proving_tac = (fun eqs -> (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) -(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *) -(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *) +(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) +(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) @@ -1693,7 +1693,7 @@ let prove_principle_for_gen is_mes acc_inv fix_id (!tcc_list@(List.map - (get_name %> Nameops.out_name) + (get_name %> Nameops.Name.get_id) (princ_info.args@princ_info.params) )@ ([acc_rec_arg_id])) eqs ) @@ -1722,7 +1722,7 @@ let prove_principle_for_gen (* observe_tac "instanciate_hyps_with_args" *) (instanciate_hyps_with_args make_proof - (List.map (get_name %> Nameops.out_name) princ_info.branches) + (List.map (get_name %> Nameops.Name.get_id) 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 18d63dd94..b8070ff88 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -12,7 +12,6 @@ open Context.Rel.Declaration open Indfun_common open Functional_principles_proofs open Misctypes -open Sigma.Notations module RelDecl = Context.Rel.Declaration @@ -44,7 +43,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let id = Namegen.next_ident_away x avoid in Hashtbl.add tbl id x; RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates - | Anonymous -> anomaly (Pp.str "Anonymous property binder ")) + | Anonymous -> anomaly (Pp.str "Anonymous property binder.")) in let avoid = (Termops.ids_of_context env_with_params ) in let princ_type_info = @@ -62,7 +61,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = then List.tl args else args in - Context.Named.Declaration.LocalAssum (Nameops.out_name (Context.Rel.Declaration.get_name decl), + Context.Named.Declaration.LocalAssum (Nameops.Name.get_id (Context.Rel.Declaration.get_name decl), Term.compose_prod real_args (mkSort new_sort)) in let new_predicates = @@ -185,11 +184,11 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = with | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) end @@ -214,11 +213,11 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = with | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) end @@ -399,7 +398,7 @@ let get_funs_constant mp dp = let const = make_con mp dp (Label.of_id id) in const,i | Anonymous -> - anomaly (Pp.str "Anonymous fix") + anomaly (Pp.str "Anonymous fix.") ) na | _ -> [|const,0|] @@ -669,11 +668,9 @@ let build_case_scheme fa = let ind = first_fun_kn,funs_indexes in (ind,Univ.Instance.empty)(*FIXME*),prop_sort in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (scheme, sigma, _) = + let (sigma, scheme) = Indrec.build_case_analysis_scheme_default env sigma ind sf in - let sigma = Sigma.to_evar_map sigma in let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in let sorts = (fun (_,_,x) -> diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 1db8be081..d28e0aba0 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -22,26 +22,10 @@ open Pltac DECLARE PLUGIN "recdef_plugin" -let pr_binding prc = function - | loc, (NamedHyp id, c) -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) - | loc, (AnonHyp n, c) -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) - -let pr_bindings prc prlc = function - | ImplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - pr_sequence prc l - | ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | NoBindings -> mt () - -let pr_with_bindings prc prlc (c,bl) = - prc c ++ hv 0 (pr_bindings prc prlc bl) - let pr_fun_ind_using prc prlc _ opt_c = match opt_c with | None -> mt () - | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc b) + | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b) (* Duplication of printing functions because "'a with_bindings" is (internally) not uniform in 'a: indeed constr_with_bindings at the @@ -49,16 +33,12 @@ let pr_fun_ind_using prc prlc _ opt_c = "constr with_bindings"; hence, its printer cannot be polymorphic in (prc,prlc)... *) -let pr_with_bindings_typed prc prlc (c,bl) = - prc c ++ - hv 0 (pr_bindings prc prlc bl) - let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () | Some b -> - let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in - spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b) + let (_, b) = b (Global.env ()) Evd.empty in + spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b) ARGUMENT EXTEND fun_ind_using @@ -80,7 +60,6 @@ TACTIC EXTEND newfuninv ] END - let pr_intro_as_pat _prc _ _ pat = match pat with | Some pat -> diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 68e097fe9..785633e25 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1115,7 +1115,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) else CAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - | _ -> anomaly (Pp.str "Should not have an anonymous function here") + | _ -> anomaly (Pp.str "Should not have an anonymous function here.") (* We have renamed all the anonymous functions during alpha_renaming phase *) end @@ -1288,17 +1288,20 @@ let do_build_inductive let t = EConstr.Unsafe.to_constr t in evd, Environ.push_named (LocalAssum (id,t)) - (* try *) - (* Typing.e_type_of env evd (mkConstU c) *) - (* with Not_found -> *) - (* raise (UserError("do_build_inductive", str "Cannot handle partial fixpoint")) *) env ) funnames (Array.of_list funconstants) (evd,Global.env ()) in - let resa = Array.map (build_entry_lc env funnames_as_set []) rta in + (* we solve and replace the implicits *) + let rta = + Array.mapi (fun i rt -> + let _,t = Typing.type_of env evd (EConstr.of_constr (mkConstU ((Array.of_list funconstants).(i)))) in + resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env evd rt + ) rta + in + let resa = Array.map (build_entry_lc env funnames_as_set []) rta in let env_with_graphs = let rel_arity i funargs = (* Rebuilding arities (with parameters) *) let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 0361e8cb1..6fd496f50 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -532,7 +532,7 @@ let rec are_unifiable_aux = function else let eqs' = try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux") + with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") in are_unifiable_aux eqs' @@ -555,7 +555,7 @@ let rec eq_cases_pattern_aux = function else let eqs' = try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux") + with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") in eq_cases_pattern_aux eqs' | _ -> raise NotUnifiable @@ -707,3 +707,48 @@ let expand_as = (loc,(idl,cpl, expand_as (List.fold_left add_as map cpl) rt)) in expand_as Id.Map.empty + + + + +(* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution + *) + +exception Found of Evd.evar_info +let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expected_type=Pretyping.WithoutTypeConstraint) env sigma rt = + let open Evd in + let open Evar_kinds in + (* we first (pseudo) understand [rt] and get back the computed evar_map *) + (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. +If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) + let ctx,_ = Pretyping.ise_pretype_gen flags env sigma Pretyping.empty_lvar expected_type rt in + let ctx, f = Evarutil.nf_evars_and_universes ctx in + + (* then we map [rt] to replace the implicit holes by their values *) + let rec change rt = + match rt.CAst.v with + | GHole(ImplicitArg(grk,pk,bk),_,_) -> (* we only want to deal with implicit arguments *) + ( + try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | (loc_evi,ImplicitArg(gr_evi,p_evi,b_evi)) -> + if Globnames.eq_gr grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi + then raise (Found evi) + | _ -> () + ) + ctx + (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype false [] env ctx (EConstr.of_constr (f c)) + | Evar_empty -> rt (* the hole was not solved : we do nothing *) + ) + | _ -> Glob_ops.map_glob_constr change rt + in + change rt diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 25d79582f..99a258de9 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -119,3 +119,10 @@ val zeta_normalize : Glob_term.glob_constr -> Glob_term.glob_constr val expand_as : glob_constr -> glob_constr + + +(* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution + *) +val resolve_and_replace_implicits : + ?flags:Pretyping.inference_flags -> + ?expected_type:Pretyping.typing_constraint -> Environ.env -> Evd.evar_map -> glob_constr -> glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 74c0eb4cc..f1a9758e8 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -11,7 +11,6 @@ open Glob_term open Declarations open Misctypes open Decl_kinds -open Sigma.Notations module RelDecl = Context.Rel.Declaration @@ -93,7 +92,7 @@ let functional_induction with_clean c princl pat = in let encoded_pat_as_patlist = List.make (List.length args + List.length c_list - 1) None @ [pat] in - List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None)) + List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)) )),(None,pat),None)) (args@c_list) encoded_pat_as_patlist in let princ' = Some (princ,bindings) in @@ -142,7 +141,7 @@ let rec abstract_glob_constr c = function let interp_casted_constr_with_implicits env sigma impls c = Constrintern.intern_gen Pretyping.WithoutTypeConstraint env ~impls - ~allow_patvar:false c + c (* Construct a fixpoint as a Glob_term @@ -200,13 +199,13 @@ let is_rec names = | GIf(b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) | GProd(na,_,t,b) | GLambda(na,_,t,b) -> - lookup names t || lookup (Nameops.name_fold Id.Set.remove na names) b + lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b | GLetIn(na,b,t,c) -> - lookup names b || Option.cata (lookup names) true t || lookup (Nameops.name_fold Id.Set.remove na names) c + lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c | GLetTuple(nal,_,t,b) -> lookup names t || lookup (List.fold_left - (fun acc na -> Nameops.name_fold Id.Set.remove na acc) + (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) names nal ) @@ -734,7 +733,7 @@ let rec add_args id new_args = CAst.map (function CAppExpl((None,r,None),new_args) | _ -> b end - | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo") + | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo.") | CProdN(nal,b1) -> CProdN(List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) @@ -782,9 +781,9 @@ let rec add_args id new_args = CAst.map (function Miscops.map_cast_type (add_args id new_args) b2) | CRecord pars -> CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) - | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation") - | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization") - | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters") + | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation.") + | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization.") + | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters.") ) exception Stop of Constrexpr.constr_expr @@ -826,7 +825,7 @@ let rec chop_n_arrow n t = chop_n_arrow new_n t' with Stop t -> t end - | _ -> anomaly (Pp.str "Not enough products") + | _ -> anomaly (Pp.str "Not enough products.") let rec get_args b t : Constrexpr.local_binder_expr list * @@ -856,7 +855,7 @@ let make_graph (f_ref:global_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 !" + | None -> error "Cannot build a graph over an axiom!" | Some body -> let env = Global.env () in let sigma = Evd.from_env env in @@ -885,7 +884,7 @@ let make_graph (f_ref:global_reference) = | Constrexpr.CLocalAssum (nal,_,_) -> List.map (fun (loc,n) -> CAst.make ?loc @@ - CRef(Libnames.Ident(loc, Nameops.out_name n),None)) + CRef(Libnames.Ident(loc, Nameops.Name.get_id n),None)) nal | Constrexpr.CLocalPattern _ -> assert false ) diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 2476478ab..a73425543 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -369,7 +369,7 @@ let in_Function : function_info -> Libobject.obj = let find_or_none id = try Some - (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant") + (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) with Not_found -> None @@ -397,7 +397,7 @@ let add_Function is_general f = and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") and graph_ind = match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) - with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive") + with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive.") in let finfos = { function_constant = f; diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index d68bdc215..bcfa6b931 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -26,31 +26,6 @@ open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration -(* Some pretty printing function for debugging purpose *) - -let pr_binding prc = - function - | loc, (NamedHyp id, c) -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) - | loc, (AnonHyp n, c) -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) - -let pr_bindings prc prlc = function - | ImplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - pr_sequence prc l - | ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | NoBindings -> mt () - - -let pr_with_bindings prc prlc (c,bl) = - prc c ++ hv 0 (pr_bindings prc prlc bl) - - - -let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = - pr_with_bindings prc prc (c,bl) - (* The local debugging mechanism *) (* let msgnl = Pp.msgnl *) @@ -140,7 +115,7 @@ let generate_type evd g_to_f f graph i = let ctxt,_ = decompose_prod_assum !evd graph_arity in let fun_ctxt,res_type = match ctxt with - | [] | [_] -> anomaly (Pp.str "Not a valid context") + | [] | [_] -> anomaly (Pp.str "Not a valid context.") | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl in let rec args_from_decl i accu = function @@ -292,7 +267,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (fun (_,pat) acc -> match pat with | IntroNaming (IntroIdentifier id) -> id::acc - | _ -> anomaly (Pp.str "Not an identifier") + | _ -> anomaly (Pp.str "Not an identifier.") ) (List.nth intro_pats (pred i)) [] @@ -401,7 +376,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes Array.map (fun ((_,(ctxt,concl))) -> match ctxt with - | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") + | [] | [_] | [_;_] -> anomaly (Pp.str "bad context.") | hres::res::decl::ctxt -> let res = EConstr.it_mkLambda_or_LetIn (EConstr.it_mkProd_or_LetIn concl [hres;res]) @@ -421,7 +396,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 (RelDecl.get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) avoid in p::bindings,id::avoid ) ([],pf_ids_of_hyps g) @@ -431,7 +406,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 (RelDecl.get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) avoid in (nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates @@ -708,7 +683,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = then let eq_lemma = try Option.get (infos).equation_lemma - with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma") + with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma.") in tclTHENSEQ[ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; @@ -938,7 +913,7 @@ let revert_graph kn post_tac hid g = let info = try find_Function_of_graph ind' with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) - anomaly (Pp.str "Cannot retrieve infos about a mutual block") + anomaly (Pp.str "Cannot retrieve infos about a mutual block.") in (* if we can find a completeness lemma for this function then we can come back to the functional form. If not, we do nothing diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index b2c8489ce..763443717 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -133,20 +133,6 @@ let prNamedRLDecl s lc = prstr "\n"; end -let showind (id:Id.t) = - let cstrid = Constrintern.global_reference id in - let (ind1, u),cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty (EConstr.of_constr cstrid) in - let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in - let u = EConstr.Unsafe.to_instance u in - List.iter (fun decl -> - print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":"); - prconstr (RelDecl.get_type decl); print_string "\n") - ib1.mind_arity_ctxt; - Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) (ind1, u)); - Array.iteri - (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) - ib1.mind_user_lc - (** {2 Misc} *) exception Found of int diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 2f9f70876..ff397d2e9 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -42,7 +42,6 @@ open Auto open Eauto open Indfun_common -open Sigma.Notations open Context.Rel.Declaration (* Ugly things which should not be here *) @@ -76,7 +75,7 @@ let def_of_const t = | _ -> raise Not_found) with Not_found -> anomaly (str "Cannot find definition of constant " ++ - (Id.print (Label.to_id (con_label (fst sp))))) + (Id.print (Label.to_id (con_label (fst sp)))) ++ str ".") ) |_ -> assert false @@ -95,7 +94,7 @@ let constant sl s = constr_of_global (find_reference sl s) let const_of_ref = function ConstRef kn -> kn - | _ -> anomaly (Pp.str "ConstRef expected") + | _ -> anomaly (Pp.str "ConstRef expected.") let nf_zeta env = @@ -442,7 +441,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = travel jinfo new_continuation_tac {expr_info with info = b; is_final=false} g end - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") | Prod _ -> begin try @@ -486,7 +485,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = travel_args jinfo expr_info.is_main_branch new_continuation_tac new_infos g | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr 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_leconstr expr_info.info) + | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr expr_info.info ++ Pp.str ".") end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> @@ -700,11 +699,9 @@ let mkDestructEq : observe_tclTHENLIST (str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> - let changefun patvars = { run = fun sigma -> - let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in - let Sigma (c, sigma, p) = redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2) in - Sigma (c, sigma, p) - } in + let changefun patvars sigma = + pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) + in Proofview.V82.of_tactic (change_in_concl None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert @@ -879,7 +876,7 @@ let rec make_rewrite_list expr_info max = function let k_na,_,t = destProd sigma t_eq in let _,_,t = destProd sigma t in let def_na,_,_ = destProd sigma t in - Nameops.out_name k_na,Nameops.out_name def_na + Nameops.Name.get_id k_na,Nameops.Name.get_id def_na in Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true @@ -905,7 +902,7 @@ let make_rewrite expr_info l hp max = let k_na,_,t = destProd sigma t_eq in let _,_,t = destProd sigma t in let def_na,_,_ = destProd sigma t in - Nameops.out_name k_na,Nameops.out_name def_na + Nameops.Name.get_id k_na,Nameops.Name.get_id def_na in observe_tac (str "general_rewrite_bindings") (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences @@ -1165,7 +1162,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let f_id = match f_name with | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly (Pp.str "Anonymous function") + | Anonymous -> anomaly (Pp.str "Anonymous function.") in let n_names_types,_ = decompose_lam_n sigma nb_args body1 in let n_ids,ids = @@ -1175,7 +1172,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a | Name id -> let n_id = next_ident_away_in_goal id ids in n_id::n_ids,n_id::ids - | _ -> anomaly (Pp.str "anonymous argument") + | _ -> anomaly (Pp.str "anonymous argument.") ) ([],(f_id::ids)) n_names_types @@ -1302,7 +1299,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp | None -> try add_suffix current_proof_name "_subproof" with e when CErrors.noncritical e -> - anomaly (Pp.str "open_new_goal with an unamed theorem") + anomaly (Pp.str "open_new_goal with an unamed theorem.") in let na = next_global_ident_away name [] in if Termops.occur_existential sigma gls_type then @@ -1313,7 +1310,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp let na_global = Smartlocate.global_with_alias na_ref in match na_global with ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant") + | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in ref_ := Value (EConstr.Unsafe.to_constr lemma); @@ -1357,7 +1354,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (Proofview.V82.of_tactic e_assumption); Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] + [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] [Hints.Hint_db.empty empty_transparent_state false] ] ) @@ -1464,7 +1461,7 @@ let (com_eqn : int -> Id.t -> let opacity = match terminate_ref with | ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant") + | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in let (evmap, env) = Lemmas.get_current_context() in let evmap = Evd.from_ctx (Evd.evar_universe_context evmap) in diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 index 0a13a20a9..ea1660d90 100644 --- a/plugins/ltac/coretactics.ml4 +++ b/plugins/ltac/coretactics.ml4 @@ -16,8 +16,6 @@ open Genredexpr open Stdarg open Extraargs -open Sigma.Notations - DECLARE PLUGIN "coretactics" (** Basic tactics *) @@ -160,12 +158,12 @@ END (** Split *) let rec delayed_list = function -| [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma } +| [] -> fun _ sigma -> (sigma, []) | x :: l -> - { Tacexpr.delayed = fun env sigma -> - let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in - let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in - Sigma (x :: l, sigma, p +> q) } + fun env sigma -> + let (sigma, x) = x env sigma in + let (sigma, l) = delayed_list l env sigma in + (sigma, x :: l) TACTIC EXTEND split [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index bf84f61a5..7db484d82 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -16,8 +16,6 @@ open Tacexpr open Refiner open Evd open Locus -open Sigma.Notations -open Proofview.Notations open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -81,7 +79,7 @@ let instantiate_tac_by_name id c = let let_evar name typ = let src = (Loc.tag Evar_kinds.GoalEvar) in - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let sigma = ref sigma in @@ -93,17 +91,14 @@ let let_evar name typ = Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) | Names.Name id -> id in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in - let tac = - (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) - in - Sigma (tac, sigma, p) - end } + let (sigma, evar) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) + end let hget_evar n = let open EConstr in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let evl = evar_list sigma concl in @@ -113,5 +108,5 @@ let hget_evar n = let ev = List.nth evl (n-1) in let ev_type = EConstr.existential_type sigma ev in Tactics.change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) - end } + end diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index d68139a4b..8afe3053d 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -24,7 +24,6 @@ open Util open Termops open Equality open Misctypes -open Sigma.Notations open Proofview.Notations DECLARE PLUGIN "extratactics" @@ -80,12 +79,12 @@ let induction_arg_of_quantified_hyp = function ElimOnIdent and not as "constr" *) let mytclWithHoles tac with_evars c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Tacmach.New.pf_env gl in let sigma = Tacmach.New.project gl in let sigma',c = Tactics.force_destruction_arg with_evars env sigma c in Tacticals.New.tclWITHHOLES with_evars (tac with_evars (Some c)) sigma' - end } + end let elimOnConstrWithHoles tac with_evars c = Tacticals.New.tclDELAYEDWITHHOLES with_evars c @@ -115,7 +114,7 @@ END let discrHyp id = Proofview.tclEVARMAP >>= fun sigma -> - discr_main { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma } + discr_main (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) let injection_main with_evars c = elimOnConstrWithHoles (injClause None) with_evars c @@ -147,7 +146,7 @@ END let injHyp id = Proofview.tclEVARMAP >>= fun sigma -> - injection_main false { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma } + injection_main false (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) TACTIC EXTEND dependent_rewrite | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] @@ -306,7 +305,8 @@ let project_hint pri l2r r = | _ -> assert false in let p = if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in - let p = EConstr.of_constr @@ Universes.constr_of_global p in + let sigma, p = Evd.fresh_global env sigma p in + let p = EConstr.of_constr p in let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in let c = it_mkLambda_or_LetIn (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in @@ -353,23 +353,22 @@ let constr_flags () = { Pretyping.expand_evars = true } let refine_tac ist simple with_classes c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let flags = { constr_flags () with Pretyping.use_typeclasses = with_classes } in let expected_type = Pretyping.OfType concl in let c = Pretyping.type_uconstr ~flags ~expected_type ist c in - let update = { run = fun sigma -> - let Sigma (c, sigma, p) = c.delayed env sigma in - Sigma (c, sigma, p) - } in + let update = begin fun sigma -> + c env sigma + end in let refine = Refine.refine ~unsafe:true update in if simple then refine else refine <*> Tactics.New.reduce_after_refine <*> Proofview.shelve_unifiable - end } + end TACTIC EXTEND refine | [ "refine" uconstr(c) ] -> @@ -636,7 +635,7 @@ let subst_var_with_hole occ tid t = else (incr locref; CAst.make ~loc:(Loc.make_loc (!locref,0)) @@ - GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true), + GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous), Misctypes.IntroAnonymous, None))) else x | c -> map_glob_constr_left_to_right substrec c in @@ -648,13 +647,13 @@ let subst_hole_with_term occ tc t = let locref = ref 0 in let occref = ref occ in let rec substrec = function - | { CAst.v = GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) } -> + | { CAst.v = GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s) } -> decr occref; if Int.equal !occref 0 then tc else (incr locref; CAst.make ~loc:(Loc.make_loc (!locref,0)) @@ - GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s)) + GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s)) | c -> map_glob_constr_left_to_right substrec c in substrec t @@ -662,9 +661,8 @@ let subst_hole_with_term occ tc t = open Tacmach let hResolve id c occ t = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in let env = Termops.clear_named_body id (Proofview.Goal.env gl) in let concl = Proofview.Goal.concl gl in let env_ids = Termops.ids_of_context env in @@ -683,11 +681,9 @@ let hResolve id c occ t = let t_constr = EConstr.of_constr t_constr in let sigma = Evd.merge_universe_context sigma ctx in let t_constr_type = Retyping.get_type_of env sigma t_constr in - let tac = + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl))) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + end let hResolve_auto id c t = let rec resolve_auto n = @@ -725,17 +721,16 @@ END exception Found of unit Proofview.tactic let rewrite_except h = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = Tacmach.New.pf_ids_of_hyps gl in Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) hyps - end } + end let refl_equal = let coq_base_constant s = - Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "RecursiveDefinition" (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in function () -> (coq_base_constant "eq_refl") @@ -745,28 +740,29 @@ let refl_equal = should be replaced by a call to the tactic but I don't know how to call it before it is defined. *) let mkCaseEq a : unit Proofview.tactic = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of_a = Tacmach.New.pf_unsafe_type_of gl a in - Tacticals.New.tclTHENLIST - [Tactics.generalize [(mkApp(EConstr.of_constr (delayed_force refl_equal), [| type_of_a; a|]))]; - Proofview.Goal.enter { enter = begin fun gl -> + Tacticals.New.pf_constr_of_global (delayed_force refl_equal) >>= fun req -> + Tacticals.New.tclTHENLIST + [Tactics.generalize [(mkApp(req, [| type_of_a; a|]))]; + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in (** FIXME: this looks really wrong. Does anybody really use this tactic? *) - let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in + let (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl in change_concl c - end }; + end; simplest_case a] - end } + end let case_eq_intros_rewrite x = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let n = nb_prod (Tacmach.New.project gl) (Proofview.Goal.concl gl) in (* Pp.msgnl (Printer.pr_lconstr x); *) Tacticals.New.tclTHENLIST [ mkCaseEq x; - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let hyps = Tacmach.New.pf_ids_of_hyps gl in let n' = nb_prod (Tacmach.New.project gl) concl in @@ -775,9 +771,9 @@ let case_eq_intros_rewrite x = Tacticals.New.tclDO (n'-n-1) intro; introduction h; rewrite_except h] - end } + end ] - end } + end let rec find_a_destructable_match sigma t = let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in @@ -801,15 +797,15 @@ let destauto t = with Found tac -> tac let destauto_in id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in (* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) (* Pp.msgnl (Printer.pr_lconstr (ctype)); *) destauto ctype - end } + end TACTIC EXTEND destauto -| [ "destauto" ] -> [ Proofview.Goal.enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ] +| [ "destauto" ] -> [ Proofview.Goal.enter begin fun gl -> destauto (Proofview.Goal.concl gl) end ] | [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] END @@ -821,21 +817,21 @@ END (**********************************************************************) TACTIC EXTEND transparent_abstract -| [ "transparent_abstract" tactic3(t) ] -> [ Proofview.Goal.nf_enter { enter = fun gl -> - Tactics.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) } ] -| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> [ Proofview.Goal.nf_enter { enter = fun gl -> - Tactics.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) } ] +| [ "transparent_abstract" tactic3(t) ] -> [ Proofview.Goal.nf_enter begin fun gl -> + Tactics.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end ] +| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> [ Proofview.Goal.nf_enter begin fun gl -> + Tactics.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end ] END (* ********************************************************************* *) let eq_constr x y = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let evd = Tacmach.New.project gl in match EConstr.eq_constr_universes evd x y with | Some _ -> Proofview.tclUNIT () | None -> Tacticals.New.tclFAIL 0 (str "Not equal") - end } + end TACTIC EXTEND constr_eq | [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ] @@ -1081,7 +1077,7 @@ TACTIC EXTEND guard END let decompose l c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let to_ind c = if isInd sigma c then fst (destInd sigma c) @@ -1089,7 +1085,7 @@ let decompose l c = in let l = List.map to_ind l in Elim.h_decompose l c - end } + end TACTIC EXTEND decompose | [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index 50e8255a6..2c2a4b850 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -15,7 +15,6 @@ open Pcoq.Prim open Pcoq.Constr open Pltac open Hints -open Tacexpr open Names DECLARE PLUGIN "g_auto" @@ -49,10 +48,7 @@ let eval_uconstrs ist cs = fail_evar = false; expand_evars = true } in - let map c = { delayed = fun env sigma -> - let Sigma.Sigma (c, sigma, p) = c.delayed env sigma in - Sigma.Sigma (c, sigma, p) - } in + let map c env sigma = c env sigma in List.map (fun c -> map (Pretyping.type_uconstr ~flags ist c)) cs let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4 index 23ce368ee..dd5307638 100644 --- a/plugins/ltac/g_class.ml4 +++ b/plugins/ltac/g_class.ml4 @@ -102,18 +102,18 @@ let rec eq_constr_mod_evars sigma x y = | _, _ -> compare_constr sigma (fun x y -> eq_constr_mod_evars sigma x y) x y let progress_evars t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let check = - Proofview.Goal.enter { enter = begin fun gl' -> + Proofview.Goal.enter begin fun gl' -> let sigma = Tacmach.New.project gl' in let newconcl = Proofview.Goal.concl gl' in if eq_constr_mod_evars sigma concl newconcl then Tacticals.New.tclFAIL 0 (Pp.str"No progress made (modulo evars)") else Proofview.tclUNIT () - end } + end in t <*> check - end } + end TACTIC EXTEND progress_evars [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index 5adf8475a..25258ffa9 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -18,7 +18,6 @@ open Glob_term open Geninterp open Extraargs open Tacmach -open Proofview.Notations open Rewrite open Stdarg open Pcoq.Vernac_ @@ -123,7 +122,7 @@ TACTIC EXTEND rewrite_strat END let clsubstitute o c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let is_tac id = match fst (fst (snd c)) with { CAst.v = GVar id' } when Id.equal id' id -> true | _ -> false in let hyps = Tacmach.New.pf_ids_of_hyps gl in Tacticals.New.tclMAP @@ -132,7 +131,7 @@ let clsubstitute o c = | Some id when is_tac id -> Tacticals.New.tclIDTAC | _ -> cl_rewrite_clause c o AllOccurrences cl) (None :: List.map (fun id -> Some id) hyps) - end } + end TACTIC EXTEND substitute | [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ] diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 index 1404b1c1f..83bfd0233 100644 --- a/plugins/ltac/g_tactic.ml4 +++ b/plugins/ltac/g_tactic.ml4 @@ -538,38 +538,64 @@ GEXTEND Gram TacAtom (Loc.tag ~loc:!@loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) | IDENT "pose"; (id,b) = bindings_with_parameters -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (Names.Name id,b,Locusops.nowhere,true,None)) + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,Names.Name id,b,Locusops.nowhere,true,None)) | IDENT "pose"; b = constr; na = as_name -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (na,b,Locusops.nowhere,true,None)) + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) + | IDENT "epose"; (id,b) = bindings_with_parameters -> + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) + | IDENT "epose"; b = constr; na = as_name -> + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (Names.Name id,c,p,true,None)) + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,Names.Name id,c,p,true,None)) | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (na,c,p,true,None)) + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,c,p,true,None)) + | IDENT "eset"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) + | IDENT "eset"; c = constr; na = as_name; p = clause_dft_concl -> + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,c,p,true,None)) | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; p = clause_dft_all -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (na,c,p,false,e)) + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,c,p,false,e)) + | IDENT "eremember"; c = constr; na = as_name; e = eqn_ipat; + p = clause_dft_all -> + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,c,p,false,e)) (* Alternative syntax for "pose proof c as id" *) | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; c = lconstr; ")" -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,None,Some (Loc.tag ~loc:!@loc @@IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,None,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) + | IDENT "eassert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; + c = lconstr; ")" -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,None,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) (* Alternative syntax for "assert c as id by tac" *) | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; c = lconstr; ")"; tac=by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,Some tac,Some (Loc.tag ~loc:!@loc @@IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) + | IDENT "eassert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) (* Alternative syntax for "enough c as id by tac" *) | IDENT "enough"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; c = lconstr; ")"; tac=by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,Some tac,Some (Loc.tag ~loc:!@loc @@IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,false,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) + | IDENT "eenough"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,false,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,Some tac,ipat,c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,Some tac,ipat,c)) + | IDENT "eassert"; c = constr; ipat = as_ipat; tac = by_tactic -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,Some tac,ipat,c)) | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,None,ipat,c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,None,ipat,c)) + | IDENT "epose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,None,ipat,c)) | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,Some tac,ipat,c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,false,Some tac,ipat,c)) + | IDENT "eenough"; c = constr; ipat = as_ipat; tac = by_tactic -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,false,Some tac,ipat,c)) | IDENT "generalize"; c = constr -> TacAtom (Loc.tag ~loc:!@loc @@ TacGeneralize [((AllOccurrences,c),Names.Anonymous)]) diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index a001c6a2b..9446f9df4 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -161,28 +161,6 @@ type 'a extra_genarg_printer = | AnonHyp n -> int n | NamedHyp id -> pr_id id - let pr_binding prc = function - | loc, (NamedHyp id, c) -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c) - | loc, (AnonHyp n, c) -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) - - let pr_bindings prc prlc = function - | ImplicitBindings l -> - brk (1,1) ++ keyword "with" ++ brk (1,1) ++ - hv 0 (prlist_with_sep spc prc l) - | ExplicitBindings l -> - brk (1,1) ++ keyword "with" ++ brk (1,1) ++ - hv 0 (prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l) - | NoBindings -> mt () - - let pr_bindings_no_with prc prlc = function - | ImplicitBindings l -> - brk (0,1) ++ - prlist_with_sep spc prc l - | ExplicitBindings l -> - brk (0,1) ++ - prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | NoBindings -> mt () - let pr_clear_flag clear_flag pp x = match clear_flag with | Some false -> surround (pp x) @@ -190,7 +168,7 @@ type 'a extra_genarg_printer = | None -> pp x let pr_with_bindings prc prlc (c,bl) = - prc c ++ pr_bindings prc prlc bl + prc c ++ Miscprint.pr_bindings prc prlc bl let pr_with_bindings_arg prc prlc (clear_flag,c) = pr_clear_flag clear_flag (pr_with_bindings prc prlc) c @@ -367,30 +345,6 @@ type 'a extra_genarg_printer = | EvalConstRef sp -> Nametab.pr_global_env (Termops.vars_of_env env) (Globnames.ConstRef sp) - let pr_esubst prc l = - let pr_qhyp = function - (_,(AnonHyp n,c)) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" - | (_,(NamedHyp id,c)) -> - str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")" - in - prlist_with_sep spc pr_qhyp l - - let pr_bindings_gen for_ex prc prlc = function - | ImplicitBindings l -> - spc () ++ - hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ - prlist_with_sep spc prc l) - | ExplicitBindings l -> - spc () ++ - hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ - pr_esubst prlc l) - | NoBindings -> mt () - - let pr_bindings prc prlc = pr_bindings_gen false prc prlc - - let pr_with_bindings prc prlc (c,bl) = - hov 1 (prc c ++ pr_bindings prc prlc bl) - let pr_as_disjunctive_ipat prc ipatl = keyword "as" ++ spc () ++ pr_or_var (fun (loc,p) -> Miscprint.pr_or_and_intro_pattern prc p) ipatl @@ -571,7 +525,7 @@ type 'a extra_genarg_printer = str "=>" ++ brk (1,4) ++ pr t)) | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t - let pr_funvar n = spc () ++ pr_name n + let pr_funvar n = spc () ++ Name.print n let pr_let_clause k pr (id,(bl,t)) = hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++ @@ -582,7 +536,7 @@ type 'a extra_genarg_printer = hv 0 (pr_let_clause (if recflag then "let rec" else "let") pr hd ++ prlist (fun t -> spc () ++ pr_let_clause "with" pr t) tl) - | [] -> anomaly (Pp.str "LetIn must declare at least one binding") + | [] -> anomaly (Pp.str "LetIn must declare at least one binding.") let pr_seq_body pr tl = hv 0 (str "[ " ++ @@ -768,15 +722,15 @@ type 'a extra_genarg_printer = primitive "cofix" ++ spc () ++ pr_id id ++ spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l ) - | TacAssert (b,Some tac,ipat,c) -> + | TacAssert (ev,b,Some tac,ipat,c) -> hov 1 ( - primitive (if b then "assert" else "enough") ++ + primitive (if b then if ev then "eassert" else "assert" else if ev then "eenough" else "enough") ++ pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac ) - | TacAssert (_,None,ipat,c) -> + | TacAssert (ev,_,None,ipat,c) -> hov 1 ( - primitive "pose proof" + primitive (if ev then "epose proof" else "pose proof") ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ) | TacGeneralize l -> @@ -786,11 +740,11 @@ type 'a extra_genarg_printer = pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) l ) - | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl -> - hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c) - | TacLetTac (na,c,cl,b,e) -> + | TacLetTac (ev,na,c,cl,true,_) when Locusops.is_nowhere cl -> + hov 1 (primitive (if ev then "epose" else "pose") ++ pr_pose pr.pr_constr pr.pr_lconstr na c) + | TacLetTac (ev,na,c,cl,b,e) -> hov 1 ( - (if b then primitive "set" else primitive "remember") ++ + primitive (if b then if ev then "eset" else "set" else if ev then "eremember" else "remember") ++ (if b then pr_pose pr.pr_constr pr.pr_lconstr na c else pr_pose_as_style pr.pr_constr na c) ++ pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ @@ -1225,11 +1179,10 @@ let declare_extra_genarg_pprule wit (** Registering *) -let run_delayed c = - Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma } +let run_delayed c = c (Global.env ()) Evd.empty let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *) - | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (fst (run_delayed g)) + | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (snd (run_delayed g)) | clear_flag,ElimOnAnonHyp n as x -> x | clear_flag,ElimOnIdent id as x -> x @@ -1249,7 +1202,7 @@ let () = 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_econstr (fst (run_delayed c)))); + (Miscprint.pr_intro_pattern (fun c -> pr_econstr (snd (run_delayed c)))); Genprint.register_print0 wit_clause_dft_concl (pr_clauses (Some true) pr_lident) @@ -1280,13 +1233,13 @@ let () = (pr_red_expr (pr_econstr, pr_leconstr, pr_evaluable_reference, pr_constr_pattern)); 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_econstr pr_leconstr (fst (run_delayed it))); + (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr) + (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + (fun it -> Miscprint.pr_bindings_no_with pr_econstr pr_leconstr (snd (run_delayed it))); 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_econstr pr_leconstr (fst (run_delayed it))); + (fun it -> pr_with_bindings pr_econstr pr_leconstr (snd (run_delayed it))); 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)) diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 19bdf2d49..4265c416b 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -106,10 +106,6 @@ val pr_hintbases : string list option -> std_ppcmds val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds -val pr_bindings : - ('constr -> std_ppcmds) -> - ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds - val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 3ff7b53c7..b237e917d 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -113,7 +113,7 @@ let rec to_ltacprof_tactic m xml = children = List.fold_left to_ltacprof_tactic M.empty xs; } in M.add name node m - | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof_tactic XML") + | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof_tactic XML.") let to_ltacprof_results xml = let open Xml_datatype in @@ -125,7 +125,7 @@ let to_ltacprof_results xml = max_total = 0.0; local = 0.0; children = List.fold_left to_ltacprof_tactic M.empty xs } - | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML") + | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML.") let feedback_results results = Feedback.(feedback diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 966b11d0e..68dc1fd37 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -33,7 +33,6 @@ open Environ open Termops open EConstr open Libnames -open Sigma.Notations open Proofview.Notations open Context.Named.Declaration @@ -66,9 +65,7 @@ type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) let find_global dir s = let gr = lazy (find_reference dir s) in fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in - let evd = Sigma.to_evar_map sigma in + let (evd, c) = Evarutil.new_global evd (Lazy.force gr) in (evd, cstrs), c (** Utility for dealing with polymorphic applications *) @@ -89,9 +86,7 @@ let cstrevars evars = snd evars let new_cstr_evar (evd,cstrs) env t = let s = Typeclasses.set_resolvable Evd.Store.empty false in - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in - let evd' = Sigma.to_evar_map evd' in + let (evd', t) = Evarutil.new_evar ~store:s env evd t in let ev, _ = destEvar evd' t in (evd', Evar.Set.add ev cstrs), t @@ -176,17 +171,13 @@ end) = struct let proper_type = let l = lazy (Lazy.force proper_class).cl_impl in fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in - let evd = Sigma.to_evar_map sigma in + let (evd, c) = Evarutil.new_global evd (Lazy.force l) in (evd, cstrs), c let proper_proxy_type = let l = lazy (Lazy.force proper_proxy_class).cl_impl in fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in - let evd = Sigma.to_evar_map sigma in + let (evd, c) = Evarutil.new_global evd (Lazy.force l) in (evd, cstrs), c let proper_proof env evars carrier relation x = @@ -236,7 +227,7 @@ end) = struct let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs else user_err Pp.(str "build_signature: no constraint can apply on a dependent argument") - | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") + | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products.") | _, [] -> (match finalcstr with | None | Some (_, None) -> @@ -357,9 +348,7 @@ end) = struct (try let params, args = Array.chop (Array.length args - 2) args in let env' = push_rel_context rels env in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in - let evars = Sigma.to_evar_map evars in + let (evars, (evar, _)) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in let evars, inst = app_poly env (evars,Evar.Set.empty) rewrite_relation_class [| evar; mkApp (c, params) |] in @@ -419,9 +408,7 @@ module TypeGlobal = struct let inverse env (evd,cstrs) car rel = - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in - let evd = Sigma.to_evar_map sigma in + let (evd, sort) = Evarutil.new_Type ~rigid:Evd.univ_flexible env evd in app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] end @@ -751,17 +738,23 @@ let default_flags = { under_lambdas = true; on_morphisms = true; } let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None -let make_eq () = -(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) -let make_eq_refl () = -(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq_refl ())) +let new_global (evars, cstrs) gr = + let (sigma,c) = Evarutil.new_global evars gr in + (sigma, cstrs), c -let get_rew_prf r = match r.rew_prf with - | RewPrf (rel, prf) -> rel, prf +let make_eq sigma = + new_global sigma (Coqlib.build_coq_eq ()) +let make_eq_refl sigma = + new_global sigma (Coqlib.build_coq_eq_refl ()) + +let get_rew_prf evars r = match r.rew_prf with + | RewPrf (rel, prf) -> evars, (rel, prf) | RewCast c -> - let rel = mkApp (make_eq (), [| r.rew_car |]) in - rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]), - c, mkApp (rel, [| r.rew_from; r.rew_to |])) + let evars, eq = make_eq evars in + let evars, eq_refl = make_eq_refl evars in + let rel = mkApp (eq, [| r.rew_car |]) in + evars, (rel, mkCast (mkApp (eq_refl, [| r.rew_car; r.rew_from |]), + c, mkApp (rel, [| r.rew_from; r.rew_to |]))) let poly_subrelation sort = if sort then PropGlobal.subrelation else TypeGlobal.subrelation @@ -827,7 +820,8 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev env evars carrier relation x in [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' | Some r -> - [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, + let evars, proof = get_rew_prf evars r in + [ snd proof; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') | None -> if not (Option.is_empty y) then @@ -847,7 +841,8 @@ let apply_constraint env avoid car rel prf cstr res = | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res let coerce env avoid cstr res = - let rel, prf = get_rew_prf res in + let evars, (rel, prf) = get_rew_prf res.rew_evars res in + let res = { res with rew_evars = evars } in apply_constraint env avoid res.rew_car rel prf cstr res let apply_rule unify loccs : int pure_strategy = @@ -868,8 +863,7 @@ let apply_rule unify loccs : int pure_strategy = else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occ, Identity) else let res = { rew with rew_car = ty } in - let rel, prf = get_rew_prf res in - let res = Success (apply_constraint env unfresh rew.rew_car rel prf cstr res) in + let res = Success (coerce env unfresh cstr res) in (occ, res) } @@ -1231,9 +1225,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = in let res = match res with - | Success r -> - let rel, prf = get_rew_prf r in - Success (apply_constraint env unfresh r.rew_car rel prf (prop,cstr) r) + | Success r -> Success (coerce env unfresh (prop,cstr) r) | Fail | Identity -> res in state, res | _ -> state, Fail @@ -1401,15 +1393,14 @@ module Strategies = let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy = fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> let rfn, ckind = Redexpr.reduction_of_red_expr env r in - let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in - let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in - let evars' = Sigma.to_evar_map sigma in - if Termops.eq_constr evars' t' t then + let sigma = goalevars evars in + let (sigma, t') = rfn env sigma t in + if Termops.eq_constr sigma t' t then state, Identity else state, Success { rew_car = ty; rew_from = t; rew_to = t'; rew_prf = RewCast ckind; - rew_evars = evars', cstrevars evars } + rew_evars = sigma, cstrevars evars } } let fold_glob c : 'a pure_strategy = { strategy = @@ -1419,7 +1410,7 @@ module Strategies = let unfolded = try Tacred.try_red_product env sigma c with e when CErrors.noncritical e -> - user_err Pp.(str "fold: the term is not unfoldable !") + user_err Pp.(str "fold: the term is not unfoldable!") in try let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in @@ -1536,7 +1527,7 @@ let rec insert_dependent env sigma decl accu hyps = match hyps with insert_dependent env sigma decl (ndecl :: accu) rem let assert_replacing id newt tac = - let prf = Proofview.Goal.enter { enter = begin fun gl -> + let prf = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1547,17 +1538,17 @@ let assert_replacing id newt tac = | d :: rem -> insert_dependent env sigma (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 + Refine.refine ~unsafe:false begin fun sigma -> + let (sigma, ev) = Evarutil.new_evar env' sigma concl in + let (sigma, ev') = Evarutil.new_evar env sigma newt in let map d = let n = NamedDecl.get_id d in if Id.equal n id then ev' else mkVar n in - let (e, _) = destEvar (Sigma.to_evar_map sigma) ev in - Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) - end } - end } in + let (e, _) = destEvar sigma ev in + (sigma, mkEvar (e, Array.map_of_list map nc)) + end + end in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) let newfail n s = @@ -1581,7 +1572,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = match clause, prf with | Some id, Some p -> let tac = tclTHENLIST [ - Refine.refine ~unsafe:false { run = fun h -> Sigma.here p h }; + Refine.refine ~unsafe:false (fun h -> (h,p)); Proofview.Unsafe.tclNEWGOALS gls; ] in Proofview.Unsafe.tclEVARS undef <*> @@ -1592,19 +1583,19 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let make = { run = begin fun sigma -> - let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in - Sigma (mkApp (p, [| ev |]), sigma, q) - end } in + let make = begin fun sigma -> + let (sigma, ev) = Evarutil.new_evar env sigma newt in + (sigma, mkApp (p, [| ev |])) + end in Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls - end } + end | None, None -> Proofview.Unsafe.tclEVARS undef <*> convert_concl_no_check newt DEFAULTcast in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1632,7 +1623,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = with | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> raise (RewriteFailure (Himsg.explain_pretype_error env evd e)) - end } + end let tactic_init_setoid () = try init_setoid (); Proofview.tclUNIT () @@ -2087,7 +2078,7 @@ let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } (** Setoid rewriting when called with "rewrite" *) let general_s_rewrite cl l2r occs (c,l) ~new_goals = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in let unify env evars t = unify_abs res l2r sort env evars t in let app = apply_rule unify occs in @@ -2109,7 +2100,7 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals = | RewriteFailure e -> tclFAIL 0 (str"setoid rewrite failed: " ++ e) | e -> Proofview.tclZERO ~info e) - end } + end let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite @@ -2121,7 +2112,7 @@ let not_declared env sigma ty rel = str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library") let setoid_proof ty fn fallback = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -2150,7 +2141,7 @@ let setoid_proof ty fn fallback = | e' -> Proofview.tclZERO ~info e' end end - end } + end let tac_open ((evm,_), c) tac = (tclTHEN (Proofview.Unsafe.tclEVARS evm) (tac c)) @@ -2190,7 +2181,7 @@ let setoid_transitivity c = let setoid_symmetry_in id = let open Tacmach.New in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let ctype = pf_unsafe_type_of gl (mkVar id) in let binders,concl = decompose_prod_assum sigma ctype in @@ -2207,7 +2198,7 @@ let setoid_symmetry_in id = (tclTHENLAST (Tactics.assert_after_replacing id new_hyp) (tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ])) - end } + end let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 75f89a81e..f44ccbd3b 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -502,7 +502,7 @@ let print_ltacs () = | Tacexpr.TacFun (l, t) -> (l, t) | _ -> ([], body) in - let pr_ltac_fun_arg n = spc () ++ pr_name n in + let pr_ltac_fun_arg n = spc () ++ Name.print n in hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) in Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index e3c2b4ad5..efb7e780d 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -24,7 +24,7 @@ let register_alias key tac = let interp_alias key = try KNmap.find key !alias_map - with Not_found -> CErrors.anomaly (str "Unknown tactic alias: " ++ KerName.print key) + with Not_found -> CErrors.anomaly (str "Unknown tactic alias: " ++ KerName.print key ++ str ".") let check_alias key = KNmap.mem key !alias_map diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index bf760e7bb..cfb698cd8 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -117,8 +117,7 @@ type open_glob_constr = unit * glob_constr_and_expr 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 Tactypes.delayed_open = - { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } +type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open @@ -141,10 +140,10 @@ type 'a gen_atomic_tactic_expr = | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list | TacMutualCofix of Id.t * (Id.t * 'trm) list | TacAssert of - bool * 'tacexpr option option * + evars_flag * bool * 'tacexpr option option * 'dtrm intro_pattern_expr located option * 'trm | TacGeneralize of ('trm with_occurrences * Name.t) list - | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag * + | TacLetTac of evars_flag * Name.t * 'trm * 'nam clause_expr * letin_flag * intro_pattern_naming_expr located option (* Derived basic tactics *) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index e431a13bc..d201cf949 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -189,7 +189,7 @@ let intern_binding_name ist x = and if a term w/o ltac vars, check the name is indeed quantified *) x -let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env; extra} c = +let intern_constr_gen pattern_mode isarity {ltacvars=lfun; genv=env; extra} c = let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in let ltacvars = { @@ -198,7 +198,7 @@ let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env; extra} c = ltac_extra = extra; } in let c' = - warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c + warn (Constrintern.intern_gen scope ~pattern_mode ~ltacvars env) c in (c',if !strict_check then None else Some c) @@ -489,17 +489,17 @@ let rec intern_atomic lf ist x = | TacMutualCofix (id,l) -> let f (id,c) = (intern_ident lf ist id,intern_type ist c) in TacMutualCofix (intern_ident lf ist id, List.map f l) - | TacAssert (b,otac,ipat,c) -> - TacAssert (b,Option.map (Option.map (intern_pure_tactic ist)) otac, + | TacAssert (ev,b,otac,ipat,c) -> + TacAssert (ev,b,Option.map (Option.map (intern_pure_tactic ist)) otac, Option.map (intern_intro_pattern lf ist) ipat, intern_constr_gen false (not (Option.is_empty otac)) ist c) | TacGeneralize cl -> TacGeneralize (List.map (fun (c,na) -> intern_constr_with_occurrences ist c, intern_name lf ist na) cl) - | TacLetTac (na,c,cls,b,eqpat) -> + | TacLetTac (ev,na,c,cls,b,eqpat) -> let na = intern_name lf ist na in - TacLetTac (na,intern_constr ist c, + TacLetTac (ev,na,intern_constr ist c, (clause_app (intern_hyp_location ist) cls),b, (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) @@ -718,7 +718,7 @@ let split_ltac_fun = function | TacFun (l,t) -> (l,t) | t -> ([],t) -let pr_ltac_fun_arg n = spc () ++ pr_name n +let pr_ltac_fun_arg n = spc () ++ Name.print n let print_ltac id = try diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index a9ec779d1..ff76d06cf 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -37,7 +37,6 @@ open Misctypes open Locus open Tacintern open Taccoerce -open Sigma.Notations open Proofview.Notations open Context.Named.Declaration @@ -379,7 +378,7 @@ let try_interp_ltac_var coerce ist env (loc,id) = let interp_ltac_var coerce ist env locid = try try_interp_ltac_var coerce ist env locid - with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time") + with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time.") let interp_ident ist env sigma id = try try_interp_ltac_var (coerce_var_to_ident false env sigma) ist (Some (env,sigma)) (Loc.tag id) @@ -577,57 +576,47 @@ let extract_ltac_constr_context ist env sigma = (** Significantly simpler than [interp_constr], to interpret an untyped constr, it suffices to adjoin a closure environment. *) -let interp_uconstr ist env sigma = function - | (term,None) -> - { closure = extract_ltac_constr_context ist env sigma; term } - | (_,Some ce) -> - let ( {typed ; untyped } as closure) = extract_ltac_constr_context ist env sigma in +let interp_glob_closure ist env sigma ?(kind=WithoutTypeConstraint) ?(pattern_mode=false) (term,term_expr_opt) = + let closure = extract_ltac_constr_context ist env sigma in + match term_expr_opt with + | None -> { closure ; term } + | Some term_expr -> + (* If at toplevel (term_expr_opt<>None), the error can be due to + an incorrect context at globalization time: we retype with the + now known intros/lettac/inversion hypothesis names *) + let constr_context = + Id.Set.union + (Id.Map.domain closure.typed) + (Id.Map.domain closure.untyped) + in let ltacvars = { - Constrintern.ltac_vars = Id.(Set.union (Map.domain typed) (Map.domain untyped)); + ltac_vars = constr_context; ltac_bound = Id.Map.domain ist.lfun; ltac_extra = Genintern.Store.empty; } in - { closure ; term = intern_gen WithoutTypeConstraint ~ltacvars env ce } + { closure ; term = intern_gen kind ~pattern_mode ~ltacvars env term_expr } + +let interp_uconstr ist env sigma c = interp_glob_closure ist env sigma c -let interp_gen kind ist allow_patvar flags env sigma (c,ce) = - let constrvars = extract_ltac_constr_context ist env sigma in +let interp_gen kind ist pattern_mode flags env sigma c = + let kind_for_intern = match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in + let { closure = constrvars ; term } = + interp_glob_closure ist env sigma ~kind:kind_for_intern ~pattern_mode c in let vars = { Pretyping.ltac_constrs = constrvars.typed; Pretyping.ltac_uconstrs = constrvars.untyped; Pretyping.ltac_idents = constrvars.idents; Pretyping.ltac_genargs = ist.lfun; } in - let c = match ce with - | None -> c - (* If at toplevel (ce<>None), the error can be due to an incorrect - context at globalization time: we retype with the now known - intros/lettac/inversion hypothesis names *) - | Some c -> - let constr_context = - Id.Set.union - (Id.Map.domain constrvars.typed) - (Id.Set.union - (Id.Map.domain constrvars.untyped) - (Id.Map.domain constrvars.idents)) - in - let ltacvars = { - ltac_vars = constr_context; - ltac_bound = Id.Map.domain ist.lfun; - ltac_extra = Genintern.Store.empty; - } in - let kind_for_intern = - match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in - intern_gen kind_for_intern ~allow_patvar ~ltacvars env c - in (* Jason Gross: To avoid unnecessary modifications to tacinterp, as suggested by Arnaud Spiwack, we run push_trace immediately. We do this with the kludge of an empty proofview, and rely on the invariant that running the tactic returned by push_trace does not modify sigma. *) let (_, dummy_proofview) = Proofview.init sigma [] in - let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist) dummy_proofview in + let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist) dummy_proofview in let (evd,c) = - catch_error trace (understand_ltac flags env sigma vars kind) c + catch_error trace (understand_ltac flags env sigma vars kind) term in (* spiwack: to avoid unnecessary modifications of tacinterp, as this function already use effect, I call [run] hoping it doesn't mess @@ -672,12 +661,12 @@ let pure_open_constr_flags = { expand_evars = false } (* Interprets an open constr *) -let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist env sigma c = - let flags = - if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags () - else open_constr_use_classes_flags () in +let interp_open_constr ?(expected_type=WithoutTypeConstraint) ?(flags=open_constr_no_classes_flags ()) ist env sigma c = interp_gen expected_type ist false flags env sigma c +let interp_open_constr_with_classes ?(expected_type=WithoutTypeConstraint) ist env sigma c = + interp_gen expected_type ist false (open_constr_use_classes_flags ()) env sigma c + let interp_pure_open_constr ist = interp_gen WithoutTypeConstraint ist false pure_open_constr_flags @@ -777,9 +766,7 @@ let interp_may_eval f ist env sigma = function let (sigma,redexp) = interp_red_expr ist env sigma r in let (sigma,c_interp) = f ist env sigma c in let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in - (Sigma.to_evar_map sigma, c) + redfun env sigma c_interp | ConstrContext ((loc,s),c) -> (try let (sigma,ic) = f ist env sigma c in @@ -839,12 +826,12 @@ let rec message_of_value v = Ftactic.return (str "<tactic>") else if has_type v (topwit wit_constr) then let v = out_gen (topwit wit_constr) v in - Ftactic.enter {enter = begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) v) end } + Ftactic.enter begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) v) end else if has_type v (topwit wit_constr_under_binders) then let c = out_gen (topwit wit_constr_under_binders) v in - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c) - end } + end else if has_type v (topwit wit_unit) then Ftactic.return (str "()") else if has_type v (topwit wit_int) then @@ -852,24 +839,24 @@ let rec message_of_value v = else if has_type v (topwit wit_intro_pattern) then let p = out_gen (topwit wit_intro_pattern) v in let print env sigma c = - let (c, sigma) = Tactics.run_delayed env sigma c in + let (sigma, c) = c env sigma in pr_econstr_env env sigma c in - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) - end } + end else if has_type v (topwit wit_constr_context) then let c = out_gen (topwit wit_constr_context) v in - Ftactic.enter { enter = begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) c) end } + Ftactic.enter begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) c) end else if has_type v (topwit wit_uconstr) then let c = out_gen (topwit wit_uconstr) v in - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> Ftactic.return (pr_closed_glob_env (pf_env gl) (project gl) c) - end } + end else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in - Ftactic.enter { enter = begin fun gl -> Ftactic.return (pr_id id) end } + Ftactic.enter begin fun gl -> Ftactic.return (pr_id id) end else match Value.to_list v with | Some l -> Ftactic.List.map message_of_value l >>= fun l -> @@ -915,11 +902,7 @@ and interp_intro_pattern_action ist env sigma = function let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in sigma, IntroInjection l | IntroApplyOn ((loc,c),ipat) -> - let c = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } in + let c env sigma = interp_open_constr ist env sigma c in let sigma,ipat = interp_intro_pattern ist env sigma ipat in sigma, IntroApplyOn ((loc,c),ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x @@ -1013,21 +996,15 @@ let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = let loc1 = loc_of_glob_constr c in let loc2 = loc_of_bindings bl in let loc = Loc.merge_opt loc1 loc2 in - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in - Sigma.Unsafe.of_pair (c, sigma) - } in - (loc,f) + let f env sigma = interp_open_constr_with_bindings ist env sigma cb in + (loc,f) let interp_destruction_arg ist gl arg = match arg with | keep,ElimOnConstr c -> - keep,ElimOnConstr { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } + keep,ElimOnConstr begin fun env sigma -> + interp_open_constr_with_bindings ist env sigma c + end | keep,ElimOnAnonHyp n as x -> x | keep,ElimOnIdent (loc,id) -> let error () = user_err ?loc @@ -1038,12 +1015,12 @@ let interp_destruction_arg ist gl arg = if Tactics.is_quantified_hypothesis id' gl then keep,ElimOnIdent (loc,id') else - (keep, ElimOnConstr { delayed = begin fun env sigma -> - try Sigma.here (constr_of_id env id', NoBindings) sigma + (keep, ElimOnConstr begin fun env sigma -> + try (sigma, (constr_of_id env id', NoBindings)) with Not_found -> 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 }) + end) in try (** FIXME: should be moved to taccoerce *) @@ -1061,18 +1038,17 @@ let interp_destruction_arg ist gl arg = keep,ElimOnAnonHyp (out_gen (topwit wit_int) v) else match Value.to_constr v with | None -> error () - | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) } + | Some c -> keep,ElimOnConstr (fun env sigma -> (sigma, (c,NoBindings))) with Not_found -> (* We were in non strict (interactive) mode *) if Tactics.is_quantified_hypothesis id gl then keep,ElimOnIdent (loc,id) else let c = (CAst.make ?loc @@ GVar id,Some (CAst.make @@ CRef (Ident (loc,id),None))) in - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in + let f env sigma = let (sigma,c) = interp_open_constr ist env sigma c in - Sigma.Unsafe.of_pair ((c,NoBindings), sigma) - } in + (sigma, (c,NoBindings)) + in keep,ElimOnConstr f (* Associates variables with values and gives the remaining variables and @@ -1116,11 +1092,11 @@ let cons_and_check_name id l = let rec read_match_goal_hyps lfun ist env sigma lidh = function | (Hyp ((loc,na) as locna,mp))::tl -> - let lidh' = name_fold cons_and_check_name na lidh in + let lidh' = Name.fold_right cons_and_check_name na lidh in Hyp (locna,read_pattern lfun ist env sigma mp):: (read_match_goal_hyps lfun ist env sigma lidh' tl) | (Def ((loc,na) as locna,mv,mp))::tl -> - let lidh' = name_fold cons_and_check_name na lidh in + let lidh' = Name.fold_right cons_and_check_name na lidh in Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp):: (read_match_goal_hyps lfun ist env sigma lidh' tl) | [] -> [] @@ -1208,9 +1184,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) end | TacAbstract (tac,ido) -> - Proofview.Goal.enter { enter = begin fun gl -> Tactics.tclABSTRACT + Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac) - end } + end | TacThen (t1,t) -> Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) | TacDispatch tl -> @@ -1328,12 +1304,13 @@ and interp_tacarg ist arg : Val.t Ftactic.t = | TacGeneric arg -> interp_genarg ist arg | Reference r -> interp_ltac_reference false ist r | ConstrMayEval c -> - Ftactic.s_enter { s_enter = begin fun gl -> + Ftactic.enter begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in - Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Ftactic.return (Value.of_constr c_interp)) + end | TacCall (loc,(r,[])) -> interp_ltac_reference true ist r | TacCall (loc,(f,l)) -> @@ -1342,18 +1319,19 @@ and interp_tacarg ist arg : Val.t Ftactic.t = Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> interp_app loc ist fv largs | TacFreshId l -> - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let id = interp_fresh_id ist (pf_env gl) (project gl) l in Ftactic.return (in_gen (topwit wit_intro_pattern) (Loc.tag @@ IntroNaming (IntroIdentifier id))) - end } + end | TacPretype c -> - Ftactic.s_enter { s_enter = begin fun gl -> + Ftactic.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let c = interp_uconstr ist env (Sigma.to_evar_map sigma) c in - let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in - Sigma (Ftactic.return (Value.of_constr c), sigma, p) - end } + let c = interp_uconstr ist env sigma c in + let (sigma, c) = type_uconstr ist c env sigma in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Ftactic.return (Value.of_constr c)) + end | TacNumgoals -> Ftactic.lift begin let open Proofview.Notations in @@ -1423,7 +1401,7 @@ and tactic_of_value ist vle = (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++ Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++ Pp.str (String.plural numargs "variable") ++ Pp.str " " ++ - pr_enum pr_name vars ++ Pp.str ".") + pr_enum Name.print vars ++ Pp.str ".") | VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") else if has_type vle (topwit wit_tactic) then let tac = out_gen (topwit wit_tactic) vle in @@ -1514,16 +1492,16 @@ and interp_match ist lz constr lmr = Proofview.tclZERO ~info e end end >>= fun constr -> - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) - end } + end (* Interprets the Match Context expressions *) and interp_match_goal ist lz lr lmr = - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let hyps = Proofview.Goal.hyps gl in @@ -1531,7 +1509,7 @@ and interp_match_goal ist lz lr lmr = let concl = Proofview.Goal.concl gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr) - end } + end (* Interprets extended tactic generic arguments *) and interp_genarg ist x : Val.t Ftactic.t = @@ -1568,24 +1546,25 @@ and interp_genarg ist x : Val.t Ftactic.t = independently of goals. *) and interp_genarg_constr_list ist x = - Ftactic.nf_s_enter { s_enter = begin fun gl -> + Ftactic.nf_enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in let (sigma,lc) = interp_constr_list ist env sigma lc in let lc = in_list (val_tag wit_constr) lc in - Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Ftactic.return lc) + end and interp_genarg_var_list ist x = - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in let lc = interp_hyp_list ist env sigma lc in let lc = in_list (val_tag wit_var) lc in Ftactic.return lc - end } + end (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist e : EConstr.t Ftactic.t = @@ -1594,7 +1573,7 @@ and interp_ltac_constr ist e : EConstr.t Ftactic.t = (val_interp ist e) begin function (err, info) -> match err with | Not_found -> - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in Proofview.tclLIFT begin debugging_step ist (fun () -> @@ -1602,11 +1581,11 @@ and interp_ltac_constr ist e : EConstr.t Ftactic.t = Pptactic.pr_glob_tactic env e) end <*> Proofview.tclZERO Not_found - end } + end | err -> Proofview.tclZERO ~info err end end >>= fun result -> - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let result = Value.normalize result in @@ -1623,7 +1602,7 @@ and interp_ltac_constr ist e : EConstr.t Ftactic.t = let env = Proofview.Goal.env gl in Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ str "offending expression: " ++ fnl() ++ pr_inspect env e result) - end } + end (* Interprets tactic expressions : returns a "tactic" *) @@ -1645,7 +1624,7 @@ and interp_atomic ist tac : unit Proofview.tactic = match tac with (* Basic tactics *) | TacIntroPattern (ev,l) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in @@ -1655,11 +1634,11 @@ and interp_atomic ist tac : unit Proofview.tactic = (* spiwack: print uninterpreted, not sure if it is the expected behaviour. *) (Tactics.intro_patterns ev l')) sigma - end } + end | TacApply (a,ev,cb,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let l = List.map (fun (k,c) -> @@ -1672,10 +1651,10 @@ and interp_atomic ist tac : unit Proofview.tactic = let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in sigma, Tactics.apply_delayed_in a ev id l cl in Tacticals.New.tclWITHHOLES ev tac sigma - end } + end end | TacElim (ev,(keep,cb),cbo) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in @@ -1685,9 +1664,9 @@ and interp_atomic ist tac : unit Proofview.tactic = name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac in Tacticals.New.tclWITHHOLES ev named_tac sigma - end } + end | TacCase (ev,(keep,cb)) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in @@ -1696,11 +1675,11 @@ and interp_atomic ist tac : unit Proofview.tactic = name_atomic ~env (TacCase(ev,(keep,cb))) tac in Tacticals.New.tclWITHHOLES ev named_tac sigma - end } + end | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = let (sigma,c_interp) = interp_type ist env sigma c in @@ -1708,14 +1687,14 @@ and interp_atomic ist tac : unit Proofview.tactic = let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in - let tac = Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0 in - Sigma.Unsafe.of_pair (tac, sigma) - end } + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0) + end end | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let env = pf_env gl in let f sigma (id,c) = let (sigma,c_interp) = interp_type ist env sigma c in @@ -1723,26 +1702,29 @@ and interp_atomic ist tac : unit Proofview.tactic = let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in - let tac = Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0 in - Sigma.Unsafe.of_pair (tac, sigma) - end } + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0) end - | TacAssert (b,t,ipat,c) -> - Proofview.Goal.enter { enter = begin fun gl -> + end + | TacAssert (ev,b,t,ipat,c) -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in - let (sigma,c) = - (if Option.is_empty t then interp_constr else interp_type) ist env sigma c + let (sigma,c) = + let expected_type = + if Option.is_empty t then WithoutTypeConstraint else IsType in + let flags = open_constr_use_classes_flags () in + interp_open_constr ~expected_type ~flags ist env sigma c in let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in let tac = Option.map (Option.map (interp_tactic ist)) t in - Tacticals.New.tclWITHHOLES false + Tacticals.New.tclWITHHOLES ev (name_atomic ~env - (TacAssert(b,Option.map (Option.map ignore) t,ipat,c)) + (TacAssert(ev,b,Option.map (Option.map ignore) t,ipat,c)) (Tactics.forward b tac ipat' c)) sigma - end } + end | TacGeneralize cl -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in @@ -1750,46 +1732,47 @@ and interp_atomic ist tac : unit Proofview.tactic = (name_atomic ~env (TacGeneralize cl) (Tactics.generalize_gen cl)) sigma - end } - | TacLetTac (na,c,clp,b,eqpat) -> - Proofview.Goal.enter { enter = begin fun gl -> + end + | TacLetTac (ev,na,c,clp,b,eqpat) -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let clp = interp_clause ist env sigma clp in let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in - if Locusops.is_nowhere clp then + if Locusops.is_nowhere clp (* typically "pose" *) then (* We try to fully-typecheck the term *) - let (sigma,c_interp) = interp_constr ist env sigma c in + let flags = open_constr_use_classes_flags () in + let (sigma,c_interp) = interp_open_constr ~flags ist env sigma c in let let_tac b na c cl eqpat = let id = Option.default (Loc.tag IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in Tactics.letin_tac with_eq na c None cl in let na = interp_name ist env sigma na in - Tacticals.New.tclWITHHOLES false + Tacticals.New.tclWITHHOLES ev (name_atomic ~env - (TacLetTac(na,c_interp,clp,b,eqpat)) + (TacLetTac(ev,na,c_interp,clp,b,eqpat)) (let_tac b na c_interp clp eqpat)) sigma else (* We try to keep the pattern structure as much as possible *) let let_pat_tac b na c cl eqpat = let id = Option.default (Loc.tag IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in - Tactics.letin_pat_tac with_eq na c cl + Tactics.letin_pat_tac ev with_eq na c cl in let (sigma',c) = interp_pure_open_constr ist env sigma c in name_atomic ~env - (TacLetTac(na,c,clp,b,eqpat)) - (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*) + (TacLetTac(ev,na,c,clp,b,eqpat)) + (Tacticals.New.tclWITHHOLES ev (let_pat_tac b (interp_name ist env sigma na) (sigma,c) clp eqpat) sigma') - end } + end (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> (* spiwack: some unknown part of destruct needs the goal to be prenormalised. *) - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma,l = @@ -1808,23 +1791,23 @@ and interp_atomic ist tac : unit Proofview.tactic = let l,lp = List.split l in let sigma,el = Option.fold_map (interp_open_constr_with_bindings ist env) sigma el in - let tac = name_atomic ~env + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (name_atomic ~env (TacInductionDestruct(isrec,ev,(lp,el))) - (Tactics.induction_destruct isrec ev (l,el)) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + (Tactics.induction_destruct isrec ev (l,el))) + end (* Conversion *) | TacReduce (r,cl) -> - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in - Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma) - end } + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl)) + end | TacChange (None,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let is_onhyps = match cl.onhyps with | None | Some [] -> true | _ -> false @@ -1833,58 +1816,50 @@ and interp_atomic ist tac : unit Proofview.tactic = | AllOccurrences | NoOccurrences -> true | _ -> false in - let c_interp patvars = { Sigma.run = begin fun sigma -> + let c_interp patvars sigma = let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in - let sigma = Sigma.to_evar_map sigma in let ist = { ist with lfun = lfun' } in - let (sigma, c) = if is_onhyps && is_onconcl then interp_type ist (pf_env gl) sigma c else interp_constr ist (pf_env gl) sigma c - in - Sigma.Unsafe.of_pair (c, sigma) - end } in + in Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) - end } + end end | TacChange (Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let op = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> CErrors.is_anomaly e in - let c_interp patvars = { Sigma.run = begin fun sigma -> + let c_interp patvars sigma = let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in let ist = { ist with lfun = lfun' } in try - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_constr ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) + interp_constr ist env sigma c with e when to_catch e (* Hack *) -> user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") - end } in + in Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) - end } + end end (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let l' = List.map (fun (b,m,(keep,c)) -> - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } in + let f env sigma = + interp_open_constr_with_bindings ist env sigma c + in (b,m,keep,f)) l in let env = Proofview.Goal.env gl in let sigma = project gl in @@ -1895,9 +1870,9 @@ and interp_atomic ist tac : unit Proofview.tactic = (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by), Equality.Naive) by)) - end } + end | TacInversion (DepInversion (k,c,ids),hyp) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let (sigma,c_interp) = @@ -1913,9 +1888,9 @@ and interp_atomic ist tac : unit Proofview.tactic = (name_atomic ~env (TacInversion(DepInversion(k,c_interp,ids),dqhyps)) (Inv.dinv k c_interp ids_interp dqhyps)) sigma - end } + end | TacInversion (NonDepInversion (k,idl,ids),hyp) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let hyps = interp_hyp_list ist env sigma idl in @@ -1925,20 +1900,19 @@ and interp_atomic ist tac : unit Proofview.tactic = (name_atomic ~env (TacInversion (NonDepInversion (k,hyps,ids),dqhyps)) (Inv.inv_clause k ids_interp hyps dqhyps)) sigma - end } + end | TacInversion (InversionUsing (c,idl),hyp) -> - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let (sigma,c_interp) = interp_constr ist env sigma c in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let hyps = interp_hyp_list ist env sigma idl in - let tac = name_atomic ~env + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (name_atomic ~env (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) - (Leminv.lemInv_clause dqhyps c_interp hyps) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + (Leminv.lemInv_clause dqhyps c_interp hyps)) + end (* Initial call for interpretation *) @@ -1959,7 +1933,7 @@ let eval_tactic_ist ist t = let interp_tac_gen lfun avoid_ids debug t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let extra = TacStore.set TacStore.empty f_debug debug in let extra = TacStore.set extra f_avoid_ids avoid_ids in @@ -1967,7 +1941,7 @@ let interp_tac_gen lfun avoid_ids debug t = let ltacvars = Id.Map.domain lfun in interp_tactic ist (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars } t) - end } + end let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t @@ -1986,9 +1960,9 @@ let hide_interp global t ot = Proofview.tclENV >>= fun env -> hide_interp env else - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> hide_interp (Proofview.Goal.env gl) - end } + end (***************************************************************************) (** Register standard arguments *) @@ -2021,37 +1995,35 @@ let () = let () = declare_uniform wit_string -let lift f = (); fun ist x -> Ftactic.enter { enter = begin fun gl -> +let lift f = (); fun ist x -> Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in Ftactic.return (f ist env sigma x) -end } +end -let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl -> +let lifts f = (); fun ist x -> Ftactic.nf_enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in let (sigma, v) = f ist env sigma x in - Sigma.Unsafe.of_pair (Ftactic.return v, sigma) -end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Ftactic.return v) +end -let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> - let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in - Sigma.Unsafe.of_pair (bl, sigma) - } +let interp_bindings' ist bl = Ftactic.return begin fun env sigma -> + interp_bindings ist env sigma bl + end -let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> - let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in - Sigma.Unsafe.of_pair (c, sigma) - } +let interp_constr_with_bindings' ist c = Ftactic.return begin fun env sigma -> + interp_constr_with_bindings ist env sigma c + end -let interp_open_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> - let (sigma, c) = interp_open_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in - Sigma.Unsafe.of_pair (c, sigma) - } +let interp_open_constr_with_bindings' ist c = Ftactic.return begin fun env sigma -> + interp_open_constr_with_bindings ist env sigma c + end -let interp_destruction_arg' ist c = Ftactic.enter { enter = begin fun gl -> +let interp_destruction_arg' ist c = Ftactic.enter begin fun gl -> Ftactic.return (interp_destruction_arg ist gl c) -end } +end let interp_pre_ident ist env sigma s = s |> Id.of_string |> interp_ident ist env sigma |> Id.to_string @@ -2084,9 +2056,9 @@ let () = register_interp0 wit_ltac interp let () = - register_interp0 wit_uconstr (fun ist c -> Ftactic.enter { enter = begin fun gl -> + register_interp0 wit_uconstr (fun ist c -> Ftactic.enter begin fun gl -> Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) (Tacmach.New.project gl) c) - end }) + end) (***************************************************************************) (* Other entry points *) @@ -2117,7 +2089,7 @@ let _ = let dummy_id = Id.of_string "_" let lift_constr_tac_to_ml_tac vars tac = - let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> + let tac _ ist = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let map = function @@ -2130,7 +2102,7 @@ let lift_constr_tac_to_ml_tac vars tac = in let args = List.map_filter map vars in tac args ist - end } in + end in tac let vernac_debug b = diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index 2ec45312e..fb50a6434 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -72,11 +72,27 @@ val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map -> Id.t Loc.located -> Id.t +val interp_glob_closure : interp_sign -> Environ.env -> Evd.evar_map -> + ?kind:Pretyping.typing_constraint -> ?pattern_mode:bool -> glob_constr_and_expr -> + Glob_term.closed_glob_constr + +val interp_uconstr : interp_sign -> Environ.env -> Evd.evar_map -> + glob_constr_and_expr -> Glob_term.closed_glob_constr + val interp_constr_gen : Pretyping.typing_constraint -> interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Evd.evar_map * constr val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> - glob_constr_and_expr bindings -> Evd.evar_map * constr bindings + glob_constr_and_expr bindings -> Evd.evar_map * constr bindings + +val interp_open_constr : ?expected_type:Pretyping.typing_constraint -> + ?flags:Pretyping.inference_flags -> + interp_sign -> Environ.env -> Evd.evar_map -> + glob_constr_and_expr -> Evd.evar_map * EConstr.constr + +val interp_open_constr_with_classes : ?expected_type:Pretyping.typing_constraint -> + interp_sign -> Environ.env -> Evd.evar_map -> + glob_constr_and_expr -> Evd.evar_map * EConstr.constr val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr with_bindings -> Evd.evar_map * EConstr.constr with_bindings diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 4390ff08b..2858df313 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -14,7 +14,6 @@ open Stdarg open Tacarg open Misctypes open Globnames -open Term open Genredexpr open Patternops @@ -91,7 +90,7 @@ open Printer let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in - if not (eq_constr (Universes.constr_of_global ref') t') then + if not (is_global ref' t') then Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ pr_global ref') ; @@ -146,13 +145,13 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) | TacMutualCofix (id,l) -> TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l) - | TacAssert (b,otac,na,c) -> - TacAssert (b,Option.map (Option.map (subst_tactic subst)) otac,na, + | TacAssert (ev,b,otac,na,c) -> + TacAssert (ev,b,Option.map (Option.map (subst_tactic subst)) otac,na, subst_glob_constr subst c) | TacGeneralize cl -> TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl) - | TacLetTac (id,c,clp,b,eqpat) -> - TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) + | TacLetTac (ev,id,c,clp,b,eqpat) -> + TacLetTac (ev,id,subst_glob_constr subst c,clp,b,eqpat) (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 294cba4d7..e6d0370f3 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -12,7 +12,6 @@ open Pp open Tacexpr open Termops open Nameops -open Proofview.Notations let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () @@ -57,10 +56,10 @@ let db_pr_goal gl = str" " ++ pc) ++ fnl () let db_pr_goal = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let pg = db_pr_goal gl in Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) - end } + end (* Prints the commands *) diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 4ec111e01..d8e21d81d 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -220,9 +220,7 @@ let apply_nnpp _ ist = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> try - let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in - let nnpp = EConstr.of_constr nnpp in - apply nnpp + Tacticals.New.pf_constr_of_global (Nametab.global_of_path coq_nnpp_path) >>= apply with Not_found -> tclFAIL 0 (Pp.mt ()) end diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index d28bb8286..4d5c3b1d5 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -38,17 +38,17 @@ Extract Inductive sumor => option [ Some None ]. Let's rather use the ocaml && *) Extract Inlined Constant andb => "(&&)". -Require Import Reals. +Import Reals.Rdefinitions. -Extract Constant R => "int". -Extract Constant R0 => "0". -Extract Constant R1 => "1". +Extract Constant R => "int". +Extract Constant R0 => "0". +Extract Constant R1 => "1". Extract Constant Rplus => "( + )". Extract Constant Rmult => "( * )". Extract Constant Ropp => "fun x -> - x". Extract Constant Rinv => "fun x -> 1 / x". -Extraction "micromega.ml" +Extraction "plugins/micromega/micromega.ml" List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 7497aae3c..83f374346 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1668,8 +1668,6 @@ let rcst_domain_spec = lazy { dump_proof = dump_psatz coq_Q dump_q } -open Proofview.Notations - (** Naive topological sort of constr according to the subterm-ordering *) (* An element is minimal x is minimal w.r.t y if @@ -1712,7 +1710,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in let vm = dump_varmap (spec.typ) (vm_of_list env) in (* todo : directly generate the proof term - or generalize before conversion? *) - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> Tacticals.New.tclTHENLIST [ Tactics.change_concl @@ -1724,7 +1722,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* ] (Tacmach.New.pf_concl gl)) ] - end } + end (** @@ -1972,7 +1970,7 @@ let micromega_gen (normalise:'cst atom -> 'cst mc_cnf) unsat deduce spec dumpexpr prover tac = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in @@ -2029,7 +2027,7 @@ let micromega_gen ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end } + end let micromega_gen parse_arith (negate:'cst atom -> 'cst mc_cnf) @@ -2050,7 +2048,7 @@ let micromega_order_changer cert env ff = let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) (vm_of_list env) in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> Tacticals.New.tclTHENLIST [ (Tactics.change_concl @@ -2065,7 +2063,7 @@ let micromega_order_changer cert env ff = (Tacmach.New.pf_concl gl))); (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) ] - end } + end let micromega_genr prover tac = let parse_arith = parse_rarith in @@ -2080,7 +2078,7 @@ let micromega_genr prover tac = proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in @@ -2144,7 +2142,7 @@ let micromega_genr prover tac = ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end } + end diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml deleted file mode 100644 index 5cf1da8ea..000000000 --- a/plugins/micromega/micromega.ml +++ /dev/null @@ -1,1809 +0,0 @@ -(** val negb : bool -> bool **) - -let negb = function -| true -> false -| false -> true - -type nat = -| O -| S of nat - -(** val app : 'a1 list -> 'a1 list -> 'a1 list **) - -let rec app l m = - match l with - | [] -> m - | a::l1 -> a::(app l1 m) - -type comparison = -| Eq -| Lt -| Gt - -(** val compOpp : comparison -> comparison **) - -let compOpp = function -| Eq -> Eq -| Lt -> Gt -| Gt -> Lt - -module Coq__1 = struct - (** val add : nat -> nat -> nat **) - let rec add n0 m = - match n0 with - | O -> m - | S p -> S (add p m) -end -let add = Coq__1.add - - -type positive = -| XI of positive -| XO of positive -| XH - -type n = -| N0 -| Npos of positive - -type z = -| Z0 -| Zpos of positive -| Zneg of positive - -module Pos = - struct - type mask = - | IsNul - | IsPos of positive - | IsNeg - end - -module Coq_Pos = - struct - (** val succ : positive -> positive **) - - let rec succ = function - | XI p -> XO (succ p) - | XO p -> XI p - | XH -> XO XH - - (** val add : positive -> positive -> positive **) - - let rec add x y = - match x with - | XI p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XO p -> - (match y with - | XI q0 -> XI (add p q0) - | XO q0 -> XO (add p q0) - | XH -> XI p) - | XH -> - (match y with - | XI q0 -> XO (succ q0) - | XO q0 -> XI q0 - | XH -> XO XH) - - (** val add_carry : positive -> positive -> positive **) - - and add_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> XI (add_carry p q0) - | XO q0 -> XO (add_carry p q0) - | XH -> XI (succ p)) - | XO p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XH -> - (match y with - | XI q0 -> XI (succ q0) - | XO q0 -> XO (succ q0) - | XH -> XI XH) - - (** val pred_double : positive -> positive **) - - let rec pred_double = function - | XI p -> XI (XO p) - | XO p -> XI (pred_double p) - | XH -> XH - - type mask = Pos.mask = - | IsNul - | IsPos of positive - | IsNeg - - (** val succ_double_mask : mask -> mask **) - - let succ_double_mask = function - | IsNul -> IsPos XH - | IsPos p -> IsPos (XI p) - | IsNeg -> IsNeg - - (** val double_mask : mask -> mask **) - - let double_mask = function - | IsPos p -> IsPos (XO p) - | x0 -> x0 - - (** val double_pred_mask : positive -> mask **) - - let double_pred_mask = function - | XI p -> IsPos (XO (XO p)) - | XO p -> IsPos (XO (pred_double p)) - | XH -> IsNul - - (** val sub_mask : positive -> positive -> mask **) - - let rec sub_mask x y = - match x with - | XI p -> - (match y with - | XI q0 -> double_mask (sub_mask p q0) - | XO q0 -> succ_double_mask (sub_mask p q0) - | XH -> IsPos (XO p)) - | XO p -> - (match y with - | XI q0 -> succ_double_mask (sub_mask_carry p q0) - | XO q0 -> double_mask (sub_mask p q0) - | XH -> IsPos (pred_double p)) - | XH -> - (match y with - | XH -> IsNul - | _ -> IsNeg) - - (** val sub_mask_carry : positive -> positive -> mask **) - - and sub_mask_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> succ_double_mask (sub_mask_carry p q0) - | XO q0 -> double_mask (sub_mask p q0) - | XH -> IsPos (pred_double p)) - | XO p -> - (match y with - | XI q0 -> double_mask (sub_mask_carry p q0) - | XO q0 -> succ_double_mask (sub_mask_carry p q0) - | XH -> double_pred_mask p) - | XH -> IsNeg - - (** val sub : positive -> positive -> positive **) - - let sub x y = - match sub_mask x y with - | IsPos z0 -> z0 - | _ -> XH - - (** val mul : positive -> positive -> positive **) - - let rec mul x y = - match x with - | XI p -> add y (XO (mul p y)) - | XO p -> XO (mul p y) - | XH -> y - - (** val size_nat : positive -> nat **) - - let rec size_nat = function - | XI p2 -> S (size_nat p2) - | XO p2 -> S (size_nat p2) - | XH -> S O - - (** val compare_cont : - comparison -> positive -> positive -> comparison **) - - let rec compare_cont r x y = - match x with - | XI p -> - (match y with - | XI q0 -> compare_cont r p q0 - | XO q0 -> compare_cont Gt p q0 - | XH -> Gt) - | XO p -> - (match y with - | XI q0 -> compare_cont Lt p q0 - | XO q0 -> compare_cont r p q0 - | XH -> Gt) - | XH -> - (match y with - | XH -> r - | _ -> Lt) - - (** val compare : positive -> positive -> comparison **) - - let compare = - compare_cont Eq - - (** val gcdn : nat -> positive -> positive -> positive **) - - let rec gcdn n0 a b = - match n0 with - | O -> XH - | S n1 -> - (match a with - | XI a' -> - (match b with - | XI b' -> - (match compare a' b' with - | Eq -> a - | Lt -> gcdn n1 (sub b' a') a - | Gt -> gcdn n1 (sub a' b') b) - | XO b0 -> gcdn n1 a b0 - | XH -> XH) - | XO a0 -> - (match b with - | XI _ -> gcdn n1 a0 b - | XO b0 -> XO (gcdn n1 a0 b0) - | XH -> XH) - | XH -> XH) - - (** val gcd : positive -> positive -> positive **) - - let gcd a b = - gcdn (Coq__1.add (size_nat a) (size_nat b)) a b - - (** val of_succ_nat : nat -> positive **) - - let rec of_succ_nat = function - | O -> XH - | S x -> succ (of_succ_nat x) - end - -module N = - struct - (** val of_nat : nat -> n **) - - let of_nat = function - | O -> N0 - | S n' -> Npos (Coq_Pos.of_succ_nat n') - end - -(** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) - -let rec pow_pos rmul x = function -| XI i0 -> let p = pow_pos rmul x i0 in rmul x (rmul p p) -| XO i0 -> let p = pow_pos rmul x i0 in rmul p p -| XH -> x - -(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) - -let rec nth n0 l default = - match n0 with - | O -> - (match l with - | [] -> default - | x::_ -> x) - | S m -> - (match l with - | [] -> default - | _::t0 -> nth m t0 default) - -(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) - -let rec map f = function -| [] -> [] -| a::t0 -> (f a)::(map f t0) - -(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) - -let rec fold_right f a0 = function -| [] -> a0 -| b::t0 -> f b (fold_right f a0 t0) - -module Z = - struct - (** val double : z -> z **) - - let double = function - | Z0 -> Z0 - | Zpos p -> Zpos (XO p) - | Zneg p -> Zneg (XO p) - - (** val succ_double : z -> z **) - - let succ_double = function - | Z0 -> Zpos XH - | Zpos p -> Zpos (XI p) - | Zneg p -> Zneg (Coq_Pos.pred_double p) - - (** val pred_double : z -> z **) - - let pred_double = function - | Z0 -> Zneg XH - | Zpos p -> Zpos (Coq_Pos.pred_double p) - | Zneg p -> Zneg (XI p) - - (** val pos_sub : positive -> positive -> z **) - - let rec pos_sub x y = - match x with - | XI p -> - (match y with - | XI q0 -> double (pos_sub p q0) - | XO q0 -> succ_double (pos_sub p q0) - | XH -> Zpos (XO p)) - | XO p -> - (match y with - | XI q0 -> pred_double (pos_sub p q0) - | XO q0 -> double (pos_sub p q0) - | XH -> Zpos (Coq_Pos.pred_double p)) - | XH -> - (match y with - | XI q0 -> Zneg (XO q0) - | XO q0 -> Zneg (Coq_Pos.pred_double q0) - | XH -> Z0) - - (** val add : z -> z -> z **) - - let add x y = - match x with - | Z0 -> y - | Zpos x' -> - (match y with - | Z0 -> x - | Zpos y' -> Zpos (Coq_Pos.add x' y') - | Zneg y' -> pos_sub x' y') - | Zneg x' -> - (match y with - | Z0 -> x - | Zpos y' -> pos_sub y' x' - | Zneg y' -> Zneg (Coq_Pos.add x' y')) - - (** val opp : z -> z **) - - let opp = function - | Z0 -> Z0 - | Zpos x0 -> Zneg x0 - | Zneg x0 -> Zpos x0 - - (** val sub : z -> z -> z **) - - let sub m n0 = - add m (opp n0) - - (** val mul : z -> z -> z **) - - let mul x y = - match x with - | Z0 -> Z0 - | Zpos x' -> - (match y with - | Z0 -> Z0 - | Zpos y' -> Zpos (Coq_Pos.mul x' y') - | Zneg y' -> Zneg (Coq_Pos.mul x' y')) - | Zneg x' -> - (match y with - | Z0 -> Z0 - | Zpos y' -> Zneg (Coq_Pos.mul x' y') - | Zneg y' -> Zpos (Coq_Pos.mul x' y')) - - (** val compare : z -> z -> comparison **) - - let compare x y = - match x with - | Z0 -> - (match y with - | Z0 -> Eq - | Zpos _ -> Lt - | Zneg _ -> Gt) - | Zpos x' -> - (match y with - | Zpos y' -> Coq_Pos.compare x' y' - | _ -> Gt) - | Zneg x' -> - (match y with - | Zneg y' -> compOpp (Coq_Pos.compare x' y') - | _ -> Lt) - - (** val leb : z -> z -> bool **) - - let leb x y = - match compare x y with - | Gt -> false - | _ -> true - - (** val ltb : z -> z -> bool **) - - let ltb x y = - match compare x y with - | Lt -> true - | _ -> false - - (** val gtb : z -> z -> bool **) - - let gtb x y = - match compare x y with - | Gt -> true - | _ -> false - - (** val max : z -> z -> z **) - - let max n0 m = - match compare n0 m with - | Lt -> m - | _ -> n0 - - (** val abs : z -> z **) - - let abs = function - | Zneg p -> Zpos p - | x -> x - - (** val to_N : z -> n **) - - let to_N = function - | Zpos p -> Npos p - | _ -> N0 - - (** val pos_div_eucl : positive -> z -> z * z **) - - let rec pos_div_eucl a b = - match a with - | XI a' -> - let q0,r = pos_div_eucl a' b in - let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in - if ltb r' b - then (mul (Zpos (XO XH)) q0),r' - else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) - | XO a' -> - let q0,r = pos_div_eucl a' b in - let r' = mul (Zpos (XO XH)) r in - if ltb r' b - then (mul (Zpos (XO XH)) q0),r' - else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) - | XH -> if leb (Zpos (XO XH)) b then Z0,(Zpos XH) else (Zpos XH),Z0 - - (** val div_eucl : z -> z -> z * z **) - - let div_eucl a b = - match a with - | Z0 -> Z0,Z0 - | Zpos a' -> - (match b with - | Z0 -> Z0,Z0 - | Zpos _ -> pos_div_eucl a' b - | Zneg b' -> - let q0,r = pos_div_eucl a' (Zpos b') in - (match r with - | Z0 -> (opp q0),Z0 - | _ -> (opp (add q0 (Zpos XH))),(add b r))) - | Zneg a' -> - (match b with - | Z0 -> Z0,Z0 - | Zpos _ -> - let q0,r = pos_div_eucl a' b in - (match r with - | Z0 -> (opp q0),Z0 - | _ -> (opp (add q0 (Zpos XH))),(sub b r)) - | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in q0,(opp r)) - - (** val div : z -> z -> z **) - - let div a b = - let q0,_ = div_eucl a b in q0 - - (** val gcd : z -> z -> z **) - - let gcd a b = - match a with - | Z0 -> abs b - | Zpos a0 -> - (match b with - | Z0 -> abs a - | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) - | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) - | Zneg a0 -> - (match b with - | Z0 -> abs a - | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) - | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) - end - -(** val zeq_bool : z -> z -> bool **) - -let zeq_bool x y = - match Z.compare x y with - | Eq -> true - | _ -> false - -type 'c pol = -| Pc of 'c -| Pinj of positive * 'c pol -| PX of 'c pol * positive * 'c pol - -(** val p0 : 'a1 -> 'a1 pol **) - -let p0 cO = - Pc cO - -(** val p1 : 'a1 -> 'a1 pol **) - -let p1 cI = - Pc cI - -(** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **) - -let rec peq ceqb p p' = - match p with - | Pc c -> - (match p' with - | Pc c' -> ceqb c c' - | _ -> false) - | Pinj (j, q0) -> - (match p' with - | Pinj (j', q') -> - (match Coq_Pos.compare j j' with - | Eq -> peq ceqb q0 q' - | _ -> false) - | _ -> false) - | PX (p2, i, q0) -> - (match p' with - | PX (p'0, i', q') -> - (match Coq_Pos.compare i i' with - | Eq -> if peq ceqb p2 p'0 then peq ceqb q0 q' else false - | _ -> false) - | _ -> false) - -(** val mkPinj : positive -> 'a1 pol -> 'a1 pol **) - -let mkPinj j p = match p with -| Pc _ -> p -| Pinj (j', q0) -> Pinj ((Coq_Pos.add j j'), q0) -| PX (_, _, _) -> Pinj (j, p) - -(** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) - -let mkPinj_pred j p = - match j with - | XI j0 -> Pinj ((XO j0), p) - | XO j0 -> Pinj ((Coq_Pos.pred_double j0), p) - | XH -> p - -(** val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 - pol **) - -let mkPX cO ceqb p i q0 = - match p with - | Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0) - | Pinj (_, _) -> PX (p, i, q0) - | PX (p', i', q') -> - if peq ceqb q' (p0 cO) - then PX (p', (Coq_Pos.add i' i), q0) - else PX (p, i, q0) - -(** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **) - -let mkXi cO cI i = - PX ((p1 cI), i, (p0 cO)) - -(** val mkX : 'a1 -> 'a1 -> 'a1 pol **) - -let mkX cO cI = - mkXi cO cI XH - -(** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) - -let rec popp copp = function -| Pc c -> Pc (copp c) -| Pinj (j, q0) -> Pinj (j, (popp copp q0)) -| PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0)) - -(** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) - -let rec paddC cadd p c = - match p with - | Pc c1 -> Pc (cadd c1 c) - | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c)) - | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c)) - -(** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) - -let rec psubC csub p c = - match p with - | Pc c1 -> Pc (csub c1 c) - | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c)) - | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c)) - -(** val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol **) - -let rec paddI cadd pop q0 j = function -| Pc c -> mkPinj j (paddC cadd q0 c) -| Pinj (j', q') -> - (match Z.pos_sub j' j with - | Z0 -> mkPinj j (pop q' q0) - | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) - | Zneg k -> mkPinj j' (paddI cadd pop q0 k q')) -| PX (p2, i, q') -> - (match j with - | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q')) - | XO j0 -> PX (p2, i, (paddI cadd pop q0 (Coq_Pos.pred_double j0) q')) - | XH -> PX (p2, i, (pop q' q0))) - -(** val psubI : - ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec psubI cadd copp pop q0 j = function -| Pc c -> mkPinj j (paddC cadd (popp copp q0) c) -| Pinj (j', q') -> - (match Z.pos_sub j' j with - | Z0 -> mkPinj j (pop q' q0) - | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) - | Zneg k -> mkPinj j' (psubI cadd copp pop q0 k q')) -| PX (p2, i, q') -> - (match j with - | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q')) - | XO j0 -> - PX (p2, i, (psubI cadd copp pop q0 (Coq_Pos.pred_double j0) q')) - | XH -> PX (p2, i, (pop q' q0))) - -(** val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 - pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec paddX cO ceqb pop p' i' p = match p with -| Pc _ -> PX (p', i', p) -| Pinj (j, q') -> - (match j with - | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) - | XO j0 -> PX (p', i', (Pinj ((Coq_Pos.pred_double j0), q'))) - | XH -> PX (p', i', q')) -| PX (p2, i, q') -> - (match Z.pos_sub i i' with - | Z0 -> mkPX cO ceqb (pop p2 p') i q' - | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' - | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') - -(** val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> - 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec psubX cO copp ceqb pop p' i' p = match p with -| Pc _ -> PX ((popp copp p'), i', p) -| Pinj (j, q') -> - (match j with - | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) - | XO j0 -> - PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q'))) - | XH -> PX ((popp copp p'), i', q')) -| PX (p2, i, q') -> - (match Z.pos_sub i i' with - | Z0 -> mkPX cO ceqb (pop p2 p') i q' - | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' - | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') - -(** val padd : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 - pol -> 'a1 pol **) - -let rec padd cO cadd ceqb p = function -| Pc c' -> paddC cadd p c' -| Pinj (j', q') -> paddI cadd (padd cO cadd ceqb) q' j' p -| PX (p'0, i', q') -> - (match p with - | Pc c -> PX (p'0, i', (paddC cadd q' c)) - | Pinj (j, q0) -> - (match j with - | XI j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((XO j0), q0)) q')) - | XO j0 -> - PX (p'0, i', - (padd cO cadd ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q')) - | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q'))) - | PX (p2, i, q0) -> - (match Z.pos_sub i i' with - | Z0 -> - mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i - (padd cO cadd ceqb q0 q') - | Zpos k -> - mkPX cO ceqb (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' - (padd cO cadd ceqb q0 q') - | Zneg k -> - mkPX cO ceqb (paddX cO ceqb (padd cO cadd ceqb) p'0 k p2) i - (padd cO cadd ceqb q0 q'))) - -(** val psub : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> - ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) - -let rec psub cO cadd csub copp ceqb p = function -| Pc c' -> psubC csub p c' -| Pinj (j', q') -> psubI cadd copp (psub cO cadd csub copp ceqb) q' j' p -| PX (p'0, i', q') -> - (match p with - | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c)) - | Pinj (j, q0) -> - (match j with - | XI j0 -> - PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) - | XO j0 -> - PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), - q0)) q')) - | XH -> - PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q'))) - | PX (p2, i, q0) -> - (match Z.pos_sub i i' with - | Z0 -> - mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i - (psub cO cadd csub copp ceqb q0 q') - | Zpos k -> - mkPX cO ceqb - (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) i' - (psub cO cadd csub copp ceqb q0 q') - | Zneg k -> - mkPX cO ceqb - (psubX cO copp ceqb (psub cO cadd csub copp ceqb) p'0 k p2) i - (psub cO cadd csub copp ceqb q0 q'))) - -(** val pmulC_aux : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 - -> 'a1 pol **) - -let rec pmulC_aux cO cmul ceqb p c = - match p with - | Pc c' -> Pc (cmul c' c) - | Pinj (j, q0) -> mkPinj j (pmulC_aux cO cmul ceqb q0 c) - | PX (p2, i, q0) -> - mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i - (pmulC_aux cO cmul ceqb q0 c) - -(** val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol - -> 'a1 -> 'a1 pol **) - -let pmulC cO cI cmul ceqb p c = - if ceqb c cO - then p0 cO - else if ceqb c cI then p else pmulC_aux cO cmul ceqb p c - -(** val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol - -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec pmulI cO cI cmul ceqb pmul0 q0 j = function -| Pc c -> mkPinj j (pmulC cO cI cmul ceqb q0 c) -| Pinj (j', q') -> - (match Z.pos_sub j' j with - | Z0 -> mkPinj j (pmul0 q' q0) - | Zpos k -> mkPinj j (pmul0 (Pinj (k, q')) q0) - | Zneg k -> mkPinj j' (pmulI cO cI cmul ceqb pmul0 q0 k q')) -| PX (p', i', q') -> - (match j with - | XI j' -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' - (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q') - | XO j' -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' - (pmulI cO cI cmul ceqb pmul0 q0 (Coq_Pos.pred_double j') q') - | XH -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' (pmul0 q' q0)) - -(** val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) - -let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with -| Pc c -> pmulC cO cI cmul ceqb p c -| Pinj (j', q') -> - pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p -| PX (p', i', q') -> - (match p with - | Pc c -> pmulC cO cI cmul ceqb p'' c - | Pinj (j, q0) -> - let qQ' = - match j with - | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' - | XO j0 -> - pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) - q' - | XH -> pmul cO cI cadd cmul ceqb q0 q' - in - mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ' - | PX (p2, i, q0) -> - let qQ' = pmul cO cI cadd cmul ceqb q0 q' in - let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 - in - let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q0) p' in - let pP' = pmul cO cI cadd cmul ceqb p2 p' in - padd cO cadd ceqb - (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') - i' (p0 cO)) (mkPX cO ceqb pQ' i qQ')) - -(** val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> bool) -> 'a1 pol -> 'a1 pol **) - -let rec psquare cO cI cadd cmul ceqb = function -| Pc c -> Pc (cmul c c) -| Pinj (j, q0) -> Pinj (j, (psquare cO cI cadd cmul ceqb q0)) -| PX (p2, i, q0) -> - let twoPQ = - pmul cO cI cadd cmul ceqb p2 - (mkPinj XH (pmulC cO cI cmul ceqb q0 (cadd cI cI))) - in - let q2 = psquare cO cI cadd cmul ceqb q0 in - let p3 = psquare cO cI cadd cmul ceqb p2 in - mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb p3 i (p0 cO)) twoPQ) i q2 - -type 'c pExpr = -| PEc of 'c -| PEX of positive -| PEadd of 'c pExpr * 'c pExpr -| PEsub of 'c pExpr * 'c pExpr -| PEmul of 'c pExpr * 'c pExpr -| PEopp of 'c pExpr -| PEpow of 'c pExpr * n - -(** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) - -let mk_X cO cI j = - mkPinj_pred j (mkX cO cI) - -(** val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive - -> 'a1 pol **) - -let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function -| XI p3 -> - subst_l - (pmul cO cI cadd cmul ceqb - (ppow_pos cO cI cadd cmul ceqb subst_l - (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p) -| XO p3 -> - ppow_pos cO cI cadd cmul ceqb subst_l - (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3 -| XH -> subst_l (pmul cO cI cadd cmul ceqb res p) - -(** val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **) - -let ppow_N cO cI cadd cmul ceqb subst_l p = function -| N0 -> p1 cI -| Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 - -(** val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> - 'a1 pol **) - -let rec norm_aux cO cI cadd cmul csub copp ceqb = function -| PEc c -> Pc c -| PEX j -> mk_X cO cI j -| PEadd (pe1, pe2) -> - (match pe1 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe2) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - (match pe2 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - padd cO cadd ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2))) -| PEsub (pe1, pe2) -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) -| PEmul (pe1, pe2) -> - pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) -| PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) -| PEpow (pe1, n0) -> - ppow_N cO cI cadd cmul ceqb (fun p -> p) - (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 - -type 'a bFormula = -| TT -| FF -| X -| A of 'a -| Cj of 'a bFormula * 'a bFormula -| D of 'a bFormula * 'a bFormula -| N of 'a bFormula -| I of 'a bFormula * 'a bFormula - -(** val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula **) - -let rec map_bformula fct = function -| TT -> TT -| FF -> FF -| X -> X -| A a -> A (fct a) -| Cj (f1, f2) -> Cj ((map_bformula fct f1), (map_bformula fct f2)) -| D (f1, f2) -> D ((map_bformula fct f1), (map_bformula fct f2)) -| N f0 -> N (map_bformula fct f0) -| I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2)) - -type 'x clause = 'x list - -type 'x cnf = 'x clause list - -(** val tt : 'a1 cnf **) - -let tt = - [] - -(** val ff : 'a1 cnf **) - -let ff = - []::[] - -(** val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> - 'a1 clause option **) - -let rec add_term unsat deduce t0 = function -| [] -> - (match deduce t0 t0 with - | Some u -> if unsat u then None else Some (t0::[]) - | None -> Some (t0::[])) -| t'::cl0 -> - (match deduce t0 t' with - | Some u -> - if unsat u - then None - else (match add_term unsat deduce t0 cl0 with - | Some cl' -> Some (t'::cl') - | None -> None) - | None -> - (match add_term unsat deduce t0 cl0 with - | Some cl' -> Some (t'::cl') - | None -> None)) - -(** val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 - clause -> 'a1 clause option **) - -let rec or_clause unsat deduce cl1 cl2 = - match cl1 with - | [] -> Some cl2 - | t0::cl -> - (match add_term unsat deduce t0 cl2 with - | Some cl' -> or_clause unsat deduce cl cl' - | None -> None) - -(** val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf - -> 'a1 cnf **) - -let or_clause_cnf unsat deduce t0 f = - fold_right (fun e acc -> - match or_clause unsat deduce t0 e with - | Some cl -> cl::acc - | None -> acc) [] f - -(** val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> - 'a1 cnf **) - -let rec or_cnf unsat deduce f f' = - match f with - | [] -> tt - | e::rst -> - app (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') - -(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) - -let and_cnf f1 f2 = - app f1 f2 - -(** val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> - ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) - -let rec xcnf unsat deduce normalise0 negate0 pol0 = function -| TT -> if pol0 then tt else ff -| FF -> if pol0 then ff else tt -| X -> ff -| A x -> if pol0 then normalise0 x else negate0 x -| Cj (e1, e2) -> - if pol0 - then and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) - else or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) -| D (e1, e2) -> - if pol0 - then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) - else and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) -| N e -> xcnf unsat deduce normalise0 negate0 (negb pol0) e -| I (e1, e2) -> - if pol0 - then or_cnf unsat deduce - (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) - else and_cnf (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) - -(** val cnf_checker : - ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **) - -let rec cnf_checker checker f l = - match f with - | [] -> true - | e::f0 -> - (match l with - | [] -> false - | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false) - -(** val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> - ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 - list -> bool **) - -let tauto_checker unsat deduce normalise0 negate0 checker f w = - cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w - -(** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) - -let cneqb ceqb x y = - negb (ceqb x y) - -(** val cltb : - ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) - -let cltb ceqb cleb x y = - (&&) (cleb x y) (cneqb ceqb x y) - -type 'c polC = 'c pol - -type op1 = -| Equal -| NonEqual -| Strict -| NonStrict - -type 'c nFormula = 'c polC * op1 - -(** val opMult : op1 -> op1 -> op1 option **) - -let opMult o o' = - match o with - | Equal -> Some Equal - | NonEqual -> - (match o' with - | Equal -> Some Equal - | NonEqual -> Some NonEqual - | _ -> None) - | Strict -> - (match o' with - | NonEqual -> None - | _ -> Some o') - | NonStrict -> - (match o' with - | Equal -> Some Equal - | NonEqual -> None - | _ -> Some NonStrict) - -(** val opAdd : op1 -> op1 -> op1 option **) - -let opAdd o o' = - match o with - | Equal -> Some o' - | NonEqual -> - (match o' with - | Equal -> Some NonEqual - | _ -> None) - | Strict -> - (match o' with - | NonEqual -> None - | _ -> Some Strict) - | NonStrict -> - (match o' with - | Equal -> Some NonStrict - | NonEqual -> None - | x -> Some x) - -type 'c psatz = -| PsatzIn of nat -| PsatzSquare of 'c polC -| PsatzMulC of 'c polC * 'c psatz -| PsatzMulE of 'c psatz * 'c psatz -| PsatzAdd of 'c psatz * 'c psatz -| PsatzC of 'c -| PsatzZ - -(** val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **) - -let map_option f = function -| Some x -> f x -| None -> None - -(** val map_option2 : - ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **) - -let map_option2 f o o' = - match o with - | Some x -> - (match o' with - | Some x' -> f x x' - | None -> None) - | None -> None - -(** val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **) - -let pexpr_times_nformula cO cI cplus ctimes ceqb e = function -| ef,o -> - (match o with - | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef),Equal) - | _ -> None) - -(** val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) - -let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = - let e1,o1 = f1 in - let e2,o2 = f2 in - map_option (fun x -> Some ((pmul cO cI cplus ctimes ceqb e1 e2),x)) - (opMult o1 o2) - -(** val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> - 'a1 nFormula -> 'a1 nFormula option **) - -let nformula_plus_nformula cO cplus ceqb f1 f2 = - let e1,o1 = f1 in - let e2,o2 = f2 in - map_option (fun x -> Some ((padd cO cplus ceqb e1 e2),x)) (opAdd o1 o2) - -(** val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz - -> 'a1 nFormula option **) - -let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function -| PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal)) -| PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0),NonStrict) -| PsatzMulC (re, e0) -> - map_option (pexpr_times_nformula cO cI cplus ctimes ceqb re) - (eval_Psatz cO cI cplus ctimes ceqb cleb l e0) -| PsatzMulE (f1, f2) -> - map_option2 (nformula_times_nformula cO cI cplus ctimes ceqb) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) -| PsatzAdd (f1, f2) -> - map_option2 (nformula_plus_nformula cO cplus ceqb) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) -| PsatzC c -> if cltb ceqb cleb cO c then Some ((Pc c),Strict) else None -| PsatzZ -> Some ((Pc cO),Equal) - -(** val check_inconsistent : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> - bool **) - -let check_inconsistent cO ceqb cleb = function -| e,op -> - (match e with - | Pc c -> - (match op with - | Equal -> cneqb ceqb c cO - | NonEqual -> ceqb c cO - | Strict -> cleb c cO - | NonStrict -> cltb ceqb cleb c cO) - | _ -> false) - -(** val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz - -> bool **) - -let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm = - match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with - | Some f -> check_inconsistent cO ceqb cleb f - | None -> false - -type op2 = -| OpEq -| OpNEq -| OpLe -| OpGe -| OpLt -| OpGt - -type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } - -(** val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> - 'a1 pol **) - -let norm cO cI cplus ctimes cminus copp ceqb = - norm_aux cO cI cplus ctimes cminus copp ceqb - -(** val psub0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> - ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) - -let psub0 cO cplus cminus copp ceqb = - psub cO cplus cminus copp ceqb - -(** val padd0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 - pol -> 'a1 pol **) - -let padd0 cO cplus ceqb = - padd cO cplus ceqb - -(** val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> - 'a1 nFormula list **) - -let xnormalise cO cI cplus ctimes cminus copp ceqb t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in - let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in - (match o with - | OpEq -> - ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO - cplus - cminus copp - ceqb rhs0 - lhs0),Strict)::[]) - | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] - | OpLe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[] - | OpGe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] - | OpLt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] - | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[]) - -(** val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> - 'a1 nFormula cnf **) - -let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 = - map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t0) - -(** val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> - 'a1 nFormula list **) - -let xnegate cO cI cplus ctimes cminus copp ceqb t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in - let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in - (match o with - | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] - | OpNEq -> - ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO - cplus - cminus copp - ceqb rhs0 - lhs0),Strict)::[]) - | OpLe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[] - | OpGe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] - | OpLt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] - | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[]) - -(** val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> - 'a1 nFormula cnf **) - -let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 = - map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) - -(** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) - -let rec xdenorm jmp = function -| Pc c -> PEc c -| Pinj (j, p2) -> xdenorm (Coq_Pos.add j jmp) p2 -| PX (p2, j, q0) -> - PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp), (Npos j))))), - (xdenorm (Coq_Pos.succ jmp) q0)) - -(** val denorm : 'a1 pol -> 'a1 pExpr **) - -let denorm p = - xdenorm XH p - -(** val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr **) - -let rec map_PExpr c_of_S = function -| PEc c -> PEc (c_of_S c) -| PEX p -> PEX p -| PEadd (e1, e2) -> PEadd ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) -| PEsub (e1, e2) -> PEsub ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) -| PEmul (e1, e2) -> PEmul ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) -| PEopp e0 -> PEopp (map_PExpr c_of_S e0) -| PEpow (e0, n0) -> PEpow ((map_PExpr c_of_S e0), n0) - -(** val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula **) - -let map_Formula c_of_S f = - let { flhs = l; fop = o; frhs = r } = f in - { flhs = (map_PExpr c_of_S l); fop = o; frhs = (map_PExpr c_of_S r) } - -(** val simpl_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz - -> 'a1 psatz **) - -let simpl_cone cO cI ctimes ceqb e = match e with -| PsatzSquare t0 -> - (match t0 with - | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c) - | _ -> PsatzSquare t0) -| PsatzMulE (t1, t2) -> - (match t1 with - | PsatzMulE (x, x0) -> - (match x with - | PsatzC p2 -> - (match t2 with - | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0) - | PsatzZ -> PsatzZ - | _ -> e) - | _ -> - (match x0 with - | PsatzC p2 -> - (match t2 with - | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x) - | PsatzZ -> PsatzZ - | _ -> e) - | _ -> - (match t2 with - | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) - | PsatzZ -> PsatzZ - | _ -> e))) - | PsatzC c -> - (match t2 with - | PsatzMulE (x, x0) -> - (match x with - | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0) - | _ -> - (match x0 with - | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x) - | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))) - | PsatzAdd (y, z0) -> - PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), - z0))) - | PsatzC c0 -> PsatzC (ctimes c c0) - | PsatzZ -> PsatzZ - | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)) - | PsatzZ -> PsatzZ - | _ -> - (match t2 with - | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) - | PsatzZ -> PsatzZ - | _ -> e)) -| PsatzAdd (t1, t2) -> - (match t1 with - | PsatzZ -> t2 - | _ -> - (match t2 with - | PsatzZ -> t1 - | _ -> PsatzAdd (t1, t2))) -| _ -> e - -type q = { qnum : z; qden : positive } - -(** val qnum : q -> z **) - -let qnum x = x.qnum - -(** val qden : q -> positive **) - -let qden x = x.qden - -(** val qeq_bool : q -> q -> bool **) - -let qeq_bool x y = - zeq_bool (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) - -(** val qle_bool : q -> q -> bool **) - -let qle_bool x y = - Z.leb (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) - -(** val qplus : q -> q -> q **) - -let qplus x y = - { qnum = - (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))); - qden = (Coq_Pos.mul x.qden y.qden) } - -(** val qmult : q -> q -> q **) - -let qmult x y = - { qnum = (Z.mul x.qnum y.qnum); qden = (Coq_Pos.mul x.qden y.qden) } - -(** val qopp : q -> q **) - -let qopp x = - { qnum = (Z.opp x.qnum); qden = x.qden } - -(** val qminus : q -> q -> q **) - -let qminus x y = - qplus x (qopp y) - -(** val qinv : q -> q **) - -let qinv x = - match x.qnum with - | Z0 -> { qnum = Z0; qden = XH } - | Zpos p -> { qnum = (Zpos x.qden); qden = p } - | Zneg p -> { qnum = (Zneg x.qden); qden = p } - -(** val qpower_positive : q -> positive -> q **) - -let qpower_positive = - pow_pos qmult - -(** val qpower : q -> z -> q **) - -let qpower q0 = function -| Z0 -> { qnum = (Zpos XH); qden = XH } -| Zpos p -> qpower_positive q0 p -| Zneg p -> qinv (qpower_positive q0 p) - -type 'a t = -| Empty -| Leaf of 'a -| Node of 'a t * 'a * 'a t - -(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) - -let rec find default vm p = - match vm with - | Empty -> default - | Leaf i -> i - | Node (l, e, r) -> - (match p with - | XI p2 -> find default r p2 - | XO p2 -> find default l p2 - | XH -> e) - -(** val singleton : 'a1 -> positive -> 'a1 -> 'a1 t **) - -let rec singleton default x v = - match x with - | XI p -> Node (Empty, default, (singleton default p v)) - | XO p -> Node ((singleton default p v), default, Empty) - | XH -> Leaf v - -(** val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t **) - -let rec vm_add default x v = function -| Empty -> singleton default x v -| Leaf vl -> - (match x with - | XI p -> Node (Empty, vl, (singleton default p v)) - | XO p -> Node ((singleton default p v), vl, Empty) - | XH -> Leaf v) -| Node (l, o, r) -> - (match x with - | XI p -> Node (l, o, (vm_add default p v r)) - | XO p -> Node ((vm_add default p v l), o, r) - | XH -> Node (l, v, r)) - -type zWitness = z psatz - -(** val zWeakChecker : z nFormula list -> z psatz -> bool **) - -let zWeakChecker = - check_normalised_formulas Z0 (Zpos XH) Z.add Z.mul zeq_bool Z.leb - -(** val psub1 : z pol -> z pol -> z pol **) - -let psub1 = - psub0 Z0 Z.add Z.sub Z.opp zeq_bool - -(** val padd1 : z pol -> z pol -> z pol **) - -let padd1 = - padd0 Z0 Z.add zeq_bool - -(** val norm0 : z pExpr -> z pol **) - -let norm0 = - norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp zeq_bool - -(** val xnormalise0 : z formula -> z nFormula list **) - -let xnormalise0 t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm0 lhs in - let rhs0 = norm0 rhs in - (match o with - | OpEq -> - ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 - (padd1 lhs0 - (Pc (Zpos - XH)))),NonStrict)::[]) - | OpNEq -> ((psub1 lhs0 rhs0),Equal)::[] - | OpLe -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[] - | OpGe -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] - | OpLt -> ((psub1 lhs0 rhs0),NonStrict)::[] - | OpGt -> ((psub1 rhs0 lhs0),NonStrict)::[]) - -(** val normalise : z formula -> z nFormula cnf **) - -let normalise t0 = - map (fun x -> x::[]) (xnormalise0 t0) - -(** val xnegate0 : z formula -> z nFormula list **) - -let xnegate0 t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm0 lhs in - let rhs0 = norm0 rhs in - (match o with - | OpEq -> ((psub1 lhs0 rhs0),Equal)::[] - | OpNEq -> - ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 - (padd1 lhs0 - (Pc (Zpos - XH)))),NonStrict)::[]) - | OpLe -> ((psub1 rhs0 lhs0),NonStrict)::[] - | OpGe -> ((psub1 lhs0 rhs0),NonStrict)::[] - | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] - | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[]) - -(** val negate : z formula -> z nFormula cnf **) - -let negate t0 = - map (fun x -> x::[]) (xnegate0 t0) - -(** val zunsat : z nFormula -> bool **) - -let zunsat = - check_inconsistent Z0 zeq_bool Z.leb - -(** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) - -let zdeduce = - nformula_plus_nformula Z0 Z.add zeq_bool - -(** val ceiling : z -> z -> z **) - -let ceiling a b = - let q0,r = Z.div_eucl a b in - (match r with - | Z0 -> q0 - | _ -> Z.add q0 (Zpos XH)) - -type zArithProof = -| DoneProof -| RatProof of zWitness * zArithProof -| CutProof of zWitness * zArithProof -| EnumProof of zWitness * zWitness * zArithProof list - -(** val zgcdM : z -> z -> z **) - -let zgcdM x y = - Z.max (Z.gcd x y) (Zpos XH) - -(** val zgcd_pol : z polC -> z * z **) - -let rec zgcd_pol = function -| Pc c -> Z0,c -| Pinj (_, p2) -> zgcd_pol p2 -| PX (p2, _, q0) -> - let g1,c1 = zgcd_pol p2 in - let g2,c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2),c2 - -(** val zdiv_pol : z polC -> z -> z polC **) - -let rec zdiv_pol p x = - match p with - | Pc c -> Pc (Z.div c x) - | Pinj (j, p2) -> Pinj (j, (zdiv_pol p2 x)) - | PX (p2, j, q0) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q0 x)) - -(** val makeCuttingPlane : z polC -> z polC * z **) - -let makeCuttingPlane p = - let g,c = zgcd_pol p in - if Z.gtb g Z0 - then (zdiv_pol (psubC Z.sub p c) g),(Z.opp (ceiling (Z.opp c) g)) - else p,Z0 - -(** val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option **) - -let genCuttingPlane = function -| e,op -> - (match op with - | Equal -> - let g,c = zgcd_pol e in - if (&&) (Z.gtb g Z0) - ((&&) (negb (zeq_bool c Z0)) (negb (zeq_bool (Z.gcd g c) g))) - then None - else Some ((makeCuttingPlane e),Equal) - | NonEqual -> Some ((e,Z0),op) - | Strict -> - Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict) - | NonStrict -> Some ((makeCuttingPlane e),NonStrict)) - -(** val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula **) - -let nformula_of_cutting_plane = function -| e_z,o -> let e,z0 = e_z in (padd1 e (Pc z0)),o - -(** val is_pol_Z0 : z polC -> bool **) - -let is_pol_Z0 = function -| Pc z0 -> - (match z0 with - | Z0 -> true - | _ -> false) -| _ -> false - -(** val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option **) - -let eval_Psatz0 = - eval_Psatz Z0 (Zpos XH) Z.add Z.mul zeq_bool Z.leb - -(** val valid_cut_sign : op1 -> bool **) - -let valid_cut_sign = function -| Equal -> true -| NonStrict -> true -| _ -> false - -(** val zChecker : z nFormula list -> zArithProof -> bool **) - -let rec zChecker l = function -| DoneProof -> false -| RatProof (w, pf0) -> - (match eval_Psatz0 l w with - | Some f -> if zunsat f then true else zChecker (f::l) pf0 - | None -> false) -| CutProof (w, pf0) -> - (match eval_Psatz0 l w with - | Some f -> - (match genCuttingPlane f with - | Some cp -> zChecker ((nformula_of_cutting_plane cp)::l) pf0 - | None -> true) - | None -> false) -| EnumProof (w1, w2, pf0) -> - (match eval_Psatz0 l w1 with - | Some f1 -> - (match eval_Psatz0 l w2 with - | Some f2 -> - (match genCuttingPlane f1 with - | Some p -> - let p2,op3 = p in - let e1,z1 = p2 in - (match genCuttingPlane f2 with - | Some p3 -> - let p4,op4 = p3 in - let e2,z2 = p4 in - if (&&) ((&&) (valid_cut_sign op3) (valid_cut_sign op4)) - (is_pol_Z0 (padd1 e1 e2)) - then let rec label pfs lb ub = - match pfs with - | [] -> Z.gtb lb ub - | pf1::rsr -> - (&&) (zChecker (((psub1 e1 (Pc lb)),Equal)::l) pf1) - (label rsr (Z.add lb (Zpos XH)) ub) - in label pf0 (Z.opp z1) z2 - else false - | None -> true) - | None -> true) - | None -> false) - | None -> false) - -(** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) - -let zTautoChecker f w = - tauto_checker zunsat zdeduce normalise negate zChecker f w - -type qWitness = q psatz - -(** val qWeakChecker : q nFormula list -> q psatz -> bool **) - -let qWeakChecker = - check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); - qden = XH } qplus qmult qeq_bool qle_bool - -(** val qnormalise : q formula -> q nFormula cnf **) - -let qnormalise = - cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool - -(** val qnegate : q formula -> q nFormula cnf **) - -let qnegate = - cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool - -(** val qunsat : q nFormula -> bool **) - -let qunsat = - check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool - -(** val qdeduce : q nFormula -> q nFormula -> q nFormula option **) - -let qdeduce = - nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool - -(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) - -let qTautoChecker f w = - tauto_checker qunsat qdeduce qnormalise qnegate qWeakChecker f w - -type rcst = -| C0 -| C1 -| CQ of q -| CZ of z -| CPlus of rcst * rcst -| CMinus of rcst * rcst -| CMult of rcst * rcst -| CInv of rcst -| COpp of rcst - -(** val q_of_Rcst : rcst -> q **) - -let rec q_of_Rcst = function -| C0 -> { qnum = Z0; qden = XH } -| C1 -> { qnum = (Zpos XH); qden = XH } -| CQ q0 -> q0 -| CZ z0 -> { qnum = z0; qden = XH } -| CPlus (r1, r2) -> qplus (q_of_Rcst r1) (q_of_Rcst r2) -| CMinus (r1, r2) -> qminus (q_of_Rcst r1) (q_of_Rcst r2) -| CMult (r1, r2) -> qmult (q_of_Rcst r1) (q_of_Rcst r2) -| CInv r0 -> qinv (q_of_Rcst r0) -| COpp r0 -> qopp (q_of_Rcst r0) - -type rWitness = q psatz - -(** val rWeakChecker : q nFormula list -> q psatz -> bool **) - -let rWeakChecker = - check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); - qden = XH } qplus qmult qeq_bool qle_bool - -(** val rnormalise : q formula -> q nFormula cnf **) - -let rnormalise = - cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool - -(** val rnegate : q formula -> q nFormula cnf **) - -let rnegate = - cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool - -(** val runsat : q nFormula -> bool **) - -let runsat = - check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool - -(** val rdeduce : q nFormula -> q nFormula -> q nFormula option **) - -let rdeduce = - nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool - -(** val rTautoChecker : rcst formula bFormula -> rWitness list -> bool **) - -let rTautoChecker f w = - tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker - (map_bformula (map_Formula q_of_Rcst) f) w diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli deleted file mode 100644 index beb042f49..000000000 --- a/plugins/micromega/micromega.mli +++ /dev/null @@ -1,522 +0,0 @@ -val negb : bool -> bool - -type nat = -| O -| S of nat - -val app : 'a1 list -> 'a1 list -> 'a1 list - -type comparison = -| Eq -| Lt -| Gt - -val compOpp : comparison -> comparison - -val add : nat -> nat -> nat - -type positive = -| XI of positive -| XO of positive -| XH - -type n = -| N0 -| Npos of positive - -type z = -| Z0 -| Zpos of positive -| Zneg of positive - -module Pos : - sig - type mask = - | IsNul - | IsPos of positive - | IsNeg - end - -module Coq_Pos : - sig - val succ : positive -> positive - - val add : positive -> positive -> positive - - val add_carry : positive -> positive -> positive - - val pred_double : positive -> positive - - type mask = Pos.mask = - | IsNul - | IsPos of positive - | IsNeg - - val succ_double_mask : mask -> mask - - val double_mask : mask -> mask - - val double_pred_mask : positive -> mask - - val sub_mask : positive -> positive -> mask - - val sub_mask_carry : positive -> positive -> mask - - val sub : positive -> positive -> positive - - val mul : positive -> positive -> positive - - val size_nat : positive -> nat - - val compare_cont : comparison -> positive -> positive -> comparison - - val compare : positive -> positive -> comparison - - val gcdn : nat -> positive -> positive -> positive - - val gcd : positive -> positive -> positive - - val of_succ_nat : nat -> positive - end - -module N : - sig - val of_nat : nat -> n - end - -val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 - -val nth : nat -> 'a1 list -> 'a1 -> 'a1 - -val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list - -val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 - -module Z : - sig - val double : z -> z - - val succ_double : z -> z - - val pred_double : z -> z - - val pos_sub : positive -> positive -> z - - val add : z -> z -> z - - val opp : z -> z - - val sub : z -> z -> z - - val mul : z -> z -> z - - val compare : z -> z -> comparison - - val leb : z -> z -> bool - - val ltb : z -> z -> bool - - val gtb : z -> z -> bool - - val max : z -> z -> z - - val abs : z -> z - - val to_N : z -> n - - val pos_div_eucl : positive -> z -> z * z - - val div_eucl : z -> z -> z * z - - val div : z -> z -> z - - val gcd : z -> z -> z - end - -val zeq_bool : z -> z -> bool - -type 'c pol = -| Pc of 'c -| Pinj of positive * 'c pol -| PX of 'c pol * positive * 'c pol - -val p0 : 'a1 -> 'a1 pol - -val p1 : 'a1 -> 'a1 pol - -val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool - -val mkPinj : positive -> 'a1 pol -> 'a1 pol - -val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol - -val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol - -val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol - -val mkX : 'a1 -> 'a1 -> 'a1 pol - -val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol - -val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol - -val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol - -val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol - -val psubI : - ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol - -val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 - pol -> positive -> 'a1 pol -> 'a1 pol - -val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> - 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol - -val padd : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol - -> 'a1 pol - -val psub : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> - ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol - -val pmulC_aux : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> - 'a1 pol - -val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> - 'a1 -> 'a1 pol - -val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> - 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol - -val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol - -val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 pol -> 'a1 pol - -type 'c pExpr = -| PEc of 'c -| PEX of positive -| PEadd of 'c pExpr * 'c pExpr -| PEsub of 'c pExpr * 'c pExpr -| PEmul of 'c pExpr * 'c pExpr -| PEopp of 'c pExpr -| PEpow of 'c pExpr * n - -val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol - -val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> - 'a1 pol - -val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol - -val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol - -type 'a bFormula = -| TT -| FF -| X -| A of 'a -| Cj of 'a bFormula * 'a bFormula -| D of 'a bFormula * 'a bFormula -| N of 'a bFormula -| I of 'a bFormula * 'a bFormula - -val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula - -type 'x clause = 'x list - -type 'x cnf = 'x clause list - -val tt : 'a1 cnf - -val ff : 'a1 cnf - -val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 - clause option - -val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause - -> 'a1 clause option - -val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> - 'a1 cnf - -val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 - cnf - -val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf - -val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf - -val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool - -val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> - bool - -val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool - -val cltb : - ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool - -type 'c polC = 'c pol - -type op1 = -| Equal -| NonEqual -| Strict -| NonStrict - -type 'c nFormula = 'c polC * op1 - -val opMult : op1 -> op1 -> op1 option - -val opAdd : op1 -> op1 -> op1 option - -type 'c psatz = -| PsatzIn of nat -| PsatzSquare of 'c polC -| PsatzMulC of 'c polC * 'c psatz -| PsatzMulE of 'c psatz * 'c psatz -| PsatzAdd of 'c psatz * 'c psatz -| PsatzC of 'c -| PsatzZ - -val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option - -val map_option2 : - ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option - -val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option - -val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option - -val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> - 'a1 nFormula -> 'a1 nFormula option - -val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> - 'a1 nFormula option - -val check_inconsistent : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> - bool - -val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> - bool - -type op2 = -| OpEq -| OpNEq -| OpLe -| OpGe -| OpLt -| OpGt - -type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } - -val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol - -val psub0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> - ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol - -val padd0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol - -> 'a1 pol - -val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list - -val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf - -val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list - -val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf - -val xdenorm : positive -> 'a1 pol -> 'a1 pExpr - -val denorm : 'a1 pol -> 'a1 pExpr - -val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr - -val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula - -val simpl_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz - -> 'a1 psatz - -type q = { qnum : z; qden : positive } - -val qnum : q -> z - -val qden : q -> positive - -val qeq_bool : q -> q -> bool - -val qle_bool : q -> q -> bool - -val qplus : q -> q -> q - -val qmult : q -> q -> q - -val qopp : q -> q - -val qminus : q -> q -> q - -val qinv : q -> q - -val qpower_positive : q -> positive -> q - -val qpower : q -> z -> q - -type 'a t = -| Empty -| Leaf of 'a -| Node of 'a t * 'a * 'a t - -val find : 'a1 -> 'a1 t -> positive -> 'a1 - -val singleton : 'a1 -> positive -> 'a1 -> 'a1 t - -val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t - -type zWitness = z psatz - -val zWeakChecker : z nFormula list -> z psatz -> bool - -val psub1 : z pol -> z pol -> z pol - -val padd1 : z pol -> z pol -> z pol - -val norm0 : z pExpr -> z pol - -val xnormalise0 : z formula -> z nFormula list - -val normalise : z formula -> z nFormula cnf - -val xnegate0 : z formula -> z nFormula list - -val negate : z formula -> z nFormula cnf - -val zunsat : z nFormula -> bool - -val zdeduce : z nFormula -> z nFormula -> z nFormula option - -val ceiling : z -> z -> z - -type zArithProof = -| DoneProof -| RatProof of zWitness * zArithProof -| CutProof of zWitness * zArithProof -| EnumProof of zWitness * zWitness * zArithProof list - -val zgcdM : z -> z -> z - -val zgcd_pol : z polC -> z * z - -val zdiv_pol : z polC -> z -> z polC - -val makeCuttingPlane : z polC -> z polC * z - -val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option - -val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula - -val is_pol_Z0 : z polC -> bool - -val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option - -val valid_cut_sign : op1 -> bool - -val zChecker : z nFormula list -> zArithProof -> bool - -val zTautoChecker : z formula bFormula -> zArithProof list -> bool - -type qWitness = q psatz - -val qWeakChecker : q nFormula list -> q psatz -> bool - -val qnormalise : q formula -> q nFormula cnf - -val qnegate : q formula -> q nFormula cnf - -val qunsat : q nFormula -> bool - -val qdeduce : q nFormula -> q nFormula -> q nFormula option - -val qTautoChecker : q formula bFormula -> qWitness list -> bool - -type rcst = -| C0 -| C1 -| CQ of q -| CZ of z -| CPlus of rcst * rcst -| CMinus of rcst * rcst -| CMult of rcst * rcst -| CInv of rcst -| COpp of rcst - -val q_of_Rcst : rcst -> q - -type rWitness = q psatz - -val rWeakChecker : q nFormula list -> q psatz -> bool - -val rnormalise : q formula -> q nFormula cnf - -val rnegate : q formula -> q nFormula cnf - -val runsat : q nFormula -> bool - -val rdeduce : q nFormula -> q nFormula -> q nFormula option - -val rTautoChecker : rcst formula bFormula -> rWitness list -> bool diff --git a/plugins/micromega/vo.itarget b/plugins/micromega/vo.itarget index c9009ea4d..a555d5ba1 100644 --- a/plugins/micromega/vo.itarget +++ b/plugins/micromega/vo.itarget @@ -1,3 +1,4 @@ +MExtraction.vo EnvRing.vo Env.vo OrderedRing.vo diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index ee748567b..465e77019 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -28,7 +28,6 @@ open Globnames open Nametab open Contradiction open Misctypes -open Proofview.Notations open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -38,12 +37,12 @@ open OmegaSolver (* Added by JCF, 09/03/98 *) let elim_id id = - Proofview.Goal.enter { enter = begin fun gl -> - simplest_elim (Tacmach.New.pf_global id gl) - end } -let resolve_id id = Proofview.Goal.enter { enter = begin fun gl -> - apply (Tacmach.New.pf_global id gl) -end } + Proofview.Goal.enter begin fun gl -> + simplest_elim (mkVar id) + end +let resolve_id id = Proofview.Goal.enter begin fun gl -> + apply (mkVar id) +end let timing timer_name f arg = f arg @@ -362,7 +361,7 @@ let coq_True = lazy (init_constant "True") let evaluable_ref_of_constr s c = match EConstr.kind Evd.empty (Lazy.force c) with | Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> EvalConstRef kn - | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant")) + | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant.")) let sp_Zsucc = lazy (evaluable_ref_of_constr "Z.succ" coq_Zsucc) let sp_Zpred = lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred) @@ -580,10 +579,10 @@ let abstract_path sigma typ path t = let focused_simpl path = let open Tacmach.New in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in convert_concl_no_check newc DEFAULTcast - end } + end let focused_simpl path = focused_simpl path @@ -630,7 +629,7 @@ let compile name kind = let id = new_id () in tag_hypothesis name id; {kind = kind; body = List.rev accu; constant = n; id = id} - | _ -> anomaly (Pp.str "compile_equation") + | _ -> anomaly (Pp.str "compile_equation.") in loop [] @@ -643,17 +642,16 @@ let decompile af = (** Backward compat to emulate the old Refine: normalize the goal conclusion *) let new_hole env sigma c = - let c = Reductionops.nf_betaiota (Sigma.to_evar_map sigma) c in + let c = Reductionops.nf_betaiota sigma c in Evarutil.new_evar env sigma c let clever_rewrite_base_poly typ p result theorem = let open Tacmach.New in - let open Sigma in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let full = pf_concl gl in let env = pf_env gl in let (abstracted,occ) = abstract_path (project gl) typ (List.rev p) full in - Refine.refine { run = begin fun sigma -> + Refine.refine begin fun sigma -> let t = applist (mkLambda @@ -667,10 +665,10 @@ let clever_rewrite_base_poly typ p result theorem = [abstracted]) in let argt = mkApp (abstracted, [|result|]) in - let Sigma (hole, sigma, p) = new_hole env sigma argt in - Sigma (applist (t, [hole]), sigma, p) - end } - end } + let (sigma, hole) = new_hole env sigma argt in + (sigma, applist (t, [hole])) + end + end let clever_rewrite_base p result theorem = clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem @@ -689,26 +687,25 @@ let clever_rewrite_gen_nat p result (t,args) = (** Solve using the term the term [t _] *) let refine_app gl t = let open Tacmach.New in - let open Sigma in - Refine.refine { run = begin fun sigma -> + Refine.refine begin fun sigma -> let env = pf_env gl in - let ht = match EConstr.kind (Sigma.to_evar_map sigma) (pf_get_type_of gl t) with + let ht = match EConstr.kind sigma (pf_get_type_of gl t) with | Prod (_, t, _) -> t | _ -> assert false in - let Sigma (hole, sigma, p) = new_hole env sigma ht in - Sigma (applist (t, [hole]), sigma, p) - end } + let (sigma, hole) = new_hole env sigma ht in + (sigma, applist (t, [hole])) + end let clever_rewrite p vpath t = let open Tacmach.New in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let full = pf_concl gl in let (abstracted,occ) = abstract_path (project gl) (Lazy.force coq_Z) (List.rev p) full in let vargs = List.map (fun p -> occurrence (project gl) p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in refine_app gl t' - end } + end let rec shuffle p (t1,t2) = match t1,t2 with @@ -1466,7 +1463,7 @@ let reintroduce id = open Proofview.Notations let coq_omega = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> clear_constr_tables (); let hyps_types = Tacmach.New.pf_hyps_types gl in let destructure_omega = destructure_omega gl in @@ -1514,12 +1511,12 @@ let coq_omega = tclTHEN prelude (replay_history tactic_normalisation path) with NO_CONTRADICTION -> tclZEROMSG (Pp.str"Omega can't solve this system") end - end } + end let coq_omega = coq_omega let nat_inject = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in let rec explore p t : unit Proofview.tactic = Proofview.tclEVARMAP >>= fun sigma -> @@ -1655,7 +1652,7 @@ let nat_inject = in let hyps_types = Tacmach.New.pf_hyps_types gl in loop (List.rev hyps_types) - end } + end let dec_binop = function | Zne -> coq_dec_Zne @@ -1729,19 +1726,19 @@ let onClearedName id tac = (* so renaming may be necessary *) tclTHEN (tclTRY (clear [id])) - (Proofview.Goal.nf_enter { enter = begin fun gl -> + (Proofview.Goal.nf_enter begin fun gl -> let id = fresh_id [] id gl in tclTHEN (introduction id) (tac id) - end }) + end) let onClearedName2 id tac = tclTHEN (tclTRY (clear [id])) - (Proofview.Goal.nf_enter { enter = begin fun gl -> + (Proofview.Goal.nf_enter begin fun gl -> let id1 = fresh_id [] (add_suffix id "_left") gl in let id2 = fresh_id [] (add_suffix id "_right") gl in tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] - end }) + end) let rec is_Prop sigma c = match EConstr.kind sigma c with | Sort s -> Sorts.is_prop (ESorts.kind sigma s) @@ -1749,7 +1746,7 @@ let rec is_Prop sigma c = match EConstr.kind sigma c with | _ -> false let destructure_hyps = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in let decidability = decidability gl in let pf_nf = pf_nf gl in @@ -1888,10 +1885,10 @@ let destructure_hyps = in let hyps = Proofview.Goal.hyps gl in loop hyps - end } + end let destructure_goal = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let decidability = decidability gl in let rec loop t = @@ -1910,9 +1907,9 @@ let destructure_goal = try let dec = decidability t in tclTHEN - (Proofview.Goal.nf_enter { enter = begin fun gl -> + (Proofview.Goal.nf_enter begin fun gl -> refine_app gl (mkApp (Lazy.force coq_dec_not_not, [| t; dec |])) - end }) + end) intro with Undecidable -> Tactics.elim_type (Lazy.force coq_False) | e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e @@ -1920,7 +1917,7 @@ let destructure_goal = tclTHEN goal_tac destructure_hyps in (loop concl) - end } + end let destructure_goal = destructure_goal diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 7412de1e8..ffacd8b36 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -423,7 +423,7 @@ let quote_terms env sigma ivs lc = | None -> begin match ivs.constant_lhs with | Some c_lhs -> subst_meta [1, c] c_lhs - | None -> anomaly (Pp.str "invalid inversion scheme for quote") + | None -> anomaly (Pp.str "invalid inversion scheme for quote.") end | Some var_lhs -> begin match ivs.constant_lhs with @@ -456,40 +456,57 @@ let quote_terms env sigma ivs lc = term. Ring for example needs that, but Ring doesn't use Quote yet. *) +let pf_constrs_of_globals l = + let rec aux l acc = + match l with + [] -> Proofview.tclUNIT (List.rev acc) + | hd :: tl -> + Tacticals.New.pf_constr_of_global hd >>= fun g -> aux tl (g :: acc) + in aux l [] + let quote f lid = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let f = Tacmach.New.pf_global f gl in - let cl = List.map (fun id -> EConstr.to_constr sigma (Tacmach.New.pf_global id gl)) lid in - let ivs = compute_ivs f cl gl in - let concl = Proofview.Goal.concl gl in - let quoted_terms = quote_terms env sigma ivs [concl] in - let (p, vm) = match quoted_terms with + Proofview.Goal.enter begin fun gl -> + let fg = Tacmach.New.pf_global f gl in + let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + Tacticals.New.pf_constr_of_global fg >>= fun f -> + pf_constrs_of_globals clg >>= fun cl -> + Proofview.Goal.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ivs = compute_ivs f (List.map (EConstr.to_constr sigma) cl) gl in + let concl = Proofview.Goal.concl gl in + let quoted_terms = quote_terms env sigma ivs [concl] in + let (p, vm) = match quoted_terms with | [p], vm -> (p,vm) | _ -> assert false - in - match ivs.variable_lhs with - | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast - | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast - end } + in + match ivs.variable_lhs with + | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast + | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast + end + end let gen_quote cont c f lid = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let f = Tacmach.New.pf_global f gl in - let cl = List.map (fun id -> EConstr.to_constr sigma (Tacmach.New.pf_global id gl)) lid in - let ivs = compute_ivs f cl gl in - let quoted_terms = quote_terms env sigma ivs [c] in - let (p, vm) = match quoted_terms with - | [p], vm -> (p,vm) - | _ -> assert false - in - match ivs.variable_lhs with - | None -> cont (mkApp (f, [| p |])) - | Some _ -> cont (mkApp (f, [| vm; p |])) - end } + Proofview.Goal.enter begin fun gl -> + let fg = Tacmach.New.pf_global f gl in + let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + Tacticals.New.pf_constr_of_global fg >>= fun f -> + pf_constrs_of_globals clg >>= fun cl -> + Proofview.Goal.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let cl = List.map (EConstr.to_constr sigma) cl in + let ivs = compute_ivs f cl gl in + let quoted_terms = quote_terms env sigma ivs [c] in + let (p, vm) = match quoted_terms with + | [p], vm -> (p,vm) + | _ -> assert false + in + match ivs.variable_lhs with + | None -> cont (mkApp (f, [| p |])) + | Some _ -> cont (mkApp (f, [| vm; p |])) + end + end (*i diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index fbed1df17..d97dea039 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -226,7 +226,7 @@ module type Int = sig val mk : Bigint.bigint -> Term.constr val parse_term : Term.constr -> parse_term - val parse_rel : ([ `NF ], 'r) Proofview.Goal.t -> Term.constr -> parse_rel + val parse_rel : [ `NF ] Proofview.Goal.t -> Term.constr -> parse_rel (* check whether t is built only with numbers and + * - *) val get_scalar : Term.constr -> Bigint.bigint option end diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index ca23ed6c4..a452b1a91 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -113,7 +113,7 @@ module type Int = (* parsing a term (one level, except if a number is found) *) val parse_term : Term.constr -> parse_term (* parsing a relation expression, including = < <= >= > *) - val parse_rel : ([ `NF ], 'r) Proofview.Goal.t -> Term.constr -> parse_rel + val parse_rel : [ `NF ] Proofview.Goal.t -> Term.constr -> parse_rel (* Is a particular term only made of numbers and + * - ? *) val get_scalar : Term.constr -> Bigint.bigint option end diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index fdcd62299..575634174 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -8,7 +8,6 @@ open Pp open Util -open Proofview.Notations open Const_omega module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -1029,7 +1028,7 @@ let resolution unsafe env (reified_concl,reified_hyps) systems_list = Tactics.apply (EConstr.of_constr (Lazy.force coq_I)) let total_reflexive_omega_tactic unsafe = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> Coqlib.check_required_library ["Coq";"romega";"ROmega"]; rst_omega_eq (); rst_omega_var (); @@ -1043,4 +1042,5 @@ let total_reflexive_omega_tactic unsafe = if !debug then display_systems systems_list; resolution unsafe env reified_goal systems_list with NO_CONTRADICTION -> CErrors.user_err Pp.(str "ROmega can't solve this system") - end } + end + diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 4eef1b0a7..153a6a49a 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -145,7 +145,7 @@ let add_step s sub = | SI_Or_r,[p] -> I_Or_r p | SE_Or i,[p1;p2] -> E_Or(i,p1,p2) | SD_Or i,[p] -> D_Or(i,p) - | _,_ -> anomaly ~label:"add_step" (Pp.str "wrong arity") + | _,_ -> anomaly ~label:"add_step" (Pp.str "wrong arity.") type 'a with_deps = {dep_it:'a; @@ -167,7 +167,7 @@ type state = let project = function Complete prf -> prf - | Incomplete (_,_) -> anomaly (Pp.str "not a successful state") + | Incomplete (_,_) -> anomaly (Pp.str "not a successful state.") let pop n prf = let nprf= @@ -361,7 +361,7 @@ let search_norev seq= (Arrow(f2,f3))) f1; add_hyp (embed nseq) f3]):: !goals - | _ -> anomaly ~label:"search_no_rev" (Pp.str "can't happen") in + | _ -> anomaly ~label:"search_no_rev" (Pp.str "can't happen.") in Int.Map.iter add_one seq.norev_hyps; List.rev !goals @@ -386,7 +386,7 @@ let search_in_rev_hyps seq= | Arrow (Disjunct (f1,f2),f0) -> [make_step (SD_Or(i)), [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]] - | _ -> anomaly ~label:"search_in_rev_hyps" (Pp.str "can't happen") + | _ -> anomaly ~label:"search_in_rev_hyps" (Pp.str "can't happen.") with Not_found -> search_norev seq @@ -464,7 +464,7 @@ let branching = function | _::next -> s_info.nd_branching<-s_info.nd_branching+List.length next in List.map (append stack) successors - | Complete prf -> anomaly (Pp.str "already succeeded") + | Complete prf -> anomaly (Pp.str "already succeeded.") open Pp diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 38f05978d..85cbdc5a4 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -47,7 +47,7 @@ let tag_arg tag_rec map subs i c = let global_head_of_constr sigma c = let f, args = decompose_app sigma c in try fst (Termops.global_of_constr sigma f) - with Not_found -> CErrors.anomaly (str "global_head_of_constr") + with Not_found -> CErrors.anomaly (str "global_head_of_constr.") let global_of_constr_nofail c = try global_of_constr c @@ -749,7 +749,7 @@ let ltac_ring_structure e = lemma1;lemma2;pretac;posttac] let ring_lookup (f : Value.t) lH rl t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try (* find_ring_strucure can raise an exception *) @@ -761,7 +761,7 @@ let ring_lookup (f : Value.t) lH rl t = let ring = ltac_ring_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e - end } + end (***********************************************************************) @@ -1035,7 +1035,7 @@ let ltac_field_structure e = field_simpl_eq_in_ok;cond_ok;pretac;posttac] let field_lookup (f : Value.t) lH rl t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try @@ -1047,4 +1047,4 @@ let field_lookup (f : Value.t) lH rl t = let field = ltac_field_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e - end } + end diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli new file mode 100644 index 000000000..69202ae2d --- /dev/null +++ b/plugins/ssr/ssrast.mli @@ -0,0 +1,149 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names +open Ltac_plugin + +(* Names of variables to be cleared (automatic check: not a section var) *) +type ssrhyp = SsrHyp of Id.t Loc.located +(* Variant of the above *) +type ssrhyp_or_id = Hyp of ssrhyp | Id of ssrhyp + +(* Variant of the above *) +type ssrhyps = ssrhyp list + +(* Direction to be used for rewriting as in -> or rewrite flag *) +type ssrdir = Ssrmatching_plugin.Ssrmatching.ssrdir = L2R | R2L + +(* simpl: "/=", cut: "//", simplcut: "//=" nop: commodity placeholder *) +type ssrsimpl = Simpl of int | Cut of int | SimplCut of int * int | Nop + +(* modality for rewrite and do: ! ? *) +type ssrmmod = May | Must | Once + +(* modality with a bound for rewrite and do: !n ?n *) +type ssrmult = int * ssrmmod + +(** Occurrence switch {1 2}, all is Some(false,[]) *) +type ssrocc = (bool * int list) option + +(* index MAYBE REMOVE ONLY INTERNAL stuff between {} *) +type ssrindex = int Misctypes.or_var + +(* clear switch {H G} *) +type ssrclear = ssrhyps + +(* Discharge occ switch (combined occurrence / clear switch) *) +type ssrdocc = ssrclear option * ssrocc + +(* FIXME, make algebraic *) +type ssrtermkind = char + +type ssrterm = ssrtermkind * Tacexpr.glob_constr_and_expr + +type ssrview = ssrterm list + +(* TODO +type id_mod = Hat | HatTilde | Sharp + *) + +(* Only [One] forces an introduction, possibly reducing the goal. *) +type anon_iter = + | One + | Drop + | All + +(* TODO + | Dependent (* fast mode *) + | UntilMark + | Temporary (* "+" *) + *) + +type ssripat = + | IPatNoop + | IPatId of (*TODO id_mod option * *) Id.t + | IPatAnon of anon_iter (* inaccessible name *) +(* TODO | IPatClearMark *) +(* TODO | IPatDispatch of ssripatss (* /[..|..] *) *) + | IPatCase of (* ipats_mod option * *) ssripatss (* this is not equivalent to /case /[..|..] if there are already multiple goals *) + | IPatInj of ssripatss + | IPatRewrite of (*occurrence option * rewrite_pattern **) ssrocc * ssrdir + | IPatView of ssrterm list (* /view *) + | IPatClear of ssrclear (* {H1 H2} *) + | IPatSimpl of ssrsimpl + | IPatNewHidden of identifier list +(* | IPatVarsForAbstract of Id.t list *) + +and ssripats = ssripat list +and ssripatss = ssripats list +type ssrhpats = ((ssrclear * ssripats) * ssripats) * ssripats +type ssrhpats_wtransp = bool * ssrhpats + +(* tac => inpats *) +type ssrintrosarg = Tacexpr.raw_tactic_expr * ssripats + + +type ssrfwdid = Id.t +(** Binders (for fwd tactics) *) +type 'term ssrbind = + | Bvar of name + | Bdecl of name list * 'term + | Bdef of name * 'term option * 'term + | Bstruct of name + | Bcast of 'term +(* We use an intermediate structure to correctly render the binder list *) +(* abbreviations. We use a list of hints to extract the binders and *) +(* base term from a term, for the two first levels of representation of *) +(* of constr terms. *) +type ssrbindfmt = + | BFvar + | BFdecl of int (* #xs *) + | BFcast (* final cast *) + | BFdef (* has cast? *) + | BFrec of bool * bool (* has struct? * has cast? *) +type 'term ssrbindval = 'term ssrbind list * 'term + +(** Forward chaining argument *) +(* There are three kinds of forward definitions: *) +(* - Hint: type only, cast to Type, may have proof hint. *) +(* - Have: type option + value, no space before type *) +(* - Pose: binders + value, space before binders. *) +type ssrfwdkind = FwdHint of string * bool | FwdHave | FwdPose +type ssrfwdfmt = ssrfwdkind * ssrbindfmt list + +(* in *) +type ssrclseq = InGoal | InHyps + | InHypsGoal | InHypsSeqGoal | InSeqGoal | InHypsSeq | InAll | InAllHyps + +type 'tac ssrhint = bool * 'tac option list + +type 'tac fwdbinders = + bool * (ssrhpats * ((ssrfwdfmt * ssrterm) * 'tac ssrhint)) + +type clause = + (ssrclear * ((ssrhyp_or_id * string) * + Ssrmatching_plugin.Ssrmatching.cpattern option) option) +type clauses = clause list * ssrclseq + +type wgen = + (ssrclear * + ((ssrhyp_or_id * string) * + Ssrmatching_plugin.Ssrmatching.cpattern option) + option) + +type 'a ssrdoarg = ((ssrindex * ssrmmod) * 'a ssrhint) * clauses +type 'a ssrseqarg = ssrindex * ('a ssrhint * 'a option) + +(* OOP : these are general shortcuts *) +type gist = Tacintern.glob_sign +type ist = Tacinterp.interp_sign +type goal = Proof_type.goal +type 'a sigma = 'a Evd.sigma +type v82tac = Proof_type.tactic diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v new file mode 100644 index 000000000..63bf0116c --- /dev/null +++ b/plugins/ssr/ssrbool.v @@ -0,0 +1,1871 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +Require Bool. +Require Import ssreflect ssrfun. + +(******************************************************************************) +(* A theory of boolean predicates and operators. A large part of this file is *) +(* concerned with boolean reflection. *) +(* Definitions and notations: *) +(* is_true b == the coercion of b : bool to Prop (:= b = true). *) +(* This is just input and displayed as `b''. *) +(* reflect P b == the reflection inductive predicate, asserting *) +(* that the logical proposition P : prop with the *) +(* formula b : bool. Lemmas asserting reflect P b *) +(* are often referred to as "views". *) +(* iffP, appP, sameP, rwP :: lemmas for direct manipulation of reflection *) +(* views: iffP is used to prove reflection from *) +(* logical equivalence, appP to compose views, and *) +(* sameP and rwP to perform boolean and setoid *) +(* rewriting. *) +(* elimT :: coercion reflect >-> Funclass, which allows the *) +(* direct application of `reflect' views to *) +(* boolean assertions. *) +(* decidable P <-> P is effectively decidable (:= {P} + {~ P}. *) +(* contra, contraL, ... :: contraposition lemmas. *) +(* altP my_viewP :: natural alternative for reflection; given *) +(* lemma myviewP: reflect my_Prop my_formula, *) +(* have [myP | not_myP] := altP my_viewP. *) +(* generates two subgoals, in which my_formula has *) +(* been replaced by true and false, resp., with *) +(* new assumptions myP : my_Prop and *) +(* not_myP: ~~ my_formula. *) +(* Caveat: my_formula must be an APPLICATION, not *) +(* a variable, constant, let-in, etc. (due to the *) +(* poor behaviour of dependent index matching). *) +(* boolP my_formula :: boolean disjunction, equivalent to *) +(* altP (idP my_formula) but circumventing the *) +(* dependent index capture issue; destructing *) +(* boolP my_formula generates two subgoals with *) +(* assumtions my_formula and ~~ myformula. As *) +(* with altP, my_formula must be an application. *) +(* \unless C, P <-> we can assume property P when a something that *) +(* holds under condition C (such as C itself). *) +(* := forall G : Prop, (C -> G) -> (P -> G) -> G. *) +(* This is just C \/ P or rather its impredicative *) +(* encoding, whose usage better fits the above *) +(* description: given a lemma UCP whose conclusion *) +(* is \unless C, P we can assume P by writing: *) +(* wlog hP: / P by apply/UCP; (prove C -> goal). *) +(* or even apply: UCP id _ => hP if the goal is C. *) +(* classically P <-> we can assume P when proving is_true b. *) +(* := forall b : bool, (P -> b) -> b. *) +(* This is equivalent to ~ (~ P) when P : Prop. *) +(* implies P Q == wrapper coinductive type that coerces to P -> Q *) +(* and can be used as a P -> Q view unambigously. *) +(* Useful to avoid spurious insertion of <-> views *) +(* when Q is a conjunction of foralls, as in Lemma *) +(* all_and2 below; conversely, avoids confusion in *) +(* apply views for impredicative properties, such *) +(* as \unless C, P. Also supports contrapositives. *) +(* a && b == the boolean conjunction of a and b. *) +(* a || b == the boolean disjunction of a and b. *) +(* a ==> b == the boolean implication of b by a. *) +(* ~~ a == the boolean negation of a. *) +(* a (+) b == the boolean exclusive or (or sum) of a and b. *) +(* [ /\ P1 , P2 & P3 ] == multiway logical conjunction, up to 5 terms. *) +(* [ \/ P1 , P2 | P3 ] == multiway logical disjunction, up to 4 terms. *) +(* [&& a, b, c & d] == iterated, right associative boolean conjunction *) +(* with arbitrary arity. *) +(* [|| a, b, c | d] == iterated, right associative boolean disjunction *) +(* with arbitrary arity. *) +(* [==> a, b, c => d] == iterated, right associative boolean implication *) +(* with arbitrary arity. *) +(* and3P, ... == specific reflection lemmas for iterated *) +(* connectives. *) +(* andTb, orbAC, ... == systematic names for boolean connective *) +(* properties (see suffix conventions below). *) +(* prop_congr == a tactic to move a boolean equality from *) +(* its coerced form in Prop to the equality *) +(* in bool. *) +(* bool_congr == resolution tactic for blindly weeding out *) +(* like terms from boolean equalities (can fail). *) +(* This file provides a theory of boolean predicates and relations: *) +(* pred T == the type of bool predicates (:= T -> bool). *) +(* simpl_pred T == the type of simplifying bool predicates, using *) +(* the simpl_fun from ssrfun.v. *) +(* rel T == the type of bool relations. *) +(* := T -> pred T or T -> T -> bool. *) +(* simpl_rel T == type of simplifying relations. *) +(* predType == the generic predicate interface, supported for *) +(* for lists and sets. *) +(* pred_class == a coercion class for the predType projection to *) +(* pred; declaring a coercion to pred_class is an *) +(* alternative way of equipping a type with a *) +(* predType structure, which interoperates better *) +(* with coercion subtyping. This is used, e.g., *) +(* for finite sets, so that finite groups inherit *) +(* the membership operation by coercing to sets. *) +(* If P is a predicate the proposition "x satisfies P" can be written *) +(* applicatively as (P x), or using an explicit connective as (x \in P); in *) +(* the latter case we say that P is a "collective" predicate. We use A, B *) +(* rather than P, Q for collective predicates: *) +(* x \in A == x satisfies the (collective) predicate A. *) +(* x \notin A == x doesn't satisfy the (collective) predicate A. *) +(* The pred T type can be used as a generic predicate type for either kind, *) +(* but the two kinds of predicates should not be confused. When a "generic" *) +(* pred T value of one type needs to be passed as the other the following *) +(* conversions should be used explicitly: *) +(* SimplPred P == a (simplifying) applicative equivalent of P. *) +(* mem A == an applicative equivalent of A: *) +(* mem A x simplifies to x \in A. *) +(* Alternatively one can use the syntax for explicit simplifying predicates *) +(* and relations (in the following x is bound in E): *) +(* [pred x | E] == simplifying (see ssrfun) predicate x => E. *) +(* [pred x : T | E] == predicate x => E, with a cast on the argument. *) +(* [pred : T | P] == constant predicate P on type T. *) +(* [pred x | E1 & E2] == [pred x | E1 && E2]; an x : T cast is allowed. *) +(* [pred x in A] == [pred x | x in A]. *) +(* [pred x in A | E] == [pred x | x in A & E]. *) +(* [pred x in A | E1 & E2] == [pred x in A | E1 && E2]. *) +(* [predU A & B] == union of two collective predicates A and B. *) +(* [predI A & B] == intersection of collective predicates A and B. *) +(* [predD A & B] == difference of collective predicates A and B. *) +(* [predC A] == complement of the collective predicate A. *) +(* [preim f of A] == preimage under f of the collective predicate A. *) +(* predU P Q, ... == union, etc of applicative predicates. *) +(* pred0 == the empty predicate. *) +(* predT == the total (always true) predicate. *) +(* if T : predArgType, then T coerces to predT. *) +(* {: T} == T cast to predArgType (e.g., {: bool * nat}) *) +(* In the following, x and y are bound in E: *) +(* [rel x y | E] == simplifying relation x, y => E. *) +(* [rel x y : T | E] == simplifying relation with arguments cast. *) +(* [rel x y in A & B | E] == [rel x y | [&& x \in A, y \in B & E]]. *) +(* [rel x y in A & B] == [rel x y | (x \in A) && (y \in B)]. *) +(* [rel x y in A | E] == [rel x y in A & A | E]. *) +(* [rel x y in A] == [rel x y in A & A]. *) +(* relU R S == union of relations R and S. *) +(* Explicit values of type pred T (i.e., lamdba terms) should always be used *) +(* applicatively, while values of collection types implementing the predType *) +(* interface, such as sequences or sets should always be used as collective *) +(* predicates. Defined constants and functions of type pred T or simpl_pred T *) +(* as well as the explicit simpl_pred T values described below, can generally *) +(* be used either way. Note however that x \in A will not auto-simplify when *) +(* A is an explicit simpl_pred T value; the generic simplification rule inE *) +(* must be used (when A : pred T, the unfold_in rule can be used). Constants *) +(* of type pred T with an explicit simpl_pred value do not auto-simplify when *) +(* used applicatively, but can still be expanded with inE. This behavior can *) +(* be controlled as follows: *) +(* Let A : collective_pred T := [pred x | ... ]. *) +(* The collective_pred T type is just an alias for pred T, but this cast *) +(* stops rewrite inE from expanding the definition of A, thus treating A *) +(* into an abstract collection (unfold_in or in_collective can be used to *) +(* expand manually). *) +(* Let A : applicative_pred T := [pred x | ...]. *) +(* This cast causes inE to turn x \in A into the applicative A x form; *) +(* A will then have to unfolded explicitly with the /A rule. This will *) +(* also apply to any definition that reduces to A (e.g., Let B := A). *) +(* Canonical A_app_pred := ApplicativePred A. *) +(* This declaration, given after definition of A, similarly causes inE to *) +(* turn x \in A into A x, but in addition allows the app_predE rule to *) +(* turn A x back into x \in A; it can be used for any definition of type *) +(* pred T, which makes it especially useful for ambivalent predicates *) +(* as the relational transitive closure connect, that are used in both *) +(* applicative and collective styles. *) +(* Purely for aesthetics, we provide a subtype of collective predicates: *) +(* qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T *) +(* coerces to pred_class and thus behaves as a collective *) +(* predicate, but x \in A and x \notin A are displayed as: *) +(* x \is A and x \isn't A when q = 0, *) +(* x \is a A and x \isn't a A when q = 1, *) +(* x \is an A and x \isn't an A when q = 2, respectively. *) +(* [qualify x | P] := Qualifier 0 (fun x => P), constructor for the above. *) +(* [qualify x : T | P], [qualify a x | P], [qualify an X | P], etc. *) +(* variants of the above with type constraints and different *) +(* values of q. *) +(* We provide an internal interface to support attaching properties (such as *) +(* being multiplicative) to predicates: *) +(* pred_key p == phantom type that will serve as a support for properties *) +(* to be attached to p : pred_class; instances should be *) +(* created with Fact/Qed so as to be opaque. *) +(* KeyedPred k_p == an instance of the interface structure that attaches *) +(* (k_p : pred_key P) to P; the structure projection is a *) +(* coercion to pred_class. *) +(* KeyedQualifier k_q == an instance of the interface structure that attaches *) +(* (k_q : pred_key q) to (q : qualifier n T). *) +(* DefaultPredKey p == a default value for pred_key p; the vernacular command *) +(* Import DefaultKeying attaches this key to all predicates *) +(* that are not explicitly keyed. *) +(* Keys can be used to attach properties to predicates, qualifiers and *) +(* generic nouns in a way that allows them to be used transparently. The key *) +(* projection of a predicate property structure such as unsignedPred should *) +(* be a pred_key, not a pred, and corresponding lemmas will have the form *) +(* Lemma rpredN R S (oppS : @opprPred R S) (kS : keyed_pred oppS) : *) +(* {mono -%R: x / x \in kS}. *) +(* Because x \in kS will be displayed as x \in S (or x \is S, etc), the *) +(* canonical instance of opprPred will not normally be exposed (it will also *) +(* be erased by /= simplification). In addition each predicate structure *) +(* should have a DefaultPredKey Canonical instance that simply issues the *) +(* property as a proof obligation (which can be caught by the Prop-irrelevant *) +(* feature of the ssreflect plugin). *) +(* Some properties of predicates and relations: *) +(* A =i B <-> A and B are extensionally equivalent. *) +(* {subset A <= B} <-> A is a (collective) subpredicate of B. *) +(* subpred P Q <-> P is an (applicative) subpredicate or Q. *) +(* subrel R S <-> R is a subrelation of S. *) +(* In the following R is in rel T: *) +(* reflexive R <-> R is reflexive. *) +(* irreflexive R <-> R is irreflexive. *) +(* symmetric R <-> R (in rel T) is symmetric (equation). *) +(* pre_symmetric R <-> R is symmetric (implication). *) +(* antisymmetric R <-> R is antisymmetric. *) +(* total R <-> R is total. *) +(* transitive R <-> R is transitive. *) +(* left_transitive R <-> R is a congruence on its left hand side. *) +(* right_transitive R <-> R is a congruence on its right hand side. *) +(* equivalence_rel R <-> R is an equivalence relation. *) +(* Localization of (Prop) predicates; if P1 is convertible to forall x, Qx, *) +(* P2 to forall x y, Qxy and P3 to forall x y z, Qxyz : *) +(* {for y, P1} <-> Qx{y / x}. *) +(* {in A, P1} <-> forall x, x \in A -> Qx. *) +(* {in A1 & A2, P2} <-> forall x y, x \in A1 -> y \in A2 -> Qxy. *) +(* {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. *) +(* {in A1 & A2 & A3, Q3} <-> forall x y z, *) +(* x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. *) +(* {in A1 & A2 &, Q3} == {in A1 & A2 & A2, Q3}. *) +(* {in A1 && A3, Q3} == {in A1 & A1 & A3, Q3}. *) +(* {in A &&, Q3} == {in A & A & A, Q3}. *) +(* {in A, bijective f} == f has a right inverse in A. *) +(* {on C, P1} == forall x, (f x) \in C -> Qx *) +(* when P1 is also convertible to Pf f. *) +(* {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy *) +(* when P2 is also convertible to Pf f. *) +(* {on C, P1' & g} == forall x, (f x) \in cd -> Qx *) +(* when P1' is convertible to Pf f *) +(* and P1' g is convertible to forall x, Qx. *) +(* {on C, bijective f} == f has a right inverse on C. *) +(* This file extends the lemma name suffix conventions of ssrfun as follows: *) +(* A -- associativity, as in andbA : associative andb. *) +(* AC -- right commutativity. *) +(* ACA -- self-interchange (inner commutativity), e.g., *) +(* orbACA : (a || b) || (c || d) = (a || c) || (b || d). *) +(* b -- a boolean argument, as in andbb : idempotent andb. *) +(* C -- commutativity, as in andbC : commutative andb, *) +(* or predicate complement, as in predC. *) +(* CA -- left commutativity. *) +(* D -- predicate difference, as in predD. *) +(* E -- elimination, as in negbFE : ~~ b = false -> b. *) +(* F or f -- boolean false, as in andbF : b && false = false. *) +(* I -- left/right injectivity, as in addbI : right_injective addb, *) +(* or predicate intersection, as in predI. *) +(* l -- a left-hand operation, as andb_orl : left_distributive andb orb. *) +(* N or n -- boolean negation, as in andbN : a && (~~ a) = false. *) +(* P -- a characteristic property, often a reflection lemma, as in *) +(* andP : reflect (a /\ b) (a && b). *) +(* r -- a right-hand operation, as orb_andr : rightt_distributive orb andb. *) +(* T or t -- boolean truth, as in andbT: right_id true andb. *) +(* U -- predicate union, as in predU. *) +(* W -- weakening, as in in1W : {in D, forall x, P} -> forall x, P. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. +Set Warnings "-projection-no-head-constant". + +Notation reflect := Bool.reflect. +Notation ReflectT := Bool.ReflectT. +Notation ReflectF := Bool.ReflectF. + +Reserved Notation "~~ b" (at level 35, right associativity). +Reserved Notation "b ==> c" (at level 55, right associativity). +Reserved Notation "b1 (+) b2" (at level 50, left associativity). +Reserved Notation "x \in A" + (at level 70, format "'[hv' x '/ ' \in A ']'", no associativity). +Reserved Notation "x \notin A" + (at level 70, format "'[hv' x '/ ' \notin A ']'", no associativity). +Reserved Notation "p1 =i p2" + (at level 70, format "'[hv' p1 '/ ' =i p2 ']'", no associativity). + +(* We introduce a number of n-ary "list-style" notations that share a common *) +(* format, namely *) +(* [op arg1, arg2, ... last_separator last_arg] *) +(* This usually denotes a right-associative applications of op, e.g., *) +(* [&& a, b, c & d] denotes a && (b && (c && d)) *) +(* The last_separator must be a non-operator token. Here we use &, | or =>; *) +(* our default is &, but we try to match the intended meaning of op. The *) +(* separator is a workaround for limitations of the parsing engine; the same *) +(* limitations mean the separator cannot be omitted even when last_arg can. *) +(* The Notation declarations are complicated by the separate treatment for *) +(* some fixed arities (binary for bool operators, and all arities for Prop *) +(* operators). *) +(* We also use the square brackets in comprehension-style notations *) +(* [type var separator expr] *) +(* where "type" is the type of the comprehension (e.g., pred) and "separator" *) +(* is | or => . It is important that in other notations a leading square *) +(* bracket [ is always followed by an operator symbol or a fixed identifier. *) + +Reserved Notation "[ /\ P1 & P2 ]" (at level 0, only parsing). +Reserved Notation "[ /\ P1 , P2 & P3 ]" (at level 0, format + "'[hv' [ /\ '[' P1 , '/' P2 ']' '/ ' & P3 ] ']'"). +Reserved Notation "[ /\ P1 , P2 , P3 & P4 ]" (at level 0, format + "'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 ']' '/ ' & P4 ] ']'"). +Reserved Notation "[ /\ P1 , P2 , P3 , P4 & P5 ]" (at level 0, format + "'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 , '/' P4 ']' '/ ' & P5 ] ']'"). + +Reserved Notation "[ \/ P1 | P2 ]" (at level 0, only parsing). +Reserved Notation "[ \/ P1 , P2 | P3 ]" (at level 0, format + "'[hv' [ \/ '[' P1 , '/' P2 ']' '/ ' | P3 ] ']'"). +Reserved Notation "[ \/ P1 , P2 , P3 | P4 ]" (at level 0, format + "'[hv' [ \/ '[' P1 , '/' P2 , '/' P3 ']' '/ ' | P4 ] ']'"). + +Reserved Notation "[ && b1 & c ]" (at level 0, only parsing). +Reserved Notation "[ && b1 , b2 , .. , bn & c ]" (at level 0, format + "'[hv' [ && '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/ ' & c ] ']'"). + +Reserved Notation "[ || b1 | c ]" (at level 0, only parsing). +Reserved Notation "[ || b1 , b2 , .. , bn | c ]" (at level 0, format + "'[hv' [ || '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/ ' | c ] ']'"). + +Reserved Notation "[ ==> b1 => c ]" (at level 0, only parsing). +Reserved Notation "[ ==> b1 , b2 , .. , bn => c ]" (at level 0, format + "'[hv' [ ==> '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/' => c ] ']'"). + +Reserved Notation "[ 'pred' : T => E ]" (at level 0, format + "'[hv' [ 'pred' : T => '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x => E ]" (at level 0, x at level 8, format + "'[hv' [ 'pred' x => '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x : T => E ]" (at level 0, x at level 8, format + "'[hv' [ 'pred' x : T => '/ ' E ] ']'"). + +Reserved Notation "[ 'rel' x y => E ]" (at level 0, x, y at level 8, format + "'[hv' [ 'rel' x y => '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y : T => E ]" (at level 0, x, y at level 8, format + "'[hv' [ 'rel' x y : T => '/ ' E ] ']'"). + +(* Shorter delimiter *) +Delimit Scope bool_scope with B. +Open Scope bool_scope. + +(* An alternative to xorb that behaves somewhat better wrt simplification. *) +Definition addb b := if b then negb else id. + +(* Notation for && and || is declared in Init.Datatypes. *) +Notation "~~ b" := (negb b) : bool_scope. +Notation "b ==> c" := (implb b c) : bool_scope. +Notation "b1 (+) b2" := (addb b1 b2) : bool_scope. + +(* Constant is_true b := b = true is defined in Init.Datatypes. *) +Coercion is_true : bool >-> Sortclass. (* Prop *) + +Lemma prop_congr : forall b b' : bool, b = b' -> b = b' :> Prop. +Proof. by move=> b b' ->. Qed. + +Ltac prop_congr := apply: prop_congr. + +(* Lemmas for trivial. *) +Lemma is_true_true : true. Proof. by []. Qed. +Lemma not_false_is_true : ~ false. Proof. by []. Qed. +Lemma is_true_locked_true : locked true. Proof. by unlock. Qed. +Hint Resolve is_true_true not_false_is_true is_true_locked_true. + +(* Shorter names. *) +Definition isT := is_true_true. +Definition notF := not_false_is_true. + +(* Negation lemmas. *) + +(* We generally take NEGATION as the standard form of a false condition: *) +(* negative boolean hypotheses should be of the form ~~ b, rather than ~ b or *) +(* b = false, as much as possible. *) + +Lemma negbT b : b = false -> ~~ b. Proof. by case: b. Qed. +Lemma negbTE b : ~~ b -> b = false. Proof. by case: b. Qed. +Lemma negbF b : (b : bool) -> ~~ b = false. Proof. by case: b. Qed. +Lemma negbFE b : ~~ b = false -> b. Proof. by case: b. Qed. +Lemma negbK : involutive negb. Proof. by case. Qed. +Lemma negbNE b : ~~ ~~ b -> b. Proof. by case: b. Qed. + +Lemma negb_inj : injective negb. Proof. exact: can_inj negbK. Qed. +Lemma negbLR b c : b = ~~ c -> ~~ b = c. Proof. exact: canLR negbK. Qed. +Lemma negbRL b c : ~~ b = c -> b = ~~ c. Proof. exact: canRL negbK. Qed. + +Lemma contra (c b : bool) : (c -> b) -> ~~ b -> ~~ c. +Proof. by case: b => //; case: c. Qed. +Definition contraNN := contra. + +Lemma contraL (c b : bool) : (c -> ~~ b) -> b -> ~~ c. +Proof. by case: b => //; case: c. Qed. +Definition contraTN := contraL. + +Lemma contraR (c b : bool) : (~~ c -> b) -> ~~ b -> c. +Proof. by case: b => //; case: c. Qed. +Definition contraNT := contraR. + +Lemma contraLR (c b : bool) : (~~ c -> ~~ b) -> b -> c. +Proof. by case: b => //; case: c. Qed. +Definition contraTT := contraLR. + +Lemma contraT b : (~~ b -> false) -> b. Proof. by case: b => // ->. Qed. + +Lemma wlog_neg b : (~~ b -> b) -> b. Proof. by case: b => // ->. Qed. + +Lemma contraFT (c b : bool) : (~~ c -> b) -> b = false -> c. +Proof. by move/contraR=> notb_c /negbT. Qed. + +Lemma contraFN (c b : bool) : (c -> b) -> b = false -> ~~ c. +Proof. by move/contra=> notb_notc /negbT. Qed. + +Lemma contraTF (c b : bool) : (c -> ~~ b) -> b -> c = false. +Proof. by move/contraL=> b_notc /b_notc/negbTE. Qed. + +Lemma contraNF (c b : bool) : (c -> b) -> ~~ b -> c = false. +Proof. by move/contra=> notb_notc /notb_notc/negbTE. Qed. + +Lemma contraFF (c b : bool) : (c -> b) -> b = false -> c = false. +Proof. by move/contraFN=> bF_notc /bF_notc/negbTE. Qed. + +(* Coercion of sum-style datatypes into bool, which makes it possible *) +(* to use ssr's boolean if rather than Coq's "generic" if. *) + +Coercion isSome T (u : option T) := if u is Some _ then true else false. + +Coercion is_inl A B (u : A + B) := if u is inl _ then true else false. + +Coercion is_left A B (u : {A} + {B}) := if u is left _ then true else false. + +Coercion is_inleft A B (u : A + {B}) := if u is inleft _ then true else false. + +Prenex Implicits isSome is_inl is_left is_inleft. + +Definition decidable P := {P} + {~ P}. + +(* Lemmas for ifs with large conditions, which allow reasoning about the *) +(* condition without repeating it inside the proof (the latter IS *) +(* preferable when the condition is short). *) +(* Usage : *) +(* if the goal contains (if cond then ...) = ... *) +(* case: ifP => Hcond. *) +(* generates two subgoal, with the assumption Hcond : cond = true/false *) +(* Rewrite if_same eliminates redundant ifs *) +(* Rewrite (fun_if f) moves a function f inside an if *) +(* Rewrite if_arg moves an argument inside a function-valued if *) + +Section BoolIf. + +Variables (A B : Type) (x : A) (f : A -> B) (b : bool) (vT vF : A). + +CoInductive if_spec (not_b : Prop) : bool -> A -> Set := + | IfSpecTrue of b : if_spec not_b true vT + | IfSpecFalse of not_b : if_spec not_b false vF. + +Lemma ifP : if_spec (b = false) b (if b then vT else vF). +Proof. by case def_b: b; constructor. Qed. + +Lemma ifPn : if_spec (~~ b) b (if b then vT else vF). +Proof. by case def_b: b; constructor; rewrite ?def_b. Qed. + +Lemma ifT : b -> (if b then vT else vF) = vT. Proof. by move->. Qed. +Lemma ifF : b = false -> (if b then vT else vF) = vF. Proof. by move->. Qed. +Lemma ifN : ~~ b -> (if b then vT else vF) = vF. Proof. by move/negbTE->. Qed. + +Lemma if_same : (if b then vT else vT) = vT. +Proof. by case b. Qed. + +Lemma if_neg : (if ~~ b then vT else vF) = if b then vF else vT. +Proof. by case b. Qed. + +Lemma fun_if : f (if b then vT else vF) = if b then f vT else f vF. +Proof. by case b. Qed. + +Lemma if_arg (fT fF : A -> B) : + (if b then fT else fF) x = if b then fT x else fF x. +Proof. by case b. Qed. + +(* Turning a boolean "if" form into an application. *) +Definition if_expr := if b then vT else vF. +Lemma ifE : (if b then vT else vF) = if_expr. Proof. by []. Qed. + +End BoolIf. + +(* Core (internal) reflection lemmas, used for the three kinds of views. *) + +Section ReflectCore. + +Variables (P Q : Prop) (b c : bool). + +Hypothesis Hb : reflect P b. + +Lemma introNTF : (if c then ~ P else P) -> ~~ b = c. +Proof. by case c; case Hb. Qed. + +Lemma introTF : (if c then P else ~ P) -> b = c. +Proof. by case c; case Hb. Qed. + +Lemma elimNTF : ~~ b = c -> if c then ~ P else P. +Proof. by move <-; case Hb. Qed. + +Lemma elimTF : b = c -> if c then P else ~ P. +Proof. by move <-; case Hb. Qed. + +Lemma equivPif : (Q -> P) -> (P -> Q) -> if b then Q else ~ Q. +Proof. by case Hb; auto. Qed. + +Lemma xorPif : Q \/ P -> ~ (Q /\ P) -> if b then ~ Q else Q. +Proof. by case Hb => [? _ H ? | ? H _]; case: H. Qed. + +End ReflectCore. + +(* Internal negated reflection lemmas *) +Section ReflectNegCore. + +Variables (P Q : Prop) (b c : bool). +Hypothesis Hb : reflect P (~~ b). + +Lemma introTFn : (if c then ~ P else P) -> b = c. +Proof. by move/(introNTF Hb) <-; case b. Qed. + +Lemma elimTFn : b = c -> if c then ~ P else P. +Proof. by move <-; apply: (elimNTF Hb); case b. Qed. + +Lemma equivPifn : (Q -> P) -> (P -> Q) -> if b then ~ Q else Q. +Proof. by rewrite -if_neg; apply: equivPif. Qed. + +Lemma xorPifn : Q \/ P -> ~ (Q /\ P) -> if b then Q else ~ Q. +Proof. by rewrite -if_neg; apply: xorPif. Qed. + +End ReflectNegCore. + +(* User-oriented reflection lemmas *) +Section Reflect. + +Variables (P Q : Prop) (b b' c : bool). +Hypotheses (Pb : reflect P b) (Pb' : reflect P (~~ b')). + +Lemma introT : P -> b. Proof. exact: introTF true _. Qed. +Lemma introF : ~ P -> b = false. Proof. exact: introTF false _. Qed. +Lemma introN : ~ P -> ~~ b. Proof. exact: introNTF true _. Qed. +Lemma introNf : P -> ~~ b = false. Proof. exact: introNTF false _. Qed. +Lemma introTn : ~ P -> b'. Proof. exact: introTFn true _. Qed. +Lemma introFn : P -> b' = false. Proof. exact: introTFn false _. Qed. + +Lemma elimT : b -> P. Proof. exact: elimTF true _. Qed. +Lemma elimF : b = false -> ~ P. Proof. exact: elimTF false _. Qed. +Lemma elimN : ~~ b -> ~P. Proof. exact: elimNTF true _. Qed. +Lemma elimNf : ~~ b = false -> P. Proof. exact: elimNTF false _. Qed. +Lemma elimTn : b' -> ~ P. Proof. exact: elimTFn true _. Qed. +Lemma elimFn : b' = false -> P. Proof. exact: elimTFn false _. Qed. + +Lemma introP : (b -> Q) -> (~~ b -> ~ Q) -> reflect Q b. +Proof. by case b; constructor; auto. Qed. + +Lemma iffP : (P -> Q) -> (Q -> P) -> reflect Q b. +Proof. by case: Pb; constructor; auto. Qed. + +Lemma equivP : (P <-> Q) -> reflect Q b. +Proof. by case; apply: iffP. Qed. + +Lemma sumboolP (decQ : decidable Q) : reflect Q decQ. +Proof. by case: decQ; constructor. Qed. + +Lemma appP : reflect Q b -> P -> Q. +Proof. by move=> Qb; move/introT; case: Qb. Qed. + +Lemma sameP : reflect P c -> b = c. +Proof. by case; [apply: introT | apply: introF]. Qed. + +Lemma decPcases : if b then P else ~ P. Proof. by case Pb. Qed. + +Definition decP : decidable P. by case: b decPcases; [left | right]. Defined. + +Lemma rwP : P <-> b. Proof. by split; [apply: introT | apply: elimT]. Qed. + +Lemma rwP2 : reflect Q b -> (P <-> Q). +Proof. by move=> Qb; split=> ?; [apply: appP | apply: elimT; case: Qb]. Qed. + +(* Predicate family to reflect excluded middle in bool. *) +CoInductive alt_spec : bool -> Type := + | AltTrue of P : alt_spec true + | AltFalse of ~~ b : alt_spec false. + +Lemma altP : alt_spec b. +Proof. by case def_b: b / Pb; constructor; rewrite ?def_b. Qed. + +End Reflect. + +Hint View for move/ elimTF|3 elimNTF|3 elimTFn|3 introT|2 introTn|2 introN|2. + +Hint View for apply/ introTF|3 introNTF|3 introTFn|3 elimT|2 elimTn|2 elimN|2. + +Hint View for apply// equivPif|3 xorPif|3 equivPifn|3 xorPifn|3. + +(* Allow the direct application of a reflection lemma to a boolean assertion. *) +Coercion elimT : reflect >-> Funclass. + +CoInductive implies P Q := Implies of P -> Q. +Lemma impliesP P Q : implies P Q -> P -> Q. Proof. by case. Qed. +Lemma impliesPn (P Q : Prop) : implies P Q -> ~ Q -> ~ P. +Proof. by case=> iP ? /iP. Qed. +Coercion impliesP : implies >-> Funclass. +Hint View for move/ impliesPn|2 impliesP|2. +Hint View for apply/ impliesPn|2 impliesP|2. + +(* Impredicative or, which can emulate a classical not-implies. *) +Definition unless condition property : Prop := + forall goal : Prop, (condition -> goal) -> (property -> goal) -> goal. + +Notation "\unless C , P" := (unless C P) + (at level 200, C at level 100, + format "'[' \unless C , '/ ' P ']'") : type_scope. + +Lemma unlessL C P : implies C (\unless C, P). +Proof. by split=> hC G /(_ hC). Qed. + +Lemma unlessR C P : implies P (\unless C, P). +Proof. by split=> hP G _ /(_ hP). Qed. + +Lemma unless_sym C P : implies (\unless C, P) (\unless P, C). +Proof. by split; apply; [apply/unlessR | apply/unlessL]. Qed. + +Lemma unlessP (C P : Prop) : (\unless C, P) <-> C \/ P. +Proof. by split=> [|[/unlessL | /unlessR]]; apply; [left | right]. Qed. + +Lemma bind_unless C P {Q} : implies (\unless C, P) (\unless (\unless C, Q), P). +Proof. by split; apply=> [hC|hP]; [apply/unlessL/unlessL | apply/unlessR]. Qed. + +Lemma unless_contra b C : implies (~~ b -> C) (\unless C, b). +Proof. by split; case: b => [_ | hC]; [apply/unlessR | apply/unlessL/hC]. Qed. + +(* Classical reasoning becomes directly accessible for any bool subgoal. *) +(* Note that we cannot use "unless" here for lack of universe polymorphism. *) +Definition classically P : Prop := forall b : bool, (P -> b) -> b. + +Lemma classicP (P : Prop) : classically P <-> ~ ~ P. +Proof. +split=> [cP nP | nnP [] // nP]; last by case nnP; move/nP. +by have: P -> false; [move/nP | move/cP]. +Qed. + +Lemma classicW P : P -> classically P. Proof. by move=> hP _ ->. Qed. + +Lemma classic_bind P Q : (P -> classically Q) -> classically P -> classically Q. +Proof. by move=> iPQ cP b /iPQ-/cP. Qed. + +Lemma classic_EM P : classically (decidable P). +Proof. +by case=> // undecP; apply/undecP; right=> notP; apply/notF/undecP; left. +Qed. + +Lemma classic_pick T P : classically ({x : T | P x} + (forall x, ~ P x)). +Proof. +case=> // undecP; apply/undecP; right=> x Px. +by apply/notF/undecP; left; exists x. +Qed. + +Lemma classic_imply P Q : (P -> classically Q) -> classically (P -> Q). +Proof. +move=> iPQ []// notPQ; apply/notPQ=> /iPQ-cQ. +by case: notF; apply: cQ => hQ; apply: notPQ. +Qed. + +(* List notations for wider connectives; the Prop connectives have a fixed *) +(* width so as to avoid iterated destruction (we go up to width 5 for /\, and *) +(* width 4 for or). The bool connectives have arbitrary widths, but denote *) +(* expressions that associate to the RIGHT. This is consistent with the right *) +(* associativity of list expressions and thus more convenient in most proofs. *) + +Inductive and3 (P1 P2 P3 : Prop) : Prop := And3 of P1 & P2 & P3. + +Inductive and4 (P1 P2 P3 P4 : Prop) : Prop := And4 of P1 & P2 & P3 & P4. + +Inductive and5 (P1 P2 P3 P4 P5 : Prop) : Prop := + And5 of P1 & P2 & P3 & P4 & P5. + +Inductive or3 (P1 P2 P3 : Prop) : Prop := Or31 of P1 | Or32 of P2 | Or33 of P3. + +Inductive or4 (P1 P2 P3 P4 : Prop) : Prop := + Or41 of P1 | Or42 of P2 | Or43 of P3 | Or44 of P4. + +Notation "[ /\ P1 & P2 ]" := (and P1 P2) (only parsing) : type_scope. +Notation "[ /\ P1 , P2 & P3 ]" := (and3 P1 P2 P3) : type_scope. +Notation "[ /\ P1 , P2 , P3 & P4 ]" := (and4 P1 P2 P3 P4) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 & P5 ]" := (and5 P1 P2 P3 P4 P5) : type_scope. + +Notation "[ \/ P1 | P2 ]" := (or P1 P2) (only parsing) : type_scope. +Notation "[ \/ P1 , P2 | P3 ]" := (or3 P1 P2 P3) : type_scope. +Notation "[ \/ P1 , P2 , P3 | P4 ]" := (or4 P1 P2 P3 P4) : type_scope. + +Notation "[ && b1 & c ]" := (b1 && c) (only parsing) : bool_scope. +Notation "[ && b1 , b2 , .. , bn & c ]" := (b1 && (b2 && .. (bn && c) .. )) + : bool_scope. + +Notation "[ || b1 | c ]" := (b1 || c) (only parsing) : bool_scope. +Notation "[ || b1 , b2 , .. , bn | c ]" := (b1 || (b2 || .. (bn || c) .. )) + : bool_scope. + +Notation "[ ==> b1 , b2 , .. , bn => c ]" := + (b1 ==> (b2 ==> .. (bn ==> c) .. )) : bool_scope. +Notation "[ ==> b1 => c ]" := (b1 ==> c) (only parsing) : bool_scope. + +Section AllAnd. + +Variables (T : Type) (P1 P2 P3 P4 P5 : T -> Prop). +Local Notation a P := (forall x, P x). + +Lemma all_and2 : implies (forall x, [/\ P1 x & P2 x]) [/\ a P1 & a P2]. +Proof. by split=> haveP; split=> x; case: (haveP x). Qed. + +Lemma all_and3 : implies (forall x, [/\ P1 x, P2 x & P3 x]) + [/\ a P1, a P2 & a P3]. +Proof. by split=> haveP; split=> x; case: (haveP x). Qed. + +Lemma all_and4 : implies (forall x, [/\ P1 x, P2 x, P3 x & P4 x]) + [/\ a P1, a P2, a P3 & a P4]. +Proof. by split=> haveP; split=> x; case: (haveP x). Qed. + +Lemma all_and5 : implies (forall x, [/\ P1 x, P2 x, P3 x, P4 x & P5 x]) + [/\ a P1, a P2, a P3, a P4 & a P5]. +Proof. by split=> haveP; split=> x; case: (haveP x). Qed. + +End AllAnd. + +Arguments all_and2 {T P1 P2}. +Arguments all_and3 {T P1 P2 P3}. +Arguments all_and4 {T P1 P2 P3 P4}. +Arguments all_and5 {T P1 P2 P3 P4 P5}. + +Lemma pair_andP P Q : P /\ Q <-> P * Q. Proof. by split; case. Qed. + +Section ReflectConnectives. + +Variable b1 b2 b3 b4 b5 : bool. + +Lemma idP : reflect b1 b1. +Proof. by case b1; constructor. Qed. + +Lemma boolP : alt_spec b1 b1 b1. +Proof. exact: (altP idP). Qed. + +Lemma idPn : reflect (~~ b1) (~~ b1). +Proof. by case b1; constructor. Qed. + +Lemma negP : reflect (~ b1) (~~ b1). +Proof. by case b1; constructor; auto. Qed. + +Lemma negPn : reflect b1 (~~ ~~ b1). +Proof. by case b1; constructor. Qed. + +Lemma negPf : reflect (b1 = false) (~~ b1). +Proof. by case b1; constructor. Qed. + +Lemma andP : reflect (b1 /\ b2) (b1 && b2). +Proof. by case b1; case b2; constructor=> //; case. Qed. + +Lemma and3P : reflect [/\ b1, b2 & b3] [&& b1, b2 & b3]. +Proof. by case b1; case b2; case b3; constructor; try by case. Qed. + +Lemma and4P : reflect [/\ b1, b2, b3 & b4] [&& b1, b2, b3 & b4]. +Proof. by case b1; case b2; case b3; case b4; constructor; try by case. Qed. + +Lemma and5P : reflect [/\ b1, b2, b3, b4 & b5] [&& b1, b2, b3, b4 & b5]. +Proof. +by case b1; case b2; case b3; case b4; case b5; constructor; try by case. +Qed. + +Lemma orP : reflect (b1 \/ b2) (b1 || b2). +Proof. by case b1; case b2; constructor; auto; case. Qed. + +Lemma or3P : reflect [\/ b1, b2 | b3] [|| b1, b2 | b3]. +Proof. +case b1; first by constructor; constructor 1. +case b2; first by constructor; constructor 2. +case b3; first by constructor; constructor 3. +by constructor; case. +Qed. + +Lemma or4P : reflect [\/ b1, b2, b3 | b4] [|| b1, b2, b3 | b4]. +Proof. +case b1; first by constructor; constructor 1. +case b2; first by constructor; constructor 2. +case b3; first by constructor; constructor 3. +case b4; first by constructor; constructor 4. +by constructor; case. +Qed. + +Lemma nandP : reflect (~~ b1 \/ ~~ b2) (~~ (b1 && b2)). +Proof. by case b1; case b2; constructor; auto; case; auto. Qed. + +Lemma norP : reflect (~~ b1 /\ ~~ b2) (~~ (b1 || b2)). +Proof. by case b1; case b2; constructor; auto; case; auto. Qed. + +Lemma implyP : reflect (b1 -> b2) (b1 ==> b2). +Proof. by case b1; case b2; constructor; auto. Qed. + +End ReflectConnectives. + +Arguments idP [b1]. +Arguments idPn [b1]. +Arguments negP [b1]. +Arguments negPn [b1]. +Arguments negPf [b1]. +Arguments andP [b1 b2]. +Arguments and3P [b1 b2 b3]. +Arguments and4P [b1 b2 b3 b4]. +Arguments and5P [b1 b2 b3 b4 b5]. +Arguments orP [b1 b2]. +Arguments or3P [b1 b2 b3]. +Arguments or4P [b1 b2 b3 b4]. +Arguments nandP [b1 b2]. +Arguments norP [b1 b2]. +Arguments implyP [b1 b2]. +Prenex Implicits idP idPn negP negPn negPf. +Prenex Implicits andP and3P and4P and5P orP or3P or4P nandP norP implyP. + +(* Shorter, more systematic names for the boolean connectives laws. *) + +Lemma andTb : left_id true andb. Proof. by []. Qed. +Lemma andFb : left_zero false andb. Proof. by []. Qed. +Lemma andbT : right_id true andb. Proof. by case. Qed. +Lemma andbF : right_zero false andb. Proof. by case. Qed. +Lemma andbb : idempotent andb. Proof. by case. Qed. +Lemma andbC : commutative andb. Proof. by do 2!case. Qed. +Lemma andbA : associative andb. Proof. by do 3!case. Qed. +Lemma andbCA : left_commutative andb. Proof. by do 3!case. Qed. +Lemma andbAC : right_commutative andb. Proof. by do 3!case. Qed. +Lemma andbACA : interchange andb andb. Proof. by do 4!case. Qed. + +Lemma orTb : forall b, true || b. Proof. by []. Qed. +Lemma orFb : left_id false orb. Proof. by []. Qed. +Lemma orbT : forall b, b || true. Proof. by case. Qed. +Lemma orbF : right_id false orb. Proof. by case. Qed. +Lemma orbb : idempotent orb. Proof. by case. Qed. +Lemma orbC : commutative orb. Proof. by do 2!case. Qed. +Lemma orbA : associative orb. Proof. by do 3!case. Qed. +Lemma orbCA : left_commutative orb. Proof. by do 3!case. Qed. +Lemma orbAC : right_commutative orb. Proof. by do 3!case. Qed. +Lemma orbACA : interchange orb orb. Proof. by do 4!case. Qed. + +Lemma andbN b : b && ~~ b = false. Proof. by case: b. Qed. +Lemma andNb b : ~~ b && b = false. Proof. by case: b. Qed. +Lemma orbN b : b || ~~ b = true. Proof. by case: b. Qed. +Lemma orNb b : ~~ b || b = true. Proof. by case: b. Qed. + +Lemma andb_orl : left_distributive andb orb. Proof. by do 3!case. Qed. +Lemma andb_orr : right_distributive andb orb. Proof. by do 3!case. Qed. +Lemma orb_andl : left_distributive orb andb. Proof. by do 3!case. Qed. +Lemma orb_andr : right_distributive orb andb. Proof. by do 3!case. Qed. + +Lemma andb_idl (a b : bool) : (b -> a) -> a && b = b. +Proof. by case: a; case: b => // ->. Qed. +Lemma andb_idr (a b : bool) : (a -> b) -> a && b = a. +Proof. by case: a; case: b => // ->. Qed. +Lemma andb_id2l (a b c : bool) : (a -> b = c) -> a && b = a && c. +Proof. by case: a; case: b; case: c => // ->. Qed. +Lemma andb_id2r (a b c : bool) : (b -> a = c) -> a && b = c && b. +Proof. by case: a; case: b; case: c => // ->. Qed. + +Lemma orb_idl (a b : bool) : (a -> b) -> a || b = b. +Proof. by case: a; case: b => // ->. Qed. +Lemma orb_idr (a b : bool) : (b -> a) -> a || b = a. +Proof. by case: a; case: b => // ->. Qed. +Lemma orb_id2l (a b c : bool) : (~~ a -> b = c) -> a || b = a || c. +Proof. by case: a; case: b; case: c => // ->. Qed. +Lemma orb_id2r (a b c : bool) : (~~ b -> a = c) -> a || b = c || b. +Proof. by case: a; case: b; case: c => // ->. Qed. + +Lemma negb_and (a b : bool) : ~~ (a && b) = ~~ a || ~~ b. +Proof. by case: a; case: b. Qed. + +Lemma negb_or (a b : bool) : ~~ (a || b) = ~~ a && ~~ b. +Proof. by case: a; case: b. Qed. + +(* Pseudo-cancellation -- i.e, absorbtion *) + +Lemma andbK a b : a && b || a = a. Proof. by case: a; case: b. Qed. +Lemma andKb a b : a || b && a = a. Proof. by case: a; case: b. Qed. +Lemma orbK a b : (a || b) && a = a. Proof. by case: a; case: b. Qed. +Lemma orKb a b : a && (b || a) = a. Proof. by case: a; case: b. Qed. + +(* Imply *) + +Lemma implybT b : b ==> true. Proof. by case: b. Qed. +Lemma implybF b : (b ==> false) = ~~ b. Proof. by case: b. Qed. +Lemma implyFb b : false ==> b. Proof. by []. Qed. +Lemma implyTb b : (true ==> b) = b. Proof. by []. Qed. +Lemma implybb b : b ==> b. Proof. by case: b. Qed. + +Lemma negb_imply a b : ~~ (a ==> b) = a && ~~ b. +Proof. by case: a; case: b. Qed. + +Lemma implybE a b : (a ==> b) = ~~ a || b. +Proof. by case: a; case: b. Qed. + +Lemma implyNb a b : (~~ a ==> b) = a || b. +Proof. by case: a; case: b. Qed. + +Lemma implybN a b : (a ==> ~~ b) = (b ==> ~~ a). +Proof. by case: a; case: b. Qed. + +Lemma implybNN a b : (~~ a ==> ~~ b) = b ==> a. +Proof. by case: a; case: b. Qed. + +Lemma implyb_idl (a b : bool) : (~~ a -> b) -> (a ==> b) = b. +Proof. by case: a; case: b => // ->. Qed. +Lemma implyb_idr (a b : bool) : (b -> ~~ a) -> (a ==> b) = ~~ a. +Proof. by case: a; case: b => // ->. Qed. +Lemma implyb_id2l (a b c : bool) : (a -> b = c) -> (a ==> b) = (a ==> c). +Proof. by case: a; case: b; case: c => // ->. Qed. + +(* Addition (xor) *) + +Lemma addFb : left_id false addb. Proof. by []. Qed. +Lemma addbF : right_id false addb. Proof. by case. Qed. +Lemma addbb : self_inverse false addb. Proof. by case. Qed. +Lemma addbC : commutative addb. Proof. by do 2!case. Qed. +Lemma addbA : associative addb. Proof. by do 3!case. Qed. +Lemma addbCA : left_commutative addb. Proof. by do 3!case. Qed. +Lemma addbAC : right_commutative addb. Proof. by do 3!case. Qed. +Lemma addbACA : interchange addb addb. Proof. by do 4!case. Qed. +Lemma andb_addl : left_distributive andb addb. Proof. by do 3!case. Qed. +Lemma andb_addr : right_distributive andb addb. Proof. by do 3!case. Qed. +Lemma addKb : left_loop id addb. Proof. by do 2!case. Qed. +Lemma addbK : right_loop id addb. Proof. by do 2!case. Qed. +Lemma addIb : left_injective addb. Proof. by do 3!case. Qed. +Lemma addbI : right_injective addb. Proof. by do 3!case. Qed. + +Lemma addTb b : true (+) b = ~~ b. Proof. by []. Qed. +Lemma addbT b : b (+) true = ~~ b. Proof. by case: b. Qed. + +Lemma addbN a b : a (+) ~~ b = ~~ (a (+) b). +Proof. by case: a; case: b. Qed. +Lemma addNb a b : ~~ a (+) b = ~~ (a (+) b). +Proof. by case: a; case: b. Qed. + +Lemma addbP a b : reflect (~~ a = b) (a (+) b). +Proof. by case: a; case: b; constructor. Qed. +Arguments addbP [a b]. + +(* Resolution tactic for blindly weeding out common terms from boolean *) +(* equalities. When faced with a goal of the form (andb/orb/addb b1 b2) = b3 *) +(* they will try to locate b1 in b3 and remove it. This can fail! *) + +Ltac bool_congr := + match goal with + | |- (?X1 && ?X2 = ?X3) => first + [ symmetry; rewrite -1?(andbC X1) -?(andbCA X1); congr 1 (andb X1); symmetry + | case: (X1); [ rewrite ?andTb ?andbT // | by rewrite ?andbF /= ] ] + | |- (?X1 || ?X2 = ?X3) => first + [ symmetry; rewrite -1?(orbC X1) -?(orbCA X1); congr 1 (orb X1); symmetry + | case: (X1); [ by rewrite ?orbT //= | rewrite ?orFb ?orbF ] ] + | |- (?X1 (+) ?X2 = ?X3) => + symmetry; rewrite -1?(addbC X1) -?(addbCA X1); congr 1 (addb X1); symmetry + | |- (~~ ?X1 = ?X2) => congr 1 negb + end. + +(******************************************************************************) +(* Predicates, i.e., packaged functions to bool. *) +(* - pred T, the basic type for predicates over a type T, is simply an alias *) +(* for T -> bool. *) +(* We actually distinguish two kinds of predicates, which we call applicative *) +(* and collective, based on the syntax used to test them at some x in T: *) +(* - For an applicative predicate P, one uses prefix syntax: *) +(* P x *) +(* Also, most operations on applicative predicates use prefix syntax as *) +(* well (e.g., predI P Q). *) +(* - For a collective predicate A, one uses infix syntax: *) +(* x \in A *) +(* and all operations on collective predicates use infix syntax as well *) +(* (e.g., [predI A & B]). *) +(* There are only two kinds of applicative predicates: *) +(* - pred T, the alias for T -> bool mentioned above *) +(* - simpl_pred T, an alias for simpl_fun T bool with a coercion to pred T *) +(* that auto-simplifies on application (see ssrfun). *) +(* On the other hand, the set of collective predicate types is open-ended via *) +(* - predType T, a Structure that can be used to put Canonical collective *) +(* predicate interpretation on other types, such as lists, tuples, *) +(* finite sets, etc. *) +(* Indeed, we define such interpretations for applicative predicate types, *) +(* which can therefore also be used with the infix syntax, e.g., *) +(* x \in predI P Q *) +(* Moreover these infix forms are convertible to their prefix counterpart *) +(* (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse *) +(* is not true, however; collective predicate types cannot, in general, be *) +(* general, be used applicatively, because of the "uniform inheritance" *) +(* restriction on implicit coercions. *) +(* However, we do define an explicit generic coercion *) +(* - mem : forall (pT : predType), pT -> mem_pred T *) +(* where mem_pred T is a variant of simpl_pred T that preserves the infix *) +(* syntax, i.e., mem A x auto-simplifies to x \in A. *) +(* Indeed, the infix "collective" operators are notation for a prefix *) +(* operator with arguments of type mem_pred T or pred T, applied to coerced *) +(* collective predicates, e.g., *) +(* Notation "x \in A" := (in_mem x (mem A)). *) +(* This prevents the variability in the predicate type from interfering with *) +(* the application of generic lemmas. Moreover this also makes it much easier *) +(* to define generic lemmas, because the simplest type -- pred T -- can be *) +(* used as the type of generic collective predicates, provided one takes care *) +(* not to use it applicatively; this avoids the burden of having to declare a *) +(* different predicate type for each predicate parameter of each section or *) +(* lemma. *) +(* This trick is made possible by the fact that the constructor of the *) +(* mem_pred T type aligns the unification process, forcing a generic *) +(* "collective" predicate A : pred T to unify with the actual collective B, *) +(* which mem has coerced to pred T via an internal, hidden implicit coercion, *) +(* supplied by the predType structure for B. Users should take care not to *) +(* inadvertently "strip" (mem B) down to the coerced B, since this will *) +(* expose the internal coercion: Coq will display a term B x that cannot be *) +(* typed as such. The topredE lemma can be used to restore the x \in B *) +(* syntax in this case. While -topredE can conversely be used to change *) +(* x \in P into P x, it is safer to use the inE and memE lemmas instead, as *) +(* they do not run the risk of exposing internal coercions. As a consequence *) +(* it is better to explicitly cast a generic applicative pred T to simpl_pred *) +(* using the SimplPred constructor, when it is used as a collective predicate *) +(* (see, e.g., Lemma eq_big in bigop). *) +(* We also sometimes "instantiate" the predType structure by defining a *) +(* coercion to the sort of the predPredType structure. This works better for *) +(* types such as {set T} that have subtypes that coerce to them, since the *) +(* same coercion will be inserted by the application of mem. It also lets us *) +(* turn any Type aT : predArgType into the total predicate over that type, *) +(* i.e., fun _: aT => true. This allows us to write, e.g., #|'I_n| for the *) +(* cardinal of the (finite) type of integers less than n. *) +(* Collective predicates have a specific extensional equality, *) +(* - A =i B, *) +(* while applicative predicates use the extensional equality of functions, *) +(* - P =1 Q *) +(* The two forms are convertible, however. *) +(* We lift boolean operations to predicates, defining: *) +(* - predU (union), predI (intersection), predC (complement), *) +(* predD (difference), and preim (preimage, i.e., composition) *) +(* For each operation we define three forms, typically: *) +(* - predU : pred T -> pred T -> simpl_pred T *) +(* - [predU A & B], a Notation for predU (mem A) (mem B) *) +(* - xpredU, a Notation for the lambda-expression inside predU, *) +(* which is mostly useful as an argument of =1, since it exposes the head *) +(* head constant of the expression to the ssreflect matching algorithm. *) +(* The syntax for the preimage of a collective predicate A is *) +(* - [preim f of A] *) +(* Finally, the generic syntax for defining a simpl_pred T is *) +(* - [pred x : T | P(x)], [pred x | P(x)], [pred x in A | P(x)], etc. *) +(* We also support boolean relations, but only the applicative form, with *) +(* types *) +(* - rel T, an alias for T -> pred T *) +(* - simpl_rel T, an auto-simplifying version, and syntax *) +(* [rel x y | P(x,y)], [rel x y in A & B | P(x,y)], etc. *) +(* The notation [rel of fA] can be used to coerce a function returning a *) +(* collective predicate to one returning pred T. *) +(* Finally, note that there is specific support for ambivalent predicates *) +(* that can work in either style, as per this file's head descriptor. *) +(******************************************************************************) + +Definition pred T := T -> bool. + +Identity Coercion fun_of_pred : pred >-> Funclass. + +Definition rel T := T -> pred T. + +Identity Coercion fun_of_rel : rel >-> Funclass. + +Notation xpred0 := (fun _ => false). +Notation xpredT := (fun _ => true). +Notation xpredI := (fun (p1 p2 : pred _) x => p1 x && p2 x). +Notation xpredU := (fun (p1 p2 : pred _) x => p1 x || p2 x). +Notation xpredC := (fun (p : pred _) x => ~~ p x). +Notation xpredD := (fun (p1 p2 : pred _) x => ~~ p2 x && p1 x). +Notation xpreim := (fun f (p : pred _) x => p (f x)). +Notation xrelU := (fun (r1 r2 : rel _) x y => r1 x y || r2 x y). + +Section Predicates. + +Variables T : Type. + +Definition subpred (p1 p2 : pred T) := forall x, p1 x -> p2 x. + +Definition subrel (r1 r2 : rel T) := forall x y, r1 x y -> r2 x y. + +Definition simpl_pred := simpl_fun T bool. +Definition applicative_pred := pred T. +Definition collective_pred := pred T. + +Definition SimplPred (p : pred T) : simpl_pred := SimplFun p. + +Coercion pred_of_simpl (p : simpl_pred) : pred T := fun_of_simpl p. +Coercion applicative_pred_of_simpl (p : simpl_pred) : applicative_pred := + fun_of_simpl p. +Coercion collective_pred_of_simpl (p : simpl_pred) : collective_pred := + fun x => (let: SimplFun f := p in fun _ => f x) x. +(* Note: applicative_of_simpl is convertible to pred_of_simpl, while *) +(* collective_of_simpl is not. *) + +Definition pred0 := SimplPred xpred0. +Definition predT := SimplPred xpredT. +Definition predI p1 p2 := SimplPred (xpredI p1 p2). +Definition predU p1 p2 := SimplPred (xpredU p1 p2). +Definition predC p := SimplPred (xpredC p). +Definition predD p1 p2 := SimplPred (xpredD p1 p2). +Definition preim rT f (d : pred rT) := SimplPred (xpreim f d). + +Definition simpl_rel := simpl_fun T (pred T). + +Definition SimplRel (r : rel T) : simpl_rel := [fun x => r x]. + +Coercion rel_of_simpl_rel (r : simpl_rel) : rel T := fun x y => r x y. + +Definition relU r1 r2 := SimplRel (xrelU r1 r2). + +Lemma subrelUl r1 r2 : subrel r1 (relU r1 r2). +Proof. by move=> *; apply/orP; left. Qed. + +Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). +Proof. by move=> *; apply/orP; right. Qed. + +CoInductive mem_pred := Mem of pred T. + +Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). + +Structure predType := PredType { + pred_sort :> Type; + topred : pred_sort -> pred T; + _ : {mem | isMem topred mem} +}. + +Definition mkPredType pT toP := PredType (exist (@isMem pT toP) _ (erefl _)). + +Canonical predPredType := Eval hnf in @mkPredType (pred T) id. +Canonical simplPredType := Eval hnf in mkPredType pred_of_simpl. +Canonical boolfunPredType := Eval hnf in @mkPredType (T -> bool) id. + +Coercion pred_of_mem mp : pred_sort predPredType := let: Mem p := mp in [eta p]. +Canonical memPredType := Eval hnf in mkPredType pred_of_mem. + +Definition clone_pred U := + fun pT & pred_sort pT -> U => + fun a mP (pT' := @PredType U a mP) & phant_id pT' pT => pT'. + +End Predicates. + +Arguments pred0 [T]. +Arguments predT [T]. +Prenex Implicits pred0 predT predI predU predC predD preim relU. + +Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) + (at level 0, format "[ 'pred' : T | E ]") : fun_scope. +Notation "[ 'pred' x | E ]" := (SimplPred (fun x => E%B)) + (at level 0, x ident, format "[ 'pred' x | E ]") : fun_scope. +Notation "[ 'pred' x | E1 & E2 ]" := [pred x | E1 && E2 ] + (at level 0, x ident, format "[ 'pred' x | E1 & E2 ]") : fun_scope. +Notation "[ 'pred' x : T | E ]" := (SimplPred (fun x : T => E%B)) + (at level 0, x ident, only parsing) : fun_scope. +Notation "[ 'pred' x : T | E1 & E2 ]" := [pred x : T | E1 && E2 ] + (at level 0, x ident, only parsing) : fun_scope. +Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) + (at level 0, x ident, y ident, format "[ 'rel' x y | E ]") : fun_scope. +Notation "[ 'rel' x y : T | E ]" := (SimplRel (fun x y : T => E%B)) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ _ id) + (at level 0, format "[ 'predType' 'of' T ]") : form_scope. + +(* This redundant coercion lets us "inherit" the simpl_predType canonical *) +(* instance by declaring a coercion to simpl_pred. This hack is the only way *) +(* to put a predType structure on a predArgType. We use simpl_pred rather *) +(* than pred to ensure that /= removes the identity coercion. Note that the *) +(* coercion will never be used directly for simpl_pred, since the canonical *) +(* instance should always be resolved. *) + +Notation pred_class := (pred_sort (predPredType _)). +Coercion sort_of_simpl_pred T (p : simpl_pred T) : pred_class := p : pred T. + +(* This lets us use some types as a synonym for their universal predicate. *) +(* Unfortunately, this won't work for existing types like bool, unless we *) +(* redefine bool, true, false and all bool ops. *) +Definition predArgType := Type. +Bind Scope type_scope with predArgType. +Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. +Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. + +Notation "{ : T }" := (T%type : predArgType) + (at level 0, format "{ : T }") : type_scope. + +(* These must be defined outside a Section because "cooking" kills the *) +(* nosimpl tag. *) + +Definition mem T (pT : predType T) : pT -> mem_pred T := + nosimpl (let: @PredType _ _ _ (exist _ mem _) := pT return pT -> _ in mem). +Definition in_mem T x mp := nosimpl pred_of_mem T mp x. + +Prenex Implicits mem. + +Coercion pred_of_mem_pred T mp := [pred x : T | in_mem x mp]. + +Definition eq_mem T p1 p2 := forall x : T, in_mem x p1 = in_mem x p2. +Definition sub_mem T p1 p2 := forall x : T, in_mem x p1 -> in_mem x p2. + +Typeclasses Opaque eq_mem. + +Lemma sub_refl T (p : mem_pred T) : sub_mem p p. Proof. by []. Qed. +Arguments sub_refl {T p}. + +Notation "x \in A" := (in_mem x (mem A)) : bool_scope. +Notation "x \in A" := (in_mem x (mem A)) : bool_scope. +Notation "x \notin A" := (~~ (x \in A)) : bool_scope. +Notation "A =i B" := (eq_mem (mem A) (mem B)) : type_scope. +Notation "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) + (at level 0, A, B at level 69, + format "{ '[hv' 'subset' A '/ ' <= B ']' }") : type_scope. +Notation "[ 'mem' A ]" := (pred_of_simpl (pred_of_mem_pred (mem A))) + (at level 0, only parsing) : fun_scope. +Notation "[ 'rel' 'of' fA ]" := (fun x => [mem (fA x)]) + (at level 0, format "[ 'rel' 'of' fA ]") : fun_scope. +Notation "[ 'predI' A & B ]" := (predI [mem A] [mem B]) + (at level 0, format "[ 'predI' A & B ]") : fun_scope. +Notation "[ 'predU' A & B ]" := (predU [mem A] [mem B]) + (at level 0, format "[ 'predU' A & B ]") : fun_scope. +Notation "[ 'predD' A & B ]" := (predD [mem A] [mem B]) + (at level 0, format "[ 'predD' A & B ]") : fun_scope. +Notation "[ 'predC' A ]" := (predC [mem A]) + (at level 0, format "[ 'predC' A ]") : fun_scope. +Notation "[ 'preim' f 'of' A ]" := (preim f [mem A]) + (at level 0, format "[ 'preim' f 'of' A ]") : fun_scope. + +Notation "[ 'pred' x 'in' A ]" := [pred x | x \in A] + (at level 0, x ident, format "[ 'pred' x 'in' A ]") : fun_scope. +Notation "[ 'pred' x 'in' A | E ]" := [pred x | x \in A & E] + (at level 0, x ident, format "[ 'pred' x 'in' A | E ]") : fun_scope. +Notation "[ 'pred' x 'in' A | E1 & E2 ]" := [pred x | x \in A & E1 && E2 ] + (at level 0, x ident, + format "[ 'pred' x 'in' A | E1 & E2 ]") : fun_scope. +Notation "[ 'rel' x y 'in' A & B | E ]" := + [rel x y | (x \in A) && (y \in B) && E] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A & B | E ]") : fun_scope. +Notation "[ 'rel' x y 'in' A & B ]" := [rel x y | (x \in A) && (y \in B)] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A & B ]") : fun_scope. +Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A | E ]") : fun_scope. +Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A ]") : fun_scope. + +Section simpl_mem. + +Variables (T : Type) (pT : predType T). +Implicit Types (x : T) (p : pred T) (sp : simpl_pred T) (pp : pT). + +(* Bespoke structures that provide fine-grained control over matching the *) +(* various forms of the \in predicate; note in particular the different forms *) +(* of hoisting that are used. We had to work around several bugs in the *) +(* implementation of unification, notably improper expansion of telescope *) +(* projections and overwriting of a variable assignment by a later *) +(* unification (probably due to conversion cache cross-talk). *) +Structure manifest_applicative_pred p := ManifestApplicativePred { + manifest_applicative_pred_value :> pred T; + _ : manifest_applicative_pred_value = p +}. +Definition ApplicativePred p := ManifestApplicativePred (erefl p). +Canonical applicative_pred_applicative sp := + ApplicativePred (applicative_pred_of_simpl sp). + +Structure manifest_simpl_pred p := ManifestSimplPred { + manifest_simpl_pred_value :> simpl_pred T; + _ : manifest_simpl_pred_value = SimplPred p +}. +Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). + +Structure manifest_mem_pred p := ManifestMemPred { + manifest_mem_pred_value :> mem_pred T; + _ : manifest_mem_pred_value= Mem [eta p] +}. +Canonical expose_mem_pred p := @ManifestMemPred p _ (erefl _). + +Structure applicative_mem_pred p := + ApplicativeMemPred {applicative_mem_pred_value :> manifest_mem_pred p}. +Canonical check_applicative_mem_pred p (ap : manifest_applicative_pred p) mp := + @ApplicativeMemPred ap mp. + +Lemma mem_topred (pp : pT) : mem (topred pp) = mem pp. +Proof. by rewrite /mem; case: pT pp => T1 app1 [mem1 /= ->]. Qed. + +Lemma topredE x (pp : pT) : topred pp x = (x \in pp). +Proof. by rewrite -mem_topred. Qed. + +Lemma app_predE x p (ap : manifest_applicative_pred p) : ap x = (x \in p). +Proof. by case: ap => _ /= ->. Qed. + +Lemma in_applicative x p (amp : applicative_mem_pred p) : in_mem x amp = p x. +Proof. by case: amp => [[_ /= ->]]. Qed. + +Lemma in_collective x p (msp : manifest_simpl_pred p) : + (x \in collective_pred_of_simpl msp) = p x. +Proof. by case: msp => _ /= ->. Qed. + +Lemma in_simpl x p (msp : manifest_simpl_pred p) : + in_mem x (Mem [eta fun_of_simpl (msp : simpl_pred T)]) = p x. +Proof. by case: msp => _ /= ->. Qed. + +(* Because of the explicit eta expansion in the left-hand side, this lemma *) +(* should only be used in a right-to-left direction. The 8.3 hack allowing *) +(* partial right-to-left use does not work with the improved expansion *) +(* heuristics in 8.4. *) +Lemma unfold_in x p : (x \in ([eta p] : pred T)) = p x. +Proof. by []. Qed. + +Lemma simpl_predE p : SimplPred p =1 p. +Proof. by []. Qed. + +Definition inE := (in_applicative, in_simpl, simpl_predE). (* to be extended *) + +Lemma mem_simpl sp : mem sp = sp :> pred T. +Proof. by []. Qed. + +Definition memE := mem_simpl. (* could be extended *) + +Lemma mem_mem (pp : pT) : (mem (mem pp) = mem pp) * (mem [mem pp] = mem pp). +Proof. by rewrite -mem_topred. Qed. + +End simpl_mem. + +(* Qualifiers and keyed predicates. *) + +CoInductive qualifier (q : nat) T := Qualifier of predPredType T. + +Coercion has_quality n T (q : qualifier n T) : pred_class := + fun x => let: Qualifier _ p := q in p x. +Arguments has_quality n [T]. + +Lemma qualifE n T p x : (x \in @Qualifier n T p) = p x. Proof. by []. Qed. + +Notation "x \is A" := (x \in has_quality 0 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \is A ']'") : bool_scope. +Notation "x \is 'a' A" := (x \in has_quality 1 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \is 'a' A ']'") : bool_scope. +Notation "x \is 'an' A" := (x \in has_quality 2 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \is 'an' A ']'") : bool_scope. +Notation "x \isn't A" := (x \notin has_quality 0 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \isn't A ']'") : bool_scope. +Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'a' A ']'") : bool_scope. +Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'an' A ']'") : bool_scope. +Notation "[ 'qualify' x | P ]" := (Qualifier 0 (fun x => P%B)) + (at level 0, x at level 99, + format "'[hv' [ 'qualify' x | '/ ' P ] ']'") : form_scope. +Notation "[ 'qualify' x : T | P ]" := (Qualifier 0 (fun x : T => P%B)) + (at level 0, x at level 99, only parsing) : form_scope. +Notation "[ 'qualify' 'a' x | P ]" := (Qualifier 1 (fun x => P%B)) + (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'a' x | '/ ' P ] ']'") : form_scope. +Notation "[ 'qualify' 'a' x : T | P ]" := (Qualifier 1 (fun x : T => P%B)) + (at level 0, x at level 99, only parsing) : form_scope. +Notation "[ 'qualify' 'an' x | P ]" := (Qualifier 2 (fun x => P%B)) + (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'an' x | '/ ' P ] ']'") : form_scope. +Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) + (at level 0, x at level 99, only parsing) : form_scope. + +(* Keyed predicates: support for property-bearing predicate interfaces. *) + +Section KeyPred. + +Variable T : Type. +CoInductive pred_key (p : predPredType T) := DefaultPredKey. + +Variable p : predPredType T. +Structure keyed_pred (k : pred_key p) := + PackKeyedPred {unkey_pred :> pred_class; _ : unkey_pred =i p}. + +Variable k : pred_key p. +Definition KeyedPred := @PackKeyedPred k p (frefl _). + +Variable k_p : keyed_pred k. +Lemma keyed_predE : k_p =i p. Proof. by case: k_p. Qed. + +(* Instances that strip the mem cast; the first one has "pred_of_mem" as its *) +(* projection head value, while the second has "pred_of_simpl". The latter *) +(* has the side benefit of preempting accidental misdeclarations. *) +(* Note: pred_of_mem is the registered mem >-> pred_class coercion, while *) +(* simpl_of_mem; pred_of_simpl is the mem >-> pred >=> Funclass coercion. We *) +(* must write down the coercions explicitly as the Canonical head constant *) +(* computation does not strip casts !! *) +Canonical keyed_mem := + @PackKeyedPred k (pred_of_mem (mem k_p)) keyed_predE. +Canonical keyed_mem_simpl := + @PackKeyedPred k (pred_of_simpl (mem k_p)) keyed_predE. + +End KeyPred. + +Notation "x \i 'n' S" := (x \in @unkey_pred _ S _ _) + (at level 70, format "'[hv' x '/ ' \i 'n' S ']'") : bool_scope. + +Section KeyedQualifier. + +Variables (T : Type) (n : nat) (q : qualifier n T). + +Structure keyed_qualifier (k : pred_key q) := + PackKeyedQualifier {unkey_qualifier; _ : unkey_qualifier = q}. +Definition KeyedQualifier k := PackKeyedQualifier k (erefl q). +Variables (k : pred_key q) (k_q : keyed_qualifier k). +Fact keyed_qualifier_suproof : unkey_qualifier k_q =i q. +Proof. by case: k_q => /= _ ->. Qed. +Canonical keyed_qualifier_keyed := PackKeyedPred k keyed_qualifier_suproof. + +End KeyedQualifier. + +Notation "x \i 's' A" := (x \i n has_quality 0 A) + (at level 70, format "'[hv' x '/ ' \i 's' A ']'") : bool_scope. +Notation "x \i 's' 'a' A" := (x \i n has_quality 1 A) + (at level 70, format "'[hv' x '/ ' \i 's' 'a' A ']'") : bool_scope. +Notation "x \i 's' 'an' A" := (x \i n has_quality 2 A) + (at level 70, format "'[hv' x '/ ' \i 's' 'an' A ']'") : bool_scope. + +Module DefaultKeying. + +Canonical default_keyed_pred T p := KeyedPred (@DefaultPredKey T p). +Canonical default_keyed_qualifier T n (q : qualifier n T) := + KeyedQualifier (DefaultPredKey q). + +End DefaultKeying. + +(* Skolemizing with conditions. *) + +Lemma all_tag_cond_dep I T (C : pred I) U : + (forall x, T x) -> (forall x, C x -> {y : T x & U x y}) -> + {f : forall x, T x & forall x, C x -> U x (f x)}. +Proof. +move=> f0 fP; apply: all_tag (fun x y => C x -> U x y) _ => x. +by case Cx: (C x); [case/fP: Cx => y; exists y | exists (f0 x)]. +Qed. + +Lemma all_tag_cond I T (C : pred I) U : + T -> (forall x, C x -> {y : T & U x y}) -> + {f : I -> T & forall x, C x -> U x (f x)}. +Proof. by move=> y0; apply: all_tag_cond_dep. Qed. + +Lemma all_sig_cond_dep I T (C : pred I) P : + (forall x, T x) -> (forall x, C x -> {y : T x | P x y}) -> + {f : forall x, T x | forall x, C x -> P x (f x)}. +Proof. by move=> f0 /(all_tag_cond_dep f0)[f]; exists f. Qed. + +Lemma all_sig_cond I T (C : pred I) P : + T -> (forall x, C x -> {y : T | P x y}) -> + {f : I -> T | forall x, C x -> P x (f x)}. +Proof. by move=> y0; apply: all_sig_cond_dep. Qed. + +Section RelationProperties. + +(* Caveat: reflexive should not be used to state lemmas, as auto and trivial *) +(* will not expand the constant. *) + +Variable T : Type. + +Variable R : rel T. + +Definition total := forall x y, R x y || R y x. +Definition transitive := forall y x z, R x y -> R y z -> R x z. + +Definition symmetric := forall x y, R x y = R y x. +Definition antisymmetric := forall x y, R x y && R y x -> x = y. +Definition pre_symmetric := forall x y, R x y -> R y x. + +Lemma symmetric_from_pre : pre_symmetric -> symmetric. +Proof. by move=> symR x y; apply/idP/idP; apply: symR. Qed. + +Definition reflexive := forall x, R x x. +Definition irreflexive := forall x, R x x = false. + +Definition left_transitive := forall x y, R x y -> R x =1 R y. +Definition right_transitive := forall x y, R x y -> R^~ x =1 R^~ y. + +Section PER. + +Hypotheses (symR : symmetric) (trR : transitive). + +Lemma sym_left_transitive : left_transitive. +Proof. by move=> x y Rxy z; apply/idP/idP; apply: trR; rewrite // symR. Qed. + +Lemma sym_right_transitive : right_transitive. +Proof. by move=> x y /sym_left_transitive Rxy z; rewrite !(symR z) Rxy. Qed. + +End PER. + +(* We define the equivalence property with prenex quantification so that it *) +(* can be localized using the {in ..., ..} form defined below. *) + +Definition equivalence_rel := forall x y z, R z z * (R x y -> R x z = R y z). + +Lemma equivalence_relP : equivalence_rel <-> reflexive /\ left_transitive. +Proof. +split=> [eqiR | [Rxx trR] x y z]; last by split=> [|/trR->]. +by split=> [x | x y Rxy z]; [rewrite (eqiR x x x) | rewrite (eqiR x y z)]. +Qed. + +End RelationProperties. + +Lemma rev_trans T (R : rel T) : transitive R -> transitive (fun x y => R y x). +Proof. by move=> trR x y z Ryx Rzy; apply: trR Rzy Ryx. Qed. + +(* Property localization *) + +Local Notation "{ 'all1' P }" := (forall x, P x : Prop) (at level 0). +Local Notation "{ 'all2' P }" := (forall x y, P x y : Prop) (at level 0). +Local Notation "{ 'all3' P }" := (forall x y z, P x y z: Prop) (at level 0). +Local Notation ph := (phantom _). + +Section LocalProperties. + +Variables T1 T2 T3 : Type. + +Variables (d1 : mem_pred T1) (d2 : mem_pred T2) (d3 : mem_pred T3). +Local Notation ph := (phantom Prop). + +Definition prop_for (x : T1) P & ph {all1 P} := P x. + +Lemma forE x P phP : @prop_for x P phP = P x. Proof. by []. Qed. + +Definition prop_in1 P & ph {all1 P} := + forall x, in_mem x d1 -> P x. + +Definition prop_in11 P & ph {all2 P} := + forall x y, in_mem x d1 -> in_mem y d2 -> P x y. + +Definition prop_in2 P & ph {all2 P} := + forall x y, in_mem x d1 -> in_mem y d1 -> P x y. + +Definition prop_in111 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d2 -> in_mem z d3 -> P x y z. + +Definition prop_in12 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d2 -> in_mem z d2 -> P x y z. + +Definition prop_in21 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d1 -> in_mem z d2 -> P x y z. + +Definition prop_in3 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d1 -> in_mem z d1 -> P x y z. + +Variable f : T1 -> T2. + +Definition prop_on1 Pf P & phantom T3 (Pf f) & ph {all1 P} := + forall x, in_mem (f x) d2 -> P x. + +Definition prop_on2 Pf P & phantom T3 (Pf f) & ph {all2 P} := + forall x y, in_mem (f x) d2 -> in_mem (f y) d2 -> P x y. + +End LocalProperties. + +Definition inPhantom := Phantom Prop. +Definition onPhantom T P (x : T) := Phantom Prop (P x). + +Definition bijective_in aT rT (d : mem_pred aT) (f : aT -> rT) := + exists2 g, prop_in1 d (inPhantom (cancel f g)) + & prop_on1 d (Phantom _ (cancel g)) (onPhantom (cancel g) f). + +Definition bijective_on aT rT (cd : mem_pred rT) (f : aT -> rT) := + exists2 g, prop_on1 cd (Phantom _ (cancel f)) (onPhantom (cancel f) g) + & prop_in1 cd (inPhantom (cancel g f)). + +Notation "{ 'for' x , P }" := + (prop_for x (inPhantom P)) + (at level 0, format "{ 'for' x , P }") : type_scope. + +Notation "{ 'in' d , P }" := + (prop_in1 (mem d) (inPhantom P)) + (at level 0, format "{ 'in' d , P }") : type_scope. + +Notation "{ 'in' d1 & d2 , P }" := + (prop_in11 (mem d1) (mem d2) (inPhantom P)) + (at level 0, format "{ 'in' d1 & d2 , P }") : type_scope. + +Notation "{ 'in' d & , P }" := + (prop_in2 (mem d) (inPhantom P)) + (at level 0, format "{ 'in' d & , P }") : type_scope. + +Notation "{ 'in' d1 & d2 & d3 , P }" := + (prop_in111 (mem d1) (mem d2) (mem d3) (inPhantom P)) + (at level 0, format "{ 'in' d1 & d2 & d3 , P }") : type_scope. + +Notation "{ 'in' d1 & & d3 , P }" := + (prop_in21 (mem d1) (mem d3) (inPhantom P)) + (at level 0, format "{ 'in' d1 & & d3 , P }") : type_scope. + +Notation "{ 'in' d1 & d2 & , P }" := + (prop_in12 (mem d1) (mem d2) (inPhantom P)) + (at level 0, format "{ 'in' d1 & d2 & , P }") : type_scope. + +Notation "{ 'in' d & & , P }" := + (prop_in3 (mem d) (inPhantom P)) + (at level 0, format "{ 'in' d & & , P }") : type_scope. + +Notation "{ 'on' cd , P }" := + (prop_on1 (mem cd) (inPhantom P) (inPhantom P)) + (at level 0, format "{ 'on' cd , P }") : type_scope. + +Notation "{ 'on' cd & , P }" := + (prop_on2 (mem cd) (inPhantom P) (inPhantom P)) + (at level 0, format "{ 'on' cd & , P }") : type_scope. + +Local Arguments onPhantom {_%type_scope} _ _. + +Notation "{ 'on' cd , P & g }" := + (prop_on1 (mem cd) (Phantom (_ -> Prop) P) (onPhantom P g)) + (at level 0, format "{ 'on' cd , P & g }") : type_scope. + +Notation "{ 'in' d , 'bijective' f }" := (bijective_in (mem d) f) + (at level 0, f at level 8, + format "{ 'in' d , 'bijective' f }") : type_scope. + +Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) + (at level 0, f at level 8, + format "{ 'on' cd , 'bijective' f }") : type_scope. + +(* Weakening and monotonicity lemmas for localized predicates. *) +(* Note that using these lemmas in backward reasoning will force expansion of *) +(* the predicate definition, as Coq needs to expose the quantifier to apply *) +(* these lemmas. We define a few specialized variants to avoid this for some *) +(* of the ssrfun predicates. *) + +Section LocalGlobal. + +Variables T1 T2 T3 : predArgType. +Variables (D1 : pred T1) (D2 : pred T2) (D3 : pred T3). +Variables (d1 d1' : mem_pred T1) (d2 d2' : mem_pred T2) (d3 d3' : mem_pred T3). +Variables (f f' : T1 -> T2) (g : T2 -> T1) (h : T3). +Variables (P1 : T1 -> Prop) (P2 : T1 -> T2 -> Prop). +Variable P3 : T1 -> T2 -> T3 -> Prop. +Variable Q1 : (T1 -> T2) -> T1 -> Prop. +Variable Q1l : (T1 -> T2) -> T3 -> T1 -> Prop. +Variable Q2 : (T1 -> T2) -> T1 -> T1 -> Prop. + +Hypothesis sub1 : sub_mem d1 d1'. +Hypothesis sub2 : sub_mem d2 d2'. +Hypothesis sub3 : sub_mem d3 d3'. + +Lemma in1W : {all1 P1} -> {in D1, {all1 P1}}. +Proof. by move=> ? ?. Qed. +Lemma in2W : {all2 P2} -> {in D1 & D2, {all2 P2}}. +Proof. by move=> ? ?. Qed. +Lemma in3W : {all3 P3} -> {in D1 & D2 & D3, {all3 P3}}. +Proof. by move=> ? ?. Qed. + +Lemma in1T : {in T1, {all1 P1}} -> {all1 P1}. +Proof. by move=> ? ?; auto. Qed. +Lemma in2T : {in T1 & T2, {all2 P2}} -> {all2 P2}. +Proof. by move=> ? ?; auto. Qed. +Lemma in3T : {in T1 & T2 & T3, {all3 P3}} -> {all3 P3}. +Proof. by move=> ? ?; auto. Qed. + +Lemma sub_in1 (Ph : ph {all1 P1}) : prop_in1 d1' Ph -> prop_in1 d1 Ph. +Proof. by move=> allP x /sub1; apply: allP. Qed. + +Lemma sub_in11 (Ph : ph {all2 P2}) : prop_in11 d1' d2' Ph -> prop_in11 d1 d2 Ph. +Proof. by move=> allP x1 x2 /sub1 d1x1 /sub2; apply: allP. Qed. + +Lemma sub_in111 (Ph : ph {all3 P3}) : + prop_in111 d1' d2' d3' Ph -> prop_in111 d1 d2 d3 Ph. +Proof. by move=> allP x1 x2 x3 /sub1 d1x1 /sub2 d2x2 /sub3; apply: allP. Qed. + +Let allQ1 f'' := {all1 Q1 f''}. +Let allQ1l f'' h' := {all1 Q1l f'' h'}. +Let allQ2 f'' := {all2 Q2 f''}. + +Lemma on1W : allQ1 f -> {on D2, allQ1 f}. Proof. by move=> ? ?. Qed. + +Lemma on1lW : allQ1l f h -> {on D2, allQ1l f & h}. Proof. by move=> ? ?. Qed. + +Lemma on2W : allQ2 f -> {on D2 &, allQ2 f}. Proof. by move=> ? ?. Qed. + +Lemma on1T : {on T2, allQ1 f} -> allQ1 f. Proof. by move=> ? ?; auto. Qed. + +Lemma on1lT : {on T2, allQ1l f & h} -> allQ1l f h. +Proof. by move=> ? ?; auto. Qed. + +Lemma on2T : {on T2 &, allQ2 f} -> allQ2 f. +Proof. by move=> ? ?; auto. Qed. + +Lemma subon1 (Phf : ph (allQ1 f)) (Ph : ph (allQ1 f)) : + prop_on1 d2' Phf Ph -> prop_on1 d2 Phf Ph. +Proof. by move=> allQ x /sub2; apply: allQ. Qed. + +Lemma subon1l (Phf : ph (allQ1l f)) (Ph : ph (allQ1l f h)) : + prop_on1 d2' Phf Ph -> prop_on1 d2 Phf Ph. +Proof. by move=> allQ x /sub2; apply: allQ. Qed. + +Lemma subon2 (Phf : ph (allQ2 f)) (Ph : ph (allQ2 f)) : + prop_on2 d2' Phf Ph -> prop_on2 d2 Phf Ph. +Proof. by move=> allQ x y /sub2=> d2fx /sub2; apply: allQ. Qed. + +Lemma can_in_inj : {in D1, cancel f g} -> {in D1 &, injective f}. +Proof. by move=> fK x y /fK{2}<- /fK{2}<- ->. Qed. + +Lemma canLR_in x y : {in D1, cancel f g} -> y \in D1 -> x = f y -> g x = y. +Proof. by move=> fK D1y ->; rewrite fK. Qed. + +Lemma canRL_in x y : {in D1, cancel f g} -> x \in D1 -> f x = y -> x = g y. +Proof. by move=> fK D1x <-; rewrite fK. Qed. + +Lemma on_can_inj : {on D2, cancel f & g} -> {on D2 &, injective f}. +Proof. by move=> fK x y /fK{2}<- /fK{2}<- ->. Qed. + +Lemma canLR_on x y : {on D2, cancel f & g} -> f y \in D2 -> x = f y -> g x = y. +Proof. by move=> fK D2fy ->; rewrite fK. Qed. + +Lemma canRL_on x y : {on D2, cancel f & g} -> f x \in D2 -> f x = y -> x = g y. +Proof. by move=> fK D2fx <-; rewrite fK. Qed. + +Lemma inW_bij : bijective f -> {in D1, bijective f}. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma onW_bij : bijective f -> {on D2, bijective f}. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma inT_bij : {in T1, bijective f} -> bijective f. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma onT_bij : {on T2, bijective f} -> bijective f. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma sub_in_bij (D1' : pred T1) : + {subset D1 <= D1'} -> {in D1', bijective f} -> {in D1, bijective f}. +Proof. +by move=> subD [g' fK g'K]; exists g' => x; move/subD; [apply: fK | apply: g'K]. +Qed. + +Lemma subon_bij (D2' : pred T2) : + {subset D2 <= D2'} -> {on D2', bijective f} -> {on D2, bijective f}. +Proof. +by move=> subD [g' fK g'K]; exists g' => x; move/subD; [apply: fK | apply: g'K]. +Qed. + +End LocalGlobal. + +Lemma sub_in2 T d d' (P : T -> T -> Prop) : + sub_mem d d' -> forall Ph : ph {all2 P}, prop_in2 d' Ph -> prop_in2 d Ph. +Proof. by move=> /= sub_dd'; apply: sub_in11. Qed. + +Lemma sub_in3 T d d' (P : T -> T -> T -> Prop) : + sub_mem d d' -> forall Ph : ph {all3 P}, prop_in3 d' Ph -> prop_in3 d Ph. +Proof. by move=> /= sub_dd'; apply: sub_in111. Qed. + +Lemma sub_in12 T1 T d1 d1' d d' (P : T1 -> T -> T -> Prop) : + sub_mem d1 d1' -> sub_mem d d' -> + forall Ph : ph {all3 P}, prop_in12 d1' d' Ph -> prop_in12 d1 d Ph. +Proof. by move=> /= sub1 sub; apply: sub_in111. Qed. + +Lemma sub_in21 T T3 d d' d3 d3' (P : T -> T -> T3 -> Prop) : + sub_mem d d' -> sub_mem d3 d3' -> + forall Ph : ph {all3 P}, prop_in21 d' d3' Ph -> prop_in21 d d3 Ph. +Proof. by move=> /= sub sub3; apply: sub_in111. Qed. + +Lemma equivalence_relP_in T (R : rel T) (A : pred T) : + {in A & &, equivalence_rel R} + <-> {in A, reflexive R} /\ {in A &, forall x y, R x y -> {in A, R x =1 R y}}. +Proof. +split=> [eqiR | [Rxx trR] x y z *]; last by split=> [|/trR-> //]; apply: Rxx. +by split=> [x Ax|x y Ax Ay Rxy z Az]; [rewrite (eqiR x x) | rewrite (eqiR x y)]. +Qed. + +Section MonoHomoMorphismTheory. + +Variables (aT rT sT : Type) (f : aT -> rT) (g : rT -> aT). +Variables (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). + +Lemma monoW : {mono f : x / aP x >-> rP x} -> {homo f : x / aP x >-> rP x}. +Proof. by move=> hf x ax; rewrite hf. Qed. + +Lemma mono2W : + {mono f : x y / aR x y >-> rR x y} -> {homo f : x y / aR x y >-> rR x y}. +Proof. by move=> hf x y axy; rewrite hf. Qed. + +Hypothesis fgK : cancel g f. + +Lemma homoRL : + {homo f : x y / aR x y >-> rR x y} -> forall x y, aR (g x) y -> rR x (f y). +Proof. by move=> Hf x y /Hf; rewrite fgK. Qed. + +Lemma homoLR : + {homo f : x y / aR x y >-> rR x y} -> forall x y, aR x (g y) -> rR (f x) y. +Proof. by move=> Hf x y /Hf; rewrite fgK. Qed. + +Lemma homo_mono : + {homo f : x y / aR x y >-> rR x y} -> {homo g : x y / rR x y >-> aR x y} -> + {mono g : x y / rR x y >-> aR x y}. +Proof. +move=> mf mg x y; case: (boolP (rR _ _))=> [/mg //|]. +by apply: contraNF=> /mf; rewrite !fgK. +Qed. + +Lemma monoLR : + {mono f : x y / aR x y >-> rR x y} -> forall x y, rR (f x) y = aR x (g y). +Proof. by move=> mf x y; rewrite -{1}[y]fgK mf. Qed. + +Lemma monoRL : + {mono f : x y / aR x y >-> rR x y} -> forall x y, rR x (f y) = aR (g x) y. +Proof. by move=> mf x y; rewrite -{1}[x]fgK mf. Qed. + +Lemma can_mono : + {mono f : x y / aR x y >-> rR x y} -> {mono g : x y / rR x y >-> aR x y}. +Proof. by move=> mf x y /=; rewrite -mf !fgK. Qed. + +End MonoHomoMorphismTheory. + +Section MonoHomoMorphismTheory_in. + +Variables (aT rT sT : predArgType) (f : aT -> rT) (g : rT -> aT). +Variable (aD : pred aT). +Variable (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). + +Notation rD := [pred x | g x \in aD]. + +Lemma monoW_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in aD &, {homo f : x y / aR x y >-> rR x y}}. +Proof. by move=> hf x y hx hy axy; rewrite hf. Qed. + +Lemma mono2W_in : + {in aD, {mono f : x / aP x >-> rP x}} -> + {in aD, {homo f : x / aP x >-> rP x}}. +Proof. by move=> hf x hx ax; rewrite hf. Qed. + +Hypothesis fgK_on : {on aD, cancel g & f}. + +Lemma homoRL_in : + {in aD &, {homo f : x y / aR x y >-> rR x y}} -> + {in rD & aD, forall x y, aR (g x) y -> rR x (f y)}. +Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. + +Lemma homoLR_in : + {in aD &, {homo f : x y / aR x y >-> rR x y}} -> + {in aD & rD, forall x y, aR x (g y) -> rR (f x) y}. +Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. + +Lemma homo_mono_in : + {in aD &, {homo f : x y / aR x y >-> rR x y}} -> + {in rD &, {homo g : x y / rR x y >-> aR x y}} -> + {in rD &, {mono g : x y / rR x y >-> aR x y}}. +Proof. +move=> mf mg x y hx hy; case: (boolP (rR _ _))=> [/mg //|]; first exact. +by apply: contraNF=> /mf; rewrite !fgK_on //; apply. +Qed. + +Lemma monoLR_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in aD & rD, forall x y, rR (f x) y = aR x (g y)}. +Proof. by move=> mf x y hx hy; rewrite -{1}[y]fgK_on // mf. Qed. + +Lemma monoRL_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in rD & aD, forall x y, rR x (f y) = aR (g x) y}. +Proof. by move=> mf x y hx hy; rewrite -{1}[x]fgK_on // mf. Qed. + +Lemma can_mono_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in rD &, {mono g : x y / rR x y >-> aR x y}}. +Proof. by move=> mf x y hx hy /=; rewrite -mf // !fgK_on. Qed. + +End MonoHomoMorphismTheory_in. diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml new file mode 100644 index 000000000..cc0e86684 --- /dev/null +++ b/plugins/ssr/ssrbwd.ml @@ -0,0 +1,126 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Printer +open Pretyping +open Globnames +open Glob_term +open Tacmach + +open Ssrmatching_plugin +open Ssrmatching + +open Ssrast +open Ssrprinters +open Ssrcommon + +let char_to_kind = function + | '(' -> xInParens + | '@' -> xWithAt + | ' ' -> xNoFlag + | 'x' -> xCpattern + | _ -> assert false + +(** Backward chaining tactics: apply, exact, congr. *) + +(** The "apply" tactic *) + +let interp_agen ist gl ((goclr, _), (k, gc as c)) (clr, rcs) = +(* ppdebug(lazy(str"sigma@interp_agen=" ++ pr_evar_map None (project gl))); *) + let k = char_to_kind k in + let rc = pf_intern_term ist gl c in + let rcs' = rc :: rcs in + match goclr with + | None -> clr, rcs' + | Some ghyps -> + let clr' = snd (interp_hyps ist gl ghyps) @ clr in + if k <> xNoFlag then clr', rcs' else + let open CAst in + match rc with + | { loc; v = GVar id } when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' + | { loc; v = GRef (VarRef id, _) } when not_section_id id -> + SsrHyp (Loc.tag ?loc id) :: clr', rcs' + | _ -> clr', rcs' + +let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) + +let interp_agens ist gl gagens = + match List.fold_right (interp_agen ist gl) gagens ([], []) with + | clr, rlemma :: args -> + let n = interp_nbargs ist gl rlemma - List.length args in + let rec loop i = + if i > n then + errorstrm Pp.(str "Cannot apply lemma " ++ pf_pr_glob_constr gl rlemma) + else + try interp_refine ist gl (mkRApp rlemma (mkRHoles i @ args)) + with _ -> loop (i + 1) in + clr, loop 0 + | _ -> assert false + +let pf_match = pf_apply (fun e s c t -> understand_tcc e s ~expected_type:t c) + +let apply_rconstr ?ist t gl = +(* ppdebug(lazy(str"sigma@apply_rconstr=" ++ pr_evar_map None (project gl))); *) + let open CAst in + let n = match ist, t with + | None, { v = GVar id | GRef (VarRef id,_) } -> pf_nbargs gl (EConstr.mkVar id) + | Some ist, _ -> interp_nbargs ist gl t + | _ -> anomaly "apply_rconstr without ist and not RVar" in + let mkRlemma i = mkRApp t (mkRHoles i) in + let cl = pf_concl gl in + let rec loop i = + if i > n then + errorstrm Pp.(str"Cannot apply lemma "++pf_pr_glob_constr gl t) + else try pf_match gl (mkRlemma i) (OfType cl) with _ -> loop (i + 1) in + refine_with (loop 0) gl + +let mkRAppView ist gl rv gv = + let nb_view_imps = interp_view_nbimps ist gl rv in + mkRApp rv (mkRHoles (abs nb_view_imps)) + +let prof_apply_interp_with = mk_profiler "ssrapplytac.interp_with";; + +let refine_interp_apply_view i ist gl gv = + let pair i = List.map (fun x -> i, x) in + let rv = pf_intern_term ist gl gv in + let v = mkRAppView ist gl rv gv in + let interp_with (i, hint) = + interp_refine ist gl (mkRApp hint (v :: mkRHoles i)) in + let interp_with x = prof_apply_interp_with.profile interp_with x in + let rec loop = function + | [] -> (try apply_rconstr ~ist rv gl with _ -> view_error "apply" gv) + | h :: hs -> (try refine_with (snd (interp_with h)) gl with _ -> loop hs) in + loop (pair i Ssrview.viewtab.(i) @ + if i = 2 then pair 1 Ssrview.viewtab.(1) else []) + +let apply_top_tac gl = + Tacticals.tclTHENLIST [introid top_id; apply_rconstr (mkRVar top_id); Proofview.V82.of_tactic (Tactics.clear [top_id])] gl + +let inner_ssrapplytac gviews ggenl gclr ist gl = + let _, clr = interp_hyps ist gl gclr in + let vtac gv i gl' = refine_interp_apply_view i ist gl' gv in + let ggenl, tclGENTAC = + if gviews <> [] && ggenl <> [] then + let ggenl= List.map (fun (x,g) -> x, cpattern_of_term g) (List.hd ggenl) in + [], Tacticals.tclTHEN (genstac (ggenl,[]) ist) + else ggenl, Tacticals.tclTHEN Tacticals.tclIDTAC in + tclGENTAC (fun gl -> + match gviews, ggenl with + | v :: tl, [] -> + let dbl = if List.length tl = 1 then 2 else 1 in + Tacticals.tclTHEN + (List.fold_left (fun acc v -> Tacticals.tclTHENLAST acc (vtac v dbl)) (vtac v 1) tl) + (cleartac clr) gl + | [], [agens] -> + let clr', (sigma, lemma) = interp_agens ist gl agens in + let gl = pf_merge_uc_of sigma gl in + Tacticals.tclTHENLIST [cleartac clr; refine_with ~beta:true lemma; cleartac clr'] gl + | _, _ -> Tacticals.tclTHEN apply_top_tac (cleartac clr) gl) gl + diff --git a/plugins/ssr/ssrbwd.mli b/plugins/ssr/ssrbwd.mli new file mode 100644 index 000000000..8bf785a21 --- /dev/null +++ b/plugins/ssr/ssrbwd.mli @@ -0,0 +1,20 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +val apply_top_tac : Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + +val inner_ssrapplytac : + Ssrast.ssrterm list -> + ((Ssrast.ssrhyps option * Ssrmatching_plugin.Ssrmatching.occ) * + (Ssrast.ssrtermkind * Tacexpr.glob_constr_and_expr)) + list list -> + Ssrast.ssrhyps -> + Ssrast.ist -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml new file mode 100644 index 000000000..e90be92cf --- /dev/null +++ b/plugins/ssr/ssrcommon.ml @@ -0,0 +1,1297 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Util +open Names +open Evd +open Constr +open Termops +open Printer +open Locusops + +open Ltac_plugin +open Tacmach +open Refiner +open Libnames +open Ssrmatching_plugin +open Ssrmatching +open Ssrast +open Ssrprinters + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = CLexer.get_keyword_state () ;; + +let errorstrm x = CErrors.user_err ~hdr:"ssreflect" x + +let allocc = Some(false,[]) + +(** Bound assumption argument *) + +(* The Ltac API does have a type for assumptions but it is level-dependent *) +(* and therefore impractical to use for complex arguments, so we substitute *) +(* our own to have a uniform representation. Also, we refuse to intern *) +(* idents that match global/section constants, since this would lead to *) +(* fragile Ltac scripts. *) + +let hyp_id (SsrHyp (_, id)) = id + +let hyp_err ?loc msg id = + CErrors.user_err ?loc ~hdr:"ssrhyp" Pp.(str msg ++ Id.print id) + +let not_section_id id = not (Termops.is_section_variable id) + +let hyps_ids = List.map hyp_id + +let rec check_hyps_uniq ids = function + | SsrHyp (loc, id) :: _ when List.mem id ids -> + hyp_err ?loc "Duplicate assumption " id + | SsrHyp (_, id) :: hyps -> check_hyps_uniq (id :: ids) hyps + | [] -> () + +let check_hyp_exists hyps (SsrHyp(_, id)) = + try ignore(Context.Named.lookup id hyps) + with Not_found -> errorstrm Pp.(str"No assumption is named " ++ Id.print id) + +let test_hypname_exists hyps id = + try ignore(Context.Named.lookup id hyps); true + with Not_found -> false + +let hoik f = function Hyp x -> f x | Id x -> f x +let hoi_id = hoik hyp_id + +let mk_hint tac = false, [Some tac] +let mk_orhint tacs = true, tacs +let nullhint = true, [] +let nohint = false, [] + +type 'a tac_a = (goal * 'a) sigma -> (goal * 'a) list sigma + +let push_ctx a gl = re_sig (sig_it gl, a) (project gl) +let push_ctxs a gl = + re_sig (List.map (fun x -> x,a) (sig_it gl)) (project gl) +let pull_ctx gl = let g, a = sig_it gl in re_sig g (project gl), a +let pull_ctxs gl = let g, a = List.split (sig_it gl) in re_sig g (project gl), a + +let with_ctx f gl = + let gl, ctx = pull_ctx gl in + let rc, ctx = f ctx in + rc, push_ctx ctx gl +let without_ctx f gl = + let gl, _ctx = pull_ctx gl in + f gl +let tac_ctx t gl = + let gl, a = pull_ctx gl in + let gl = t gl in + push_ctxs a gl + +let tclTHEN_ia t1 t2 gl = + let gal = t1 gl in + let goals, sigma = sig_it gal, project gal in + let _, opened, sigma = + List.fold_left (fun (i,opened,sigma) g -> + let gl = t2 i (re_sig g sigma) in + i+1, sig_it gl :: opened, project gl) + (1,[],sigma) goals in + re_sig (List.flatten (List.rev opened)) sigma + +let tclTHEN_a t1 t2 gl = tclTHEN_ia t1 (fun _ -> t2) gl + +let tclTHENS_a t1 tl gl = tclTHEN_ia t1 + (fun i -> List.nth tl (i-1)) gl + +let rec tclTHENLIST_a = function + | [] -> tac_ctx tclIDTAC + | t1::tacl -> tclTHEN_a t1 (tclTHENLIST_a tacl) + +(* like tclTHEN_i but passes to the tac "i of n" and not just i *) +let tclTHEN_i_max tac taci gl = + let maxi = ref 0 in + tclTHEN_ia (tclTHEN_ia tac (fun i -> maxi := max i !maxi; tac_ctx tclIDTAC)) + (fun i gl -> taci i !maxi gl) gl + +let tac_on_all gl tac = + let goals = sig_it gl in + let opened, sigma = + List.fold_left (fun (opened,sigma) g -> + let gl = tac (re_sig g sigma) in + sig_it gl :: opened, project gl) + ([],project gl) goals in + re_sig (List.flatten (List.rev opened)) sigma + +(* Used to thread data between intro patterns at run time *) +type tac_ctx = { + tmp_ids : (Id.t * name ref) list; + wild_ids : Id.t list; + delayed_clears : Id.t list; +} + +let new_ctx () = + { tmp_ids = []; wild_ids = []; delayed_clears = [] } + +let with_fresh_ctx t gl = + let gl = push_ctx (new_ctx()) gl in + let gl = t gl in + fst (pull_ctxs gl) + +open Genarg +open Stdarg +open Pp + +let errorstrm x = CErrors.user_err ~hdr:"ssreflect" x +let anomaly s = CErrors.anomaly (str s) + +(* Tentative patch from util.ml *) + +let array_fold_right_from n f v a = + let rec fold n = + if n >= Array.length v then a else f v.(n) (fold (succ n)) + in + fold n + +let array_app_tl v l = + if Array.length v = 0 then invalid_arg "array_app_tl"; + array_fold_right_from 1 (fun e l -> e::l) v l + +let array_list_of_tl v = + if Array.length v = 0 then invalid_arg "array_list_of_tl"; + array_fold_right_from 1 (fun e l -> e::l) v [] + +(* end patch *) + + +(** Constructors for rawconstr *) +open Glob_term +open Globnames +open Misctypes +open Decl_kinds + +let mkRHole = CAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None) + +let rec mkRHoles n = if n > 0 then mkRHole :: mkRHoles (n - 1) else [] +let rec isRHoles = function { CAst.v = GHole _ } :: cl -> isRHoles cl | cl -> cl = [] +let mkRApp f args = if args = [] then f else CAst.make @@ GApp (f, args) +let mkRVar id = CAst.make @@ GRef (VarRef id,None) +let mkRltacVar id = CAst.make @@ GVar (id) +let mkRCast rc rt = CAst.make @@ GCast (rc, CastConv rt) +let mkRType = CAst.make @@ GSort (GType []) +let mkRProp = CAst.make @@ GSort (GProp) +let mkRArrow rt1 rt2 = CAst.make @@ GProd (Anonymous, Explicit, rt1, rt2) +let mkRConstruct c = CAst.make @@ GRef (ConstructRef c,None) +let mkRInd mind = CAst.make @@ GRef (IndRef mind,None) +let mkRLambda n s t = CAst.make @@ GLambda (n, Explicit, s, t) + +let rec mkRnat n = + if n <= 0 then CAst.make @@ GRef (Coqlib.glob_O, None) else + mkRApp (CAst.make @@ GRef (Coqlib.glob_S, None)) [mkRnat (n - 1)] + +let glob_constr ist genv = function + | _, Some ce -> + let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.Tacinterp.lfun Id.Set.empty in + let ltacvars = { + Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in + Constrintern.intern_gen Pretyping.WithoutTypeConstraint ~ltacvars genv ce + | rc, None -> rc + +let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c +let intern_term ist env (_, c) = glob_constr ist env c + +(* Estimate a bound on the number of arguments of a raw constr. *) +(* This is not perfect, because the unifier may fail to *) +(* typecheck the partial application, so we use a minimum of 5. *) +(* Also, we don't handle delayed or iterated coercions to *) +(* FUNCLASS, which is probably just as well since these can *) +(* lead to infinite arities. *) + +let splay_open_constr gl (sigma, c) = + let env = pf_env gl in let t = Retyping.get_type_of env sigma c in + Reductionops.splay_prod env sigma t + +let isAppInd gl c = + try ignore (pf_reduce_to_atomic_ind gl c); true with _ -> false + +(** Generic argument-based globbing/typing utilities *) + +let interp_refine ist gl rc = + let constrvars = Tacinterp.extract_ltac_constr_values ist (pf_env gl) in + let vars = { Pretyping.empty_lvar with + Pretyping.ltac_constrs = constrvars; ltac_genargs = ist.Tacinterp.lfun + } in + let kind = Pretyping.OfType (pf_concl gl) in + let flags = { + Pretyping.use_typeclasses = true; + solve_unification_constraints = true; + use_hook = None; + fail_evar = false; + expand_evars = true } + in + let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in +(* ppdebug(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) + ppdebug(lazy(str"c@interp_refine=" ++ Printer.pr_econstr c)); + (sigma, (sigma, c)) + + +let interp_open_constr ist gl gc = + let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist (pf_env gl) (project gl) (gc, Misctypes.NoBindings) in + (project gl, (sigma, c)) + +let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) + +let of_ftactic ftac gl = + let r = ref None in + let tac = Ftactic.run ftac (fun ans -> r := Some ans; Proofview.tclUNIT ()) in + let tac = Proofview.V82.of_tactic tac in + let { sigma = sigma } = tac gl in + let ans = match !r with + | None -> assert false (** If the tactic failed we should not reach this point *) + | Some ans -> ans + in + (sigma, ans) + +let interp_wit wit ist gl x = + let globarg = in_gen (glbwit wit) x in + let arg = Tacinterp.interp_genarg ist globarg in + let (sigma, arg) = of_ftactic arg gl in + sigma, Tacinterp.Value.cast (topwit wit) arg + +let interp_hyp ist gl (SsrHyp (loc, id)) = + let s, id' = interp_wit wit_var ist gl (loc, id) in + if not_section_id id' then s, SsrHyp (loc, id') else + hyp_err ?loc "Can't clear section hypothesis " id' + +let interp_hyps ist gl ghyps = + let hyps = List.map snd (List.map (interp_hyp ist gl) ghyps) in + check_hyps_uniq [] hyps; Tacmach.project gl, hyps + +let mk_term k c = k, (mkRHole, Some c) +let mk_lterm c = mk_term xNoFlag c + +let interp_view_nbimps ist gl rc = + try + let sigma, t = interp_open_constr ist gl (rc, None) in + let si = sig_it gl in + let gl = re_sig si sigma in + let pl, c = splay_open_constr gl t in + if isAppInd gl c then List.length pl else (-(List.length pl)) + with _ -> 0 + +let nbargs_open_constr gl oc = + let pl, _ = splay_open_constr gl oc in List.length pl + +let interp_nbargs ist gl rc = + try + let rc6 = mkRApp rc (mkRHoles 6) in + let sigma, t = interp_open_constr ist gl (rc6, None) in + let si = sig_it gl in + let gl = re_sig si sigma in + 6 + nbargs_open_constr gl t + with _ -> 5 + +let pf_nbargs gl c = nbargs_open_constr gl (project gl, c) + +let internal_names = ref [] +let add_internal_name pt = internal_names := pt :: !internal_names +let is_internal_name s = List.exists (fun p -> p s) !internal_names + +let tmp_tag = "_the_" +let tmp_post = "_tmp_" +let mk_tmp_id i = + id_of_string (Printf.sprintf "%s%s%s" tmp_tag (CString.ordinal i) tmp_post) +let new_tmp_id ctx = + let id = mk_tmp_id (1 + List.length ctx.tmp_ids) in + let orig = ref Anonymous in + (id, orig), { ctx with tmp_ids = (id, orig) :: ctx.tmp_ids } +;; + +let mk_internal_id s = + let s' = Printf.sprintf "_%s_" s in + let s' = String.map (fun c -> if c = ' ' then '_' else c) s' in + add_internal_name ((=) s'); id_of_string s' + +let same_prefix s t n = + let rec loop i = i = n || s.[i] = t.[i] && loop (i + 1) in loop 0 + +let skip_digits s = + let n = String.length s in + let rec loop i = if i < n && is_digit s.[i] then loop (i + 1) else i in loop + +let mk_tagged_id t i = id_of_string (Printf.sprintf "%s%d_" t i) +let is_tagged t s = + let n = String.length s - 1 and m = String.length t in + m < n && s.[n] = '_' && same_prefix s t m && skip_digits s m = n + +let evar_tag = "_evar_" +let _ = add_internal_name (is_tagged evar_tag) +let mk_evar_name n = Name (mk_tagged_id evar_tag n) + +let ssr_anon_hyp = "Hyp" + +let wildcard_tag = "_the_" +let wildcard_post = "_wildcard_" +let mk_wildcard_id i = + id_of_string (Printf.sprintf "%s%s%s" wildcard_tag (CString.ordinal i) wildcard_post) +let has_wildcard_tag s = + let n = String.length s in let m = String.length wildcard_tag in + let m' = String.length wildcard_post in + n < m + m' + 2 && same_prefix s wildcard_tag m && + String.sub s (n - m') m' = wildcard_post && + skip_digits s m = n - m' - 2 +let _ = add_internal_name has_wildcard_tag + +let new_wild_id ctx = + let i = 1 + List.length ctx.wild_ids in + let id = mk_wildcard_id i in + id, { ctx with wild_ids = id :: ctx.wild_ids } + +let discharged_tag = "_discharged_" +let mk_discharged_id id = + id_of_string (Printf.sprintf "%s%s_" discharged_tag (string_of_id id)) +let has_discharged_tag s = + let m = String.length discharged_tag and n = String.length s - 1 in + m < n && s.[n] = '_' && same_prefix s discharged_tag m +let _ = add_internal_name has_discharged_tag +let is_discharged_id id = has_discharged_tag (string_of_id id) + +let max_suffix m (t, j0 as tj0) id = + let s = string_of_id id in let n = String.length s - 1 in + let dn = String.length t - 1 - n in let i0 = j0 - dn in + if not (i0 >= m && s.[n] = '_' && same_prefix s t m) then tj0 else + let rec loop i = + if i < i0 && s.[i] = '0' then loop (i + 1) else + if (if i < i0 then skip_digits s i = n else le_s_t i) then s, i else tj0 + and le_s_t i = + let ds = s.[i] and dt = t.[i + dn] in + if ds = dt then i = n || le_s_t (i + 1) else + dt < ds && skip_digits s i = n in + loop m + +let mk_anon_id t gl = + let m, si0, id0 = + let s = ref (Printf.sprintf "_%s_" t) in + if is_internal_name !s then s := "_" ^ !s; + let n = String.length !s - 1 in + let rec loop i j = + let d = !s.[i] in if not (is_digit d) then i + 1, j else + loop (i - 1) (if d = '0' then j else i) in + let m, j = loop (n - 1) n in m, (!s, j), id_of_string !s in + let gl_ids = pf_ids_of_hyps gl in + if not (List.mem id0 gl_ids) then id0 else + let s, i = List.fold_left (max_suffix m) si0 gl_ids in + let open Bytes in + let s = of_string s in + let n = length s - 1 in + let rec loop i = + if get s i = '9' then (set s i '0'; loop (i - 1)) else + if i < m then (set s n '0'; set s m '1'; cat s (of_string "_")) else + (set s i (Char.chr (Char.code (get s i) + 1)); s) in + Id.of_bytes (loop (n - 1)) + +let convert_concl_no_check t = Tactics.convert_concl_no_check t Term.DEFAULTcast +let convert_concl t = Tactics.convert_concl t Term.DEFAULTcast + +let rename_hd_prod orig_name_ref gl = + match EConstr.kind (project gl) (pf_concl gl) with + | Constr.Prod(_,src,tgt) -> + Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkProd (!orig_name_ref,src,tgt))) gl + | _ -> CErrors.anomaly (str "gentac creates no product") + +(* Reduction that preserves the Prod/Let spine of the "in" tactical. *) + +let inc_safe n = if n = 0 then n else n + 1 +let rec safe_depth s c = match EConstr.kind s c with +| LetIn (Name x, _, _, c') when is_discharged_id x -> safe_depth s c' + 1 +| LetIn (_, _, _, c') | Prod (_, _, c') -> inc_safe (safe_depth s c') +| _ -> 0 + +let red_safe (r : Reductionops.reduction_function) e s c0 = + let rec red_to e c n = match EConstr.kind s c with + | Prod (x, t, c') when n > 0 -> + let t' = r e s t in let e' = EConstr.push_rel (RelDecl.LocalAssum (x, t')) e in + EConstr.mkProd (x, t', red_to e' c' (n - 1)) + | LetIn (x, b, t, c') when n > 0 -> + let t' = r e s t in let e' = EConstr.push_rel (RelDecl.LocalAssum (x, t')) e in + EConstr.mkLetIn (x, r e s b, t', red_to e' c' (n - 1)) + | _ -> r e s c in + red_to e c0 (safe_depth s c0) + +let is_id_constr sigma c = match EConstr.kind sigma c with + | Lambda(_,_,c) when EConstr.isRel sigma c -> 1 = EConstr.destRel sigma c + | _ -> false + +let red_product_skip_id env sigma c = match EConstr.kind sigma c with + | App(hd,args) when Array.length args = 1 && is_id_constr sigma hd -> args.(0) + | _ -> try Tacred.red_product env sigma c with _ -> c + +let ssrevaltac ist gtac = + Proofview.V82.of_tactic (Tacinterp.tactic_of_value ist gtac) +(** Open term to lambda-term coercion {{{ ************************************) + +(* This operation takes a goal gl and an open term (sigma, t), and *) +(* returns a term t' where all the new evars in sigma are abstracted *) +(* with the mkAbs argument, i.e., for mkAbs = mkLambda then there is *) +(* some duplicate-free array args of evars of sigma such that the *) +(* term mkApp (t', args) is convertible to t. *) +(* This makes a useful shorthand for local definitions in proofs, *) +(* i.e., pose succ := _ + 1 means pose succ := fun n : nat => n + 1, *) +(* and, in context of the the 4CT library, pose mid := maps id means *) +(* pose mid := fun d : detaSet => @maps d d (@id (datum d)) *) +(* Note that this facility does not extend to set, which tries *) +(* instead to fill holes by matching a goal subterm. *) +(* The argument to "have" et al. uses product abstraction, e.g. *) +(* have Hmid: forall s, (maps id s) = s. *) +(* stands for *) +(* have Hmid: forall (d : dataSet) (s : seq d), (maps id s) = s. *) +(* We also use this feature for rewrite rules, so that, e.g., *) +(* rewrite: (plus_assoc _ 3). *) +(* will execute as *) +(* rewrite (fun n => plus_assoc n 3) *) +(* i.e., it will rewrite some subterm .. + (3 + ..) to .. + 3 + ... *) +(* The convention is also used for the argument of the congr tactic, *) +(* e.g., congr (x + _ * 1). *) + +(* Replace new evars with lambda variables, retaining local dependencies *) +(* but stripping global ones. We use the variable names to encode the *) +(* the number of dependencies, so that the transformation is reversible. *) + +open Term +let env_size env = List.length (Environ.named_context env) + +let pf_concl gl = EConstr.Unsafe.to_constr (pf_concl gl) +let pf_get_hyp gl x = EConstr.Unsafe.to_named_decl (pf_get_hyp gl x) + +let pf_e_type_of gl t = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, ty = Typing.type_of env sigma t in + re_sig it sigma, ty + +let nf_evar sigma t = + EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr t)) + +let pf_abs_evars2 gl rigid (sigma, c0) = + let c0 = EConstr.Unsafe.to_constr c0 in + let sigma0, ucst = project gl, Evd.evar_universe_context sigma in + let nenv = env_size (pf_env gl) in + let abs_evar n k = + let evi = Evd.find sigma k in + let dc = CList.firstn n (evar_filtered_context evi) in + let abs_dc c = function + | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) + | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in + let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in + nf_evar sigma t in + let rec put evlist c = match kind_of_term c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k || List.mem k rigid then evlist else + let n = max 0 (Array.length a - nenv) in + let t = abs_evar n k in (k, (n, t)) :: put evlist t + | _ -> fold_constr put evlist c in + let evlist = put [] c0 in + if evlist = [] then 0, EConstr.of_constr c0,[], ucst else + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n, _)) :: evl -> if k = k' then i, n else lookup k (i + 1) evl in + let rec get i c = match kind_of_term c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then map_constr (get i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get i a.(n - 1 - k))) + | _ -> map_constr_with_binders ((+) 1) get i c in + let rec loop c i = function + | (_, (n, t)) :: evl -> + loop (mkLambda (mk_evar_name n, get (i - 1) t, c)) (i - 1) evl + | [] -> c in + List.length evlist, EConstr.of_constr (loop (get 1 c0) 1 evlist), List.map fst evlist, ucst + +let pf_abs_evars gl t = pf_abs_evars2 gl [] t + + +(* As before but if (?i : T(?j)) and (?j : P : Prop), then the lambda for i + * looks like (fun evar_i : (forall pi : P. T(pi))) thanks to "loopP" and all + * occurrences of evar_i are replaced by (evar_i evar_j) thanks to "app". + * + * If P can be solved by ssrautoprop (that defaults to trivial), then + * the corresponding lambda looks like (fun evar_i : T(c)) where c is + * the solution found by ssrautoprop. + *) +let ssrautoprop_tac = ref (fun gl -> assert false) + +(* Thanks to Arnaud Spiwack for this snippet *) +let call_on_evar tac e s = + let { it = gs ; sigma = s } = + tac { it = e ; sigma = s; } in + gs, s + +open Pp +let pp _ = () (* FIXME *) +module Intset = Evar.Set + +let pf_abs_evars_pirrel gl (sigma, c0) = + pp(lazy(str"==PF_ABS_EVARS_PIRREL==")); + pp(lazy(str"c0= " ++ Printer.pr_constr c0)); + let sigma0 = project gl in + let c0 = nf_evar sigma0 (nf_evar sigma c0) in + let nenv = env_size (pf_env gl) in + let abs_evar n k = + let evi = Evd.find sigma k in + let dc = CList.firstn n (evar_filtered_context evi) in + let abs_dc c = function + | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) + | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in + let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in + nf_evar sigma0 (nf_evar sigma t) in + let rec put evlist c = match kind_of_term c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else + let n = max 0 (Array.length a - nenv) in + let k_ty = + Retyping.get_sort_family_of + (pf_env gl) sigma (EConstr.of_constr (Evd.evar_concl (Evd.find sigma k))) in + let is_prop = k_ty = InProp in + let t = abs_evar n k in (k, (n, t, is_prop)) :: put evlist t + | _ -> fold_constr put evlist c in + let evlist = put [] c0 in + if evlist = [] then 0, c0 else + let pr_constr t = Printer.pr_econstr (Reductionops.nf_beta (project gl) (EConstr.of_constr t)) in + pp(lazy(str"evlist=" ++ pr_list (fun () -> str";") + (fun (k,_) -> str(Evd.string_of_existential k)) evlist)); + let evplist = + let depev = List.fold_left (fun evs (_,(_,t,_)) -> + let t = EConstr.of_constr t in + Intset.union evs (Evarutil.undefined_evars_of_term sigma t)) Intset.empty evlist in + List.filter (fun (i,(_,_,b)) -> b && Intset.mem i depev) evlist in + let evlist, evplist, sigma = + if evplist = [] then evlist, [], sigma else + List.fold_left (fun (ev, evp, sigma) (i, (_,t,_) as p) -> + try + let ng, sigma = call_on_evar !ssrautoprop_tac i sigma in + if (ng <> []) then errorstrm (str "Should we tell the user?"); + List.filter (fun (j,_) -> j <> i) ev, evp, sigma + with _ -> ev, p::evp, sigma) (evlist, [], sigma) (List.rev evplist) in + let c0 = nf_evar sigma c0 in + let evlist = + List.map (fun (x,(y,t,z)) -> x,(y,nf_evar sigma t,z)) evlist in + let evplist = + List.map (fun (x,(y,t,z)) -> x,(y,nf_evar sigma t,z)) evplist in + pp(lazy(str"c0= " ++ pr_constr c0)); + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n,_,_)) :: evl -> if k = k' then i,n else lookup k (i + 1) evl in + let rec get evlist i c = match kind_of_term c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then map_constr (get evlist i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get evlist i a.(n - 1 - k))) + | _ -> map_constr_with_binders ((+) 1) (get evlist) i c in + let rec app extra_args i c = match decompose_app c with + | hd, args when isRel hd && destRel hd = i -> + let j = destRel hd in + mkApp (mkRel j, Array.of_list (List.map (Vars.lift (i-1)) extra_args @ args)) + | _ -> map_constr_with_binders ((+) 1) (app extra_args) i c in + let rec loopP evlist c i = function + | (_, (n, t, _)) :: evl -> + let t = get evlist (i - 1) t in + let n = Name (id_of_string (ssr_anon_hyp ^ string_of_int n)) in + loopP evlist (mkProd (n, t, c)) (i - 1) evl + | [] -> c in + let rec loop c i = function + | (_, (n, t, _)) :: evl -> + let evs = Evarutil.undefined_evars_of_term sigma (EConstr.of_constr t) in + let t_evplist = List.filter (fun (k,_) -> Intset.mem k evs) evplist in + let t = loopP t_evplist (get t_evplist 1 t) 1 t_evplist in + let t = get evlist (i - 1) t in + let extra_args = + List.map (fun (k,_) -> mkRel (fst (lookup k i evlist))) + (List.rev t_evplist) in + let c = if extra_args = [] then c else app extra_args 1 c in + loop (mkLambda (mk_evar_name n, t, c)) (i - 1) evl + | [] -> c in + let res = loop (get evlist 1 c0) 1 evlist in + pp(lazy(str"res= " ++ pr_constr res)); + List.length evlist, res + +(* Strip all non-essential dependencies from an abstracted term, generating *) +(* standard names for the abstracted holes. *) + +let nb_evar_deps = function + | Name id -> + let s = string_of_id id in + if not (is_tagged evar_tag s) then 0 else + let m = String.length evar_tag in + (try int_of_string (String.sub s m (String.length s - 1 - m)) with _ -> 0) + | _ -> 0 + +let pf_type_id gl t = id_of_string (Namegen.hdchar (pf_env gl) (project gl) t) +let pfe_type_of gl t = + let sigma, ty = pf_type_of gl t in + re_sig (sig_it gl) sigma, ty +let pf_type_of gl t = + let sigma, ty = pf_type_of gl (EConstr.of_constr t) in + re_sig (sig_it gl) sigma, EConstr.Unsafe.to_constr ty + +let pf_abs_cterm gl n c0 = + if n <= 0 then c0 else + let c0 = EConstr.Unsafe.to_constr c0 in + let noargs = [|0|] in + let eva = Array.make n noargs in + let rec strip i c = match kind_of_term c with + | App (f, a) when isRel f -> + let j = i - destRel f in + if j >= n || eva.(j) = noargs then mkApp (f, Array.map (strip i) a) else + let dp = eva.(j) in + let nd = Array.length dp - 1 in + let mkarg k = strip i a.(if k < nd then dp.(k + 1) - j else k + dp.(0)) in + mkApp (f, Array.init (Array.length a - dp.(0)) mkarg) + | _ -> map_constr_with_binders ((+) 1) strip i c in + let rec strip_ndeps j i c = match kind_of_term c with + | Prod (x, t, c1) when i < j -> + let dl, c2 = strip_ndeps j (i + 1) c1 in + if Vars.noccurn 1 c2 then dl, Vars.lift (-1) c2 else + i :: dl, mkProd (x, strip i t, c2) + | LetIn (x, b, t, c1) when i < j -> + let _, _, c1' = destProd c1 in + let dl, c2 = strip_ndeps j (i + 1) c1' in + if Vars.noccurn 1 c2 then dl, Vars.lift (-1) c2 else + i :: dl, mkLetIn (x, strip i b, strip i t, c2) + | _ -> [], strip i c in + let rec strip_evars i c = match kind_of_term c with + | Lambda (x, t1, c1) when i < n -> + let na = nb_evar_deps x in + let dl, t2 = strip_ndeps (i + na) i t1 in + let na' = List.length dl in + eva.(i) <- Array.of_list (na - na' :: dl); + let x' = + if na' = 0 then Name (pf_type_id gl (EConstr.of_constr t2)) else mk_evar_name na' in + mkLambda (x', t2, strip_evars (i + 1) c1) +(* if noccurn 1 c2 then lift (-1) c2 else + mkLambda (Name (pf_type_id gl t2), t2, c2) *) + | _ -> strip i c in + EConstr.of_constr (strip_evars 0 c0) + +(* }}} *) + +let pf_merge_uc uc gl = + re_sig (sig_it gl) (Evd.merge_universe_context (Refiner.project gl) uc) +let pf_merge_uc_of sigma gl = + let ucst = Evd.evar_universe_context sigma in + pf_merge_uc ucst gl + + +let rec constr_name sigma c = match EConstr.kind sigma c with + | Var id -> Name id + | Cast (c', _, _) -> constr_name sigma c' + | Const (cn,_) -> Name (id_of_label (con_label cn)) + | App (c', _) -> constr_name sigma c' + | _ -> Anonymous + +let pf_mkprod gl c ?(name=constr_name (project gl) c) cl = + let gl, t = pfe_type_of gl c in + if name <> Anonymous || EConstr.Vars.noccurn (project gl) 1 cl then gl, EConstr.mkProd (name, t, cl) else + gl, EConstr.mkProd (Name (pf_type_id gl t), t, cl) + +let pf_abs_prod name gl c cl = pf_mkprod gl c ~name (Termops.subst_term (project gl) c cl) + +(** look up a name in the ssreflect internals module *) +let ssrdirpath = make_dirpath [id_of_string "ssreflect"] +let ssrqid name = Libnames.make_qualid ssrdirpath (id_of_string name) +let ssrtopqid name = Libnames.make_short_qualid (id_of_string name) +let locate_reference qid = + Smartlocate.global_of_extended_global (Nametab.locate_extended qid) +let mkSsrRef name = + try locate_reference (ssrqid name) with Not_found -> + try locate_reference (ssrtopqid name) with Not_found -> + CErrors.user_err (Pp.str "Small scale reflection library not loaded") +let mkSsrRRef name = (CAst.make @@ GRef (mkSsrRef name,None)), None +let mkSsrConst name env sigma = + EConstr.fresh_global env sigma (mkSsrRef name) +let pf_mkSsrConst name gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let (sigma, t) = mkSsrConst name env sigma in + t, re_sig it sigma +let pf_fresh_global name gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma,t = Evd.fresh_global env sigma name in + t, re_sig it sigma + +let mkProt t c gl = + let prot, gl = pf_mkSsrConst "protect_term" gl in + EConstr.mkApp (prot, [|t; c|]), gl + +let mkEtaApp c n imin = + let open EConstr in + if n = 0 then c else + let nargs, mkarg = + if n < 0 then -n, (fun i -> mkRel (imin + i)) else + let imax = imin + n - 1 in n, (fun i -> mkRel (imax - i)) in + mkApp (c, Array.init nargs mkarg) + +let mkRefl t c gl = + let sigma = project gl in + let (sigma, refl) = EConstr.fresh_global (pf_env gl) sigma Coqlib.((build_coq_eq_data()).refl) in + EConstr.mkApp (refl, [|t; c|]), { gl with sigma } + +let discharge_hyp (id', (id, mode)) gl = + let cl' = Vars.subst_var id (pf_concl gl) in + match pf_get_hyp gl id, mode with + | NamedDecl.LocalAssum (_, t), _ | NamedDecl.LocalDef (_, _, t), "(" -> + Proofview.V82.of_tactic (Tactics.apply_type (EConstr.of_constr (mkProd (Name id', t, cl'))) + [EConstr.of_constr (mkVar id)]) gl + | NamedDecl.LocalDef (_, v, t), _ -> + Proofview.V82.of_tactic + (convert_concl (EConstr.of_constr (mkLetIn (Name id', v, t, cl')))) gl + +(* wildcard names *) +let clear_wilds wilds gl = + Proofview.V82.of_tactic (Tactics.clear (List.filter (fun id -> List.mem id wilds) (pf_ids_of_hyps gl))) gl + +let clear_with_wilds wilds clr0 gl = + let extend_clr clr nd = + let id = NamedDecl.get_id nd in + if List.mem id clr || not (List.mem id wilds) then clr else + let vars = Termops.global_vars_set_of_decl (pf_env gl) (project gl) nd in + let occurs id' = Idset.mem id' vars in + if List.exists occurs clr then id :: clr else clr in + Proofview.V82.of_tactic (Tactics.clear (Context.Named.fold_inside extend_clr ~init:clr0 (Tacmach.pf_hyps gl))) gl + +let clear_wilds_and_tmp_and_delayed_ids gl = + let _, ctx = pull_ctx gl in + tac_ctx + (tclTHEN + (clear_with_wilds ctx.wild_ids ctx.delayed_clears) + (clear_wilds (List.map fst ctx.tmp_ids @ ctx.wild_ids))) gl + +let rec is_name_in_ipats name = function + | IPatClear clr :: tl -> + List.exists (function SsrHyp(_,id) -> id = name) clr + || is_name_in_ipats name tl + | IPatId id :: tl -> id = name || is_name_in_ipats name tl + | IPatCase l :: tl -> List.exists (is_name_in_ipats name) l || is_name_in_ipats name tl + | _ :: tl -> is_name_in_ipats name tl + | [] -> false + +let view_error s gv = + errorstrm (str ("Cannot " ^ s ^ " view ") ++ pr_term gv) + + +open Locus +(****************************** tactics ***********************************) + +let rewritetac dir c = + (* Due to the new optional arg ?tac, application shouldn't be too partial *) + Proofview.V82.of_tactic begin + Equality.general_rewrite (dir = L2R) AllOccurrences true false c + end + +(**********************`:********* hooks ************************************) + +type name_hint = (int * EConstr.types array) option ref + +let pf_abs_ssrterm ?(resolve_typeclasses=false) ist gl t = + let sigma, ct as t = interp_term ist gl t in + let sigma, _ as t = + let env = pf_env gl in + if not resolve_typeclasses then t + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma ct in + let n, c, abstracted_away, ucst = pf_abs_evars gl t in + List.fold_left Evd.remove sigma abstracted_away, pf_abs_cterm gl n c, ucst, n + +let top_id = mk_internal_id "top assumption" + +let ssr_n_tac seed n gl = + let name = if n = -1 then seed else ("ssr" ^ seed ^ string_of_int n) in + let fail msg = CErrors.user_err (Pp.str msg) in + let tacname = + try Nametab.locate_tactic (Libnames.qualid_of_ident (id_of_string name)) + with Not_found -> try Nametab.locate_tactic (ssrqid name) + with Not_found -> + if n = -1 then fail "The ssreflect library was not loaded" + else fail ("The tactic "^name^" was not found") in + let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in + Proofview.V82.of_tactic (Tacinterp.eval_tactic (Tacexpr.TacArg tacexpr)) gl + +let donetac n gl = ssr_n_tac "done" n gl + +open Constrexpr +open Util + +(** Constructors for constr_expr *) +let mkCProp loc = CAst.make ?loc @@ CSort GProp +let mkCType loc = CAst.make ?loc @@ CSort (GType []) +let mkCVar ?loc id = CAst.make ?loc @@ CRef (Ident (Loc.tag ?loc id), None) +let rec mkCHoles ?loc n = + if n <= 0 then [] else (CAst.make ?loc @@ CHole (None, IntroAnonymous, None)) :: mkCHoles ?loc (n - 1) +let mkCHole loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) +let mkCLambda ?loc name ty t = CAst.make ?loc @@ + CLambdaN ([[loc, name], Default Explicit, ty], t) +let mkCArrow ?loc ty t = CAst.make ?loc @@ + CProdN ([[Loc.tag Anonymous], Default Explicit, ty], t) +let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, CastConv ty) + +let rec isCHoles = function { CAst.v = CHole _ } :: cl -> isCHoles cl | cl -> cl = [] +let rec isCxHoles = function ({ CAst.v = CHole _ }, None) :: ch -> isCxHoles ch | _ -> false + +let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = + let n_binders = ref 0 in + let ty = match ty with + | a, (t, None) -> + let rec force_type ty = CAst.(map (function + | GProd (x, k, s, t) -> incr n_binders; GProd (x, k, s, force_type t) + | GLetIn (x, v, oty, t) -> incr n_binders; GLetIn (x, v, oty, force_type t) + | _ -> (mkRCast ty mkRType).v)) ty in + a, (force_type t, None) + | _, (_, Some ty) -> + let rec force_type ty = CAst.(map (function + | CProdN (abs, t) -> + n_binders := !n_binders + List.length (List.flatten (List.map pi1 abs)); + CProdN (abs, force_type t) + | CLetIn (n, v, oty, t) -> incr n_binders; CLetIn (n, v, oty, force_type t) + | _ -> (mkCCast ty (mkCType None)).v)) ty in + mk_term ' ' (force_type ty) in + let strip_cast (sigma, t) = + let rec aux t = match EConstr.kind_of_type sigma t with + | CastType (t, ty) when !n_binders = 0 && EConstr.isSort sigma ty -> t + | ProdType(n,s,t) -> decr n_binders; EConstr.mkProd (n, s, aux t) + | LetInType(n,v,ty,t) -> decr n_binders; EConstr.mkLetIn (n, v, ty, aux t) + | _ -> anomaly "pf_interp_ty: ssr Type cast deleted by typecheck" in + sigma, aux t in + let sigma, cty as ty = strip_cast (interp_term ist gl ty) in + let ty = + let env = pf_env gl in + if not resolve_typeclasses then ty + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma cty in + let n, c, _, ucst = pf_abs_evars gl ty in + let lam_c = pf_abs_cterm gl n c in + let ctx, c = EConstr.decompose_lam_n_assum sigma n lam_c in + n, EConstr.it_mkProd_or_LetIn c ctx, lam_c, ucst +;; + +(* TASSI: given (c : ty), generates (c ??? : ty[???/...]) with m evars *) +exception NotEnoughProducts +let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_of env sigma c) m += + let rec loop ty args sigma n = + if n = 0 then + let args = List.rev args in + (if beta then Reductionops.whd_beta sigma else fun x -> x) + (EConstr.mkApp (c, Array.of_list (List.map snd args))), ty, args, sigma + else match EConstr.kind_of_type sigma ty with + | ProdType (_, src, tgt) -> + let sigma = create_evar_defs sigma in + let (sigma, x) = + Evarutil.new_evar env sigma + (if bi_types then Reductionops.nf_betaiota sigma src else src) in + loop (EConstr.Vars.subst1 x tgt) ((m - n,x) :: args) sigma (n-1) + | CastType (t, _) -> loop t args sigma n + | LetInType (_, v, _, t) -> loop (EConstr.Vars.subst1 v t) args sigma n + | SortType _ -> assert false + | AtomicType _ -> + let ty = (* FIXME *) + (Reductionops.whd_all env sigma) ty in + match EConstr.kind_of_type sigma ty with + | ProdType _ -> loop ty args sigma n + | _ -> raise NotEnoughProducts + in + loop ty [] sigma m + +let pf_saturate ?beta ?bi_types gl c ?ty m = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let t, ty, args, sigma = saturate ?beta ?bi_types env sigma c ?ty m in + t, ty, args, re_sig si sigma + +let pf_partial_solution gl t evl = + let sigma, g = project gl, sig_it gl in + let sigma = Goal.V82.partial_solution sigma g t in + re_sig (List.map (fun x -> (fst (EConstr.destEvar sigma x))) evl) sigma + +let dependent_apply_error = + try CErrors.user_err (Pp.str "Could not fill dependent hole in \"apply\"") + with err -> err + +(* TASSI: Sometimes Coq's apply fails. According to my experience it may be + * related to goals that are products and with beta redexes. In that case it + * guesses the wrong number of implicit arguments for your lemma. What follows + * is just like apply, but with a user-provided number n of implicits. + * + * Refine.refine function that handles type classes and evars but fails to + * handle "dependently typed higher order evars". + * + * Refiner.refiner that does not handle metas with a non ground type but works + * with dependently typed higher order metas. *) +let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = + if with_evars then + let refine gl = + let t, ty, args, gl = pf_saturate ?beta ~bi_types:true gl t n in +(* pp(lazy(str"sigma@saturate=" ++ pr_evar_map None (project gl))); *) + let gl = pf_unify_HO gl ty (Tacmach.pf_concl gl) in + let gs = CList.map_filter (fun (_, e) -> + if EConstr.isEvar (project gl) e then Some e else None) + args in + pf_partial_solution gl t gs + in + Proofview.(V82.of_tactic + (tclTHEN (V82.tactic refine) + (if with_shelve then shelve_unifiable else tclUNIT ()))) gl + else + let t, gl = if n = 0 then t, gl else + let sigma, si = project gl, sig_it gl in + let rec loop sigma bo args = function (* saturate with metas *) + | 0 -> EConstr.mkApp (t, Array.of_list (List.rev args)), re_sig si sigma + | n -> match EConstr.kind sigma bo with + | Lambda (_, ty, bo) -> + if not (EConstr.Vars.closed0 sigma ty) then + raise dependent_apply_error; + let m = Evarutil.new_meta () in + loop (meta_declare m (EConstr.Unsafe.to_constr ty) sigma) bo ((EConstr.mkMeta m)::args) (n-1) + | _ -> assert false + in loop sigma t [] n in + pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr t)); + Refiner.refiner (Proof_type.Refine (EConstr.Unsafe.to_constr t)) gl + +let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = + let rec mkRels = function 1 -> [] | n -> mkRel n :: mkRels (n-1) in + let uct = Evd.evar_universe_context (fst oc) in + let n, oc = pf_abs_evars_pirrel gl (fst oc, EConstr.Unsafe.to_constr (snd oc)) in + let gl = pf_unsafe_merge_uc uct gl in + let oc = if not first_goes_last || n <= 1 then oc else + let l, c = decompose_lam oc in + if not (List.for_all_i (fun i (_,t) -> Vars.closedn ~-i t) (1-n) l) then oc else + compose_lam (let xs,y = List.chop (n-1) l in y @ xs) + (mkApp (compose_lam l c, Array.of_list (mkRel 1 :: mkRels n))) + in + pp(lazy(str"after: " ++ Printer.pr_constr oc)); + try applyn ~with_evars ~with_shelve:true ?beta n (EConstr.of_constr oc) gl + with e when CErrors.noncritical e -> raise dependent_apply_error + +(** Profiling {{{ *************************************************************) +type profiler = { + profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; + reset : unit -> unit; + print : unit -> unit } +let profile_now = ref false +let something_profiled = ref false +let profilers = ref [] +let add_profiler f = profilers := f :: !profilers;; +let _ = + Goptions.declare_bool_option + { Goptions.optname = "ssreflect profiling"; + Goptions.optkey = ["SsrProfiling"]; + Goptions.optread = (fun _ -> !profile_now); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> + Ssrmatching.profile b; + profile_now := b; + if b then List.iter (fun f -> f.reset ()) !profilers; + if not b then List.iter (fun f -> f.print ()) !profilers) } +let () = + let prof_total = + let init = ref 0.0 in { + profile = (fun f x -> assert false); + reset = (fun () -> init := Unix.gettimeofday ()); + print = (fun () -> if !something_profiled then + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in + let prof_legenda = { + profile = (fun f x -> assert false); + reset = (fun () -> ()); + print = (fun () -> if !something_profiled then begin + prerr_endline + (Printf.sprintf "!! %39s ---------- --------- --------- ---------" + (String.make 39 '-')); + prerr_endline + (Printf.sprintf "!! %-39s %10s %9s %9s %9s" + "function" "#calls" "total" "max" "average") end) } in + add_profiler prof_legenda; + add_profiler prof_total +;; + +let mk_profiler s = + let total, calls, max = ref 0.0, ref 0, ref 0.0 in + let reset () = total := 0.0; calls := 0; max := 0.0 in + let profile f x = + if not !profile_now then f x else + let before = Unix.gettimeofday () in + try + incr calls; + let res = f x in + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + res + with exc -> + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + raise exc in + let print () = + if !calls <> 0 then begin + something_profiled := true; + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + s !calls !total !max (!total /. (float_of_int !calls))) end in + let prof = { profile = profile; reset = reset; print = print } in + add_profiler prof; + prof +;; +(* }}} *) + +(* We wipe out all the keywords generated by the grammar rules we defined. *) +(* The user is supposed to Require Import ssreflect or Require ssreflect *) +(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) +(* consequence the extended ssreflect grammar. *) +let () = CLexer.set_keyword_state frozen_lexer ;; + +(** Basic tactics *) + +let rec fst_prod red tac = Proofview.Goal.nf_enter begin fun gl -> + let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in + match EConstr.kind (Proofview.Goal.sigma gl) concl with + | Prod (id,_,tgt) | LetIn(id,_,_,tgt) -> tac id + | _ -> if red then Tacticals.New.tclZEROMSG (str"No product even after head-reduction.") + else Tacticals.New.tclTHEN Tactics.hnf_in_concl (fst_prod true tac) +end + +let introid ?(orig=ref Anonymous) name = tclTHEN (fun gl -> + let g, env = Tacmach.pf_concl gl, pf_env gl in + let sigma = project gl in + match EConstr.kind sigma g with + | App (hd, _) when EConstr.isLambda sigma hd -> + Proofview.V82.of_tactic (convert_concl_no_check (Reductionops.whd_beta sigma g)) gl + | _ -> tclIDTAC gl) + (Proofview.V82.of_tactic + (fst_prod false (fun id -> orig := id; Tactics.intro_mustbe_force name))) +;; + +let anontac decl gl = + let id = match RelDecl.get_name decl with + | Name id -> + if is_discharged_id id then id else mk_anon_id (string_of_id id) gl + | _ -> mk_anon_id ssr_anon_hyp gl in + introid id gl + +let intro_all gl = + let dc, _ = EConstr.decompose_prod_assum (project gl) (Tacmach.pf_concl gl) in + tclTHENLIST (List.map anontac (List.rev dc)) gl + +let rec intro_anon gl = + try anontac (List.hd (fst (EConstr.decompose_prod_n_assum (project gl) 1 (Tacmach.pf_concl gl)))) gl + with err0 -> try tclTHEN (Proofview.V82.of_tactic Tactics.red_in_concl) intro_anon gl with e when CErrors.noncritical e -> raise err0 + (* with _ -> CErrors.error "No product even after reduction" *) + +let is_pf_var sigma c = + EConstr.isVar sigma c && not_section_id (EConstr.destVar sigma c) + +let hyp_of_var sigma v = SsrHyp (Loc.tag @@ EConstr.destVar sigma v) + +let interp_clr sigma = function +| Some clr, (k, c) + when (k = xNoFlag || k = xWithAt) && is_pf_var sigma c -> + hyp_of_var sigma c :: clr +| Some clr, _ -> clr +| None, _ -> [] + +(** Basic tacticals *) + +(** Multipliers {{{ ***********************************************************) + +(* tactical *) + +let tclID tac = tac + +let tclDOTRY n tac = + if n <= 0 then tclIDTAC else + let rec loop i gl = + if i = n then tclTRY tac gl else + tclTRY (tclTHEN tac (loop (i + 1))) gl in + loop 1 + +let tclDO n tac = + let prefix i = str"At iteration " ++ int i ++ str": " in + let tac_err_at i gl = + try tac gl + with + | CErrors.UserError (l, s) as e -> + let _, info = CErrors.push e in + let e' = CErrors.UserError (l, prefix i ++ s) in + Util.iraise (e', info) + | Ploc.Exc(loc, CErrors.UserError (l, s)) -> + raise (Ploc.Exc(loc, CErrors.UserError (l, prefix i ++ s))) in + let rec loop i gl = + if i = n then tac_err_at i gl else + (tclTHEN (tac_err_at i) (loop (i + 1))) gl in + loop 1 + +let tclMULT = function + | 0, May -> tclREPEAT + | 1, May -> tclTRY + | n, May -> tclDOTRY n + | 0, Must -> tclAT_LEAST_ONCE + | n, Must when n > 1 -> tclDO n + | _ -> tclID + +let cleartac clr = check_hyps_uniq [] clr; Proofview.V82.of_tactic (Tactics.clear (hyps_ids clr)) + +(** }}} *) + +(** Generalize tactic *) + +(* XXX the k of the redex should percolate out *) +let pf_interp_gen_aux ist gl to_ind ((oclr, occ), t) = + let pat = interp_cpattern ist gl t None in (* UGLY API *) + let cl, env, sigma = Tacmach.pf_concl gl, pf_env gl, project gl in + let (c, ucst), cl = + try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr cl) pat occ 1 + with NoMatch -> redex_of_pattern env pat, (EConstr.Unsafe.to_constr cl) in + let c = EConstr.of_constr c in + let cl = EConstr.of_constr cl in + let clr = interp_clr sigma (oclr, (tag_of_cpattern t, c)) in + if not(occur_existential sigma c) then + if tag_of_cpattern t = xWithAt then + if not (EConstr.isVar sigma c) then + errorstrm (str "@ can be used with variables only") + else match Tacmach.pf_get_hyp gl (EConstr.destVar sigma c) with + | NamedDecl.LocalAssum _ -> errorstrm (str "@ can be used with let-ins only") + | NamedDecl.LocalDef (name, b, ty) -> true, pat, EConstr.mkLetIn (Name name,b,ty,cl),c,clr,ucst,gl + else let gl, ccl = pf_mkprod gl c cl in false, pat, ccl, c, clr,ucst,gl + else if to_ind && occ = None then + let nv, p, _, ucst' = pf_abs_evars gl (fst pat, c) in + let ucst = Evd.union_evar_universe_context ucst ucst' in + if nv = 0 then anomaly "occur_existential but no evars" else + let gl, pty = pfe_type_of gl p in + false, pat, EConstr.mkProd (constr_name (project gl) c, pty, Tacmach.pf_concl gl), p, clr,ucst,gl + else CErrors.user_err ?loc:(loc_of_cpattern t) (str "generalized term didn't match") + +let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type x xs) + +let genclrtac cl cs clr = + let tclmyORELSE tac1 tac2 gl = + try tac1 gl + with e when CErrors.noncritical e -> tac2 e gl in + (* apply_type may give a type error, but the useful message is + * the one of clear. You type "move: x" and you get + * "x is used in hyp H" instead of + * "The term H has type T x but is expected to have type T x0". *) + tclTHEN + (tclmyORELSE + (apply_type cl cs) + (fun type_err gl -> + tclTHEN + (tclTHEN (Proofview.V82.of_tactic (Tactics.elim_type (EConstr.of_constr + (Universes.constr_of_global @@ Coqlib.build_coq_False ())))) (cleartac clr)) + (fun gl -> raise type_err) + gl)) + (cleartac clr) + +let gentac ist gen gl = +(* ppdebug(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) + let conv, _, cl, c, clr, ucst,gl = pf_interp_gen_aux ist gl false gen in + ppdebug(lazy(str"c@gentac=" ++ pr_econstr c)); + let gl = pf_merge_uc ucst gl in + if conv + then tclTHEN (Proofview.V82.of_tactic (convert_concl cl)) (cleartac clr) gl + else genclrtac cl [c] clr gl + +let genstac (gens, clr) ist = + tclTHENLIST (cleartac clr :: List.rev_map (gentac ist) gens) + +let gen_tmp_ids + ?(ist=Geninterp.({ lfun = Id.Map.empty; extra = Tacinterp.TacStore.empty })) gl += + let gl, ctx = pull_ctx gl in + push_ctxs ctx + (tclTHENLIST + (List.map (fun (id,orig_ref) -> + tclTHEN + (gentac ist ((None,Some(false,[])),cpattern_of_id id)) + (rename_hd_prod orig_ref)) + ctx.tmp_ids) gl) +;; + +let pf_interp_gen ist gl to_ind gen = + let _, _, a, b, c, ucst,gl = pf_interp_gen_aux ist gl to_ind gen in + a, b ,c, pf_merge_uc ucst gl + +(* TASSI: This version of unprotects inlines the unfold tactic definition, + * since we don't want to wipe out let-ins, and it seems there is no flag + * to change that behaviour in the standard unfold code *) +let unprotecttac gl = + let c, gl = pf_mkSsrConst "protect_term" gl in + let prot, _ = EConstr.destConst (project gl) c in + Tacticals.onClause (fun idopt -> + let hyploc = Option.map (fun id -> id, InHyp) idopt in + Proofview.V82.of_tactic (Tactics.reduct_option + (Reductionops.clos_norm_flags + (CClosure.RedFlags.mkflags + [CClosure.RedFlags.fBETA; + CClosure.RedFlags.fCONST prot; + CClosure.RedFlags.fMATCH; + CClosure.RedFlags.fFIX; + CClosure.RedFlags.fCOFIX]), DEFAULTcast) hyploc)) + allHypsAndConcl gl + +let abs_wgen keep_let ist f gen (gl,args,c) = + let sigma, env = project gl, pf_env gl in + let evar_closed t p = + if occur_existential sigma t then + CErrors.user_err ?loc:(loc_of_cpattern p) ~hdr:"ssreflect" + (pr_constr_pat (EConstr.Unsafe.to_constr t) ++ + str" contains holes and matches no subterm of the goal") in + match gen with + | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> + let x = hoi_id x in + let decl = Tacmach.pf_get_hyp gl x in + gl, + (if NamedDecl.is_local_def decl then args else EConstr.mkVar x :: args), + EConstr.mkProd_or_LetIn (decl |> NamedDecl.to_rel_decl |> RelDecl.set_name (Name (f x))) + (EConstr.Vars.subst_var x c) + | _, Some ((x, _), None) -> + let x = hoi_id x in + gl, EConstr.mkVar x :: args, EConstr.mkProd (Name (f x),Tacmach.pf_get_hyp_typ gl x, EConstr.Vars.subst_var x c) + | _, Some ((x, "@"), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern ist gl p None in + let (t, ucst), c = + try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 + with NoMatch -> redex_of_pattern env cp, (EConstr.Unsafe.to_constr c) in + let c = EConstr.of_constr c in + let t = EConstr.of_constr t in + evar_closed t p; + let ut = red_product_skip_id env sigma t in + let gl, ty = pfe_type_of gl t in + pf_merge_uc ucst gl, args, EConstr.mkLetIn(Name (f x), ut, ty, c) + | _, Some ((x, _), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern ist gl p None in + let (t, ucst), c = + try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 + with NoMatch -> redex_of_pattern env cp, (EConstr.Unsafe.to_constr c) in + let c = EConstr.of_constr c in + let t = EConstr.of_constr t in + evar_closed t p; + let gl, ty = pfe_type_of gl t in + pf_merge_uc ucst gl, t :: args, EConstr.mkProd(Name (f x), ty, c) + | _ -> gl, args, c + +let clr_of_wgen gen clrs = match gen with + | clr, Some ((x, _), None) -> + let x = hoi_id x in + cleartac clr :: cleartac [SsrHyp(Loc.tag x)] :: clrs + | clr, _ -> cleartac clr :: clrs + + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli new file mode 100644 index 000000000..834b7b722 --- /dev/null +++ b/plugins/ssr/ssrcommon.mli @@ -0,0 +1,410 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names +open Environ +open Proof_type +open Evd +open Constrexpr +open Ssrast + +open Ltac_plugin +open Genarg + +val allocc : ssrocc + +(******************************** hyps ************************************) + +val hyp_id : ssrhyp -> Id.t +val hyps_ids : ssrhyps -> Id.t list +val check_hyp_exists : ('a, 'b) Context.Named.pt -> ssrhyp -> unit +val test_hypname_exists : ('a, 'b) Context.Named.pt -> Id.t -> bool +val check_hyps_uniq : Id.t list -> ssrhyps -> unit +val not_section_id : Id.t -> bool +val hyp_err : ?loc:Loc.t -> string -> Id.t -> 'a +val hoik : (ssrhyp -> 'a) -> ssrhyp_or_id -> 'a +val hoi_id : ssrhyp_or_id -> Id.t + +(******************************* hints ***********************************) + +val mk_hint : 'a -> 'a ssrhint +val mk_orhint : 'a -> bool * 'a +val nullhint : bool * 'a list +val nohint : 'a ssrhint + +(******************************** misc ************************************) + +val errorstrm : Pp.std_ppcmds -> 'a +val anomaly : string -> 'a + +val array_app_tl : 'a array -> 'a list -> 'a list +val array_list_of_tl : 'a array -> 'a list +val array_fold_right_from : int -> ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b + +(**************************** lifted tactics ******************************) + +(* tactics with extra data attached to each goals, e.g. the list of + * temporary variables to be cleared *) +type 'a tac_a = (goal * 'a) sigma -> (goal * 'a) list sigma + +(* Thread around names to be cleared or generalized back, and the speed *) +type tac_ctx = { + tmp_ids : (Id.t * name ref) list; + wild_ids : Id.t list; + (* List of variables to be cleared at the end of the sentence *) + delayed_clears : Id.t list; +} + +val new_ctx : unit -> tac_ctx (* REMOVE *) +val pull_ctxs : ('a * tac_ctx) list sigma -> 'a list sigma * tac_ctx list (* REMOVE *) + +val with_fresh_ctx : tac_ctx tac_a -> tactic + +val pull_ctx : ('a * tac_ctx) sigma -> 'a sigma * tac_ctx +val push_ctx : tac_ctx -> 'a sigma -> ('a * tac_ctx) sigma +val push_ctxs : tac_ctx -> 'a list sigma -> ('a * tac_ctx) list sigma +val tac_ctx : tactic -> tac_ctx tac_a +val with_ctx : + (tac_ctx -> 'b * tac_ctx) -> ('a * tac_ctx) sigma -> 'b * ('a * tac_ctx) sigma +val without_ctx : ('a sigma -> 'b) -> ('a * tac_ctx) sigma -> 'b + +(* Standard tacticals lifted to the tac_a type *) +val tclTHENLIST_a : tac_ctx tac_a list -> tac_ctx tac_a +val tclTHEN_i_max : + tac_ctx tac_a -> (int -> int -> tac_ctx tac_a) -> tac_ctx tac_a +val tclTHEN_a : tac_ctx tac_a -> tac_ctx tac_a -> tac_ctx tac_a +val tclTHENS_a : tac_ctx tac_a -> tac_ctx tac_a list -> tac_ctx tac_a + +val tac_on_all : + (goal * tac_ctx) list sigma -> tac_ctx tac_a -> (goal * tac_ctx) list sigma +(************************ ssr tactic arguments ******************************) + + +(*********************** Misc helpers *****************************) +val mkRHole : Glob_term.glob_constr +val mkRHoles : int -> Glob_term.glob_constr list +val isRHoles : Glob_term.glob_constr list -> bool +val mkRApp : Glob_term.glob_constr -> Glob_term.glob_constr list -> Glob_term.glob_constr +val mkRVar : Id.t -> Glob_term.glob_constr +val mkRltacVar : Id.t -> Glob_term.glob_constr +val mkRCast : Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr +val mkRType : Glob_term.glob_constr +val mkRProp : Glob_term.glob_constr +val mkRArrow : Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr +val mkRConstruct : Names.constructor -> Glob_term.glob_constr +val mkRInd : Names.inductive -> Glob_term.glob_constr +val mkRLambda : Name.t -> Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr +val mkRnat : int -> Glob_term.glob_constr + + +val mkCHole : Loc.t option -> constr_expr +val mkCHoles : ?loc:Loc.t -> int -> constr_expr list +val mkCVar : ?loc:Loc.t -> Id.t -> constr_expr +val mkCCast : ?loc:Loc.t -> constr_expr -> constr_expr -> constr_expr +val mkCType : Loc.t option -> constr_expr +val mkCProp : Loc.t option -> constr_expr +val mkCArrow : ?loc:Loc.t -> constr_expr -> constr_expr -> constr_expr +val mkCLambda : ?loc:Loc.t -> Name.t -> constr_expr -> constr_expr -> constr_expr + +val isCHoles : constr_expr list -> bool +val isCxHoles : (constr_expr * 'a option) list -> bool + +val intern_term : + Tacinterp.interp_sign -> env -> + ssrterm -> Glob_term.glob_constr + +val pf_intern_term : + Tacinterp.interp_sign -> Proof_type.goal Evd.sigma -> + ssrterm -> Glob_term.glob_constr + +val interp_term : + Tacinterp.interp_sign -> Proof_type.goal Evd.sigma -> + ssrterm -> evar_map * EConstr.t + +val interp_wit : + ('a, 'b, 'c) genarg_type -> ist -> goal sigma -> 'b -> evar_map * 'c + +val interp_hyp : ist -> goal sigma -> ssrhyp -> evar_map * ssrhyp +val interp_hyps : ist -> goal sigma -> ssrhyps -> evar_map * ssrhyps + +val interp_refine : + Tacinterp.interp_sign -> Proof_type.goal Evd.sigma -> + Glob_term.glob_constr -> evar_map * (evar_map * EConstr.constr) + +val interp_open_constr : + Tacinterp.interp_sign -> Proof_type.goal Evd.sigma -> + Tacexpr.glob_constr_and_expr -> evar_map * (evar_map * EConstr.t) + +val pf_e_type_of : + Proof_type.goal Evd.sigma -> + EConstr.constr -> Proof_type.goal Evd.sigma * EConstr.types + +val splay_open_constr : + Proof_type.goal Evd.sigma -> + evar_map * EConstr.t -> + (Names.Name.t * EConstr.t) list * EConstr.t +val isAppInd : Proof_type.goal Evd.sigma -> EConstr.types -> bool +val interp_view_nbimps : + Tacinterp.interp_sign -> + Proof_type.goal Evd.sigma -> Glob_term.glob_constr -> int +val interp_nbargs : + Tacinterp.interp_sign -> + Proof_type.goal Evd.sigma -> Glob_term.glob_constr -> int + + +val mk_term : ssrtermkind -> 'b -> ssrtermkind * (Glob_term.glob_constr * 'b option) +val mk_lterm : 'a -> ssrtermkind * (Glob_term.glob_constr * 'a option) + +val is_internal_name : string -> bool +val add_internal_name : (string -> bool) -> unit +val mk_internal_id : string -> Id.t +val mk_tagged_id : string -> int -> Id.t +val mk_evar_name : int -> Name.t +val ssr_anon_hyp : string +val pf_type_id : Proof_type.goal Evd.sigma -> EConstr.types -> Id.t + +val pf_abs_evars : + Proof_type.goal Evd.sigma -> + evar_map * EConstr.t -> + int * EConstr.t * Constr.existential_key list * + Evd.evar_universe_context +val pf_abs_evars2 : (* ssr2 *) + Proof_type.goal Evd.sigma -> Evar.t list -> + evar_map * EConstr.t -> + int * EConstr.t * Constr.existential_key list * + Evd.evar_universe_context +val pf_abs_cterm : + Proof_type.goal Evd.sigma -> int -> EConstr.t -> EConstr.t + +val pf_merge_uc : + Evd.evar_universe_context -> 'a Evd.sigma -> 'a Evd.sigma +val pf_merge_uc_of : + evar_map -> 'a Evd.sigma -> 'a Evd.sigma +val constr_name : evar_map -> EConstr.t -> Name.t +val pf_type_of : + Proof_type.goal Evd.sigma -> + Term.constr -> Proof_type.goal Evd.sigma * Term.types +val pfe_type_of : + Proof_type.goal Evd.sigma -> + EConstr.t -> Proof_type.goal Evd.sigma * EConstr.types +val pf_abs_prod : + Names.name -> + Proof_type.goal Evd.sigma -> + EConstr.t -> + EConstr.t -> Proof_type.goal Evd.sigma * EConstr.types +val pf_mkprod : + Proof_type.goal Evd.sigma -> + EConstr.t -> + ?name:Names.name -> + EConstr.t -> Proof_type.goal Evd.sigma * EConstr.types + +val mkSsrRRef : string -> Glob_term.glob_constr * 'a option +val mkSsrRef : string -> Globnames.global_reference +val mkSsrConst : + string -> + env -> evar_map -> evar_map * EConstr.t +val pf_mkSsrConst : + string -> + Proof_type.goal Evd.sigma -> + EConstr.t * Proof_type.goal Evd.sigma +val new_wild_id : tac_ctx -> Names.identifier * tac_ctx + + +val pf_fresh_global : + Globnames.global_reference -> + Proof_type.goal Evd.sigma -> + Term.constr * Proof_type.goal Evd.sigma + +val is_discharged_id : Id.t -> bool +val mk_discharged_id : Id.t -> Id.t +val is_tagged : string -> string -> bool +val has_discharged_tag : string -> bool +val ssrqid : string -> Libnames.qualid +val new_tmp_id : + tac_ctx -> (Names.identifier * Names.name ref) * tac_ctx +val mk_anon_id : string -> Proof_type.goal Evd.sigma -> Id.t +val pf_abs_evars_pirrel : + Proof_type.goal Evd.sigma -> + evar_map * Term.constr -> int * Term.constr +val pf_nbargs : Proof_type.goal Evd.sigma -> EConstr.t -> int +val gen_tmp_ids : + ?ist:Geninterp.interp_sign -> + (Proof_type.goal * tac_ctx) Evd.sigma -> + (Proof_type.goal * tac_ctx) list Evd.sigma + +val ssrevaltac : Tacinterp.interp_sign -> Tacinterp.Value.t -> Proofview.V82.tac + +val convert_concl_no_check : EConstr.t -> unit Proofview.tactic +val convert_concl : EConstr.t -> unit Proofview.tactic + +val red_safe : + Reductionops.reduction_function -> + env -> evar_map -> EConstr.t -> EConstr.t + +val red_product_skip_id : + env -> evar_map -> EConstr.t -> EConstr.t + +val ssrautoprop_tac : + (Constr.existential_key Evd.sigma -> Constr.existential_key list Evd.sigma) ref + +val mkProt : + EConstr.t -> + EConstr.t -> + Proof_type.goal Evd.sigma -> + EConstr.t * Proof_type.goal Evd.sigma + +val mkEtaApp : EConstr.t -> int -> int -> EConstr.t + +val mkRefl : + EConstr.t -> + EConstr.t -> + Proof_type.goal Evd.sigma -> EConstr.t * Proof_type.goal Evd.sigma + +val discharge_hyp : + Id.t * (Id.t * string) -> + Proof_type.goal Evd.sigma -> Evar.t list Evd.sigma + +val clear_wilds_and_tmp_and_delayed_ids : + (Proof_type.goal * tac_ctx) Evd.sigma -> + (Proof_type.goal * tac_ctx) list Evd.sigma + +val view_error : string -> ssrterm -> 'a + + +val top_id : Id.t + +val pf_abs_ssrterm : + ?resolve_typeclasses:bool -> + ist -> + Proof_type.goal Evd.sigma -> + ssrterm -> + evar_map * EConstr.t * Evd.evar_universe_context * int + +val pf_interp_ty : + ?resolve_typeclasses:bool -> + Tacinterp.interp_sign -> + Proof_type.goal Evd.sigma -> + Ssrast.ssrtermkind * + (Glob_term.glob_constr * Constrexpr.constr_expr option) -> + int * EConstr.t * EConstr.t * Evd.evar_universe_context + +val ssr_n_tac : string -> int -> v82tac +val donetac : int -> v82tac + +val applyn : + with_evars:bool -> + ?beta:bool -> + ?with_shelve:bool -> + int -> + EConstr.t -> v82tac +exception NotEnoughProducts +val pf_saturate : + ?beta:bool -> + ?bi_types:bool -> + Proof_type.goal Evd.sigma -> + EConstr.constr -> + ?ty:EConstr.types -> + int -> + EConstr.constr * EConstr.types * (int * EConstr.constr) list * + Proof_type.goal Evd.sigma +val saturate : + ?beta:bool -> + ?bi_types:bool -> + env -> + evar_map -> + EConstr.constr -> + ?ty:EConstr.types -> + int -> + EConstr.constr * EConstr.types * (int * EConstr.constr) list * evar_map +val refine_with : + ?first_goes_last:bool -> + ?beta:bool -> + ?with_evars:bool -> + evar_map * EConstr.t -> v82tac +(*********************** Wrapped Coq tactics *****************************) + +val rewritetac : ssrdir -> EConstr.t -> tactic + +type name_hint = (int * EConstr.types array) option ref + +val gentac : + (Geninterp.interp_sign -> + (Ssrast.ssrdocc) * + Ssrmatching_plugin.Ssrmatching.cpattern -> Proof_type.tactic) + +val genstac : + ((Ssrast.ssrhyp list option * Ssrmatching_plugin.Ssrmatching.occ) * + Ssrmatching_plugin.Ssrmatching.cpattern) + list * Ssrast.ssrhyp list -> + Tacinterp.interp_sign -> Proof_type.tactic + +val pf_interp_gen : + Tacinterp.interp_sign -> + Proof_type.goal Evd.sigma -> + bool -> + (Ssrast.ssrhyp list option * Ssrmatching_plugin.Ssrmatching.occ) * + Ssrmatching_plugin.Ssrmatching.cpattern -> + EConstr.t * EConstr.t * Ssrast.ssrhyp list * + Proof_type.goal Evd.sigma + +val pf_interp_gen_aux : + Tacinterp.interp_sign -> + Proof_type.goal Evd.sigma -> + bool -> + (Ssrast.ssrhyp list option * Ssrmatching_plugin.Ssrmatching.occ) * + Ssrmatching_plugin.Ssrmatching.cpattern -> + bool * Ssrmatching_plugin.Ssrmatching.pattern * EConstr.t * + EConstr.t * Ssrast.ssrhyp list * Evd.evar_universe_context * + Proof_type.goal Evd.sigma + +val is_name_in_ipats : + Id.t -> ssripats -> bool + +type profiler = { + profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; + reset : unit -> unit; + print : unit -> unit } + +val mk_profiler : string -> profiler + +(** Basic tactics *) + +val introid : ?orig:name ref -> Id.t -> v82tac +val intro_anon : v82tac +val intro_all : v82tac + +val interp_clr : + evar_map -> ssrhyps option * (ssrtermkind * EConstr.t) -> ssrhyps + +val genclrtac : + EConstr.constr -> + EConstr.constr list -> Ssrast.ssrhyp list -> Proof_type.tactic +val cleartac : ssrhyps -> v82tac + +val tclMULT : int * ssrmmod -> Proof_type.tactic -> Proof_type.tactic + +val unprotecttac : Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + +val abs_wgen : + bool -> + Tacinterp.interp_sign -> + (Id.t -> Id.t) -> + 'a * + ((Ssrast.ssrhyp_or_id * string) * + Ssrmatching_plugin.Ssrmatching.cpattern option) + option -> + Proof_type.goal Evd.sigma * EConstr.t list * EConstr.t -> + Proof_type.goal Evd.sigma * EConstr.t list * EConstr.t + +val clr_of_wgen : + ssrhyps * ((ssrhyp_or_id * 'a) * 'b option) option -> + Proofview.V82.tac list -> Proofview.V82.tac list + + diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v new file mode 100644 index 000000000..1c599ac8c --- /dev/null +++ b/plugins/ssr/ssreflect.v @@ -0,0 +1,451 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +Require Import Bool. (* For bool_scope delimiter 'bool'. *) +Require Import ssrmatching. +Declare ML Module "ssreflect_plugin". + +(******************************************************************************) +(* This file is the Gallina part of the ssreflect plugin implementation. *) +(* Files that use the ssreflect plugin should always Require ssreflect and *) +(* either Import ssreflect or Import ssreflect.SsrSyntax. *) +(* Part of the contents of this file is technical and will only interest *) +(* advanced developers; in addition the following are defined: *) +(* [the str of v by f] == the Canonical s : str such that f s = v. *) +(* [the str of v] == the Canonical s : str that coerces to v. *) +(* argumentType c == the T such that c : forall x : T, P x. *) +(* returnType c == the R such that c : T -> R. *) +(* {type of c for s} == P s where c : forall x : T, P x. *) +(* phantom T v == singleton type with inhabitant Phantom T v. *) +(* phant T == singleton type with inhabitant Phant v. *) +(* =^~ r == the converse of rewriting rule r (e.g., in a *) +(* rewrite multirule). *) +(* unkeyed t == t, but treated as an unkeyed matching pattern by *) +(* the ssreflect matching algorithm. *) +(* nosimpl t == t, but on the right-hand side of Definition C := *) +(* nosimpl disables expansion of C by /=. *) +(* locked t == t, but locked t is not convertible to t. *) +(* locked_with k t == t, but not convertible to t or locked_with k' t *) +(* unless k = k' (with k : unit). Coq type-checking *) +(* will be much more efficient if locked_with with a *) +(* bespoke k is used for sealed definitions. *) +(* unlockable v == interface for sealed constant definitions of v. *) +(* Unlockable def == the unlockable that registers def : C = v. *) +(* [unlockable of C] == a clone for C of the canonical unlockable for the *) +(* definition of C (e.g., if it uses locked_with). *) +(* [unlockable fun C] == [unlockable of C] with the expansion forced to be *) +(* an explicit lambda expression. *) +(* -> The usage pattern for ADT operations is: *) +(* Definition foo_def x1 .. xn := big_foo_expression. *) +(* Fact foo_key : unit. Proof. by []. Qed. *) +(* Definition foo := locked_with foo_key foo_def. *) +(* Canonical foo_unlockable := [unlockable fun foo]. *) +(* This minimizes the comparison overhead for foo, while still allowing *) +(* rewrite unlock to expose big_foo_expression. *) +(* More information about these definitions and their use can be found in the *) +(* ssreflect manual, and in specific comments below. *) +(******************************************************************************) + + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module SsrSyntax. + +(* Declare Ssr keywords: 'is' 'of' '//' '/=' and '//='. We also declare the *) +(* parsing level 8, as a workaround for a notation grammar factoring problem. *) +(* Arguments of application-style notations (at level 10) should be declared *) +(* at level 8 rather than 9 or the camlp5 grammar will not factor properly. *) + +Reserved Notation "(* x 'is' y 'of' z 'isn't' // /= //= *)" (at level 8). +Reserved Notation "(* 69 *)" (at level 69). + +(* Non ambiguous keyword to check if the SsrSyntax module is imported *) +Reserved Notation "(* Use to test if 'SsrSyntax_is_Imported' *)" (at level 8). + +Reserved Notation "<hidden n >" (at level 200). +Reserved Notation "T (* n *)" (at level 200, format "T (* n *)"). + +End SsrSyntax. + +Export SsrMatchingSyntax. +Export SsrSyntax. + +(* Make the general "if" into a notation, so that we can override it below. *) +(* The notations are "only parsing" because the Coq decompiler will not *) +(* recognize the expansion of the boolean if; using the default printer *) +(* avoids a spurrious trailing %GEN_IF. *) + +Delimit Scope general_if_scope with GEN_IF. + +Notation "'if' c 'then' v1 'else' v2" := + (if c then v1 else v2) + (at level 200, c, v1, v2 at level 200, only parsing) : general_if_scope. + +Notation "'if' c 'return' t 'then' v1 'else' v2" := + (if c return t then v1 else v2) + (at level 200, c, t, v1, v2 at level 200, only parsing) : general_if_scope. + +Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := + (if c as x return t then v1 else v2) + (at level 200, c, t, v1, v2 at level 200, x ident, only parsing) + : general_if_scope. + +(* Force boolean interpretation of simple if expressions. *) + +Delimit Scope boolean_if_scope with BOOL_IF. + +Notation "'if' c 'return' t 'then' v1 'else' v2" := + (if c%bool is true in bool return t then v1 else v2) : boolean_if_scope. + +Notation "'if' c 'then' v1 'else' v2" := + (if c%bool is true in bool return _ then v1 else v2) : boolean_if_scope. + +Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := + (if c%bool is true as x in bool return t then v1 else v2) : boolean_if_scope. + +Open Scope boolean_if_scope. + +(* To allow a wider variety of notations without reserving a large number of *) +(* of identifiers, the ssreflect library systematically uses "forms" to *) +(* enclose complex mixfix syntax. A "form" is simply a mixfix expression *) +(* enclosed in square brackets and introduced by a keyword: *) +(* [keyword ... ] *) +(* Because the keyword follows a bracket it does not need to be reserved. *) +(* Non-ssreflect libraries that do not respect the form syntax (e.g., the Coq *) +(* Lists library) should be loaded before ssreflect so that their notations *) +(* do not mask all ssreflect forms. *) +Delimit Scope form_scope with FORM. +Open Scope form_scope. + +(* Allow overloading of the cast (x : T) syntax, put whitespace around the *) +(* ":" symbol to avoid lexical clashes (and for consistency with the parsing *) +(* precedence of the notation, which binds less tightly than application), *) +(* and put printing boxes that print the type of a long definition on a *) +(* separate line rather than force-fit it at the right margin. *) +Notation "x : T" := (x : T) + (at level 100, right associativity, + format "'[hv' x '/ ' : T ']'") : core_scope. + +(* Allow the casual use of notations like nat * nat for explicit Type *) +(* declarations. Note that (nat * nat : Type) is NOT equivalent to *) +(* (nat * nat)%type, whose inferred type is legacy type "Set". *) +Notation "T : 'Type'" := (T%type : Type) + (at level 100, only parsing) : core_scope. +(* Allow similarly Prop annotation for, e.g., rewrite multirules. *) +Notation "P : 'Prop'" := (P%type : Prop) + (at level 100, only parsing) : core_scope. + +(* Constants for abstract: and [: name ] intro pattern *) +Definition abstract_lock := unit. +Definition abstract_key := tt. + +Definition abstract (statement : Type) (id : nat) (lock : abstract_lock) := + let: tt := lock in statement. + +Notation "<hidden n >" := (abstract _ n _). +Notation "T (* n *)" := (abstract T n abstract_key). + +(* Constants for tactic-views *) +Inductive external_view : Type := tactic_view of Type. + +(* Syntax for referring to canonical structures: *) +(* [the struct_type of proj_val by proj_fun] *) +(* This form denotes the Canonical instance s of the Structure type *) +(* struct_type whose proj_fun projection is proj_val, i.e., such that *) +(* proj_fun s = proj_val. *) +(* Typically proj_fun will be A record field accessors of struct_type, but *) +(* this need not be the case; it can be, for instance, a field of a record *) +(* type to which struct_type coerces; proj_val will likewise be coerced to *) +(* the return type of proj_fun. In all but the simplest cases, proj_fun *) +(* should be eta-expanded to allow for the insertion of implicit arguments. *) +(* In the common case where proj_fun itself is a coercion, the "by" part *) +(* can be omitted entirely; in this case it is inferred by casting s to the *) +(* inferred type of proj_val. Obviously the latter can be fixed by using an *) +(* explicit cast on proj_val, and it is highly recommended to do so when the *) +(* return type intended for proj_fun is "Type", as the type inferred for *) +(* proj_val may vary because of sort polymorphism (it could be Set or Prop). *) +(* Note when using the [the _ of _] form to generate a substructure from a *) +(* telescopes-style canonical hierarchy (implementing inheritance with *) +(* coercions), one should always project or coerce the value to the BASE *) +(* structure, because Coq will only find a Canonical derived structure for *) +(* the Canonical base structure -- not for a base structure that is specific *) +(* to proj_value. *) + +Module TheCanonical. + +CoInductive put vT sT (v1 v2 : vT) (s : sT) := Put. + +Definition get vT sT v s (p : @put vT sT v v s) := let: Put _ _ _ := p in s. + +Definition get_by vT sT of sT -> vT := @get vT sT. + +End TheCanonical. + +Import TheCanonical. (* Note: no export. *) + +Local Arguments get_by _%type_scope _%type_scope _ _ _ _. + +Notation "[ 'the' sT 'of' v 'by' f ]" := + (@get_by _ sT f _ _ ((fun v' (s : sT) => Put v' (f s) s) v _)) + (at level 0, only parsing) : form_scope. + +Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*)s s) _)) + (at level 0, only parsing) : form_scope. + +(* The following are "format only" versions of the above notations. Since Coq *) +(* doesn't provide this facility, we fake it by splitting the "the" keyword. *) +(* We need to do this to prevent the formatter from being be thrown off by *) +(* application collapsing, coercion insertion and beta reduction in the right *) +(* hand side of the notations above. *) + +Notation "[ 'th' 'e' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) + (at level 0, format "[ 'th' 'e' sT 'of' v 'by' f ]") : form_scope. + +Notation "[ 'th' 'e' sT 'of' v ]" := (@get _ sT v _ _) + (at level 0, format "[ 'th' 'e' sT 'of' v ]") : form_scope. + +(* We would like to recognize +Notation "[ 'th' 'e' sT 'of' v : 'Type' ]" := (@get Type sT v _ _) + (at level 0, format "[ 'th' 'e' sT 'of' v : 'Type' ]") : form_scope. +*) + +(* Helper notation for canonical structure inheritance support. *) +(* This is a workaround for the poor interaction between delta reduction and *) +(* canonical projections in Coq's unification algorithm, by which transparent *) +(* definitions hide canonical instances, i.e., in *) +(* Canonical a_type_struct := @Struct a_type ... *) +(* Definition my_type := a_type. *) +(* my_type doesn't effectively inherit the struct structure from a_type. Our *) +(* solution is to redeclare the instance as follows *) +(* Canonical my_type_struct := Eval hnf in [struct of my_type]. *) +(* The special notation [str of _] must be defined for each Strucure "str" *) +(* with constructor "Str", typically as follows *) +(* Definition clone_str s := *) +(* let: Str _ x y ... z := s return {type of Str for s} -> str in *) +(* fun k => k _ x y ... z. *) +(* Notation "[ 'str' 'of' T 'for' s ]" := (@clone_str s (@Str T)) *) +(* (at level 0, format "[ 'str' 'of' T 'for' s ]") : form_scope. *) +(* Notation "[ 'str' 'of' T ]" := (repack_str (fun x => @Str T x)) *) +(* (at level 0, format "[ 'str' 'of' T ]") : form_scope. *) +(* The notation for the match return predicate is defined below; the eta *) +(* expansion in the second form serves both to distinguish it from the first *) +(* and to avoid the delta reduction problem. *) +(* There are several variations on the notation and the definition of the *) +(* the "clone" function, for telescopes, mixin classes, and join (multiple *) +(* inheritance) classes. We describe a different idiom for clones in ssrfun; *) +(* it uses phantom types (see below) and static unification; see fintype and *) +(* ssralg for examples. *) + +Definition argumentType T P & forall x : T, P x := T. +Definition dependentReturnType T P & forall x : T, P x := P. +Definition returnType aT rT & aT -> rT := rT. + +Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) + (at level 0, format "{ 'type' 'of' c 'for' s }") : type_scope. + +(* A generic "phantom" type (actually, a unit type with a phantom parameter). *) +(* This type can be used for type definitions that require some Structure *) +(* on one of their parameters, to allow Coq to infer said structure so it *) +(* does not have to be supplied explicitly or via the "[the _ of _]" notation *) +(* (the latter interacts poorly with other Notation). *) +(* The definition of a (co)inductive type with a parameter p : p_type, that *) +(* needs to use the operations of a structure *) +(* Structure p_str : Type := p_Str {p_repr :> p_type; p_op : p_repr -> ...} *) +(* should be given as *) +(* Inductive indt_type (p : p_str) := Indt ... . *) +(* Definition indt_of (p : p_str) & phantom p_type p := indt_type p. *) +(* Notation "{ 'indt' p }" := (indt_of (Phantom p)). *) +(* Definition indt p x y ... z : {indt p} := @Indt p x y ... z. *) +(* Notation "[ 'indt' x y ... z ]" := (indt x y ... z). *) +(* That is, the concrete type and its constructor should be shadowed by *) +(* definitions that use a phantom argument to infer and display the true *) +(* value of p (in practice, the "indt" constructor often performs additional *) +(* functions, like "locking" the representation -- see below). *) +(* We also define a simpler version ("phant" / "Phant") of phantom for the *) +(* common case where p_type is Type. *) + +CoInductive phantom T (p : T) := Phantom. +Arguments phantom : clear implicits. +Arguments Phantom : clear implicits. +CoInductive phant (p : Type) := Phant. + +(* Internal tagging used by the implementation of the ssreflect elim. *) + +Definition protect_term (A : Type) (x : A) : A := x. + +(* The ssreflect idiom for a non-keyed pattern: *) +(* - unkeyed t wiil match any subterm that unifies with t, regardless of *) +(* whether it displays the same head symbol as t. *) +(* - unkeyed t a b will match any application of a term f unifying with t, *) +(* to two arguments unifying with with a and b, repectively, regardless of *) +(* apparent head symbols. *) +(* - unkeyed x where x is a variable will match any subterm with the same *) +(* type as x (when x would raise the 'indeterminate pattern' error). *) + +Notation unkeyed x := (let flex := x in flex). + +(* Ssreflect converse rewrite rule rule idiom. *) +Definition ssr_converse R (r : R) := (Logic.I, r). +Notation "=^~ r" := (ssr_converse r) (at level 100) : form_scope. + +(* Term tagging (user-level). *) +(* The ssreflect library uses four strengths of term tagging to restrict *) +(* convertibility during type checking: *) +(* nosimpl t simplifies to t EXCEPT in a definition; more precisely, given *) +(* Definition foo := nosimpl bar, foo (or foo t') will NOT be expanded by *) +(* the /= and //= switches unless it is in a forcing context (e.g., in *) +(* match foo t' with ... end, foo t' will be reduced if this allows the *) +(* match to be reduced). Note that nosimpl bar is simply notation for a *) +(* a term that beta-iota reduces to bar; hence rewrite /foo will replace *) +(* foo by bar, and rewrite -/foo will replace bar by foo. *) +(* CAVEAT: nosimpl should not be used inside a Section, because the end of *) +(* section "cooking" removes the iota redex. *) +(* locked t is provably equal to t, but is not convertible to t; 'locked' *) +(* provides support for selective rewriting, via the lock t : t = locked t *) +(* Lemma, and the ssreflect unlock tactic. *) +(* locked_with k t is equal but not convertible to t, much like locked t, *) +(* but supports explicit tagging with a value k : unit. This is used to *) +(* mitigate a flaw in the term comparison heuristic of the Coq kernel, *) +(* which treats all terms of the form locked t as equal and conpares their *) +(* arguments recursively, leading to an exponential blowup of comparison. *) +(* For this reason locked_with should be used rather than locked when *) +(* defining ADT operations. The unlock tactic does not support locked_with *) +(* but the unlock rewrite rule does, via the unlockable interface. *) +(* we also use Module Type ascription to create truly opaque constants, *) +(* because simple expansion of constants to reveal an unreducible term *) +(* doubles the time complexity of a negative comparison. Such opaque *) +(* constants can be expanded generically with the unlock rewrite rule. *) +(* See the definition of card and subset in fintype for examples of this. *) + +Notation nosimpl t := (let: tt := tt in t). + +Lemma master_key : unit. Proof. exact tt. Qed. +Definition locked A := let: tt := master_key in fun x : A => x. + +Lemma lock A x : x = locked x :> A. Proof. unlock; reflexivity. Qed. + +(* Needed for locked predicates, in particular for eqType's. *) +Lemma not_locked_false_eq_true : locked false <> true. +Proof. unlock; discriminate. Qed. + +(* The basic closing tactic "done". *) +Ltac done := + trivial; hnf; intros; solve + [ do ![solve [trivial | apply: sym_equal; trivial] + | discriminate | contradiction | split] + | case not_locked_false_eq_true; assumption + | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. + +(* Quicker done tactic not including split, syntax: /0/ *) +Ltac ssrdone0 := + trivial; hnf; intros; solve + [ do ![solve [trivial | apply: sym_equal; trivial] + | discriminate | contradiction ] + | case not_locked_false_eq_true; assumption + | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. + +(* To unlock opaque constants. *) +Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. +Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. + +Notation "[ 'unlockable' 'of' C ]" := (@Unlockable _ _ C (unlock _)) + (at level 0, format "[ 'unlockable' 'of' C ]") : form_scope. + +Notation "[ 'unlockable' 'fun' C ]" := (@Unlockable _ (fun _ => _) C (unlock _)) + (at level 0, format "[ 'unlockable' 'fun' C ]") : form_scope. + +(* Generic keyed constant locking. *) + +(* The argument order ensures that k is always compared before T. *) +Definition locked_with k := let: tt := k in fun T x => x : T. + +(* This can be used as a cheap alternative to cloning the unlockable instance *) +(* below, but with caution as unkeyed matching can be expensive. *) +Lemma locked_withE T k x : unkeyed (locked_with k x) = x :> T. +Proof. by case: k. Qed. + +(* Intensionaly, this instance will not apply to locked u. *) +Canonical locked_with_unlockable T k x := + @Unlockable T x (locked_with k x) (locked_withE k x). + +(* More accurate variant of unlock, and safer alternative to locked_withE. *) +Lemma unlock_with T k x : unlocked (locked_with_unlockable k x) = x :> T. +Proof. exact: unlock. Qed. + +(* The internal lemmas for the have tactics. *) + +Definition ssr_have Plemma Pgoal (step : Plemma) rest : Pgoal := rest step. +Arguments ssr_have Plemma [Pgoal]. + +Definition ssr_have_let Pgoal Plemma step + (rest : let x : Plemma := step in Pgoal) : Pgoal := rest. +Arguments ssr_have_let [Pgoal]. + +Definition ssr_suff Plemma Pgoal step (rest : Plemma) : Pgoal := step rest. +Arguments ssr_suff Plemma [Pgoal]. + +Definition ssr_wlog := ssr_suff. +Arguments ssr_wlog Plemma [Pgoal]. + +(* Internal N-ary congruence lemmas for the congr tactic. *) + +Fixpoint nary_congruence_statement (n : nat) + : (forall B, (B -> B -> Prop) -> Prop) -> Prop := + match n with + | O => fun k => forall B, k B (fun x1 x2 : B => x1 = x2) + | S n' => + let k' A B e (f1 f2 : A -> B) := + forall x1 x2, x1 = x2 -> (e (f1 x1) (f2 x2) : Prop) in + fun k => forall A, nary_congruence_statement n' (fun B e => k _ (k' A B e)) + end. + +Lemma nary_congruence n (k := fun B e => forall y : B, (e y y : Prop)) : + nary_congruence_statement n k. +Proof. +have: k _ _ := _; rewrite {1}/k. +elim: n k => [|n IHn] k k_P /= A; first exact: k_P. +by apply: IHn => B e He; apply: k_P => f x1 x2 <-. +Qed. + +Lemma ssr_congr_arrow Plemma Pgoal : Plemma = Pgoal -> Plemma -> Pgoal. +Proof. by move->. Qed. +Arguments ssr_congr_arrow : clear implicits. + +(* View lemmas that don't use reflection. *) + +Section ApplyIff. + +Variables P Q : Prop. +Hypothesis eqPQ : P <-> Q. + +Lemma iffLR : P -> Q. Proof. by case: eqPQ. Qed. +Lemma iffRL : Q -> P. Proof. by case: eqPQ. Qed. + +Lemma iffLRn : ~P -> ~Q. Proof. by move=> nP tQ; case: nP; case: eqPQ tQ. Qed. +Lemma iffRLn : ~Q -> ~P. Proof. by move=> nQ tP; case: nQ; case: eqPQ tP. Qed. + +End ApplyIff. + +Hint View for move/ iffLRn|2 iffRLn|2 iffLR|2 iffRL|2. +Hint View for apply/ iffRLn|2 iffLRn|2 iffRL|2 iffLR|2. + +(* To focus non-ssreflect tactics on a subterm, eg vm_compute. *) +(* Usage: *) +(* elim/abstract_context: (pattern) => G defG. *) +(* vm_compute; rewrite {}defG {G}. *) +(* Note that vm_cast are not stored in the proof term *) +(* for reductions occuring in the context, hence *) +(* set here := pattern; vm_compute in (value of here) *) +(* blows up at Qed time. *) +Lemma abstract_context T (P : T -> Type) x : + (forall Q, Q = P -> Q x) -> P x. +Proof. by move=> /(_ P); apply. Qed. diff --git a/plugins/ssr/ssreflect_plugin.mlpack b/plugins/ssr/ssreflect_plugin.mlpack new file mode 100644 index 000000000..824348fee --- /dev/null +++ b/plugins/ssr/ssreflect_plugin.mlpack @@ -0,0 +1,13 @@ +Ssrast +Ssrprinters +Ssrcommon +Ssrtacticals +Ssrelim +Ssrview +Ssrbwd +Ssrequality +Ssripats +Ssrfwd +Ssrparser +Ssrvernac + diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml new file mode 100644 index 000000000..832044909 --- /dev/null +++ b/plugins/ssr/ssrelim.ml @@ -0,0 +1,441 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Util +open Names +open Printer +open Term +open Termops +open Globnames +open Misctypes +open Tacmach + +open Ssrmatching_plugin +open Ssrmatching + +open Ssrast +open Ssrprinters +open Ssrcommon + +module RelDecl = Context.Rel.Declaration + +(** The "case" and "elim" tactic *) + +let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type x xs) + +(* TASSI: given the type of an elimination principle, it finds the higher order + * argument (index), it computes it's arity and the arity of the eliminator and + * checks if the eliminator is recursive or not *) +let analyze_eliminator elimty env sigma = + let rec loop ctx t = match EConstr.kind_of_type sigma t with + | AtomicType (hd, args) when EConstr.isRel sigma hd -> + ctx, EConstr.destRel sigma hd, not (EConstr.Vars.noccurn sigma 1 t), Array.length args, t + | CastType (t, _) -> loop ctx t + | ProdType (x, ty, t) -> loop (RelDecl.LocalAssum (x, ty) :: ctx) t + | LetInType (x,b,ty,t) -> loop (RelDecl.LocalDef (x, b, ty) :: ctx) (EConstr.Vars.subst1 b t) + | _ -> + let env' = EConstr.push_rel_context ctx env in + let t' = Reductionops.whd_all env' sigma t in + if not (EConstr.eq_constr sigma t t') then loop ctx t' else + errorstrm Pp.(str"The eliminator has the wrong shape."++spc()++ + str"A (applied) bound variable was expected as the conclusion of "++ + str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_econstr elimty) in + let ctx, pred_id, elim_is_dep, n_pred_args,concl = loop [] elimty in + let n_elim_args = Context.Rel.nhyps ctx in + let is_rec_elim = + let count_occurn n term = + let count = ref 0 in + let rec occur_rec n c = match EConstr.kind sigma c with + | Rel m -> if m = n then incr count + | _ -> EConstr.iter_with_binders sigma succ occur_rec n c + in + occur_rec n term; !count in + let occurr2 n t = count_occurn n t > 1 in + not (List.for_all_i + (fun i (_,rd) -> pred_id <= i || not (occurr2 (pred_id - i) rd)) + 1 (assums_of_rel_context ctx)) + in + n_elim_args - pred_id, n_elim_args, is_rec_elim, elim_is_dep, n_pred_args, + (ctx,concl) + +let subgoals_tys sigma (relctx, concl) = + let rec aux cur_depth acc = function + | hd :: rest -> + let ty = Context.Rel.Declaration.get_type hd in + if EConstr.Vars.noccurn sigma cur_depth concl && + List.for_all_i (fun i -> function + | Context.Rel.Declaration.LocalAssum(_, t) -> + EConstr.Vars.noccurn sigma i t + | Context.Rel.Declaration.LocalDef (_, b, t) -> + EConstr.Vars.noccurn sigma i t && EConstr.Vars.noccurn sigma i b) 1 rest + then aux (cur_depth - 1) (ty :: acc) rest + else aux (cur_depth - 1) acc rest + | [] -> Array.of_list (List.rev acc) + in + aux (List.length relctx) [] (List.rev relctx) + +(* A case without explicit dependent terms but with both a view and an *) +(* occurrence switch and/or an equation is treated as dependent, with the *) +(* viewed term as the dependent term (the occurrence switch would be *) +(* meaningless otherwise). When both a view and explicit dependents are *) +(* present, it is forbidden to put a (meaningless) occurrence switch on *) +(* the viewed term. *) + +(* This is both elim and case (defaulting to the former). If ~elim is omitted + * the standard eliminator is chosen. The code is made of 4 parts: + * 1. find the eliminator if not given as ~elim and analyze it + * 2. build the patterns to be matched against the conclusion, looking at + * (occ, c), deps and the pattern inferred from the type of the eliminator + * 3. build the new predicate matching the patterns, and the tactic to + * generalize the equality in case eqid is not None + * 4. build the tactic handle intructions and clears as required in ipats and + * by eqid *) +let ssrelim ?(ind=ref None) ?(is_case=false) ?ist deps what ?elim eqid elim_intro_tac gl = + (* some sanity checks *) + let oc, orig_clr, occ, c_gen, gl = match what with + | `EConstr(_,_,t) when EConstr.isEvar (project gl) t -> + anomaly "elim called on a constr evar" + | `EGen _ when ist = None -> + anomaly "no ist and non simple elimination" + | `EGen (_, g) when elim = None && is_wildcard g -> + errorstrm Pp.(str"Indeterminate pattern and no eliminator") + | `EGen ((Some clr,occ), g) when is_wildcard g -> + None, clr, occ, None, gl + | `EGen ((None, occ), g) when is_wildcard g -> None,[],occ,None,gl + | `EGen ((_, occ), p as gen) -> + let _, c, clr,gl = pf_interp_gen (Option.get ist) gl true gen in + Some c, clr, occ, Some p,gl + | `EConstr (clr, occ, c) -> Some c, clr, occ, None,gl in + let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in + ppdebug(lazy(Pp.str(if is_case then "==CASE==" else "==ELIM=="))); + let fire_subst gl t = Reductionops.nf_evar (project gl) t in + let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in + let eq = EConstr.of_constr eq in + let is_undef_pat = function + | sigma, T t -> EConstr.isEvar sigma (EConstr.of_constr t) + | _ -> false in + let match_pat env p occ h cl = + let sigma0 = project orig_gl in + ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern p)); + let (c,ucst), cl = + fill_occ_pattern ~raise_NoMatch:true env sigma0 (EConstr.Unsafe.to_constr cl) p occ h in + ppdebug(lazy Pp.(str" got: " ++ pr_constr c)); + c, EConstr.of_constr cl, ucst in + let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env (project gl) t n in + Evd.merge_universe_context sigma ucst, T (EConstr.Unsafe.to_constr t) in + let unif_redex gl (sigma, r as p) t = (* t is a hint for the redex of p *) + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env sigma t n in + let sigma = Evd.merge_universe_context sigma ucst in + match r with + | X_In_T (e, p) -> sigma, E_As_X_In_T (EConstr.Unsafe.to_constr t, e, p) + | _ -> + try unify_HO env sigma t (EConstr.of_constr (fst (redex_of_pattern env p))), r + with e when CErrors.noncritical e -> p in + (* finds the eliminator applies it to evars and c saturated as needed *) + (* obtaining "elim ??? (c ???)". pred is the higher order evar *) + (* cty is None when the user writes _ (hence we can't make a pattern *) + let cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl = + match elim with + | Some elim -> + let gl, elimty = pf_e_type_of gl elim in + let pred_id, n_elim_args, is_rec, elim_is_dep, n_pred_args,ctx_concl = + analyze_eliminator elimty env (project gl) in + ind := Some (0, subgoals_tys (project gl) ctx_concl); + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let elimty = Reductionops.whd_all env (project gl) elimty in + let cty, gl = + if Option.is_empty oc then None, gl + else + let c = Option.get oc in let gl, c_ty = pfe_type_of gl c in + let pc = match c_gen with + | Some p -> interp_cpattern (Option.get ist) orig_gl p None + | _ -> mkTpat gl c in + Some(c, c_ty, pc), gl in + cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + | None -> + let c = Option.get oc in let gl, c_ty = pfe_type_of gl c in + let ((kn, i),_ as indu), unfolded_c_ty = + pf_reduce_to_quantified_ind gl c_ty in + let sort = Tacticals.elimination_sort_of_goal gl in + let gl, elim = + if not is_case then + let t,gl= pf_fresh_global (Indrec.lookup_eliminator (kn,i) sort) gl in + gl, t + else + Tacmach.pf_eapply (fun env sigma () -> + let indu = (fst indu, EConstr.EInstance.kind sigma (snd indu)) in + let (sigma, ind) = Indrec.build_case_analysis_scheme env sigma indu true sort in + (sigma, ind)) gl () in + let elim = EConstr.of_constr elim in + let gl, elimty = pfe_type_of gl elim in + let pred_id,n_elim_args,is_rec,elim_is_dep,n_pred_args,ctx_concl = + analyze_eliminator elimty env (project gl) in + if is_case then + let mind,indb = Inductive.lookup_mind_specif env (kn,i) in + ind := Some(mind.Declarations.mind_nparams,Array.map EConstr.of_constr indb.Declarations.mind_nf_lc); + else + ind := Some (0, subgoals_tys (project gl) ctx_concl); + let rctx = fst (EConstr.decompose_prod_assum (project gl) unfolded_c_ty) in + let n_c_args = Context.Rel.length rctx in + let c, c_ty, t_args, gl = pf_saturate gl c ~ty:c_ty n_c_args in + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let pc = match n_c_args, c_gen with + | 0, Some p -> interp_cpattern (Option.get ist) orig_gl p None + | _ -> mkTpat gl c in + let cty = Some (c, c_ty, pc) in + let elimty = Reductionops.whd_all env (project gl) elimty in + cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + in + ppdebug(lazy Pp.(str"elim= "++ pr_constr_pat (EConstr.Unsafe.to_constr elim))); + ppdebug(lazy Pp.(str"elimty= "++ pr_constr_pat (EConstr.Unsafe.to_constr elimty))); + let inf_deps_r = match EConstr.kind_of_type (project gl) elimty with + | AtomicType (_, args) -> List.rev (Array.to_list args) + | _ -> assert false in + let saturate_until gl c c_ty f = + let rec loop n = try + let c, c_ty, _, gl = pf_saturate gl c ~ty:c_ty n in + let gl' = f c c_ty gl in + Some (c, c_ty, gl, gl') + with + | NotEnoughProducts -> None + | e when CErrors.noncritical e -> loop (n+1) in loop 0 in + (* Here we try to understand if the main pattern/term the user gave is + * the first pattern to be matched (i.e. if elimty ends in P t1 .. tn, + * weather tn is the t the user wrote in 'elim: t' *) + let c_is_head_p, gl = match cty with + | None -> true, gl (* The user wrote elim: _ *) + | Some (c, c_ty, _) -> + let res = + (* we try to see if c unifies with the last arg of elim *) + if elim_is_dep then None else + let arg = List.assoc (n_elim_args - 1) elim_args in + let gl, arg_ty = pfe_type_of gl arg in + match saturate_until gl c c_ty (fun c c_ty gl -> + pf_unify_HO (pf_unify_HO gl c_ty arg_ty) arg c) with + | Some (c, _, _, gl) -> Some (false, gl) + | None -> None in + match res with + | Some x -> x + | None -> + (* we try to see if c unifies with the last inferred pattern *) + let inf_arg = List.hd inf_deps_r in + let gl, inf_arg_ty = pfe_type_of gl inf_arg in + match saturate_until gl c c_ty (fun _ c_ty gl -> + pf_unify_HO gl c_ty inf_arg_ty) with + | Some (c, _, _,gl) -> true, gl + | None -> + errorstrm Pp.(str"Unable to apply the eliminator to the term"++ + spc()++pr_econstr c++spc()++str"or to unify it's type with"++ + pr_econstr inf_arg_ty) in + ppdebug(lazy Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); + let gl, predty = pfe_type_of gl pred in + (* Patterns for the inductive types indexes to be bound in pred are computed + * looking at the ones provided by the user and the inferred ones looking at + * the type of the elimination principle *) + let pp_pat (_,p,_,occ) = Pp.(pr_occ occ ++ pp_pattern p) in + let pp_inf_pat gl (_,_,t,_) = pr_constr_pat (EConstr.Unsafe.to_constr (fire_subst gl t)) in + let patterns, clr, gl = + let rec loop patterns clr i = function + | [],[] -> patterns, clr, gl + | ((oclr, occ), t):: deps, inf_t :: inf_deps -> + let ist = match ist with Some x -> x | None -> assert false in + let p = interp_cpattern ist orig_gl t None in + let clr_t = + interp_clr (project gl) (oclr,(tag_of_cpattern t,EConstr.of_constr (fst (redex_of_pattern env p)))) in + (* if we are the index for the equation we do not clear *) + let clr_t = if deps = [] && eqid <> None then [] else clr_t in + let p = if is_undef_pat p then mkTpat gl inf_t else p in + loop (patterns @ [i, p, inf_t, occ]) + (clr_t @ clr) (i+1) (deps, inf_deps) + | [], c :: inf_deps -> + ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_constr_pat (EConstr.Unsafe.to_constr c))); + loop (patterns @ [i, mkTpat gl c, c, allocc]) + clr (i+1) ([], inf_deps) + | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in + let deps, head_p, inf_deps_r = match what, c_is_head_p, cty with + | `EConstr _, _, None -> anomaly "Simple elim with no term" + | _, false, _ -> deps, [], inf_deps_r + | `EGen gen, true, None -> deps @ [gen], [], inf_deps_r + | _, true, Some (c, _, pc) -> + let occ = if occ = None then allocc else occ in + let inf_p, inf_deps_r = List.hd inf_deps_r, List.tl inf_deps_r in + deps, [1, pc, inf_p, occ], inf_deps_r in + let patterns, clr, gl = + loop [] orig_clr (List.length head_p+1) (List.rev deps, inf_deps_r) in + head_p @ patterns, Util.List.uniquize clr, gl + in + ppdebug(lazy Pp.(pp_concat (str"patterns=") (List.map pp_pat patterns))); + ppdebug(lazy Pp.(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); + (* Predicate generation, and (if necessary) tactic to generalize the + * equation asked by the user *) + let elim_pred, gen_eq_tac, clr, gl = + let error gl t inf_t = errorstrm Pp.(str"The given pattern matches the term"++ + spc()++pp_term gl t++spc()++str"while the inferred pattern"++ + spc()++pr_constr_pat (EConstr.Unsafe.to_constr (fire_subst gl inf_t))++spc()++ str"doesn't") in + let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = + let p = unif_redex gl p inf_t in + if is_undef_pat p then + let () = ppdebug(lazy Pp.(str"postponing " ++ pp_pattern p)) in + cl, gl, post @ [h, p, inf_t, occ] + else try + let c, cl, ucst = match_pat env p occ h cl in + let gl = pf_merge_uc ucst gl in + let c = EConstr.of_constr c in + let gl = try pf_unify_HO gl inf_t c with _ -> error gl c inf_t in + cl, gl, post + with + | NoMatch | NoProgress -> + let e, ucst = redex_of_pattern env p in + let gl = pf_merge_uc ucst gl in + let e = EConstr.of_constr e in + let n, e, _, _ucst = pf_abs_evars gl (fst p, e) in + let e, _, _, gl = pf_saturate ~beta:true gl e n in + let gl = try pf_unify_HO gl inf_t e with _ -> error gl e inf_t in + cl, gl, post + in + let rec match_all concl gl patterns = + let concl, gl, postponed = + List.fold_left match_or_postpone (concl, gl, []) patterns in + if postponed = [] then concl, gl + else if List.length postponed = List.length patterns then + errorstrm Pp.(str "Some patterns are undefined even after all"++spc()++ + str"the defined ones matched") + else match_all concl gl postponed in + let concl, gl = match_all concl gl patterns in + let pred_rctx, _ = EConstr.decompose_prod_assum (project gl) (fire_subst gl predty) in + let concl, gen_eq_tac, clr, gl = match eqid with + | Some (IPatId _) when not is_rec -> + let k = List.length deps in + let c = fire_subst gl (List.assoc (n_elim_args - k - 1) elim_args) in + let gl, t = pfe_type_of gl c in + let gen_eq_tac, gl = + let refl = EConstr.mkApp (eq, [|t; c; c|]) in + let new_concl = EConstr.mkArrow refl (EConstr.Vars.lift 1 (pf_concl orig_gl)) in + let new_concl = fire_subst gl new_concl in + let erefl, gl = mkRefl t c gl in + let erefl = fire_subst gl erefl in + apply_type new_concl [erefl], gl in + let rel = k + if c_is_head_p then 1 else 0 in + let src, gl = mkProt EConstr.mkProp EConstr.(mkApp (eq,[|t; c; mkRel rel|])) gl in + let concl = EConstr.mkArrow src (EConstr.Vars.lift 1 concl) in + let clr = if deps <> [] then clr else [] in + concl, gen_eq_tac, clr, gl + | _ -> concl, Tacticals.tclIDTAC, clr, gl in + let mk_lam t r = EConstr.mkLambda_or_LetIn r t in + let concl = List.fold_left mk_lam concl pred_rctx in + let gl, concl = + if eqid <> None && is_rec then + let gl, concls = pfe_type_of gl concl in + let concl, gl = mkProt concls concl gl in + let gl, _ = pfe_type_of gl concl in + gl, concl + else gl, concl in + concl, gen_eq_tac, clr, gl in + let gl, pty = pf_e_type_of gl elim_pred in + ppdebug(lazy Pp.(str"elim_pred=" ++ pp_term gl elim_pred)); + ppdebug(lazy Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); + let gl = pf_unify_HO gl pred elim_pred in + let elim = fire_subst gl elim in + let gl, _ = pf_e_type_of gl elim in + (* check that the patterns do not contain non instantiated dependent metas *) + let () = + let evars_of_term = Evarutil.undefined_evars_of_term (project gl) in + let patterns = List.map (fun (_,_,t,_) -> fire_subst gl t) patterns in + let patterns_ev = List.map evars_of_term patterns in + let ev = List.fold_left Evar.Set.union Evar.Set.empty patterns_ev in + let ty_ev = Evar.Set.fold (fun i e -> + let ex = i in + let i_ty = EConstr.of_constr (Evd.evar_concl (Evd.find (project gl) ex)) in + Evar.Set.union e (evars_of_term i_ty)) + ev Evar.Set.empty in + let inter = Evar.Set.inter ev ty_ev in + if not (Evar.Set.is_empty inter) then begin + let i = Evar.Set.choose inter in + let pat = List.find (fun t -> Evar.Set.mem i (evars_of_term t)) patterns in + errorstrm Pp.(str"Pattern"++spc()++pr_constr_pat (EConstr.Unsafe.to_constr pat)++spc()++ + str"was not completely instantiated and one of its variables"++spc()++ + str"occurs in the type of another non-instantiated pattern variable"); + end + in + (* the elim tactic, with the eliminator and the predicated we computed *) + let elim = project gl, elim in + let elim_tac gl = + Tacticals.tclTHENLIST [refine_with ~with_evars:false elim; cleartac clr] gl in + Tacticals.tclTHENLIST [gen_eq_tac; elim_intro_tac ?ist what eqid elim_tac is_rec clr] orig_gl + +let no_intro ?ist what eqid elim_tac is_rec clr = elim_tac + +let elimtac x = ssrelim ~is_case:false [] (`EConstr ([],None,x)) None no_intro +let casetac x = ssrelim ~is_case:true [] (`EConstr ([],None,x)) None no_intro + +let pf_nb_prod gl = nb_prod (project gl) (pf_concl gl) + +let rev_id = mk_internal_id "rev concl" +let injecteq_id = mk_internal_id "injection equation" + +let revtoptac n0 gl = + let n = pf_nb_prod gl - n0 in + let dc, cl = EConstr.decompose_prod_n_assum (project gl) n (pf_concl gl) in + let dc' = dc @ [Context.Rel.Declaration.LocalAssum(Name rev_id, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in + let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in + refine (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|])) gl + +let equality_inj l b id c gl = + let msg = ref "" in + try Proofview.V82.of_tactic (Equality.inj l b None c) gl + with + | Ploc.Exc(_,CErrors.UserError (_,s)) + | CErrors.UserError (_,s) + when msg := Pp.string_of_ppcmds s; + !msg = "Not a projectable equality but a discriminable one." || + !msg = "Nothing to inject." -> + Feedback.msg_warning (Pp.str !msg); + discharge_hyp (id, (id, "")) gl + +let injectidl2rtac id c gl = + Tacticals.tclTHEN (equality_inj None true id c) (revtoptac (pf_nb_prod gl)) gl + +let injectl2rtac sigma c = match EConstr.kind sigma c with +| Var id -> injectidl2rtac id (EConstr.mkVar id, NoBindings) +| _ -> + let id = injecteq_id in + let xhavetac id c = Proofview.V82.of_tactic (Tactics.pose_proof (Name id) c) in + Tacticals.tclTHENLIST [xhavetac id c; injectidl2rtac id (EConstr.mkVar id, NoBindings); Proofview.V82.of_tactic (Tactics.clear [id])] + +let is_injection_case c gl = + let gl, cty = pfe_type_of gl c in + let (mind,_), _ = pf_reduce_to_quantified_ind gl cty in + eq_gr (IndRef mind) (Coqlib.build_coq_eq ()) + +let perform_injection c gl = + let gl, cty = pfe_type_of gl c in + let mind, t = pf_reduce_to_quantified_ind gl cty in + let dc, eqt = EConstr.decompose_prod (project gl) t in + if dc = [] then injectl2rtac (project gl) c gl else + if not (EConstr.Vars.closed0 (project gl) eqt) then + CErrors.user_err (Pp.str "can't decompose a quantified equality") else + let cl = pf_concl gl in let n = List.length dc in + let c_eq = mkEtaApp c n 2 in + let cl1 = EConstr.mkLambda EConstr.(Anonymous, mkArrow eqt cl, mkApp (mkRel 1, [|c_eq|])) in + let id = injecteq_id in + let id_with_ebind = (EConstr.mkVar id, NoBindings) in + let injtac = Tacticals.tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in + Tacticals.tclTHENLAST (Proofview.V82.of_tactic (Tactics.apply (EConstr.compose_lam dc cl1))) injtac gl + +let ssrscasetac force_inj c gl = + if force_inj || is_injection_case c gl then perform_injection c gl + else casetac c gl diff --git a/plugins/ssr/ssrelim.mli b/plugins/ssr/ssrelim.mli new file mode 100644 index 000000000..fb1b58ac3 --- /dev/null +++ b/plugins/ssr/ssrelim.mli @@ -0,0 +1,53 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ssrmatching_plugin + +val ssrelim : + ?ind:(int * EConstr.types array) option ref -> + ?is_case:bool -> + ?ist:Ltac_plugin.Tacinterp.interp_sign -> + ((Ssrast.ssrhyps option * Ssrast.ssrocc) * + Ssrmatching.cpattern) + list -> + ([< `EConstr of + Ssrast.ssrhyp list * Ssrmatching.occ * + EConstr.constr & + 'b + | `EGen of + (Ssrast.ssrhyp list option * + Ssrmatching.occ) * + Ssrmatching.cpattern ] + as 'a) -> + ?elim:EConstr.constr -> + Ssrast.ssripat option -> + (?ist:Ltac_plugin.Tacinterp.interp_sign -> + 'a -> + Ssrast.ssripat option -> + (Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma) -> + bool -> Ssrast.ssrhyp list -> Proof_type.tactic) -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + +val elimtac : + EConstr.constr -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma +val casetac : + EConstr.constr -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + +val is_injection_case : EConstr.t -> Proof_type.goal Evd.sigma -> bool +val perform_injection : + EConstr.constr -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + +val ssrscasetac : + bool -> + EConstr.constr -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml new file mode 100644 index 000000000..af315aac5 --- /dev/null +++ b/plugins/ssr/ssrequality.ml @@ -0,0 +1,663 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ltac_plugin +open Util +open Names +open Vars +open Locus +open Printer +open Globnames +open Termops +open Tacinterp +open Term + +open Ssrmatching_plugin +open Ssrmatching + +open Ssrast +open Ssrprinters +open Ssrcommon +open Tacticals +open Tacmach + +let ssroldreworder = Summary.ref ~name:"SSR:oldreworder" false +let _ = + Goptions.declare_bool_option + { Goptions.optname = "ssreflect 1.3 compatibility flag"; + Goptions.optkey = ["SsrOldRewriteGoalsOrder"]; + Goptions.optread = (fun _ -> !ssroldreworder); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssroldreworder := b) } + +(** The "simpl" tactic *) + +(* We must avoid zeta-converting any "let"s created by the "in" tactical. *) + +let tacred_simpl gl = + let simpl_expr = + Genredexpr.( + Simpl(Redops.make_red_flag[FBeta;FMatch;FZeta;FDeltaBut []],None)) in + let esimpl, _ = Redexpr.reduction_of_red_expr (pf_env gl) simpl_expr in + let esimpl e sigma c = + let (_,t) = esimpl e sigma c in + t in + let simpl env sigma c = (esimpl env sigma c) in + simpl + +let safe_simpltac n gl = + if n = ~-1 then + let cl= red_safe (tacred_simpl gl) (pf_env gl) (project gl) (pf_concl gl) in + Proofview.V82.of_tactic (convert_concl_no_check cl) gl + else + ssr_n_tac "simpl" n gl + +let simpltac = function + | Simpl n -> safe_simpltac n + | Cut n -> tclTRY (donetac n) + | SimplCut (n,m) -> tclTHEN (safe_simpltac m) (tclTRY (donetac n)) + | Nop -> tclIDTAC + +(** The "congr" tactic *) + +let interp_congrarg_at ist gl n rf ty m = + ppdebug(lazy Pp.(str"===interp_congrarg_at===")); + let congrn, _ = mkSsrRRef "nary_congruence" in + let args1 = mkRnat n :: mkRHoles n @ [ty] in + let args2 = mkRHoles (3 * n) in + let rec loop i = + if i + n > m then None else + try + let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in + ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr rt)); + Some (interp_refine ist gl rt) + with _ -> loop (i + 1) in + loop 0 + +let pattern_id = mk_internal_id "pattern value" + +let congrtac ((n, t), ty) ist gl = + ppdebug(lazy (Pp.str"===congr===")); + ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr (Tacmach.pf_concl gl))); + let sigma, _ as it = interp_term ist gl t in + let gl = pf_merge_uc_of sigma gl in + let _, f, _, _ucst = pf_abs_evars gl it in + let ist' = {ist with lfun = + Id.Map.add pattern_id (Tacinterp.Value.of_constr f) Id.Map.empty } in + let rf = mkRltacVar pattern_id in + let m = pf_nbargs gl f in + let _, cf = if n > 0 then + match interp_congrarg_at ist' gl n rf ty m with + | Some cf -> cf + | None -> errorstrm Pp.(str "No " ++ int n ++ str "-congruence with " + ++ pr_term t) + else let rec loop i = + if i > m then errorstrm Pp.(str "No congruence with " ++ pr_term t) + else match interp_congrarg_at ist' gl i rf ty m with + | Some cf -> cf + | None -> loop (i + 1) in + loop 1 in + tclTHEN (refine_with cf) (tclTRY (Proofview.V82.of_tactic Tactics.reflexivity)) gl + +let newssrcongrtac arg ist gl = + ppdebug(lazy Pp.(str"===newcongr===")); + ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr (pf_concl gl))); + (* utils *) + let fs gl t = Reductionops.nf_evar (project gl) t in + let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = + match try Some (pf_unify_HO gl_c (pf_concl gl) c) with _ -> None with + | Some gl_c -> + tclTHEN (Proofview.V82.of_tactic (convert_concl (fs gl_c c))) + (t_ok (proj gl_c)) gl + | None -> t_fail () gl in + let mk_evar gl ty = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let sigma = Evd.create_evar_defs sigma in + let (sigma, x) = Evarutil.new_evar env sigma ty in + x, re_sig si sigma in + let arr, gl = pf_mkSsrConst "ssr_congr_arrow" gl in + let ssr_congr lr = EConstr.mkApp (arr, lr) in + (* here thw two cases: simple equality or arrow *) + let equality, _, eq_args, gl' = + let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in + pf_saturate gl (EConstr.of_constr eq) 3 in + tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) + (fun ty -> congrtac (arg, Detyping.detype false [] (pf_env gl) (project gl) ty) ist) + (fun () -> + let lhs, gl' = mk_evar gl EConstr.mkProp in let rhs, gl' = mk_evar gl' EConstr.mkProp in + let arrow = EConstr.mkArrow lhs (EConstr.Vars.lift 1 rhs) in + tclMATCH_GOAL (arrow, gl') (fun gl' -> [|fs gl' lhs;fs gl' rhs|]) + (fun lr -> tclTHEN (Proofview.V82.of_tactic (Tactics.apply (ssr_congr lr))) (congrtac (arg, mkRType) ist)) + (fun _ _ -> errorstrm Pp.(str"Conclusion is not an equality nor an arrow"))) + gl + +(** 7. Rewriting tactics (rewrite, unlock) *) + +(** Coq rewrite compatibility flag *) + +let ssr_strict_match = ref false + +let _ = + Goptions.declare_bool_option + { Goptions.optname = "strict redex matching"; + Goptions.optkey = ["Match"; "Strict"]; + Goptions.optread = (fun () -> !ssr_strict_match); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssr_strict_match := b) } + +(** Rewrite rules *) + +type ssrwkind = RWred of ssrsimpl | RWdef | RWeq +type ssrrule = ssrwkind * ssrterm + +(** Rewrite arguments *) + +type ssrrwarg = (ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule) + +let notimes = 0 +let nomult = 1, Once + +let mkocc occ = None, occ +let noclr = mkocc None +let mkclr clr = Some clr, None +let nodocc = mkclr [] + +let is_rw_cut = function RWred (Cut _) -> true | _ -> false + +let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) : ssrrwarg = + if rt <> RWeq then begin + if rt = RWred Nop && not (m = nomult && occ = None && rx = None) + && (clr = None || clr = Some []) then + anomaly "Improper rewrite clear switch"; + if d = R2L && rt <> RWdef then + CErrors.user_err (Pp.str "Right-to-left switch on simplification"); + if n <> 1 && is_rw_cut rt then + CErrors.user_err (Pp.str "Bad or useless multiplier"); + if occ <> None && rx = None && rt <> RWdef then + CErrors.user_err (Pp.str "Missing redex for simplification occurrence") + end; (d, m), ((docc, rx), r) + +let norwmult = L2R, nomult +let norwocc = noclr, None + +let simplintac occ rdx sim gl = + let simptac m gl = + if m <> ~-1 then + CErrors.user_err (Pp.str "Localized custom simpl tactic not supported"); + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let simp env c _ _ = EConstr.Unsafe.to_constr (red_safe Tacred.simpl env sigma0 (EConstr.of_constr c)) in + Proofview.V82.of_tactic + (convert_concl_no_check (EConstr.of_constr (eval_pattern env0 sigma0 (EConstr.Unsafe.to_constr concl0) rdx occ simp))) + gl in + match sim with + | Simpl m -> simptac m gl + | SimplCut (n,m) -> tclTHEN (simptac m) (tclTRY (donetac n)) gl + | _ -> simpltac sim gl + +let rec get_evalref sigma c = match EConstr.kind sigma c with + | Var id -> EvalVarRef id + | Const (k,_) -> EvalConstRef k + | App (c', _) -> get_evalref sigma c' + | Cast (c', _, _) -> get_evalref sigma c' + | Proj(c,_) -> EvalConstRef(Projection.constant c) + | _ -> errorstrm Pp.(str "The term " ++ pr_constr_pat (EConstr.Unsafe.to_constr c) ++ str " is not unfoldable") + +(* Strip a pattern generated by a prenex implicit to its constant. *) +let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with + | App (f, a) when kt = xNoFlag && Array.for_all (EConstr.isEvar sigma) a && EConstr.isConst sigma f -> + (sigma, f), true + | Const _ | Var _ -> p, true + | Proj _ -> p, true + | _ -> p, false + +let same_proj sigma t1 t2 = + match EConstr.kind sigma t1, EConstr.kind sigma t2 with + | Proj(c1,_), Proj(c2, _) -> Projection.equal c1 c2 + | _ -> false + +let all_ok _ _ = true + +let fake_pmatcher_end () = + mkProp, L2R, (Evd.empty, Evd.empty_evar_universe_context, mkProp) + +let unfoldintac occ rdx t (kt,_) gl = + let fs sigma x = Reductionops.nf_evar sigma x in + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let (sigma, t), const = strip_unfold_term env0 t kt in + let body env t c = + Tacred.unfoldn [AllOccurrences, get_evalref sigma t] env sigma0 c in + let easy = occ = None && rdx = None in + let red_flags = if easy then CClosure.betaiotazeta else CClosure.betaiota in + let beta env = Reductionops.clos_norm_flags red_flags env sigma0 in + let unfold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = Evd.create_evar_defs sigma in + let ise, u = mk_tpattern env0 sigma0 (ise,EConstr.Unsafe.to_constr t) all_ok L2R (EConstr.Unsafe.to_constr t) in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in + (fun env c _ h -> + try find_T env c h ~k:(fun env c _ _ -> EConstr.Unsafe.to_constr (body env t (EConstr.of_constr c))) + with NoMatch when easy -> c + | NoMatch | NoProgress -> errorstrm Pp.(str"No occurrence of " + ++ pr_constr_pat (EConstr.Unsafe.to_constr t) ++ spc() ++ str "in " ++ Printer.pr_constr c)), + (fun () -> try end_T () with + | NoMatch when easy -> fake_pmatcher_end () + | NoMatch -> anomaly "unfoldintac") + | _ -> + (fun env (c as orig_c) _ h -> + if const then + let rec aux c = + match EConstr.kind sigma0 c with + | Const _ when EConstr.eq_constr sigma0 c t -> body env t t + | App (f,a) when EConstr.eq_constr sigma0 f t -> EConstr.mkApp (body env f f,a) + | Proj _ when same_proj sigma0 c t -> body env t c + | _ -> + let c = Reductionops.whd_betaiotazeta sigma0 c in + match EConstr.kind sigma0 c with + | Const _ when EConstr.eq_constr sigma0 c t -> body env t t + | App (f,a) when EConstr.eq_constr sigma0 f t -> EConstr.mkApp (body env f f,a) + | Proj _ when same_proj sigma0 c t -> body env t c + | Const f -> aux (body env c c) + | App (f, a) -> aux (EConstr.mkApp (body env f f, a)) + | _ -> errorstrm Pp.(str "The term "++pr_constr orig_c++ + str" contains no " ++ pr_econstr t ++ str" even after unfolding") + in EConstr.Unsafe.to_constr @@ aux (EConstr.of_constr c) + else + try EConstr.Unsafe.to_constr @@ body env t (fs (unify_HO env sigma (EConstr.of_constr c) t) t) + with _ -> errorstrm Pp.(str "The term " ++ + pr_constr c ++spc()++ str "does not unify with " ++ pr_constr_pat (EConstr.Unsafe.to_constr t))), + fake_pmatcher_end in + let concl = + let concl0 = EConstr.Unsafe.to_constr concl0 in + try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) + with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_constr_pat (EConstr.Unsafe.to_constr t)) in + let _ = conclude () in + Proofview.V82.of_tactic (convert_concl concl) gl +;; + +let foldtac occ rdx ft gl = + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let sigma, t = ft in + let t = EConstr.to_constr sigma t in + let fold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = Evd.create_evar_defs sigma in + let ut = EConstr.Unsafe.to_constr (red_product_skip_id env0 sigma (EConstr.of_constr t)) in + let ise, ut = mk_tpattern env0 sigma0 (ise,t) all_ok L2R ut in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[ut]) in + (fun env c _ h -> try find_T env c h ~k:(fun env t _ _ -> t) with NoMatch ->c), + (fun () -> try end_T () with NoMatch -> fake_pmatcher_end ()) + | _ -> + (fun env c _ h -> try let sigma = unify_HO env sigma (EConstr.of_constr c) (EConstr.of_constr t) in EConstr.to_constr sigma (EConstr.of_constr t) + with _ -> errorstrm Pp.(str "fold pattern " ++ pr_constr_pat t ++ spc () + ++ str "does not match redex " ++ pr_constr_pat c)), + fake_pmatcher_end in + let concl0 = EConstr.Unsafe.to_constr concl0 in + let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in + let _ = conclude () in + Proofview.V82.of_tactic (convert_concl (EConstr.of_constr concl)) gl +;; + +let converse_dir = function L2R -> R2L | R2L -> L2R + +let rw_progress rhs lhs ise = not (EConstr.eq_constr ise lhs (Evarutil.nf_evar ise rhs)) + +(* Coq has a more general form of "equation" (any type with a single *) +(* constructor with no arguments with_rect_r elimination lemmas). *) +(* However there is no clear way of determining the LHS and RHS of *) +(* such a generic Leibnitz equation -- short of inspecting the type *) +(* of the elimination lemmas. *) + +let rec strip_prod_assum c = match Term.kind_of_term c with + | Prod (_, _, c') -> strip_prod_assum c' + | LetIn (_, v, _, c') -> strip_prod_assum (subst1 v c) + | Cast (c', _, _) -> strip_prod_assum c' + | _ -> c + +let rule_id = mk_internal_id "rewrite rule" + +exception PRtype_error + +let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = +(* ppdebug(lazy(str"sigma@pirrel_rewrite=" ++ pr_evar_map None sigma)); *) + let env = pf_env gl in + let beta = Reductionops.clos_norm_flags CClosure.beta env sigma in + let sigma, p = + let sigma = Evd.create_evar_defs sigma in + let (sigma, ev) = Evarutil.new_evar env sigma (beta (EConstr.Vars.subst1 new_rdx pred)) in + (sigma, ev) + in + let pred = EConstr.mkNamedLambda pattern_id rdx_ty pred in + let elim, gl = + let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in + let sort = elimination_sort_of_goal gl in + let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in + if dir = R2L then elim, gl else (* taken from Coq's rewrite *) + let elim, _ = Term.destConst elim in + let mp,dp,l = repr_con (constant_of_kn (canonical_con elim)) in + let l' = label_of_id (Nameops.add_suffix (id_of_label l) "_r") in + let c1' = Global.constant_of_delta_kn (canonical_con (make_con mp dp l')) in + mkConst c1', gl in + let elim = EConstr.of_constr elim in + let proof = EConstr.mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in + (* We check the proof is well typed *) + let sigma, proof_ty = + try Typing.type_of env sigma proof with _ -> raise PRtype_error in + ppdebug(lazy Pp.(str"pirrel_rewrite proof term of type: " ++ pr_econstr proof_ty)); + try refine_with + ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl + with _ -> + (* we generate a msg like: "Unable to find an instance for the variable" *) + let hd_ty, miss = match EConstr.kind sigma c with + | App (hd, args) -> + let hd_ty = Retyping.get_type_of env sigma hd in + let names = let rec aux t = function 0 -> [] | n -> + let t = Reductionops.whd_all env sigma t in + match EConstr.kind_of_type sigma t with + | ProdType (name, _, t) -> name :: aux t (n-1) + | _ -> assert false in aux hd_ty (Array.length args) in + hd_ty, Util.List.map_filter (fun (t, name) -> + let evs = Evar.Set.elements (Evarutil.undefined_evars_of_term sigma t) in + let open_evs = List.filter (fun k -> + Sorts.InProp <> Retyping.get_sort_family_of + env sigma (EConstr.of_constr (Evd.evar_concl (Evd.find sigma k)))) + evs in + if open_evs <> [] then Some name else None) + (List.combine (Array.to_list args) names) + | _ -> anomaly "rewrite rule not an application" in + errorstrm Pp.(Himsg.explain_refiner_error (Logic.UnresolvedBindings miss)++ + (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_econstr hd_ty)) +;; + +let is_construct_ref sigma c r = + EConstr.isConstruct sigma c && eq_gr (ConstructRef (fst(EConstr.destConstruct sigma c))) r +let is_ind_ref sigma c r = EConstr.isInd sigma c && eq_gr (IndRef (fst(EConstr.destInd sigma c))) r + +let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type x xs) + +let rwcltac cl rdx dir sr gl = + let n, r_n,_, ucst = pf_abs_evars gl sr in + let r_n' = pf_abs_cterm gl n r_n in + let r' = EConstr.Vars.subst_var pattern_id r_n' in + let gl = pf_unsafe_merge_uc ucst gl in + let rdxt = Retyping.get_type_of (pf_env gl) (fst sr) rdx in +(* ppdebug(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) + ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr (snd sr))); + let cvtac, rwtac, gl = + if EConstr.Vars.closed0 (project gl) r' then + let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.build_coq_eq () in + let sigma, c_ty = Typing.type_of env sigma c in + ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr c_ty)); + match EConstr.kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with + | AtomicType(e, a) when is_ind_ref sigma e c_eq -> + let new_rdx = if dir = L2R then a.(2) else a.(1) in + pirrel_rewrite cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl + | _ -> + let cl' = EConstr.mkApp (EConstr.mkNamedLambda pattern_id rdxt cl, [|rdx|]) in + let sigma, _ = Typing.type_of env sigma cl' in + let gl = pf_merge_uc_of sigma gl in + Proofview.V82.of_tactic (convert_concl cl'), rewritetac dir r', gl + else + let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in + let r3, _, r3t = + try EConstr.destCast (project gl) r2 with _ -> + errorstrm Pp.(str "no cast from " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd sr)) + ++ str " to " ++ pr_econstr r2) in + let cl' = EConstr.mkNamedProd rule_id (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in + let cl'' = EConstr.mkNamedProd pattern_id rdxt cl' in + let itacs = [introid pattern_id; introid rule_id] in + let cltac = Proofview.V82.of_tactic (Tactics.clear [pattern_id; rule_id]) in + let rwtacs = [rewritetac dir (EConstr.mkVar rule_id); cltac] in + apply_type cl'' [rdx; EConstr.it_mkLambda_or_LetIn r3 dc], tclTHENLIST (itacs @ rwtacs), gl + in + let cvtac' _ = + try cvtac gl with + | PRtype_error -> + if occur_existential (project gl) (Tacmach.pf_concl gl) + then errorstrm Pp.(str "Rewriting impacts evars") + else errorstrm Pp.(str "Dependent type error in rewrite of " + ++ pr_constr_env (pf_env gl) (project gl) (Term.mkNamedLambda pattern_id (EConstr.Unsafe.to_constr rdxt) (EConstr.Unsafe.to_constr cl))) + | CErrors.UserError _ as e -> raise e + | e -> anomaly ("cvtac's exception: " ^ Printexc.to_string e); + in + tclTHEN cvtac' rwtac gl + +let prof_rwcltac = mk_profiler "rwrxtac.rwcltac";; +let rwcltac cl rdx dir sr gl = + prof_rwcltac.profile (rwcltac cl rdx dir sr) gl +;; + + +let lz_coq_prod = + let prod = lazy (Coqlib.build_prod ()) in fun () -> Lazy.force prod + +let lz_setoid_relation = + let sdir = ["Classes"; "RelationClasses"] in + let last_srel = ref (Environ.empty_env, None) in + fun env -> match !last_srel with + | env', srel when env' == env -> srel + | _ -> + let srel = + try Some (Universes.constr_of_global @@ + Coqlib.coq_reference "Class_setoid" sdir "RewriteRelation") + with _ -> None in + last_srel := (env, srel); srel + +let ssr_is_setoid env = + match lz_setoid_relation env with + | None -> fun _ _ _ -> false + | Some srel -> + fun sigma r args -> + Rewrite.is_applied_rewrite_relation env + sigma [] (EConstr.mkApp (r, args)) <> None + +let prof_rwxrtac_find_rule = mk_profiler "rwrxtac.find_rule";; + +let closed0_check cl p gl = + if closed0 cl then + errorstrm Pp.(str"No occurrence of redex "++ pr_constr_env (pf_env gl) (project gl) p) + +let dir_org = function L2R -> 1 | R2L -> 2 + +let rwprocess_rule dir rule gl = + let env = pf_env gl in + let coq_prod = lz_coq_prod () in + let is_setoid = ssr_is_setoid env in + let r_sigma, rules = + let rec loop d sigma r t0 rs red = + let t = + if red = 1 then Tacred.hnf_constr env sigma t0 + else Reductionops.whd_betaiotazeta sigma t0 in + ppdebug(lazy Pp.(str"rewrule="++pr_constr_pat (EConstr.Unsafe.to_constr t))); + match EConstr.kind sigma t with + | Prod (_, xt, at) -> + let sigma = Evd.create_evar_defs sigma in + let (sigma, x) = Evarutil.new_evar env sigma xt in + loop d sigma EConstr.(mkApp (r, [|x|])) (EConstr.Vars.subst1 x at) rs 0 + | App (pr, a) when is_ind_ref sigma pr coq_prod.Coqlib.typ -> + let sr sigma = match EConstr.kind sigma (Tacred.hnf_constr env sigma r) with + | App (c, ra) when is_construct_ref sigma c coq_prod.Coqlib.intro -> + fun i -> ra.(i + 1), sigma + | _ -> let ra = Array.append a [|r|] in + function 1 -> + let sigma, pi1 = Evd.fresh_global env sigma coq_prod.Coqlib.proj1 in + EConstr.mkApp (EConstr.of_constr pi1, ra), sigma + | _ -> + let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in + EConstr.mkApp (EConstr.of_constr pi2, ra), sigma in + if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_True ())) then + let s, sigma = sr sigma 2 in + loop (converse_dir d) sigma s a.(1) rs 0 + else + let s, sigma = sr sigma 2 in + let sigma, rs2 = loop d sigma s a.(1) rs 0 in + let s, sigma = sr sigma 1 in + loop d sigma s a.(0) rs2 0 + | App (r_eq, a) when Hipattern.match_with_equality_type sigma t != None -> + let (ind, u) = EConstr.destInd sigma r_eq and rhs = Array.last a in + let np = Inductiveops.inductive_nparamdecls ind in + let indu = (ind, EConstr.EInstance.kind sigma u) in + let ind_ct = Inductiveops.type_of_constructors env indu in + let lhs0 = last_arg sigma (EConstr.of_constr (strip_prod_assum ind_ct.(0))) in + let rdesc = match EConstr.kind sigma lhs0 with + | Rel i -> + let lhs = a.(np - i) in + let lhs, rhs = if d = L2R then lhs, rhs else rhs, lhs in +(* msgnl (str "RW: " ++ pr_rwdir d ++ str " " ++ pr_constr_pat r ++ str " : " + ++ pr_constr_pat lhs ++ str " ~> " ++ pr_constr_pat rhs); *) + d, r, lhs, rhs +(* + let l_i, r_i = if d = L2R then i, 1 - ndep else 1 - ndep, i in + let lhs = a.(np - l_i) and rhs = a.(np - r_i) in + let a' = Array.copy a in let _ = a'.(np - l_i) <- mkVar pattern_id in + let r' = mkCast (r, DEFAULTcast, mkApp (r_eq, a')) in + (d, r', lhs, rhs) +*) + | _ -> + let lhs = EConstr.Vars.substl (array_list_of_tl (Array.sub a 0 np)) lhs0 in + let lhs, rhs = if d = R2L then lhs, rhs else rhs, lhs in + let d' = if Array.length a = 1 then d else converse_dir d in + d', r, lhs, rhs in + sigma, rdesc :: rs + | App (s_eq, a) when is_setoid sigma s_eq a -> + let np = Array.length a and i = 3 - dir_org d in + let lhs = a.(np - i) and rhs = a.(np + i - 3) in + let a' = Array.copy a in let _ = a'.(np - i) <- EConstr.mkVar pattern_id in + let r' = EConstr.mkCast (r, DEFAULTcast, EConstr.mkApp (s_eq, a')) in + sigma, (d, r', lhs, rhs) :: rs + | _ -> + if red = 0 then loop d sigma r t rs 1 + else errorstrm Pp.(str "not a rewritable relation: " ++ pr_constr_pat (EConstr.Unsafe.to_constr t) + ++ spc() ++ str "in rule " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd rule))) + in + let sigma, r = rule in + let t = Retyping.get_type_of env sigma r in + loop dir sigma r t [] 0 + in + r_sigma, rules + +let rwrxtac occ rdx_pat dir rule gl = + let env = pf_env gl in + let r_sigma, rules = rwprocess_rule dir rule gl in + let find_rule rdx = + let rec rwtac = function + | [] -> + errorstrm Pp.(str "pattern " ++ pr_constr_pat (EConstr.Unsafe.to_constr rdx) ++ + str " does not match " ++ pr_dir_side dir ++ + str " of " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd rule))) + | (d, r, lhs, rhs) :: rs -> + try + let ise = unify_HO env (Evd.create_evar_defs r_sigma) lhs rdx in + if not (rw_progress rhs rdx ise) then raise NoMatch else + d, (ise, Evd.evar_universe_context ise, Reductionops.nf_evar ise r) + with _ -> rwtac rs in + rwtac rules in + let find_rule rdx = prof_rwxrtac_find_rule.profile find_rule rdx in + let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let find_R, conclude = match rdx_pat with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let upats_origin = dir, EConstr.Unsafe.to_constr (snd rule) in + let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + let rw_progress rhs t evd = rw_progress rhs (EConstr.of_constr t) evd in + mk_tpattern env sigma0 (sigma,EConstr.to_constr sigma r) (rw_progress rhs) d (EConstr.to_constr sigma lhs) in + sigma, pats @ [pat] in + let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in + let find_R, end_R = mk_tpattern_matcher sigma0 occ ~upats_origin rpats in + (fun e c _ i -> find_R ~k:(fun _ _ _ h -> mkRel h) e c i), + fun cl -> let rdx,d,r = end_R () in closed0_check cl rdx gl; (d,r),rdx + | Some(_, (T e | X_In_T (_,e) | E_As_X_In_T (e,_,_) | E_In_X_In_T (e,_,_))) -> + let r = ref None in + (fun env c _ h -> do_once r (fun () -> find_rule (EConstr.of_constr c), c); mkRel h), + (fun concl -> closed0_check concl e gl; + let (d,(ev,ctx,c)) , x = assert_done r in (d,(ev,ctx, EConstr.to_constr ev c)) , x) in + let concl0 = EConstr.Unsafe.to_constr concl0 in + let concl = eval_pattern env0 sigma0 concl0 rdx_pat occ find_R in + let (d, r), rdx = conclude concl in + let r = Evd.merge_universe_context (pi1 r) (pi2 r), EConstr.of_constr (pi3 r) in + rwcltac (EConstr.of_constr concl) (EConstr.of_constr rdx) d r gl +;; + +let prof_rwxrtac = mk_profiler "rwrxtac";; +let rwrxtac occ rdx_pat dir rule gl = + prof_rwxrtac.profile (rwrxtac occ rdx_pat dir rule) gl +;; + +let ssrinstancesofrule ist dir arg gl = + let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let rule = interp_term ist gl arg in + let r_sigma, rules = rwprocess_rule dir rule gl in + let find, conclude = + let upats_origin = dir, EConstr.Unsafe.to_constr (snd rule) in + let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + let rw_progress rhs t evd = rw_progress rhs (EConstr.of_constr t) evd in + mk_tpattern env sigma0 (sigma,EConstr.to_constr sigma r) (rw_progress rhs) d (EConstr.to_constr sigma lhs) in + sigma, pats @ [pat] in + let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in + mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma0 None ~upats_origin rpats in + let print env p c _ = Feedback.msg_info Pp.(hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in + Feedback.msg_info Pp.(str"BEGIN INSTANCES"); + try + while true do + ignore(find env0 (EConstr.Unsafe.to_constr concl0) 1 ~k:print) + done; raise NoMatch + with NoMatch -> Feedback.msg_info Pp.(str"END INSTANCES"); tclIDTAC gl + +let ipat_rewrite occ dir c gl = rwrxtac occ None dir (project gl, c) gl + +let rwargtac ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = + let fail = ref false in + let interp_rpattern ist gl gc = + try interp_rpattern ist gl gc + with _ when snd mult = May -> fail := true; project gl, T mkProp in + let interp gc gl = + try interp_term ist gl gc + with _ when snd mult = May -> fail := true; (project gl, EConstr.mkProp) in + let rwtac gl = + let rx = Option.map (interp_rpattern ist gl) grx in + let t = interp gt gl in + (match kind with + | RWred sim -> simplintac occ rx sim + | RWdef -> if dir = R2L then foldtac occ rx t else unfoldintac occ rx t gt + | RWeq -> rwrxtac occ rx dir t) gl in + let ctac = cleartac (interp_clr (project gl) (oclr, (fst gt, snd (interp gt gl)))) in + if !fail then ctac gl else tclTHEN (tclMULT mult rwtac) ctac gl + +(** Rewrite argument sequence *) + +(* type ssrrwargs = ssrrwarg list *) + +(** The "rewrite" tactic *) + +let ssrrewritetac ist rwargs = + tclTHENLIST (List.map (rwargtac ist) rwargs) + +(** The "unlock" tactic *) + +let unfoldtac occ ko t kt gl = + let env = pf_env gl in + let cl, c = pf_fill_occ_term gl occ (fst (strip_unfold_term env t kt)) in + let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref (project gl) c] gl c) cl in + let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in + Proofview.V82.of_tactic + (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl + +let unlocktac ist args gl = + let utac (occ, gt) gl = + unfoldtac occ occ (interp_term ist gl gt) (fst gt) gl in + let locked, gl = pf_mkSsrConst "locked" gl in + let key, gl = pf_mkSsrConst "master_key" gl in + let ktacs = [ + (fun gl -> unfoldtac None None (project gl,locked) xInParens gl); + Ssrelim.casetac key ] in + tclTHENLIST (List.map utac args @ ktacs) gl + diff --git a/plugins/ssr/ssrequality.mli b/plugins/ssr/ssrequality.mli new file mode 100644 index 000000000..9c5fd4983 --- /dev/null +++ b/plugins/ssr/ssrequality.mli @@ -0,0 +1,62 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ssrmatching_plugin +open Ssrast + +type ssrwkind = RWred of ssrsimpl | RWdef | RWeq +type ssrrule = ssrwkind * ssrterm +type ssrrwarg = (ssrdir * ssrmult) * ((ssrdocc * Ssrmatching.rpattern option) * ssrrule) + +val dir_org : ssrdir -> int + +val notimes : int +val nomult : ssrmult +val mkocc : ssrocc -> ssrdocc +val mkclr : ssrclear -> ssrdocc +val nodocc : ssrdocc +val noclr : ssrdocc + +val simpltac : Ssrast.ssrsimpl -> Proof_type.tactic + +val newssrcongrtac : + int * Ssrast.ssrterm -> + Ltac_plugin.Tacinterp.interp_sign -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + + +val mk_rwarg : + Ssrast.ssrdir * (int * Ssrast.ssrmmod) -> + (Ssrast.ssrclear option * Ssrast.ssrocc) * Ssrmatching.rpattern option -> + ssrwkind * Ssrast.ssrterm -> ssrrwarg + +val norwmult : ssrdir * ssrmult +val norwocc : (Ssrast.ssrclear option * Ssrast.ssrocc) * Ssrmatching.rpattern option + +val ssrinstancesofrule : + Ltac_plugin.Tacinterp.interp_sign -> + Ssrast.ssrdir -> + Ssrast.ssrterm -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + +val ssrrewritetac : + Ltac_plugin.Tacinterp.interp_sign -> + ((Ssrast.ssrdir * (int * Ssrast.ssrmmod)) * + (((Ssrast.ssrhyps option * Ssrmatching.occ) * + Ssrmatching.rpattern option) * + (ssrwkind * Ssrast.ssrterm))) + list -> Proof_type.tactic + +val ipat_rewrite : ssrocc -> ssrdir -> EConstr.t -> Proof_type.tactic + +val unlocktac : + Ltac_plugin.Tacinterp.interp_sign -> + (Ssrmatching.occ * Ssrast.ssrterm) list -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v new file mode 100644 index 000000000..1f3a9c124 --- /dev/null +++ b/plugins/ssr/ssrfun.v @@ -0,0 +1,791 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + +(******************************************************************************) +(* This file contains the basic definitions and notations for working with *) +(* functions. The definitions provide for: *) +(* *) +(* - Pair projections: *) +(* p.1 == first element of a pair *) +(* p.2 == second element of a pair *) +(* These notations also apply to p : P /\ Q, via an and >-> pair coercion. *) +(* *) +(* - Simplifying functions, beta-reduced by /= and simpl: *) +(* [fun : T => E] == constant function from type T that returns E *) +(* [fun x => E] == unary function *) +(* [fun x : T => E] == unary function with explicit domain type *) +(* [fun x y => E] == binary function *) +(* [fun x y : T => E] == binary function with common domain type *) +(* [fun (x : T) y => E] \ *) +(* [fun (x : xT) (y : yT) => E] | == binary function with (some) explicit, *) +(* [fun x (y : T) => E] / independent domain types for each argument *) +(* *) +(* - Partial functions using option type: *) +(* oapp f d ox == if ox is Some x returns f x, d otherwise *) +(* odflt d ox == if ox is Some x returns x, d otherwise *) +(* obind f ox == if ox is Some x returns f x, None otherwise *) +(* omap f ox == if ox is Some x returns Some (f x), None otherwise *) +(* *) +(* - Singleton types: *) +(* all_equal_to x0 == x0 is the only value in its type, so any such value *) +(* can be rewritten to x0. *) +(* *) +(* - A generic wrapper type: *) +(* wrapped T == the inductive type with values Wrap x for x : T. *) +(* unwrap w == the projection of w : wrapped T on T. *) +(* wrap x == the canonical injection of x : T into wrapped T; it is *) +(* equivalent to Wrap x, but is declared as a (default) *) +(* Canonical Structure, which lets the Coq HO unification *) +(* automatically expand x into unwrap (wrap x). The delta *) +(* reduction of wrap x to Wrap can be exploited to *) +(* introduce controlled nondeterminism in Canonical *) +(* Structure inference, as in the implementation of *) +(* the mxdirect predicate in matrix.v. *) +(* *) +(* - Sigma types: *) +(* tag w == the i of w : {i : I & T i}. *) +(* tagged w == the T i component of w : {i : I & T i}. *) +(* Tagged T x == the {i : I & T i} with component x : T i. *) +(* tag2 w == the i of w : {i : I & T i & U i}. *) +(* tagged2 w == the T i component of w : {i : I & T i & U i}. *) +(* tagged2' w == the U i component of w : {i : I & T i & U i}. *) +(* Tagged2 T U x y == the {i : I & T i} with components x : T i and y : U i. *) +(* sval u == the x of u : {x : T | P x}. *) +(* s2val u == the x of u : {x : T | P x & Q x}. *) +(* The properties of sval u, s2val u are given by lemmas svalP, s2valP, and *) +(* s2valP'. We provide coercions sigT2 >-> sigT and sig2 >-> sig >-> sigT. *) +(* A suite of lemmas (all_sig, ...) let us skolemize sig, sig2, sigT, sigT2 *) +(* and pair, e.g., *) +(* have /all_sig[f fP] (x : T): {y : U | P y} by ... *) +(* yields an f : T -> U such that fP : forall x, P (f x). *) +(* - Identity functions: *) +(* id == NOTATION for the explicit identity function fun x => x. *) +(* @id T == notation for the explicit identity at type T. *) +(* idfun == an expression with a head constant, convertible to id; *) +(* idfun x simplifies to x. *) +(* @idfun T == the expression above, specialized to type T. *) +(* phant_id x y == the function type phantom _ x -> phantom _ y. *) +(* *** In addition to their casual use in functional programming, identity *) +(* functions are often used to trigger static unification as part of the *) +(* construction of dependent Records and Structures. For example, if we need *) +(* a structure sT over a type T, we take as arguments T, sT, and a "dummy" *) +(* function T -> sort sT: *) +(* Definition foo T sT & T -> sort sT := ... *) +(* We can avoid specifying sT directly by calling foo (@id T), or specify *) +(* the call completely while still ensuring the consistency of T and sT, by *) +(* calling @foo T sT idfun. The phant_id type allows us to extend this trick *) +(* to non-Type canonical projections. It also allows us to sidestep *) +(* dependent type constraints when building explicit records, e.g., given *) +(* Record r := R {x; y : T(x)}. *) +(* if we need to build an r from a given y0 while inferring some x0, such *) +(* that y0 : T(x0), we pose *) +(* Definition mk_r .. y .. (x := ...) y' & phant_id y y' := R x y'. *) +(* Calling @mk_r .. y0 .. id will cause Coq to use y' := y0, while checking *) +(* the dependent type constraint y0 : T(x0). *) +(* *) +(* - Extensional equality for functions and relations (i.e. functions of two *) +(* arguments): *) +(* f1 =1 f2 == f1 x is equal to f2 x for all x. *) +(* f1 =1 f2 :> A == ... and f2 is explicitly typed. *) +(* f1 =2 f2 == f1 x y is equal to f2 x y for all x y. *) +(* f1 =2 f2 :> A == ... and f2 is explicitly typed. *) +(* *) +(* - Composition for total and partial functions: *) +(* f^~ y == function f with second argument specialised to y, *) +(* i.e., fun x => f x y *) +(* CAVEAT: conditional (non-maximal) implicit arguments *) +(* of f are NOT inserted in this context *) +(* @^~ x == application at x, i.e., fun f => f x *) +(* [eta f] == the explicit eta-expansion of f, i.e., fun x => f x *) +(* CAVEAT: conditional (non-maximal) implicit arguments *) +(* of f are NOT inserted in this context. *) +(* fun=> v := the constant function fun _ => v. *) +(* f1 \o f2 == composition of f1 and f2. *) +(* Note: (f1 \o f2) x simplifies to f1 (f2 x). *) +(* f1 \; f2 == categorical composition of f1 and f2. This expands to *) +(* to f2 \o f1 and (f1 \; f2) x simplifies to f2 (f1 x). *) +(* pcomp f1 f2 == composition of partial functions f1 and f2. *) +(* *) +(* *) +(* - Properties of functions: *) +(* injective f <-> f is injective. *) +(* cancel f g <-> g is a left inverse of f / f is a right inverse of g. *) +(* pcancel f g <-> g is a left inverse of f where g is partial. *) +(* ocancel f g <-> g is a left inverse of f where f is partial. *) +(* bijective f <-> f is bijective (has a left and right inverse). *) +(* involutive f <-> f is involutive. *) +(* *) +(* - Properties for operations. *) +(* left_id e op <-> e is a left identity for op (e op x = x). *) +(* right_id e op <-> e is a right identity for op (x op e = x). *) +(* left_inverse e inv op <-> inv is a left inverse for op wrt identity e, *) +(* i.e., (inv x) op x = e. *) +(* right_inverse e inv op <-> inv is a right inverse for op wrt identity e *) +(* i.e., x op (i x) = e. *) +(* self_inverse e op <-> each x is its own op-inverse (x op x = e). *) +(* idempotent op <-> op is idempotent for op (x op x = x). *) +(* associative op <-> op is associative, i.e., *) +(* x op (y op z) = (x op y) op z. *) +(* commutative op <-> op is commutative (x op y = y op x). *) +(* left_commutative op <-> op is left commutative, i.e., *) +(* x op (y op z) = y op (x op z). *) +(* right_commutative op <-> op is right commutative, i.e., *) +(* (x op y) op z = (x op z) op y. *) +(* left_zero z op <-> z is a left zero for op (z op x = z). *) +(* right_zero z op <-> z is a right zero for op (x op z = z). *) +(* left_distributive op1 op2 <-> op1 distributes over op2 to the left: *) +(* (x op2 y) op1 z = (x op1 z) op2 (y op1 z). *) +(* right_distributive op1 op2 <-> op distributes over add to the right: *) +(* x op1 (y op2 z) = (x op1 z) op2 (x op1 z). *) +(* interchange op1 op2 <-> op1 and op2 satisfy an interchange law: *) +(* (x op2 y) op1 (z op2 t) = (x op1 z) op2 (y op1 t). *) +(* Note that interchange op op is a commutativity property. *) +(* left_injective op <-> op is injective in its left argument: *) +(* x op y = z op y -> x = z. *) +(* right_injective op <-> op is injective in its right argument: *) +(* x op y = x op z -> y = z. *) +(* left_loop inv op <-> op, inv obey the inverse loop left axiom: *) +(* (inv x) op (x op y) = y for all x, y, i.e., *) +(* op (inv x) is always a left inverse of op x *) +(* rev_left_loop inv op <-> op, inv obey the inverse loop reverse left *) +(* axiom: x op ((inv x) op y) = y, for all x, y. *) +(* right_loop inv op <-> op, inv obey the inverse loop right axiom: *) +(* (x op y) op (inv y) = x for all x, y. *) +(* rev_right_loop inv op <-> op, inv obey the inverse loop reverse right *) +(* axiom: (x op y) op (inv y) = x for all x, y. *) +(* Note that familiar "cancellation" identities like x + y - y = x or *) +(* x - y + x = x are respectively instances of right_loop and rev_right_loop *) +(* The corresponding lemmas will use the K and NK/VK suffixes, respectively. *) +(* *) +(* - Morphisms for functions and relations: *) +(* {morph f : x / a >-> r} <-> f is a morphism with respect to functions *) +(* (fun x => a) and (fun x => r); if r == R[x], *) +(* this states that f a = R[f x] for all x. *) +(* {morph f : x / a} <-> f is a morphism with respect to the *) +(* function expression (fun x => a). This is *) +(* shorthand for {morph f : x / a >-> a}; note *) +(* that the two instances of a are often *) +(* interpreted at different types. *) +(* {morph f : x y / a >-> r} <-> f is a morphism with respect to functions *) +(* (fun x y => a) and (fun x y => r). *) +(* {morph f : x y / a} <-> f is a morphism with respect to the *) +(* function expression (fun x y => a). *) +(* {homo f : x / a >-> r} <-> f is a homomorphism with respect to the *) +(* predicates (fun x => a) and (fun x => r); *) +(* if r == R[x], this states that a -> R[f x] *) +(* for all x. *) +(* {homo f : x / a} <-> f is a homomorphism with respect to the *) +(* predicate expression (fun x => a). *) +(* {homo f : x y / a >-> r} <-> f is a homomorphism with respect to the *) +(* relations (fun x y => a) and (fun x y => r). *) +(* {homo f : x y / a} <-> f is a homomorphism with respect to the *) +(* relation expression (fun x y => a). *) +(* {mono f : x / a >-> r} <-> f is monotone with respect to projectors *) +(* (fun x => a) and (fun x => r); if r == R[x], *) +(* this states that R[f x] = a for all x. *) +(* {mono f : x / a} <-> f is monotone with respect to the projector *) +(* expression (fun x => a). *) +(* {mono f : x y / a >-> r} <-> f is monotone with respect to relators *) +(* (fun x y => a) and (fun x y => r). *) +(* {mono f : x y / a} <-> f is monotone with respect to the relator *) +(* expression (fun x y => a). *) +(* *) +(* The file also contains some basic lemmas for the above concepts. *) +(* Lemmas relative to cancellation laws use some abbreviated suffixes: *) +(* K - a cancellation rule like esymK : cancel (@esym T x y) (@esym T y x). *) +(* LR - a lemma moving an operation from the left hand side of a relation to *) +(* the right hand side, like canLR: cancel g f -> x = g y -> f x = y. *) +(* RL - a lemma moving an operation from the right to the left, e.g., canRL. *) +(* Beware that the LR and RL orientations refer to an "apply" (back chaining) *) +(* usage; when using the same lemmas with "have" or "move" (forward chaining) *) +(* the directions will be reversed!. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Delimit Scope fun_scope with FUN. +Open Scope fun_scope. + +(* Notations for argument transpose *) +Notation "f ^~ y" := (fun x => f x y) + (at level 10, y at level 8, no associativity, format "f ^~ y") : fun_scope. +Notation "@^~ x" := (fun f => f x) + (at level 10, x at level 8, no associativity, format "@^~ x") : fun_scope. + +Delimit Scope pair_scope with PAIR. +Open Scope pair_scope. + +(* Notations for pair/conjunction projections *) +Notation "p .1" := (fst p) + (at level 2, left associativity, format "p .1") : pair_scope. +Notation "p .2" := (snd p) + (at level 2, left associativity, format "p .2") : pair_scope. + +Coercion pair_of_and P Q (PandQ : P /\ Q) := (proj1 PandQ, proj2 PandQ). + +Definition all_pair I T U (w : forall i : I, T i * U i) := + (fun i => (w i).1, fun i => (w i).2). + +(* Complements on the option type constructor, used below to *) +(* encode partial functions. *) + +Module Option. + +Definition apply aT rT (f : aT -> rT) x u := if u is Some y then f y else x. + +Definition default T := apply (fun x : T => x). + +Definition bind aT rT (f : aT -> option rT) := apply f None. + +Definition map aT rT (f : aT -> rT) := bind (fun x => Some (f x)). + +End Option. + +Notation oapp := Option.apply. +Notation odflt := Option.default. +Notation obind := Option.bind. +Notation omap := Option.map. +Notation some := (@Some _) (only parsing). + +(* Shorthand for some basic equality lemmas. *) + +Notation erefl := refl_equal. +Notation ecast i T e x := (let: erefl in _ = i := e return T in x). +Definition esym := sym_eq. +Definition nesym := sym_not_eq. +Definition etrans := trans_eq. +Definition congr1 := f_equal. +Definition congr2 := f_equal2. +(* Force at least one implicit when used as a view. *) +Prenex Implicits esym nesym. + +(* A predicate for singleton types. *) +Definition all_equal_to T (x0 : T) := forall x, unkeyed x = x0. + +Lemma unitE : all_equal_to tt. Proof. by case. Qed. + +(* A generic wrapper type *) + +Structure wrapped T := Wrap {unwrap : T}. +Canonical wrap T x := @Wrap T x. + +Prenex Implicits unwrap wrap Wrap. + +(* Syntax for defining auxiliary recursive function. *) +(* Usage: *) +(* Section FooDefinition. *) +(* Variables (g1 : T1) (g2 : T2). (globals) *) +(* Fixoint foo_auxiliary (a3 : T3) ... := *) +(* body, using [rec e3, ...] for recursive calls *) +(* where "[ 'rec' a3 , a4 , ... ]" := foo_auxiliary. *) +(* Definition foo x y .. := [rec e1, ...]. *) +(* + proofs about foo *) +(* End FooDefinition. *) + +Reserved Notation "[ 'rec' a0 ]" + (at level 0, format "[ 'rec' a0 ]"). +Reserved Notation "[ 'rec' a0 , a1 ]" + (at level 0, format "[ 'rec' a0 , a1 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]" + (at level 0, + format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]" + (at level 0, + format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]" + (at level 0, + format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]"). + +(* Definitions and notation for explicit functions with simplification, *) +(* i.e., which simpl and /= beta expand (this is complementary to nosimpl). *) + +Section SimplFun. + +Variables aT rT : Type. + +CoInductive simpl_fun := SimplFun of aT -> rT. + +Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. + +Coercion fun_of_simpl : simpl_fun >-> Funclass. + +End SimplFun. + +Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E)) + (at level 0, + format "'[hv' [ 'fun' : T => '/ ' E ] ']'") : fun_scope. + +Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) + (at level 0, x ident, + format "'[hv' [ 'fun' x => '/ ' E ] ']'") : fun_scope. + +Notation "[ 'fun' x : T => E ]" := (SimplFun (fun x : T => E)) + (at level 0, x ident, only parsing) : fun_scope. + +Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E]) + (at level 0, x ident, y ident, + format "'[hv' [ 'fun' x y => '/ ' E ] ']'") : fun_scope. + +Notation "[ 'fun' x y : T => E ]" := (fun x : T => [fun y : T => E]) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +Notation "[ 'fun' ( x : T ) y => E ]" := (fun x : T => [fun y => E]) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +Notation "[ 'fun' x ( y : T ) => E ]" := (fun x => [fun y : T => E]) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +Notation "[ 'fun' ( x : xT ) ( y : yT ) => E ]" := + (fun x : xT => [fun y : yT => E]) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +(* For delta functions in eqtype.v. *) +Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z]. + +(* Extensional equality, for unary and binary functions, including syntactic *) +(* sugar. *) + +Section ExtensionalEquality. + +Variables A B C : Type. + +Definition eqfun (f g : B -> A) : Prop := forall x, f x = g x. + +Definition eqrel (r s : C -> B -> A) : Prop := forall x y, r x y = s x y. + +Lemma frefl f : eqfun f f. Proof. by []. Qed. +Lemma fsym f g : eqfun f g -> eqfun g f. Proof. by move=> eq_fg x. Qed. + +Lemma ftrans f g h : eqfun f g -> eqfun g h -> eqfun f h. +Proof. by move=> eq_fg eq_gh x; rewrite eq_fg. Qed. + +Lemma rrefl r : eqrel r r. Proof. by []. Qed. + +End ExtensionalEquality. + +Typeclasses Opaque eqfun. +Typeclasses Opaque eqrel. + +Hint Resolve frefl rrefl. + +Notation "f1 =1 f2" := (eqfun f1 f2) + (at level 70, no associativity) : fun_scope. +Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A)) + (at level 70, f2 at next level, A at level 90) : fun_scope. +Notation "f1 =2 f2" := (eqrel f1 f2) + (at level 70, no associativity) : fun_scope. +Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A)) + (at level 70, f2 at next level, A at level 90) : fun_scope. + +Section Composition. + +Variables A B C : Type. + +Definition funcomp u (f : B -> A) (g : C -> B) x := let: tt := u in f (g x). +Definition catcomp u g f := funcomp u f g. +Local Notation comp := (funcomp tt). + +Definition pcomp (f : B -> option A) (g : C -> option B) x := obind f (g x). + +Lemma eq_comp f f' g g' : f =1 f' -> g =1 g' -> comp f g =1 comp f' g'. +Proof. by move=> eq_ff' eq_gg' x; rewrite /= eq_gg' eq_ff'. Qed. + +End Composition. + +Notation comp := (funcomp tt). +Notation "@ 'comp'" := (fun A B C => @funcomp A B C tt). +Notation "f1 \o f2" := (comp f1 f2) + (at level 50, format "f1 \o '/ ' f2") : fun_scope. +Notation "f1 \; f2" := (catcomp tt f1 f2) + (at level 60, right associativity, format "f1 \; '/ ' f2") : fun_scope. + +Notation "[ 'eta' f ]" := (fun x => f x) + (at level 0, format "[ 'eta' f ]") : fun_scope. + +Notation "'fun' => E" := (fun _ => E) (at level 200, only parsing) : fun_scope. + +Notation id := (fun x => x). +Notation "@ 'id' T" := (fun x : T => x) + (at level 10, T at level 8, only parsing) : fun_scope. + +Definition id_head T u x : T := let: tt := u in x. +Definition explicit_id_key := tt. +Notation idfun := (id_head tt). +Notation "@ 'idfun' T " := (@id_head T explicit_id_key) + (at level 10, T at level 8, format "@ 'idfun' T") : fun_scope. + +Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. + +(* Strong sigma types. *) + +Section Tag. + +Variables (I : Type) (i : I) (T_ U_ : I -> Type). + +Definition tag := projS1. +Definition tagged : forall w, T_(tag w) := @projS2 I [eta T_]. +Definition Tagged x := @existS I [eta T_] i x. + +Definition tag2 (w : @sigT2 I T_ U_) := let: existT2 _ _ i _ _ := w in i. +Definition tagged2 w : T_(tag2 w) := let: existT2 _ _ _ x _ := w in x. +Definition tagged2' w : U_(tag2 w) := let: existT2 _ _ _ _ y := w in y. +Definition Tagged2 x y := @existS2 I [eta T_] [eta U_] i x y. + +End Tag. + +Arguments Tagged [I i]. +Arguments Tagged2 [I i]. +Prenex Implicits tag tagged Tagged tag2 tagged2 tagged2' Tagged2. + +Coercion tag_of_tag2 I T_ U_ (w : @sigT2 I T_ U_) := + Tagged (fun i => T_ i * U_ i)%type (tagged2 w, tagged2' w). + +Lemma all_tag I T U : + (forall x : I, {y : T x & U x y}) -> + {f : forall x, T x & forall x, U x (f x)}. +Proof. by move=> fP; exists (fun x => tag (fP x)) => x; case: (fP x). Qed. + +Lemma all_tag2 I T U V : + (forall i : I, {y : T i & U i y & V i y}) -> + {f : forall i, T i & forall i, U i (f i) & forall i, V i (f i)}. +Proof. by case/all_tag=> f /all_pair[]; exists f. Qed. + +(* Refinement types. *) + +(* Prenex Implicits and renaming. *) +Notation sval := (@proj1_sig _ _). +Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'"). + +Section Sig. + +Variables (T : Type) (P Q : T -> Prop). + +Lemma svalP (u : sig P) : P (sval u). Proof. by case: u. Qed. + +Definition s2val (u : sig2 P Q) := let: exist2 _ _ x _ _ := u in x. + +Lemma s2valP u : P (s2val u). Proof. by case: u. Qed. + +Lemma s2valP' u : Q (s2val u). Proof. by case: u. Qed. + +End Sig. + +Prenex Implicits svalP s2val s2valP s2valP'. + +Coercion tag_of_sig I P (u : @sig I P) := Tagged P (svalP u). + +Coercion sig_of_sig2 I P Q (u : @sig2 I P Q) := + exist (fun i => P i /\ Q i) (s2val u) (conj (s2valP u) (s2valP' u)). + +Lemma all_sig I T P : + (forall x : I, {y : T x | P x y}) -> + {f : forall x, T x | forall x, P x (f x)}. +Proof. by case/all_tag=> f; exists f. Qed. + +Lemma all_sig2 I T P Q : + (forall x : I, {y : T x | P x y & Q x y}) -> + {f : forall x, T x | forall x, P x (f x) & forall x, Q x (f x)}. +Proof. by case/all_sig=> f /all_pair[]; exists f. Qed. + +Section Morphism. + +Variables (aT rT sT : Type) (f : aT -> rT). + +(* Morphism property for unary and binary functions *) +Definition morphism_1 aF rF := forall x, f (aF x) = rF (f x). +Definition morphism_2 aOp rOp := forall x y, f (aOp x y) = rOp (f x) (f y). + +(* Homomorphism property for unary and binary relations *) +Definition homomorphism_1 (aP rP : _ -> Prop) := forall x, aP x -> rP (f x). +Definition homomorphism_2 (aR rR : _ -> _ -> Prop) := + forall x y, aR x y -> rR (f x) (f y). + +(* Stability property for unary and binary relations *) +Definition monomorphism_1 (aP rP : _ -> sT) := forall x, rP (f x) = aP x. +Definition monomorphism_2 (aR rR : _ -> _ -> sT) := + forall x y, rR (f x) (f y) = aR x y. + +End Morphism. + +Notation "{ 'morph' f : x / a >-> r }" := + (morphism_1 f (fun x => a) (fun x => r)) + (at level 0, f at level 99, x ident, + format "{ 'morph' f : x / a >-> r }") : type_scope. + +Notation "{ 'morph' f : x / a }" := + (morphism_1 f (fun x => a) (fun x => a)) + (at level 0, f at level 99, x ident, + format "{ 'morph' f : x / a }") : type_scope. + +Notation "{ 'morph' f : x y / a >-> r }" := + (morphism_2 f (fun x y => a) (fun x y => r)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'morph' f : x y / a >-> r }") : type_scope. + +Notation "{ 'morph' f : x y / a }" := + (morphism_2 f (fun x y => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'morph' f : x y / a }") : type_scope. + +Notation "{ 'homo' f : x / a >-> r }" := + (homomorphism_1 f (fun x => a) (fun x => r)) + (at level 0, f at level 99, x ident, + format "{ 'homo' f : x / a >-> r }") : type_scope. + +Notation "{ 'homo' f : x / a }" := + (homomorphism_1 f (fun x => a) (fun x => a)) + (at level 0, f at level 99, x ident, + format "{ 'homo' f : x / a }") : type_scope. + +Notation "{ 'homo' f : x y / a >-> r }" := + (homomorphism_2 f (fun x y => a) (fun x y => r)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'homo' f : x y / a >-> r }") : type_scope. + +Notation "{ 'homo' f : x y / a }" := + (homomorphism_2 f (fun x y => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'homo' f : x y / a }") : type_scope. + +Notation "{ 'homo' f : x y /~ a }" := + (homomorphism_2 f (fun y x => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'homo' f : x y /~ a }") : type_scope. + +Notation "{ 'mono' f : x / a >-> r }" := + (monomorphism_1 f (fun x => a) (fun x => r)) + (at level 0, f at level 99, x ident, + format "{ 'mono' f : x / a >-> r }") : type_scope. + +Notation "{ 'mono' f : x / a }" := + (monomorphism_1 f (fun x => a) (fun x => a)) + (at level 0, f at level 99, x ident, + format "{ 'mono' f : x / a }") : type_scope. + +Notation "{ 'mono' f : x y / a >-> r }" := + (monomorphism_2 f (fun x y => a) (fun x y => r)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'mono' f : x y / a >-> r }") : type_scope. + +Notation "{ 'mono' f : x y / a }" := + (monomorphism_2 f (fun x y => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'mono' f : x y / a }") : type_scope. + +Notation "{ 'mono' f : x y /~ a }" := + (monomorphism_2 f (fun y x => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'mono' f : x y /~ a }") : type_scope. + +(* In an intuitionistic setting, we have two degrees of injectivity. The *) +(* weaker one gives only simplification, and the strong one provides a left *) +(* inverse (we show in `fintype' that they coincide for finite types). *) +(* We also define an intermediate version where the left inverse is only a *) +(* partial function. *) + +Section Injections. + +(* rT must come first so we can use @ to mitigate the Coq 1st order *) +(* unification bug (e..g., Coq can't infer rT from a "cancel" lemma). *) +Variables (rT aT : Type) (f : aT -> rT). + +Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2. + +Definition cancel g := forall x, g (f x) = x. + +Definition pcancel g := forall x, g (f x) = Some x. + +Definition ocancel (g : aT -> option rT) h := forall x, oapp h x (g x) = x. + +Lemma can_pcan g : cancel g -> pcancel (fun y => Some (g y)). +Proof. by move=> fK x; congr (Some _). Qed. + +Lemma pcan_inj g : pcancel g -> injective. +Proof. by move=> fK x y /(congr1 g); rewrite !fK => [[]]. Qed. + +Lemma can_inj g : cancel g -> injective. +Proof. by move/can_pcan; apply: pcan_inj. Qed. + +Lemma canLR g x y : cancel g -> x = f y -> g x = y. +Proof. by move=> fK ->. Qed. + +Lemma canRL g x y : cancel g -> f x = y -> x = g y. +Proof. by move=> fK <-. Qed. + +End Injections. + +Lemma Some_inj {T} : injective (@Some T). Proof. by move=> x y []. Qed. + +(* cancellation lemmas for dependent type casts. *) +Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). +Proof. by case: y /. Qed. + +Lemma etrans_id T x y (eqxy : x = y :> T) : etrans (erefl x) eqxy = eqxy. +Proof. by case: y / eqxy. Qed. + +Section InjectionsTheory. + +Variables (A B C : Type) (f g : B -> A) (h : C -> B). + +Lemma inj_id : injective (@id A). +Proof. by []. Qed. + +Lemma inj_can_sym f' : cancel f f' -> injective f' -> cancel f' f. +Proof. by move=> fK injf' x; apply: injf'. Qed. + +Lemma inj_comp : injective f -> injective h -> injective (f \o h). +Proof. by move=> injf injh x y /injf; apply: injh. Qed. + +Lemma can_comp f' h' : cancel f f' -> cancel h h' -> cancel (f \o h) (h' \o f'). +Proof. by move=> fK hK x; rewrite /= fK hK. Qed. + +Lemma pcan_pcomp f' h' : + pcancel f f' -> pcancel h h' -> pcancel (f \o h) (pcomp h' f'). +Proof. by move=> fK hK x; rewrite /pcomp fK /= hK. Qed. + +Lemma eq_inj : injective f -> f =1 g -> injective g. +Proof. by move=> injf eqfg x y; rewrite -2!eqfg; apply: injf. Qed. + +Lemma eq_can f' g' : cancel f f' -> f =1 g -> f' =1 g' -> cancel g g'. +Proof. by move=> fK eqfg eqfg' x; rewrite -eqfg -eqfg'. Qed. + +Lemma inj_can_eq f' : cancel f f' -> injective f' -> cancel g f' -> f =1 g. +Proof. by move=> fK injf' gK x; apply: injf'; rewrite fK. Qed. + +End InjectionsTheory. + +Section Bijections. + +Variables (A B : Type) (f : B -> A). + +CoInductive bijective : Prop := Bijective g of cancel f g & cancel g f. + +Hypothesis bijf : bijective. + +Lemma bij_inj : injective f. +Proof. by case: bijf => g fK _; apply: can_inj fK. Qed. + +Lemma bij_can_sym f' : cancel f' f <-> cancel f f'. +Proof. +split=> fK; first exact: inj_can_sym fK bij_inj. +by case: bijf => h _ hK x; rewrite -[x]hK fK. +Qed. + +Lemma bij_can_eq f' f'' : cancel f f' -> cancel f f'' -> f' =1 f''. +Proof. +by move=> fK fK'; apply: (inj_can_eq _ bij_inj); apply/bij_can_sym. +Qed. + +End Bijections. + +Section BijectionsTheory. + +Variables (A B C : Type) (f : B -> A) (h : C -> B). + +Lemma eq_bij : bijective f -> forall g, f =1 g -> bijective g. +Proof. by case=> f' fK f'K g eqfg; exists f'; eapply eq_can; eauto. Qed. + +Lemma bij_comp : bijective f -> bijective h -> bijective (f \o h). +Proof. +by move=> [f' fK f'K] [h' hK h'K]; exists (h' \o f'); apply: can_comp; auto. +Qed. + +Lemma bij_can_bij : bijective f -> forall f', cancel f f' -> bijective f'. +Proof. by move=> bijf; exists f; first by apply/(bij_can_sym bijf). Qed. + +End BijectionsTheory. + +Section Involutions. + +Variables (A : Type) (f : A -> A). + +Definition involutive := cancel f f. + +Hypothesis Hf : involutive. + +Lemma inv_inj : injective f. Proof. exact: can_inj Hf. Qed. +Lemma inv_bij : bijective f. Proof. by exists f. Qed. + +End Involutions. + +Section OperationProperties. + +Variables S T R : Type. + +Section SopTisR. +Implicit Type op : S -> T -> R. +Definition left_inverse e inv op := forall x, op (inv x) x = e. +Definition right_inverse e inv op := forall x, op x (inv x) = e. +Definition left_injective op := forall x, injective (op^~ x). +Definition right_injective op := forall y, injective (op y). +End SopTisR. + + +Section SopTisS. +Implicit Type op : S -> T -> S. +Definition right_id e op := forall x, op x e = x. +Definition left_zero z op := forall x, op z x = z. +Definition right_commutative op := forall x y z, op (op x y) z = op (op x z) y. +Definition left_distributive op add := + forall x y z, op (add x y) z = add (op x z) (op y z). +Definition right_loop inv op := forall y, cancel (op^~ y) (op^~ (inv y)). +Definition rev_right_loop inv op := forall y, cancel (op^~ (inv y)) (op^~ y). +End SopTisS. + +Section SopTisT. +Implicit Type op : S -> T -> T. +Definition left_id e op := forall x, op e x = x. +Definition right_zero z op := forall x, op x z = z. +Definition left_commutative op := forall x y z, op x (op y z) = op y (op x z). +Definition right_distributive op add := + forall x y z, op x (add y z) = add (op x y) (op x z). +Definition left_loop inv op := forall x, cancel (op x) (op (inv x)). +Definition rev_left_loop inv op := forall x, cancel (op (inv x)) (op x). +End SopTisT. + +Section SopSisT. +Implicit Type op : S -> S -> T. +Definition self_inverse e op := forall x, op x x = e. +Definition commutative op := forall x y, op x y = op y x. +End SopSisT. + +Section SopSisS. +Implicit Type op : S -> S -> S. +Definition idempotent op := forall x, op x x = x. +Definition associative op := forall x y z, op x (op y z) = op (op x y) z. +Definition interchange op1 op2 := + forall x y z t, op1 (op2 x y) (op2 z t) = op2 (op1 x z) (op1 y t). +End SopSisS. + +End OperationProperties. + + + + + + + + + + diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml new file mode 100644 index 000000000..663bca15e --- /dev/null +++ b/plugins/ssr/ssrfwd.ml @@ -0,0 +1,409 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names +open Tacmach + +open Ssrmatching_plugin.Ssrmatching + +open Ssrprinters +open Ssrcommon +open Ssrtacticals + +module RelDecl = Context.Rel.Declaration + +(** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) +(** Defined identifier *) + + +let settac id c = Tactics.letin_tac None (Name id) c None +let posetac id cl = Proofview.V82.of_tactic (settac id cl Locusops.nowhere) + +let ssrposetac ist (id, (_, t)) gl = + let sigma, t, ucst, _ = pf_abs_ssrterm ist gl t in + posetac id t (pf_merge_uc ucst gl) + +open Pp +open Term + +let ssrsettac ist id ((_, (pat, pty)), (_, occ)) gl = + let pat = interp_cpattern ist gl pat (Option.map snd pty) in + let cl, sigma, env = pf_concl gl, project gl, pf_env gl in + let (c, ucst), cl = + let cl = EConstr.Unsafe.to_constr cl in + try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 + with NoMatch -> redex_of_pattern ~resolve_typeclasses:true env pat, cl in + let c = EConstr.of_constr c in + let cl = EConstr.of_constr cl in + if Termops.occur_existential sigma c then errorstrm(str"The pattern"++spc()++ + pr_constr_pat (EConstr.Unsafe.to_constr c)++spc()++str"did not match and has holes."++spc()++ + str"Did you mean pose?") else + let c, (gl, cty) = match EConstr.kind sigma c with + | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) + | _ -> c, pfe_type_of gl c in + let cl' = EConstr.mkLetIn (Name id, c, cty, cl) in + let gl = pf_merge_uc ucst gl in + Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl + +open Util + +let rec is_Evar_or_CastedMeta sigma x = + EConstr.isEvar sigma x || EConstr.isMeta sigma x || + (EConstr.isCast sigma x && is_Evar_or_CastedMeta sigma (pi1 (EConstr.destCast sigma x))) + +let occur_existential_or_casted_meta c = + let rec occrec c = match kind_of_term c with + | Evar _ -> raise Not_found + | Cast (m,_,_) when isMeta m -> raise Not_found + | _ -> iter_constr occrec c + in try occrec c; false with Not_found -> true + +open Printer + +let examine_abstract id gl = + let gl, tid = pfe_type_of gl id in + let abstract, gl = pf_mkSsrConst "abstract" gl in + let sigma = project gl in + if not (EConstr.isApp sigma tid) || not (EConstr.eq_constr sigma (fst(EConstr.destApp sigma tid)) abstract) then + errorstrm(strbrk"not an abstract constant: "++pr_econstr id); + let _, args_id = EConstr.destApp sigma tid in + if Array.length args_id <> 3 then + errorstrm(strbrk"not a proper abstract constant: "++pr_econstr id); + if not (is_Evar_or_CastedMeta sigma args_id.(2)) then + errorstrm(strbrk"abstract constant "++pr_econstr id++str" already used"); + tid, args_id + +let pf_find_abstract_proof check_lock gl abstract_n = + let fire gl t = EConstr.Unsafe.to_constr (Reductionops.nf_evar (project gl) (EConstr.of_constr t)) in + let abstract, gl = pf_mkSsrConst "abstract" gl in + let l = Evd.fold_undefined (fun e ei l -> + match kind_of_term ei.Evd.evar_concl with + | App(hd, [|ty; n; lock|]) + when (not check_lock || + (occur_existential_or_casted_meta (fire gl ty) && + is_Evar_or_CastedMeta (project gl) (EConstr.of_constr @@ fire gl lock))) && + Term.eq_constr hd (EConstr.Unsafe.to_constr abstract) && Term.eq_constr n abstract_n -> e::l + | _ -> l) (project gl) [] in + match l with + | [e] -> e + | _ -> errorstrm(strbrk"abstract constant "++pr_constr abstract_n++ + strbrk" not found in the evar map exactly once. "++ + strbrk"Did you tamper with it?") + +let reduct_in_concl t = Tactics.reduct_in_concl (t, DEFAULTcast) +let unfold cl = + let module R = Reductionops in let module F = CClosure.RedFlags in + reduct_in_concl (R.clos_norm_flags (F.mkflags + (List.map (fun c -> F.fCONST (fst (destConst (EConstr.Unsafe.to_constr c)))) cl @ + [F.fBETA; F.fMATCH; F.fFIX; F.fCOFIX]))) + +open Ssrast +open Ssripats + +let ssrhaveNOtcresolution = Summary.ref ~name:"SSR:havenotcresolution" false + +let inHaveTCResolution = Libobject.declare_object { + (Libobject.default_object "SSRHAVETCRESOLUTION") with + Libobject.cache_function = (fun (_,v) -> ssrhaveNOtcresolution := v); + Libobject.load_function = (fun _ (_,v) -> ssrhaveNOtcresolution := v); + Libobject.classify_function = (fun v -> Libobject.Keep v); +} +let _ = + Goptions.declare_bool_option + { Goptions.optname = "have type classes"; + Goptions.optkey = ["SsrHave";"NoTCResolution"]; + Goptions.optread = (fun _ -> !ssrhaveNOtcresolution); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> + Lib.add_anonymous_leaf (inHaveTCResolution b)) } + + +open Constrexpr +open Glob_term +open Misctypes + +let combineCG t1 t2 f g = match t1, t2 with + | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) + | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) + | _, (_, (_, None)) -> anomaly "have: mixed C-G constr" + | _ -> anomaly "have: mixed G-C constr" + +let basecuttac name c gl = + let hd, gl = pf_mkSsrConst name gl in + let t = EConstr.mkApp (hd, [|c|]) in + let gl, _ = pf_e_type_of gl t in + Proofview.V82.of_tactic (Tactics.apply t) gl + +let havetac ist + (transp,((((clr, pats), binders), simpl), (((fk, _), t), hint))) + suff namefst gl += + let concl = pf_concl gl in + let skols, pats = + List.partition (function IPatNewHidden _ -> true | _ -> false) pats in + let itac_mkabs = introstac ~ist skols in + let itac_c = introstac ~ist (IPatClear clr :: pats) in + let itac, id, clr = introstac ~ist pats, Tacticals.tclIDTAC, cleartac clr in + let binderstac n = + let rec aux = function 0 -> [] | n -> IPatAnon One :: aux (n-1) in + Tacticals.tclTHEN (if binders <> [] then introstac ~ist (aux n) else Tacticals.tclIDTAC) + (introstac ~ist binders) in + let simpltac = introstac ~ist simpl in + let fixtc = + not !ssrhaveNOtcresolution && + match fk with FwdHint(_,true) -> false | _ -> true in + let hint = hinttac ist true hint in + let cuttac t gl = + if transp then + let have_let, gl = pf_mkSsrConst "ssr_have_let" gl in + let step = EConstr.mkApp (have_let, [|concl;t|]) in + let gl, _ = pf_e_type_of gl step in + applyn ~with_evars:true ~with_shelve:false 2 step gl + else basecuttac "ssr_have" t gl in + (* Introduce now abstract constants, so that everything sees them *) + let abstract_key, gl = pf_mkSsrConst "abstract_key" gl in + let unlock_abs (idty,args_id) gl = + let gl, _ = pf_e_type_of gl idty in + pf_unify_HO gl args_id.(2) abstract_key in + Tacticals.tclTHENFIRST itac_mkabs (fun gl -> + let mkt t = mk_term xNoFlag t in + let mkl t = (xNoFlag, (t, None)) in + let interp gl rtc t = pf_abs_ssrterm ~resolve_typeclasses:rtc ist gl t in + let interp_ty gl rtc t = + let a,b,_,u = pf_interp_ty ~resolve_typeclasses:rtc ist gl t in a,b,u in + let open CAst in + let ct, cty, hole, loc = match t with + | _, (_, Some { loc; v = CCast (ct, CastConv cty)}) -> + mkt ct, mkt cty, mkt (mkCHole None), loc + | _, (_, Some ct) -> + mkt ct, mkt (mkCHole None), mkt (mkCHole None), None + | _, ({ loc; v = GCast (ct, CastConv cty) }, None) -> + mkl ct, mkl cty, mkl mkRHole, loc + | _, (t, None) -> mkl t, mkl mkRHole, mkl mkRHole, None in + let gl, cut, sol, itac1, itac2 = + match fk, namefst, suff with + | FwdHave, true, true -> + errorstrm (str"Suff have does not accept a proof term") + | FwdHave, false, true -> + let cty = combineCG cty hole (mkCArrow ?loc) mkRArrow in + let _,t,uc,_ = interp gl false (combineCG ct cty (mkCCast ?loc) mkRCast) in + let gl = pf_merge_uc uc gl in + let gl, ty = pfe_type_of gl t in + let ctx, _ = EConstr.decompose_prod_n_assum (project gl) 1 ty in + let assert_is_conv gl = + try Proofview.V82.of_tactic (convert_concl (EConstr.it_mkProd_or_LetIn concl ctx)) gl + with _ -> errorstrm (str "Given proof term is not of type " ++ + pr_econstr (EConstr.mkArrow (EConstr.mkVar (id_of_string "_")) concl)) in + gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c + | FwdHave, false, false -> + let skols = List.flatten (List.map (function + | IPatNewHidden ids -> ids + | _ -> assert false) skols) in + let skols_args = + List.map (fun id -> examine_abstract (EConstr.mkVar id) gl) skols in + let gl = List.fold_right unlock_abs skols_args gl in + let sigma, t, uc, n_evars = + interp gl false (combineCG ct cty (mkCCast ?loc) mkRCast) in + if skols <> [] && n_evars <> 0 then + CErrors.user_err (Pp.strbrk @@ "Automatic generalization of unresolved implicit "^ + "arguments together with abstract variables is "^ + "not supported"); + let gl = re_sig (sig_it gl) (Evd.merge_universe_context sigma uc) in + let gs = + List.map (fun (_,a) -> + pf_find_abstract_proof false gl (EConstr.Unsafe.to_constr a.(1))) skols_args in + let tacopen_skols gl = + let stuff, g = Refiner.unpackage gl in + Refiner.repackage stuff (gs @ [g]) in + let gl, ty = pf_e_type_of gl t in + gl, ty, Proofview.V82.of_tactic (Tactics.apply t), id, + Tacticals.tclTHEN (Tacticals.tclTHEN itac_c simpltac) + (Tacticals.tclTHEN tacopen_skols (fun gl -> + let abstract, gl = pf_mkSsrConst "abstract" gl in + Proofview.V82.of_tactic (unfold [abstract; abstract_key]) gl)) + | _,true,true -> + let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, EConstr.mkArrow ty concl, hint, itac, clr + | _,false,true -> + let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, EConstr.mkArrow ty concl, hint, id, itac_c + | _, false, false -> + let n, cty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, cty, Tacticals.tclTHEN (binderstac n) hint, id, Tacticals.tclTHEN itac_c simpltac + | _, true, false -> assert false in + Tacticals.tclTHENS (cuttac cut) [ Tacticals.tclTHEN sol itac1; itac2 ] gl) + gl +;; + +(* to extend the abstract value one needs: + Utility lemma to partially instantiate an abstract constant type. + Lemma use_abstract T n l (x : abstract T n l) : T. + Proof. by case: l x. Qed. +*) +let ssrabstract ist gens (*last*) gl = + let main _ (_,cid) ist gl = +(* + let proj1, proj2, prod = + let pdata = build_prod () in + pdata.Coqlib.proj1, pdata.Coqlib.proj2, pdata.Coqlib.typ in +*) + let concl, env = pf_concl gl, pf_env gl in + let fire gl t = Reductionops.nf_evar (project gl) t in + let abstract, gl = pf_mkSsrConst "abstract" gl in + let abstract_key, gl = pf_mkSsrConst "abstract_key" gl in + let cid_interpreted = interp_cpattern ist gl cid None in + let id = EConstr.mkVar (Option.get (id_of_pattern cid_interpreted)) in + let idty, args_id = examine_abstract id gl in + let abstract_n = args_id.(1) in + let abstract_proof = pf_find_abstract_proof true gl (EConstr.Unsafe.to_constr abstract_n) in + let gl, proof = + let pf_unify_HO gl a b = + try pf_unify_HO gl a b + with _ -> errorstrm(strbrk"The abstract variable "++pr_econstr id++ + strbrk" cannot abstract this goal. Did you generalize it?") in + let find_hole p t = + match EConstr.kind (project gl) t with + | Evar _ (*when last*) -> pf_unify_HO gl concl t, p + | Meta _ (*when last*) -> pf_unify_HO gl concl t, p + | Cast(m,_,_) when EConstr.isEvar (project gl) m || EConstr.isMeta + (project gl) m (*when last*) -> pf_unify_HO gl concl t, p +(* + | Evar _ -> + let sigma, it = project gl, sig_it gl in + let sigma, ty = Evarutil.new_type_evar sigma env in + let gl = re_sig it sigma in + let p = mkApp (proj2,[|ty;concl;p|]) in + let concl = mkApp(prod,[|ty; concl|]) in + pf_unify_HO gl concl t, p + | App(hd, [|left; right|]) when Term.eq_constr hd prod -> + find_hole (mkApp (proj1,[|left;right;p|])) left +*) + | _ -> errorstrm(strbrk"abstract constant "++pr_econstr abstract_n++ + strbrk" has an unexpected shape. Did you tamper with it?") + in + find_hole + ((*if last then*) id + (*else mkApp(mkSsrConst "use_abstract",Array.append args_id [|id|])*)) + (fire gl args_id.(0)) in + let gl = (*if last then*) pf_unify_HO gl abstract_key args_id.(2) (*else gl*) in + let gl, _ = pf_e_type_of gl idty in + let proof = fire gl proof in +(* if last then *) + let tacopen gl = + let stuff, g = Refiner.unpackage gl in + Refiner.repackage stuff [ g; abstract_proof ] in + Tacticals.tclTHENS tacopen [Tacticals.tclSOLVE [Proofview.V82.of_tactic (Tactics.apply proof)]; Proofview.V82.of_tactic (unfold[abstract;abstract_key])] gl +(* else apply proof gl *) + in + let introback ist (gens, _) = + introstac ~ist + (List.map (fun (_,cp) -> match id_of_pattern (interp_cpattern ist gl cp None) with + | None -> IPatAnon One + | Some id -> IPatId id) + (List.tl (List.hd gens))) in + Tacticals.tclTHEN (with_dgens gens main ist) (introback ist gens) gl + + +let destProd_or_LetIn sigma c = + match EConstr.kind sigma c with + | Prod (n,ty,c) -> RelDecl.LocalAssum (n, ty), c + | LetIn (n,bo,ty,c) -> RelDecl.LocalDef (n, bo, ty), c + | _ -> raise DestKO + +let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = + let mkabs gen = abs_wgen false ist (fun x -> x) gen in + let mkclr gen clrs = clr_of_wgen gen clrs in + let mkpats = function + | _, Some ((x, _), _) -> fun pats -> IPatId (hoi_id x) :: pats + | _ -> fun x -> x in + let open CAst in + let ct = match ct with + | (a, (b, Some { v = CCast (_, CastConv cty)})) -> a, (b, Some cty) + | (a, ({ v = GCast (_, CastConv cty) }, None)) -> a, (cty, None) + | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" in + let cut_implies_goal = not (suff || ghave <> `NoGen) in + let c, args, ct, gl = + let gens = List.filter (function _, Some _ -> true | _ -> false) gens in + let concl = pf_concl gl in + let c = EConstr.mkProp in + let c = if cut_implies_goal then EConstr.mkArrow c concl else c in + let gl, args, c = List.fold_right mkabs gens (gl,[],c) in + let env, _ = + List.fold_left (fun (env, c) _ -> + let rd, c = destProd_or_LetIn (project gl) c in + EConstr.push_rel rd env, c) (pf_env gl, c) gens in + let sigma = project gl in + let (sigma, ev) = Evarutil.new_evar env sigma EConstr.mkProp in + let k, _ = EConstr.destEvar sigma ev in + let fake_gl = {Evd.it = k; Evd.sigma = sigma} in + let _, ct, _, uc = pf_interp_ty ist fake_gl ct in + let rec var2rel c g s = match EConstr.kind sigma c, g with + | Prod(Anonymous,_,c), [] -> EConstr.mkProd(Anonymous, EConstr.Vars.subst_vars s ct, c) + | Sort _, [] -> EConstr.Vars.subst_vars s ct + | LetIn(Name id as n,b,ty,c), _::g -> EConstr.mkLetIn (n,b,ty,var2rel c g (id::s)) + | Prod(Name id as n,ty,c), _::g -> EConstr.mkProd (n,ty,var2rel c g (id::s)) + | _ -> CErrors.anomaly(str"SSR: wlog: var2rel: " ++ pr_econstr c) in + let c = var2rel c gens [] in + let rec pired c = function + | [] -> c + | t::ts as args -> match EConstr.kind sigma c with + | Prod(_,_,c) -> pired (EConstr.Vars.subst1 t c) ts + | LetIn(id,b,ty,c) -> EConstr.mkLetIn (id,b,ty,pired c args) + | _ -> CErrors.anomaly(str"SSR: wlog: pired: " ++ pr_econstr c) in + c, args, pired c args, pf_merge_uc uc gl in + let tacipat pats = introstac ~ist pats in + let tacigens = + Tacticals.tclTHEN + (Tacticals.tclTHENLIST(List.rev(List.fold_right mkclr gens [cleartac clr0]))) + (introstac ~ist (List.fold_right mkpats gens [])) in + let hinttac = hinttac ist true hint in + let cut_kind, fst_goal_tac, snd_goal_tac = + match suff, ghave with + | true, `NoGen -> "ssr_wlog", Tacticals.tclTHEN hinttac (tacipat pats), tacigens + | false, `NoGen -> "ssr_wlog", hinttac, Tacticals.tclTHEN tacigens (tacipat pats) + | true, `Gen _ -> assert false + | false, `Gen id -> + if gens = [] then errorstrm(str"gen have requires some generalizations"); + let clear0 = cleartac clr0 in + let id, name_general_hyp, cleanup, pats = match id, pats with + | None, (IPatId id as ip)::pats -> Some id, tacipat [ip], clear0, pats + | None, _ -> None, Tacticals.tclIDTAC, clear0, pats + | Some (Some id),_ -> Some id, introid id, clear0, pats + | Some _,_ -> + let id = mk_anon_id "tmp" gl in + Some id, introid id, Tacticals.tclTHEN clear0 (Proofview.V82.of_tactic (Tactics.clear [id])), pats in + let tac_specialize = match id with + | None -> Tacticals.tclIDTAC + | Some id -> + if pats = [] then Tacticals.tclIDTAC else + let args = Array.of_list args in + ppdebug(lazy(str"specialized="++pr_econstr EConstr.(mkApp (mkVar id,args)))); + ppdebug(lazy(str"specialized_ty="++pr_econstr ct)); + Tacticals.tclTHENS (basecuttac "ssr_have" ct) + [Proofview.V82.of_tactic (Tactics.apply EConstr.(mkApp (mkVar id,args))); Tacticals.tclIDTAC] in + "ssr_have", + (if hint = nohint then tacigens else hinttac), + Tacticals.tclTHENLIST [name_general_hyp; tac_specialize; tacipat pats; cleanup] + in + Tacticals.tclTHENS (basecuttac cut_kind c) [fst_goal_tac; snd_goal_tac] gl + +(** The "suffice" tactic *) + +let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = + let htac = Tacticals.tclTHEN (introstac ~ist pats) (hinttac ist true hint) in + let open CAst in + let c = match c with + | (a, (b, Some { v = CCast (_, CastConv cty)})) -> a, (b, Some cty) + | (a, ({ v = GCast (_, CastConv cty) }, None)) -> a, (cty, None) + | _ -> anomaly "suff: ssr cast hole deleted by typecheck" in + let ctac gl = + let _,ty,_,uc = pf_interp_ty ist gl c in let gl = pf_merge_uc uc gl in + basecuttac "ssr_suff" ty gl in + Tacticals.tclTHENS ctac [htac; Tacticals.tclTHEN (cleartac clr) (introstac ~ist (binders@simpl))] diff --git a/plugins/ssr/ssrfwd.mli b/plugins/ssr/ssrfwd.mli new file mode 100644 index 000000000..6fb97d524 --- /dev/null +++ b/plugins/ssr/ssrfwd.mli @@ -0,0 +1,65 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names + +open Ltac_plugin + +open Ssrast + +val ssrsettac : ist -> Id.t -> ((ssrfwdfmt * (Ssrmatching_plugin.Ssrmatching.cpattern * ssrterm option)) * ssrdocc) -> v82tac + +val ssrposetac : ist -> (Id.t * (ssrfwdfmt * ssrterm)) -> v82tac + +val havetac : + Ssrast.ist -> + bool * + ((((Ssrast.ssrclear * Ssrast.ssripat list) * Ssrast.ssripats) * + Ssrast.ssripats) * + (((Ssrast.ssrfwdkind * 'a) * + ('b * (Glob_term.glob_constr * Constrexpr.constr_expr option))) * + (bool * Tacinterp.Value.t option list))) -> + bool -> + bool -> v82tac +val ssrabstract : + Tacinterp.interp_sign -> + (Ssrast.ssrdocc * Ssrmatching_plugin.Ssrmatching.cpattern) list + list * Ssrast.ssrclear -> v82tac + +val basecuttac : + string -> + EConstr.t -> Proof_type.goal Evd.sigma -> Evar.t list Evd.sigma + +val wlogtac : + Ltac_plugin.Tacinterp.interp_sign -> + ((Ssrast.ssrhyps * Ssrast.ssripats) * 'a) * 'b -> + (Ssrast.ssrhyps * + ((Ssrast.ssrhyp_or_id * string) * + Ssrmatching_plugin.Ssrmatching.cpattern option) + option) + list * + ('c * + (Ssrast.ssrtermkind * + (Glob_term.glob_constr * Constrexpr.constr_expr option))) -> + Ltac_plugin.Tacinterp.Value.t Ssrast.ssrhint -> + bool -> + [< `Gen of Names.Id.t option option | `NoGen > `NoGen ] -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + +val sufftac : + Ssrast.ist -> + (((Ssrast.ssrhyps * Ssrast.ssripats) * Ssrast.ssripat list) * + Ssrast.ssripat list) * + (('a * + (Ssrast.ssrtermkind * + (Glob_term.glob_constr * Constrexpr.constr_expr option))) * + (bool * Tacinterp.Value.t option list)) -> + Proof_type.tactic + diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml new file mode 100644 index 000000000..b850b0e95 --- /dev/null +++ b/plugins/ssr/ssripats.ml @@ -0,0 +1,400 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names +open Pp +open Term +open Tactics +open Tacticals +open Tacmach +open Coqlib +open Util +open Evd +open Printer + +open Ssrmatching_plugin +open Ssrmatching +open Ssrast +open Ssrprinters +open Ssrcommon +open Ssrequality +open Ssrview +open Ssrelim +open Ssrbwd + +module RelDecl = Context.Rel.Declaration +(** Extended intro patterns {{{ ***********************************************) + + +(* There are two ways of "applying" a view to term: *) +(* 1- using a view hint if the view is an instance of some *) +(* (reflection) inductive predicate. *) +(* 2- applying the view if it coerces to a function, adding *) +(* implicit arguments. *) +(* They require guessing the view hints and the number of *) +(* implicits, respectively, which we do by brute force. *) + +let apply_type x xs = Proofview.V82.of_tactic (apply_type x xs) + +let new_tac = Proofview.V82.of_tactic + +let with_top tac gl = + tac_ctx + (tclTHENLIST [ introid top_id; tac (EConstr.mkVar top_id); new_tac (clear [top_id])]) + gl + +let tclTHENS_nonstrict tac tacl taclname gl = + let tacres = tac gl in + let n_gls = List.length (sig_it tacres) in + let n_tac = List.length tacl in + if n_gls = n_tac then tclTHENS_a (fun _ -> tacres) tacl gl else + if n_gls = 0 then tacres else + let pr_only n1 n2 = if n1 < n2 then str "only " else mt () in + let pr_nb n1 n2 name = + pr_only n1 n2 ++ int n1 ++ str (" " ^ String.plural n1 name) in + errorstrm (pr_nb n_tac n_gls taclname ++ spc () + ++ str "for " ++ pr_nb n_gls n_tac "subgoal") + +let rec nat_of_n n = + if n = 0 then EConstr.mkConstruct path_of_O + else EConstr.mkApp (EConstr.mkConstruct path_of_S, [|nat_of_n (n-1)|]) + +let ssr_abstract_id = Summary.ref ~name:"SSR:abstractid" 0 + +let mk_abstract_id () = incr ssr_abstract_id; nat_of_n !ssr_abstract_id + +let ssrmkabs id gl = + let env, concl = pf_env gl, Tacmach.pf_concl gl in + let step = begin fun sigma -> + let (sigma, (abstract_proof, abstract_ty)) = + let (sigma, (ty, _)) = + Evarutil.new_type_evar env sigma Evd.univ_flexible_alg in + let (sigma, ablock) = mkSsrConst "abstract_lock" env sigma in + let (sigma, lock) = Evarutil.new_evar env sigma ablock in + let (sigma, abstract) = mkSsrConst "abstract" env sigma in + let abstract_ty = EConstr.mkApp(abstract, [|ty;mk_abstract_id ();lock|]) in + let (sigma, m) = Evarutil.new_evar env sigma abstract_ty in + (sigma, (m, abstract_ty)) in + let sigma, kont = + let rd = RelDecl.LocalAssum (Name id, abstract_ty) in + let (sigma, ev) = Evarutil.new_evar (EConstr.push_rel rd env) sigma concl in + (sigma, ev) + in +(* pp(lazy(pr_econstr concl)); *) + let term = EConstr.(mkApp (mkLambda(Name id,abstract_ty,kont) ,[|abstract_proof|])) in + let sigma, _ = Typing.type_of env sigma term in + (sigma, term) + end in + Proofview.V82.of_tactic + (Proofview.tclTHEN + (Tactics.New.refine step) + (Proofview.tclFOCUS 1 3 Proofview.shelve)) gl + +let ssrmkabstac ids = + List.fold_right (fun id tac -> tclTHENFIRST (ssrmkabs id) tac) ids tclIDTAC + +(* introstac: for "move" and "clear", tclEQINTROS: for "case" and "elim" *) +(* This block hides the spaghetti-code needed to implement the only two *) +(* tactics that should be used to process intro patters. *) +(* The difficulty is that we don't want to always rename, but we can *) +(* compute needeed renamings only at runtime, so we theread a tree like *) +(* imperativestructure so that outer renamigs are inherited by inner *) +(* ipts and that the cler performed at the end of ipatstac clears hyps *) +(* eventually renamed at runtime. *) +let delayed_clear force rest clr gl = + let gl, ctx = pull_ctx gl in + let hyps = pf_hyps gl in + let () = if not force then List.iter (check_hyp_exists hyps) clr in + if List.exists (fun x -> force || is_name_in_ipats (hyp_id x) rest) clr then + let ren_clr, ren = + List.split (List.map (fun x -> + let x = hyp_id x in + let x' = mk_anon_id (string_of_id x) gl in + x', (x, x')) clr) in + let ctx = { ctx with delayed_clears = ren_clr @ ctx.delayed_clears } in + let gl = push_ctx ctx gl in + tac_ctx (Proofview.V82.of_tactic (rename_hyp ren)) gl + else + let ctx = { ctx with delayed_clears = hyps_ids clr @ ctx.delayed_clears } in + let gl = push_ctx ctx gl in + tac_ctx tclIDTAC gl + +(* Common code to handle generalization lists along with the defective case *) + +let with_defective maintac deps clr ist gl = + let top_id = + match EConstr.kind_of_type (project gl) (pf_concl gl) with + | ProdType (Name id, _, _) + when has_discharged_tag (string_of_id id) -> id + | _ -> top_id in + let top_gen = mkclr clr, cpattern_of_id top_id in + tclTHEN (introid top_id) (maintac deps top_gen ist) gl + +let with_defective_a maintac deps clr ist gl = + let sigma = sig_sig gl in + let top_id = + match EConstr.kind_of_type sigma (without_ctx pf_concl gl) with + | ProdType (Name id, _, _) + when has_discharged_tag (string_of_id id) -> id + | _ -> top_id in + let top_gen = mkclr clr, cpattern_of_id top_id in + tclTHEN_a (tac_ctx (introid top_id)) (maintac deps top_gen ist) gl + +let with_dgens (gensl, clr) maintac ist = match gensl with + | [deps; []] -> with_defective maintac deps clr ist + | [deps; gen :: gens] -> + tclTHEN (genstac (gens, clr) ist) (maintac deps gen ist) + | [gen :: gens] -> tclTHEN (genstac (gens, clr) ist) (maintac [] gen ist) + | _ -> with_defective maintac [] clr ist + +let viewmovetac_aux ?(next=ref []) clear name_ref (_, vl as v) _ gen ist gl = + let cl, c, clr, gl, gen_pat = + let gl, ctx = pull_ctx gl in + let _, gen_pat, a, b, c, ucst, gl = pf_interp_gen_aux ist gl false gen in + a, b ,c, push_ctx ctx (pf_merge_uc ucst gl), gen_pat in + let clr = if clear then clr else [] in + name_ref := (match id_of_pattern gen_pat with Some id -> id | _ -> top_id); + let clr = if clear then clr else [] in + if vl = [] then tac_ctx (genclrtac cl [c] clr) gl + else + let _, _, gl = + pfa_with_view ist ~next v cl c + (fun cl c -> tac_ctx (genclrtac cl [c] clr)) clr gl in + gl + +let move_top_with_view ~next c r v = + with_defective_a (viewmovetac_aux ~next c r v) [] [] + +type block_names = (int * EConstr.types array) option + +let (introstac : ?ist:Tacinterp.interp_sign -> ssripats -> Proof_type.tactic), + (tclEQINTROS : ?ind:block_names ref -> ?ist:Tacinterp.interp_sign -> + Proof_type.tactic -> Proof_type.tactic -> ssripats -> + Proof_type.tactic) += + + let rec ipattac ?ist ~next p : tac_ctx tac_a = fun gl -> +(* pp(lazy(str"ipattac: " ++ pr_ipat p)); *) + match p with + | IPatAnon Drop -> + let id, gl = with_ctx new_wild_id gl in + tac_ctx (introid id) gl + | IPatAnon All -> tac_ctx intro_all gl + (* TODO + | IPatAnon Temporary -> + let (id, orig), gl = with_ctx new_tmp_id gl in + introid_a ~orig id gl + *) + | IPatCase(iorpat) -> + tclIORPAT ?ist (with_top (ssrscasetac false)) iorpat gl + | IPatInj iorpat -> + tclIORPAT ?ist (with_top (ssrscasetac true)) iorpat gl + | IPatRewrite (occ, dir) -> + with_top (ipat_rewrite occ dir) gl + | IPatId id -> tac_ctx (introid id) gl + | IPatNewHidden idl -> tac_ctx (ssrmkabstac idl) gl + | IPatSimpl sim -> + tac_ctx (simpltac sim) gl + | IPatClear clr -> + delayed_clear false !next clr gl + | IPatAnon One -> tac_ctx intro_anon gl + | IPatNoop -> tac_ctx tclIDTAC gl + | IPatView v -> + let ist = + match ist with Some x -> x | _ -> anomaly "ipat: view with no ist" in + let next_keeps = + match !next with (IPatCase _ | IPatRewrite _)::_ -> false | _ -> true in + let top_id = ref top_id in + tclTHENLIST_a [ + (move_top_with_view ~next next_keeps top_id (next_keeps,v) ist); + (fun gl -> + let hyps = without_ctx pf_hyps gl in + if not next_keeps && test_hypname_exists hyps !top_id then + delayed_clear true !next [SsrHyp (Loc.tag !top_id)] gl + else tac_ctx tclIDTAC gl)] + gl + + and tclIORPAT ?ist tac = function + | [[]] -> tac + | orp -> tclTHENS_nonstrict tac (List.map (ipatstac ?ist) orp) "intro pattern" + + and ipatstac ?ist ipats gl = + let rec aux ipats gl = + match ipats with + | [] -> tac_ctx tclIDTAC gl + | p :: ps -> + let next = ref ps in + let gl = ipattac ?ist ~next p gl in + tac_on_all gl (aux !next) + in + aux ipats gl + in + + let rec split_itacs ?ist ~ind tac' = function + | (IPatSimpl _ | IPatClear _ as spat) :: ipats' -> + let tac = ipattac ?ist ~next:(ref ipats') spat in + split_itacs ?ist ~ind (tclTHEN_a tac' tac) ipats' + | IPatCase iorpat :: ipats' -> + tclIORPAT ?ist tac' iorpat, ipats' + | ipats' -> tac', ipats' in + + let combine_tacs tac eqtac ipats ?ist ~ind gl = + let tac1, ipats' = split_itacs ?ist ~ind tac ipats in + let tac2 = ipatstac ?ist ipats' in + tclTHENLIST_a [ tac1; eqtac; tac2 ] gl in + + (* Exported code *) + let introstac ?ist ipats gl = + with_fresh_ctx (tclTHENLIST_a [ + ipatstac ?ist ipats; + gen_tmp_ids ?ist; + clear_wilds_and_tmp_and_delayed_ids + ]) gl in + + let tclEQINTROS ?(ind=ref None) ?ist tac eqtac ipats gl = + with_fresh_ctx (tclTHENLIST_a [ + combine_tacs (tac_ctx tac) (tac_ctx eqtac) ipats ?ist ~ind; + gen_tmp_ids ?ist; + clear_wilds_and_tmp_and_delayed_ids; + ]) gl in + + introstac, tclEQINTROS +;; + +(* Intro patterns processing for elim tactic*) +let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr gl = + (* Utils of local interest only *) + let iD s ?t gl = let t = match t with None -> pf_concl gl | Some x -> x in + ppdebug(lazy Pp.(str s ++ pr_econstr t)); Tacticals.tclIDTAC gl in + let protectC, gl = pf_mkSsrConst "protect_term" gl in + let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in + let eq = EConstr.of_constr eq in + let fire_subst gl t = Reductionops.nf_evar (project gl) t in + let intro_eq = + match eqid with + | Some (IPatId ipat) when not is_rec -> + let rec intro_eq gl = match EConstr.kind_of_type (project gl) (pf_concl gl) with + | ProdType (_, src, tgt) -> + (match EConstr.kind_of_type (project gl) src with + | AtomicType (hd, _) when EConstr.eq_constr (project gl) hd protectC -> + Tacticals.tclTHENLIST [unprotecttac; introid ipat] gl + | _ -> Tacticals.tclTHENLIST [ iD "IA"; Ssrcommon.intro_anon; intro_eq] gl) + |_ -> errorstrm (Pp.str "Too many names in intro pattern") in + intro_eq + | Some (IPatId ipat) -> + let name gl = mk_anon_id "K" gl in + let intro_lhs gl = + let elim_name = match clr, what with + | [SsrHyp(_, x)], _ -> x + | _, `EConstr(_,_,t) when EConstr.isVar (project gl) t -> EConstr.destVar (project gl) t + | _ -> name gl in + if is_name_in_ipats elim_name ipats then introid (name gl) gl + else introid elim_name gl + in + let rec gen_eq_tac gl = + let concl = pf_concl gl in + let ctx, last = EConstr.decompose_prod_assum (project gl) concl in + let args = match EConstr.kind_of_type (project gl) last with + | AtomicType (hd, args) -> assert(EConstr.eq_constr (project gl) hd protectC); args + | _ -> assert false in + let case = args.(Array.length args-1) in + if not(EConstr.Vars.closed0 (project gl) case) then Tacticals.tclTHEN Ssrcommon.intro_anon gen_eq_tac gl + else + let gl, case_ty = pfe_type_of gl case in + let refl = EConstr.mkApp (eq, [|EConstr.Vars.lift 1 case_ty; EConstr.mkRel 1; EConstr.Vars.lift 1 case|]) in + let new_concl = fire_subst gl + EConstr.(mkProd (Name (name gl), case_ty, mkArrow refl (Vars.lift 2 concl))) in + let erefl, gl = mkRefl case_ty case gl in + let erefl = fire_subst gl erefl in + apply_type new_concl [case;erefl] gl in + Tacticals.tclTHENLIST [gen_eq_tac; intro_lhs; introid ipat] + | _ -> Tacticals.tclIDTAC in + let unprot = if eqid <> None && is_rec then unprotecttac else Tacticals.tclIDTAC in + tclEQINTROS ?ist ssrelim (Tacticals.tclTHENLIST [intro_eq; unprot]) ipats gl + +(* General case *) +let tclINTROS ist t ip = tclEQINTROS ~ist (t ist) tclIDTAC ip + +(* }}} *) + +let viewmovetac ?next v deps gen ist gl = + with_fresh_ctx + (tclTHEN_a + (viewmovetac_aux ?next true (ref top_id) v deps gen ist) + clear_wilds_and_tmp_and_delayed_ids) + gl + +let mkCoqEq gl = + let sigma = project gl in + let (sigma, eq) = EConstr.fresh_global (pf_env gl) sigma (build_coq_eq_data()).eq in + let gl = { gl with sigma } in + eq, gl + +let mkEq dir cl c t n gl = + let open EConstr in + let eqargs = [|t; c; c|] in eqargs.(dir_org dir) <- mkRel n; + let eq, gl = mkCoqEq gl in + let refl, gl = mkRefl t c gl in + mkArrow (mkApp (eq, eqargs)) (EConstr.Vars.lift 1 cl), refl, gl + +let pushmoveeqtac cl c gl = + let open EConstr in + let x, t, cl1 = destProd (project gl) cl in + let cl2, eqc, gl = mkEq R2L cl1 c t 1 gl in + apply_type (mkProd (x, t, cl2)) [c; eqc] gl + +let eqmovetac _ gen ist gl = + let cl, c, _, gl = pf_interp_gen ist gl false gen in pushmoveeqtac cl c gl + +let movehnftac gl = match EConstr.kind (project gl) (pf_concl gl) with + | Prod _ | LetIn _ -> tclIDTAC gl + | _ -> new_tac hnf_in_concl gl + +let rec eqmoveipats eqpat = function + | (IPatSimpl _ | IPatClear _ as ipat) :: ipats -> ipat :: eqmoveipats eqpat ipats + | (IPatAnon All :: _ | []) as ipats -> IPatAnon One :: eqpat :: ipats + | ipat :: ipats -> ipat :: eqpat :: ipats + +let ssrmovetac ist = function + | _::_ as view, (_, (dgens, ipats)) -> + let next = ref ipats in + let dgentac = with_dgens dgens (viewmovetac ~next (true, view)) ist in + tclTHEN dgentac (fun gl -> introstac ~ist !next gl) + | _, (Some pat, (dgens, ipats)) -> + let dgentac = with_dgens dgens eqmovetac ist in + tclTHEN dgentac (introstac ~ist (eqmoveipats pat ipats)) + | _, (_, (([gens], clr), ipats)) -> + let gentac = genstac (gens, clr) ist in + tclTHEN gentac (introstac ~ist ipats) + | _, (_, ((_, clr), ipats)) -> + tclTHENLIST [movehnftac; cleartac clr; introstac ~ist ipats] + +let ssrcasetac ist (view, (eqid, (dgens, ipats))) = + let ndefectcasetac view eqid ipats deps ((_, occ), _ as gen) ist gl = + let simple = (eqid = None && deps = [] && occ = None) in + let cl, c, clr, gl = pf_interp_gen ist gl true gen in + let _,vc, gl = + if view = [] then c,c, gl else pf_with_view_linear ist gl (false, view) cl c in + if simple && is_injection_case vc gl then + tclTHENLIST [perform_injection vc; cleartac clr; introstac ~ist ipats] gl + else + (* macro for "case/v E: x" ---> "case E: x / (v x)" *) + let deps, clr, occ = + if view <> [] && eqid <> None && deps = [] then [gen], [], None + else deps, clr, occ in + ssrelim ~is_case:true ~ist deps (`EConstr (clr,occ, vc)) eqid (elim_intro_tac ipats) gl + in + with_dgens dgens (ndefectcasetac view eqid ipats) ist + +let ssrapplytac ist (views, (_, ((gens, clr), intros))) = + tclINTROS ist (inner_ssrapplytac views gens clr) intros + + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssripats.mli b/plugins/ssr/ssripats.mli new file mode 100644 index 000000000..e90e75552 --- /dev/null +++ b/plugins/ssr/ssripats.mli @@ -0,0 +1,82 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ssrmatching_plugin +open Ssrast +open Ssrcommon + +type block_names = (int * EConstr.types array) option + +(* For case/elim with eq generation: args are elim_tac introeq_tac ipats + * elim E : "=> ipats" where E give rise to introeq_tac *) +val tclEQINTROS : + ?ind:block_names ref -> + ?ist:ist -> + v82tac -> + v82tac -> ssripats -> v82tac +(* special case with no eq and tactic taking ist *) +val tclINTROS : + ist -> + (ist -> v82tac) -> + ssripats -> v82tac + +(* move=> ipats *) +val introstac : ?ist:ist -> ssripats -> v82tac + +val elim_intro_tac : + Ssrast.ssripats -> + ?ist:Tacinterp.interp_sign -> + [> `EConstr of 'a * 'b * EConstr.t ] -> + Ssrast.ssripat option -> + Proof_type.tactic -> + bool -> + Ssrast.ssrhyp list -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + +(* "move=> top; tac top; clear top" respecting the speed *) +val with_top : (EConstr.t -> v82tac) -> tac_ctx tac_a + +val ssrmovetac : + Ltac_plugin.Tacinterp.interp_sign -> + Ssrast.ssrterm list * + (Ssrast.ssripat option * + (((Ssrast.ssrdocc * Ssrmatching.cpattern) list + list * Ssrast.ssrclear) * + Ssrast.ssripats)) -> + Proof_type.tactic + +val movehnftac : Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + +val with_dgens : + (Ssrast.ssrdocc * Ssrmatching.cpattern) list + list * Ssrast.ssrclear -> + ((Ssrast.ssrdocc * Ssrmatching.cpattern) list -> + Ssrast.ssrdocc * Ssrmatching.cpattern -> + Ltac_plugin.Tacinterp.interp_sign -> Proof_type.tactic) -> + Ltac_plugin.Tacinterp.interp_sign -> Proof_type.tactic + +val ssrcasetac : + Ltac_plugin.Tacinterp.interp_sign -> + Ssrast.ssrterm list * + (Ssrast.ssripat option * + (((Ssrast.ssrdocc * Ssrmatching.cpattern) list list * Ssrast.ssrclear) * + Ssrast.ssripats)) -> + Proof_type.tactic + +val ssrapplytac : + Tacinterp.interp_sign -> + Ssrast.ssrterm list * + ('a * + ((((Ssrast.ssrhyps option * Ssrmatching_plugin.Ssrmatching.occ) * + (Ssrast.ssrtermkind * Tacexpr.glob_constr_and_expr)) + list list * Ssrast.ssrhyps) * + Ssrast.ssripats)) -> + Proof_type.tactic + diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 new file mode 100644 index 000000000..1fba39150 --- /dev/null +++ b/plugins/ssr/ssrparser.ml4 @@ -0,0 +1,2349 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names +open Pp +open Pcoq +open Ltac_plugin +open Genarg +open Stdarg +open Tacarg +open Term +open Libnames +open Tactics +open Tacticals +open Tacmach +open Glob_term +open Util +open Tacexpr +open Tacinterp +open Pltac +open Extraargs +open Ppconstr +open Printer + +open Misctypes +open Decl_kinds +open Constrexpr +open Constrexpr_ops + +open Ssrprinters +open Ssrcommon +open Ssrtacticals +open Ssrbwd +open Ssrequality +open Ssrelim + +(** Ssreflect load check. *) + +(* To allow ssrcoq to be fully compatible with the "plain" Coq, we only *) +(* turn on its incompatible features (the new rewrite syntax, and the *) +(* reserved identifiers) when the theory library (ssreflect.v) has *) +(* has actually been required, or is being defined. Because this check *) +(* needs to be done often (for each identifier lookup), we implement *) +(* some caching, repeating the test only when the environment changes. *) +(* We check for protect_term because it is the first constant loaded; *) +(* ssr_have would ultimately be a better choice. *) +let ssr_loaded = Summary.ref ~name:"SSR:loaded" false +let is_ssr_loaded () = + !ssr_loaded || + (if CLexer.is_keyword "SsrSyntax_is_Imported" then ssr_loaded:=true; + !ssr_loaded) + +DECLARE PLUGIN "ssreflect_plugin" +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = CLexer.get_keyword_state () ;; + +let tacltop = (5,Ppextend.E) + +let pr_ssrtacarg _ _ prt = prt tacltop +ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY pr_ssrtacarg +| [ "YouShouldNotTypeThis" ] -> [ CErrors.anomaly (Pp.str "Grammar placeholder match") ] +END +GEXTEND Gram + GLOBAL: ssrtacarg; + ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> tac ]]; +END + +(* Lexically closed tactic for tacticals. *) +let pr_ssrtclarg _ _ prt tac = prt tacltop tac +ARGUMENT EXTEND ssrtclarg TYPED AS ssrtacarg + PRINTED BY pr_ssrtclarg +| [ ssrtacarg(tac) ] -> [ tac ] +END + +open Genarg + +(** Adding a new uninterpreted generic argument type *) +let add_genarg tag pr = + let wit = Genarg.make0 tag in + let tag = Geninterp.Val.create tag in + let glob ist x = (ist, x) in + let subst _ x = x in + let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in + let gen_pr _ _ _ = pr in + let () = Genintern.register_intern0 wit glob in + let () = Genintern.register_subst0 wit subst in + let () = Geninterp.register_interp0 wit interp in + let () = Geninterp.register_val0 wit (Some (Geninterp.Val.Base tag)) in + Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; + wit + +(** Primitive parsing to avoid syntax conflicts with basic tactics. *) + +let accept_before_syms syms strm = + match Util.stream_nth 1 strm with + | Tok.KEYWORD sym when List.mem sym syms -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_any_id syms strm = + match Util.stream_nth 1 strm with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT _ -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_ids syms ids strm = + match Util.stream_nth 1 strm with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT id when List.mem id ids -> () + | _ -> raise Stream.Failure + +open Ssrast +let pr_id = Ppconstr.pr_id +let pr_name = function Name id -> pr_id id | Anonymous -> str "_" +let pr_spc () = str " " +let pr_bar () = Pp.cut() ++ str "|" +let pr_list = prlist_with_sep + +(**************************** ssrhyp **************************************) + +let pr_ssrhyp _ _ _ = pr_hyp + +let wit_ssrhyprep = add_genarg "ssrhyprep" pr_hyp + +let intern_hyp ist (SsrHyp (loc, id) as hyp) = + let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_var) (loc, id)) in + if not_section_id id then hyp else + hyp_err ?loc "Can't clear section hypothesis " id + +open Pcoq.Prim + +ARGUMENT EXTEND ssrhyp TYPED AS ssrhyprep PRINTED BY pr_ssrhyp + INTERPRETED BY interp_hyp + GLOBALIZED BY intern_hyp + | [ ident(id) ] -> [ SsrHyp (Loc.tag ~loc id) ] +END + + +let pr_hoi = hoik pr_hyp +let pr_ssrhoi _ _ _ = pr_hoi + +let wit_ssrhoirep = add_genarg "ssrhoirep" pr_hoi + +let intern_ssrhoi ist = function + | Hyp h -> Hyp (intern_hyp ist h) + | Id (SsrHyp (_, id)) as hyp -> + let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_ident) id) in + hyp + +let interp_ssrhoi ist gl = function + | Hyp h -> let s, h' = interp_hyp ist gl h in s, Hyp h' + | Id (SsrHyp (loc, id)) -> + let s, id' = interp_wit wit_ident ist gl id in + s, Id (SsrHyp (loc, id')) + +ARGUMENT EXTEND ssrhoi_hyp TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Hyp (SsrHyp(Loc.tag ~loc id)) ] +END +ARGUMENT EXTEND ssrhoi_id TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Id (SsrHyp(Loc.tag ~loc id)) ] +END + + +let pr_hyps = pr_list pr_spc pr_hyp +let pr_ssrhyps _ _ _ = pr_hyps + +ARGUMENT EXTEND ssrhyps TYPED AS ssrhyp list PRINTED BY pr_ssrhyps + INTERPRETED BY interp_hyps + | [ ssrhyp_list(hyps) ] -> [ check_hyps_uniq [] hyps; hyps ] +END + +(** Rewriting direction *) + + +let pr_dir = function L2R -> str "->" | R2L -> str "<-" +let pr_rwdir = function L2R -> mt() | R2L -> str "-" + +let wit_ssrdir = add_genarg "ssrdir" pr_dir + +(** Simpl switch *) + + +let pr_simpl = function + | Simpl -1 -> str "/=" + | Cut -1 -> str "//" + | Simpl n -> str "/" ++ int n ++ str "=" + | Cut n -> str "/" ++ int n ++ str"/" + | SimplCut (-1,-1) -> str "//=" + | SimplCut (n,-1) -> str "/" ++ int n ++ str "/=" + | SimplCut (-1,n) -> str "//" ++ int n ++ str "=" + | SimplCut (n,m) -> str "/" ++ int n ++ str "/" ++ int m ++ str "=" + | Nop -> mt () + +let pr_ssrsimpl _ _ _ = pr_simpl + +let wit_ssrsimplrep = add_genarg "ssrsimplrep" pr_simpl + +let test_ssrslashnum b1 b2 strm = + match Util.stream_nth 0 strm with + | Tok.KEYWORD "/" -> + (match Util.stream_nth 1 strm with + | Tok.INT _ when b1 -> + (match Util.stream_nth 2 strm with + | Tok.KEYWORD "=" | Tok.KEYWORD "/=" when not b2 -> () + | Tok.KEYWORD "/" -> + if not b2 then () else begin + match Util.stream_nth 3 strm with + | Tok.INT _ -> () + | _ -> raise Stream.Failure + end + | _ -> raise Stream.Failure) + | Tok.KEYWORD "/" when not b1 -> + (match Util.stream_nth 2 strm with + | Tok.KEYWORD "=" when not b2 -> () + | Tok.INT _ when b2 -> + (match Util.stream_nth 3 strm with + | Tok.KEYWORD "=" -> () + | _ -> raise Stream.Failure) + | _ when not b2 -> () + | _ -> raise Stream.Failure) + | Tok.KEYWORD "=" when not b1 && not b2 -> () + | _ -> raise Stream.Failure) + | Tok.KEYWORD "//" when not b1 -> + (match Util.stream_nth 1 strm with + | Tok.KEYWORD "=" when not b2 -> () + | Tok.INT _ when b2 -> + (match Util.stream_nth 2 strm with + | Tok.KEYWORD "=" -> () + | _ -> raise Stream.Failure) + | _ when not b2 -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure + +let test_ssrslashnum10 = test_ssrslashnum true false +let test_ssrslashnum11 = test_ssrslashnum true true +let test_ssrslashnum01 = test_ssrslashnum false true +let test_ssrslashnum00 = test_ssrslashnum false false + +let negate_parser f x = + let rc = try Some (f x) with Stream.Failure -> None in + match rc with + | None -> () + | Some _ -> raise Stream.Failure + +let test_not_ssrslashnum = + Pcoq.Gram.Entry.of_parser + "test_not_ssrslashnum" (negate_parser test_ssrslashnum10) +let test_ssrslashnum00 = + Pcoq.Gram.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum00 +let test_ssrslashnum10 = + Pcoq.Gram.Entry.of_parser "test_ssrslashnum10" test_ssrslashnum10 +let test_ssrslashnum11 = + Pcoq.Gram.Entry.of_parser "test_ssrslashnum11" test_ssrslashnum11 +let test_ssrslashnum01 = + Pcoq.Gram.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum01 + + +ARGUMENT EXTEND ssrsimpl_ne TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ "//=" ] -> [ SimplCut (~-1,~-1) ] +| [ "/=" ] -> [ Simpl ~-1 ] +END + +Pcoq.(Prim.( +GEXTEND Gram + GLOBAL: ssrsimpl_ne; + ssrsimpl_ne: [ + [ test_ssrslashnum11; "/"; n = natural; "/"; m = natural; "=" -> SimplCut(n,m) + | test_ssrslashnum10; "/"; n = natural; "/" -> Cut n + | test_ssrslashnum10; "/"; n = natural; "=" -> Simpl n + | test_ssrslashnum10; "/"; n = natural; "/=" -> SimplCut (n,~-1) + | test_ssrslashnum10; "/"; n = natural; "/"; "=" -> SimplCut (n,~-1) + | test_ssrslashnum01; "//"; m = natural; "=" -> SimplCut (~-1,m) + | test_ssrslashnum00; "//" -> Cut ~-1 + ]]; + +END +)) + +ARGUMENT EXTEND ssrsimpl TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ ssrsimpl_ne(sim) ] -> [ sim ] +| [ ] -> [ Nop ] +END + +let pr_clear_ne clr = str "{" ++ pr_hyps clr ++ str "}" +let pr_clear sep clr = if clr = [] then mt () else sep () ++ pr_clear_ne clr + +let pr_ssrclear _ _ _ = pr_clear mt + +ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyps PRINTED BY pr_ssrclear +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ check_hyps_uniq [] clr; clr ] +END + +ARGUMENT EXTEND ssrclear TYPED AS ssrclear_ne PRINTED BY pr_ssrclear +| [ ssrclear_ne(clr) ] -> [ clr ] +| [ ] -> [ [] ] +END + +(** Indexes *) + +(* Since SSR indexes are always positive numbers, we use the 0 value *) +(* to encode an omitted index. We reuse the in or_var type, but we *) +(* supply our own interpretation function, which checks for non *) +(* positive values, and allows the use of constr numerals, so that *) +(* e.g., "let n := eval compute in (1 + 3) in (do n!clear)" works. *) + + +let pr_index = function + | Misctypes.ArgVar (_, id) -> pr_id id + | Misctypes.ArgArg n when n > 0 -> int n + | _ -> mt () +let pr_ssrindex _ _ _ = pr_index + +let noindex = Misctypes.ArgArg 0 + +let check_index ?loc i = + if i > 0 then i else CErrors.user_err ?loc (str"Index not positive") +let mk_index ?loc = function + | Misctypes.ArgArg i -> Misctypes.ArgArg (check_index ?loc i) + | iv -> iv + +let interp_index ist gl idx = + Tacmach.project gl, + match idx with + | Misctypes.ArgArg _ -> idx + | Misctypes.ArgVar (loc, id) -> + let i = + try + let v = Id.Map.find id ist.Tacinterp.lfun in + begin match Tacinterp.Value.to_int v with + | Some i -> i + | None -> + begin match Tacinterp.Value.to_constr v with + | Some c -> + let rc = Detyping.detype false [] (pf_env gl) (project gl) c in + begin match Notation.uninterp_prim_token rc with + | _, Constrexpr.Numeral bigi -> int_of_string (Bigint.to_string bigi) + | _ -> raise Not_found + end + | None -> raise Not_found + end end + with _ -> CErrors.user_err ?loc (str"Index not a number") in + Misctypes.ArgArg (check_index ?loc i) + +open Pltac + +ARGUMENT EXTEND ssrindex TYPED AS ssrindex PRINTED BY pr_ssrindex + INTERPRETED BY interp_index +| [ int_or_var(i) ] -> [ mk_index ~loc i ] +END + + +(** Occurrence switch *) + +(* The standard syntax of complemented occurrence lists involves a single *) +(* initial "-", e.g., {-1 3 5}. An initial *) +(* "+" may be used to indicate positive occurrences (the default). The *) +(* "+" is optional, except if the list of occurrences starts with a *) +(* variable or is empty (to avoid confusion with a clear switch). The *) +(* empty positive switch "{+}" selects no occurrences, while the empty *) +(* negative switch "{-}" selects all occurrences explicitly; this is the *) +(* default, but "{-}" prevents the implicit clear, and can be used to *) +(* force dependent elimination -- see ndefectelimtac below. *) + + +let pr_ssrocc _ _ _ = pr_occ + +open Pcoq.Prim + +ARGUMENT EXTEND ssrocc TYPED AS (bool * int list) option PRINTED BY pr_ssrocc +| [ natural(n) natural_list(occ) ] -> [ + Some (false, List.map (check_index ~loc) (n::occ)) ] +| [ "-" natural_list(occ) ] -> [ Some (true, occ) ] +| [ "+" natural_list(occ) ] -> [ Some (false, occ) ] +END + + +(* modality *) + + +let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () + +let wit_ssrmmod = add_genarg "ssrmmod" pr_mmod +let ssrmmod = Pcoq.create_generic_entry Pcoq.utactic "ssrmmod" (Genarg.rawwit wit_ssrmmod);; + +GEXTEND Gram + GLOBAL: ssrmmod; + ssrmmod: [[ "!" -> Must | LEFTQMARK -> May | "?" -> May]]; +END + +(** Rewrite multiplier: !n ?n *) + +let pr_mult (n, m) = + if n > 0 && m <> Once then int n ++ pr_mmod m else pr_mmod m + +let pr_ssrmult _ _ _ = pr_mult + +ARGUMENT EXTEND ssrmult_ne TYPED AS int * ssrmmod PRINTED BY pr_ssrmult + | [ natural(n) ssrmmod(m) ] -> [ check_index ~loc n, m ] + | [ ssrmmod(m) ] -> [ notimes, m ] +END + +ARGUMENT EXTEND ssrmult TYPED AS ssrmult_ne PRINTED BY pr_ssrmult + | [ ssrmult_ne(m) ] -> [ m ] + | [ ] -> [ nomult ] +END + +(** Discharge occ switch (combined occurrence / clear switch *) + +let pr_docc = function + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear mt clr + +let pr_ssrdocc _ _ _ = pr_docc + +ARGUMENT EXTEND ssrdocc TYPED AS ssrclear option * ssrocc PRINTED BY pr_ssrdocc +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +END + +(* kinds of terms *) + +let input_ssrtermkind strm = match Util.stream_nth 0 strm with + | Tok.KEYWORD "(" -> xInParens + | Tok.KEYWORD "@" -> xWithAt + | _ -> xNoFlag + +let ssrtermkind = Pcoq.Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind + +(* terms *) + +(** Terms parsing. ********************************************************) + +let interp_constr = interp_wit wit_constr + +(* Because we allow wildcards in term references, we need to stage the *) +(* interpretation of terms so that it occurs at the right time during *) +(* the execution of the tactic (e.g., so that we don't report an error *) +(* for a term that isn't actually used in the execution). *) +(* The term representation tracks whether the concrete initial term *) +(* started with an opening paren, which might avoid a conflict between *) +(* the ssrreflect term syntax and Gallina notation. *) + +(* terms *) +let pr_ssrterm _ _ _ = pr_term +let force_term ist gl (_, c) = interp_constr ist gl c +let glob_ssrterm gs = function + | k, (_, Some c) -> k, Tacintern.intern_constr gs c + | ct -> ct +let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c +let interp_ssrterm _ gl t = Tacmach.project gl, t + +open Pcoq.Constr + +ARGUMENT EXTEND ssrterm + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_ssrterm SUBSTITUTED BY subst_ssrterm + RAW_PRINTED BY pr_ssrterm + GLOB_PRINTED BY pr_ssrterm +| [ "YouShouldNotTypeThis" constr(c) ] -> [ mk_lterm c ] +END + + +GEXTEND Gram + GLOBAL: ssrterm; + ssrterm: [[ k = ssrtermkind; c = Pcoq.Constr.constr -> mk_term k c ]]; +END + +(* Views *) + +let pr_view = pr_list mt (fun c -> str "/" ++ pr_term c) + +let pr_ssrview _ _ _ = pr_view + +ARGUMENT EXTEND ssrview TYPED AS ssrterm list + PRINTED BY pr_ssrview +| [ "YouShouldNotTypeThis" ] -> [ [] ] +END + +Pcoq.( +GEXTEND Gram + GLOBAL: ssrview; + ssrview: [ + [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> [mk_term xNoFlag c] + | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrview -> + (mk_term xNoFlag c) :: w ]]; +END +) + +(* }}} *) + +(* ipats *) + + +let remove_loc = snd + +let ipat_of_intro_pattern p = Misctypes.( + let rec ipat_of_intro_pattern = function + | IntroNaming (IntroIdentifier id) -> IPatId id + | IntroAction IntroWildcard -> IPatAnon Drop + | IntroAction (IntroOrAndPattern (IntroOrPattern iorpat)) -> + IPatCase + (List.map (List.map ipat_of_intro_pattern) + (List.map (List.map remove_loc) iorpat)) + | IntroAction (IntroOrAndPattern (IntroAndPattern iandpat)) -> + IPatCase + [List.map ipat_of_intro_pattern (List.map remove_loc iandpat)] + | IntroNaming IntroAnonymous -> IPatAnon One + | IntroAction (IntroRewrite b) -> IPatRewrite (allocc, if b then L2R else R2L) + | IntroNaming (IntroFresh id) -> IPatAnon One + | IntroAction (IntroApplyOn _) -> (* to do *) CErrors.user_err (Pp.str "TO DO") + | IntroAction (IntroInjection ips) -> + IPatInj [List.map ipat_of_intro_pattern (List.map remove_loc ips)] + | IntroForthcoming _ -> + (* Unable to determine which kind of ipat interp_introid could + * return [HH] *) + assert false + in + ipat_of_intro_pattern p +) + +let rec pr_ipat p = + match p with + | IPatId id -> pr_id id + | IPatSimpl sim -> pr_simpl sim + | IPatClear clr -> pr_clear mt clr + | IPatCase iorpat -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") + | IPatInj iorpat -> hov 1 (str "[=" ++ pr_iorpat iorpat ++ str "]") + | IPatRewrite (occ, dir) -> pr_occ occ ++ pr_dir dir + | IPatAnon All -> str "*" + | IPatAnon Drop -> str "_" + | IPatAnon One -> str "?" + | IPatView v -> pr_view v + | IPatNoop -> str "-" + | IPatNewHidden l -> str "[:" ++ pr_list spc pr_id l ++ str "]" +(* TODO | IPatAnon Temporary -> str "+" *) + +and pr_iorpat iorpat = pr_list pr_bar pr_ipats iorpat +and pr_ipats ipats = pr_list spc pr_ipat ipats + +let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat + +let pr_ssripat _ _ _ = pr_ipat +let pr_ssripats _ _ _ = pr_ipats +let pr_ssriorpat _ _ _ = pr_iorpat + +let intern_ipat ist ipat = + let rec check_pat = function + | IPatClear clr -> ignore (List.map (intern_hyp ist) clr) + | IPatCase iorpat -> List.iter (List.iter check_pat) iorpat + | IPatInj iorpat -> List.iter (List.iter check_pat) iorpat + | _ -> () in + check_pat ipat; ipat + +let intern_ipats ist = List.map (intern_ipat ist) + +let interp_intro_pattern = interp_wit wit_intro_pattern + +let interp_introid ist gl id = Misctypes.( + try IntroNaming (IntroIdentifier (hyp_id (snd (interp_hyp ist gl (SsrHyp (Loc.tag id)))))) + with _ -> snd(snd (interp_intro_pattern ist gl (Loc.tag @@ IntroNaming (IntroIdentifier id)))) +) + +let rec add_intro_pattern_hyps (loc, ipat) hyps = Misctypes.( + match ipat with + | IntroNaming (IntroIdentifier id) -> + if not_section_id id then SsrHyp (loc, id) :: hyps else + hyp_err ?loc "Can't delete section hypothesis " id + | IntroAction IntroWildcard -> hyps + | IntroAction (IntroOrAndPattern (IntroOrPattern iorpat)) -> + List.fold_right (List.fold_right add_intro_pattern_hyps) iorpat hyps + | IntroAction (IntroOrAndPattern (IntroAndPattern iandpat)) -> + List.fold_right add_intro_pattern_hyps iandpat hyps + | IntroNaming IntroAnonymous -> [] + | IntroNaming (IntroFresh _) -> [] + | IntroAction (IntroRewrite _) -> hyps + | IntroAction (IntroInjection ips) -> List.fold_right add_intro_pattern_hyps ips hyps + | IntroAction (IntroApplyOn (c,pat)) -> add_intro_pattern_hyps pat hyps + | IntroForthcoming _ -> + (* As in ipat_of_intro_pattern, was unable to determine which kind + of ipat interp_introid could return [HH] *) assert false +) + +(* MD: what does this do? *) +let interp_ipat ist gl = Misctypes.( + let ltacvar id = Id.Map.mem id ist.Tacinterp.lfun in + let rec interp = function + | IPatId id when ltacvar id -> + ipat_of_intro_pattern (interp_introid ist gl id) + | IPatClear clr -> + let add_hyps (SsrHyp (loc, id) as hyp) hyps = + if not (ltacvar id) then hyp :: hyps else + add_intro_pattern_hyps (loc, (interp_introid ist gl id)) hyps in + let clr' = List.fold_right add_hyps clr [] in + check_hyps_uniq [] clr'; IPatClear clr' + | IPatCase(iorpat) -> + IPatCase(List.map (List.map interp) iorpat) + | IPatInj iorpat -> IPatInj (List.map (List.map interp) iorpat) + | IPatNewHidden l -> + IPatNewHidden + (List.map (function + | IntroNaming (IntroIdentifier id) -> id + | _ -> assert false) + (List.map (interp_introid ist gl) l)) + | ipat -> ipat in + interp +) + +let interp_ipats ist gl l = project gl, List.map (interp_ipat ist gl) l + +let pushIPatRewrite = function + | pats :: orpat -> (IPatRewrite (allocc, L2R) :: pats) :: orpat + | [] -> [] + +let pushIPatNoop = function + | pats :: orpat -> (IPatNoop :: pats) :: orpat + | [] -> [] + +ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY pr_ssripats + INTERPRETED BY interp_ipats + GLOBALIZED BY intern_ipats + | [ "_" ] -> [ [IPatAnon Drop] ] + | [ "*" ] -> [ [IPatAnon All] ] + (* + | [ "^" "*" ] -> [ [IPatFastMode] ] + | [ "^" "_" ] -> [ [IPatSeed `Wild] ] + | [ "^_" ] -> [ [IPatSeed `Wild] ] + | [ "^" "?" ] -> [ [IPatSeed `Anon] ] + | [ "^?" ] -> [ [IPatSeed `Anon] ] + | [ "^" ident(id) ] -> [ [IPatSeed (`Id(id,`Pre))] ] + | [ "^" "~" ident(id) ] -> [ [IPatSeed (`Id(id,`Post))] ] + | [ "^~" ident(id) ] -> [ [IPatSeed (`Id(id,`Post))] ] + *) + | [ ident(id) ] -> [ [IPatId id] ] + | [ "?" ] -> [ [IPatAnon One] ] +(* TODO | [ "+" ] -> [ [IPatAnon Temporary] ] *) + | [ ssrsimpl_ne(sim) ] -> [ [IPatSimpl sim] ] + | [ ssrdocc(occ) "->" ] -> [ match occ with + | None, occ -> [IPatRewrite (occ, L2R)] + | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, L2R)]] + | [ ssrdocc(occ) "<-" ] -> [ match occ with + | None, occ -> [IPatRewrite (occ, R2L)] + | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, R2L)]] + | [ ssrdocc(occ) ] -> [ match occ with + | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl] + | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here")] + | [ "->" ] -> [ [IPatRewrite (allocc, L2R)] ] + | [ "<-" ] -> [ [IPatRewrite (allocc, R2L)] ] + | [ "-" ] -> [ [IPatNoop] ] + | [ "-/" "=" ] -> [ [IPatNoop;IPatSimpl(Simpl ~-1)] ] + | [ "-/=" ] -> [ [IPatNoop;IPatSimpl(Simpl ~-1)] ] + | [ "-/" "/" ] -> [ [IPatNoop;IPatSimpl(Cut ~-1)] ] + | [ "-//" ] -> [ [IPatNoop;IPatSimpl(Cut ~-1)] ] + | [ "-/" integer(n) "/" ] -> [ [IPatNoop;IPatSimpl(Cut n)] ] + | [ "-/" "/=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] + | [ "-//" "=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] + | [ "-//=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] + | [ "-/" integer(n) "/=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (n,~-1))] ] + | [ "-/" integer(n) "/" integer (m) "=" ] -> + [ [IPatNoop;IPatSimpl(SimplCut(n,m))] ] + | [ ssrview(v) ] -> [ [IPatView v] ] + | [ "[" ":" ident_list(idl) "]" ] -> [ [IPatNewHidden idl] ] + | [ "[:" ident_list(idl) "]" ] -> [ [IPatNewHidden idl] ] +END + +ARGUMENT EXTEND ssripats TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] + | [ ] -> [ [] ] +END + +ARGUMENT EXTEND ssriorpat TYPED AS ssripat list PRINTED BY pr_ssriorpat +| [ ssripats(pats) "|" ssriorpat(orpat) ] -> [ pats :: orpat ] +| [ ssripats(pats) "|-" ">" ssriorpat(orpat) ] -> [ pats :: pushIPatRewrite orpat ] +| [ ssripats(pats) "|-" ssriorpat(orpat) ] -> [ pats :: pushIPatNoop orpat ] +| [ ssripats(pats) "|->" ssriorpat(orpat) ] -> [ pats :: pushIPatRewrite orpat ] +| [ ssripats(pats) "||" ssriorpat(orpat) ] -> [ pats :: [] :: orpat ] +| [ ssripats(pats) "|||" ssriorpat(orpat) ] -> [ pats :: [] :: [] :: orpat ] +| [ ssripats(pats) "||||" ssriorpat(orpat) ] -> [ [pats; []; []; []] @ orpat ] +| [ ssripats(pats) ] -> [ [pats] ] +END + +let reject_ssrhid strm = + match Util.stream_nth 0 strm with + | Tok.KEYWORD "[" -> + (match Util.stream_nth 1 strm with + | Tok.KEYWORD ":" -> raise Stream.Failure + | _ -> ()) + | _ -> () + +let test_nohidden = Pcoq.Gram.Entry.of_parser "test_ssrhid" reject_ssrhid + +ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> [ IPatCase(x) ] +END + +Pcoq.( +GEXTEND Gram + GLOBAL: ssrcpat; + ssrcpat: [ + [ test_nohidden; "["; iorpat = ssriorpat; "]" -> +(* check_no_inner_seed !@loc false iorpat; + IPatCase (understand_case_type iorpat) *) + IPatCase iorpat + | test_nohidden; "[="; iorpat = ssriorpat; "]" -> +(* check_no_inner_seed !@loc false iorpat; *) + IPatInj iorpat ]]; +END +);; + +Pcoq.( +GEXTEND Gram + GLOBAL: ssripat; + ssripat: [[ pat = ssrcpat -> [pat] ]]; +END +) + +ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] + END + +(* subsets of patterns *) + +(* TODO: review what this function does, it looks suspicious *) +let check_ssrhpats loc w_binders ipats = + let err_loc s = CErrors.user_err ~loc ~hdr:"ssreflect" s in + let clr, ipats = + let rec aux clr = function + | IPatClear cl :: tl -> aux (clr @ cl) tl +(* | IPatSimpl (cl, sim) :: tl -> clr @ cl, IPatSimpl ([], sim) :: tl *) + | tl -> clr, tl + in aux [] ipats in + let simpl, ipats = + match List.rev ipats with + | IPatSimpl _ as s :: tl -> [s], List.rev tl + | _ -> [], ipats in + if simpl <> [] && not w_binders then + err_loc (str "No s-item allowed here: " ++ pr_ipats simpl); + let ipat, binders = + let rec loop ipat = function + | [] -> ipat, [] + | ( IPatId _| IPatAnon _| IPatCase _| IPatRewrite _ as i) :: tl -> + if w_binders then + if simpl <> [] && tl <> [] then + err_loc(str"binders XOR s-item allowed here: "++pr_ipats(tl@simpl)) + else if not (List.for_all (function IPatId _ -> true | _ -> false) tl) + then err_loc (str "Only binders allowed here: " ++ pr_ipats tl) + else ipat @ [i], tl + else + if tl = [] then ipat @ [i], [] + else err_loc (str "No binder or s-item allowed here: " ++ pr_ipats tl) + | hd :: tl -> loop (ipat @ [hd]) tl + in loop [] ipats in + ((clr, ipat), binders), simpl + +let pr_hpats (((clr, ipat), binders), simpl) = + pr_clear mt clr ++ pr_ipats ipat ++ pr_ipats binders ++ pr_ipats simpl +let pr_ssrhpats _ _ _ = pr_hpats +let pr_ssrhpats_wtransp _ _ _ (_, x) = pr_hpats x + +ARGUMENT EXTEND ssrhpats TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat +PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc true i ] +END + +ARGUMENT EXTEND ssrhpats_wtransp + TYPED AS bool * (((ssrclear * ssripats) * ssripats) * ssripats) + PRINTED BY pr_ssrhpats_wtransp + | [ ssripats(i) ] -> [ false,check_ssrhpats loc true i ] + | [ ssripats(i) "@" ssripats(j) ] -> [ true,check_ssrhpats loc true (i @ j) ] +END + +ARGUMENT EXTEND ssrhpats_nobs +TYPED AS ((ssrclear * ssripats) * ssripats) * ssripats PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc false i ] +END + +ARGUMENT EXTEND ssrrpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "->" ] -> [ IPatRewrite (allocc, L2R) ] + | [ "<-" ] -> [ IPatRewrite (allocc, R2L) ] +END + +let pr_intros sep intrs = + if intrs = [] then mt() else sep () ++ str "=>" ++ pr_ipats intrs +let pr_ssrintros _ _ _ = pr_intros mt + +ARGUMENT EXTEND ssrintros_ne TYPED AS ssripat + PRINTED BY pr_ssrintros + | [ "=>" ssripats_ne(pats) ] -> [ pats ] +(* TODO | [ "=>" ">" ssripats_ne(pats) ] -> [ IPatFastMode :: pats ] + | [ "=>>" ssripats_ne(pats) ] -> [ IPatFastMode :: pats ] *) +END + +ARGUMENT EXTEND ssrintros TYPED AS ssrintros_ne PRINTED BY pr_ssrintros + | [ ssrintros_ne(intrs) ] -> [ intrs ] + | [ ] -> [ [] ] +END + +let pr_ssrintrosarg _ _ prt (tac, ipats) = + prt tacltop tac ++ pr_intros spc ipats + +ARGUMENT EXTEND ssrintrosarg TYPED AS tactic * ssrintros + PRINTED BY pr_ssrintrosarg +| [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> [ arg, ipats ] +END + +TACTIC EXTEND ssrtclintros +| [ "YouShouldNotTypeThis" ssrintrosarg(arg) ] -> + [ let tac, intros = arg in + Proofview.V82.tactic (Ssripats.tclINTROS ist (fun ist -> ssrevaltac ist tac) intros) ] + END + +(** Defined identifier *) +let pr_ssrfwdid id = pr_spc () ++ pr_id id + +let pr_ssrfwdidx _ _ _ = pr_ssrfwdid + +(* We use a primitive parser for the head identifier of forward *) +(* tactis to avoid syntactic conflicts with basic Coq tactics. *) +ARGUMENT EXTEND ssrfwdid TYPED AS ident PRINTED BY pr_ssrfwdidx + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let accept_ssrfwdid strm = + match stream_nth 0 strm with + | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm + | _ -> raise Stream.Failure + + +let test_ssrfwdid = Gram.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid + +GEXTEND Gram + GLOBAL: ssrfwdid; + ssrfwdid: [[ test_ssrfwdid; id = Prim.ident -> id ]]; + END + + +(* by *) +(** Tactical arguments. *) + +(* We have four kinds: simple tactics, [|]-bracketed lists, hints, and swaps *) +(* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) +(* and subgoal reordering tacticals (; first & ; last), respectively. *) + + +let pr_ortacs prt = + let rec pr_rec = function + | [None] -> spc() ++ str "|" ++ spc() + | None :: tacs -> spc() ++ str "|" ++ pr_rec tacs + | Some tac :: tacs -> spc() ++ str "| " ++ prt tacltop tac ++ pr_rec tacs + | [] -> mt() in + function + | [None] -> spc() + | None :: tacs -> pr_rec tacs + | Some tac :: tacs -> prt tacltop tac ++ pr_rec tacs + | [] -> mt() +let pr_ssrortacs _ _ = pr_ortacs + +ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY pr_ssrortacs +| [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> [ Some tac :: tacs ] +| [ ssrtacarg(tac) "|" ] -> [ [Some tac; None] ] +| [ ssrtacarg(tac) ] -> [ [Some tac] ] +| [ "|" ssrortacs(tacs) ] -> [ None :: tacs ] +| [ "|" ] -> [ [None; None] ] +END + +let pr_hintarg prt = function + | true, tacs -> hv 0 (str "[ " ++ pr_ortacs prt tacs ++ str " ]") + | false, [Some tac] -> prt tacltop tac + | _, _ -> mt() + +let pr_ssrhintarg _ _ = pr_hintarg + + +ARGUMENT EXTEND ssrhintarg TYPED AS bool * ssrortacs PRINTED BY pr_ssrhintarg +| [ "[" "]" ] -> [ nullhint ] +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +| [ ssrtacarg(arg) ] -> [ mk_hint arg ] +END + +ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY pr_ssrhintarg +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +END + + +let pr_hint prt arg = + if arg = nohint then mt() else str "by " ++ pr_hintarg prt arg +let pr_ssrhint _ _ = pr_hint + +ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY pr_ssrhint +| [ ] -> [ nohint ] +END +(** The "in" pseudo-tactical {{{ **********************************************) + +(* We can't make "in" into a general tactical because this would create a *) +(* crippling conflict with the ltac let .. in construct. Hence, we add *) +(* explicitly an "in" suffix to all the extended tactics for which it is *) +(* relevant (including move, case, elim) and to the extended do tactical *) +(* below, which yields a general-purpose "in" of the form do [...] in ... *) + +(* This tactical needs to come before the intro tactics because the latter *) +(* must take precautions in order not to interfere with the discharged *) +(* assumptions. This is especially difficult for discharged "let"s, which *) +(* the default simpl and unfold tactics would erase blindly. *) + +open Ssrmatching_plugin.Ssrmatching + +let pr_wgen = function + | (clr, Some((id,k),None)) -> spc() ++ pr_clear mt clr ++ str k ++ pr_hoi id + | (clr, Some((id,k),Some p)) -> + spc() ++ pr_clear mt clr ++ str"(" ++ str k ++ pr_hoi id ++ str ":=" ++ + pr_cpattern p ++ str ")" + | (clr, None) -> spc () ++ pr_clear mt clr +let pr_ssrwgen _ _ _ = pr_wgen + +(* no globwith for char *) +ARGUMENT EXTEND ssrwgen + TYPED AS ssrclear * ((ssrhoi_hyp * string) * cpattern option) option + PRINTED BY pr_ssrwgen +| [ ssrclear_ne(clr) ] -> [ clr, None ] +| [ ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, " "), None) ] +| [ "@" ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, "@"), None) ] +| [ "(" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id," "),Some p) ] +| [ "(" ssrhoi_id(id) ")" ] -> [ [], Some ((id,"("), None) ] +| [ "(@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +| [ "(" "@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +END + +let pr_clseq = function + | InGoal | InHyps -> mt () + | InSeqGoal -> str "|- *" + | InHypsSeqGoal -> str " |- *" + | InHypsGoal -> str " *" + | InAll -> str "*" + | InHypsSeq -> str " |-" + | InAllHyps -> str "* |-" + +let wit_ssrclseq = add_genarg "ssrclseq" pr_clseq +let pr_clausehyps = pr_list pr_spc pr_wgen +let pr_ssrclausehyps _ _ _ = pr_clausehyps + +ARGUMENT EXTEND ssrclausehyps +TYPED AS ssrwgen list PRINTED BY pr_ssrclausehyps +| [ ssrwgen(hyp) "," ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ] -> [ [hyp] ] +END + +(* type ssrclauses = ssrahyps * ssrclseq *) + +let pr_clauses (hyps, clseq) = + if clseq = InGoal then mt () + else str "in " ++ pr_clausehyps hyps ++ pr_clseq clseq +let pr_ssrclauses _ _ _ = pr_clauses + +ARGUMENT EXTEND ssrclauses TYPED AS ssrwgen list * ssrclseq + PRINTED BY pr_ssrclauses + | [ "in" ssrclausehyps(hyps) "|-" "*" ] -> [ hyps, InHypsSeqGoal ] + | [ "in" ssrclausehyps(hyps) "|-" ] -> [ hyps, InHypsSeq ] + | [ "in" ssrclausehyps(hyps) "*" ] -> [ hyps, InHypsGoal ] + | [ "in" ssrclausehyps(hyps) ] -> [ hyps, InHyps ] + | [ "in" "|-" "*" ] -> [ [], InSeqGoal ] + | [ "in" "*" ] -> [ [], InAll ] + | [ "in" "*" "|-" ] -> [ [], InAllHyps ] + | [ ] -> [ [], InGoal ] +END + + + + +(** Definition value formatting *) + +(* We use an intermediate structure to correctly render the binder list *) +(* abbreviations. We use a list of hints to extract the binders and *) +(* base term from a term, for the two first levels of representation of *) +(* of constr terms. *) + +let pr_binder prl = function + | Bvar x -> + pr_name x + | Bdecl (xs, t) -> + str "(" ++ pr_list pr_spc pr_name xs ++ str " : " ++ prl t ++ str ")" + | Bdef (x, None, v) -> + str "(" ++ pr_name x ++ str " := " ++ prl v ++ str ")" + | Bdef (x, Some t, v) -> + str "(" ++ pr_name x ++ str " : " ++ prl t ++ + str " := " ++ prl v ++ str ")" + | Bstruct x -> + str "{struct " ++ pr_name x ++ str "}" + | Bcast t -> + str ": " ++ prl t + +let rec mkBstruct i = function + | Bvar x :: b -> + if i = 0 then [Bstruct x] else mkBstruct (i - 1) b + | Bdecl (xs, _) :: b -> + let i' = i - List.length xs in + if i' < 0 then [Bstruct (List.nth xs i)] else mkBstruct i' b + | _ :: b -> mkBstruct i b + | [] -> [] + +let rec format_local_binders h0 bl0 = match h0, bl0 with + | BFvar :: h, CLocalAssum ([_, x], _, _) :: bl -> + Bvar x :: format_local_binders h bl + | BFdecl _ :: h, CLocalAssum (lxs, _, t) :: bl -> + Bdecl (List.map snd lxs, t) :: format_local_binders h bl + | BFdef :: h, CLocalDef ((_, x), v, oty) :: bl -> + Bdef (x, oty, v) :: format_local_binders h bl + | _ -> [] + +let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with + | BFvar :: h, { v = CLambdaN ([[_, x], _, _], c) } -> + let bs, c' = format_constr_expr h c in + Bvar x :: bs, c' + | BFdecl _:: h, { v = CLambdaN ([lxs, _, t], c) } -> + let bs, c' = format_constr_expr h c in + Bdecl (List.map snd lxs, t) :: bs, c' + | BFdef :: h, { v = CLetIn((_, x), v, oty, c) } -> + let bs, c' = format_constr_expr h c in + Bdef (x, oty, v) :: bs, c' + | [BFcast], { v = CCast (c, CastConv t) } -> + [Bcast t], c + | BFrec (has_str, has_cast) :: h, + { v = CFix ( _, [_, (Some locn, CStructRec), bl, t, c]) } -> + let bs = format_local_binders h bl in + let bstr = if has_str then [Bstruct (Name (snd locn))] else [] in + bs @ bstr @ (if has_cast then [Bcast t] else []), c + | BFrec (_, has_cast) :: h, { v = CCoFix ( _, [_, bl, t, c]) } -> + format_local_binders h bl @ (if has_cast then [Bcast t] else []), c + | _, c -> + [], c + +let rec format_glob_decl h0 d0 = match h0, d0 with + | BFvar :: h, (x, _, None, _) :: d -> + Bvar x :: format_glob_decl h d + | BFdecl 1 :: h, (x, _, None, t) :: d -> + Bdecl ([x], t) :: format_glob_decl h d + | BFdecl n :: h, (x, _, None, t) :: d when n > 1 -> + begin match format_glob_decl (BFdecl (n - 1) :: h) d with + | Bdecl (xs, _) :: bs -> Bdecl (x :: xs, t) :: bs + | bs -> Bdecl ([x], t) :: bs + end + | BFdef :: h, (x, _, Some v, _) :: d -> + Bdef (x, None, v) :: format_glob_decl h d + | _, (x, _, None, t) :: d -> + Bdecl ([x], t) :: format_glob_decl [] d + | _, (x, _, Some v, _) :: d -> + Bdef (x, None, v) :: format_glob_decl [] d + | _, [] -> [] + +let rec format_glob_constr h0 c0 = let open CAst in match h0, c0 with + | BFvar :: h, { v = GLambda (x, _, _, c) } -> + let bs, c' = format_glob_constr h c in + Bvar x :: bs, c' + | BFdecl 1 :: h, { v = GLambda (x, _, t, c) } -> + let bs, c' = format_glob_constr h c in + Bdecl ([x], t) :: bs, c' + | BFdecl n :: h, { v = GLambda (x, _, t, c) } when n > 1 -> + begin match format_glob_constr (BFdecl (n - 1) :: h) c with + | Bdecl (xs, _) :: bs, c' -> Bdecl (x :: xs, t) :: bs, c' + | _ -> [Bdecl ([x], t)], c + end + | BFdef :: h, { v = GLetIn(x, v, oty, c) } -> + let bs, c' = format_glob_constr h c in + Bdef (x, oty, v) :: bs, c' + | [BFcast], { v = GCast (c, CastConv t) } -> + [Bcast t], c + | BFrec (has_str, has_cast) :: h, { v = GRec (f, _, bl, t, c) } + when Array.length c = 1 -> + let bs = format_glob_decl h bl.(0) in + let bstr = match has_str, f with + | true, GFix ([|Some i, GStructRec|], _) -> mkBstruct i bs + | _ -> [] in + bs @ bstr @ (if has_cast then [Bcast t.(0)] else []), c.(0) + | _, c -> + [], c + +(** Forward chaining argument *) + +(* There are three kinds of forward definitions: *) +(* - Hint: type only, cast to Type, may have proof hint. *) +(* - Have: type option + value, no space before type *) +(* - Pose: binders + value, space before binders. *) + +let pr_fwdkind = function + | FwdHint (s,_) -> str (s ^ " ") | _ -> str " :=" ++ spc () +let pr_fwdfmt (fk, _ : ssrfwdfmt) = pr_fwdkind fk + +let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" pr_fwdfmt + +(* type ssrfwd = ssrfwdfmt * ssrterm *) + +let mkFwdVal fk c = ((fk, []), mk_term xNoFlag c) +let mkssrFwdVal fk c = ((fk, []), (c,None)) +let dC t = CastConv t + +let mkFwdCast fk ?loc t c = ((fk, [BFcast]), mk_term ' ' (CAst.make ?loc @@ CCast (c, dC t))) +let mkssrFwdCast fk loc t c = ((fk, [BFcast]), (c, Some t)) + +let mkFwdHint s t = + let loc = Constrexpr_ops.constr_loc t in + mkFwdCast (FwdHint (s,false)) ?loc t (mkCHole loc) +let mkFwdHintNoTC s t = + let loc = Constrexpr_ops.constr_loc t in + mkFwdCast (FwdHint (s,true)) ?loc t (mkCHole loc) + +let pr_gen_fwd prval prc prlc fk (bs, c) = + let prc s = str s ++ spc () ++ prval prc prlc c in + match fk, bs with + | FwdHint (s,_), [Bcast t] -> str s ++ spc () ++ prlc t + | FwdHint (s,_), _ -> prc (s ^ "(* typeof *)") + | FwdHave, [Bcast t] -> str ":" ++ spc () ++ prlc t ++ prc " :=" + | _, [] -> prc " :=" + | _, _ -> spc () ++ pr_list spc (pr_binder prlc) bs ++ prc " :=" + +let pr_fwd_guarded prval prval' = function +| (fk, h), (_, (_, Some c)) -> + pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c) +| (fk, h), (_, (c, None)) -> + pr_gen_fwd prval' pr_glob_constr prl_glob_constr fk (format_glob_constr h c) + +let pr_unguarded prc prlc = prlc + +let pr_fwd = pr_fwd_guarded pr_unguarded pr_unguarded +let pr_ssrfwd _ _ _ = pr_fwd + +ARGUMENT EXTEND ssrfwd TYPED AS (ssrfwdfmt * ssrterm) PRINTED BY pr_ssrfwd + | [ ":=" lconstr(c) ] -> [ mkFwdVal FwdPose c ] + | [ ":" lconstr (t) ":=" lconstr(c) ] -> [ mkFwdCast FwdPose ~loc t c ] +END + +(** Independent parsing for binders *) + +(* The pose, pose fix, and pose cofix tactics use these internally to *) +(* parse argument fragments. *) + +let pr_ssrbvar prc _ _ v = prc v + +ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY pr_ssrbvar +| [ ident(id) ] -> [ mkCVar ~loc id ] +| [ "_" ] -> [ mkCHole (Some loc) ] +END + +let bvar_lname = let open CAst in function + | { v = CRef (Ident (loc, id), _) } -> Loc.tag ?loc @@ Name id + | { loc = loc } -> Loc.tag ?loc Anonymous + +let pr_ssrbinder prc _ _ (_, c) = prc c + +ARGUMENT EXTEND ssrbinder TYPED AS ssrfwdfmt * constr PRINTED BY pr_ssrbinder + | [ ssrbvar(bv) ] -> + [ let xloc, _ as x = bvar_lname bv in + (FwdPose, [BFvar]), + CAst.make ~loc @@ CLambdaN ([[x],Default Explicit,mkCHole xloc],mkCHole (Some loc)) ] + | [ "(" ssrbvar(bv) ")" ] -> + [ let xloc, _ as x = bvar_lname bv in + (FwdPose, [BFvar]), + CAst.make ~loc @@ CLambdaN ([[x],Default Explicit,mkCHole xloc],mkCHole (Some loc)) ] + | [ "(" ssrbvar(bv) ":" lconstr(t) ")" ] -> + [ let x = bvar_lname bv in + (FwdPose, [BFdecl 1]), + CAst.make ~loc @@ CLambdaN ([[x], Default Explicit, t], mkCHole (Some loc)) ] + | [ "(" ssrbvar(bv) ne_ssrbvar_list(bvs) ":" lconstr(t) ")" ] -> + [ let xs = List.map bvar_lname (bv :: bvs) in + let n = List.length xs in + (FwdPose, [BFdecl n]), + CAst.make ~loc @@ CLambdaN ([xs, Default Explicit, t], mkCHole (Some loc)) ] + | [ "(" ssrbvar(id) ":" lconstr(t) ":=" lconstr(v) ")" ] -> + [ (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, Some t, mkCHole (Some loc)) ] + | [ "(" ssrbvar(id) ":=" lconstr(v) ")" ] -> + [ (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, None, mkCHole (Some loc)) ] + END + +GEXTEND Gram + GLOBAL: ssrbinder; + ssrbinder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + let loc = !@loc in + (FwdPose, [BFvar]), + CAst.make ~loc @@ CLambdaN ([[Loc.tag ~loc Anonymous],Default Explicit,c],mkCHole (Some loc)) ] + ]; +END + +let rec binders_fmts = function + | ((_, h), _) :: bs -> h @ binders_fmts bs + | _ -> [] + +let push_binders c2 bs = + let loc2 = constr_loc c2 in let mkloc loc1 = Loc.merge_opt loc1 loc2 in + let open CAst in + let rec loop ty c = function + | (_, { loc = loc1; v = CLambdaN (b, _) } ) :: bs when ty -> + CAst.make ?loc:(mkloc loc1) @@ CProdN (b, loop ty c bs) + | (_, { loc = loc1; v = CLambdaN (b, _) } ) :: bs -> + CAst.make ?loc:(mkloc loc1) @@ CLambdaN (b, loop ty c bs) + | (_, { loc = loc1; v = CLetIn (x, v, oty, _) } ) :: bs -> + CAst.make ?loc:(mkloc loc1) @@ CLetIn (x, v, oty, loop ty c bs) + | [] -> c + | _ -> anomaly "binder not a lambda nor a let in" in + match c2 with + | { loc; v = CCast (ct, CastConv cty) } -> + CAst.make ?loc @@ (CCast (loop false ct bs, CastConv (loop true cty bs))) + | ct -> loop false ct bs + +let rec fix_binders = let open CAst in function + | (_, { v = CLambdaN ([xs, _, t], _) } ) :: bs -> + CLocalAssum (xs, Default Explicit, t) :: fix_binders bs + | (_, { v = CLetIn (x, v, oty, _) } ) :: bs -> + CLocalDef (x, v, oty) :: fix_binders bs + | _ -> [] + +let pr_ssrstruct _ _ _ = function + | Some id -> str "{struct " ++ pr_id id ++ str "}" + | None -> mt () + +ARGUMENT EXTEND ssrstruct TYPED AS ident option PRINTED BY pr_ssrstruct +| [ "{" "struct" ident(id) "}" ] -> [ Some id ] +| [ ] -> [ None ] +END + +(** The "pose" tactic *) + +(* The plain pose form. *) + +let bind_fwd bs = function + | (fk, h), (ck, (rc, Some c)) -> + (fk,binders_fmts bs @ h), (ck,(rc,Some (push_binders c bs))) + | fwd -> fwd + +ARGUMENT EXTEND ssrposefwd TYPED AS ssrfwd PRINTED BY pr_ssrfwd + | [ ssrbinder_list(bs) ssrfwd(fwd) ] -> [ bind_fwd bs fwd ] +END + +(* The pose fix form. *) + +let pr_ssrfixfwd _ _ _ (id, fwd) = str " fix " ++ pr_id id ++ pr_fwd fwd + +let bvar_locid = function + | { CAst.v = CRef (Ident (loc, id), _) } -> loc, id + | _ -> CErrors.user_err (Pp.str "Missing identifier after \"(co)fix\"") + + +ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd + | [ "fix" ssrbvar(bv) ssrbinder_list(bs) ssrstruct(sid) ssrfwd(fwd) ] -> + [ let (_, id) as lid = bvar_locid bv in + let (fk, h), (ck, (rc, oc)) = fwd in + let c = Option.get oc in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, mkCHole (constr_loc c), c in + let lb = fix_binders bs in + let has_struct, i = + let rec loop = function + (l', Name id') :: _ when Option.equal Id.equal sid (Some id') -> true, (l', id') + | [l', Name id'] when sid = None -> false, (l', id') + | _ :: bn -> loop bn + | [] -> CErrors.user_err (Pp.str "Bad structural argument") in + loop (names_of_local_assums lb) in + let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in + let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some i, CStructRec), lb, t', c']) in + id, ((fk, h'), (ck, (rc, Some fix))) ] +END + + +(* The pose cofix form. *) + +let pr_ssrcofixfwd _ _ _ (id, fwd) = str " cofix " ++ pr_id id ++ pr_fwd fwd + +ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY pr_ssrcofixfwd + | [ "cofix" ssrbvar(bv) ssrbinder_list(bs) ssrfwd(fwd) ] -> + [ let _, id as lid = bvar_locid bv in + let (fk, h), (ck, (rc, oc)) = fwd in + let c = Option.get oc in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, mkCHole (constr_loc c), c in + let h' = BFrec (false, has_cast) :: binders_fmts bs in + let cofix = CAst.make ~loc @@ CCoFix (lid, [lid, fix_binders bs, t', c']) in + id, ((fk, h'), (ck, (rc, Some cofix))) + ] +END + +(* This does not print the type, it should be fixed... *) +let pr_ssrsetfwd _ _ _ (((fk,_),(t,_)), docc) = + pr_gen_fwd (fun _ _ -> pr_cpattern) + (fun _ -> mt()) (fun _ -> mt()) fk ([Bcast ()],t) + +ARGUMENT EXTEND ssrsetfwd +TYPED AS (ssrfwdfmt * (lcpattern * ssrterm option)) * ssrdocc +PRINTED BY pr_ssrsetfwd +| [ ":" lconstr(t) ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdCast FwdPose loc (mk_lterm t) c, mkocc occ ] +| [ ":" lconstr(t) ":=" lcpattern(c) ] -> + [ mkssrFwdCast FwdPose loc (mk_lterm t) c, nodocc ] +| [ ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdVal FwdPose c, mkocc occ ] +| [ ":=" lcpattern(c) ] -> [ mkssrFwdVal FwdPose c, nodocc ] +END + + +let pr_ssrhavefwd _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwd TYPED AS ssrfwd * ssrhint PRINTED BY pr_ssrhavefwd +| [ ":" lconstr(t) ssrhint(hint) ] -> [ mkFwdHint ":" t, hint ] +| [ ":" lconstr(t) ":=" lconstr(c) ] -> [ mkFwdCast FwdHave ~loc t c, nohint ] +| [ ":" lconstr(t) ":=" ] -> [ mkFwdHintNoTC ":" t, nohint ] +| [ ":=" lconstr(c) ] -> [ mkFwdVal FwdHave c, nohint ] +END + +let intro_id_to_binder = List.map (function + | IPatId id -> + let xloc, _ as x = bvar_lname (mkCVar id) in + (FwdPose, [BFvar]), + CAst.make @@ CLambdaN ([[x], Default Explicit, mkCHole xloc], + mkCHole None) + | _ -> anomaly "non-id accepted as binder") + +let binder_to_intro_id = CAst.(List.map (function + | (FwdPose, [BFvar]), { v = CLambdaN ([ids,_,_],_) } + | (FwdPose, [BFdecl _]), { v = CLambdaN ([ids,_,_],_) } -> + List.map (function (_, Name id) -> IPatId id | _ -> IPatAnon One) ids + | (FwdPose, [BFdef]), { v = CLetIn ((_,Name id),_,_,_) } -> [IPatId id] + | (FwdPose, [BFdef]), { v = CLetIn ((_,Anonymous),_,_,_) } -> [IPatAnon One] + | _ -> anomaly "ssrbinder is not a binder")) + +let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwdwbinders + TYPED AS bool * (ssrhpats * (ssrfwd * ssrhint)) + PRINTED BY pr_ssrhavefwdwbinders +| [ ssrhpats_wtransp(trpats) ssrbinder_list(bs) ssrhavefwd(fwd) ] -> + [ let tr, pats = trpats in + let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let hint = bind_fwd allbs (fst fwd), snd fwd in + tr, ((((clr, pats), allbinders), simpl), hint) ] +END + + +let pr_ssrdoarg prc _ prt (((n, m), tac), clauses) = + pr_index n ++ pr_mmod m ++ pr_hintarg prt tac ++ pr_clauses clauses + +ARGUMENT EXTEND ssrdoarg + TYPED AS ((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses + PRINTED BY pr_ssrdoarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +(* type ssrseqarg = ssrindex * (ssrtacarg * ssrtac option) *) + +let pr_seqtacarg prt = function + | (is_first, []), _ -> str (if is_first then "first" else "last") + | tac, Some dtac -> + hv 0 (pr_hintarg prt tac ++ spc() ++ str "|| " ++ prt tacltop dtac) + | tac, _ -> pr_hintarg prt tac + +let pr_ssrseqarg _ _ prt = function + | ArgArg 0, tac -> pr_seqtacarg prt tac + | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg prt tac + +(* We must parse the index separately to resolve the conflict with *) +(* an unindexed tactic. *) +ARGUMENT EXTEND ssrseqarg TYPED AS ssrindex * (ssrhintarg * tactic option) + PRINTED BY pr_ssrseqarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let sq_brace_tacnames = + ["first"; "solve"; "do"; "rewrite"; "have"; "suffices"; "wlog"] + (* "by" is a keyword *) +let accept_ssrseqvar strm = + match stream_nth 0 strm with + | Tok.IDENT id when not (List.mem id sq_brace_tacnames) -> + accept_before_syms_or_ids ["["] ["first";"last"] strm + | _ -> raise Stream.Failure + +let test_ssrseqvar = Gram.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar + +let swaptacarg (loc, b) = (b, []), Some (TacId []) + +let check_seqtacarg dir arg = match snd arg, dir with + | ((true, []), Some (TacAtom (loc, _))), L2R -> + CErrors.user_err ?loc (str "expected \"last\"") + | ((false, []), Some (TacAtom (loc, _))), R2L -> + CErrors.user_err ?loc (str "expected \"first\"") + | _, _ -> arg + +let ssrorelse = Gram.entry_create "ssrorelse" +GEXTEND Gram + GLOBAL: ssrorelse ssrseqarg; + ssrseqidx: [ + [ test_ssrseqvar; id = Prim.ident -> ArgVar (Loc.tag ~loc:!@loc id) + | n = Prim.natural -> ArgArg (check_index ~loc:!@loc n) + ] ]; + ssrswap: [[ IDENT "first" -> !@loc, true | IDENT "last" -> !@loc, false ]]; + ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> tac ]]; + ssrseqarg: [ + [ arg = ssrswap -> noindex, swaptacarg arg + | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> i, (tac, def) + | i = ssrseqidx; arg = ssrswap -> i, swaptacarg arg + | tac = tactic_expr LEVEL "3" -> noindex, (mk_hint tac, None) + ] ]; +END + +let tactic_expr = Pltac.tactic_expr + +(** 1. Utilities *) + +(** Tactic-level diagnosis *) + +(* debug *) + +(* Let's play with the new proof engine API *) +let old_tac = Proofview.V82.tactic + + +(** Name generation {{{ *******************************************************) + +(* Since Coq now does repeated internal checks of its external lexical *) +(* rules, we now need to carve ssreflect reserved identifiers out of *) +(* out of the user namespace. We use identifiers of the form _id_ for *) +(* this purpose, e.g., we "anonymize" an identifier id as _id_, adding *) +(* an extra leading _ if this might clash with an internal identifier. *) +(* We check for ssreflect identifiers in the ident grammar rule; *) +(* when the ssreflect Module is present this is normally an error, *) +(* but we provide a compatibility flag to reduce this to a warning. *) + +let ssr_reserved_ids = Summary.ref ~name:"SSR:idents" true + +let _ = + Goptions.declare_bool_option + { Goptions.optname = "ssreflect identifiers"; + Goptions.optkey = ["SsrIdents"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !ssr_reserved_ids); + Goptions.optwrite = (fun b -> ssr_reserved_ids := b) + } + +let is_ssr_reserved s = + let n = String.length s in n > 2 && s.[0] = '_' && s.[n - 1] = '_' + +let ssr_id_of_string loc s = + if is_ssr_reserved s && is_ssr_loaded () then begin + if !ssr_reserved_ids then + CErrors.user_err ~loc (str ("The identifier " ^ s ^ " is reserved.")) + else if is_internal_name s then + Feedback.msg_warning (str ("Conflict between " ^ s ^ " and ssreflect internal names.")) + else Feedback.msg_warning (str ( + "The name " ^ s ^ " fits the _xxx_ format used for anonymous variables.\n" + ^ "Scripts with explicit references to anonymous variables are fragile.")) + end; id_of_string s + +let ssr_null_entry = Gram.Entry.of_parser "ssr_null" (fun _ -> ()) + +let (!@) = Pcoq.to_coqloc + +GEXTEND Gram + GLOBAL: Prim.ident; + Prim.ident: [[ s = IDENT; ssr_null_entry -> ssr_id_of_string !@loc s ]]; +END + +let perm_tag = "_perm_Hyp_" +let _ = add_internal_name (is_tagged perm_tag) + +(* }}} *) + +(* We must not anonymize context names discharged by the "in" tactical. *) + +(** Tactical extensions. {{{ **************************************************) + +(* The TACTIC EXTEND facility can't be used for defining new user *) +(* tacticals, because: *) +(* - the concrete syntax must start with a fixed string *) +(* We use the following workaround: *) +(* - We use the (unparsable) "YouShouldNotTypeThis" token for tacticals that *) +(* don't start with a token, then redefine the grammar and *) +(* printer using GEXTEND and set_pr_ssrtac, respectively. *) + +type ssrargfmt = ArgSsr of string | ArgSep of string + +let ssrtac_name name = { + mltac_plugin = "ssreflect_plugin"; + mltac_tactic = "ssr" ^ name; +} + +let ssrtac_entry name n = { + mltac_name = ssrtac_name name; + mltac_index = n; +} + +let set_pr_ssrtac name prec afmt = (* FIXME *) () (* + let fmt = List.map (function + | ArgSep s -> Egramml.GramTerminal s + | ArgSsr s -> Egramml.GramTerminal s + | ArgCoq at -> Egramml.GramTerminal "COQ_ARG") afmt in + let tacname = ssrtac_name name in () *) + +let ssrtac_atom ?loc name args = TacML (Loc.tag ?loc (ssrtac_entry name 0, args)) +let ssrtac_expr ?loc name args = ssrtac_atom ?loc name args + +let tclintros_expr ?loc tac ipats = + let args = [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrintrosarg) (tac, ipats))] in + ssrtac_expr ?loc "tclintros" args + +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "1" [ RIGHTA + [ tac = tactic_expr; intros = ssrintros_ne -> tclintros_expr ~loc:!@loc tac intros + ] ]; +END + +(* }}} *) + + +(** Bracketing tactical *) + +(* The tactic pretty-printer doesn't know that some extended tactics *) +(* are actually tacticals. To prevent it from improperly removing *) +(* parentheses we override the parsing rule for bracketed tactic *) +(* expressions so that the pretty-print always reflects the input. *) +(* (Removing user-specified parentheses is dubious anyway). *) + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> Loc.tag ~loc:!@loc (Tacexp tac) ]]; + tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> TacArg arg ]]; +END + +(** The internal "done" and "ssrautoprop" tactics. *) + +(* For additional flexibility, "done" and "ssrautoprop" are *) +(* defined in Ltac. *) +(* Although we provide a default definition in ssreflect, *) +(* we look up the definition dynamically at each call point, *) +(* to allow for user extensions. "ssrautoprop" defaults to *) +(* trivial. *) + +let ssrautoprop gl = + try + let tacname = + try Nametab.locate_tactic (qualid_of_ident (id_of_string "ssrautoprop")) + with Not_found -> Nametab.locate_tactic (ssrqid "ssrautoprop") in + let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in + Proofview.V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl + with Not_found -> Proofview.V82.of_tactic (Auto.full_trivial []) gl + +let () = ssrautoprop_tac := ssrautoprop + +let tclBY tac = tclTHEN tac (donetac ~-1) + +(** Tactical arguments. *) + +(* We have four kinds: simple tactics, [|]-bracketed lists, hints, and swaps *) +(* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) +(* and subgoal reordering tacticals (; first & ; last), respectively. *) + +(* Force use of the tactic_expr parsing entry, to rule out tick marks. *) + +(** The "by" tactical. *) + + +open Ssrfwd + +TACTIC EXTEND ssrtclby +| [ "by" ssrhintarg(tac) ] -> [ Proofview.V82.tactic (hinttac ist true tac) ] +END + +(* }}} *) +(* We can't parse "by" in ARGUMENT EXTEND because it will only be made *) +(* into a keyword in ssreflect.v; so we anticipate this in GEXTEND. *) + +GEXTEND Gram + GLOBAL: ssrhint simple_tactic; + ssrhint: [[ "by"; arg = ssrhintarg -> arg ]]; +END + +open Ssripats + +(** The "do" tactical. ********************************************************) + +(* +type ssrdoarg = ((ssrindex * ssrmmod) * ssrhint) * ssrclauses +*) +TACTIC EXTEND ssrtcldo +| [ "YouShouldNotTypeThis" "do" ssrdoarg(arg) ] -> [ Proofview.V82.tactic (ssrdotac ist arg) ] +END +set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] + +let ssrdotac_expr ?loc n m tac clauses = + let arg = ((n, m), tac), clauses in + ssrtac_expr ?loc "tcldo" [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrdoarg) arg)] + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrdotac: [ + [ tac = tactic_expr LEVEL "3" -> mk_hint tac + | tacs = ssrortacarg -> tacs + ] ]; + tactic_expr: LEVEL "3" [ RIGHTA + [ IDENT "do"; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr ~loc:!@loc noindex m tac clauses + | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> + ssrdotac_expr ~loc:!@loc noindex Once tac clauses + | IDENT "do"; n = int_or_var; m = ssrmmod; + tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr ~loc:!@loc (mk_index ~loc:!@loc n) m tac clauses + ] ]; +END +(* }}} *) + + +(* We can't actually parse the direction separately because this *) +(* would introduce conflicts with the basic ltac syntax. *) +let pr_ssrseqdir _ _ _ = function + | L2R -> str ";" ++ spc () ++ str "first " + | R2L -> str ";" ++ spc () ++ str "last " + +ARGUMENT EXTEND ssrseqdir TYPED AS ssrdir PRINTED BY pr_ssrseqdir +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +TACTIC EXTEND ssrtclseq +| [ "YouShouldNotTypeThis" ssrtclarg(tac) ssrseqdir(dir) ssrseqarg(arg) ] -> + [ Proofview.V82.tactic (tclSEQAT ist tac dir arg) ] +END +set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] + +let tclseq_expr ?loc tac dir arg = + let arg1 = in_gen (rawwit wit_ssrtclarg) tac in + let arg2 = in_gen (rawwit wit_ssrseqdir) dir in + let arg3 = in_gen (rawwit wit_ssrseqarg) (check_seqtacarg dir arg) in + ssrtac_expr ?loc "tclseq" (List.map (fun x -> Tacexpr.TacGeneric x) [arg1; arg2; arg3]) + +GEXTEND Gram + GLOBAL: tactic_expr; + ssr_first: [ + [ tac = ssr_first; ipats = ssrintros_ne -> tclintros_expr ~loc:!@loc tac ipats + | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> TacFirst tacl + ] ]; + ssr_first_else: [ + [ tac1 = ssr_first; tac2 = ssrorelse -> TacOrelse (tac1, tac2) + | tac = ssr_first -> tac ]]; + tactic_expr: LEVEL "4" [ LEFTA + [ tac1 = tactic_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> + TacThen (tac1, tac2) + | tac = tactic_expr; ";"; IDENT "first"; arg = ssrseqarg -> + tclseq_expr ~loc:!@loc tac L2R arg + | tac = tactic_expr; ";"; IDENT "last"; arg = ssrseqarg -> + tclseq_expr ~loc:!@loc tac R2L arg + ] ]; +END +(* }}} *) + +(** 5. Bookkeeping tactics (clear, move, case, elim) *) + +(** Generalization (discharge) item *) + +(* An item is a switch + term pair. *) + +(* type ssrgen = ssrdocc * ssrterm *) + +let pr_gen (docc, dt) = pr_docc docc ++ pr_cpattern dt + +let pr_ssrgen _ _ _ = pr_gen + +ARGUMENT EXTEND ssrgen TYPED AS ssrdocc * cpattern PRINTED BY pr_ssrgen +| [ ssrdocc(docc) cpattern(dt) ] -> [ docc, dt ] +| [ cpattern(dt) ] -> [ nodocc, dt ] +END + +let has_occ ((_, occ), _) = occ <> None + +(** Generalization (discharge) sequence *) + +(* A discharge sequence is represented as a list of up to two *) +(* lists of d-items, plus an ident list set (the possibly empty *) +(* final clear switch). The main list is empty iff the command *) +(* is defective, and has length two if there is a sequence of *) +(* dependent terms (and in that case it is the first of the two *) +(* lists). Thus, the first of the two lists is never empty. *) + +(* type ssrgens = ssrgen list *) +(* type ssrdgens = ssrgens list * ssrclear *) + +let gens_sep = function [], [] -> mt | _ -> spc + +let pr_dgens pr_gen (gensl, clr) = + let prgens s gens = str s ++ pr_list spc pr_gen gens in + let prdeps deps = prgens ": " deps ++ spc () ++ str "/" in + match gensl with + | [deps; []] -> prdeps deps ++ pr_clear pr_spc clr + | [deps; gens] -> prdeps deps ++ prgens " " gens ++ pr_clear spc clr + | [gens] -> prgens ": " gens ++ pr_clear spc clr + | _ -> pr_clear pr_spc clr + +let pr_ssrdgens _ _ _ = pr_dgens pr_gen + +let cons_gen gen = function + | gens :: gensl, clr -> (gen :: gens) :: gensl, clr + | _ -> anomaly "missing gen list" + +let cons_dep (gensl, clr) = + if List.length gensl = 1 then ([] :: gensl, clr) else + CErrors.user_err (Pp.str "multiple dependents switches '/'") + +ARGUMENT EXTEND ssrdgens_tl TYPED AS ssrgen list list * ssrclear + PRINTED BY pr_ssrdgens +| [ "{" ne_ssrhyp_list(clr) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkclr clr, dt) dgens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> + [ [[]], clr ] +| [ "{" ssrocc(occ) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkocc occ, dt) dgens ] +| [ "/" ssrdgens_tl(dgens) ] -> + [ cons_dep dgens ] +| [ cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (nodocc, dt) dgens ] +| [ ] -> + [ [[]], [] ] +END + +ARGUMENT EXTEND ssrdgens TYPED AS ssrdgens_tl PRINTED BY pr_ssrdgens +| [ ":" ssrgen(gen) ssrdgens_tl(dgens) ] -> [ cons_gen gen dgens ] +END + +(** Equations *) + +(* argument *) + +let pr_eqid = function Some pat -> str " " ++ pr_ipat pat | None -> mt () +let pr_ssreqid _ _ _ = pr_eqid + +(* We must use primitive parsing here to avoid conflicts with the *) +(* basic move, case, and elim tactics. *) +ARGUMENT EXTEND ssreqid TYPED AS ssripatrep option PRINTED BY pr_ssreqid +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let accept_ssreqid strm = + match Util.stream_nth 0 strm with + | Tok.IDENT _ -> accept_before_syms [":"] strm + | Tok.KEYWORD ":" -> () + | Tok.KEYWORD pat when List.mem pat ["_"; "?"; "->"; "<-"] -> + accept_before_syms [":"] strm + | _ -> raise Stream.Failure + +let test_ssreqid = Gram.Entry.of_parser "test_ssreqid" accept_ssreqid + +GEXTEND Gram + GLOBAL: ssreqid; + ssreqpat: [ + [ id = Prim.ident -> IPatId id + | "_" -> IPatAnon Drop + | "?" -> IPatAnon One + | occ = ssrdocc; "->" -> (match occ with + | None, occ -> IPatRewrite (occ, L2R) + | _ -> CErrors.user_err ~loc:!@loc (str"Only occurrences are allowed here")) + | occ = ssrdocc; "<-" -> (match occ with + | None, occ -> IPatRewrite (occ, R2L) + | _ -> CErrors.user_err ~loc:!@loc (str "Only occurrences are allowed here")) + | "->" -> IPatRewrite (allocc, L2R) + | "<-" -> IPatRewrite (allocc, R2L) + ]]; + ssreqid: [ + [ test_ssreqid; pat = ssreqpat -> Some pat + | test_ssreqid -> None + ]]; +END + +(** Bookkeeping (discharge-intro) argument *) + +(* Since all bookkeeping ssr commands have the same discharge-intro *) +(* argument format we use a single grammar entry point to parse them. *) +(* the entry point parses only non-empty arguments to avoid conflicts *) +(* with the basic Coq tactics. *) + +(* type ssrarg = ssrview * (ssreqid * (ssrdgens * ssripats)) *) + +let pr_ssrarg _ _ _ (view, (eqid, (dgens, ipats))) = + let pri = pr_intros (gens_sep dgens) in + pr_view view ++ pr_eqid eqid ++ pr_dgens pr_gen dgens ++ pri ipats + +ARGUMENT EXTEND ssrarg TYPED AS ssrview * (ssreqid * (ssrdgens * ssrintros)) + PRINTED BY pr_ssrarg +| [ ssrview(view) ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ view, (eqid, (dgens, ipats)) ] +| [ ssrview(view) ssrclear(clr) ssrintros(ipats) ] -> + [ view, (None, (([], clr), ipats)) ] +| [ ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ [], (eqid, (dgens, ipats)) ] +| [ ssrclear_ne(clr) ssrintros(ipats) ] -> + [ [], (None, (([], clr), ipats)) ] +| [ ssrintros_ne(ipats) ] -> + [ [], (None, (([], []), ipats)) ] +END + +(** The "clear" tactic *) + +(* We just add a numeric version that clears the n top assumptions. *) + +let poptac ist n = introstac ~ist (List.init n (fun _ -> IPatAnon Drop)) + +TACTIC EXTEND ssrclear + | [ "clear" natural(n) ] -> [ Proofview.V82.tactic (poptac ist n) ] +END + +(** The "move" tactic *) + +(* TODO: review this, in particular the => _ and => [] cases *) +let rec improper_intros = function + | IPatSimpl _ :: ipats -> improper_intros ipats + | (IPatId _ | IPatAnon _ | IPatCase _) :: _ -> false + | _ -> true (* FIXME *) + +let check_movearg = function + | view, (eqid, _) when view <> [] && eqid <> None -> + CErrors.user_err (Pp.str "incompatible view and equation in move tactic") + | view, (_, (([gen :: _], _), _)) when view <> [] && has_occ gen -> + CErrors.user_err (Pp.str "incompatible view and occurrence switch in move tactic") + | _, (_, ((dgens, _), _)) when List.length dgens > 1 -> + CErrors.user_err (Pp.str "dependents switch `/' in move tactic") + | _, (eqid, (_, ipats)) when eqid <> None && improper_intros ipats -> + CErrors.user_err (Pp.str "no proper intro pattern for equation in move tactic") + | arg -> arg + +ARGUMENT EXTEND ssrmovearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_movearg arg ] +END + + + +TACTIC EXTEND ssrmove +| [ "move" ssrmovearg(arg) ssrrpat(pat) ] -> + [ Proofview.V82.tactic (tclTHEN (ssrmovetac ist arg) (introstac ~ist [pat])) ] +| [ "move" ssrmovearg(arg) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrmovetac ist arg) clauses) ] +| [ "move" ssrrpat(pat) ] -> [ Proofview.V82.tactic (introstac ~ist [pat]) ] +| [ "move" ] -> [ Proofview.V82.tactic (movehnftac) ] +END + +let check_casearg = function +| view, (_, (([_; gen :: _], _), _)) when view <> [] && has_occ gen -> + CErrors.user_err (Pp.str "incompatible view and occurrence switch in dependent case tactic") +| arg -> arg + +ARGUMENT EXTEND ssrcasearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_casearg arg ] +END + + +TACTIC EXTEND ssrcase +| [ "case" ssrcasearg(arg) ssrclauses(clauses) ] -> + [ old_tac (tclCLAUSES ist (ssrcasetac ist arg) clauses) ] +| [ "case" ] -> [ old_tac (with_fresh_ctx (with_top (ssrscasetac false))) ] +END + +(** The "elim" tactic *) + +(* Elim views are elimination lemmas, so the eliminated term is not addded *) +(* to the dependent terms as for "case", unless it actually occurs in the *) +(* goal, the "all occurrences" {+} switch is used, or the equation switch *) +(* is used and there are no dependents. *) + +let ssrelimtac ist (view, (eqid, (dgens, ipats))) = + let ndefectelimtac view eqid ipats deps gen ist gl = + let elim = match view with [v] -> Some (snd(force_term ist gl v)) | _ -> None in + ssrelim ~ist deps (`EGen gen) ?elim eqid (elim_intro_tac ipats) gl + in + with_dgens dgens (ndefectelimtac view eqid ipats) ist + +TACTIC EXTEND ssrelim +| [ "elim" ssrarg(arg) ssrclauses(clauses) ] -> + [ old_tac (tclCLAUSES ist (ssrelimtac ist arg) clauses) ] +| [ "elim" ] -> [ old_tac (with_fresh_ctx (with_top elimtac)) ] +END + +(** 6. Backward chaining tactics: apply, exact, congr. *) + +(** The "apply" tactic *) + +let pr_agen (docc, dt) = pr_docc docc ++ pr_term dt +let pr_ssragen _ _ _ = pr_agen +let pr_ssragens _ _ _ = pr_dgens pr_agen + +ARGUMENT EXTEND ssragen TYPED AS ssrdocc * ssrterm PRINTED BY pr_ssragen +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ] -> [ mkclr clr, dt ] +| [ ssrterm(dt) ] -> [ nodocc, dt ] +END + +ARGUMENT EXTEND ssragens TYPED AS ssragen list list * ssrclear +PRINTED BY pr_ssragens +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (mkclr clr, dt) agens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ [[]], clr] +| [ ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (nodocc, dt) agens ] +| [ ] -> [ [[]], [] ] +END + +let mk_applyarg views agens intros = views, (None, (agens, intros)) + +let pr_ssraarg _ _ _ (view, (eqid, (dgens, ipats))) = + let pri = pr_intros (gens_sep dgens) in + pr_view view ++ pr_eqid eqid ++ pr_dgens pr_agen dgens ++ pri ipats + +ARGUMENT EXTEND ssrapplyarg +TYPED AS ssrview * (ssreqid * (ssragens * ssrintros)) +PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg [] (cons_gen gen dgens) intros ] +| [ ssrclear_ne(clr) ssrintros(intros) ] -> + [ mk_applyarg [] ([], clr) intros ] +| [ ssrintros_ne(intros) ] -> + [ mk_applyarg [] ([], []) intros ] +| [ ssrview(view) ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg view (cons_gen gen dgens) intros ] +| [ ssrview(view) ssrclear(clr) ssrintros(intros) ] -> + [ mk_applyarg view ([], clr) intros ] + END + +TACTIC EXTEND ssrapply +| [ "apply" ssrapplyarg(arg) ] -> [ Proofview.V82.tactic (ssrapplytac ist arg) ] +| [ "apply" ] -> [ Proofview.V82.tactic apply_top_tac ] +END + +(** The "exact" tactic *) + +let mk_exactarg views dgens = mk_applyarg views dgens [] + +ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ] -> + [ mk_exactarg [] (cons_gen gen dgens) ] +| [ ssrview(view) ssrclear(clr) ] -> + [ mk_exactarg view ([], clr) ] +| [ ssrclear_ne(clr) ] -> + [ mk_exactarg [] ([], clr) ] +END + +let vmexacttac pf = + Proofview.Goal.nf_enter begin fun gl -> + exact_no_check (EConstr.mkCast (pf, VMcast, Tacmach.New.pf_concl gl)) + end + +TACTIC EXTEND ssrexact +| [ "exact" ssrexactarg(arg) ] -> [ Proofview.V82.tactic (tclBY (ssrapplytac ist arg)) ] +| [ "exact" ] -> [ Proofview.V82.tactic (tclORELSE (donetac ~-1) (tclBY apply_top_tac)) ] +| [ "exact" "<:" lconstr(pf) ] -> [ vmexacttac pf ] +END + +(** The "congr" tactic *) + +(* type ssrcongrarg = open_constr * (int * constr) *) + +let pr_ssrcongrarg _ _ _ ((n, f), dgens) = + (if n <= 0 then mt () else str " " ++ int n) ++ + str " " ++ pr_term f ++ pr_dgens pr_gen dgens + +ARGUMENT EXTEND ssrcongrarg TYPED AS (int * ssrterm) * ssrdgens + PRINTED BY pr_ssrcongrarg +| [ natural(n) constr(c) ssrdgens(dgens) ] -> [ (n, mk_term xNoFlag c), dgens ] +| [ natural(n) constr(c) ] -> [ (n, mk_term xNoFlag c),([[]],[]) ] +| [ constr(c) ssrdgens(dgens) ] -> [ (0, mk_term xNoFlag c), dgens ] +| [ constr(c) ] -> [ (0, mk_term xNoFlag c), ([[]],[]) ] +END + + + +TACTIC EXTEND ssrcongr +| [ "congr" ssrcongrarg(arg) ] -> +[ let arg, dgens = arg in + Proofview.V82.tactic begin + match dgens with + | [gens], clr -> tclTHEN (genstac (gens,clr) ist) (newssrcongrtac arg ist) + | _ -> errorstrm (str"Dependent family abstractions not allowed in congr") + end] +END + +(** 7. Rewriting tactics (rewrite, unlock) *) + +(** Coq rewrite compatibility flag *) + +(** Rewrite clear/occ switches *) + +let pr_rwocc = function + | None, None -> mt () + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear_ne clr + +let pr_ssrrwocc _ _ _ = pr_rwocc + +ARGUMENT EXTEND ssrrwocc TYPED AS ssrdocc PRINTED BY pr_ssrrwocc +| [ "{" ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +| [ ] -> [ noclr ] +END + +(** Rewrite rules *) + +let pr_rwkind = function + | RWred s -> pr_simpl s + | RWdef -> str "/" + | RWeq -> mt () + +let wit_ssrrwkind = add_genarg "ssrrwkind" pr_rwkind + +let pr_rule = function + | RWred s, _ -> pr_simpl s + | RWdef, r-> str "/" ++ pr_term r + | RWeq, r -> pr_term r + +let pr_ssrrule _ _ _ = pr_rule + +let noruleterm loc = mk_term xNoFlag (mkCProp loc) + +ARGUMENT EXTEND ssrrule_ne TYPED AS ssrrwkind * ssrterm PRINTED BY pr_ssrrule + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +GEXTEND Gram + GLOBAL: ssrrule_ne; + ssrrule_ne : [ + [ test_not_ssrslashnum; x = + [ "/"; t = ssrterm -> RWdef, t + | t = ssrterm -> RWeq, t + | s = ssrsimpl_ne -> RWred s, noruleterm (Some !@loc) + ] -> x + | s = ssrsimpl_ne -> RWred s, noruleterm (Some !@loc) + ]]; +END + +ARGUMENT EXTEND ssrrule TYPED AS ssrrule_ne PRINTED BY pr_ssrrule + | [ ssrrule_ne(r) ] -> [ r ] + | [ ] -> [ RWred Nop, noruleterm (Some loc) ] +END + +(** Rewrite arguments *) + +let pr_option f = function None -> mt() | Some x -> f x +let pr_pattern_squarep= pr_option (fun r -> str "[" ++ pr_rpattern r ++ str "]") +let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep +let pr_rwarg ((d, m), ((docc, rx), r)) = + pr_rwdir d ++ pr_mult m ++ pr_rwocc docc ++ pr_pattern_squarep rx ++ pr_rule r + +let pr_ssrrwarg _ _ _ = pr_rwarg + +ARGUMENT EXTEND ssrpattern_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] + | [ ] -> [ None ] +END + +ARGUMENT EXTEND ssrpattern_ne_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] +END + + +ARGUMENT EXTEND ssrrwarg + TYPED AS (ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule) + PRINTED BY pr_ssrrwarg + | [ "-" ssrmult(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (R2L, m) (docc, rx) r ] + | [ "-/" ssrterm(t) ] -> (* just in case '-/' should become a token *) + [ mk_rwarg (R2L, nomult) norwocc (RWdef, t) ] + | [ ssrmult_ne(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (L2R, m) (docc, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkclr clr, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrrule(r) ] -> + [ mk_rwarg norwmult (mkclr clr, None) r ] + | [ "{" ssrocc(occ) "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkocc occ, rx) r ] + | [ "{" "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (nodocc, rx) r ] + | [ ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (noclr, rx) r ] + | [ ssrrule_ne(r) ] -> + [ mk_rwarg norwmult norwocc r ] +END + +TACTIC EXTEND ssrinstofruleL2R +| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> [ Proofview.V82.tactic (ssrinstancesofrule ist L2R arg) ] +END +TACTIC EXTEND ssrinstofruleR2L +| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> [ Proofview.V82.tactic (ssrinstancesofrule ist R2L arg) ] +END + +(** Rewrite argument sequence *) + +(* type ssrrwargs = ssrrwarg list *) + +let pr_ssrrwargs _ _ _ rwargs = pr_list spc pr_rwarg rwargs + +ARGUMENT EXTEND ssrrwargs TYPED AS ssrrwarg list PRINTED BY pr_ssrrwargs + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let ssr_rw_syntax = Summary.ref ~name:"SSR:rewrite" true + +let _ = + Goptions.declare_bool_option + { Goptions.optname = "ssreflect rewrite"; + Goptions.optkey = ["SsrRewrite"]; + Goptions.optread = (fun _ -> !ssr_rw_syntax); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssr_rw_syntax := b) } + +let test_ssr_rw_syntax = + let test strm = + if not !ssr_rw_syntax then raise Stream.Failure else + if is_ssr_loaded () then () else + match Util.stream_nth 0 strm with + | Tok.KEYWORD key when List.mem key.[0] ['{'; '['; '/'] -> () + | _ -> raise Stream.Failure in + Gram.Entry.of_parser "test_ssr_rw_syntax" test + +GEXTEND Gram + GLOBAL: ssrrwargs; + ssrrwargs: [[ test_ssr_rw_syntax; a = LIST1 ssrrwarg -> a ]]; +END + +(** The "rewrite" tactic *) + +TACTIC EXTEND ssrrewrite + | [ "rewrite" ssrrwargs(args) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrrewritetac ist args) clauses) ] +END + +(** The "unlock" tactic *) + +let pr_unlockarg (occ, t) = pr_occ occ ++ pr_term t +let pr_ssrunlockarg _ _ _ = pr_unlockarg + +ARGUMENT EXTEND ssrunlockarg TYPED AS ssrocc * ssrterm + PRINTED BY pr_ssrunlockarg + | [ "{" ssrocc(occ) "}" ssrterm(t) ] -> [ occ, t ] + | [ ssrterm(t) ] -> [ None, t ] +END + +let pr_ssrunlockargs _ _ _ args = pr_list spc pr_unlockarg args + +ARGUMENT EXTEND ssrunlockargs TYPED AS ssrunlockarg list + PRINTED BY pr_ssrunlockargs + | [ ssrunlockarg_list(args) ] -> [ args ] +END + +TACTIC EXTEND ssrunlock + | [ "unlock" ssrunlockargs(args) ssrclauses(clauses) ] -> +[ Proofview.V82.tactic (tclCLAUSES ist (unlocktac ist args) clauses) ] +END + +(** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) + + +TACTIC EXTEND ssrpose +| [ "pose" ssrfixfwd(ffwd) ] -> [ Proofview.V82.tactic (ssrposetac ist ffwd) ] +| [ "pose" ssrcofixfwd(ffwd) ] -> [ Proofview.V82.tactic (ssrposetac ist ffwd) ] +| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> [ Proofview.V82.tactic (ssrposetac ist (id, fwd)) ] +END + +(** The "set" tactic *) + +(* type ssrsetfwd = ssrfwd * ssrdocc *) + +TACTIC EXTEND ssrset +| [ "set" ssrfwdid(id) ssrsetfwd(fwd) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrsettac ist id fwd) clauses) ] +END + +(** The "have" tactic *) + +(* type ssrhavefwd = ssrfwd * ssrhint *) + + +(* Pltac. *) + +(* The standard TACTIC EXTEND does not work for abstract *) +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "3" + [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> + ssrtac_expr ~loc:!@loc "abstract" + [Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] ]]; +END +TACTIC EXTEND ssrabstract +| [ "abstract" ssrdgens(gens) ] -> [ + if List.length (fst gens) <> 1 then + errorstrm (str"dependents switches '/' not allowed here"); + Proofview.V82.tactic (ssrabstract ist gens) ] +END + +TACTIC EXTEND ssrhave +| [ "have" ssrhavefwdwbinders(fwd) ] -> + [ Proofview.V82.tactic (havetac ist fwd false false) ] +END + +TACTIC EXTEND ssrhavesuff +| [ "have" "suff" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true false) ] +END + +TACTIC EXTEND ssrhavesuffices +| [ "have" "suffices" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true false) ] +END + +TACTIC EXTEND ssrsuffhave +| [ "suff" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true true) ] +END + +TACTIC EXTEND ssrsufficeshave +| [ "suffices" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true true) ] +END + +(** The "suffice" tactic *) + +let pr_ssrsufffwdwbinders _ _ prt (hpats, (fwd, hint)) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrsufffwd + TYPED AS ssrhpats * (ssrfwd * ssrhint) PRINTED BY pr_ssrsufffwdwbinders +| [ ssrhpats(pats) ssrbinder_list(bs) ":" lconstr(t) ssrhint(hint) ] -> + [ let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let fwd = mkFwdHint ":" t in + (((clr, pats), allbinders), simpl), (bind_fwd allbs fwd, hint) ] +END + + +TACTIC EXTEND ssrsuff +| [ "suff" ssrsufffwd(fwd) ] -> [ Proofview.V82.tactic (sufftac ist fwd) ] +END + +TACTIC EXTEND ssrsuffices +| [ "suffices" ssrsufffwd(fwd) ] -> [ Proofview.V82.tactic (sufftac ist fwd) ] +END + +(** The "wlog" (Without Loss Of Generality) tactic *) + +(* type ssrwlogfwd = ssrwgen list * ssrfwd *) + +let pr_ssrwlogfwd _ _ _ (gens, t) = + str ":" ++ pr_list mt pr_wgen gens ++ spc() ++ pr_fwd t + +ARGUMENT EXTEND ssrwlogfwd TYPED AS ssrwgen list * ssrfwd + PRINTED BY pr_ssrwlogfwd +| [ ":" ssrwgen_list(gens) "/" lconstr(t) ] -> [ gens, mkFwdHint "/" t] +END + + +TACTIC EXTEND ssrwlog +| [ "wlog" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] +END + +TACTIC EXTEND ssrwlogs +| [ "wlog" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwlogss +| [ "wlog" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwithoutloss +| [ "without" "loss" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] +END + +TACTIC EXTEND ssrwithoutlosss +| [ "without" "loss" "suff" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwithoutlossss +| [ "without" "loss" "suffices" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +(* Generally have *) +let pr_idcomma _ _ _ = function + | None -> mt() + | Some None -> str"_, " + | Some (Some id) -> pr_id id ++ str", " + +ARGUMENT EXTEND ssr_idcomma TYPED AS ident option option PRINTED BY pr_idcomma + | [ ] -> [ None ] +END + +let accept_idcomma strm = + match stream_nth 0 strm with + | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm + | _ -> raise Stream.Failure + +let test_idcomma = Gram.Entry.of_parser "test_idcomma" accept_idcomma + +GEXTEND Gram + GLOBAL: ssr_idcomma; + ssr_idcomma: [ [ test_idcomma; + ip = [ id = IDENT -> Some (id_of_string id) | "_" -> None ]; "," -> + Some ip + ] ]; +END + +let augment_preclr clr1 (((clr0, x),y),z) = (((clr1 @ clr0, x),y),z) + +TACTIC EXTEND ssrgenhave +| [ "gen" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + Proofview.V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] +END + +TACTIC EXTEND ssrgenhave2 +| [ "generally" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + Proofview.V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] +END + +(* We wipe out all the keywords generated by the grammar rules we defined. *) +(* The user is supposed to Require Import ssreflect or Require ssreflect *) +(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) +(* consequence the extended ssreflect grammar. *) +let () = CLexer.set_keyword_state frozen_lexer ;; + + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli new file mode 100644 index 000000000..bf6f44f11 --- /dev/null +++ b/plugins/ssr/ssrparser.mli @@ -0,0 +1,20 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry +val wit_ssrtacarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type +val pr_ssrtacarg : 'a -> 'b -> (int * Ppextend.parenRelation -> 'c) -> 'c + +val ssrtclarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry +val wit_ssrtclarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type +val pr_ssrtclarg : 'a -> 'b -> (int * Ppextend.parenRelation -> 'c -> 'd) -> 'c -> 'd + +val add_genarg : string -> ('a -> Pp.std_ppcmds) -> 'a Genarg.uniform_genarg_type + diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml new file mode 100644 index 000000000..e865ef706 --- /dev/null +++ b/plugins/ssr/ssrprinters.ml @@ -0,0 +1,85 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Pp +open Names +open Printer +open Tacmach + +open Ssrmatching_plugin +open Ssrast + +let pr_spc () = str " " +let pr_bar () = Pp.cut() ++ str "|" +let pr_list = prlist_with_sep + +let pp_concat hd ?(sep=str", ") = function [] -> hd | x :: xs -> + hd ++ List.fold_left (fun acc x -> acc ++ sep ++ x) x xs + +let pp_term gl t = + let t = Reductionops.nf_evar (project gl) t in pr_econstr t + +(* FIXME *) +(* terms are pre constr, the kind is parsing/printing flag to distinguish + * between x, @x and (x). It affects automatic clear and let-in preservation. + * Cpattern is a temporary flag that becomes InParens ASAP. *) +(* type ssrtermkind = InParens | WithAt | NoFlag | Cpattern *) +let xInParens = '(' +let xWithAt = '@' +let xNoFlag = ' ' +let xCpattern = 'x' + +(* Term printing utilities functions for deciding bracketing. *) +let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") +(* String lexing utilities *) +let skip_wschars s = + let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop +(* We also guard characters that might interfere with the ssreflect *) +(* tactic syntax. *) +let guard_term ch1 s i = match s.[i] with + | '(' -> false + | '{' | '/' | '=' -> true + | _ -> ch1 = xInParens + +(* We also guard characters that might interfere with the ssreflect *) +(* tactic syntax. *) +let pr_guarded guard prc c = + pp_with Format.str_formatter (prc c); + let s = Format.flush_str_formatter () ^ "$" in + if guard s (skip_wschars s 0) then pr_paren prc c else prc c + +let prl_constr_expr = Ppconstr.pr_lconstr_expr +let pr_glob_constr c = Printer.pr_glob_constr_env (Global.env ()) c +let prl_glob_constr c = Printer.pr_lglob_constr_env (Global.env ()) c +let pr_glob_constr_and_expr = function + | _, Some c -> Ppconstr.pr_constr_expr c + | c, None -> pr_glob_constr c +let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c + +let pr_hyp (SsrHyp (_, id)) = Id.print id + +let pr_occ = function + | Some (true, occ) -> str "{-" ++ pr_list pr_spc int occ ++ str "}" + | Some (false, occ) -> str "{+" ++ pr_list pr_spc int occ ++ str "}" + | None -> str "{}" + +(* 0 cost pp function. Active only if Debug Ssreflect is Set *) +let ppdebug_ref = ref (fun _ -> ()) +let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) +let _ = + Goptions.declare_bool_option + { Goptions.optname = "ssreflect debugging"; + Goptions.optkey = ["Debug";"Ssreflect"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !ppdebug_ref == ssr_pp); + Goptions.optwrite = (fun b -> + Ssrmatching.debug b; + if b then ppdebug_ref := ssr_pp else ppdebug_ref := fun _ -> ()) } +let ppdebug s = !ppdebug_ref s diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli new file mode 100644 index 000000000..56ec145ad --- /dev/null +++ b/plugins/ssr/ssrprinters.mli @@ -0,0 +1,45 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ssrast + +val pp_term : + Proof_type.goal Evd.sigma -> EConstr.constr -> Pp.std_ppcmds + +val pr_spc : unit -> Pp.std_ppcmds +val pr_bar : unit -> Pp.std_ppcmds +val pr_list : + (unit -> Pp.std_ppcmds) -> ('a -> Pp.std_ppcmds) -> 'a list -> Pp.std_ppcmds + +val pp_concat : + Pp.std_ppcmds -> + ?sep:Pp.std_ppcmds -> Pp.std_ppcmds list -> Pp.std_ppcmds + +val xInParens : ssrtermkind +val xWithAt : ssrtermkind +val xNoFlag : ssrtermkind +val xCpattern : ssrtermkind + +val pr_term : + ssrtermkind * (Glob_term.glob_constr * Constrexpr.constr_expr option) -> + Pp.std_ppcmds + +val pr_hyp : ssrhyp -> Pp.std_ppcmds + +val prl_constr_expr : Constrexpr.constr_expr -> Pp.std_ppcmds +val prl_glob_constr : Glob_term.glob_constr -> Pp.std_ppcmds + +val pr_guarded : + (string -> int -> bool) -> ('a -> Pp.std_ppcmds) -> 'a -> Pp.std_ppcmds + +val pr_occ : ssrocc -> Pp.std_ppcmds + +val ppdebug : Pp.std_ppcmds Lazy.t -> unit + diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml new file mode 100644 index 000000000..0fe8fdc26 --- /dev/null +++ b/plugins/ssr/ssrtacticals.ml @@ -0,0 +1,160 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names +open Constr +open Termops +open Tacmach +open Misctypes +open Locusops + +open Ssrast +open Ssrcommon + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +(** Tacticals (+, -, *, done, by, do, =>, first, and last). *) + +let get_index = function ArgArg i -> i | _ -> + anomaly "Uninterpreted index" +(* Toplevel constr must be globalized twice ! *) + +(** The "first" and "last" tacticals. *) + +let tclPERM perm tac gls = + let subgls = tac gls in + let sigma, subgll = Refiner.unpackage subgls in + let subgll' = perm subgll in + Refiner.repackage sigma subgll' + +let rot_hyps dir i hyps = + let n = List.length hyps in + if i = 0 then List.rev hyps else + if i > n then CErrors.user_err (Pp.str "Not enough subgoals") else + let rec rot i l_hyps = function + | hyp :: hyps' when i > 0 -> rot (i - 1) (hyp :: l_hyps) hyps' + | hyps' -> hyps' @ (List.rev l_hyps) in + rot (match dir with L2R -> i | R2L -> n - i) [] hyps + +let tclSEQAT ist atac1 dir (ivar, ((_, atacs2), atac3)) = + let i = get_index ivar in + let evtac = ssrevaltac ist in + let tac1 = evtac atac1 in + if atacs2 = [] && atac3 <> None then tclPERM (rot_hyps dir i) tac1 else + let evotac = function Some atac -> evtac atac | _ -> Tacticals.tclIDTAC in + let tac3 = evotac atac3 in + let rec mk_pad n = if n > 0 then tac3 :: mk_pad (n - 1) else [] in + match dir, mk_pad (i - 1), List.map evotac atacs2 with + | L2R, [], [tac2] when atac3 = None -> Tacticals.tclTHENFIRST tac1 tac2 + | L2R, [], [tac2] when atac3 = None -> Tacticals.tclTHENLAST tac1 tac2 + | L2R, pad, tacs2 -> Tacticals.tclTHENSFIRSTn tac1 (Array.of_list (pad @ tacs2)) tac3 + | R2L, pad, tacs2 -> Tacticals.tclTHENSLASTn tac1 tac3 (Array.of_list (tacs2 @ pad)) + +(** The "in" pseudo-tactical {{{ **********************************************) + +let hidden_goal_tag = "the_hidden_goal" + +let check_wgen_uniq gens = + let clears = List.flatten (List.map fst gens) in + check_hyps_uniq [] clears; + let ids = CList.map_filter + (function (_,Some ((id,_),_)) -> Some (hoi_id id) | _ -> None) gens in + let rec check ids = function + | id :: _ when List.mem id ids -> + errorstrm Pp.(str"Duplicate generalization " ++ Id.print id) + | id :: hyps -> check (id :: ids) hyps + | [] -> () in + check [] ids + +let pf_clauseids gl gens clseq = + let keep_clears = List.map (fun (x, _) -> x, None) in + if gens <> [] then (check_wgen_uniq gens; gens) else + if clseq <> InAll && clseq <> InAllHyps then keep_clears gens else + CErrors.user_err (Pp.str "assumptions should be named explicitly") + +let hidden_clseq = function InHyps | InHypsSeq | InAllHyps -> true | _ -> false + +let settac id c = Tactics.letin_tac None (Name id) c None +let posetac id cl = Proofview.V82.of_tactic (settac id cl nowhere) + +let hidetacs clseq idhide cl0 = + if not (hidden_clseq clseq) then [] else + [posetac idhide cl0; + Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkVar idhide))] + +let endclausestac id_map clseq gl_id cl0 gl = + let not_hyp' id = not (List.mem_assoc id id_map) in + let orig_id id = try List.assoc id id_map with _ -> id in + let dc, c = EConstr.decompose_prod_assum (project gl) (pf_concl gl) in + let hide_goal = hidden_clseq clseq in + let c_hidden = hide_goal && EConstr.eq_constr (project gl) c (EConstr.mkVar gl_id) in + let rec fits forced = function + | (id, _) :: ids, decl :: dc' when RelDecl.get_name decl = Name id -> + fits true (ids, dc') + | ids, dc' -> + forced && ids = [] && (not hide_goal || dc' = [] && c_hidden) in + let rec unmark c = match EConstr.kind (project gl) c with + | Var id when hidden_clseq clseq && id = gl_id -> cl0 + | Prod (Name id, t, c') when List.mem_assoc id id_map -> + EConstr.mkProd (Name (orig_id id), unmark t, unmark c') + | LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> + EConstr.mkLetIn (Name (orig_id id), unmark v, unmark t, unmark c') + | _ -> EConstr.map (project gl) unmark c in + let utac hyp = + Proofview.V82.of_tactic + (Tactics.convert_hyp_no_check (NamedDecl.map_constr unmark hyp)) in + let utacs = List.map utac (pf_hyps gl) in + let ugtac gl' = + Proofview.V82.of_tactic + (convert_concl_no_check (unmark (pf_concl gl'))) gl' in + let ctacs = if hide_goal then [Proofview.V82.of_tactic (Tactics.clear [gl_id])] else [] in + let mktac itacs = Tacticals.tclTHENLIST (itacs @ utacs @ ugtac :: ctacs) in + let itac (_, id) = Proofview.V82.of_tactic (Tactics.introduction id) in + if fits false (id_map, List.rev dc) then mktac (List.map itac id_map) gl else + let all_ids = ids_of_rel_context dc @ pf_ids_of_hyps gl in + if List.for_all not_hyp' all_ids && not c_hidden then mktac [] gl else + CErrors.user_err (Pp.str "tampering with discharged assumptions of \"in\" tactical") + +let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type x xs) + +let tclCLAUSES ist tac (gens, clseq) gl = + if clseq = InGoal || clseq = InSeqGoal then tac gl else + let clr_gens = pf_clauseids gl gens clseq in + let clear = Tacticals.tclTHENLIST (List.rev(List.fold_right clr_of_wgen clr_gens [])) in + let gl_id = mk_anon_id hidden_goal_tag gl in + let cl0 = pf_concl gl in + let dtac gl = + let c = pf_concl gl in + let gl, args, c = + List.fold_right (abs_wgen true ist mk_discharged_id) gens (gl,[], c) in + apply_type c args gl in + let endtac = + let id_map = CList.map_filter (function + | _, Some ((x,_),_) -> let id = hoi_id x in Some (mk_discharged_id id, id) + | _, None -> None) gens in + endclausestac id_map clseq gl_id cl0 in + Tacticals.tclTHENLIST (hidetacs clseq gl_id cl0 @ [dtac; clear; tac; endtac]) gl + +(** The "do" tactical. ********************************************************) + +let hinttac ist is_by (is_or, atacs) = + let dtac = if is_by then donetac ~-1 else Tacticals.tclIDTAC in + let mktac = function + | Some atac -> Tacticals.tclTHEN (ssrevaltac ist atac) dtac + | _ -> dtac in + match List.map mktac atacs with + | [] -> if is_or then dtac else Tacticals.tclIDTAC + | [tac] -> tac + | tacs -> Tacticals.tclFIRST tacs + +let ssrdotac ist (((n, m), tac), clauses) = + let mul = get_index n, m in + tclCLAUSES ist (tclMULT mul (hinttac ist false tac)) clauses diff --git a/plugins/ssr/ssrtacticals.mli b/plugins/ssr/ssrtacticals.mli new file mode 100644 index 000000000..b8e95b2b1 --- /dev/null +++ b/plugins/ssr/ssrtacticals.mli @@ -0,0 +1,44 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +val tclSEQAT : + Ltac_plugin.Tacinterp.interp_sign -> + Ltac_plugin.Tacinterp.Value.t -> + Ssrast.ssrdir -> + int Misctypes.or_var * + (('a * Ltac_plugin.Tacinterp.Value.t option list) * + Ltac_plugin.Tacinterp.Value.t option) -> + Proof_type.tactic + +val tclCLAUSES : + Ltac_plugin.Tacinterp.interp_sign -> + Proofview.V82.tac -> + (Ssrast.ssrhyps * + ((Ssrast.ssrhyp_or_id * string) * + Ssrmatching_plugin.Ssrmatching.cpattern option) + option) + list * Ssrast.ssrclseq -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + +val hinttac : + Tacinterp.interp_sign -> + bool -> bool * Tacinterp.Value.t option list -> Ssrast.v82tac + +val ssrdotac : + Ltac_plugin.Tacinterp.interp_sign -> + ((int Misctypes.or_var * Ssrast.ssrmmod) * + (bool * Ltac_plugin.Tacinterp.Value.t option list)) * + ((Ssrast.ssrhyps * + ((Ssrast.ssrhyp_or_id * string) * + Ssrmatching_plugin.Ssrmatching.cpattern option) + option) + list * Ssrast.ssrclseq) -> + Proof_type.goal Evd.sigma -> Proof_type.goal list Evd.sigma + diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 new file mode 100644 index 000000000..b154cf217 --- /dev/null +++ b/plugins/ssr/ssrvernac.ml4 @@ -0,0 +1,600 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names +open Term +open Termops +open Constrexpr +open Constrexpr_ops +open Pcoq +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Vernac_ +open Ltac_plugin +open Notation_ops +open Notation_term +open Glob_term +open Globnames +open Stdarg +open Genarg +open Misctypes +open Decl_kinds +open Libnames +open Pp +open Ppconstr +open Printer +open Util +open Extraargs +open Evar_kinds +open Ssrprinters +open Ssrcommon +open Ssrparser +DECLARE PLUGIN "ssreflect_plugin" + +let (!@) = Pcoq.to_coqloc + +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = CLexer.get_keyword_state () ;; + +(* global syntactic changes and vernacular commands *) + +(** Alternative notations for "match" and anonymous arguments. {{{ ************) + +(* Syntax: *) +(* if <term> is <pattern> then ... else ... *) +(* if <term> is <pattern> [in ..] return ... then ... else ... *) +(* let: <pattern> := <term> in ... *) +(* let: <pattern> [in ...] := <term> return ... in ... *) +(* The scope of a top-level 'as' in the pattern extends over the *) +(* 'return' type (dependent if/let). *) +(* Note that the optional "in ..." appears next to the <pattern> *) +(* rather than the <term> in then "let:" syntax. The alternative *) +(* would lead to ambiguities in, e.g., *) +(* let: p1 := (*v---INNER LET:---v *) *) +(* let: p2 := let: p3 := e3 in k return t in k2 in k1 return t' *) +(* in b (*^--ALTERNATIVE INNER LET--------^ *) *) + +(* Caveat : There is no pretty-printing support, since this would *) +(* require a modification to the Coq kernel (adding a new match *) +(* display style -- why aren't these strings?); also, the v8.1 *) +(* pretty-printer only allows extension hooks for printing *) +(* integer or string literals. *) +(* Also note that in the v8 grammar "is" needs to be a keyword; *) +(* as this can't be done from an ML extension file, the new *) +(* syntax will only work when ssreflect.v is imported. *) + +let no_ct = None, None and no_rt = None in +let aliasvar = function + | [_, [{ CAst.v = CPatAlias (_, id); loc }]] -> Some (loc,Name id) + | _ -> None in +let mk_cnotype mp = aliasvar mp, None in +let mk_ctype mp t = aliasvar mp, Some t in +let mk_rtype t = Some t in +let mk_dthen ?loc (mp, ct, rt) c = (Loc.tag ?loc (mp, c)), ct, rt in +let mk_let ?loc rt ct mp c1 = + CAst.make ?loc @@ CCases (LetPatternStyle, rt, ct, [Loc.tag ?loc (mp, c1)]) in +let mk_pat c (na, t) = (c, na, t) in +GEXTEND Gram + GLOBAL: binder_constr; + ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> mk_rtype t ]]; + ssr_mpat: [[ p = pattern -> [Loc.tag ~loc:!@loc [p]] ]]; + ssr_dpat: [ + [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> mp, mk_ctype mp t, rt + | mp = ssr_mpat; rt = ssr_rtype -> mp, mk_cnotype mp, rt + | mp = ssr_mpat -> mp, no_ct, no_rt + ] ]; + ssr_dthen: [[ dp = ssr_dpat; "then"; c = lconstr -> mk_dthen ~loc:!@loc dp c ]]; + ssr_elsepat: [[ "else" -> [Loc.tag ~loc:!@loc [CAst.make ~loc:!@loc @@ CPatAtom None]] ]]; + ssr_else: [[ mp = ssr_elsepat; c = lconstr -> Loc.tag ~loc:!@loc (mp, c) ]]; + binder_constr: [ + [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in CAst.make ~loc:!@loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) + | "if"; c = operconstr LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in + let b1, b2 = + let (l1, (p1, r1)), (l2, (p2, r2)) = b1, b2 in (l1, (p1, r2)), (l2, (p2, r1)) in + CAst.make ~loc:!@loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; "in"; c1 = lconstr -> + mk_let ~loc:!@loc no_rt [mk_pat c no_ct] mp c1 + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let ~loc:!@loc rt [mk_pat c (mk_cnotype mp)] mp c1 + | "let"; ":"; mp = ssr_mpat; "in"; t = pattern; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let ~loc:!@loc rt [mk_pat c (mk_ctype mp t)] mp c1 + ] ]; +END + +GEXTEND Gram + GLOBAL: closed_binder; + closed_binder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + [CLocalAssum ([Loc.tag ~loc:!@loc Anonymous], Default Explicit, c)] + ] ]; +END +(* }}} *) + +(** Vernacular commands: Prenex Implicits and Search {{{ **********************) + +(* This should really be implemented as an extension to the implicit *) +(* arguments feature, but unfortuately that API is sealed. The current *) +(* workaround uses a combination of notations that works reasonably, *) +(* with the following caveats: *) +(* - The pretty-printing always elides prenex implicits, even when *) +(* they are obviously needed. *) +(* - Prenex Implicits are NEVER exported from a module, because this *) +(* would lead to faulty pretty-printing and scoping errors. *) +(* - The command "Import Prenex Implicits" can be used to reassert *) +(* Prenex Implicits for all the visible constants that had been *) +(* declared as Prenex Implicits. *) + +let declare_one_prenex_implicit locality f = + let fref = + try Smartlocate.global_with_alias f + with _ -> errorstrm (pr_reference f ++ str " is not declared") in + let rec loop = function + | a :: args' when Impargs.is_status_implicit a -> + (ExplByName (Impargs.name_of_implicit a), (true, true, true)) :: loop args' + | args' when List.exists Impargs.is_status_implicit args' -> + errorstrm (str "Expected prenex implicits for " ++ pr_reference f) + | _ -> [] in + let impls = + match Impargs.implicits_of_global fref with + | [cond,impls] -> impls + | [] -> errorstrm (str "Expected some implicits for " ++ pr_reference f) + | _ -> errorstrm (str "Multiple implicits not supported") in + match loop impls with + | [] -> + errorstrm (str "Expected some implicits for " ++ pr_reference f) + | impls -> + Impargs.declare_manual_implicits locality fref ~enriching:false [impls] + +VERNAC COMMAND EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF + | [ "Prenex" "Implicits" ne_global_list(fl) ] + -> [ let locality = + Locality.make_section_locality (Locality.LocalityFixme.consume ()) in + List.iter (declare_one_prenex_implicit locality) fl ] +END + +(* Vernac grammar visibility patch *) + +GEXTEND Gram + GLOBAL: gallina_ext; + gallina_ext: + [ [ IDENT "Import"; IDENT "Prenex"; IDENT "Implicits" -> + Vernacexpr.VernacUnsetOption (["Printing"; "Implicit"; "Defensive"]) + ] ] + ; +END + +(** Extend Search to subsume SearchAbout, also adding hidden Type coercions. *) + +(* Main prefilter *) + +type raw_glob_search_about_item = + | RGlobSearchSubPattern of constr_expr + | RGlobSearchString of Loc.t * string * string option + +let pr_search_item = function + | RGlobSearchString (_,s,_) -> str s + | RGlobSearchSubPattern p -> pr_constr_expr p + +let wit_ssr_searchitem = add_genarg "ssr_searchitem" pr_search_item + +let pr_ssr_search_item _ _ _ = pr_search_item + +(* Workaround the notation API that can only print notations *) + +let is_ident s = try CLexer.check_ident s; true with _ -> false + +let is_ident_part s = is_ident ("H" ^ s) + +let interp_search_notation ?loc tag okey = + let err msg = CErrors.user_err ?loc ~hdr:"interp_search_notation" msg in + let mk_pntn s for_key = + let n = String.length s in + let s' = Bytes.make (n + 2) ' ' in + let rec loop i i' = + if i >= n then s', i' - 2 else if s.[i] = ' ' then loop (i + 1) i' else + let j = try String.index_from s (i + 1) ' ' with _ -> n in + let m = j - i in + if s.[i] = '\'' && i < j - 2 && s.[j - 1] = '\'' then + (String.blit s (i + 1) s' i' (m - 2); loop (j + 1) (i' + m - 1)) + else if for_key && is_ident (String.sub s i m) then + (Bytes.set s' i' '_'; loop (j + 1) (i' + 2)) + else (String.blit s i s' i' m; loop (j + 1) (i' + m + 1)) in + loop 0 1 in + let trim_ntn (pntn, m) = Bytes.sub_string pntn 1 (max 0 m) in + let pr_ntn ntn = str "(" ++ str ntn ++ str ")" in + let pr_and_list pr = function + | [x] -> pr x + | x :: lx -> pr_list pr_comma pr lx ++ pr_comma () ++ str "and " ++ pr x + | [] -> mt () in + let pr_sc sc = str (if sc = "" then "independently" else sc) in + let pr_scs = function + | [""] -> pr_sc "" + | scs -> str "in " ++ pr_and_list pr_sc scs in + let generator, pr_tag_sc = + let ign _ = mt () in match okey with + | Some key -> + let sc = Notation.find_delimiters_scope ?loc key in + let pr_sc s_in = str s_in ++ spc() ++ str sc ++ pr_comma() in + Notation.pr_scope ign sc, pr_sc + | None -> Notation.pr_scopes ign, ign in + let qtag s_in = pr_tag_sc s_in ++ qstring tag ++ spc()in + let ptag, ttag = + let ptag, m = mk_pntn tag false in + if m <= 0 then err (str "empty notation fragment"); + ptag, trim_ntn (ptag, m) in + let last = ref "" and last_sc = ref "" in + let scs = ref [] and ntns = ref [] in + let push_sc sc = match !scs with + | "" :: scs' -> scs := "" :: sc :: scs' + | scs' -> scs := sc :: scs' in + let get s _ _ = match !last with + | "Scope " -> last_sc := s; last := "" + | "Lonely notation" -> last_sc := ""; last := "" + | "\"" -> + let pntn, m = mk_pntn s true in + if String.string_contains ~where:(Bytes.to_string pntn) ~what:(Bytes.to_string ptag) then begin + let ntn = trim_ntn (pntn, m) in + match !ntns with + | [] -> ntns := [ntn]; scs := [!last_sc] + | ntn' :: _ when ntn' = ntn -> push_sc !last_sc + | _ when ntn = ttag -> ntns := ntn :: !ntns; scs := [!last_sc] + | _ :: ntns' when List.mem ntn ntns' -> () + | ntn' :: ntns' -> ntns := ntn' :: ntn :: ntns' + end; + last := "" + | _ -> last := s in + pp_with (Format.make_formatter get (fun _ -> ())) generator; + let ntn = match !ntns with + | [] -> + err (hov 0 (qtag "in" ++ str "does not occur in any notation")) + | ntn :: ntns' when ntn = ttag -> + if ntns' <> [] then begin + let pr_ntns' = pr_and_list pr_ntn ntns' in + Feedback.msg_warning (hov 4 (qtag "In" ++ str "also occurs in " ++ pr_ntns')) + end; ntn + | [ntn] -> + Feedback.msg_info (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn + | ntns' -> + let e = str "occurs in" ++ spc() ++ pr_and_list pr_ntn ntns' in + err (hov 4 (str "ambiguous: " ++ qtag "in" ++ e)) in + let (nvars, body), ((_, pat), osc) = match !scs with + | [sc] -> Notation.interp_notation ?loc ntn (None, [sc]) + | scs' -> + try Notation.interp_notation ?loc ntn (None, []) with _ -> + let e = pr_ntn ntn ++ spc() ++ str "is defined " ++ pr_scs scs' in + err (hov 4 (str "ambiguous: " ++ pr_tag_sc "in" ++ e)) in + let sc = Option.default "" osc in + let _ = + let m_sc = + if osc <> None then str "In " ++ str sc ++ pr_comma() else mt() in + let ntn_pat = trim_ntn (mk_pntn pat false) in + let rbody = glob_constr_of_notation_constr ?loc body in + let m_body = hov 0 (Constrextern.without_symbols prl_glob_constr rbody) in + let m = m_sc ++ pr_ntn ntn_pat ++ spc () ++ str "denotes " ++ m_body in + Feedback.msg_info (hov 0 m) in + if List.length !scs > 1 then + let scs' = List.remove (=) sc !scs in + let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in + Feedback.msg_warning (hov 4 w) + else if String.string_contains ~where:ntn ~what:" .. " then + err (pr_ntn ntn ++ str " is an n-ary notation"); + let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in + let rec sub () = function + | NVar x when List.mem_assoc x nvars -> CAst.make ?loc @@ GPatVar (FirstOrderPatVar x) + | c -> + glob_constr_of_notation_constr_with_binders ?loc (fun _ x -> (), x) sub () c in + let _, npat = Patternops.pattern_of_glob_constr (sub () body) in + Search.GlobSearchSubPattern npat + +ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem + PRINTED BY pr_ssr_search_item + | [ string(s) ] -> [ RGlobSearchString (loc,s,None) ] + | [ string(s) "%" preident(key) ] -> [ RGlobSearchString (loc,s,Some key) ] + | [ constr_pattern(p) ] -> [ RGlobSearchSubPattern p ] +END + +let pr_ssr_search_arg _ _ _ = + let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item p in + pr_list spc pr_item + +ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list + PRINTED BY pr_ssr_search_arg + | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> [ (false, p) :: a ] + | [ ssr_search_item(p) ssr_search_arg(a) ] -> [ (true, p) :: a ] + | [ ] -> [ [] ] +END + +(* Main type conclusion pattern filter *) + +let rec splay_search_pattern na = function + | Pattern.PApp (fp, args) -> splay_search_pattern (na + Array.length args) fp + | Pattern.PLetIn (_, _, _, bp) -> splay_search_pattern na bp + | Pattern.PRef hr -> hr, na + | _ -> CErrors.user_err (Pp.str "no head constant in head search pattern") + +let push_rels_assum l e = + let l = List.map (fun (n,t) -> n, EConstr.Unsafe.to_constr t) l in + push_rels_assum l e + +let coerce_search_pattern_to_sort hpat = + let env = Global.env () and sigma = Evd.empty in + let mkPApp fp n_imps args = + let args' = Array.append (Array.make n_imps (Pattern.PMeta None)) args in + Pattern.PApp (fp, args') in + let hr, na = splay_search_pattern 0 hpat in + let dc, ht = + Reductionops.splay_prod env sigma (EConstr.of_constr (Universes.unsafe_type_of_global hr)) in + let np = List.length dc in + if np < na then CErrors.user_err (Pp.str "too many arguments in head search pattern") else + let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in + let warn () = + Feedback.msg_warning (str "Listing only lemmas with conclusion matching " ++ + pr_constr_pattern hpat') in + if EConstr.isSort sigma ht then begin warn (); true, hpat' end else + let filter_head, coe_path = + try + let _, cp = + Classops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in + warn (); + true, cp + with _ -> false, [] in + let coerce hp coe_index = + let coe = Classops.get_coercion_value coe_index in + try + let coe_ref = reference_of_constr coe in + let n_imps = Option.get (Classops.hide_coercion coe_ref) in + mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] + with _ -> + errorstrm (str "need explicit coercion " ++ pr_constr coe ++ spc () + ++ str "to interpret head search pattern as type") in + filter_head, List.fold_left coerce hpat' coe_path + +let interp_head_pat hpat = + let filter_head, p = coerce_search_pattern_to_sort hpat in + let rec loop c = match kind_of_term c with + | Cast (c', _, _) -> loop c' + | Prod (_, _, c') -> loop c' + | LetIn (_, _, _, c') -> loop c' + | _ -> Constr_matching.is_matching (Global.env()) Evd.empty p (EConstr.of_constr c) in + filter_head, loop + +let all_true _ = true + +let rec interp_search_about args accu = match args with +| [] -> accu +| (flag, arg) :: rem -> + fun gr env typ -> + let ans = Search.search_about_filter arg gr env typ in + (if flag then ans else not ans) && interp_search_about rem accu gr env typ + +let interp_search_arg arg = + let arg = List.map (fun (x,arg) -> x, match arg with + | RGlobSearchString (loc,s,key) -> + if is_ident_part s then Search.GlobSearchString s else + interp_search_notation ~loc s key + | RGlobSearchSubPattern p -> + try + let intern = Constrintern.intern_constr_pattern in + Search.GlobSearchSubPattern (snd (intern (Global.env()) p)) + with e -> let e = CErrors.push e in iraise (ExplainErr.process_vernac_interp_error e)) arg in + let hpat, a1 = match arg with + | (_, Search.GlobSearchSubPattern (Pattern.PMeta _)) :: a' -> all_true, a' + | (true, Search.GlobSearchSubPattern p) :: a' -> + let filter_head, p = interp_head_pat p in + if filter_head then p, a' else all_true, arg + | _ -> all_true, arg in + let is_string = + function (_, Search.GlobSearchString _) -> true | _ -> false in + let a2, a3 = List.partition is_string a1 in + interp_search_about (a2 @ a3) (fun gr env typ -> hpat typ) + +(* Module path postfilter *) + +let pr_modloc (b, m) = if b then str "-" ++ pr_reference m else pr_reference m + +let wit_ssrmodloc = add_genarg "ssrmodloc" pr_modloc + +let pr_ssr_modlocs _ _ _ ml = + if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml + +ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY pr_ssr_modlocs + | [ ] -> [ [] ] +END + +GEXTEND Gram + GLOBAL: ssr_modlocs; + modloc: [[ "-"; m = global -> true, m | m = global -> false, m]]; + ssr_modlocs: [[ "in"; ml = LIST1 modloc -> ml ]]; +END + +let interp_modloc mr = + let interp_mod (_, mr) = + let (loc, qid) = qualid_of_reference mr in + try Nametab.full_name_module qid with Not_found -> + CErrors.user_err ?loc (str "No Module " ++ pr_qualid qid) in + let mr_out, mr_in = List.partition fst mr in + let interp_bmod b = function + | [] -> fun _ _ _ -> true + | rmods -> Search.module_filter (List.map interp_mod rmods, b) in + let is_in = interp_bmod false mr_in and is_out = interp_bmod true mr_out in + fun gr env typ -> is_in gr env typ && is_out gr env typ + +(* The unified, extended vernacular "Search" command *) + +let ssrdisplaysearch gr env t = + let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in + Feedback.msg_info (hov 2 pr_res ++ fnl ()) + +VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY +| [ "Search" ssr_search_arg(a) ssr_modlocs(mr) ] -> + [ let hpat = interp_search_arg a in + let in_mod = interp_modloc mr in + let post_filter gr env typ = in_mod gr env typ && hpat gr env typ in + let display gr env typ = + if post_filter gr env typ then ssrdisplaysearch gr env typ + in + Search.generic_search None display ] +END + +(* }}} *) + +(** View hint database and View application. {{{ ******************************) + +(* There are three databases of lemmas used to mediate the application *) +(* of reflection lemmas: one for forward chaining, one for backward *) +(* chaining, and one for secondary backward chaining. *) + +(* View hints *) + +let pr_raw_ssrhintref prc _ _ = let open CAst in function + | { v = CAppExpl ((None, r,x), args) } when isCHoles args -> + prc (CAst.make @@ CRef (r,x)) ++ str "|" ++ int (List.length args) + | { v = CApp ((_, { v = CRef _ }), _) } as c -> prc c + | { v = CApp ((_, c), args) } when isCxHoles args -> + prc c ++ str "|" ++ int (List.length args) + | c -> prc c + +let pr_rawhintref = let open CAst in function + | { v = GApp (f, args) } when isRHoles args -> + pr_glob_constr f ++ str "|" ++ int (List.length args) + | c -> pr_glob_constr c + +let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c + +let pr_ssrhintref prc _ _ = prc + +let mkhintref ?loc c n = match c.CAst.v with + | CRef (r,x) -> CAst.make ?loc @@ CAppExpl ((None, r, x), mkCHoles ?loc n) + | _ -> mkAppC (c, mkCHoles ?loc n) + +ARGUMENT EXTEND ssrhintref + PRINTED BY pr_ssrhintref + RAW_TYPED AS constr RAW_PRINTED BY pr_raw_ssrhintref + GLOB_TYPED AS constr GLOB_PRINTED BY pr_glob_ssrhintref + | [ constr(c) ] -> [ c ] + | [ constr(c) "|" natural(n) ] -> [ mkhintref ~loc c n ] +END + +(* View purpose *) + +let pr_viewpos = function + | 0 -> str " for move/" + | 1 -> str " for apply/" + | 2 -> str " for apply//" + | _ -> mt () + +let pr_ssrviewpos _ _ _ = pr_viewpos + +let mapviewpos f n k = if n < 3 then f n else for i = 0 to k - 1 do f i done + +ARGUMENT EXTEND ssrviewpos TYPED AS int PRINTED BY pr_ssrviewpos + | [ "for" "move" "/" ] -> [ 0 ] + | [ "for" "apply" "/" ] -> [ 1 ] + | [ "for" "apply" "/" "/" ] -> [ 2 ] + | [ "for" "apply" "//" ] -> [ 2 ] + | [ ] -> [ 3 ] +END + +let pr_ssrviewposspc _ _ _ i = pr_viewpos i ++ spc () + +ARGUMENT EXTEND ssrviewposspc TYPED AS ssrviewpos PRINTED BY pr_ssrviewposspc + | [ ssrviewpos(i) ] -> [ i ] +END + +let print_view_hints i = + let pp_viewname = str "Hint View" ++ pr_viewpos i ++ str " " in + let pp_hints = pr_list spc pr_rawhintref Ssrview.viewtab.(i) in + Feedback.msg_info (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) + +VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY +| [ "Print" "Hint" "View" ssrviewpos(i) ] -> [ mapviewpos print_view_hints i 3 ] +END + + +VERNAC COMMAND EXTEND HintView CLASSIFIED AS SIDEFF + | [ "Hint" "View" ssrviewposspc(n) ne_ssrhintref_list(lvh) ] -> + [ mapviewpos (Ssrview.add_view_hints (Ssrview.glob_view_hints lvh)) n 2 ] +END + +(* }}} *) + +(** Canonical Structure alias *) + +GEXTEND Gram + GLOBAL: gallina_ext; + + gallina_ext: + (* Canonical structure *) + [[ IDENT "Canonical"; qid = Constr.global -> + Vernacexpr.VernacCanonical (AN qid) + | IDENT "Canonical"; ntn = Prim.by_notation -> + Vernacexpr.VernacCanonical (ByNotation ntn) + | IDENT "Canonical"; qid = Constr.global; + d = G_vernac.def_body -> + let s = coerce_reference_to_id qid in + Vernacexpr.VernacDefinition + ((Some Decl_kinds.Global,Decl_kinds.CanonicalStructure), + ((Loc.tag s),None),(d )) + ]]; +END + +(** Keyword compatibility fixes. *) + +(* Coq v8.1 notation uses "by" and "of" quasi-keywords, i.e., reserved *) +(* identifiers used as keywords. This is incompatible with ssreflect.v *) +(* which makes "by" and "of" true keywords, because of technicalities *) +(* in the internal lexer-parser API of Coq. We patch this here by *) +(* adding new parsing rules that recognize the new keywords. *) +(* To make matters worse, the Coq grammar for tactics fails to *) +(* export the non-terminals we need to patch. Fortunately, the CamlP5 *) +(* API provides a backdoor access (with loads of Obj.magic trickery). *) + +(* Coq v8.3 defines "by" as a keyword, some hacks are not needed any *) +(* longer and thus comment out. Such comments are marked with v8.3 *) + +open Pltac + +GEXTEND Gram + GLOBAL: hypident; + hypident: [ + [ "("; IDENT "type"; "of"; id = Prim.identref; ")" -> id, Locus.InHypTypeOnly + | "("; IDENT "value"; "of"; id = Prim.identref; ")" -> id, Locus.InHypValueOnly + ] ]; +END + +GEXTEND Gram + GLOBAL: hloc; +hloc: [ + [ "in"; "("; "Type"; "of"; id = ident; ")" -> + Tacexpr.HypLocation ((Loc.tag id), Locus.InHypTypeOnly) + | "in"; "("; IDENT "Value"; "of"; id = ident; ")" -> + Tacexpr.HypLocation ((Loc.tag id), Locus.InHypValueOnly) + ] ]; +END + +GEXTEND Gram + GLOBAL: constr_eval; + constr_eval: [ + [ IDENT "type"; "of"; c = Constr.constr -> Genredexpr.ConstrTypeOf c ] + ]; +END + +(* We wipe out all the keywords generated by the grammar rules we defined. *) +(* The user is supposed to Require Import ssreflect or Require ssreflect *) +(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) +(* consequence the extended ssreflect grammar. *) +let () = CLexer.set_keyword_state frozen_lexer ;; + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/ide/texmacspp.mli b/plugins/ssr/ssrvernac.mli index c1086a633..58e81130c 100644 --- a/ide/texmacspp.mli +++ b/plugins/ssr/ssrvernac.mli @@ -1,12 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Xml_datatype -open Vernacexpr - -val tmpp : ?loc:Loc.t -> vernac_expr -> xml +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml new file mode 100644 index 000000000..3c995b1bb --- /dev/null +++ b/plugins/ssr/ssrview.ml @@ -0,0 +1,125 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Util +open Names +open Term +open Ltac_plugin +open Tacinterp +open Glob_term +open Tacmach +open Tacticals + +open Ssrcommon + +(* The table and its display command *) + +(* FIXME this looks hackish *) + +let viewtab : glob_constr list array = Array.make 3 [] + +let _ = + let init () = Array.fill viewtab 0 3 [] in + let freeze _ = Array.copy viewtab in + let unfreeze vt = Array.blit vt 0 viewtab 0 3 in + Summary.declare_summary "ssrview" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init } + +(* Populating the table *) + +let cache_viewhint (_, (i, lvh)) = + let mem_raw h = List.exists (Glob_ops.glob_constr_eq h) in + let add_hint h hdb = if mem_raw h hdb then hdb else h :: hdb in + viewtab.(i) <- List.fold_right add_hint lvh viewtab.(i) + +let subst_viewhint ( subst, (i, lvh as ilvh)) = + let lvh' = List.smartmap (Detyping.subst_glob_constr subst) lvh in + if lvh' == lvh then ilvh else i, lvh' + +let classify_viewhint x = Libobject.Substitute x + +let in_viewhint = + Libobject.declare_object {(Libobject.default_object "VIEW_HINTS") with + Libobject.open_function = (fun i o -> if i = 1 then cache_viewhint o); + Libobject.cache_function = cache_viewhint; + Libobject.subst_function = subst_viewhint; + Libobject.classify_function = classify_viewhint } + +let glob_view_hints lvh = + List.map (Constrintern.intern_constr (Global.env ())) lvh + +let add_view_hints lvh i = Lib.add_anonymous_leaf (in_viewhint (i, lvh)) + +let interp_view ist si env sigma gv v rid = + let open CAst in + match v with + | { v = GApp ( { v = GHole _ } , rargs); loc } -> + let rv = make ?loc @@ GApp (rid, rargs) in + snd (interp_open_constr ist (re_sig si sigma) (rv, None)) + | rv -> + let interp rc rargs = + interp_open_constr ist (re_sig si sigma) (mkRApp rc rargs, None) in + let rec simple_view rargs n = + if n < 0 then view_error "use" gv else + try interp rv rargs with _ -> simple_view (mkRHole :: rargs) (n - 1) in + let view_nbimps = interp_view_nbimps ist (re_sig si sigma) rv in + let view_args = [mkRApp rv (mkRHoles view_nbimps); rid] in + let rec view_with = function + | [] -> simple_view [rid] (interp_nbargs ist (re_sig si sigma) rv) + | hint :: hints -> try interp hint view_args with _ -> view_with hints in + snd (view_with (if view_nbimps < 0 then [] else viewtab.(0))) + + +let with_view ist ~next si env (gl0 : (Proof_type.goal * tac_ctx) Evd.sigma) c name cl prune (conclude : EConstr.t -> EConstr.t -> tac_ctx tac_a) clr = + let c2r ist x = { ist with lfun = + Id.Map.add top_id (Value.of_constr x) ist.lfun } in + let terminate (sigma, c') = + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + let c' = Reductionops.nf_evar sigma c' in + let n, c', _, ucst = without_ctx pf_abs_evars gl0 (sigma, c') in + let c' = if not prune then c' else without_ctx pf_abs_cterm gl0 n c' in + let gl0 = pf_merge_uc ucst gl0 in + let gl0, ap = + let gl0, ctx = pull_ctx gl0 in + let gl0, ap = pf_abs_prod name gl0 c' (Termops.prod_applist sigma cl [c]) in + push_ctx ctx gl0, ap in + let gl0 = pf_merge_uc_of sigma gl0 in + ap, c', gl0 in + let rec loop (sigma, c') = function + | [] -> + let ap, c', gl = terminate (sigma, c') in + ap, c', conclude ap c' gl + | f :: view -> + let ist, rid = + match EConstr.kind sigma c' with + | Var id -> ist,mkRVar id + | _ -> c2r ist c',mkRltacVar top_id in + let v = intern_term ist env f in + loop (interp_view ist si env sigma f v rid) view + in loop + +let pfa_with_view ist ?(next=ref []) (prune, view) cl c conclude clr gl = + let env, sigma, si = + without_ctx pf_env gl, Refiner.project gl, without_ctx sig_it gl in + with_view + ist ~next si env gl c (constr_name sigma c) cl prune conclude clr (sigma, c) view + +let pf_with_view_linear ist gl v cl c = + let x,y,gl = + pfa_with_view ist v cl c (fun _ _ -> tac_ctx tclIDTAC) [] + (push_ctx (new_ctx ()) gl) in + let gl, _ = pull_ctxs gl in + assert(List.length (sig_it gl) = 1); + x,y,re_sig (List.hd (sig_it gl)) (Refiner.project gl) + + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrview.mli b/plugins/ssr/ssrview.mli new file mode 100644 index 000000000..6fd906ff4 --- /dev/null +++ b/plugins/ssr/ssrview.mli @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ssrast +open Ssrcommon + +val viewtab : Glob_term.glob_constr list array +val add_view_hints : Glob_term.glob_constr list -> int -> unit +val glob_view_hints : Constrexpr.constr_expr list -> Glob_term.glob_constr list + +val pfa_with_view : + ist -> + ?next:ssripats ref -> + bool * ssrterm list -> + EConstr.t -> + EConstr.t -> + (EConstr.t -> EConstr.t -> tac_ctx tac_a) -> + ssrhyps -> + (goal * tac_ctx) sigma -> EConstr.types * EConstr.t * (goal * tac_ctx) list sigma + +val pf_with_view_linear : + ist -> + goal sigma -> + bool * ssrterm list -> + EConstr.t -> + EConstr.t -> + EConstr.types * EConstr.t * goal sigma + + diff --git a/plugins/ssr/vo.itarget b/plugins/ssr/vo.itarget new file mode 100644 index 000000000..99f9f160b --- /dev/null +++ b/plugins/ssr/vo.itarget @@ -0,0 +1,3 @@ +ssreflect.vo +ssrfun.vo +ssrbool.vo diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 6b752fb4b..67e6c7e93 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -133,7 +133,7 @@ let dC t = CastConv t (** Constructors for constr_expr *) let isCVar = function { CAst.v = CRef (Ident _, _) } -> true | _ -> false let destCVar = function { CAst.v = CRef (Ident (_, id), _) } -> id | _ -> - CErrors.anomaly (str"not a CRef") + CErrors.anomaly (str"not a CRef.") let mkCHole ~loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) let mkCLambda ?loc name ty t = CAst.make ?loc @@ CLambdaN ([[Loc.tag ?loc name], Default Explicit, ty], t) @@ -150,8 +150,8 @@ let mkRLambda n s t = CAst.make @@ GLambda (n, Explicit, s, t) let combineCG t1 t2 f g = match t1, t2 with | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) - | _, (_, (_, None)) -> CErrors.anomaly (str"have: mixed C-G constr") - | _ -> CErrors.anomaly (str"have: mixed G-C constr") + | _, (_, (_, None)) -> CErrors.anomaly (str"have: mixed C-G constr.") + | _ -> CErrors.anomaly (str"have: mixed G-C constr.") let loc_ofCG = function | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s @@ -620,12 +620,12 @@ let match_upats_FO upats env sigma0 ise orig_c = let pt' = pi1 pt', pi2 pt', EConstr.Unsafe.to_constr (pi3 pt') in raise (FoundUnif (ungen_upat lhs pt' u)) with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u - | Not_found -> CErrors.anomaly (str"incomplete ise in match_upats_FO") + | Not_found -> CErrors.anomaly (str"incomplete ise in match_upats_FO.") | e when CErrors.noncritical e -> () in List.iter one_match fpats done; iter_constr_LR loop f; Array.iter loop a in - try loop orig_c with Invalid_argument _ -> CErrors.anomaly (str"IN FO") + try loop orig_c with Invalid_argument _ -> CErrors.anomaly (str"IN FO.") let prof_FO = mk_profiler "match_upats_FO";; let match_upats_FO upats env sigma0 ise c = @@ -696,11 +696,11 @@ let fixed_upat = function let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) let assert_done r = - match !r with Some x -> x | None -> CErrors.anomaly (str"do_once never called") + match !r with Some x -> x | None -> CErrors.anomaly (str"do_once never called.") let assert_done_multires r = match !r with - | None -> CErrors.anomaly (str"do_once never called") + | None -> CErrors.anomaly (str"do_once never called.") | Some (n, xs) -> r := Some (n+1,xs); try List.nth xs n with Failure _ -> raise NoMatch @@ -757,7 +757,7 @@ let source () = match upats_origin, upats with | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ pr_constr_pat rule ++ spc() | _, [] | None, _::_::_ -> - CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in + CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in let on_instance, instances = let instances = ref [] in (fun x -> @@ -795,7 +795,7 @@ let rec uniquize = function errorstrm (source () ++ str "does not match any subterm of the goal") | NoProgress when (not raise_NoMatch) -> let dir = match upats_origin with Some (d,_) -> d | _ -> - CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in + CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in errorstrm (str"all matches of "++source()++ str"are equal to the " ++ pr_dir_side (inv_dir dir)) | NoProgress -> raise NoMatch); @@ -833,7 +833,7 @@ let rec uniquize = function let sigma, uc, ({up_f = pf; up_a = pa} as u) = match !upat_that_matched with | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch - | None -> CErrors.anomaly (str"companion function never called") in + | None -> CErrors.anomaly (str"companion function never called.") in let p' = mkApp (pf, pa) in if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t) else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ @@ -920,7 +920,7 @@ let glob_cpattern gs p = | (r1, Some _), (r2, Some _) when isCVar t1 -> encode k "In" [r1; r2; bind_in t1 t2] | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] - | _ -> CErrors.anomaly (str"where are we?") + | _ -> CErrors.anomaly (str"where are we?.") with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) | CNotation("( _ in _ in _ )", ([t1; t2; t3], [], [])) -> check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] @@ -1094,7 +1094,7 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = (Value.cast (topwit (Option.get wit_ssrpatternarg)) v) | it -> g t with e when CErrors.noncritical e -> g t in let decodeG t f g = decode ist (mkG t) f g in - let bad_enc id _ = CErrors.anomaly (str"bad encoding for pattern "++str id) in + let bad_enc id _ = CErrors.anomaly (str"bad encoding for pattern "++str id++str".") in let cleanup_XinE h x rp sigma = let h_k = match kind_of_term h with Evar (k,_) -> k | _ -> assert false in let to_clean, update = (* handle rename if x is already used *) @@ -1280,7 +1280,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = let e = match p with - | In_T _ | In_X_In_T _ -> CErrors.anomaly (str"pattern without redex") + | In_T _ | In_X_In_T _ -> CErrors.anomaly (str"pattern without redex.") | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in let sigma = if not resolve_typeclasses then sigma diff --git a/pretyping/cases.ml b/pretyping/cases.ml index c2c8065a9..c3f392980 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -32,7 +32,6 @@ open Evardefine open Evarsolve open Evarconv open Evd -open Sigma.Notations open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration @@ -70,7 +69,7 @@ let error_wrong_numarg_inductive ?loc env c n = let list_try_compile f l = let rec aux errors = function - | [] -> if errors = [] then anomaly (str "try_find_f") else iraise (List.last errors) + | [] -> if errors = [] then anomaly (str "try_find_f.") else iraise (List.last errors) | h::t -> try f h with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ as e -> @@ -162,9 +161,9 @@ let feed_history arg = function | Continuation (n, l, h) when n>=1 -> Continuation (n-1, arg :: l, h) | Continuation (n, _, _) -> - anomaly (str "Bad number of expected remaining patterns: " ++ int n) + anomaly (str "Bad number of expected remaining patterns: " ++ int n ++ str ".") | Result _ -> - anomaly (Pp.str "Exhausted pattern history") + anomaly (Pp.str "Exhausted pattern history.") (* This is for non exhaustive error message *) @@ -190,7 +189,7 @@ let pop_history_pattern = function | Continuation (0, l, MakeConstructor (pci, rh)) -> feed_history (CAst.make @@ PatCstr (pci,List.rev l,Anonymous)) rh | _ -> - anomaly (Pp.str "Constructor not yet filled with its arguments") + anomaly (Pp.str "Constructor not yet filled with its arguments.") let pop_history h = feed_history (CAst.make @@ PatVar Anonymous) h @@ -425,7 +424,7 @@ let lift_tomatch_type n = liftn_tomatch_type n 1 let current_pattern eqn = match eqn.patterns with | pat::_ -> pat - | [] -> anomaly (Pp.str "Empty list of patterns") + | [] -> anomaly (Pp.str "Empty list of patterns.") let alias_of_pat = CAst.with_val (function | PatVar name -> name @@ -438,7 +437,7 @@ let remove_current_pattern eqn = { eqn with patterns = pats; alias_stack = alias_of_pat pat :: eqn.alias_stack } - | [] -> anomaly (Pp.str "Empty list of patterns") + | [] -> anomaly (Pp.str "Empty list of patterns.") let push_current_pattern (cur,ty) eqn = match eqn.patterns with @@ -447,7 +446,7 @@ let push_current_pattern (cur,ty) eqn = { eqn with rhs = { eqn.rhs with rhs_env = rhs_env }; patterns = pats } - | [] -> anomaly (Pp.str "Empty list of patterns") + | [] -> anomaly (Pp.str "Empty list of patterns.") (* spiwack: like [push_current_pattern] but does not introduce an alias in rhs_env. Aliasing binders are only useful for variables at @@ -457,7 +456,7 @@ let push_noalias_current_pattern eqn = match eqn.patterns with | _::pats -> { eqn with patterns = pats } - | [] -> anomaly (Pp.str "push_noalias_current_pattern: Empty list of patterns") + | [] -> anomaly (Pp.str "push_noalias_current_pattern: Empty list of patterns.") @@ -641,7 +640,7 @@ let replace_tomatch sigma n c = | Pushed (initial,((b,tm),l,na)) :: rest -> let b = replace_term sigma n c depth b in let tm = map_tomatch_type (replace_term sigma n c depth) tm in - List.iter (fun i -> if Int.equal i (n + depth) then anomaly (Pp.str "replace_tomatch")) l; + List.iter (fun i -> if Int.equal i (n + depth) then anomaly (Pp.str "replace_tomatch.")) l; Pushed (initial,((b,tm),l,na)) :: replrec depth rest | Alias (initial,(na,b,d)) :: rest -> (* [b] is out of replacement scope *) @@ -731,7 +730,7 @@ let get_names env sigma sign eqns = (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env sigma t na) avoid)) d na in - (na::l,(out_name na)::avoid)) + (na::l,(Name.get_id na)::avoid)) ([],allvars) (List.rev sign) names2 in names3,aliasname @@ -882,7 +881,7 @@ let specialize_predicate_var (cur,typ,dep) env tms ccl = (*****************************************************************************) let generalize_predicate sigma (names,na) ny d tms ccl = let () = match na with - | Anonymous -> anomaly (Pp.str "Undetected dependency") + | Anonymous -> anomaly (Pp.str "Undetected dependency.") | _ -> () in let p = List.length names + 1 in let ccl = lift_predicate 1 ccl tms in @@ -1708,7 +1707,7 @@ let build_tycon ?loc env tycon_env s subst tycon extenv evdref t = evdref := evd; (t,tt) in let b = e_cumul env evdref tt (mkSort s) (* side effect *) in - if not b then anomaly (Pp.str "Build_tycon: should be a type"); + if not b then anomaly (Pp.str "Build_tycon: should be a type."); { uj_val = t; uj_type = tt } (* For a multiple pattern-matching problem Xi on t1..tn with return @@ -1872,7 +1871,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = if not (eq_ind ind ind') then 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"); + anomaly (Pp.str "Ill-formed 'in' clause in cases."); List.rev realnal | None -> List.make nrealargs_ctxt Anonymous in LocalAssum (na, EConstr.of_constr (build_dependent_inductive env0 indf')) @@ -2000,10 +1999,8 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = let sigma,t = match tycon with | Some t -> refresh_tycon sigma t | None -> - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma ((t, _), sigma, _) = + let (sigma, (t, _)) = new_type_evar env sigma univ_flexible_alg ~src:(Loc.tag ?loc @@ Evar_kinds.CasesType false) in - let sigma = Sigma.to_evar_map sigma in sigma, t in (* First strategy: we build an "inversion" predicate *) @@ -2064,8 +2061,8 @@ let mk_JMeq evdref typ x typ' y = let mk_JMeq_refl evdref typ x = papp evdref coq_JMeq_refl [| typ; x |] -let hole = CAst.make @@ - GHole (Evar_kinds.QuestionMark (Evar_kinds.Define false), +let hole na = CAst.make @@ + GHole (Evar_kinds.QuestionMark (Evar_kinds.Define false,na), Misctypes.IntroAnonymous, None) let constr_of_pat env evdref arsign pat avoid = @@ -2168,7 +2165,7 @@ let vars_of_ctx sigma ctx = prev, (CAst.make @@ GApp ( (CAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)), - [hole; CAst.make @@ GVar prev])) :: vars + [hole na; CAst.make @@ GVar prev])) :: vars | _ -> match RelDecl.get_name decl with Anonymous -> invalid_arg "vars_of_ctx" @@ -2223,14 +2220,14 @@ let build_ineqs evdref prevpatterns pats liftsign = (Some ([], 0, 0, [])) eqnpats pats in match acc with None -> c - | Some (sign, len, _, c') -> - let conj = it_mkProd_or_LetIn (mk_coq_not (mk_coq_and c')) - (lift_rel_context liftsign sign) - in - conj :: c) + | Some (sign, len, _, c') -> + let sigma, conj = mk_coq_and !evdref c' in + let sigma, neg = mk_coq_not sigma conj in + let conj = it_mkProd_or_LetIn neg (lift_rel_context liftsign sign) in + evdref := sigma; conj :: c) [] prevpatterns in match diffs with [] -> None - | _ -> Some (mk_coq_and diffs) + | _ -> Some (let sigma, conj = mk_coq_and !evdref diffs in evdref := sigma; conj) let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = let i = ref 0 in @@ -2301,7 +2298,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = | l -> CAst.make @@ GApp (bref, l) in let branch = match ineqs with - Some _ -> CAst.make @@ GApp (branch, [ hole ]) + Some _ -> CAst.make @@ GApp (branch, [ hole Anonymous ]) | None -> branch in incr i; diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 3ef17912f..1282e3cb8 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -67,7 +67,7 @@ let apply_coercion_args env evd check isproj argl funj = if check && not (e_cumul env evdref (Retyping.get_type_of env !evdref h) c1) then raise NoCoercion; apply_rec (h::acc) (subst1 h c2) restl - | _ -> anomaly (Pp.str "apply_coercion_args") + | _ -> anomaly (Pp.str "apply_coercion_args.") in let res = apply_rec [] funj.uj_type argl in !evdref, res @@ -90,8 +90,8 @@ let inh_pattern_coerce_to ?loc env pat ind1 ind2 = open Program -let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) env evdref c = - let src = Loc.tag ?loc (Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in +let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) na env evdref c = + let src = Loc.tag ?loc (Evar_kinds.QuestionMark (Evar_kinds.Define opaque,na)) in Evarutil.e_new_evar env evdref ~src c let app_opt env evdref f t = @@ -181,7 +181,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in - let evar = make_existential ?loc env evdref eq in + let evar = make_existential ?loc n env evdref eq in let eq_app x = papp evdref coq_eq_rect [| eqT; hdx; pred; x; hdy; evar|] in @@ -324,7 +324,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) Some (fun x -> let cx = app_opt env evdref c x in - let evar = make_existential ?loc env evdref (mkApp (p, [| cx |])) + let evar = make_existential ?loc Anonymous env evdref (mkApp (p, [| cx |])) in (papp evdref sig_intro [| u; p; cx; evar |])) | None -> @@ -368,7 +368,7 @@ let apply_coercion env sigma p hj typ_cl = (hj,typ_cl,sigma) p in evd, j with NoCoercion as e -> raise e - | e when CErrors.noncritical e -> anomaly (Pp.str "apply_coercion") + | e when CErrors.noncritical e -> anomaly (Pp.str "apply_coercion.") (* Try to coerce to a funclass; raise NoCoercion if not possible *) let inh_app_fun_core env evd j = diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 752819aa3..c93b1e568 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -425,7 +425,7 @@ type binder_kind = BProd | BLambda | BLetIn (**********************************************************************) (* Main detyping function *) -let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable")) +let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable.")) let set_detype_anonymous f = detype_anonymous := f let detype_level sigma l = @@ -907,8 +907,7 @@ let simple_cases_matrix_of_branches ind brs = let nal,c = it_destRLambda_or_LetIn_names n b in let mkPatVar na = CAst.make @@ PatVar na in let p = CAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in - let map name = try Some (Nameops.out_name name) with Failure _ -> None in - let ids = List.map_filter map nal in + let ids = List.map_filter Nameops.Name.to_option nal in Loc.tag @@ (ids,[p],c)) brs diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index bf62cea6b..3757ba7e6 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -23,7 +23,6 @@ open Evardefine open Evarsolve open Evd open Pretype_errors -open Sigma.Notations open Context.Named.Declaration module RelDecl = Context.Rel.Declaration @@ -638,7 +637,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> let b = nf_evar i b1 in let t = nf_evar i t1 in - let na = Nameops.name_max na1 na2 in + let na = Nameops.Name.pick na1 na2 in 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 = @@ -755,7 +754,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in - let na = Nameops.name_max na1 na2 in + let na = Nameops.Name.pick na1 na2 in 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 @@ -816,7 +815,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in - let na = Nameops.name_max n1 n2 in + let na = Nameops.Name.pick n1 n2 in evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> @@ -913,9 +912,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) (i,t2::ks, m-1, test) else let dloc = Loc.tag Evar_kinds.InternalHole in - let i = Sigma.Unsafe.of_evar_map i in - let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in - let i' = Sigma.to_evar_map i' in + let (i', ev) = Evarutil.new_evar env i ~src:dloc (substl ks b) in (i', ev :: ks, m - 1,test)) (evd,[],List.length bs,fun i -> Success i) bs in @@ -1088,7 +1085,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let filter' = filter_possible_projections evd c ty ctxt args in (id,t,c,ty,evs,Filter.make filter',occs) :: make_subst (ctxt',l,occsl) | _, _, [] -> [] - | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list") in + | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list.") in let rec set_holes evdref rhs = function | (id,_,c,cty,evsref,filter,occs)::subst -> @@ -1099,9 +1096,8 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = | None -> let evty = set_holes evdref cty subst in let instance = Filter.filter_list filter instance in - let evd = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in - let evd = Sigma.to_evar_map evd in + let evd = !evdref in + let (evd, ev) = new_evar_instance sign evd evty ~filter instance in evdref := evd; evsref := (fst (destEvar !evdref ev),evty)::!evsref; ev in diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index a11619846..2d86daadb 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -17,15 +17,9 @@ open Namegen open Evd 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 nf_evar c = nf_evar sigma c in process_rel_context @@ -82,9 +76,7 @@ let define_pure_evar_as_product evd evk = let concl = Reductionops.whd_all evenv evd (EConstr.of_constr evi.evar_concl) in let s = destSort evd concl in let evd1,(dom,u1) = - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in - (Sigma.to_evar_map evd1, e) + new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in let evd2,rng = let newenv = push_named (LocalAssum (id, dom)) evenv in @@ -92,13 +84,11 @@ let define_pure_evar_as_product evd evk = let filter = Filter.extend 1 (evar_filter evi) in if is_prop_sort (ESorts.kind evd1 s) then (* Impredicative product, conclusion must fall in [Prop]. *) - new_evar_unsafe newenv evd1 concl ~src ~filter + new_evar newenv evd1 concl ~src ~filter else let status = univ_flexible_alg in let evd3, (rng, srng) = - let evd1 = Sigma.Unsafe.of_evar_map evd1 in - let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in - (Sigma.to_evar_map evd3, e) + new_type_evar newenv evd1 status ~src ~filter in let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) (ESorts.kind evd1 s) in @@ -143,7 +133,7 @@ let define_pure_evar_as_lambda env evd evk = let newenv = push_named (LocalAssum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in - let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in + let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in let lam = mkLambda (Name id, dom, subst_var id body) in Evd.define evk (EConstr.Unsafe.to_constr lam) evd2, lam diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 98e71c7fd..ff0aeff75 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -20,7 +20,6 @@ open Retyping open Reductionops open Evarutil open Pretype_errors -open Sigma.Notations let normalize_evar evd ev = match EConstr.kind evd (mkEvar ev) with @@ -203,9 +202,7 @@ let restrict_evar_key evd evk filter candidates = let candidates = match candidates with | NoUpdate -> Option.map (fun l -> List.map EConstr.of_constr l) evi.evar_candidates | UpdateWith c -> Some c in - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (evk, sigma, _) = restrict_evar sigma evk filter candidates in - (Sigma.to_evar_map sigma, evk) + restrict_evar evd evk filter candidates end (* Restrict an applied evar and returns its restriction in the same context *) @@ -634,7 +631,7 @@ let make_projectable_subst aliases sigma evi args = cstrs) | _ -> (rest,Id.Map.add id [a,normalize_alias_opt sigma aliases a,id] all,cstrs)) - | _ -> anomaly (Pp.str "Instance does not match its signature")) + | _ -> anomaly (Pp.str "Instance does not match its signature.")) sign (Array.rev_to_list args,Id.Map.empty,Constrmap.empty) in (full_subst,cstr_subst) @@ -649,9 +646,7 @@ let make_projectable_subst aliases sigma evi args = *) let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in - let evd = Sigma.to_evar_map evd in + let (evd, evar_in_env) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in let t_in_env = whd_evar evd t_in_env in let (evk, _) = destEvar evd evar_in_env in let evd = define_fun env evd None (destEvar evd evar_in_env) t_in_env in @@ -721,10 +716,8 @@ 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 ty_in_env ty_t_in_sign sign2 filter2 inst2_in_env in - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (ev2_in_sign, evd, _) = + let (evd, ev2_in_sign) = new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in - let evd = Sigma.to_evar_map evd in let ev2_in_env = (fst (destEvar evd ev2_in_sign), Array.of_list inst2_in_env) in (evd, ev2_in_sign, ev2_in_env) @@ -828,7 +821,7 @@ let rec find_projectable_vars with_evars aliases sigma y subst = | _ -> subst' end | [] -> subst' - | _ -> anomaly (Pp.str "More than one non var in aliases class of evar instance") + | _ -> anomaly (Pp.str "More than one non var in aliases class of evar instance.") else subst' in Id.Map.fold is_projectable subst [] diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 923d7d938..e53d19b59 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -12,6 +12,7 @@ open Nameops open Globnames open Misctypes open Glob_term +open Evar_kinds (* Untyped intermediate terms, after ASTs and before constr. *) @@ -33,109 +34,108 @@ let map_glob_decl_left_to_right f (na,k,obd,ty) = (na,k,comp1,comp2) let binding_kind_eq bk1 bk2 = match bk1, bk2 with -| Decl_kinds.Explicit, Decl_kinds.Explicit -> true -| Decl_kinds.Implicit, Decl_kinds.Implicit -> true -| _ -> false + | Decl_kinds.Explicit, Decl_kinds.Explicit -> true + | Decl_kinds.Implicit, Decl_kinds.Implicit -> true + | (Decl_kinds.Explicit | Decl_kinds.Implicit), _ -> false let case_style_eq s1 s2 = match s1, s2 with -| LetStyle, LetStyle -> true -| IfStyle, IfStyle -> true -| LetPatternStyle, LetPatternStyle -> true -| MatchStyle, MatchStyle -> true -| RegularStyle, RegularStyle -> true -| _ -> false + | LetStyle, LetStyle -> true + | IfStyle, IfStyle -> true + | LetPatternStyle, LetPatternStyle -> true + | MatchStyle, MatchStyle -> true + | RegularStyle, RegularStyle -> true + | (LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle), _ -> false let rec cases_pattern_eq { CAst.v = p1} { CAst.v = p2 } = match p1, p2 with -| PatVar na1, PatVar na2 -> Name.equal na1 na2 -| PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> - eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && - Name.equal na1 na2 -| _ -> false + | PatVar na1, PatVar na2 -> Name.equal na1 na2 + | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> + eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && + Name.equal na1 na2 + | (PatVar _ | PatCstr _), _ -> false let cast_type_eq eq t1 t2 = match t1, t2 with -| CastConv t1, CastConv t2 -> eq t1 t2 -| CastVM t1, CastVM t2 -> eq t1 t2 -| CastCoerce, CastCoerce -> true -| CastNative t1, CastNative t2 -> eq t1 t2 -| _ -> false - -let rec glob_constr_eq { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with -| GRef (gr1, _), GRef (gr2, _) -> eq_gr gr1 gr2 -| GVar id1, GVar id2 -> Id.equal id1 id2 -| GEvar (id1, arg1), GEvar (id2, arg2) -> - Id.equal id1 id2 && - List.equal instance_eq arg1 arg2 -| GPatVar (b1, pat1), GPatVar (b2, pat2) -> - (b1 : bool) == b2 && Id.equal pat1 pat2 -| GApp (f1, arg1), GApp (f2, arg2) -> - glob_constr_eq f1 f2 && List.equal glob_constr_eq arg1 arg2 -| GLambda (na1, bk1, t1, c1), GLambda (na2, bk2, t2, c2) -> - Name.equal na1 na2 && binding_kind_eq bk1 bk2 && - glob_constr_eq t1 t2 && glob_constr_eq c1 c2 -| GProd (na1, bk1, t1, c1), GProd (na2, bk2, t2, c2) -> - Name.equal na1 na2 && binding_kind_eq bk1 bk2 && - glob_constr_eq t1 t2 && glob_constr_eq c1 c2 -| GLetIn (na1, b1, t1, c1), GLetIn (na2, b2, t2, c2) -> - Name.equal na1 na2 && glob_constr_eq b1 b2 && Option.equal glob_constr_eq t1 t2 && glob_constr_eq c1 c2 -| GCases (st1, c1, tp1, cl1), GCases (st2, c2, tp2, cl2) -> - case_style_eq st1 st2 && Option.equal glob_constr_eq c1 c2 && - List.equal tomatch_tuple_eq tp1 tp2 && - List.equal cases_clause_eq cl1 cl2 -| GLetTuple (na1, (n1, p1), c1, t1), GLetTuple (na2, (n2, p2), c2, t2) -> - List.equal Name.equal na1 na2 && Name.equal n1 n2 && - Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 && - glob_constr_eq t1 t2 -| GIf (m1, (pat1, p1), c1, t1), GIf (m2, (pat2, p2), c2, t2) -> - glob_constr_eq m1 m2 && Name.equal pat1 pat2 && - Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 && - glob_constr_eq t1 t2 -| GRec (kn1, id1, decl1, c1, t1), GRec (kn2, id2, decl2, c2, t2) -> - fix_kind_eq kn1 kn2 && Array.equal Id.equal id1 id2 && - Array.equal (fun l1 l2 -> List.equal glob_decl_eq l1 l2) decl1 decl2 && - Array.equal glob_constr_eq c1 c2 && - Array.equal glob_constr_eq t1 t2 -| GSort s1, GSort s2 -> Miscops.glob_sort_eq s1 s2 -| GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) -> - Option.equal (==) gn1 gn2 (** Only thing sensible *) && - Miscops.intro_pattern_naming_eq nam1 nam2 -| GCast (c1, t1), GCast (c2, t2) -> - glob_constr_eq c1 c2 && cast_type_eq glob_constr_eq t1 t2 -| _ -> false - -and tomatch_tuple_eq (c1, p1) (c2, p2) = + | CastConv t1, CastConv t2 -> eq t1 t2 + | CastVM t1, CastVM t2 -> eq t1 t2 + | CastCoerce, CastCoerce -> true + | CastNative t1, CastNative t2 -> eq t1 t2 + | (CastConv _ | CastVM _ | CastCoerce | CastNative _), _ -> false + +let matching_var_kind_eq k1 k2 = match k1, k2 with +| FirstOrderPatVar ido1, FirstOrderPatVar ido2 -> Id.equal ido1 ido2 +| SecondOrderPatVar id1, SecondOrderPatVar id2 -> Id.equal id1 id2 +| (FirstOrderPatVar _ | SecondOrderPatVar _), _ -> false + +let tomatch_tuple_eq f (c1, p1) (c2, p2) = let eqp (_, (i1, na1)) (_, (i2, na2)) = eq_ind i1 i2 && List.equal Name.equal na1 na2 in let eq_pred (n1, o1) (n2, o2) = Name.equal n1 n2 && Option.equal eqp o1 o2 in - glob_constr_eq c1 c2 && eq_pred p1 p2 + f c1 c2 && eq_pred p1 p2 -and cases_clause_eq (_, (id1, p1, c1)) (_, (id2, p2, c2)) = - List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 && - glob_constr_eq c1 c2 +and cases_clause_eq f (_, (id1, p1, c1)) (_, (id2, p2, c2)) = + List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 && f c1 c2 -and glob_decl_eq (na1, bk1, c1, t1) (na2, bk2, c2, t2) = +let glob_decl_eq f (na1, bk1, c1, t1) (na2, bk2, c2, t2) = Name.equal na1 na2 && binding_kind_eq bk1 bk2 && - Option.equal glob_constr_eq c1 c2 && - glob_constr_eq t1 t2 - -and fix_kind_eq k1 k2 = match k1, k2 with -| GFix (a1, i1), GFix (a2, i2) -> - let eq (i1, o1) (i2, o2) = - Option.equal Int.equal i1 i2 && fix_recursion_order_eq o1 o2 - in - Int.equal i1 i2 && Array.equal eq a1 a1 -| GCoFix i1, GCoFix i2 -> Int.equal i1 i2 -| _ -> false - -and fix_recursion_order_eq o1 o2 = match o1, o2 with -| GStructRec, GStructRec -> true -| GWfRec c1, GWfRec c2 -> glob_constr_eq c1 c2 -| GMeasureRec (c1, o1), GMeasureRec (c2, o2) -> - glob_constr_eq c1 c2 && Option.equal glob_constr_eq o1 o2 -| _ -> false - -and instance_eq (x1,c1) (x2,c2) = - Id.equal x1 x2 && glob_constr_eq c1 c2 + Option.equal f c1 c2 && f t1 t2 + +let fix_recursion_order_eq f o1 o2 = match o1, o2 with + | GStructRec, GStructRec -> true + | GWfRec c1, GWfRec c2 -> f c1 c2 + | GMeasureRec (c1, o1), GMeasureRec (c2, o2) -> + f c1 c2 && Option.equal f o1 o2 + | (GStructRec | GWfRec _ | GMeasureRec _), _ -> false + +let fix_kind_eq f k1 k2 = match k1, k2 with + | GFix (a1, i1), GFix (a2, i2) -> + let eq (i1, o1) (i2, o2) = + Option.equal Int.equal i1 i2 && fix_recursion_order_eq f o1 o2 + in + Int.equal i1 i2 && Array.equal eq a1 a1 + | GCoFix i1, GCoFix i2 -> Int.equal i1 i2 + | (GFix _ | GCoFix _), _ -> false + +let instance_eq f (x1,c1) (x2,c2) = + Id.equal x1 x2 && f c1 c2 + +let mk_glob_constr_eq f { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with + | GRef (gr1, _), GRef (gr2, _) -> eq_gr gr1 gr2 + | GVar id1, GVar id2 -> Id.equal id1 id2 + | GEvar (id1, arg1), GEvar (id2, arg2) -> + Id.equal id1 id2 && List.equal (instance_eq f) arg1 arg2 + | GPatVar k1, GPatVar k2 -> matching_var_kind_eq k1 k2 + | GApp (f1, arg1), GApp (f2, arg2) -> + f f1 f2 && List.equal f arg1 arg2 + | GLambda (na1, bk1, t1, c1), GLambda (na2, bk2, t2, c2) -> + Name.equal na1 na2 && binding_kind_eq bk1 bk2 && f t1 t2 && f c1 c2 + | GProd (na1, bk1, t1, c1), GProd (na2, bk2, t2, c2) -> + Name.equal na1 na2 && binding_kind_eq bk1 bk2 && f t1 t2 && f c1 c2 + | GLetIn (na1, b1, t1, c1), GLetIn (na2, b2, t2, c2) -> + Name.equal na1 na2 && f b1 b2 && Option.equal f t1 t2 && f c1 c2 + | GCases (st1, c1, tp1, cl1), GCases (st2, c2, tp2, cl2) -> + case_style_eq st1 st2 && Option.equal f c1 c2 && + List.equal (tomatch_tuple_eq f) tp1 tp2 && + List.equal (cases_clause_eq f) cl1 cl2 + | GLetTuple (na1, (n1, p1), c1, t1), GLetTuple (na2, (n2, p2), c2, t2) -> + List.equal Name.equal na1 na2 && Name.equal n1 n2 && + Option.equal f p1 p2 && f c1 c2 && f t1 t2 + | GIf (m1, (pat1, p1), c1, t1), GIf (m2, (pat2, p2), c2, t2) -> + f m1 m2 && Name.equal pat1 pat2 && + Option.equal f p1 p2 && f c1 c2 && f t1 t2 + | GRec (kn1, id1, decl1, c1, t1), GRec (kn2, id2, decl2, c2, t2) -> + fix_kind_eq f kn1 kn2 && Array.equal Id.equal id1 id2 && + Array.equal (fun l1 l2 -> List.equal (glob_decl_eq f) l1 l2) decl1 decl2 && + Array.equal f c1 c2 && Array.equal f t1 t2 + | GSort s1, GSort s2 -> Miscops.glob_sort_eq s1 s2 + | GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) -> + Option.equal (==) gn1 gn2 (** Only thing sensible *) && + Miscops.intro_pattern_naming_eq nam1 nam2 + | GCast (c1, t1), GCast (c2, t2) -> + f c1 c2 && cast_type_eq f t1 t2 + | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | + GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _), _ -> false + +let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c let map_glob_constr_left_to_right f = CAst.map (function | GApp (g,args) -> @@ -215,20 +215,20 @@ let fold_glob_constr f acc = CAst.with_val (function ) let fold_return_type_with_binders f g v acc (na,tyopt) = - Option.fold_left (f (name_fold g na v)) acc tyopt + Option.fold_left (f (Name.fold_right g na v)) acc tyopt let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function | GVar _ -> acc | GApp (c,args) -> List.fold_left (f v) (f v acc c) args | GLambda (na,_,b,c) | GProd (na,_,b,c) -> - f (name_fold g na v) (f v acc b) c + f (Name.fold_right g na v) (f v acc b) c | GLetIn (na,b,t,c) -> - f (name_fold g na v) (Option.fold_left (f v) (f v acc b) t) c + f (Name.fold_right g na v) (Option.fold_left (f v) (f v acc b) t) c | GCases (_,rtntypopt,tml,pl) -> let fold_pattern acc (_,(idl,p,c)) = f (List.fold_right g idl v) acc c in let fold_tomatch (v',acc) (tm,(na,onal)) = - (Option.fold_left (fun v'' (_,(_,nal)) -> List.fold_right (name_fold g) nal v'') - (name_fold g na v') onal, + (Option.fold_left (fun v'' (_,(_,nal)) -> List.fold_right (Name.fold_right g) nal v'') + (Name.fold_right g na v') onal, f v acc tm) in let (v',acc) = List.fold_left fold_tomatch (v,acc) tml in let acc = Option.fold_left (f v') acc rtntypopt in @@ -242,7 +242,7 @@ let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function let v,acc = List.fold_left (fun (v,acc) (na,k,bbd,bty) -> - (name_fold g na v, f v (Option.fold_left (f v) acc bbd) bty)) + (Name.fold_right g na v, f v (Option.fold_left (f v) acc bbd) bty)) (v,acc) bll.(i) in f (Array.fold_right g idl v) (f v acc tyl.(i)) (bv.(i)) in @@ -371,12 +371,12 @@ let loc_of_glob_constr c = c.CAst.loc let collide_id l id = List.exists (fun (id',id'') -> Id.equal id id' || Id.equal id id'') l let test_id l id = if collide_id l id then raise Not_found -let test_na l na = name_iter (test_id l) na +let test_na l na = Name.iter (test_id l) na let update_subst na l = let in_range id l = List.exists (fun (_,id') -> Id.equal id id') l in - let l' = name_fold Id.List.remove_assoc na l in - name_fold + let l' = Name.fold_right Id.List.remove_assoc na l in + Name.fold_right (fun id _ -> if in_range id l' then let id' = Namegen.next_ident_away_from id (fun id' -> in_range id' l') in diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index aa48516af..f7cc08ca2 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -36,6 +36,9 @@ val map_glob_constr_left_to_right : val warn_variable_collision : ?loc:Loc.t -> Id.t -> unit +val mk_glob_constr_eq : (glob_constr -> glob_constr -> bool) -> + glob_constr -> glob_constr -> bool + val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a val fold_glob_constr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> glob_constr -> 'b) -> 'a -> 'b -> glob_constr -> 'b val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index c4a74d990..97aec1814 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -27,7 +27,6 @@ open Inductiveops open Environ open Reductionops open Nametab -open Sigma.Notations open Context.Rel.Declaration type dep_flag = bool @@ -130,19 +129,19 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = it_mkLambda_or_LetIn_name env' obj deparsign else let cs = lift_constructor (k+1) constrs.(k) in - let t = build_branch_type env (Sigma.to_evar_map sigma) dep (mkRel (k+1)) cs in + let t = build_branch_type env sigma dep (mkRel (k+1)) cs in mkLambda_string "f" t (add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1)) in - let Sigma (s, sigma, p) = Sigma.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in - let typP = make_arity env' (Sigma.to_evar_map sigma) dep indf s in + let (sigma, s) = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in + let typP = make_arity env' sigma dep indf s in let typP = EConstr.Unsafe.to_constr typP in let c = it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP (add_branch (push_rel (LocalAssum (Anonymous,typP)) env') 0)) lnamespar in - Sigma (c, sigma, p) + (sigma, c) (* check if the type depends recursively on one of the inductive scheme *) @@ -296,7 +295,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = process_constr (push_rel d env) (i+1) (lift 1 f) (cprest,rest)) | [],[] -> f - | _,[] | [],_ -> anomaly (Pp.str "process_constr") + | _,[] | [],_ -> anomaly (Pp.str "process_constr.") in process_constr env 0 f (List.rev cstr.cs_args, recargs) @@ -475,10 +474,9 @@ let mis_make_indrec env sigma listdepkind mib u = it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamesparrec else - let sigma = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (c, sigma, _) = mis_make_case_com dep env sigma (indi,u) (mibi,mipi) kind in - let evd' = Sigma.to_evar_map sigma in - evdref := evd'; c + let evd = !evdref in + let (evd, c) = mis_make_case_com dep env evd (indi,u) (mibi,mipi) kind in + evdref := evd; c in (* Body of mis_make_indrec *) !evdref, List.init nrec make_one_rec @@ -533,7 +531,7 @@ let weaken_sort_scheme env evd set sort npars term ty = mkProd (n, t, c'), mkLambda (n, t, term') | LetIn (n,b,t,c) -> let c',term' = drec np c in mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') - | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type") + | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type.") in let ty, term = drec npars ty in !evdref, ty, term @@ -577,7 +575,7 @@ let build_mutual_induction_scheme env sigma = function in let _ = check_arities env listdepkind in mis_make_indrec env sigma listdepkind mib u - | _ -> anomaly (Pp.str "build_induction_scheme expects a non empty list of inductive types") + | _ -> anomaly (Pp.str "build_induction_scheme expects a non empty list of inductive types.") let build_induction_scheme env sigma pind dep kind = let (mib,mip) = lookup_mind_specif env (fst pind) in diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index 192b64a5e..a22470ae8 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -26,14 +26,14 @@ type dep_flag = bool (** Build a case analysis elimination scheme in some sort family *) -val build_case_analysis_scheme : env -> 'r Sigma.t -> pinductive -> - dep_flag -> sorts_family -> (constr, 'r) Sigma.sigma +val build_case_analysis_scheme : env -> Evd.evar_map -> pinductive -> + dep_flag -> sorts_family -> evar_map * Constr.t (** Build a dependent case elimination predicate unless type is in Prop or is a recursive record with primitive projections. *) -val build_case_analysis_scheme_default : env -> 'r Sigma.t -> pinductive -> - sorts_family -> (constr, 'r) Sigma.sigma +val build_case_analysis_scheme_default : env -> evar_map -> pinductive -> + sorts_family -> evar_map * Constr.t (** Builds a recursive induction scheme (Peano-induction style) in the same sort family as the inductive family; it is dependent if not in Prop diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 7f3bafc68..d8252ea9b 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -538,7 +538,7 @@ let is_predicate_explicitly_dep env sigma pred arsign = | Name _ -> true end - | _ -> anomaly (Pp.str "Non eta-expanded dep-expanded \"match\" predicate") + | _ -> anomaly (Pp.str "Non eta-expanded dep-expanded \"match\" predicate.") in srec env (EConstr.of_constr pred) arsign diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index 211ffbe01..e555742bc 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -84,7 +84,7 @@ let concrete_clause_of enum_hyps cl = (** Miscellaneous functions *) let out_arg = function - | Misctypes.ArgVar _ -> CErrors.anomaly (Pp.str "Unevaluated or_var variable") + | Misctypes.ArgVar _ -> CErrors.anomaly (Pp.str "Unevaluated or_var variable.") | Misctypes.ArgArg x -> x let occurrences_of_hyp id cls = diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index afaa20b6f..61118cf77 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -139,7 +139,7 @@ let type_of_var env id = let open Context.Named.Declaration in try env |> lookup_named id |> get_type with Not_found -> - anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound") + anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound.") let sort_of_product env domsort rangsort = match (domsort, rangsort) with @@ -405,7 +405,7 @@ let native_norm env sigma c ty = let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in if !Flags.debug then Feedback.msg_debug (Pp.str time_info); EConstr.of_constr res - | _ -> anomaly (Pp.str "Compilation failure") + | _ -> anomaly (Pp.str "Compilation failure.") let native_conv_generic pb sigma t = Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 1c8ad0cdd..db2e5da95 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -112,14 +112,14 @@ let rec head_pattern_bound t = -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) | PLambda _ -> raise BoundPattern - | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type") + | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type.") let head_of_constr_reference sigma c = match EConstr.kind sigma c with | Const (sp,_) -> ConstRef sp | Construct (sp,_) -> ConstructRef sp | Ind (sp,_) -> IndRef sp | Var id -> VarRef id - | _ -> anomaly (Pp.str "Not a rigid reference") + | _ -> anomaly (Pp.str "Not a rigid reference.") let pattern_of_constr env sigma t = let rec pattern_of_constr env t = @@ -143,7 +143,7 @@ let pattern_of_constr env sigma t = match kind_of_term f with | Evar (evk,args) -> (match snd (Evd.evar_source evk sigma) with - Evar_kinds.MatchingVar (true,id) -> Some id + Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar id) -> Some id | _ -> None) | _ -> None with @@ -156,13 +156,14 @@ let pattern_of_constr env sigma t = pattern_of_constr env (EConstr.Unsafe.to_constr (Retyping.expand_projection env sigma p (EConstr.of_constr c) [])) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with - | Evar_kinds.MatchingVar (b,id) -> - assert (not b); PMeta (Some id) + | Evar_kinds.MatchingVar (Evar_kinds.FirstOrderPatVar id) -> + PMeta (Some id) | Evar_kinds.GoalEvar | Evar_kinds.VarInstance _ -> (* These are the two evar kinds used for existing goals *) (* see Proofview.mark_in_evm *) if Evd.is_defined sigma evk then pattern_of_constr env (Evd.existential_value sigma ev) else PEvar (evk,Array.map (pattern_of_constr env) ctxt) + | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false | _ -> PMeta None) | Case (ci,p,a,br) -> @@ -329,26 +330,26 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function | GVar id -> (try PRel (List.index Name.equal (Name id) vars) with Not_found -> PVar id) - | GPatVar (false,n) -> + | GPatVar (Evar_kinds.FirstOrderPatVar n) -> metas := n::!metas; PMeta (Some n) | GRef (gr,_) -> PRef (canonical_gr gr) (* Hack to avoid rewriting a complete interpretation of patterns *) - | GApp ({ CAst.v = GPatVar (true,n) }, cl) -> + | GApp ({ CAst.v = GPatVar (Evar_kinds.SecondOrderPatVar n) }, cl) -> metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) | GApp (c,cl) -> PApp (pat_of_raw metas vars c, Array.of_list (List.map (pat_of_raw metas vars) cl)) | GLambda (na,bk,c1,c2) -> - name_iter (fun n -> metas := n::!metas) na; + Name.iter (fun n -> metas := n::!metas) na; PLambda (na, pat_of_raw metas vars c1, pat_of_raw metas (na::vars) c2) | GProd (na,bk,c1,c2) -> - name_iter (fun n -> metas := n::!metas) na; + Name.iter (fun n -> metas := n::!metas) na; PProd (na, pat_of_raw metas vars c1, pat_of_raw metas (na::vars) c2) | GLetIn (na,c1,t,c2) -> - name_iter (fun n -> metas := n::!metas) na; + Name.iter (fun n -> metas := n::!metas) na; PLetIn (na, pat_of_raw metas vars c1, Option.map (pat_of_raw metas vars) t, pat_of_raw metas (na::vars) c2) @@ -411,7 +412,7 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function and pats_of_glob_branches loc metas vars ind brs = let get_arg = function | { CAst.v = PatVar na } -> - name_iter (fun n -> metas := n::!metas) na; + Name.iter (fun n -> metas := n::!metas) na; na | { CAst.v = PatCstr(_,_,_) ; loc } -> err ?loc (Pp.str "Non supported pattern.") in diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index e72394fa2..92e728683 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -44,8 +44,6 @@ open Glob_ops open Evarconv open Pattern open Misctypes -open Tactypes -open Sigma.Notations module NamedDecl = Context.Named.Declaration @@ -111,9 +109,9 @@ let e_new_evar env evdref ?src ?naming typ = let typ' = subst2 subst vsubst typ in let instance = inst_rels @ inst_vars in let sign = val_of_named_context nc in - let sigma = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (e, sigma, _) = new_evar_instance sign sigma typ' ?src ?naming instance in - evdref := Sigma.to_evar_map sigma; + let sigma = !evdref in + let (sigma, e) = new_evar_instance sign sigma typ' ?src ?naming instance in + evdref := sigma; e let push_rec_types sigma (lna,typarray,_) env = @@ -199,7 +197,7 @@ let interp_universe_level_name ~anon_rigidity evd (loc, s) = let names, _ = Global.global_universe_names () in if CString.string_contains ~where:s ~what:"." then match List.rev (CString.split '.' s) with - | [] -> anomaly (str"Invalid universe name " ++ str s) + | [] -> anomaly (str"Invalid universe name " ++ str s ++ str".") | n :: dp -> let num = int_of_string n in let dp = DirPath.make (List.map Id.of_string dp) in @@ -383,6 +381,20 @@ let process_inference_flags flags env initial_sigma (sigma,c) = let c = if flags.expand_evars then nf_evar sigma c else c in sigma,c +let adjust_evar_source evdref na c = + match na, kind !evdref c with + | Name id, Evar (evk,args) -> + let evi = Evd.find !evdref evk in + begin match evi.evar_source with + | loc, Evar_kinds.QuestionMark (b,Anonymous) -> + let src = (loc,Evar_kinds.QuestionMark (b,na)) in + let (evd, evk') = restrict_evar !evdref evk (evar_filter evi) ~src None in + evdref := evd; + mkEvar (evk',args) + | _ -> c + end + | _, _ -> c + (* Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *) let allow_anonymous_refs = ref false @@ -556,12 +568,12 @@ let pretype_sort ?loc evdref = function | GType s -> evd_comb1 (judge_of_Type ?loc) evdref s let new_type_evar env evdref loc = - let sigma = Sigma.Unsafe.of_evar_map !evdref in - let Sigma ((e, _), sigma, _) = + let sigma = !evdref in + let (sigma, (e, _)) = Evarutil.new_type_evar env.ExtraEnv.env sigma univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole) in - evdref := Sigma.to_evar_map sigma; + evdref := sigma; e module ConstrInterpObj = @@ -610,13 +622,13 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let j = (Retyping.get_judgment_of env.ExtraEnv.env !evdref c) in inh_conv_coerce_to_tycon ?loc env evdref j tycon - | GPatVar (someta,n) -> + | GPatVar kind -> let env = ltac_interp_name_env k0 lvar env !evdref in let ty = match tycon with | Some ty -> ty | None -> new_type_evar env evdref loc in - let k = Evar_kinds.MatchingVar (someta,n) in + let k = Evar_kinds.MatchingVar kind in { uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty } | GHole (k, naming, None) -> @@ -785,6 +797,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre args, nf_evar !evdref (j_val hj) else [], j_val hj in + let ujval = adjust_evar_source evdref na ujval in let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in let j = { uj_val = value; uj_type = typ } in apply_rec env (n+1) j candargs rest @@ -1133,7 +1146,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function | Sort s -> ESorts.kind sigma s | Evar ev when is_Type (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev - | _ -> anomaly (Pp.str "Found a type constraint which is not a type") + | _ -> anomaly (Pp.str "Found a type constraint which is not a type.") in { utj_val = v; utj_type = s } @@ -1251,7 +1264,7 @@ let constr_flags = { (* Fully evaluate an untyped constr *) let type_uconstr ?(flags = constr_flags) ?(expected_type = WithoutTypeConstraint) ist c = - { delayed = begin fun env sigma -> + begin fun env sigma -> let { closure; term } = c in let vars = { ltac_constrs = closure.typed; @@ -1259,10 +1272,8 @@ let type_uconstr ?(flags = constr_flags) ltac_idents = closure.idents; ltac_genargs = Id.Map.empty; } in - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = understand_ltac flags env sigma vars expected_type term in - Sigma.Unsafe.of_pair (c, sigma) - end } + understand_ltac flags env sigma vars expected_type term + end let pretype k0 resolve_tc typcon env evdref lvar t = pretype k0 resolve_tc typcon (make_env env !evdref) evdref lvar t diff --git a/pretyping/program.ml b/pretyping/program.ml index 8769c5659..f9be82024 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -9,7 +9,6 @@ open CErrors open Util -let init_constant dir s () = Universes.constr_of_global @@ Coqlib.coq_reference "Program" dir s let init_reference dir s () = Coqlib.coq_reference "Program" dir s let papp evdref r args = @@ -39,20 +38,20 @@ let coq_eq_rect = init_reference ["Init"; "Logic"] "eq_rect" let coq_JMeq_ind = init_reference ["Logic";"JMeq"] "JMeq" let coq_JMeq_refl = init_reference ["Logic";"JMeq"] "JMeq_refl" -let coq_not = init_constant ["Init";"Logic"] "not" -let coq_and = init_constant ["Init";"Logic"] "and" +let coq_not = init_reference ["Init";"Logic"] "not" +let coq_and = init_reference ["Init";"Logic"] "and" -let delayed_force c = EConstr.of_constr (c ()) - -let mk_coq_not x = EConstr.mkApp (delayed_force coq_not, [| x |]) +let mk_coq_not sigma x = + let sigma, notc = Evarutil.new_global sigma (coq_not ()) in + sigma, EConstr.mkApp (notc, [| x |]) let unsafe_fold_right f = function hd :: tl -> List.fold_right f tl hd | [] -> invalid_arg "unsafe_fold_right" -let mk_coq_and l = - let and_typ = delayed_force coq_and in - unsafe_fold_right +let mk_coq_and sigma l = + let sigma, and_typ = Evarutil.new_global sigma (coq_and ()) in + sigma, unsafe_fold_right (fun c conj -> EConstr.mkApp (and_typ, [| c ; conj |])) l diff --git a/pretyping/program.mli b/pretyping/program.mli index 94a7bdcb6..8439b9528 100644 --- a/pretyping/program.mli +++ b/pretyping/program.mli @@ -32,8 +32,8 @@ val coq_eq_rect : unit -> global_reference val coq_JMeq_ind : unit -> global_reference val coq_JMeq_refl : unit -> global_reference -val mk_coq_and : constr list -> constr -val mk_coq_not : constr -> constr +val mk_coq_and : Evd.evar_map -> constr list -> Evd.evar_map * constr +val mk_coq_not : Evd.evar_map -> constr -> Evd.evar_map * constr (** Polymorphic application of delayed references *) val papp : Evd.evar_map ref -> (unit -> global_reference) -> constr array -> constr diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index e7c963582..b4654bfb5 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -595,7 +595,7 @@ type state = constr * constr Stack.t type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr -type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list @@ -1317,19 +1317,23 @@ let sigma_univ_state = let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = (** FIXME *) + let open Universes in let x = EConstr.Unsafe.to_constr x in let y = EConstr.Unsafe.to_constr y in try - let fold cstr sigma = - try Some (Evd.add_universe_constraints sigma cstr) - with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None - in + let fold cstr accu = Some (Constraints.fold Constraints.add cstr accu) in let b, sigma = let ans = if pb == Reduction.CUMUL then - Universes.leq_constr_univs_infer (Evd.universes sigma) fold x y sigma + Universes.leq_constr_univs_infer (Evd.universes sigma) fold x y Constraints.empty else - Universes.eq_constr_univs_infer (Evd.universes sigma) fold x y sigma + Universes.eq_constr_univs_infer (Evd.universes sigma) fold x y Constraints.empty + in + let ans = match ans with + | None -> None + | Some cstr -> + try Some (Evd.add_universe_constraints sigma cstr) + with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None in match ans with | None -> false, sigma @@ -1441,7 +1445,7 @@ let instance sigma s c = let hnf_prod_app env sigma t n = match EConstr.kind sigma (whd_all env sigma t) with | Prod (_,_,b) -> subst1 n b - | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product") + | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product.") let hnf_prod_appvect env sigma t nl = Array.fold_left (fun acc t -> hnf_prod_app env sigma acc t) t nl @@ -1452,7 +1456,7 @@ let hnf_prod_applist env sigma t nl = let hnf_lam_app env sigma t n = match EConstr.kind sigma (whd_all env sigma t) with | Lambda (_,_,b) -> subst1 n b - | _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction") + | _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction.") let hnf_lam_appvect env sigma t nl = Array.fold_left (fun acc t -> hnf_lam_app env sigma acc t) t nl @@ -1689,5 +1693,5 @@ let betazetaevar_applist sigma n c l = | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack | Evar _, _ -> applist (substl env t, stack) - | _ -> anomaly (Pp.str "Not enough lambda/let's") in + | _ -> anomaly (Pp.str "Not enough lambda/let's.") in stacklam n [] c l diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index af8048156..af0e28cdd 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -117,7 +117,7 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr -type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 496c706ec..a1d0977f5 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -48,7 +48,7 @@ let retype_error re = raise (RetypeError re) let anomaly_on_error f x = try f x - with RetypeError e -> anomaly ~label:"retyping" (print_retype_error e) + with RetypeError e -> anomaly ~label:"retyping" (print_retype_error e ++ str ".") let get_type_from_constraints env sigma t = if isEvar sigma (fst (decompose_app_vect sigma t)) then diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 3d41d2ddd..ec3669bfe 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -24,7 +24,6 @@ open Reductionops open Cbv open Patternops open Locus -open Sigma.Notations module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -107,7 +106,7 @@ let destEvalRefU sigma c = match EConstr.kind sigma c with | Var id -> (EvalVar id, EInstance.empty) | Rel n -> (EvalRel n, EInstance.empty) | Evar ev -> (EvalEvar ev, EInstance.empty) - | _ -> anomaly (Pp.str "Not an unfoldable reference") + | _ -> anomaly (Pp.str "Not an unfoldable reference.") let unsafe_reference_opt_value env sigma eval = match eval with @@ -307,7 +306,7 @@ let compute_consteval_mutual_fix env sigma ref = (* Forget all \'s and args and do as if we had started with c' *) let ref,_ = destEvalRefU sigma c' in (match unsafe_reference_opt_value env sigma ref with - | None -> anomaly (Pp.str "Should have been trapped by compute_direct") + | None -> anomaly (Pp.str "Should have been trapped by compute_direct.") | Some c -> srec env (minarg-nargs) [] ref c) | _ -> (* Should not occur *) NotAnElimination in @@ -399,9 +398,8 @@ let substl_with_function subst sigma constr = if i <= k + Array.length v then match v.(i-k-1) with | (fx, Some (min, ref)) -> - let sigma = Sigma.Unsafe.of_evar_map !evd in - let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma dummy in - let sigma = Sigma.to_evar_map sigma in + let sigma = !evd in + let (sigma, evk) = Evarutil.new_pure_evar venv sigma dummy in evd := sigma; minargs := Evar.Map.add evk min !minargs; Vars.lift k (mkEvar (evk, [|fx;ref|])) @@ -983,11 +981,10 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = | _ -> mkApp (app', [| a' |])) | _ -> map_constr_with_binders_left_to_right sigma g f acc c -let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> +let e_contextually byhead (occs,c) f = begin fun env sigma t -> let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in - let sigma = Sigma.to_evar_map sigma in (** FIXME: we do suspicious things with this evarmap *) let evd = ref sigma in let rec traverse nested (env,c as envc) t = @@ -1007,8 +1004,8 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> (* Skip inner occurrences for stable counting of occurrences *) if locs != [] then ignore (traverse_below (Some (!pos-1)) envc t); - let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in - (evd := Sigma.to_evar_map evm; t) + let (evm, t) = (f subst) env !evd t in + (evd := evm; t) end else traverse_below nested envc t @@ -1027,15 +1024,12 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> in let t' = traverse None (env,c) t in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; - Sigma.Unsafe.of_pair (t', !evd) - end } + (!evd, t') + end let contextually byhead occs f env sigma t = - let f' subst = { e_redfun = begin fun env sigma t -> - Sigma.here (f subst env (Sigma.to_evar_map sigma) t) sigma - end } in - let Sigma (c, _, _) = (e_contextually byhead occs f').e_redfun env (Sigma.Unsafe.of_evar_map sigma) t in - c + let f' subst env sigma t = sigma, f subst env sigma t in + snd (e_contextually byhead occs f' env sigma t) (* linear bindings (following pretty-printer) of the value of name in c. * n is the number of the next occurrence of name. @@ -1154,15 +1148,14 @@ let abstract_scheme env sigma (locc,a) (c, sigma) = let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in mkLambda (na,ta,c'), sigma' -let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> - let sigma = Sigma.to_evar_map sigma in +let pattern_occs loccs_trm = begin fun env sigma c -> let abstr_trm, sigma = List.fold_right (abstract_scheme env sigma) loccs_trm (c,sigma) in try let _ = Typing.unsafe_type_of env sigma abstr_trm in - Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma) + (sigma, applist(abstr_trm, List.map snd loccs_trm)) with Type_errors.TypeError (env',t) -> raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t)))) - end } + end (* Used in several tactics. *) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 757e12451..7ad988ad0 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -31,7 +31,7 @@ let push_rec_types pfix env = let meta_type evd mv = let ty = try Evd.meta_ftype evd mv - with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv)) in + with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv) ++ str ".") in let ty = Evd.map_fl EConstr.of_constr ty in meta_instance evd ty @@ -121,11 +121,11 @@ let lambda_applist_assum sigma n c l = let rec app n subst t l = if Int.equal n 0 then if l == [] then substl subst t - else anomaly (Pp.str "Not enough arguments") + else anomaly (Pp.str "Not enough arguments.") else match EConstr.kind sigma t, l with | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l - | _ -> anomaly (Pp.str "Not enough lambda/let's") in + | _ -> anomaly (Pp.str "Not enough lambda/let's.") in app n [] c l let e_type_case_branches env evdref (ind,largs) pj c = diff --git a/pretyping/unification.ml b/pretyping/unification.ml index d1643a8c7..0fb48ed8c 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -31,7 +31,6 @@ open Recordops open Locus open Locusops open Find_subterm -open Sigma.Notations type metabinding = (metavariable * EConstr.constr * (instance_constraint * instance_typing_status)) @@ -145,9 +144,7 @@ let set_occurrences_of_last_arg args = Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args) let abstract_list_all_with_dependencies env evd typ c l = - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (ev, evd, _) = new_evar env evd typ in - let evd = Sigma.to_evar_map evd in + let (evd, ev) = new_evar env evd typ in let evd,ev' = evar_absorb_arguments env evd (destEvar evd ev) l in let n = List.length l in let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in @@ -1239,20 +1236,19 @@ let merge_instances env sigma flags st1 st2 c1 c2 = * close it off. But this might not always work, * since other metavars might also need to be resolved. *) -let applyHead env (type r) (evd : r Sigma.t) n c = - let rec apprec : type s. _ -> _ -> _ -> (r, s) Sigma.le -> s Sigma.t -> (constr, r) Sigma.sigma = - fun n c cty p evd -> +let applyHead env evd n c = + let rec apprec n c cty evd = if Int.equal n 0 then - Sigma (c, evd, p) + (evd, c) else - let sigma = Sigma.to_evar_map evd in - match EConstr.kind sigma (whd_all env sigma cty) with + match EConstr.kind evd (whd_all env evd cty) with | Prod (_,c1,c2) -> - let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.tag Evar_kinds.GoalEvar) c1 in - apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' + let (evd',evar) = + Evarutil.new_evar env evd ~src:(Loc.tag Evar_kinds.GoalEvar) c1 in + apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd' | _ -> user_err Pp.(str "Apply_Head_Then") in - apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd + apprec n c (Typing.unsafe_type_of env evd c) evd let is_mimick_head sigma ts f = match EConstr.kind sigma f with @@ -1416,9 +1412,7 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = and mimick_undefined_evar evd flags hdc nargs sp = let ev = Evd.find_undefined evd sp in let sp_env = Global.env_of_context ev.evar_hyps in - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, evd', _) = applyHead sp_env evd nargs hdc in - let evd' = Sigma.to_evar_map evd' in + let (evd', c) = applyHead sp_env evd nargs hdc in let (evd'',mc,ec) = unify_0 sp_env evd' CUMUL flags (get_type_of sp_env evd' c) (EConstr.of_constr ev.evar_concl) in @@ -1534,10 +1528,9 @@ let indirectly_dependent sigma c d decls = List.exists (fun d' -> dependent_in_decl sigma (EConstr.mkVar (NamedDecl.get_id d')) d) decls 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 let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in let sigma, subst = nf_univ_variables sigma in - Sigma.Unsafe.of_pair (EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr (nf_evar sigma c))), sigma) + (sigma, EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr (nf_evar sigma c)))) let default_matching_core_flags sigma = let ts = Names.full_transparent_state in { @@ -1684,7 +1677,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = 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)) + | Some (sigma, c) -> Some (sigma,c) in (id,sign,depdecls,lastlhyp,ccl,res) with @@ -1711,10 +1704,9 @@ type abstraction_request = type 'r abstraction_result = Names.Id.t * named_context_val * named_declaration list * Names.Id.t option * - types * (constr, 'r) Sigma.sigma option + types * (evar_map * constr) option let make_abstraction env evd ccl abs = - let evd = Sigma.to_evar_map evd in match abs with | AbstractPattern (from_prefix,check,name,c,occs,check_occs) -> make_abstraction_core name diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 8d7e3521d..0d90ab158 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -76,14 +76,14 @@ type abstraction_request = | AbstractExact of Names.Name.t * constr * types option * Locus.clause * bool val finish_evar_resolution : ?flags:Pretyping.inference_flags -> - env -> 'r Sigma.t -> (evar_map * constr) -> (constr, 'r) Sigma.sigma + env -> evar_map -> (evar_map * constr) -> evar_map * constr type 'r abstraction_result = Names.Id.t * named_context_val * named_declaration list * Names.Id.t option * - types * (constr, 'r) Sigma.sigma option + types * (evar_map * constr) option -val make_abstraction : env -> 'r Sigma.t -> constr -> +val make_abstraction : env -> evar_map -> constr -> abstraction_request -> 'r abstraction_result val pose_all_metas_as_evars : env -> evar_map -> constr -> evar_map * constr diff --git a/printing/miscprint.ml b/printing/miscprint.ml index 360843711..a4ecbdf5e 100644 --- a/printing/miscprint.ml +++ b/printing/miscprint.ml @@ -47,3 +47,28 @@ let pr_move_location pr_id = function | MoveBefore id -> brk(1,1) ++ str "before " ++ pr_id id | MoveFirst -> str " at top" | MoveLast -> str " at bottom" + +(** Printing of bindings *) +let pr_binding prc = function + | loc, (NamedHyp id, c) -> hov 1 (Names.Id.print id ++ str " := " ++ cut () ++ prc c) + | loc, (AnonHyp n, c) -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) + +let pr_bindings prc prlc = function + | ImplicitBindings l -> + brk (1,1) ++ str "with" ++ brk (1,1) ++ + pr_sequence prc l + | ExplicitBindings l -> + brk (1,1) ++ str "with" ++ brk (1,1) ++ + pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | NoBindings -> mt () + +let pr_bindings_no_with prc prlc = function + | ImplicitBindings l -> + brk (0,1) ++ prlist_with_sep spc prc l + | ExplicitBindings l -> + brk (0,1) ++ prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | NoBindings -> mt () + +let pr_with_bindings prc prlc (c,bl) = + hov 1 (prc c ++ pr_bindings prc prlc bl) + diff --git a/printing/miscprint.mli b/printing/miscprint.mli index fe8c779ff..dbbe3dcfd 100644 --- a/printing/miscprint.mli +++ b/printing/miscprint.mli @@ -22,3 +22,16 @@ val pr_intro_pattern_naming : intro_pattern_naming_expr -> Pp.std_ppcmds val pr_move_location : ('a -> Pp.std_ppcmds) -> 'a move_location -> Pp.std_ppcmds + +val pr_bindings : + ('a -> Pp.std_ppcmds) -> + ('a -> Pp.std_ppcmds) -> 'a bindings -> Pp.std_ppcmds + +val pr_bindings_no_with : + ('a -> Pp.std_ppcmds) -> + ('a -> Pp.std_ppcmds) -> 'a bindings -> Pp.std_ppcmds + +val pr_with_bindings : + ('a -> Pp.std_ppcmds) -> + ('a -> Pp.std_ppcmds) -> 'a * 'a bindings -> Pp.std_ppcmds + diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index f76555b04..626464b96 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -151,8 +151,8 @@ let tag_var = tag Tag.variable let pr_univ l = match l with - | [_,x] -> pr_name x - | l -> str"max(" ++ prlist_with_sep (fun () -> str",") (fun x -> pr_name (snd x)) l ++ str")" + | [_,x] -> Name.print x + | l -> str"max(" ++ prlist_with_sep (fun () -> str",") (fun x -> Name.print (snd x)) l ++ str")" let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" @@ -166,7 +166,7 @@ let tag_var = tag Tag.variable | GProp -> tag_type (str "Prop") | GSet -> tag_type (str "Set") | GType None -> tag_type (str "Type") - | GType (Some (_, u)) -> tag_type (pr_name u) + | GType (Some (_, u)) -> tag_type (Name.print u) let pr_qualid sp = let (sl, id) = repr_qualid sp in @@ -191,7 +191,7 @@ let tag_var = tag Tag.variable tag_type (str "Set") | GType u -> (match u with - | Some (_,u) -> pr_name u + | Some (_,u) -> Name.print u | None -> tag_type (str "Type")) let pr_universe_instance l = @@ -208,7 +208,7 @@ let tag_var = tag Tag.variable match expl with | None -> pr (lapp,L) a | Some (_,ExplByPos (n,_id)) -> - anomaly (Pp.str "Explicitation by position not implemented") + anomaly (Pp.str "Explicitation by position not implemented.") | Some (_,ExplByName id) -> str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")" @@ -224,7 +224,7 @@ let tag_var = tag Tag.variable let pr_lname = function | (loc,Name id) -> pr_lident (loc,id) - | lna -> pr_located pr_name lna + | lna -> pr_located Name.print lna let pr_or_var pr = function | ArgArg x -> pr x @@ -423,7 +423,7 @@ let tag_var = tag Tag.variable | CLambdaN ([[na],bk,t],c) -> (na,t,c) | CLambdaN (([na],bk,t)::bl,c) -> (na,t, CAst.make ?loc @@ CLambdaN(bl,c)) | CLambdaN ((na::nal,bk,t)::bl,c) -> (na,t, CAst.make ?loc @@ CLambdaN((nal,bk,t)::bl,c)) - | _ -> anomaly (Pp.str "ill-formed fixpoint body") + | _ -> anomaly (Pp.str "ill-formed fixpoint body.") ) let rename na na' t c = @@ -438,7 +438,7 @@ let tag_var = tag Tag.variable | CProdN (([na],bk,t)::bl,c) -> rename na na' t (CAst.make ?loc @@ CProdN(bl,c)) | CProdN ((na::nal,bk,t)::bl,c) -> rename na na' t (CAst.make ?loc @@ CProdN((nal,bk,t)::bl,c)) - | _ -> anomaly (Pp.str "ill-formed fixpoint body") + | _ -> anomaly (Pp.str "ill-formed fixpoint body.") ) let rec split_fix n typ def = @@ -485,7 +485,7 @@ let tag_var = tag Tag.variable pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c let pr_recursive pr_decl id = function - | [] -> anomaly (Pp.str "(co)fixpoint with no definition") + | [] -> anomaly (Pp.str "(co)fixpoint with no definition.") | [d1] -> pr_decl false d1 | dl -> prlist_with_sep (fun () -> fnl() ++ keyword "with" ++ spc ()) diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index c328b6032..781af4789 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -56,7 +56,7 @@ open Decl_kinds let pr_lname = function | (loc,Name id) -> pr_lident (loc,id) - | lna -> pr_located pr_name lna + | lna -> pr_located Name.print lna let pr_smart_global = Pputils.pr_or_by_notation pr_reference @@ -118,7 +118,7 @@ open Decl_kinds let pr_explanation (e,b,f) = let a = match e with - | ExplByPos (n,_) -> anomaly (Pp.str "No more supported") + | ExplByPos (n,_) -> anomaly (Pp.str "No more supported.") | ExplByName id -> pr_id id in let a = if f then str"!" ++ a else a in if b then str "[" ++ a ++ str "]" else a @@ -318,7 +318,7 @@ open Decl_kinds keyword (if many then "Local Parameters" else "Local Parameter") | (Global,Conjectural) -> str"Conjecture" | ((Discharge | Local),Conjectural) -> - anomaly (Pp.str "Don't know how to beautify a local conjecture") + anomaly (Pp.str "Don't know how to beautify a local conjecture.") let pr_params pr_c (xl,(c,t)) = hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++ @@ -1022,13 +1022,13 @@ open Decl_kinds | n, { name = id; recarg_like = k; notation_scope = s; implicit_status = imp } :: tl -> - spc() ++ pr_br imp (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++ + spc() ++ pr_br imp (pr_if k (str"!") ++ Name.print id ++ pr_s s) ++ print_arguments (Option.map pred n) tl in let rec print_implicits = function | [] -> mt () | (name, impl) :: rest -> - spc() ++ pr_br impl (pr_name name) ++ print_implicits rest + spc() ++ pr_br impl (Name.print name) ++ print_implicits rest in print_arguments nargs args ++ if not (List.is_empty more_implicits) then @@ -1075,7 +1075,7 @@ open Decl_kinds ) | VernacSetOpacity _ -> return ( - CErrors.anomaly (keyword "VernacSetOpacity used to set something else") + CErrors.anomaly (keyword "VernacSetOpacity used to set something else.") ) | VernacSetStrategy l -> let pr_lev = function diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 0f7da3613..2b21b3f9e 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -132,7 +132,7 @@ let print_impargs_list prefix l = let print_renames_list prefix l = if List.is_empty l then [] else [add_colon prefix ++ str "Arguments are renamed to " ++ - hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map pr_name l))] + hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map Name.print l))] let need_expansion impl ref = let typ = Global.type_of_global_unsafe ref in diff --git a/printing/printer.ml b/printing/printer.ml index ebe68680f..3c31dd96b 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -26,9 +26,6 @@ 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 get_current_context () = Pfedit.get_current_context () @@ -656,9 +653,6 @@ let print_dependent_evars gl sigma seeds = in cut () ++ cut () ++ str "(dependent evars:" ++ evars ++ str ")" - else if !Flags.print_emacs then - (* IDEs prefer something dummy instead of nothing *) - cut () ++ cut () ++ str "(dependent evars: (printing disabled) )" else mt () in constraints ++ evars () diff --git a/printing/printer.mli b/printing/printer.mli index 24107394e..3fce06561 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -169,19 +169,6 @@ val pr_ne_evar_set : std_ppcmds -> std_ppcmds -> evar_map -> val pr_prim_rule : prim_rule -> std_ppcmds -(** Emacs/proof general support - (emacs_str s) outputs - - s if emacs mode, - - nothing otherwise. - This function was previously used to insert special chars like - [(String.make 1 (Char.chr 253))] to parenthesize sub-parts of the - proof context for proof by pointing. This part of the code is - removed for now because it interacted badly with utf8. We may put - it back some day using some xml-like tags instead of special - chars. See for example the <prompt> tag in the prompt when in - emacs mode. *) -val emacs_str : string -> string - (** Backwards compatibility *) val prterm : constr -> std_ppcmds (** = pr_lconstr *) diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 33a86402e..79d2e4694 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -25,7 +25,6 @@ open Pretype_errors open Evarutil open Unification open Misctypes -open Sigma.Notations (******************************************************************) (* Clausal environments *) @@ -157,7 +156,7 @@ let error_incompatible_inst clenv mv = (str "An incompatible instantiation has already been found for " ++ pr_id id) | _ -> - anomaly ~label:"clenv_assign" (Pp.str "non dependent metavar already assigned") + anomaly ~label:"clenv_assign" (Pp.str "non dependent metavar already assigned.") (* TODO: replace by clenv_unify (mkMeta mv) rhs ? *) let clenv_assign mv rhs clenv = @@ -337,9 +336,8 @@ let clenv_pose_metas_as_evars clenv dep_mvs = else let src = evar_source_of_meta mv clenv.evd in let src = adjust_meta_source clenv.evd mv src in - let evd = Sigma.Unsafe.of_evar_map clenv.evd in - let Sigma (evar, evd, _) = new_evar (cl_env clenv) evd ~src ty in - let evd = Sigma.to_evar_map evd in + let evd = clenv.evd in + let (evd, evar) = new_evar (cl_env clenv) evd ~src ty in let clenv = clenv_assign mv evar {clenv with evd=evd} in fold clenv mvs in fold clenv dep_mvs @@ -433,7 +431,7 @@ let explain_no_such_bound_variable evd id = | Cltyp (na, _) -> na | Clval (na, _, _) -> na in - if na != Anonymous then out_name na :: l else l + if na != Anonymous then Name.get_id na :: l else l in let mvl = List.fold_left fold [] (Evd.meta_list evd) in user_err ~hdr:"Evd.meta_with_name" @@ -614,9 +612,7 @@ let make_evar_clause env sigma ?len t = | Cast (t, _, _) -> clrec (sigma, holes) n t | Prod (na, t1, t2) -> let store = Typeclasses.set_resolvable Evd.Store.empty false in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (ev, sigma, _) = new_evar ~store env sigma t1 in - let sigma = Sigma.to_evar_map sigma in + let (sigma, ev) = new_evar ~store env sigma t1 in let dep = not (noccurn sigma 1 t2) in let hole = { hole_evar = ev; diff --git a/proofs/clenv.mli b/proofs/clenv.mli index 4bcd50591..f43c0531d 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -41,10 +41,10 @@ val clenv_nf_meta : clausenv -> EConstr.constr -> EConstr.constr (** type of a meta in clenv context *) val clenv_meta_type : clausenv -> metavariable -> types -val mk_clenv_from : ('a, 'r) Proofview.Goal.t -> EConstr.constr * EConstr.types -> clausenv +val mk_clenv_from : 'a Proofview.Goal.t -> EConstr.constr * EConstr.types -> clausenv val mk_clenv_from_n : - ('a, 'r) Proofview.Goal.t -> int option -> EConstr.constr * EConstr.types -> clausenv -val mk_clenv_type_of : ('a, 'r) Proofview.Goal.t -> EConstr.constr -> clausenv + 'a Proofview.Goal.t -> int option -> EConstr.constr * EConstr.types -> clausenv +val mk_clenv_type_of : 'a Proofview.Goal.t -> EConstr.constr -> clausenv val mk_clenv_from_env : env -> evar_map -> int option -> EConstr.constr * EConstr.types -> clausenv (** Refresh the universes in a clenv *) @@ -66,7 +66,7 @@ val old_clenv_unique_resolver : ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv val clenv_unique_resolver : - ?flags:unify_flags -> clausenv -> ('a, 'r) Proofview.Goal.t -> clausenv + ?flags:unify_flags -> clausenv -> 'a Proofview.Goal.t -> clausenv val clenv_dependent : clausenv -> metavariable list diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 0722ea047..2ce144a6d 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -17,7 +17,6 @@ open Logic open Reduction open Tacmach open Clenv -open Proofview.Notations (* This function put casts around metavariables whose type could not be * infered by the refiner, that is head of applications, predicates and @@ -104,10 +103,10 @@ open Unification let dft = default_unify_flags let res_pf ?(with_evars=false) ?(with_classes=true) ?(flags=dft ()) clenv = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clenv = clenv_unique_resolver ~flags clenv gl in clenv_refine with_evars ~with_classes clenv - end } + end (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en particulier ne semblent pas vérifier que des instances différentes @@ -139,7 +138,7 @@ let fail_quick_unif_flags = { (* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *) let unify ?(flags=fail_quick_unif_flags) m = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Tacmach.New.pf_env gl in let n = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in let evd = clear_metas (Tacmach.New.project gl) in @@ -147,4 +146,4 @@ let unify ?(flags=fail_quick_unif_flags) m = let evd' = w_unify env evd CONV ~flags m n in Proofview.Unsafe.tclEVARSADVANCE evd' with e when CErrors.noncritical e -> Proofview.tclZERO e - end } + end diff --git a/proofs/goal.ml b/proofs/goal.ml index 5a717f166..e69ef18fd 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -8,7 +8,6 @@ open Util open Pp -open Sigma.Notations module NamedDecl = Context.Named.Declaration @@ -73,9 +72,7 @@ module V82 = struct Evd.evar_extra = extra } in let evi = Typeclasses.mark_unresolvable evi in - let evars = Sigma.Unsafe.of_evar_map evars in - let Sigma (evk, evars, _) = Evarutil.new_pure_evar_full evars evi in - let evars = Sigma.to_evar_map evars in + let (evars, evk) = Evarutil.new_pure_evar_full evars evi 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 (NamedDecl.get_id %> EConstr.mkVar) ctxt in @@ -131,9 +128,7 @@ module V82 = struct let new_evi = { evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in let new_evi = Typeclasses.mark_unresolvable new_evi in - let sigma = Sigma.Unsafe.of_evar_map Evd.empty in - let Sigma (evk, sigma, _) = Evarutil.new_pure_evar_full sigma new_evi in - let sigma = Sigma.to_evar_map sigma in + let (sigma, evk) = Evarutil.new_pure_evar_full Evd.empty new_evi in { Evd.it = evk ; sigma = sigma; } (* Used by the compatibility layer and typeclasses *) diff --git a/proofs/logic.ml b/proofs/logic.ml index cd2cfbd32..c329bdf4a 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -414,7 +414,7 @@ let rec mk_refgoals sigma goal goalacc conclty trm = | _ -> if occur_meta sigma (EConstr.of_constr trm) then - anomaly (Pp.str "refiner called with a meta in non app/case subterm"); + anomaly (Pp.str "refiner called with a meta in non app/case subterm."); let (sigma, t'ty) = goal_type_of env sigma trm in let sigma = check_conv_leq_goal env sigma trm t'ty conclty in (goalacc,t'ty,sigma, trm) @@ -474,7 +474,7 @@ and mk_hdgoals sigma goal goalacc trm = | _ -> if !check && occur_meta sigma (EConstr.of_constr trm) then - anomaly (Pp.str "refine called with a dependent meta"); + anomaly (Pp.str "refine called with a dependent meta."); let (sigma, ty) = goal_type_of env sigma trm in goalacc, ty, sigma, trm @@ -502,7 +502,7 @@ and mk_casegoals sigma goal goalacc p c = let (acc'',pt,sigma,p') = mk_hdgoals sigma goal acc' p in let ((ind, u), spec) = try Tacred.find_hnf_rectype env sigma ct - with Not_found -> anomaly (Pp.str "mk_casegoals") in + with Not_found -> anomaly (Pp.str "mk_casegoals.") in let indspec = ((ind, EConstr.EInstance.kind sigma u), spec) in let (lbrty,conclty) = type_case_branches_with_names env sigma indspec p c in (acc'',lbrty,conclty,sigma,p',c') diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index aaceb7b76..3fb66d1b8 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -113,7 +113,7 @@ let get_current_context () = let current_proof_statement () = match Proof_global.V82.get_current_initial_conclusions () with | (id,([concl],strength)) -> id,strength,concl - | _ -> CErrors.anomaly ~label:"Pfedit.current_proof_statement" (Pp.str "more than one statement") + | _ -> CErrors.anomaly ~label:"Pfedit.current_proof_statement" (Pp.str "more than one statement.") let solve ?with_end_tac gi info_lvl tac pr = try diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 4d2f534a7..5ec34a638 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -719,7 +719,7 @@ type state = pstate list let freeze ~marshallable = match marshallable with | `Yes -> - CErrors.anomaly (Pp.str"full marshalling of proof state not supported") + CErrors.anomaly (Pp.str"full marshalling of proof state not supported.") | `Shallow -> !pstates | `No -> !pstates let unfreeze s = pstates := s; update_proof_mode () diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 52bbd9ac5..22cc8cf59 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -10,26 +10,6 @@ toplevel. In particular it defines the global proof environment. *) -(** Type of proof modes : - - A name - - A function [set] to set it *from standard mode* - - A function [reset] to reset the *standard mode* from it - -*) -type proof_mode_name = string -type proof_mode = { - name : proof_mode_name ; - set : unit -> unit ; - reset : unit -> unit -} - -(** Registers a new proof mode which can then be adressed by name - in [set_default_proof_mode]. - One mode is already registered - the standard mode - named "No", - It corresponds to Coq default setting are they are set when coqtop starts. *) -val register_proof_mode : proof_mode -> unit -val get_default_proof_mode_name : unit -> proof_mode_name - val there_are_pending_proofs : unit -> bool val check_no_pending_proof : unit -> unit @@ -40,10 +20,6 @@ val discard : Names.Id.t Loc.located -> unit val discard_current : unit -> unit val discard_all : unit -> unit -(** [set_proof_mode] sets the proof mode to be used after it's called. It is - typically called by the Proof Mode command. *) -val set_proof_mode : proof_mode_name -> unit - exception NoCurrentProof val give_me_the_proof : unit -> Proof.proof (** @raise NoCurrentProof when outside proof mode. *) @@ -147,16 +123,6 @@ val get_universe_binders : unit -> universe_binders option (**********************************************************) (* *) -(* Proof modes *) -(* *) -(**********************************************************) - - -val activate_proof_mode : proof_mode_name -> unit -val disactivate_current_proof_mode : unit -> unit - -(**********************************************************) -(* *) (* Bullets *) (* *) (**********************************************************) @@ -211,3 +177,46 @@ val freeze : marshallable:[`Yes | `No | `Shallow] -> state val unfreeze : state -> unit val proof_of_state : state -> Proof.proof val copy_terminators : src:state -> tgt:state -> state + + +(**********************************************************) +(* Proof Mode API *) +(* The current Proof Mode API is deprecated and a new one *) +(* will be (hopefully) defined in 8.8 *) +(**********************************************************) + +(** Type of proof modes : + - A name + - A function [set] to set it *from standard mode* + - A function [reset] to reset the *standard mode* from it + +*) +type proof_mode_name = string +type proof_mode = { + name : proof_mode_name ; + set : unit -> unit ; + reset : unit -> unit +} + +(** Registers a new proof mode which can then be adressed by name + in [set_default_proof_mode]. + One mode is already registered - the standard mode - named "No", + It corresponds to Coq default setting are they are set when coqtop starts. *) +val register_proof_mode : proof_mode -> unit +(* Can't make this deprecated due to limitations of camlp5 *) +(* [@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] *) + +val get_default_proof_mode_name : unit -> proof_mode_name +[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] + +(** [set_proof_mode] sets the proof mode to be used after it's called. It is + typically called by the Proof Mode command. *) +val set_proof_mode : proof_mode_name -> unit +[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] + +val activate_proof_mode : proof_mode_name -> unit +[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] + +val disactivate_current_proof_mode : unit -> unit +[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] + diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 7cd526843..458dd2161 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -195,13 +195,13 @@ let decl_red_expr s e = end let out_arg = function - | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable") + | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable.") | ArgArg x -> x let out_with_occurrences (occs,c) = (Locusops.occurrences_map (List.map out_arg) occs, c) -let e_red f = { e_redfun = fun env evm c -> Sigma.here (f env (Sigma.to_evar_map evm) c) evm } +let e_red f env evm c = evm, f env evm c let head_style = false (* Turn to true to have a semantics where simpl only reduce at the head when an evaluable reference is given, e.g. diff --git a/proofs/refine.ml b/proofs/refine.ml index 63ae41075..caa6b9fb3 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -7,7 +7,6 @@ (************************************************************************) open Util -open Sigma.Notations open Proofview.Notations open Context.Named.Declaration @@ -73,7 +72,6 @@ let add_side_effects env effects = let generic_refine ?(unsafe = true) f gl = let gl = Proofview.Goal.assume gl in let sigma = Proofview.Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in (** Save the [future_goals] state to restore them after the @@ -129,19 +127,20 @@ let generic_refine ?(unsafe = true) f gl = let lift c = Proofview.tclEVARMAP >>= fun sigma -> Proofview.V82.wrap_exceptions begin fun () -> - let Sigma (c, sigma, _) = c.run (Sigma.Unsafe.of_evar_map sigma) in - Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> + let (sigma, c) = c sigma in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT c end -let make_refine_enter ?unsafe f = - { enter = fun gl -> generic_refine ?unsafe (lift f) gl } +let make_refine_enter ?unsafe f gl = generic_refine ?unsafe (lift f) gl let refine_one ?(unsafe = true) f = Proofview.Goal.enter_one (make_refine_enter ~unsafe f) let refine ?(unsafe = true) f = - let f = { run = fun sigma -> let Sigma (c,sigma,p) = f.run sigma in Sigma (((),c),sigma,p) } in + let f evd = + let (evd,c) = f evd in (evd,((), c)) + in Proofview.Goal.enter (make_refine_enter ~unsafe f) (** Useful definitions *) @@ -154,17 +153,16 @@ let with_type env evd c t = in evd , j'.Environ.uj_val -let refine_casted ?unsafe f = Proofview.Goal.enter { enter = begin fun gl -> +let refine_casted ?unsafe f = Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in - let f = { run = fun h -> - let Sigma (c, h, p) = f.run h in - let sigma, c = with_type env (Sigma.to_evar_map h) c concl in - Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) - } in + let f h = + let (h, c) = f h in + with_type env h c concl + in refine ?unsafe f -end } +end (** {7 solve_constraints} diff --git a/proofs/refine.mli b/proofs/refine.mli index 5098f246a..f1439f9a1 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -21,7 +21,7 @@ val pr_constr : (** {7 Refinement primitives} *) -val refine : ?unsafe:bool -> EConstr.t Sigma.run -> unit tactic +val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic (** In [refine ?unsafe t], [t] is a term with holes under some [evar_map] context. The term [t] is used as a partial solution for the current goal (refine is a goal-dependent tactic), the @@ -30,11 +30,11 @@ val refine : ?unsafe:bool -> EConstr.t Sigma.run -> unit tactic tactic failures. If [unsafe] is [false] (default is [true]) [t] is type-checked beforehand. *) -val refine_one : ?unsafe:bool -> ('a * EConstr.t) Sigma.run -> 'a tactic +val refine_one : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * ('a * EConstr.t)) -> 'a tactic (** A variant of [refine] which assumes exactly one goal under focus *) val generic_refine : ?unsafe:bool -> ('a * EConstr.t) tactic -> - ([ `NF ], 'r) Proofview.Goal.t -> 'a tactic + [ `NF ] Proofview.Goal.t -> 'a tactic (** The general version of refine. *) (** {7 Helper functions} *) @@ -44,7 +44,7 @@ val with_type : Environ.env -> Evd.evar_map -> (** [with_type env sigma c t] ensures that [c] is of type [t] inserting a coercion if needed. *) -val refine_casted : ?unsafe:bool -> EConstr.t Sigma.run -> unit tactic +val refine_casted : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic (** Like {!refine} except the refined term is coerced to the conclusion of the current goal. *) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 259e96a27..91e6dc4ab 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -188,8 +188,6 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) (fun hypl -> List.subtract cmp hypl oldhyps) hyps in - let emacs_str s = - if !Flags.print_emacs then s else "" in let s = let frst = ref true in List.fold_left @@ -199,9 +197,9 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) "" lh)) "" newhyps in Feedback.msg_notice - (str (emacs_str "<infoH>") + (str "<infoH>" ++ (hov 0 (str s)) - ++ (str (emacs_str "</infoH>"))); + ++ (str "</infoH>")); tclIDTAC goal;; diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 97c5cda77..f9d9f25cc 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -18,7 +18,6 @@ open Tacred open Proof_type open Logic open Refiner -open Sigma.Notations open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -75,13 +74,12 @@ let pf_get_new_ids ids gls = (fun id acc -> (next_ident_away id (acc@avoid))::acc) ids [] -let pf_global gls id = EConstr.of_constr (Constrintern.construct_reference (pf_hyps gls) id) +let pf_global gls id = EConstr.of_constr (Universes.constr_of_global (Constrintern.construct_reference (pf_hyps gls) id)) let pf_reduction_of_red_expr gls re c = let (redfun, _) = reduction_of_red_expr (pf_env gls) re in - let sigma = Sigma.Unsafe.of_evar_map (project gls) in - let Sigma (c, sigma, _) = redfun.e_redfun (pf_env gls) sigma c in - (Sigma.to_evar_map sigma, c) + let sigma = project gls in + redfun (pf_env gls) sigma c let pf_apply f gls = f (pf_env gls) (project gls) let pf_eapply f gls x = @@ -158,8 +156,7 @@ let pr_glls glls = module New = struct let project gl = - let sigma = Proofview.Goal.sigma gl in - Sigma.to_evar_map sigma + Proofview.Goal.sigma gl let pf_apply f gl = f (Proofview.Goal.env gl) (project gl) @@ -171,7 +168,7 @@ module New = struct (** We only check for the existence of an [id] in [hyps] *) let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in - EConstr.of_constr (Constrintern.construct_reference hyps id) + Constrintern.construct_reference hyps id let pf_env = Proofview.Goal.env let pf_concl = Proofview.Goal.concl @@ -216,7 +213,7 @@ module New = struct let hyps = Proofview.Goal.hyps gl in List.hd hyps - let pf_nf_concl (gl : ([ `LZ ], 'r) Proofview.Goal.t) = + let pf_nf_concl (gl : [ `LZ ] Proofview.Goal.t) = (** We normalize the conclusion just after *) let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index e6e60e27f..3d2fa72c1 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -99,47 +99,47 @@ val pr_glls : goal list sigma -> Pp.std_ppcmds (* Variants of [Tacmach] functions built with the new proof engine *) module New : sig - val pf_apply : (env -> evar_map -> 'a) -> ('b, 'r) Proofview.Goal.t -> 'a - val pf_global : identifier -> ('a, 'r) Proofview.Goal.t -> constr + val pf_apply : (env -> evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a + val pf_global : identifier -> 'a Proofview.Goal.t -> Globnames.global_reference (** FIXME: encapsulate the level in an existential type. *) - val of_old : (Proof_type.goal Evd.sigma -> 'a) -> ([ `NF ], 'r) Proofview.Goal.t -> 'a + val of_old : (Proof_type.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a - val project : ('a, 'r) Proofview.Goal.t -> Evd.evar_map - val pf_env : ('a, 'r) Proofview.Goal.t -> Environ.env - val pf_concl : ('a, 'r) Proofview.Goal.t -> types + val project : 'a Proofview.Goal.t -> Evd.evar_map + val pf_env : 'a Proofview.Goal.t -> Environ.env + val pf_concl : 'a Proofview.Goal.t -> types (** WRONG: To be avoided at all costs, it typechecks the term entirely but forgets the universe constraints necessary to retypecheck it *) - val pf_unsafe_type_of : ('a, 'r) Proofview.Goal.t -> constr -> types + val pf_unsafe_type_of : 'a Proofview.Goal.t -> constr -> types (** This function does no type inference and expects an already well-typed term. It recomputes its type in the fastest way possible (no conversion is ever involved) *) - val pf_get_type_of : ('a, 'r) Proofview.Goal.t -> constr -> types + val pf_get_type_of : 'a Proofview.Goal.t -> constr -> types (** This function entirely type-checks the term and computes its type and the implied universe constraints. *) - val pf_type_of : ('a, 'r) Proofview.Goal.t -> constr -> evar_map * types - val pf_conv_x : ('a, 'r) Proofview.Goal.t -> t -> t -> bool + val pf_type_of : 'a Proofview.Goal.t -> constr -> evar_map * types + val pf_conv_x : 'a Proofview.Goal.t -> t -> t -> bool - val pf_get_new_id : identifier -> ('a, 'r) Proofview.Goal.t -> identifier - val pf_ids_of_hyps : ('a, 'r) Proofview.Goal.t -> identifier list - val pf_hyps_types : ('a, 'r) Proofview.Goal.t -> (identifier * types) list + val pf_get_new_id : identifier -> 'a Proofview.Goal.t -> identifier + val pf_ids_of_hyps : 'a Proofview.Goal.t -> identifier list + val pf_hyps_types : 'a Proofview.Goal.t -> (identifier * types) list - val pf_get_hyp : identifier -> ('a, 'r) Proofview.Goal.t -> named_declaration - val pf_get_hyp_typ : identifier -> ('a, 'r) Proofview.Goal.t -> types - val pf_last_hyp : ('a, 'r) Proofview.Goal.t -> named_declaration + val pf_get_hyp : identifier -> 'a Proofview.Goal.t -> named_declaration + val pf_get_hyp_typ : identifier -> 'a Proofview.Goal.t -> types + val pf_last_hyp : 'a Proofview.Goal.t -> named_declaration - val pf_nf_concl : ([ `LZ ], 'r) Proofview.Goal.t -> types - val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> types -> (inductive * EInstance.t) * types + val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types + val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> (inductive * EInstance.t) * types - val pf_hnf_constr : ('a, 'r) Proofview.Goal.t -> constr -> types - val pf_hnf_type_of : ('a, 'r) Proofview.Goal.t -> constr -> types + val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types + val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types - val pf_whd_all : ('a, 'r) Proofview.Goal.t -> constr -> constr - val pf_compute : ('a, 'r) Proofview.Goal.t -> constr -> constr + val pf_whd_all : 'a Proofview.Goal.t -> constr -> constr + val pf_compute : 'a Proofview.Goal.t -> constr -> constr - val pf_matches : ('a, 'r) Proofview.Goal.t -> constr_pattern -> constr -> patvar_map + val pf_matches : 'a Proofview.Goal.t -> constr_pattern -> constr -> patvar_map - val pf_nf_evar : ('a, 'r) Proofview.Goal.t -> constr -> constr + val pf_nf_evar : 'a Proofview.Goal.t -> constr -> constr end diff --git a/stm/spawned.ml b/stm/spawned.ml index c5bd5f6f9..de19dd535 100644 --- a/stm/spawned.ml +++ b/stm/spawned.ml @@ -46,7 +46,7 @@ let control_channel = ref None let channels = ref None let init_channels () = - if !channels <> None then CErrors.anomaly(Pp.str "init_channels called twice"); + if !channels <> None then CErrors.anomaly(Pp.str "init_channels called twice."); let () = match !main_channel with | None -> () | Some (Socket(mh,mpr,mpw)) -> @@ -65,7 +65,7 @@ let init_channels () = | Some (Socket (ch, cpr, cpw)) -> controller ch cpr cpw | Some AnonPipe -> - CErrors.anomaly (Pp.str "control channel cannot be a pipe") + CErrors.anomaly (Pp.str "control channel cannot be a pipe.") let get_channels () = match !channels with diff --git a/stm/stm.ml b/stm/stm.ml index b98cb312e..a79bf5426 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -66,7 +66,7 @@ end (* During interactive use we cache more states so that Undoing is fast *) let interactive () = - if !Flags.ide_slave || !Flags.print_emacs || not !Flags.batch_mode then `Yes + if !Flags.ide_slave || not !Flags.batch_mode then `Yes else `No let async_proofs_workers_extra_env = ref [||] @@ -80,7 +80,7 @@ type aast = { } let pr_ast { expr; indentation } = Pp.(int indentation ++ str " " ++ Ppvernac.pr_vernac expr) -let default_proof_mode () = Proof_global.get_default_proof_mode_name () +let default_proof_mode () = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] (* Commands piercing opaque *) let may_pierce_opaque = function @@ -219,7 +219,7 @@ end = struct (* {{{ *) let find_proof_at_depth vcs pl = try List.find (function | _, { Vcs_.kind = `Proof(m, n) } -> Int.equal n pl - | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.str "find_proof_at_depth") + | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.str "find_proof_at_depth.") | _ -> false) (List.map (fun h -> h, Vcs_.get_branch vcs h) (Vcs_.branches vcs)) with Not_found -> failwith "find_proof_at_depth" @@ -227,9 +227,9 @@ end = struct (* {{{ *) exception Expired let visit vcs id = if Stateid.equal id Stateid.initial then - anomaly(Pp.str "Visiting the initial state id") + anomaly(Pp.str "Visiting the initial state id.") else if Stateid.equal id Stateid.dummy then - anomaly(Pp.str "Visiting the dummy state id") + anomaly(Pp.str "Visiting the dummy state id.") else try match Vcs_.Dag.from_node (Vcs_.dag vcs) id with @@ -245,7 +245,7 @@ end = struct (* {{{ *) | [n, Sideff (ReplayCommand x); p, Noop] | [p, Noop; n, Sideff (ReplayCommand x)]-> { step = `Sideff(ReplayCommand x,p); next = n } | [n, Sideff (ReplayCommand x)]-> {step = `Sideff(ReplayCommand x, Stateid.dummy); next=n} - | _ -> anomaly (Pp.str ("Malformed VCS at node "^Stateid.to_string id)) + | _ -> anomaly (Pp.str ("Malformed VCS at node "^Stateid.to_string id^".")) with Not_found -> raise Expired end (* }}} *) @@ -474,10 +474,12 @@ end = struct (* {{{ *) vcs := rewrite_merge !vcs id ~ours ~theirs:Noop ~at branch let reachable id = reachable !vcs id let mk_branch_name { expr = x } = Branch.make - (match x with + (let rec aux x = match x with | VernacDefinition (_,((_,i),_),_) -> Names.string_of_id i | VernacStartTheoremProof (_,[Some ((_,i),_),_],_) -> Names.string_of_id i - | _ -> "branch") + | VernacTime (_, e) + | VernacTimeout (_, e) -> aux e + | _ -> "branch" in aux x) let edit_branch = Branch.make "edit" let branch ?root ?pos name kind = vcs := branch !vcs ?root ?pos name kind let get_info id = @@ -500,7 +502,7 @@ end = struct (* {{{ *) if List.mem edit_branch (Vcs_.branches !vcs) then begin checkout edit_branch; match get_branch edit_branch with - | { kind = `Edit (mode, _,_,_,_) } -> Proof_global.activate_proof_mode mode + | { kind = `Edit (mode, _,_,_,_) } -> Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] | _ -> assert false end else let pl = proof_nesting () in @@ -509,10 +511,10 @@ end = struct (* {{{ *) | h, { Vcs_.kind = `Proof (m, _) } -> h, m | _ -> assert false in checkout branch; stm_prerr_endline (fun () -> "mode:" ^ mode); - Proof_global.activate_proof_mode mode + Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] with Failure _ -> checkout Branch.master; - Proof_global.disactivate_current_proof_mode () + Proof_global.disactivate_current_proof_mode () [@ocaml.warning "-3"] (* copies the transaction on every open branch *) let propagate_sideff ~action = @@ -533,7 +535,7 @@ end = struct (* {{{ *) | { next = n; step = `Sideff (ReplayCommand x,_) } -> (id,Sideff (ReplayCommand x)) :: aux n | _ -> anomaly Pp.(str("Cannot slice from "^ Stateid.to_string block_start ^ - " to "^Stateid.to_string block_stop)) + " to "^Stateid.to_string block_stop^".")) in aux block_stop let slice ~block_start ~block_stop = @@ -585,11 +587,11 @@ end = struct (* {{{ *) l let create_proof_task_box l ~qed ~block_start:lemma = - if not (topo_invariant l) then anomaly Pp.(str "overlapping boxes"); + if not (topo_invariant l) then anomaly Pp.(str "overlapping boxes."); vcs := create_property !vcs l (ProofTask { qed; lemma }) let create_proof_block ({ block_start; block_stop} as decl) name = let l = nodes_in_slice ~block_start ~block_stop in - if not (topo_invariant l) then anomaly Pp.(str "overlapping boxes"); + if not (topo_invariant l) then anomaly Pp.(str "overlapping boxes."); vcs := create_property !vcs l (ProofBlock (decl, name)) let box_of id = List.map Dag.Property.data (property_of !vcs id) let delete_boxes_of id = @@ -600,7 +602,7 @@ end = struct (* {{{ *) with | [] -> None | [x] -> Some x - | _ -> anomaly Pp.(str "node with more than 1 proof task box") + | _ -> anomaly Pp.(str "node with more than 1 proof task box.") let gc () = let old_vcs = !vcs in @@ -764,13 +766,13 @@ end = struct (* {{{ *) | _ -> (* coqc has a 1 slot cache and only for valid states *) if interactive () = `No && Stateid.equal id !cur_id then () - else anomaly Pp.(str "installing a non cached state") + else anomaly Pp.(str "installing a non cached state.") let get_cached id = try match VCS.get_info id with | { state = Valid s } -> s - | _ -> anomaly Pp.(str "not a cached state") - with VCS.Expired -> anomaly Pp.(str "not a cached state (expired)") + | _ -> anomaly Pp.(str "not a cached state.") + with VCS.Expired -> anomaly Pp.(str "not a cached state (expired).") let assign id what = if VCS.get_state id <> Empty then () else @@ -821,7 +823,7 @@ end = struct (* {{{ *) feedback ~id:id (ProcessingIn !Flags.async_proofs_worker_id); let str_id = Stateid.to_string id in if is_cached id && not redefine then - anomaly Pp.(str"defining state "++str str_id++str" twice"); + anomaly Pp.(str"defining state "++str str_id++str" twice."); try stm_prerr_endline (fun () -> "defining "^str_id^" (cache="^ if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)"); @@ -1013,7 +1015,7 @@ end = struct (* {{{ *) match info.vcs_backup with | None, _ -> anomaly Pp.(str"Backtrack.backto "++str(Stateid.to_string oid)++ - str": a state with no vcs_backup") + str": a state with no vcs_backup.") | Some vcs, _ -> VCS.restore vcs let branches_of id = @@ -1021,7 +1023,7 @@ end = struct (* {{{ *) match info.vcs_backup with | _, None -> anomaly Pp.(str"Backtrack.branches_of "++str(Stateid.to_string id)++ - str": a state with no vcs_backup") + str": a state with no vcs_backup.") | _, Some x -> x let rec fold_until f acc id = @@ -1075,7 +1077,7 @@ end = struct (* {{{ *) let id = VCS.get_branch_pos (VCS.current_branch ()) in let vcs = match (VCS.get_info id).vcs_backup with - | None, _ -> anomaly Pp.(str"Backtrack: tip with no vcs_backup") + | None, _ -> anomaly Pp.(str"Backtrack: tip with no vcs_backup.") | Some vcs, _ -> vcs in let cb, _ = try Vcs_aux.find_proof_at_depth vcs (Vcs_aux.proof_nesting vcs) @@ -1094,7 +1096,7 @@ end = struct (* {{{ *) VtStm (VtBack oid, true), VtLater | VernacBacktrack (id,_,_) | VernacBackTo id -> - VtStm (VtBack (Stateid.of_int id), not !Flags.print_emacs), VtNow + VtStm (VtBack (Stateid.of_int id), not !Flags.batch_mode), VtNow | _ -> VtUnknown, VtNow with | Not_found -> @@ -1834,11 +1836,11 @@ end = struct (* {{{ *) 1 goals in TaskQueue.join queue; let assign_tac : unit Proofview.tactic = - Proofview.(Goal.nf_enter { Goal.enter = fun g -> + Proofview.(Goal.nf_enter begin fun g -> let gid = Goal.goal g in let f = try List.assoc gid res - with Not_found -> CErrors.anomaly(str"Partac: wrong focus") in + with Not_found -> CErrors.anomaly(str"Partac: wrong focus.") in if not (Future.is_over f) then (* One has failed and cancelled the others, but not this one *) if solve then Tacticals.New.tclZEROMSG @@ -1857,7 +1859,7 @@ end = struct (* {{{ *) Tactics.exact_no_check (EConstr.of_constr pt)) with TacTask.NoProgress -> if solve then Tacticals.New.tclSOLVE [] else tclUNIT () - }) + end) in Proof.run_tactic (Global.env()) assign_tac p)))) ()) @@ -2106,12 +2108,11 @@ let known_state ?(redefine_qed=false) ~cache id = | `Leaks -> Exninfo.iraise exn | `ValidBlock { base_state; goals_to_admit; recovery_command } -> begin let tac = - let open Proofview.Notations in - Proofview.Goal.nf_enter { enter = fun gl -> + Proofview.Goal.nf_enter begin fun gl -> if CList.mem_f Evar.equal (Proofview.Goal.goal gl) goals_to_admit then Proofview.give_up else Proofview.tclUNIT () - } in + end in match (VCS.get_info base_state).state with | Valid { proof } -> Proof_global.unfreeze proof; @@ -2367,8 +2368,8 @@ let finish () = hides true bugs cf bug #5363. Also, what happens with observe? *) (* Some commands may by side effect change the proof mode *) match VCS.get_branch head with - | { VCS.kind = `Edit (mode,_,_,_,_) } -> Proof_global.activate_proof_mode mode - | { VCS.kind = `Proof (mode, _) } -> Proof_global.activate_proof_mode mode + | { VCS.kind = `Edit (mode,_,_,_,_) } -> Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] + | { VCS.kind = `Proof (mode, _) } -> Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] | _ -> () let wait () = @@ -2455,7 +2456,7 @@ let handle_failure (e, info) vcs = VCS.restore vcs; VCS.print (); anomaly(str"error with no safe_id attached:" ++ spc() ++ - CErrors.iprint_no_report (e, info)) + CErrors.iprint_no_report (e, info) ++ str".") | Some (safe_id, id) -> stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); VCS.restore vcs; @@ -2487,7 +2488,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) | VtStm (VtJoinDocument, b), VtNow -> join (); `Ok | VtStm (VtWait, b), VtNow -> finish (); wait (); `Ok | VtStm ((VtJoinDocument|VtWait),_), VtLater -> - anomaly(str"classifier: join actions cannot be classified as VtLater") + anomaly(str"classifier: join actions cannot be classified as VtLater.") (* Back *) | VtStm (VtBack oid, true), w -> @@ -2515,7 +2516,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) VCS.checkout_shallowest_proof_branch (); Reach.known_state ~cache:(interactive ()) id; `Ok | VtStm (VtBack id, false), VtLater -> - anomaly(str"classifier: VtBack + VtLater must imply part_of_script") + anomaly(str"classifier: VtBack + VtLater must imply part_of_script.") (* Query *) | VtQuery (false,(report_id,route)), VtNow -> @@ -2536,7 +2537,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) VCS.commit id (mkTransCmd x [] false queue); Backtrack.record (); if w == VtNow then finish (); `Ok | VtQuery (false,_), VtLater -> - anomaly(str"classifier: VtQuery + VtLater must imply part_of_script") + anomaly(str"classifier: VtQuery + VtLater must imply part_of_script.") (* Proof *) | VtStartProof (mode, guarantee, names), w -> @@ -2550,10 +2551,10 @@ let process_transaction ?(newtip=Stateid.fresh ()) VCS.branch bname (`Proof (mode, VCS.proof_nesting () + 1)); VCS.merge id ~ours:(Fork (x, bname, guarantee, names)) head end; - Proof_global.activate_proof_mode mode; + Proof_global.activate_proof_mode mode [@ocaml.warning "-3"]; Backtrack.record (); if w == VtNow then finish (); `Ok | VtProofMode _, VtLater -> - anomaly(str"VtProofMode must be executed VtNow") + anomaly(str"VtProofMode must be executed VtNow.") | VtProofMode mode, VtNow -> let id = VCS.new_node ~id:newtip () in VCS.commit id (mkTransCmd x [] false `MainQueue); @@ -2631,7 +2632,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) VCS.commit id (Fork (x,bname,opacity_of_produced_term x.expr,[])); let proof_mode = default_proof_mode () in VCS.branch bname (`Proof (proof_mode, VCS.proof_nesting () + 1)); - Proof_global.activate_proof_mode proof_mode; + Proof_global.activate_proof_mode proof_mode [@ocaml.warning "-3"]; end else begin VCS.commit id (mkTransCmd x [] in_proof `MainQueue); (* We hope it can be replayed, but we can't really know *) @@ -2642,7 +2643,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) Backtrack.record (); `Ok | VtUnknown, VtLater -> - anomaly(str"classifier: VtUnknown must imply VtNow") + anomaly(str"classifier: VtUnknown must imply VtNow.") end in let pr_rc rc = match rc with | `Ok -> Pp.(seq [str "newtip ("; str (Stateid.to_string (VCS.cur_tip ())); str ")"]) @@ -2781,7 +2782,7 @@ let query ~at ?(report_with=(Stateid.dummy,default_route)) s = s let edit_at id = - if Stateid.equal id Stateid.dummy then anomaly(str"edit_at dummy") else + if Stateid.equal id Stateid.dummy then anomaly(str"edit_at dummy.") else let vcs = VCS.backup () in let on_cur_branch id = let rec aux cur = @@ -2820,7 +2821,7 @@ let edit_at id = (* Hum, this should be the real start_id in the cluster and not next *) match VCS.visit qed_id with | { step = `Qed ({ fproof = Some (_,cs); keep },_) } -> start, cs, keep - | _ -> anomaly (str "ProofTask not ending with Qed") in + | _ -> anomaly (str "ProofTask not ending with Qed.") in VCS.branch ~root:master_id ~pos:id VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch)); VCS.delete_boxes_of id; @@ -2872,7 +2873,7 @@ let edit_at id = end else if is_ancestor_of_cur_branch id then begin backto id (Some bn) end else begin - anomaly(str"Cannot leave an `Edit branch open") + anomaly(str"Cannot leave an `Edit branch open.") end | true, None, _ -> if on_cur_branch id then begin @@ -2883,7 +2884,7 @@ let edit_at id = end else if is_ancestor_of_cur_branch id then begin backto id None end else begin - anomaly(str"Cannot leave an `Edit branch open") + anomaly(str"Cannot leave an `Edit branch open.") end | false, None, Some(_,bn) -> backto id (Some bn) | false, None, None -> backto id None @@ -2896,7 +2897,7 @@ let edit_at id = | None -> VCS.print (); anomaly (str ("edit_at "^Stateid.to_string id^": ") ++ - CErrors.print_no_report e) + CErrors.print_no_report e ++ str ".") | Some (_, id) -> stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); VCS.restore vcs; diff --git a/stm/tQueue.ml b/stm/tQueue.ml index a0b08778b..fee4f35b4 100644 --- a/stm/tQueue.ml +++ b/stm/tQueue.ml @@ -88,7 +88,7 @@ let broadcast { lock = m; cond = c } = let push { queue = q; lock = m; cond = c; release } x = if release then CErrors.anomaly(Pp.str - "TQueue.push while being destroyed! Only 1 producer/destroyer allowed"); + "TQueue.push while being destroyed! Only 1 producer/destroyer allowed."); Mutex.lock m; PriorityQueue.push q x; Condition.broadcast c; diff --git a/stm/vcs.ml b/stm/vcs.ml index 88f860eb6..df3b8aa62 100644 --- a/stm/vcs.ml +++ b/stm/vcs.ml @@ -113,7 +113,7 @@ let add_node vcs id edges = let get_branch vcs head = try BranchMap.find head vcs.heads - with Not_found -> anomaly (str"head " ++ str head ++ str" not found") + with Not_found -> anomaly (str"head " ++ str head ++ str" not found.") let reset_branch vcs head id = let map name h = diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index c4f392f20..471e05e45 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -10,7 +10,7 @@ open Vernacexpr open CErrors open Pp -let default_proof_mode () = Proof_global.get_default_proof_mode_name () +let default_proof_mode () = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] let string_of_in_script b = if b then " (inside script)" else "" @@ -206,7 +206,7 @@ let rec classify_vernac e = (* Plugins should classify their commands *) | VernacExtend (s,l) -> try List.assoc s !classifiers l () - with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)) + with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in let res = static_classifier e in if Flags.is_universe_polymorphism () then diff --git a/tactics/auto.ml b/tactics/auto.ml index b76c0a96a..272cb1eda 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -97,11 +97,11 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = in clenv, c let unify_resolve poly flags ((c : raw_hint), clenv) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clenv, c = connect_hint_clenv poly c clenv gl in let clenv = clenv_unique_resolver ~flags clenv gl in Clenvtac.clenv_refine false clenv - end } + end let unify_resolve_nodelta poly h = unify_resolve poly auto_unif_flags h @@ -110,12 +110,12 @@ let unify_resolve_gen poly = function | Some flags -> unify_resolve poly flags let exact poly (c,clenv) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (exact_check c) - end } + end (* Util *) @@ -139,9 +139,9 @@ let conclPattern concl pat tac = try Proofview.tclUNIT (Constr_matching.matches env sigma pat concl) with Constr_matching.PatternMatchingFailure -> - Tacticals.New.tclZEROMSG (str "conclPattern") + Tacticals.New.tclZEROMSG (str "pattern-matching failed") in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in constr_bindings env sigma >>= fun constr_bindings -> @@ -157,7 +157,7 @@ let conclPattern concl pat tac = match tac with | GenArg (Glbwit wit, tac) -> Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) - end } + end (***********************************************************) (** A debugging / verbosity framework for trivial and auto *) @@ -313,7 +313,7 @@ let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption let rec trivial_fail_db dbg mod_delta db_list local_db = let intro_tac = Tacticals.New.tclTHEN (dbg_intro dbg) - ( Proofview.Goal.enter { enter = begin fun gl -> + ( Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let nf c = Evarutil.nf_evar sigma c in @@ -322,9 +322,9 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = let hintl = make_resolve_hyp env sigma hyp in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list env sigma hintl local_db) - end }) + end) in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in @@ -332,7 +332,7 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = ((dbg_assumption dbg)::intro_tac:: (List.map Tacticals.New.tclCOMPLETE (trivial_resolve sigma dbg mod_delta db_list local_db secvars concl))) - end } + end and my_find_search_nodelta sigma db_list local_db secvars hdc concl = List.map (fun hint -> (None,hint)) @@ -375,7 +375,7 @@ and my_find_search_delta sigma db_list local_db secvars hdc concl = and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=dbname})) = let tactic = function | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl) - | ERes_pf _ -> Proofview.Goal.enter { enter = fun gl -> Tacticals.New.tclZEROMSG (str "eres_pf") } + | ERes_pf _ -> Proofview.Goal.enter (fun gl -> Tacticals.New.tclZEROMSG (str "eres_pf")) | Give_exact (c, cl) -> exact poly (c, cl) | Res_pf_THEN_trivial_fail (c,cl) -> Tacticals.New.tclTHEN @@ -384,11 +384,11 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= with "debug auto" we don't display the details of inner trivial *) (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db) | Unfold_nth c -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> if exists_evaluable_reference (Tacmach.New.pf_env gl) c then Tacticals.New.tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) else Tacticals.New.tclFAIL 0 (str"Unbound reference") - end } + end | Extern tacast -> conclPattern concl p tacast in @@ -417,7 +417,7 @@ and trivial_resolve sigma dbg mod_delta db_list local_db secvars cl = "nocore" amongst the databases. *) let trivial ?(debug=Off) lems dbnames = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in @@ -425,10 +425,10 @@ let trivial ?(debug=Off) lems dbnames = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (trivial_fail_db d false db_list hints) - end } + end let full_trivial ?(debug=Off) lems = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in @@ -436,7 +436,7 @@ let full_trivial ?(debug=Off) lems = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (trivial_fail_db d false db_list hints) - end } + end let gen_trivial ?(debug=Off) lems = function | None -> full_trivial ~debug lems @@ -469,10 +469,10 @@ let extend_local_db decl db gl = let intro_register dbg kont db = Tacticals.New.tclTHEN (dbg_intro dbg) - (Proofview.Goal.enter { enter = begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let extend_local_db decl db = extend_local_db decl db gl in Tacticals.New.onLastDecl (fun decl -> kont (extend_local_db decl db)) - end }) + end) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) @@ -485,7 +485,7 @@ let search d n mod_delta db_list local_db = if Int.equal n 0 then Tacticals.New.tclZEROMSG (str"BOUND 2") else Tacticals.New.tclORELSE0 (dbg_assumption d) (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) - ( Proofview.Goal.enter { enter = begin fun gl -> + ( Proofview.Goal.enter begin fun gl -> let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in @@ -494,7 +494,7 @@ let search d n mod_delta db_list local_db = (List.map (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) (possible_resolve sigma d mod_delta db_list local_db secvars concl)) - end })) + end)) end [] in search d n local_db @@ -502,7 +502,7 @@ let search d n mod_delta db_list local_db = let default_search_depth = ref 5 let delta_auto debug mod_delta n lems dbnames = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in @@ -510,7 +510,7 @@ let delta_auto debug mod_delta n lems dbnames = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (search d n mod_delta db_list hints) - end } + end let delta_auto = if Flags.profile then @@ -525,7 +525,7 @@ let new_auto ?(debug=Off) n = delta_auto debug true n let default_auto = auto !default_search_depth [] [] let delta_full_auto ?(debug=Off) mod_delta n lems = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in @@ -533,7 +533,7 @@ let delta_full_auto ?(debug=Off) mod_delta n lems = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (search d n mod_delta db_list hints) - end } + end let full_auto ?(debug=Off) n = delta_full_auto ~debug false n let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n diff --git a/tactics/auto.mli b/tactics/auto.mli index 9ed9f0ae2..a6fb82bab 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -16,14 +16,14 @@ open Decl_kinds open Hints open Tactypes -val compute_secvars : ('a,'b) Proofview.Goal.t -> Id.Pred.t +val compute_secvars : 'a Proofview.Goal.t -> Id.Pred.t val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> - ('a, 'r) Proofview.Goal.t -> clausenv * constr + 'a Proofview.Goal.t -> clausenv * constr (** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index de544fe5f..2d4f20276 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -15,7 +15,6 @@ open CErrors open Util open Mod_subst open Locus -open Proofview.Notations (* Rewriting rules *) type rew_rule = { rew_lemma: constr; @@ -90,15 +89,14 @@ type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_gen let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in let try_rewrite dir ctx c tc = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c in - let sigma = Sigma.to_evar_map sigma in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in - let tac = general_rewrite_maybe_in dir c' tc in - Sigma.Unsafe.of_pair (tac, sigma) - end } in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (general_rewrite_maybe_in dir c' tc) + end in let lrul = List.map (fun h -> let tac = match h.rew_tac with | None -> Proofview.tclUNIT () @@ -125,7 +123,7 @@ let autorewrite ?(conds=Naive) tac_main lbas = (Proofview.tclUNIT()) lbas)) let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (* let's check at once if id exists (to raise the appropriate error) *) let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in let general_rewrite_in id dir cstr tac = @@ -137,7 +135,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = (List.fold_left (fun tac bas -> Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas))) idl - end } + end let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] @@ -162,10 +160,10 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = | None -> (* try to rewrite in all hypothesis (except maybe the rewritten one) *) - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let ids = Tacmach.New.pf_ids_of_hyps gl in try_do_hyps (fun id -> id) ids - end }) + end) let auto_multi_rewrite ?(conds=Naive) lems cl = Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 46d66b9d0..de49a521f 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -211,7 +211,7 @@ let auto_unif_flags freeze st = let e_give_exact flags poly (c,clenv) = let open Tacmach.New in - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let (c, _, _) = c in let c, sigma = @@ -223,28 +223,34 @@ let e_give_exact flags poly (c,clenv) = else c, sigma in let (sigma, t1) = Typing.type_of (pf_env gl) sigma c in - Sigma.Unsafe.of_pair (Clenvtac.unify ~flags t1 <*> exact_no_check c, sigma) - end } - -let unify_e_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> + Proofview.Unsafe.tclEVARS sigma <*> + Clenvtac.unify ~flags t1 <*> exact_no_check c + end + +let clenv_unique_resolver_tac with_evars ~flags clenv' = + Proofview.Goal.enter begin fun gls -> + let resolve = + try Proofview.tclUNIT (clenv_unique_resolver ~flags clenv' gls) + with e -> Proofview.tclZERO e + in resolve >>= fun clenv' -> + Clenvtac.clenv_refine with_evars ~with_classes:false clenv' + end + +let unify_e_resolve poly flags = begin fun gls (c,_,clenv) -> let clenv', c = connect_hint_clenv poly c clenv gls in - let clenv' = clenv_unique_resolver ~flags clenv' gls in - Clenvtac.clenv_refine true ~with_classes:false clenv' - end } + clenv_unique_resolver_tac true ~flags clenv' end -let unify_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> +let unify_resolve poly flags = begin fun gls (c,_,clenv) -> let clenv', _ = connect_hint_clenv poly c clenv gls in - let clenv' = clenv_unique_resolver ~flags clenv' gls in - Clenvtac.clenv_refine false ~with_classes:false clenv' - end } + clenv_unique_resolver_tac false ~flags clenv' + end (** Application of a lemma using [refine] instead of the old [w_unify] *) let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = let open Clenv in let env = Proofview.Goal.env gls in let concl = Proofview.Goal.concl gls in - Refine.refine ~unsafe:true { Sigma.run = fun sigma -> - let sigma = Sigma.to_evar_map sigma in + Refine.refine ~unsafe:true begin fun sigma -> let sigma, term, ty = if poly then let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in @@ -260,7 +266,7 @@ let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = let sigma' = Evarconv.the_conv_x_leq env ~ts:flags.core_unify_flags.modulo_delta cl.cl_concl concl sigma' - in Sigma.here term (Sigma.Unsafe.of_evar_map sigma') } + in (sigma', term) end let unify_resolve_refine poly flags gl clenv = Proofview.tclORELSE @@ -291,32 +297,31 @@ let clenv_of_prods poly nprods (c, clenv) gl = let with_prods nprods poly (c, clenv) f = if get_typeclasses_limit_intros () then - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> try match clenv_of_prods poly nprods (c, clenv) gl with | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") - | Some (diff, clenv') -> f.enter gl (c, diff, clenv') + | Some (diff, clenv') -> f gl (c, diff, clenv') with e when CErrors.noncritical e -> - Tacticals.New.tclZEROMSG (CErrors.print e) end } + Tacticals.New.tclZEROMSG (CErrors.print e) end else Proofview.Goal.enter - { enter = begin fun gl -> - if Int.equal nprods 0 then f.enter gl (c, None, clenv) - else Tacticals.New.tclZEROMSG (str"Not enough premisses") end } + begin fun gl -> + if Int.equal nprods 0 then f gl (c, None, clenv) + else Tacticals.New.tclZEROMSG (str"Not enough premisses") end let matches_pattern concl pat = let matches env sigma = match pat with | None -> Proofview.tclUNIT () | Some pat -> - let sigma = Sigma.to_evar_map sigma in if Constr_matching.is_matching env sigma pat concl then Proofview.tclUNIT () else Tacticals.New.tclZEROMSG (str "pattern does not match") in - Proofview.Goal.enter { enter = fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - matches env sigma } + matches env sigma end (** Semantics of type class resolution lemma application: @@ -357,7 +362,7 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = let open Tacticals.New in let open Tacmach.New in let trivial_fail = - Proofview.Goal.enter { enter = + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -365,15 +370,15 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = let hintl = make_resolve_hyp env sigma d in let hints = Hint_db.add_list env sigma hintl local_db in e_trivial_fail_db only_classes db_list hints secvars - end } + end in let trivial_resolve = - Proofview.Goal.enter { enter = + Proofview.Goal.enter begin fun gl -> let tacs = e_trivial_resolve db_list local_db secvars only_classes (project gl) (pf_concl gl) in tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs) - end} + end in let tacl = Eauto.registered_e_assumption :: @@ -412,9 +417,9 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co if get_typeclasses_filtered_unification () then let tac = with_prods nprods poly (term,cl) - ({ enter = fun gl clenv -> + (fun gl clenv -> matches_pattern concl p <*> - unify_resolve_refine poly flags gl clenv}) + unify_resolve_refine poly flags gl clenv) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = @@ -427,9 +432,9 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co | ERes_pf (term,cl) -> if get_typeclasses_filtered_unification () then let tac = (with_prods nprods poly (term,cl) - ({ enter = fun gl clenv -> + (fun gl clenv -> matches_pattern concl p <*> - unify_resolve_refine poly flags gl clenv})) in + unify_resolve_refine poly flags gl clenv)) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = @@ -444,7 +449,7 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co let tac = matches_pattern concl p <*> Proofview.Goal.nf_enter - { enter = fun gl -> unify_resolve_refine poly flags gl (c,None,clenv) } in + (fun gl -> unify_resolve_refine poly flags gl (c,None,clenv)) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else e_give_exact flags poly (c,clenv) @@ -691,7 +696,7 @@ module V85 = struct let merge_failures x y = match x, y with | _, ReachedLimit - | ReachedLimit, _ -> ReachedLimit + | ReachedLimit, _ -> ReachedLimit | NotApplicable, NotApplicable -> NotApplicable let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = @@ -1004,9 +1009,9 @@ module Search = struct (** In the proof engine failures are represented as exceptions *) exception ReachedLimitEx - exception NotApplicableEx + exception NoApplicableEx - (** ReachedLimitEx has priority over NotApplicableEx to handle + (** ReachedLimitEx has priority over NoApplicableEx to handle iterative deepening: it should fail when no hints are applicable, but go to a deeper depth otherwise. *) let merge_exceptions e e' = @@ -1033,16 +1038,16 @@ module Search = struct sigma goals let fail_if_nonclass info = - Proofview.Goal.enter { enter = fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in if is_class_type sigma (Proofview.Goal.concl gl) then Proofview.tclUNIT () else (if !typeclasses_debug > 1 then Feedback.msg_debug (pr_depth info.search_depth ++ str": failure due to non-class subgoal " ++ pr_ev sigma (Proofview.Goal.goal gl)); - Proofview.tclZERO NotApplicableEx) } + Proofview.tclZERO NoApplicableEx) end (** The general hint application tactic. tac1 + tac2 .... The choice of OR or ORELSE is determined @@ -1054,18 +1059,17 @@ module Search = struct let env = Goal.env gl in let concl = Goal.concl gl in let sigma = Goal.sigma gl in - let s = Sigma.to_evar_map sigma in - let unique = not info.search_dep || is_unique env s concl in - let backtrack = needs_backtrack env s unique concl in + let unique = not info.search_dep || is_unique env sigma concl in + let backtrack = needs_backtrack env sigma unique concl in if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.search_depth ++ str": looking for " ++ - Printer.pr_econstr_env (Goal.env gl) s concl ++ + Printer.pr_econstr_env (Goal.env gl) sigma concl ++ (if backtrack then str" with backtracking" else str" without backtracking")); let secvars = compute_secvars gl in let poss = - e_possible_resolve hints info.search_hints secvars info.search_only_classes s concl in + e_possible_resolve hints info.search_hints secvars info.search_only_classes sigma concl in (* If no goal depends on the solution of this one or the instances are irrelevant/assumed to be unique, then we don't need to backtrack, as long as no evar appears in the goal @@ -1078,25 +1082,34 @@ module Search = struct let derivs = path_derivate info.search_cut name in let pr_error ie = if !typeclasses_debug > 1 then - let msg = - pr_depth (!idx :: info.search_depth) ++ str": " ++ + let idx = if fst ie == NoApplicableEx then pred !idx else !idx in + let header = + pr_depth (idx :: info.search_depth) ++ str": " ++ Lazy.force pp ++ (if !foundone != true then - str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal (Proofview.Goal.assume gl)) + str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal (Proofview.Goal.assume gl)) else mt ()) in - Feedback.msg_debug (msg ++ str " failed with " ++ CErrors.iprint ie) + let msg = + match fst ie with + | Pretype_errors.PretypeError (env, evd, Pretype_errors.CannotUnify (x,y,_)) -> + str"Cannot unify " ++ print_constr_env env evd x ++ str" and " ++ + print_constr_env env evd y + | ReachedLimitEx -> str "Proof-search reached its limit." + | NoApplicableEx -> str "Proof-search failed." + | e -> CErrors.iprint ie + in + Feedback.msg_debug (header ++ str " failed with: " ++ msg) else () in - let tac_of gls i j = Goal.enter { enter = fun gl' -> + let tac_of gls i j = Goal.enter begin fun gl' -> let sigma' = Goal.sigma gl' in - let s' = Sigma.to_evar_map sigma' in let _concl = Goal.concl gl' in if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth (succ j :: i :: info.search_depth) ++ str" : " ++ - pr_ev s' (Proofview.Goal.goal (Proofview.Goal.assume gl'))); - let eq c1 c2 = EConstr.eq_constr s' c1 c2 in + pr_ev sigma' (Proofview.Goal.goal (Proofview.Goal.assume gl'))); + let eq c1 c2 = EConstr.eq_constr sigma' c1 c2 in let hints' = if b && not (Context.Named.equal eq (Goal.hyps gl') (Goal.hyps gl)) then @@ -1104,7 +1117,7 @@ module Search = struct make_autogoal_hints info.search_only_classes ~st gl' else info.search_hints in - let dep' = info.search_dep || Proofview.unifiable s' (Goal.goal (Proofview.Goal.assume gl')) gls in + let dep' = info.search_dep || Proofview.unifiable sigma' (Goal.goal (Proofview.Goal.assume gl')) gls in let info' = { search_depth = succ j :: i :: info.search_depth; last_tac = pp; @@ -1112,7 +1125,7 @@ module Search = struct search_only_classes = info.search_only_classes; search_hints = hints'; search_cut = derivs } - in kont info' } + in kont info' end in let rec result (shelf, ()) i k = foundone := true; @@ -1121,7 +1134,7 @@ module Search = struct (if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth (i :: info.search_depth) ++ str": " ++ Lazy.force pp - ++ str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal (Proofview.Goal.assume gl)) + ++ str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal (Proofview.Goal.assume gl)) ++ str", " ++ int j ++ str" subgoal(s)" ++ (Option.cata (fun k -> str " in addition to the first " ++ int k) (mt()) k))); @@ -1191,30 +1204,29 @@ module Search = struct if !foundone == false && !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.search_depth ++ str": no match for " ++ - Printer.pr_econstr_env (Goal.env gl) s concl ++ + Printer.pr_econstr_env (Goal.env gl) sigma concl ++ str ", " ++ int (List.length poss) ++ str" possibilities"); match e with | (ReachedLimitEx,ie) -> Proofview.tclZERO ~info:ie ReachedLimitEx - | (_,ie) -> Proofview.tclZERO ~info:ie NotApplicableEx + | (_,ie) -> Proofview.tclZERO ~info:ie NoApplicableEx in - if backtrack then aux (NotApplicableEx,Exninfo.null) poss - else tclONCE (aux (NotApplicableEx,Exninfo.null) poss) + if backtrack then aux (NoApplicableEx,Exninfo.null) poss + else tclONCE (aux (NoApplicableEx,Exninfo.null) poss) let hints_tac hints info kont : unit Proofview.tactic = Proofview.Goal.enter - { enter = fun gl -> hints_tac_gl hints info kont gl } + (fun gl -> hints_tac_gl hints info kont gl) let intro_tac info kont gl = let open Proofview in let env = Goal.env gl in let sigma = Goal.sigma gl in - let s = Sigma.to_evar_map sigma in let decl = Tacmach.New.pf_last_hyp gl in let hint = - make_resolve_hyp env s (Hint_db.transparent_state info.search_hints) + make_resolve_hyp env sigma (Hint_db.transparent_state info.search_hints) (true,false,false) info.search_only_classes empty_hint_info decl in - let ldb = Hint_db.add_list env s hint info.search_hints in + let ldb = Hint_db.add_list env sigma hint info.search_hints in let info' = { info with search_hints = ldb; last_tac = lazy (str"intro"); search_depth = 1 :: 1 :: info.search_depth } @@ -1222,7 +1234,7 @@ module Search = struct let intro info kont = Proofview.tclBIND Tactics.intro - (fun _ -> Proofview.Goal.enter { enter = fun gl -> intro_tac info kont gl }) + (fun _ -> Proofview.Goal.enter (fun gl -> intro_tac info kont gl)) let rec search_tac hints limit depth = let kont info = @@ -1255,8 +1267,8 @@ module Search = struct let open Proofview in let tac sigma gls i = Goal.enter - { enter = fun gl -> - search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl } + begin fun gl -> + search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl end in Proofview.Unsafe.tclGETGOALS >>= fun gls -> Proofview.tclEVARMAP >>= fun sigma -> @@ -1303,7 +1315,7 @@ module Search = struct match e with | ReachedLimitEx -> Tacticals.New.tclFAIL 0 (str"Proof search reached its limit") - | NotApplicableEx -> + | NoApplicableEx -> Tacticals.New.tclFAIL 0 (str"Proof search failed" ++ (if Option.is_empty depth then mt() else str" without reaching its limit")) @@ -1611,13 +1623,13 @@ let is_ground c = let autoapply c i = let open Proofview.Notations in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let flags = auto_unif_flags Evar.Set.empty (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in let cty = Tacmach.New.pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - (unify_e_resolve false flags).enter gl + unify_e_resolve false flags gl ((c,cty,Univ.ContextSet.empty),0,ce) <*> Proofview.tclEVARMAP >>= (fun sigma -> let sigma = Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals sigma in - Proofview.Unsafe.tclEVARS sigma) end } + Proofview.Unsafe.tclEVARS sigma) end diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index fe44559ed..83c2be410 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -19,27 +19,26 @@ module NamedDecl = Context.Named.Declaration (* Absurd *) -let mk_absurd_proof t = - let build_coq_not () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_not ()) in +let mk_absurd_proof coq_not t = let id = Namegen.default_dependent_ident in - mkLambda (Names.Name id,mkApp(build_coq_not (),[|t|]), + mkLambda (Names.Name id,mkApp(coq_not,[|t|]), mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) let absurd c = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map sigma in let j = Retyping.get_judgment_of env sigma c in let sigma, j = Coercion.inh_coerce_to_sort env sigma j in let t = j.Environ.utj_val in - let tac = + Proofview.Unsafe.tclEVARS sigma <*> + Tacticals.New.pf_constr_of_global (build_coq_not ()) >>= fun coqnot -> + Tacticals.New.pf_constr_of_global (build_coq_False ()) >>= fun coqfalse -> Tacticals.New.tclTHENLIST [ - elim_type (EConstr.of_constr (Universes.constr_of_global @@ build_coq_False ())); - Simple.apply (mk_absurd_proof t) - ] in - Sigma.Unsafe.of_pair (tac, sigma) - end } + elim_type coqfalse; + Simple.apply (mk_absurd_proof coqnot t) + ] + end let absurd c = absurd c @@ -53,13 +52,13 @@ let filter_hyp f tac = | [] -> Proofview.tclZERO Not_found | d::rest when f (NamedDecl.get_type d) -> tac (NamedDecl.get_id d) | _::rest -> seek rest in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in seek hyps - end } + end let contradiction_context = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let rec seek_neg l = match l with @@ -88,11 +87,11 @@ let contradiction_context = | None -> Tacticals.New.tclZEROMSG (Pp.str"Not a negated unit type.")) (Proofview.tclORELSE - (Proofview.Goal.enter { enter = begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in filter_hyp (fun typ -> is_conv_leq typ t) (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) - end }) + end) begin function (e, info) -> match e with | Not_found -> seek_neg rest | e -> Proofview.tclZERO ~info e @@ -101,7 +100,7 @@ let contradiction_context = in let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in seek_neg hyps - end } + end let is_negation_of env sigma typ t = match EConstr.kind sigma (whd_all env sigma t) with @@ -110,7 +109,7 @@ let is_negation_of env sigma typ t = | _ -> false let contradiction_term (c,lbind as cl) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in @@ -133,7 +132,7 @@ let contradiction_term (c,lbind as cl) = | Not_found -> Tacticals.New.tclZEROMSG (Pp.str"Not a contradiction.") | e -> Proofview.tclZERO ~info e end - end } + end let contradiction = function | None -> Tacticals.New.tclTHEN intros contradiction_context diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 986f53139..bae334461 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -30,27 +30,27 @@ open Proofview.Notations let eauto_unif_flags = auto_flags_of_state full_transparent_state let e_give_exact ?(flags=eauto_unif_flags) c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let t1 = Tacmach.New.pf_unsafe_type_of gl c in let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in let sigma = Tacmach.New.project gl in if occur_existential sigma t1 || occur_existential sigma t2 then Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) else exact_check c - end } + end let assumption id = e_give_exact (mkVar id) let e_assumption = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl)) - end } + end let registered_e_assumption = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) (Tacmach.New.pf_ids_of_hyps gl)) - end } + end (************************************************************************) (* PROLOG tactic *) @@ -93,7 +93,7 @@ let out_term = function let prolog_tac l n = Proofview.V82.tactic begin fun gl -> let map c = - let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in + let (sigma, c) = c (pf_env gl) (project gl) in let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in out_term c in @@ -112,13 +112,13 @@ open Auto let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) let unify_e_resolve poly flags (c,clenv) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in let clenv' = clenv_unique_resolver ~flags clenv' gl in Proofview.tclTHEN (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (Tactics.Simple.eapply c) - end } + end let hintmap_of sigma secvars hdc concl = match hdc with @@ -130,20 +130,20 @@ let hintmap_of sigma secvars hdc concl = (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) let e_exact poly flags (c,clenv) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (e_give_exact c) - end } + end let rec e_trivial_fail_db db_list local_db = - let next = Proofview.Goal.enter { enter = begin fun gl -> + let next = Proofview.Goal.enter begin fun gl -> let d = Tacmach.New.pf_last_hyp gl in let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) - end } in - Proofview.Goal.enter { enter = begin fun gl -> + end in + Proofview.Goal.enter begin fun gl -> let secvars = compute_secvars gl in let tacl = registered_e_assumption :: @@ -151,7 +151,7 @@ let rec e_trivial_fail_db db_list local_db = (List.map fst (e_trivial_resolve (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_concl gl))) in Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) - end } + end and e_my_find_search sigma db_list local_db secvars hdc concl = let hint_of_db = hintmap_of sigma secvars hdc concl in @@ -497,7 +497,7 @@ let unfold_head env sigma (ids, csts) c = in aux c let autounfold_one db cl = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -517,4 +517,4 @@ let autounfold_one db cl = | Some hyp -> change_in_hyp None (make_change_arg c') hyp | None -> convert_concl_no_check c' DEFAULTcast else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") - end } + end diff --git a/tactics/elim.ml b/tactics/elim.ml index 855cb206f..13d64b8e3 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -77,7 +77,7 @@ let tmphyp_name = Id.of_string "_TmpHyp" let up_to_delta = ref false (* true *) let general_decompose recognizer c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of = pf_unsafe_type_of gl in let sigma = project gl in let typc = type_of c in @@ -87,7 +87,7 @@ let general_decompose recognizer c = (ifOnHyp (recognizer sigma) (general_decompose_aux (recognizer sigma)) (fun id -> clear [id]))); exact_no_check c ] - end } + end let head_in indl t gl = let env = Proofview.Goal.env gl in @@ -101,10 +101,10 @@ let head_in indl t gl = with Not_found -> false let decompose_these c l = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let indl = List.map (fun x -> x, Univ.Instance.empty) l in general_decompose (fun sigma (_,t) -> head_in indl t gl) c - end } + end let decompose_and c = general_decompose @@ -132,7 +132,7 @@ let induction_trailer abs_i abs_j bargs = (tclDO (abs_j - abs_i) intro) (onLastHypId (fun id -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let idty = pf_unsafe_type_of gl (mkVar id) in let fvty = global_vars (pf_env gl) (project gl) idty in let possible_bring_hyps = @@ -150,11 +150,11 @@ let induction_trailer abs_i abs_j bargs = let ids = List.rev (ids_of_named_context hyps) in (tclTHENLIST [revert ids; simple_elimination (mkVar id)]) - end } + end )) let double_ind h1 h2 = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let abs_i = depth_of_quantified_hypothesis true h1 gl in let abs_j = depth_of_quantified_hypothesis true h2 gl in let abs = @@ -167,7 +167,7 @@ let double_ind h1 h2 = (fun id -> elimination_then (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id)))) - end } + end let h_double_induction = double_ind diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 93073fdc7..466b1350d 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -18,7 +18,6 @@ open Indrec open Declarations open Typeops open Ind_tables -open Sigma.Notations (* Induction/recursion schemes *) @@ -109,10 +108,10 @@ let rec_dep_scheme_kind_from_type = let build_case_analysis_scheme_in_type dep sort ind = let env = Global.env () in - let sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in - let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in - let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep sort in - c, Evd.evar_universe_context (Sigma.to_evar_map sigma) + let sigma = Evd.from_env env in + let (sigma, indu) = Evd.fresh_inductive_instance env sigma ind in + let (sigma, c) = build_case_analysis_scheme env sigma indu dep sort in + c, Evd.evar_universe_context sigma let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index bda25d7f0..0cee4b6ed 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -23,7 +23,6 @@ open Tacticals.New open Auto open Constr_matching open Misctypes -open Tactypes open Hipattern open Proofview.Notations open Tacmach.New @@ -66,22 +65,20 @@ let choose_noteq eqonleft = else left_with_bindings false Misctypes.NoBindings -open Sigma.Notations - (* A surgical generalize which selects the right occurrences by hand *) (* This prevents issues where c2 is also a subterm of c1 (see e.g. #5449) *) let generalize_right mk typ c1 c2 = - Proofview.Goal.enter { Proofview.Goal.enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in - Refine.refine ~unsafe:true { Sigma.run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> let na = Name (next_name_away_with_default "x" Anonymous (Termops.ids_of_context env)) in let newconcl = mkProd (na, typ, mk typ c1 (mkRel 1)) in - let Sigma (x, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newconcl in - Sigma (mkApp (x, [|c2|]), sigma, p) - end } - end } + let (sigma, x) = Evarutil.new_evar env sigma ~principal:true ~store newconcl in + (sigma, mkApp (x, [|c2|])) + end + end let mkBranches (eqonleft,mk,c1,c2,typ) = tclTHENLIST @@ -93,7 +90,7 @@ let mkBranches (eqonleft,mk,c1,c2,typ) = intros] let discrHyp id = - let c = { delayed = fun env sigma -> Sigma.here (mkVar id, NoBindings) sigma } in + let c env sigma = (sigma, (mkVar id, NoBindings)) in let tac c = Equality.discr_tac false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -104,14 +101,9 @@ let solveNoteqBranch side = (* Constructs the type {c1=c2}+{~c1=c2} *) -let make_eq () = -(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) -let build_coq_not () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_not ()) -let build_coq_sumbool () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_sumbool ()) - -let mkDecideEqGoal eqonleft op rectype c1 c2 = - let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in - let disequality = mkApp(build_coq_not (), [|equality|]) in +let mkDecideEqGoal eqonleft (op,eq,neg) rectype c1 c2 = + let equality = mkApp(eq, [|rectype; c1; c2|]) in + let disequality = mkApp(neg, [|equality|]) in if eqonleft then mkApp(op, [|equality; disequality |]) else mkApp(op, [|disequality; equality |]) @@ -121,13 +113,13 @@ let mkDecideEqGoal eqonleft op rectype c1 c2 = let idx = Id.of_string "x" let idy = Id.of_string "y" -let mkGenDecideEqGoal rectype g = +let mkGenDecideEqGoal rectype ops g = let hypnames = pf_ids_of_hyps g in let xname = next_ident_away idx hypnames and yname = next_ident_away idy hypnames in (mkNamedProd xname rectype (mkNamedProd yname rectype - (mkDecideEqGoal true (build_coq_sumbool ()) + (mkDecideEqGoal true ops rectype (mkVar xname) (mkVar yname)))) let rec rewrite_and_clear hyps = match hyps with @@ -143,7 +135,7 @@ let eqCase tac = tclTHEN intro (onLastHypId tac) let injHyp id = - let c = { delayed = fun env sigma -> Sigma.here (mkVar id, NoBindings) sigma } in + let c env sigma = (sigma, (mkVar id, NoBindings)) in let tac c = Equality.injClause None false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -194,7 +186,7 @@ let rec solveArg hyps eqonleft mk largs rargs = match largs, rargs with intros_reflexivity; ] | a1 :: largs, a2 :: rargs -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let rectype = pf_unsafe_type_of gl a1 in let decide = mk rectype a1 a2 in let tac hyp = solveArg (hyp :: hyps) eqonleft mk largs rargs in @@ -202,13 +194,13 @@ let rec solveArg hyps eqonleft mk largs rargs = match largs, rargs with if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] else [diseqCase hyps eqonleft;eqCase tac;default_auto] in (tclTHENS (elim_type decide) subtacs) - end } + end | _ -> invalid_arg "List.fold_right2" let solveEqBranch rectype = Proofview.tclORELSE begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = pf_concl gl in let sigma = project gl in match_eqdec sigma concl >>= fun (eqonleft,mk,lhs,rhs,_) -> @@ -217,8 +209,9 @@ let solveEqBranch rectype = let getargs l = List.skipn nparams (snd (decompose_app sigma l)) in let rargs = getargs rhs and largs = getargs lhs in + solveArg [] eqonleft mk largs rargs - end } + end end begin function (e, info) -> match e with | PatternMatchingFailure -> Tacticals.New.tclZEROMSG (Pp.str"Unexpected conclusion!") @@ -234,7 +227,7 @@ let hd_app sigma c = match EConstr.kind sigma c with let decideGralEquality = Proofview.tclORELSE begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = pf_concl gl in let sigma = project gl in match_eqdec sigma concl >>= fun (eqonleft,mk,c1,c2,typ as data) -> @@ -246,7 +239,7 @@ let decideGralEquality = (tclTHEN (mkBranches data) (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype))) - end } + end end begin function (e, info) -> match e with | PatternMatchingFailure -> @@ -256,21 +249,25 @@ let decideGralEquality = let decideEqualityGoal = tclTHEN intros decideGralEquality -let decideEquality rectype = - Proofview.Goal.enter { enter = begin fun gl -> - let decide = mkGenDecideEqGoal rectype gl in +let decideEquality rectype ops = + Proofview.Goal.enter begin fun gl -> + let decide = mkGenDecideEqGoal rectype ops gl in (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) - end } + end (* The tactic Compare *) let compare c1 c2 = - Proofview.Goal.enter { enter = begin fun gl -> + pf_constr_of_global (build_coq_sumbool ()) >>= fun opc -> + pf_constr_of_global (Coqlib.build_coq_eq ()) >>= fun eqc -> + pf_constr_of_global (build_coq_not ()) >>= fun notc -> + Proofview.Goal.enter begin fun gl -> let rectype = pf_unsafe_type_of gl c1 in - let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in + let ops = (opc,eqc,notc) in + let decide = mkDecideEqGoal true ops rectype c1 c2 in (tclTHENS (cut decide) [(tclTHEN intro (tclTHEN (onLastHyp simplest_case) clear_last)); - decideEquality rectype]) - end } + decideEquality rectype ops]) + end diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index bcd31cb7e..efcefcf16 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -57,7 +57,6 @@ open Namegen open Inductiveops open Ind_tables open Indrec -open Sigma.Notations open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration @@ -632,7 +631,7 @@ let fix_r2l_forward_rew_scheme (c, ctx') = (EConstr.of_constr (applist (c, Context.Rel.to_extended_list mkRel 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))))) in c', ctx' - | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme") + | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme.") (**********************************************************************) (* Build the right-to-left rewriting lemma for conclusion associated *) @@ -656,10 +655,10 @@ let fix_r2l_forward_rew_scheme (c, ctx') = (**********************************************************************) let build_r2l_rew_scheme dep env ind k = - let sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in - let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in - let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep k in - c, Evd.evar_universe_context (Sigma.to_evar_map sigma) + let sigma = Evd.from_env env in + let (sigma, indu) = Evd.fresh_inductive_instance env sigma ind in + let (sigma, c) = build_case_analysis_scheme env sigma indu dep k in + c, Evd.evar_universe_context sigma let build_l2r_rew_scheme = build_l2r_rew_scheme let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme diff --git a/tactics/equality.ml b/tactics/equality.ml index e6278943d..05c5cd5ec 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -40,7 +40,6 @@ open Eqschemes open Locus open Locusops open Misctypes -open Sigma.Notations open Proofview.Notations open Unification open Context.Named.Declaration @@ -254,16 +253,16 @@ let rewrite_keyed_unif_flags = { } let rewrite_elim with_evars frzevars cls c e = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let flags = if Unification.is_keyed_unification () then rewrite_keyed_unif_flags else rewrite_conv_closed_unif_flags in let flags = make_flags frzevars (Tacmach.New.project gl) flags c in general_elim_clause with_evars flags cls c e - end } + end let tclNOTSAMEGOAL tac = let goal gl = Proofview.Goal.goal (Proofview.Goal.assume gl) in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let sigma = project gl in let ev = goal gl in tac >>= fun () -> @@ -278,7 +277,7 @@ let tclNOTSAMEGOAL tac = tclZEROMSG (str"Tactic generated a subgoal identical to the original goal.") else Proofview.tclUNIT () - end } + end (* Ad hoc asymmetric general_elim_clause *) let general_elim_clause with_evars frzevars cls rew elim = @@ -313,7 +312,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim = (general_elim_clause with_evars frzevars cls c elim)) tac in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let instantiate_lemma concl = if not all then instantiate_lemma gl c t l l2r concl else instantiate_lemma_all frzevars gl c t l l2r concl @@ -325,7 +324,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim = let cs = instantiate_lemma typ in if firstonly then tclFIRST (List.map try_clause cs) else tclMAP try_clause cs - end } + end (* The next function decides in particular whether to try a regular rewrite or a generalized rewrite. @@ -387,9 +386,9 @@ let find_elim hdcncl lft2rgt dep cls ot gl = Logic.eq or Jmeq just before *) assert false in - let Sigma (elim, sigma, p) = Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in + let (sigma, elim) = fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in let elim = EConstr.of_constr elim in - Sigma ((elim, Safe_typing.empty_private_constants), sigma, p) + (sigma, (elim, Safe_typing.empty_private_constants)) else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) @@ -407,11 +406,11 @@ let find_elim hdcncl lft2rgt dep cls ot gl = | Ind (ind,u) -> let c, eff = find_scheme scheme_name ind in (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *) - let Sigma (elim, sigma, p) = - Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) + let (sigma, elim) = + fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in let elim = EConstr.of_constr elim in - Sigma ((elim, eff), sigma, p) + (sigma, (elim, eff)) | _ -> assert false let type_of_clause cls gl = match cls with @@ -419,21 +418,19 @@ let type_of_clause cls gl = match cls with | Some id -> pf_get_hyp_typ id gl let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let evd = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + Proofview.Goal.enter begin fun gl -> + let evd = Proofview.Goal.sigma gl in let isatomic = isProd evd (whd_zeta evd hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun evd c type_of_cls in - let Sigma ((elim, effs), sigma, p) = find_elim hdcncl lft2rgt dep cls (Some t) gl in - let tac = + let (sigma, (elim, effs)) = find_elim hdcncl lft2rgt dep cls (Some t) gl in + Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS effs <*> general_elim_clause with_evars frzevars tac cls c t l (match lft2rgt with None -> false | Some b -> b) {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} - in - Sigma (tac, sigma, p) - end } + end let adjust_rewriting_direction args lft2rgt = match args with @@ -456,7 +453,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac if occs != AllOccurrences then ( rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac) else - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in @@ -485,7 +482,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac | None -> Proofview.tclZERO ~info e (* error "The provided term does not end with an equality or a declared rewrite relation." *) end - end } + end let general_rewrite_ebindings = general_rewrite_ebindings_clause None @@ -547,9 +544,9 @@ let general_rewrite_clause l2r with_evars ?tac c cl = let ids_of_hyps = pf_ids_of_hyps gl in Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> do_hyps_atleastonce (ids gl) - end } + end in if cl.concl_occs == NoOccurrences then do_hyps else tclIFTHENTRYELSEMUST @@ -557,25 +554,25 @@ let general_rewrite_clause l2r with_evars ?tac c cl = do_hyps let apply_special_clear_request clear_flag f = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try - let ((c, bl), sigma) = run_delayed env sigma f in + let (sigma, (c, bl)) = f env sigma in apply_clear_request clear_flag (use_clear_hyp_by_default ()) c with e when catchable_exception e -> tclIDTAC - end } + end let general_multi_rewrite with_evars l cl tac = let do1 l2r f = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - let (c, sigma) = run_delayed env sigma f in + let (sigma, c) = f env sigma in tclWITHHOLES with_evars (general_rewrite_clause l2r with_evars ?tac c cl) sigma - end } + end in let rec doN l2r c = function | Precisely n when n <= 0 -> Proofview.tclUNIT () @@ -638,7 +635,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = | None -> Proofview.tclUNIT () | Some tac -> tclCOMPLETE tac in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let get_type_of = pf_apply get_type_of gl in let t1 = get_type_of c1 and t2 = get_type_of c2 in @@ -664,7 +661,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = tclTHEN (apply sym) assumption; try_prove_eq ]) - end } + end let replace c1 c2 = replace_using_leibniz onConcl c2 c1 false false None @@ -874,7 +871,7 @@ let descend_then env sigma head dirn = let dirn_env = Environ.push_rel_context cstr.(dirn-1).cs_args env in (dirn_nlams, dirn_env, - (fun dirnval (dfltval,resty) -> + (fun sigma dirnval (dfltval,resty) -> let deparsign = make_arity_signature env sigma true indf in let p = it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in @@ -887,7 +884,7 @@ let descend_then env sigma head dirn = List.map build_branch (List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in - Inductiveops.make_case_or_project env sigma indf ci p head (Array.of_list brl))) + sigma, Inductiveops.make_case_or_project env sigma indf ci p head (Array.of_list brl))) (* Now we need to construct the discriminator, given a discriminable position. This boils down to: @@ -932,23 +929,24 @@ let build_selector env sigma dirn c ind special default = let brl = List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in - mkCase (ci, p, c, Array.of_list brl) + sigma, mkCase (ci, p, c, Array.of_list brl) -let build_coq_False () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_False ()) -let build_coq_True () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_True ()) -let build_coq_I () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_I ()) +let build_coq_False sigma = Evarutil.new_global sigma (build_coq_False ()) +let build_coq_True sigma = Evarutil.new_global sigma (build_coq_True ()) +let build_coq_I sigma = Evarutil.new_global sigma (build_coq_I ()) let rec build_discriminator env sigma dirn c = function | [] -> let ind = get_type_of env sigma c in - let true_0,false_0 = - build_coq_True(),build_coq_False() in + let sigma, true_0 = build_coq_True sigma in + let sigma, false_0 = build_coq_False sigma in build_selector env sigma dirn c ind true_0 false_0 | ((sp,cnum),argnum)::l -> + let sigma, false_0 = build_coq_False sigma in let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in - let subval = build_discriminator cnum_env sigma dirn newc l in - kont subval (build_coq_False (),mkSort (Prop Null)) + let sigma, subval = build_discriminator cnum_env sigma dirn newc l in + kont sigma subval (false_0,mkSort (Prop Null)) (* Note: discrimination could be more clever: if some elimination is not allowed because of a large impredicative constructor in the @@ -962,7 +960,7 @@ let rec build_discriminator env sigma dirn c = function *) let gen_absurdity id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in if is_empty_type sigma hyp_typ @@ -970,7 +968,7 @@ let gen_absurdity id = simplest_elim (mkVar id) else tclZEROMSG (str "Not the negation of an equality.") - end } + end (* Precondition: eq is leibniz equality @@ -991,9 +989,9 @@ let ind_scheme_of_eq lbeq = let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = - let i = build_coq_I () in - let absurd_term = build_coq_False () in - let eq_elim, eff = ind_scheme_of_eq lbeq in + let sigma, i = build_coq_I sigma in + let sigma, absurd_term = build_coq_False sigma in + let eq_elim, eff = ind_scheme_of_eq lbeq in let sigma, eq_elim = Evd.fresh_global (Global.env ()) sigma eq_elim in let eq_elim = EConstr.of_constr eq_elim in sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), @@ -1013,7 +1011,7 @@ let apply_on_clause (f,t) clause = let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in - let discriminator = + let sigma, discriminator = build_discriminator e_env sigma dirn (mkVar e) cpath in let sigma,(pf, absurd_term), eff = discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in @@ -1027,17 +1025,17 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in match find_positions env sigma ~no_discr:false t1 t2 with | Inr _ -> tclZEROMSG (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u eq_clause cpath dirn - end } + end let onEquality with_evars tac (c,lbindc) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in let t = type_of c in @@ -1049,10 +1047,10 @@ let onEquality with_evars tac (c,lbindc) = tclTHEN (Proofview.Unsafe.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') - end } + end let onNegatedEquality with_evars tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in @@ -1063,7 +1061,7 @@ let onNegatedEquality with_evars tac = onEquality with_evars tac (mkVar id,NoBindings))) | _ -> tclZEROMSG (str "Not a negated primitive equality.") - end } + end let discrSimpleClause with_evars = function | None -> onNegatedEquality with_evars discrEq @@ -1206,7 +1204,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = else let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with | (_sigS,[a;p]) -> (a, p) - | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type") in + | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type.") in let ev = Evarutil.e_new_evar env evdref a in let rty = beta_applist sigma (p_i_minus_1,[ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in @@ -1309,7 +1307,8 @@ let rec build_injrec env sigma dflt c = function let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in let sigma, (subval,tuplety,dfltval) = build_injrec cnum_env sigma dflt newc l in - sigma, (kont subval (dfltval,tuplety), tuplety,dfltval) + let sigma, res = kont sigma subval (dfltval,tuplety) in + sigma, (res, tuplety,dfltval) with UserError _ -> failwith "caught" @@ -1321,13 +1320,11 @@ let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) let inject_if_homogenous_dependent_pair ty = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> try let sigma = Tacmach.New.project gl in let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in (* fetch the informations of the pair *) - let ceq = Universes.constr_of_global Coqlib.glob_eq in - let ceq = EConstr.of_constr ceq in let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in let existTconstr () = (Coqlib.build_sigma_type()).Coqlib.intro in (* check whether the equality deals with dep pairs or not *) @@ -1346,22 +1343,24 @@ let inject_if_homogenous_dependent_pair ty = pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; Coqlib.check_required_library ["Coq";"Logic";"Eqdep_dec"]; let new_eq_args = [|pf_unsafe_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in - let inj2 = EConstr.of_constr @@ Universes.constr_of_global @@ - Coqlib.coq_reference "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in + let inj2 = Coqlib.coq_reference "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] + "inj_pair2_eq_dec" in let c, eff = find_scheme (!eq_dec_scheme_kind_name()) ind in (* cut with the good equality and prove the requested goal *) tclTHENLIST [Proofview.tclEFFECTS eff; intro; onLastHyp (fun hyp -> + Tacticals.New.pf_constr_of_global Coqlib.glob_eq >>= fun ceq -> tclTHENS (cut (mkApp (ceq,new_eq_args))) [clear [destVar sigma hyp]; + Tacticals.New.pf_constr_of_global inj2 >>= fun inj2 -> Proofview.V82.tactic (Tacmach.refine (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|]))) ])] with Exit -> Proofview.tclUNIT () - end } + end (* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it expands then only when the whdnf has a constructor of an inductive type @@ -1445,7 +1444,7 @@ let injEq ?(old=false) with_evars clear_flag ipats = let post_tac c n = match ipats_style with | Some ipats -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let destopt = match EConstr.kind sigma c with | Var id -> get_previous_hyp_position id gl @@ -1458,7 +1457,7 @@ let injEq ?(old=false) with_evars clear_flag ipats = then intro_patterns_bound_to with_evars n destopt ipats else intro_patterns_to with_evars destopt ipats in tclTHEN clear_tac intro_tac - end } + end | None -> tclIDTAC in injEqThen post_tac l2r @@ -1476,7 +1475,7 @@ let injConcl = injClause None false None let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.tag id))) let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = clause.evd in let env = Proofview.Goal.env gl in match find_positions env sigma ~no_discr:false t1 t2 with @@ -1487,7 +1486,7 @@ let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = | Inr posns -> inject_at_positions env sigma true u clause posns (ntac (clenv_value clause)) - end } + end let dEqThen with_evars ntac = function | None -> onNegatedEquality with_evars (decompEqThen (ntac None)) @@ -1498,10 +1497,10 @@ let dEq with_evars = (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) let intro_decomp_eq tac data (c, t) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let cl = pf_apply make_clenv_binding gl (c, t) NoBindings in decompEqThen (fun _ -> tac) data cl - end } + end let _ = declare_intro_decomp_eq intro_decomp_eq @@ -1552,7 +1551,6 @@ let decomp_tuple_term env sigma c t = in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = - let sigma = Sigma.to_evar_map sigma in let typ = get_type_of env sigma dep_pair1 in (* We find all possible decompositions *) let decomps1 = decomp_tuple_term env sigma dep_pair1 typ in @@ -1577,7 +1575,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* Retype to get universes right *) let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in let sigma, _ = Typing.type_of env sigma body in - Sigma.Unsafe.of_pair ((body, expected_goal), sigma) + (sigma, (body, expected_goal)) (* Like "replace" but decompose dependent equalities *) (* i.e. if equality is "exists t v = exists u w", and goal is "phi(t,u)", *) @@ -1585,42 +1583,38 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* on for further iterated sigma-tuples *) let cutSubstInConcl l2r eqn = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in - let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in - let tac = - tclTHENFIRST + let (sigma, (typ, expected)) = subst_tuple_term env sigma e1 e2 typ in + tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (tclTHENFIRST (tclTHENLIST [ (change_concl typ); (* Put in pattern form *) (replace_core onConcl l2r eqn) ]) - (change_concl expected) (* Put in normalized form *) - in - Sigma (tac, sigma, p) - end } + (change_concl expected)) (* Put in normalized form *) + end let cutSubstInHyp l2r eqn id = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_get_hyp_typ id gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in - let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in - let tac = - tclTHENFIRST + let (sigma, (typ, expected)) = subst_tuple_term env sigma e1 e2 typ in + tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (tclTHENFIRST (tclTHENLIST [ (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly)); (replace_core (onHyp id) l2r eqn) ]) - (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly)) - in - Sigma (tac, sigma, p) - end } + (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly))) + end let try_rewrite tac = Proofview.tclORELSE tac begin function (e, info) -> match e with @@ -1642,11 +1636,11 @@ let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None let substClause l2r c cls = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let eq = pf_apply get_type_of gl c in tclTHENS (cutSubstClause l2r eq cls) [Proofview.tclUNIT (); exact_no_check c] - end } + end let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls) let rewriteInHyp l2r c id = rewriteClause l2r c (Some id) @@ -1707,7 +1701,7 @@ let is_eq_x gl x d = erase hyp and x; proceed by generalizing all dep hyps *) let subst_one dep_proof_ok x (hyp,rhs,dir) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in @@ -1736,13 +1730,13 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = else [Proofview.tclUNIT ()]) @ [tclTRY (clear [x; hyp])]) - end } + end (* Look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *) let subst_one_var dep_proof_ok x = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let decl = pf_get_hyp x gl in (* If x has a body, simply replace x with body and clear x *) @@ -1759,7 +1753,7 @@ let subst_one_var dep_proof_ok x = str".") with FoundHyp res -> res in subst_one dep_proof_ok x res - end } + end let subst_gen dep_proof_ok ids = tclMAP (subst_one_var dep_proof_ok) ids @@ -1812,7 +1806,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = (* Second step: treat equations *) let process hyp = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let sigma = project gl in let env = Proofview.Goal.env gl in @@ -1828,19 +1822,19 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = subst_one flags.rewrite_dependent_proof y' (hyp,x,false) | _ -> Proofview.tclUNIT () - end } + end in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let ids = find_equations gl in tclMAP process ids - end } + end else (* Old implementation, not able to manage configurations like a=b, a=t, or situations like "a = S b, b = S a", or also accidentally unfolding let-ins *) - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = @@ -1859,7 +1853,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let ids = List.map_filter test hyps in let ids = List.uniquize ids in subst_gen flags.rewrite_dependent_proof ids - end } + end (* Rewrite the first assumption for which a condition holds and gives the direction of the rewrite *) @@ -1896,11 +1890,10 @@ let rewrite_assumption_cond cond_eq_term cl = with | Failure _ | UserError _ -> arec rest gl end in - Proofview.Goal.enter { enter = begin fun gl -> - let gl = Proofview.Goal.lift gl Sigma.Unsafe.le in + Proofview.Goal.enter begin fun gl -> let hyps = Proofview.Goal.hyps gl in arec hyps gl - end } + end (* Generalize "subst x" to substitution of subterm appearing as an equation in the context, but not clearing the hypothesis *) diff --git a/tactics/equality.mli b/tactics/equality.mli index b47be3bbc..27be5affb 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -126,4 +126,4 @@ val set_eq_dec_scheme_kind : mutual scheme_kind -> unit (* [build_selector env sigma i c t u v] matches on [c] of type [t] and returns [u] in branch [i] and [v] on other branches *) val build_selector : env -> evar_map -> int -> constr -> types -> - constr -> constr -> constr + constr -> constr -> evar_map * constr diff --git a/tactics/hints.ml b/tactics/hints.ml index 48a7b3f75..773abb9f0 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -22,7 +22,6 @@ open Namegen open Libnames open Smartlocate open Misctypes -open Tactypes open Termops open Inductiveops open Typing @@ -34,7 +33,6 @@ open Pfedit open Tacred open Printer open Vernacexpr -open Sigma.Notations module NamedDecl = Context.Named.Declaration @@ -912,7 +910,7 @@ let make_resolve_hyp env sigma decl = (c, NamedDecl.get_type decl, Univ.ContextSet.empty)] with | Failure _ -> [] - | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") + | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp.") (* REM : in most cases hintname = id *) @@ -1363,11 +1361,7 @@ let add_hint_lemmas env sigma eapply lems hint_db = Hint_db.add_list env sigma hintlist' hint_db let make_local_hint_db env sigma ts eapply lems = - let map c = - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (c, sigma, _) = c.delayed env sigma in - (Sigma.to_evar_map sigma, c) - in + let map c = c env sigma in let lems = List.map map lems in let sign = EConstr.named_context env in let ts = match ts with diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index fd5eabe64..4db744224 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -254,13 +254,13 @@ open Evar_kinds let mkPattern c = snd (Patternops.pattern_of_glob_constr c) let mkGApp f args = CAst.make @@ GApp (f, args) let mkGHole = CAst.make @@ - GHole (QuestionMark (Define false), Misctypes.IntroAnonymous, None) + GHole (QuestionMark (Define false,Anonymous), Misctypes.IntroAnonymous, None) let mkGProd id c1 c2 = CAst.make @@ GProd (Name (Id.of_string id), Explicit, c1, c2) let mkGArrow c1 c2 = CAst.make @@ GProd (Anonymous, Explicit, c1, c2) let mkGVar id = CAst.make @@ GVar (Id.of_string id) -let mkGPatVar id = CAst.make @@ GPatVar((false, Id.of_string id)) +let mkGPatVar id = CAst.make @@ GPatVar(Evar_kinds.FirstOrderPatVar (Id.of_string id)) let mkGRef r = CAst.make @@ GRef (Lazy.force r, None) let mkGAppRef r args = mkGApp (mkGRef r) args @@ -340,7 +340,7 @@ let match_arrow_pattern sigma t = match Id.Map.bindings result with | [(m1,arg);(m2,mind)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind) - | _ -> anomaly (Pp.str "Incorrect pattern matching") + | _ -> anomaly (Pp.str "Incorrect pattern matching.") let match_with_imp_term sigma c = match EConstr.kind sigma c with @@ -471,7 +471,7 @@ let match_eq_nf gls eqn (ref, hetero) = | [(m1,t);(m2,x);(m3,y)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); (t,pf_whd_all gls x,pf_whd_all gls y) - | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms") + | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms.") let dest_nf_eq gls eqn = try @@ -499,7 +499,7 @@ let coq_sig_pattern = let match_sigma sigma t = match Id.Map.bindings (matches sigma (Lazy.force coq_sig_pattern) t) with | [(_,a); (_,p)] -> (a,p) - | _ -> anomaly (Pp.str "Unexpected pattern") + | _ -> anomaly (Pp.str "Unexpected pattern.") let is_matching_sigma sigma t = is_matching sigma (Lazy.force coq_sig_pattern) t @@ -544,8 +544,8 @@ let match_eqdec sigma t = false,op_or,matches sigma (Lazy.force coq_eqdec_rev_pattern) t in match Id.Map.bindings subst with | [(_,typ);(_,c1);(_,c2)] -> - eqonleft, EConstr.of_constr (Universes.constr_of_global (Lazy.force op)), c1, c2, typ - | _ -> anomaly (Pp.str "Unexpected pattern") + eqonleft, Lazy.force op, c1, c2, typ + | _ -> anomaly (Pp.str "Unexpected pattern.") (* Patterns "~ ?" and "? -> False" *) let coq_not_pattern = lazy (mkPattern (mkGAppRef coq_not_ref [mkGHole])) diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 82a3d47b5..a1d986544 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -120,11 +120,11 @@ val match_with_equation: (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) -val find_eq_data_decompose : ('a, 'r) Proofview.Goal.t -> constr -> +val find_eq_data_decompose : 'a Proofview.Goal.t -> constr -> coq_eq_data * EInstance.t * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) -val find_this_eq_data_decompose : ('a, 'r) Proofview.Goal.t -> constr -> +val find_this_eq_data_decompose : 'a Proofview.Goal.t -> constr -> coq_eq_data * EInstance.t * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) @@ -142,10 +142,10 @@ val is_matching_sigma : evar_map -> constr -> bool (** Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns [t,u,T] and a boolean telling if equality is on the left side *) -val match_eqdec : evar_map -> constr -> bool * constr * constr * constr * constr +val match_eqdec : evar_map -> constr -> bool * Globnames.global_reference * constr * constr * constr (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) -val dest_nf_eq : ('a, 'r) Proofview.Goal.t -> constr -> (constr * constr * constr) +val dest_nf_eq : 'a Proofview.Goal.t -> constr -> (constr * constr * constr) (** Match a negation *) val is_matching_not : evar_map -> constr -> bool diff --git a/tactics/inv.ml b/tactics/inv.ml index b951e7ceb..ec038f638 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -25,7 +25,6 @@ open Tactics open Elim open Equality open Misctypes -open Sigma.Notations open Proofview.Notations module NamedDecl = Context.Named.Declaration @@ -272,14 +271,14 @@ Nota: with Inversion_clear, only four useless hypotheses let generalizeRewriteIntros as_mode tac depids id = Proofview.tclENV >>= fun env -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let dids = dependent_hyps env id depids gl in let reintros = if as_mode then intros_replacing else intros_possibly_replacing in (tclTHENLIST [bring_hyps dids; tac; (* may actually fail to replace if dependent in a previous eq *) reintros (ids_of_named_context dids)]) - end } + end let error_too_many_names pats = let loc = Loc.merge_opt (fst (List.hd pats)) (fst (List.last pats)) in @@ -287,7 +286,7 @@ let error_too_many_names pats = tclZEROMSG ?loc ( str "Unexpected " ++ str (String.plural (List.length pats) "introduction pattern") ++ - str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (EConstr.Unsafe.to_constr (fst (run_delayed env Evd.empty c))))) pats ++ + str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (EConstr.Unsafe.to_constr (snd (c env Evd.empty))))) pats ++ str ".") let get_names (allow_conj,issimple) (loc, pat as x) = match pat with @@ -341,7 +340,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC)) in let substHypIfVariable tac id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in (** We only look at the type of hypothesis "id" *) let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in @@ -350,7 +349,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1 | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2 | _ -> tac id - end } + end in let deq_trailer id clear_flag _ neqns = assert (clear_flag == None); @@ -377,7 +376,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = id let nLastDecls i tac = - Proofview.Goal.enter { enter = begin fun gl -> tac (nLastDecls gl i) end } + Proofview.Goal.enter begin fun gl -> tac (nLastDecls gl i) end (* Introduction of the equations on arguments othin: discriminates Simple Inversion, Inversion and Inversion_clear @@ -385,7 +384,7 @@ let nLastDecls i tac = Some thin: the equations are rewritten, and cleared if thin is true *) let rewrite_equations as_mode othin neqns names ba = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.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 NamedDecl.get_id nodepids else [] in @@ -418,7 +417,7 @@ let rewrite_equations as_mode othin neqns names ba = [tclDO neqns intro; bring_hyps nodepids; clear (ids_of_named_context nodepids)]) - end } + end let interp_inversion_kind = function | SimpleInversion -> None @@ -435,9 +434,8 @@ let rewrite_equations_tac as_mode othin id neqns names ba = tac let raw_inversion inv_kind id status names = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let c = mkVar id in @@ -462,11 +460,11 @@ let raw_inversion inv_kind id status names = in let refined id = let prf = mkApp (mkVar id, args) in - Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) } + Refine.refine (fun h -> (h, prf)) in let neqns = List.length realargs in let as_mode = names != None in - let tac = + tclTHEN (Proofview.Unsafe.tclEVARS sigma) (tclTHENS (assert_before Anonymous cut_concl) [case_tac names @@ -474,9 +472,7 @@ let raw_inversion inv_kind id status names = (rewrite_equations_tac as_mode inv_kind id neqns)) (Some elim_predicate) ind (c,t); onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + end (* Error messages of the inversion tactics *) let wrap_inv_error id = function (e, info) -> match e with @@ -516,13 +512,13 @@ let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) * back to their places in the hyp-list. *) let invIn k names ids id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let concl = Proofview.Goal.concl gl in let sigma = project gl in let nb_prod_init = nb_prod sigma concl in let intros_replace_ids = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = pf_concl gl in let sigma = project gl in let nb_of_new_hyp = @@ -532,7 +528,7 @@ let invIn k names ids id = intros_replacing ids else tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) - end } + end in Proofview.tclORELSE (tclTHENLIST @@ -540,7 +536,7 @@ let invIn k names ids id = inversion k NoDep names id; intros_replace_ids]) (wrap_inv_error id) - end } + end let invIn_gen k names idl = try_intros_until (invIn k names idl) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 83f3da30a..87d815fc8 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -27,7 +27,6 @@ open Declare open Tacticals.New open Tactics open Decl_kinds -open Proofview.Notations open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -261,7 +260,7 @@ let add_inversion_lemma_exn na com comsort bool tac = (* ================================= *) let lemInv id c = - Proofview.Goal.enter { enter = begin fun gls -> + Proofview.Goal.enter begin fun gls -> try let clause = mk_clenv_from_env (pf_env gls) (project gls) None (c, pf_unsafe_type_of gls c) in let clause = clenv_constrain_last_binding (EConstr.mkVar id) clause in @@ -274,12 +273,12 @@ let lemInv id c = user_err ~hdr:"LemInv" (str "Cannot refine current goal with the lemma " ++ pr_leconstr_env (pf_env gls) (project gls) c) - end } + end let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id let lemInvIn id c ids = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let intros_replace_ids = let concl = Proofview.Goal.concl gl in @@ -292,7 +291,7 @@ let lemInvIn id c ids = in ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c)) (intros_replace_ids))) - end } + end let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index c495b5ece..aa574e41c 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -17,7 +17,6 @@ open Declarations open Tacmach open Clenv open Tactypes -open Sigma.Notations module NamedDecl = Context.Named.Declaration @@ -238,7 +237,7 @@ let compute_constructor_signatures isrec ((_,k as ity),u) = end | LetIn (_,_,_,c), rest -> false :: analrec c rest | _, [] -> [] - | _ -> anomaly (Pp.str "compute_constructor_signatures") + | _ -> anomaly (Pp.str "compute_constructor_signatures.") in let (mib,mip) = Global.lookup_inductive ity in let n = mib.mind_nparams in @@ -511,12 +510,12 @@ module New = struct Proofview.Unsafe.tclEVARS sigma <*> tac >>= check_evars_if let tclDELAYEDWITHHOLES check x tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let Sigma (x, sigma, _) = x.delayed env sigma in - tclWITHHOLES check (tac x) (Sigma.to_evar_map sigma) - end } + let (sigma, x) = x env sigma in + tclWITHHOLES check (tac x) sigma + end let tclTIMEOUT n t = Proofview.tclOR @@ -547,73 +546,73 @@ module New = struct mkVar (nthHypId m gl) let onNthHypId m tac = - Proofview.Goal.enter { enter = begin fun gl -> tac (nthHypId m gl) end } + Proofview.Goal.enter begin fun gl -> tac (nthHypId m gl) end let onNthHyp m tac = - Proofview.Goal.enter { enter = begin fun gl -> tac (nthHyp m gl) end } + Proofview.Goal.enter begin fun gl -> tac (nthHyp m gl) end let onLastHypId = onNthHypId 1 let onLastHyp = onNthHyp 1 let onNthDecl m tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Proofview.tclUNIT (nthDecl m gl) >>= tac - end } + end let onLastDecl = onNthDecl 1 let ifOnHyp pred tac1 tac2 id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let typ = Tacmach.New.pf_get_hyp_typ id gl in if pred (id,typ) then tac1 id else tac2 id - end } + end - let onHyps find tac = Proofview.Goal.enter { enter = begin fun gl -> tac (find.enter gl) end } + let onHyps find tac = Proofview.Goal.enter begin fun gl -> tac (find gl) end let afterHyp id tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in let rem, _ = List.split_when (NamedDecl.get_id %> Id.equal id) hyps in tac rem - end } + end let fullGoal gl = let hyps = Tacmach.New.pf_ids_of_hyps gl in None :: List.map Option.make hyps let tryAllHyps tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = Tacmach.New.pf_ids_of_hyps gl in tclFIRST_PROGRESS_ON tac hyps - end } + end let tryAllHypsAndConcl tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> tclFIRST_PROGRESS_ON tac (fullGoal gl) - end } + end let onClause tac cl = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = Tacmach.New.pf_ids_of_hyps gl in tclMAP tac (Locusops.simple_clause_of (fun () -> hyps) cl) - end } + end (* Find the right elimination suffix corresponding to the sort of the goal *) (* c should be of type A1->.. An->B with B an inductive definition *) let general_elim_then_using mk_elim isrec allnames tac predicate ind (c, t) = - Proofview.Goal.enter { enter = begin fun gl -> - let sigma, elim = (mk_elim ind).enter gl in + Proofview.Goal.enter begin fun gl -> + let sigma, elim = mk_elim ind gl in let ind = on_snd (fun u -> EInstance.kind sigma u) ind in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Proofview.Goal.enter { enter = begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let indclause = mk_clenv_from gl (c, t) in (* applying elimination_scheme just a little modified *) let elimclause = mk_clenv_from gl (elim,Tacmach.New.pf_unsafe_type_of gl elim) in let indmv = match EConstr.kind elimclause.evd (last_arg elimclause.evd elimclause.templval.Evd.rebus) with | Meta mv -> mv - | _ -> anomaly (str"elimination") + | _ -> anomaly (str"elimination.") in let pmv = let p, _ = decompose_app elimclause.evd elimclause.templtyp.Evd.rebus in @@ -655,7 +654,7 @@ module New = struct Proofview.tclTHEN (Clenvtac.clenv_refine false clenv') (Proofview.tclEXTEND [] tclIDTAC branchtacs) - end }) end } + end) end let elimination_sort_of_goal gl = (** Retyping will expand evars anyway. *) @@ -673,50 +672,50 @@ module New = struct (* computing the case/elim combinators *) - let gl_make_elim ind = { enter = begin fun gl -> + let gl_make_elim ind = begin fun gl -> let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in let (sigma, c) = pf_apply Evd.fresh_global gl gr in (sigma, EConstr.of_constr c) - end } + end - let gl_make_case_dep (ind, u) = { enter = begin fun gl -> - let sigma = Sigma.Unsafe.of_evar_map (project gl) in + let gl_make_case_dep (ind, u) = begin fun gl -> + let sigma = project gl in let u = EInstance.kind (project gl) u in - let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) true + let (sigma, r) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) true (elimination_sort_of_goal gl) in - (Sigma.to_evar_map sigma, EConstr.of_constr r) - end } + (sigma, EConstr.of_constr r) + end - let gl_make_case_nodep (ind, u) = { enter = begin fun gl -> - let sigma = Sigma.Unsafe.of_evar_map (project gl) in - let u = EInstance.kind (project gl) u in - let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) false + let gl_make_case_nodep (ind, u) = begin fun gl -> + let sigma = project gl in + let u = EInstance.kind sigma u in + let (sigma, r) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) false (elimination_sort_of_goal gl) in - (Sigma.to_evar_map sigma, EConstr.of_constr r) - end } + (sigma, EConstr.of_constr r) + end let make_elim_branch_assumptions ba hyps = let assums = try List.rev (List.firstn ba.nassums hyps) - with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions") in + with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions.") in { ba = ba; assums = assums } let elim_on_ba tac ba = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in tac branches - end } + end let case_on_ba tac ba = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in tac branches - end } + end let elimination_then tac c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (ind,t) = pf_reduce_to_quantified_ind gl (pf_unsafe_type_of gl c) in let isrec,mkelim = match (Global.lookup_mind (fst (fst ind))).mind_record with @@ -724,7 +723,7 @@ module New = struct | Some _ -> false,gl_make_case_dep in general_elim_then_using mkelim isrec None tac None ind (c, t) - end } + end let case_then_using = general_elim_then_using gl_make_case_dep false diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 96270f748..9603212de 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -225,7 +225,7 @@ module New : sig val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic - val nLastDecls : ('a, 'r) Proofview.Goal.t -> int -> named_context + val nLastDecls : 'a Proofview.Goal.t -> int -> named_context val ifOnHyp : (identifier * types -> bool) -> (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) -> @@ -236,7 +236,7 @@ module New : sig val onLastHyp : (constr -> unit tactic) -> unit tactic val onLastDecl : (named_declaration -> unit tactic) -> unit tactic - val onHyps : ([ `LZ ], named_context) Proofview.Goal.enter -> + val onHyps : ([ `LZ ] Proofview.Goal.t -> named_context) -> (named_context -> unit tactic) -> unit tactic val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic @@ -244,9 +244,9 @@ module New : sig val tryAllHypsAndConcl : (identifier option -> unit tactic) -> unit tactic val onClause : (identifier option -> unit tactic) -> clause -> unit tactic - val elimination_sort_of_goal : ('a, 'r) Proofview.Goal.t -> sorts_family - val elimination_sort_of_hyp : Id.t -> ('a, 'r) Proofview.Goal.t -> sorts_family - val elimination_sort_of_clause : Id.t option -> ('a, 'r) Proofview.Goal.t -> sorts_family + val elimination_sort_of_goal : 'a Proofview.Goal.t -> sorts_family + val elimination_sort_of_hyp : Id.t -> 'a Proofview.Goal.t -> sorts_family + val elimination_sort_of_clause : Id.t option -> 'a Proofview.Goal.t -> sorts_family val elimination_then : (branch_args -> unit Proofview.tactic) -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 7e8cb4e63..b553f316c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -43,9 +43,7 @@ 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 @@ -55,7 +53,7 @@ let inj_with_occurrences e = (AllOccurrences,e) let typ_of env sigma c = let open Retyping in - try get_type_of ~lax:true env (Sigma.to_evar_map sigma) c + try get_type_of ~lax:true env sigma c with RetypeError e -> user_err (print_retype_error e) @@ -165,18 +163,18 @@ let _ = (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) let unsafe_intro env store decl b = - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> let ctx = named_context_val env in let nctx = push_named_context_val decl ctx in let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in let ninst = mkRel 1 :: inst 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 (sigma, ev) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in + (sigma, mkNamedLambda_or_LetIn decl ev) + end let introduction ?(check=true) id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in @@ -192,49 +190,48 @@ let introduction ?(check=true) id = | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b | _ -> raise (RefinerError IntroNeedsProduct) - end } + end let refine = Tacmach.refine let error msg = CErrors.user_err Pp.(str msg) let convert_concl ?(check=true) ty k = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.concl gl in - Refine.refine ~unsafe:true { run = begin fun sigma -> - let Sigma ((), sigma, p) = + Refine.refine ~unsafe:true begin fun sigma -> + let sigma = if check then begin - let sigma = Sigma.to_evar_map sigma in ignore (Typing.unsafe_type_of env sigma ty); let sigma,b = Reductionops.infer_conv env sigma ty conclty in if not b then error "Not convertible."; - Sigma.Unsafe.of_pair ((), sigma) - end else Sigma.here () sigma in - let Sigma (x, sigma, q) = Evarutil.new_evar env sigma ~principal:true ~store ty in + sigma + end else sigma in + let (sigma, x) = Evarutil.new_evar env sigma ~principal:true ~store ty in let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in - Sigma (ans, sigma, p +> q) - end } - end } + (sigma, ans) + end + end let convert_hyp ?(check=true) d = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty - end } - end } + end + end let convert_concl_no_check = convert_concl ~check:false let convert_hyp_no_check = convert_hyp ~check:false let convert_gen pb x y = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> try let sigma, b = Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y in if b then Proofview.Unsafe.tclEVARS sigma @@ -242,7 +239,7 @@ let convert_gen pb x y = with (* Reduction.NotConvertible *) _ -> (** FIXME: Sometimes an anomaly is raised from conversion *) Tacticals.New.tclFAIL 0 (str "Not convertible") -end } +end let convert x y = convert_gen Reduction.CONV x y let convert_leq x y = convert_gen Reduction.CUMUL x y @@ -282,7 +279,7 @@ let error_replacing_dependency env sigma id err = let clear_gen fail = function | [] -> Proofview.tclUNIT () | ids -> - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let ids = List.fold_right Id.Set.add ids Id.Set.empty in (** clear_hyps_in_evi does not require nf terms *) let gl = Proofview.Goal.assume gl in @@ -295,11 +292,11 @@ let clear_gen fail = function with Evarutil.ClearDependencyError (id,err) -> fail env sigma id err in let env = reset_with_named_context hyps env in - let tac = Refine.refine ~unsafe:true { run = fun sigma -> + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) + (Refine.refine ~unsafe:true begin fun sigma -> Evarutil.new_evar env sigma ~principal:true concl - } in - Sigma.Unsafe.of_pair (tac, !evdref) - end } + end) + end let clear ids = clear_gen error_clear_dependency ids let clear_for_replacing ids = clear_gen error_replacing_dependency ids @@ -318,7 +315,7 @@ let apply_clear_request clear_flag dft c = (* Moving hypotheses *) let move_hyp id dest = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.concl gl in @@ -326,10 +323,10 @@ let move_hyp id dest = let sign = named_context_val env in let sign' = move_hyp_in_named_context sigma id dest sign in let env = reset_with_named_context sign' env in - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty - end } - end } + end + end (* Renaming hypotheses *) let rename_hyp repl = @@ -348,7 +345,7 @@ let rename_hyp repl = match dom with | None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping") | Some (src, dst) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in let concl = Proofview.Goal.concl gl in @@ -380,10 +377,10 @@ let rename_hyp repl = let nconcl = subst concl in let nctx = val_of_named_context nhyps in let instance = List.map (NamedDecl.get_id %> mkVar) hyps in - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance - end } - end } + end + end (**************************************************************) (* Fresh names *) @@ -447,7 +444,7 @@ let find_name mayrepl decl naming gl = match naming with let assert_before_then_gen b naming t tac = let open Context.Rel.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENLAST (Proofview.V82.tactic @@ -456,7 +453,7 @@ let assert_before_then_gen b naming t tac = with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) - end } + end let assert_before_gen b naming t = assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ()) @@ -466,7 +463,7 @@ let assert_before_replacing id = assert_before_gen true (NamingMustBe (Loc.tag i let assert_after_then_gen b naming t tac = let open Context.Rel.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENFIRST (Proofview.V82.tactic @@ -475,7 +472,7 @@ let assert_after_then_gen b naming t tac = with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) - end } + end let assert_after_gen b naming t = assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ())) @@ -487,13 +484,12 @@ let assert_after_replacing id = assert_after_gen true (NamingMustBe (Loc.tag id) (* Fixpoints and CoFixpoints *) (**************************************************************) -let rec mk_holes : type r s. _ -> r Sigma.t -> (s, r) Sigma.le -> _ -> (_, s) Sigma.sigma = -fun env sigma p -> function -| [] -> Sigma ([], sigma, p) +let rec mk_holes env sigma = function +| [] -> (sigma, []) | arg :: rem -> - let Sigma (arg, sigma, q) = Evarutil.new_evar env sigma arg in - let Sigma (rem, sigma, r) = mk_holes env sigma (p +> q) rem in - Sigma (arg :: rem, sigma, r) + let (sigma, arg) = Evarutil.new_evar env sigma arg in + let (sigma, rem) = mk_holes env sigma rem in + (sigma, arg :: rem) let rec check_mutind env sigma k cl = match EConstr.kind sigma (strip_outer_cast sigma cl) with | Prod (na, c1, b) -> @@ -511,7 +507,7 @@ let rec check_mutind env sigma k cl = match EConstr.kind sigma (strip_outer_cast | _ -> error "Not enough products." (* Refine as a fixpoint *) -let mutual_fix f n rest j = Proofview.Goal.enter { enter = begin fun gl -> +let mutual_fix f n rest j = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -531,8 +527,8 @@ let mutual_fix f n rest j = Proofview.Goal.enter { enter = begin fun gl -> mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in - Refine.refine { run = begin fun sigma -> - let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl (List.map pi3 all) in + Refine.refine begin fun sigma -> + let (sigma, evs) = mk_holes nenv sigma (List.map pi3 all) in let ids = List.map pi1 all in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in @@ -540,17 +536,17 @@ let mutual_fix f n rest j = Proofview.Goal.enter { enter = begin fun gl -> let typarray = Array.of_list (List.map pi3 all) in let bodies = Array.of_list evs in let oterm = mkFix ((indxs,0),(funnames,typarray,bodies)) in - Sigma (oterm, sigma, p) - end } -end } + (sigma, oterm) + end +end let fix ido n = match ido with | None -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let name = Pfedit.get_current_proof_name () in let id = new_fresh_id [] name gl in mutual_fix id n [] 0 - end } + end | Some id -> mutual_fix id n [] 0 @@ -567,7 +563,7 @@ let rec check_is_mutcoind env sigma cl = error "All methods must construct elements in coinductive types." (* Refine as a cofixpoint *) -let mutual_cofix f others j = Proofview.Goal.enter { enter = begin fun gl -> +let mutual_cofix f others j = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -583,25 +579,25 @@ let mutual_cofix f others j = Proofview.Goal.enter { enter = begin fun gl -> mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in - Refine.refine { run = begin fun sigma -> + Refine.refine begin fun sigma -> let (ids, types) = List.split all in - let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl types in + let (sigma, evs) = mk_holes nenv sigma types in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in let funnames = Array.of_list (List.map (fun i -> Name i) ids) in let typarray = Array.of_list types in let bodies = Array.of_list evs in let oterm = mkCoFix (0, (funnames, typarray, bodies)) in - Sigma (oterm, sigma, p) - end } -end } + (sigma, oterm) + end +end let cofix ido = match ido with | None -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let name = Pfedit.get_current_proof_name () in let id = new_fresh_id [] name gl in mutual_cofix id [] 0 - end } + end | Some id -> mutual_cofix id [] 0 @@ -693,14 +689,14 @@ let bind_red_expr_occurrences occs nbcl redexp = certain hypothesis *) let reduct_in_concl (redfun,sty) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty - end } + end let reduct_in_hyp ?(check=false) redfun (id,where) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> convert_hyp ~check (pf_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl) - end } + end let revert_cast (redfun,kind as r) = if kind == DEFAULTcast then (redfun,REVERTcast) else r @@ -714,30 +710,32 @@ let reduct_option ?(check=false) redfun = function let pf_e_reduce_decl redfun where decl gl = let open Context.Named.Declaration in let sigma = Proofview.Goal.sigma gl in - let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma c in + let redfun sigma c = redfun (Tacmach.New.pf_env gl) sigma c in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then user_err (pr_id id ++ str " has no value."); - let Sigma (ty', sigma, p) = redfun sigma ty in - Sigma (LocalAssum (id, ty'), sigma, p) + let (sigma, ty') = redfun sigma ty in + (sigma, LocalAssum (id, ty')) | LocalDef (id,b,ty) -> - let Sigma (b', sigma, p) = if where != InHypTypeOnly then redfun sigma b else Sigma.here b sigma in - let Sigma (ty', sigma, q) = if where != InHypValueOnly then redfun sigma ty else Sigma.here ty sigma in - Sigma (LocalDef (id, b', ty'), sigma, p +> q) + let (sigma, b') = if where != InHypTypeOnly then redfun sigma b else (sigma, b) in + let (sigma, ty') = if where != InHypValueOnly then redfun sigma ty else (sigma, ty) in + (sigma, LocalDef (id, b', ty')) let e_reduct_in_concl ~check (redfun, sty) = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in - Sigma (convert_concl ~check c' sty, sigma, p) - end } + let (sigma, c') = redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_concl ~check c' sty) + end let e_reduct_in_hyp ?(check=false) redfun (id, where) = - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let Sigma (decl', sigma, p) = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in - Sigma (convert_hyp ~check decl', sigma, p) - end } + Proofview.Goal.enter begin fun gl -> + let (sigma, decl') = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_hyp ~check decl') + end let e_reduct_option ?(check=false) redfun = function | Some id -> e_reduct_in_hyp ~check (fst redfun) id @@ -747,11 +745,12 @@ let e_reduct_option ?(check=false) redfun = function from conversions. *) let e_change_in_concl (redfun,sty) = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.concl gl) in - Sigma (convert_concl_no_check c sty, sigma, p) - end } + let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.concl gl) in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_concl_no_check c sty) + end let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = let open Context.Named.Declaration in @@ -759,29 +758,29 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm | LocalAssum (id,ty) -> if where == InHypValueOnly then 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) + let (sigma, ty') = redfun false env sigma ty in + (sigma, LocalAssum (id, ty')) | LocalDef (id,b,ty) -> - let Sigma (b', sigma, p) = - if where != InHypTypeOnly then (redfun true).e_redfun env sigma b else Sigma.here b sigma + let (sigma, b') = + if where != InHypTypeOnly then redfun true env sigma b else (sigma, b) in - let Sigma (ty', sigma, q) = - if where != InHypValueOnly then (redfun false).e_redfun env sigma ty else Sigma.here ty sigma + let (sigma, ty') = + if where != InHypValueOnly then redfun false env sigma ty else (sigma, ty) in - Sigma (LocalDef (id,b',ty'), sigma, p +> q) + (sigma, LocalDef (id,b',ty')) let e_change_in_hyp redfun (id,where) = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in - let Sigma (c, sigma, p) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in - Sigma (convert_hyp c, sigma, p) - end } + let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_hyp c) + end -type change_arg = Pattern.patvar_map -> EConstr.constr Sigma.run +type change_arg = Pattern.patvar_map -> evar_map -> evar_map * EConstr.constr -let make_change_arg c pats = - { run = fun sigma -> Sigma.here (replace_vars (Id.Map.bindings pats) c) sigma } +let make_change_arg c pats sigma = (sigma, replace_vars (Id.Map.bindings pats) c) let check_types env sigma mayneedglobalcheck deep newc origc = let t1 = Retyping.get_type_of env sigma newc in @@ -805,33 +804,30 @@ let check_types env sigma mayneedglobalcheck deep newc origc = else sigma (* Now we introduce different instances of the previous tacticals *) -let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun env sigma c -> - let Sigma (t', sigma, p) = t.run sigma in - let sigma = Sigma.to_evar_map sigma in +let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = + let (sigma, t') = t 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 user_err ~hdr:"convert-check-hyp" (str "Not convertible."); - Sigma.Unsafe.of_pair (t', sigma) -end } + (sigma, t') (* Use cumulativity only if changing the conclusion not a subterm *) -let change_on_subterm cv_pb deep t where = { e_redfun = begin fun env sigma c -> +let change_on_subterm cv_pb deep t where env sigma c = let mayneedglobalcheck = ref false in - let Sigma (c, sigma, p) = match where with - | None -> (change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty)).e_redfun env sigma c + let (sigma, c) = match where with + | None -> change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c | Some occl -> - (e_contextually false occl + e_contextually false occl (fun subst -> - change_and_check Reduction.CONV mayneedglobalcheck true (t subst))).e_redfun + change_and_check Reduction.CONV mayneedglobalcheck true (t subst)) env sigma c in if !mayneedglobalcheck then begin - try ignore (Typing.unsafe_type_of env (Sigma.to_evar_map sigma) c) + try ignore (Typing.unsafe_type_of env sigma c) with e when catchable_exception e -> error "Replacement would lead to an ill-typed term." end; - Sigma (c, sigma, p) -end } + (sigma, c) let change_in_concl occl t = e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) @@ -844,7 +840,7 @@ let change_option occl t = function | None -> change_in_concl occl t let change chg c cls = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let cls = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in Tacticals.New.tclMAP (function | OnHyp (id,occs,where) -> @@ -852,7 +848,7 @@ let change chg c cls = | OnConcl occs -> change_option (bind_change_occurrences occs chg) c None) cls - end } + end let change_concl t = change_in_concl None (make_change_arg t) @@ -893,14 +889,14 @@ let reduce redexp cl = Pp.(hov 2 (Pputils.pr_red_expr pr str redexp)) in Proofview.Trace.name_tactic trace begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let cl' = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in let redexps = reduction_clause redexp cl' in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in Tacticals.New.tclMAP (fun (where,redexp) -> e_reduct_option ~check (Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp) where) redexps - end } + end end (* Unfolding occurrences of a constant *) @@ -936,7 +932,7 @@ let build_intro_tac id dest tac = match dest with let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let open Context.Rel.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in match EConstr.kind sigma concl with @@ -962,7 +958,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = Tacticals.New.tclZEROMSG (str "No product even after head-reduction.") | e -> Proofview.tclZERO ~info e end - end } + end let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ()) let intro_mustbe_force id = intro_gen (NamingMustBe (Loc.tag id)) MoveLast true false @@ -1027,14 +1023,14 @@ let get_previous_hyp_position id gl = aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let intro_replacing id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let next_hyp = get_next_hyp_position id gl in Tacticals.New.tclTHENLIST [ clear_for_replacing [id]; introduction id; move_hyp id next_hyp; ] - end } + end (* We have e.g. [x, y, y', x', y'' |- forall y y' y'', G] and want to reintroduce y, y,' y''. Note that we have to clear y, y' and y'' @@ -1046,7 +1042,7 @@ let intro_replacing id = (* the behavior of inversion *) let intros_possibly_replacing ids = let suboptimal = true in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN (Tacticals.New.tclMAP (fun id -> @@ -1055,16 +1051,16 @@ let intros_possibly_replacing ids = (Tacticals.New.tclMAP (fun (id,pos) -> Tacticals.New.tclORELSE (intro_move (Some id) pos) (intro_using id)) posl) - end } + end (* This version assumes that replacement is actually possible *) let intros_replacing ids = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN (clear_for_replacing ids) (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl) - end } + end (* User-level introduction tactics *) @@ -1078,7 +1074,7 @@ let lookup_hypothesis_as_renamed_gen red h gl = match lookup_hypothesis_as_renamed env (Tacmach.New.project gl) ccl h with | None when red -> let (redfun, _) = Redexpr.reduction_of_red_expr env (Red true) in - let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) ccl in + let (_, c) = redfun env (Proofview.Goal.sigma gl) ccl in aux c | x -> x in @@ -1108,10 +1104,10 @@ let depth_of_quantified_hypothesis red h gl = str".") let intros_until_gen red h = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let n = depth_of_quantified_hypothesis red h gl in Tacticals.New.tclDO n (if red then introf else intro) - end } + end let intros_until_id id = intros_until_gen false (NamedHyp id) let intros_until_n_gen red n = intros_until_gen red (AnonHyp n) @@ -1120,10 +1116,10 @@ let intros_until = intros_until_gen true let intros_until_n = intros_until_n_gen true let tclCHECKVAR id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let _ = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in Proofview.tclUNIT () - end } + end let try_intros_until_id_check id = Tacticals.New.tclORELSE (intros_until_id id) (tclCHECKVAR id) @@ -1138,9 +1134,6 @@ let rec intros_move = function Tacticals.New.tclTHEN (intro_gen (NamingMustBe (Loc.tag hyp)) destopt false false) (intros_move rest) -let run_delayed env sigma c = - Sigma.run sigma { Sigma.run = fun sigma -> c.delayed env sigma } - (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) @@ -1154,7 +1147,7 @@ let tactic_infer_flags with_evar = { let onOpenInductionArg env sigma tac = function | clear_flag,ElimOnConstr f -> - let (cbl, sigma') = run_delayed env sigma f in + let (sigma', cbl) = f env sigma in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma') (tac clear_flag (sigma,cbl)) @@ -1163,18 +1156,18 @@ let onOpenInductionArg env sigma tac = function (intros_until_n n) (Tacticals.New.onLastHyp (fun c -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in tac clear_flag (sigma,(c,NoBindings)) - end })) + end)) | clear_flag,ElimOnIdent (_,id) -> (* A quantified hypothesis *) Tacticals.New.tclTHEN (try_intros_until_id_check id) - (Proofview.Goal.enter { enter = begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in tac clear_flag (sigma,(mkVar id,NoBindings)) - end }) + end) let onInductionArg tac = function | clear_flag,ElimOnConstr cbl -> @@ -1195,11 +1188,10 @@ let map_destruction_arg f sigma = function | clear_flag,ElimOnIdent id as x -> (sigma,x) let finish_delayed_evar_resolution with_evars env sigma f = - let ((c, lbind), sigma') = run_delayed env sigma f in - let sigma' = Sigma.Unsafe.of_evar_map sigma' in + let (sigma', (c, lbind)) = f env sigma in let flags = tactic_infer_flags with_evars in - let Sigma (c, sigma', _) = finish_evar_resolution ~flags env sigma' (sigma,c) in - (Sigma.to_evar_map sigma', (c, lbind)) + let (sigma', c) = finish_evar_resolution ~flags env sigma' (sigma,c) in + (sigma', (c, lbind)) let with_no_bindings (c, lbind) = if lbind != NoBindings then error "'with' clause not supported here."; @@ -1215,7 +1207,7 @@ let force_destruction_arg with_evars env sigma c = let normalize_cut = false let cut c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -1233,20 +1225,20 @@ let cut c = let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in - Refine.refine ~unsafe:true { run = begin fun h -> - let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in - let Sigma (x, h, q) = Evarutil.new_evar env h c in + Refine.refine ~unsafe:true begin fun h -> + let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in + let (h, x) = Evarutil.new_evar env h c in let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in - Sigma (f, h, p +> q) - end } + (h, f) + end else Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") - end } + end let error_uninstantiated_metas t clenv = let t = EConstr.Unsafe.to_constr t in 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") + let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta.") in user_err (str "Cannot find an instance for " ++ pr_id id ++ str".") let check_unresolved_evars_of_metas sigma clenv = @@ -1305,13 +1297,13 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) let last_arg sigma c = match EConstr.kind sigma c with | App (f,cl) -> Array.last cl - | _ -> anomaly (Pp.str "last_arg") + | _ -> anomaly (Pp.str "last_arg.") let nth_arg sigma i c = if Int.equal i (-1) then last_arg sigma c else match EConstr.kind sigma c with | App (f,cl) -> cl.(i) - | _ -> anomaly (Pp.str "nth_arg") + | _ -> anomaly (Pp.str "nth_arg.") let index_of_ind_arg sigma t = let rec aux i j t = match EConstr.kind sigma t with @@ -1352,12 +1344,12 @@ let enforce_prop_bound_names rename tac = mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t') | _ -> assert false in let rename_branch i = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let t = Proofview.Goal.concl gl in change_concl (aux env sigma i t) - end } in + end in (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) tac (Array.map rename_branch nn) @@ -1372,7 +1364,7 @@ let rec contract_letin_in_lam_header sigma c = let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header sigma elim in @@ -1385,7 +1377,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in enforce_prop_bound_names rename (Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags) - end } + end (* * Elimination tactic with bindings and using an arbitrary @@ -1402,7 +1394,7 @@ type eliminator = { } let general_elim_clause_gen elimtac indclause elim = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (elimc,lbindelimc) = elim.elimbody in @@ -1410,10 +1402,10 @@ let general_elim_clause_gen elimtac indclause elim = let i = match elim.elimindex with None -> index_of_ind_arg sigma elimt | Some i -> i in elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause - end } + end let general_elim with_evars clear_flag (c, lbindc) elim = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ct = Retyping.get_type_of env sigma c in @@ -1425,32 +1417,30 @@ let general_elim with_evars clear_flag (c, lbindc) elim = Tacticals.New.tclTHEN (general_elim_clause_gen elimtac indclause elim) (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c) - end } + end (* Case analysis tactics *) let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in - let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in + let t = Retyping.get_type_of env sigma c in + let (mind,_) = reduce_to_quantified_ind env sigma t in let sort = Tacticals.New.elimination_sort_of_goal gl in - let mind = on_snd (fun u -> EInstance.kind (Sigma.to_evar_map sigma) u) mind in - let Sigma (elim, sigma, p) = - if occur_term (Sigma.to_evar_map sigma) c concl then + let mind = on_snd (fun u -> EInstance.kind sigma u) mind in + let (sigma, elim) = + if occur_term sigma c concl then build_case_analysis_scheme env sigma mind true sort else build_case_analysis_scheme_default env sigma mind sort in let elim = EConstr.of_constr elim in - let tac = + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (general_elim with_evars clear_flag (c,lbindc) {elimindex = None; elimbody = (elim,NoBindings); elimrename = Some (false, constructors_nrealdecls (fst mind))}) - in - Sigma (tac, sigma, p) - end } + end let general_case_analysis with_evars clear_flag (c,lbindc as cx) = Proofview.tclEVARMAP >>= fun sigma -> @@ -1486,13 +1476,11 @@ let find_eliminator c gl = let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE - (Proofview.Goal.s_enter { s_enter = begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let sigma, elim = find_eliminator c gl in - let tac = - (general_elim with_evars clear_flag cx elim) - in - Sigma.Unsafe.of_pair (tac, sigma) - end }) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (general_elim with_evars clear_flag cx elim) + end) begin function (e, info) -> match e with | IsNonrec -> (* For records, induction principles aren't there by default @@ -1540,7 +1528,7 @@ let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) id rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header sigma elim in @@ -1563,7 +1551,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id id sigma elimclause'' (fun id -> Proofview.tclUNIT ()) - end } + end let general_elim_clause with_evars flags id c e = let elim = match id with @@ -1622,7 +1610,7 @@ let make_projection env sigma params cstr sign elim i n c u = in elim let descend_in_conjunctions avoid tac (err, info) c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try @@ -1641,14 +1629,13 @@ let descend_in_conjunctions avoid tac (err, info) c = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> let u = EInstance.kind sigma u in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (elim, _, _) = build_case_analysis_scheme env sigma (ind,u) false sort in + let (_, elim) = build_case_analysis_scheme env sigma (ind,u) false sort in let elim = EConstr.of_constr elim in NotADefinedRecordUseScheme elim in Tacticals.New.tclORELSE0 (Tacticals.New.tclFIRST (List.init n (fun i -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match make_projection env sigma params cstr sign elim i n c u with @@ -1659,32 +1646,31 @@ let descend_in_conjunctions avoid tac (err, info) c = [Proofview.V82.tactic (refine p); (* Might be ill-typed due to forbidden elimination. *) Tacticals.New.onLastHypId (tac (not isrec))] - end }))) + end))) (Proofview.tclZERO ~info err) | None -> Proofview.tclZERO ~info err with RefinerError _|UserError _ -> Proofview.tclZERO ~info err - end } + end (****************************************************) (* Resolution tactics *) (****************************************************) let solve_remaining_apply_goals = - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + Proofview.Goal.enter begin fun gl -> + let evd = Proofview.Goal.sigma gl in if !apply_solve_class_goals then try let env = Proofview.Goal.env gl in - let evd = Sigma.to_evar_map sigma in let concl = Proofview.Goal.concl gl in if Typeclasses.is_class_type evd concl then let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in - let tac = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c' h } in - Sigma.Unsafe.of_pair (tac, evd') - else Sigma.here (Proofview.tclUNIT ()) sigma - with Not_found -> Sigma.here (Proofview.tclUNIT ()) sigma - else Sigma.here (Proofview.tclUNIT ()) sigma - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd') + (Refine.refine ~unsafe:true (fun h -> (h,c'))) + else Proofview.tclUNIT () + with Not_found -> Proofview.tclUNIT () + else Proofview.tclUNIT () + end let tclORELSEOPT t k = Proofview.tclORELSE t @@ -1695,7 +1681,7 @@ let tclORELSEOPT t k = | Some tac -> tac) let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : EConstr.constr with_bindings)) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let flags = @@ -1705,7 +1691,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : step. *) let concl_nprod = nb_prod_modulo_zeta sigma concl in let rec try_main_apply with_destruct c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1759,14 +1745,14 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : | PretypeError _|RefinerError _|UserError _|Failure _ -> Some (try_red_apply thm_ty0 (e, info)) | _ -> None) - end } + end in Tacticals.New.tclTHENLIST [ try_main_apply with_destruct c; solve_remaining_apply_goals; apply_clear_request clear_flag (use_clear_hyp_by_default ()) c ] - end } + end let rec apply_with_bindings_gen b e = function | [] -> Proofview.tclUNIT () @@ -1778,13 +1764,13 @@ let rec apply_with_bindings_gen b e = function let apply_with_delayed_bindings_gen b e l = let one k (loc, f) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - let (cb, sigma) = run_delayed env sigma f in + let (sigma, cb) = f env sigma in Tacticals.New.tclWITHHOLES e (general_apply b b e k (loc,cb)) sigma - end } + end in let rec aux = function | [] -> Proofview.tclUNIT () @@ -1861,7 +1847,7 @@ let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = let apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,(d,lbind))) tac = let open Context.Rel.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let flags = @@ -1870,7 +1856,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in let rec aux idstoclear with_destruct c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try @@ -1887,22 +1873,22 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming (descend_in_conjunctions [targetid] (fun b id -> aux (id::idstoclear) b (mkVar id)) (e, info) c) - end } + end in aux [] with_destruct d - end } + end let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,f)) tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let (c, sigma) = run_delayed env sigma f in + let (sigma, c) = f env sigma in Tacticals.New.tclWITHHOLES with_evars (apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,c)) tac) sigma - end } + end (* A useful resolution tactic which, if c:A->B, transforms |- C into |- B -> C and |- A @@ -1922,21 +1908,20 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam *) let cut_and_apply c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in match EConstr.kind sigma (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with | Prod (_,c1,c2) when Vars.noccurn sigma 1 c2 -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in - Refine.refine { run = begin fun sigma -> + Refine.refine begin fun sigma -> let typ = mkProd (Anonymous, c2, concl) in - let Sigma (f, sigma, p) = Evarutil.new_evar env sigma typ in - let Sigma (x, sigma, q) = Evarutil.new_evar env sigma c1 in - let ans = mkApp (f, [|mkApp (c, [|x|])|]) in - Sigma (ans, sigma, p +> q) - end } + let (sigma, f) = Evarutil.new_evar env sigma typ in + let (sigma, x) = Evarutil.new_evar env sigma c1 in + (sigma, mkApp (f, [|mkApp (c, [|x|])|])) + end | _ -> error "lapply needs a non-dependent product." - end } + end (********************************************************************) (* Exact tactics *) @@ -1949,42 +1934,38 @@ let cut_and_apply c = (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) let exact_no_check c = - Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } + Refine.refine ~unsafe:true (fun h -> (h,c)) let exact_check c = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in (** We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map sigma in let sigma, ct = Typing.type_of env sigma c in - let tac = - Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c)) + end let cast_no_check cast c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in exact_no_check (mkCast (c, cast, concl)) - end } + end let vm_cast_no_check c = cast_no_check Term.VMcast c let native_cast_no_check c = cast_no_check Term.NATIVEcast c let exact_proof c = let open Tacmach.New in - Proofview.Goal.enter { enter = begin fun gl -> - Refine.refine { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in + Proofview.Goal.enter begin fun gl -> + Refine.refine begin fun sigma -> let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (pf_concl gl) in let c = EConstr.of_constr c in let sigma = Evd.merge_universe_context sigma ctx in - Sigma.Unsafe.of_pair (c, sigma) - end } - end } + (sigma, c) + end + end let assumption = let rec arec gl only_eq = function @@ -2008,10 +1989,10 @@ let assumption = exact_no_check (mkVar (NamedDecl.get_id decl)) else arec gl only_eq rest in - let assumption_tac = { enter = begin fun gl -> + let assumption_tac gl = let hyps = Proofview.Goal.hyps gl in arec gl true hyps - end } in + in Proofview.Goal.enter assumption_tac (*****************************************************************) @@ -2050,7 +2031,7 @@ let check_decl env sigma decl = let clear_body ids = let open Context.Named.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let sigma = Tacmach.New.project gl in @@ -2095,10 +2076,10 @@ let clear_body ids = Tacticals.New.tclZEROMSG msg in check <*> - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> Evarutil.new_evar env sigma ~principal:true concl - end } - end } + end + end let clear_wildcards ids = Tacticals.New.tclMAP (fun (loc, id) -> clear [id]) ids @@ -2117,7 +2098,7 @@ let rec intros_clearing = function (* Keeping only a few hypotheses *) let keep hyps = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in @@ -2133,7 +2114,7 @@ let keep hyps = ~init:([],[]) (Proofview.Goal.env gl) in clear cl - end } + end (*********************************) (* Basic generalization tactics *) @@ -2144,16 +2125,16 @@ let keep hyps = this generalizes [hyps |- goal] into [hyps |- T] *) let apply_type newcl args = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in - Refine.refine { run = begin fun sigma -> - let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in - let Sigma (ev, sigma, p) = + Refine.refine begin fun sigma -> + let newcl = nf_betaiota sigma newcl (* As in former Logic.refine *) in + let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true ~store newcl in - Sigma (applist (ev, args), sigma, p) - end } - end } + (sigma, applist (ev, args)) + end + end (* Given a context [hyps] with domain [x1..xn], possibly with let-ins, and well-typed in the current goal, [bring_hyps hyps] generalizes @@ -2162,25 +2143,25 @@ let apply_type newcl args = let bring_hyps hyps = if List.is_empty hyps then Tacticals.New.tclIDTAC else - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let concl = Tacmach.New.pf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.of_list (Context.Named.to_instance mkVar hyps) in - Refine.refine { run = begin fun sigma -> - let Sigma (ev, sigma, p) = + Refine.refine begin fun sigma -> + let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true ~store newcl in - Sigma (mkApp (ev, args), sigma, p) - end } - end } + (sigma, mkApp (ev, args)) + end + end let revert hyps = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in (bring_hyps ctx) <*> (clear hyps) - end } + end (************************) (* Introduction tactics *) @@ -2197,7 +2178,7 @@ let check_number_of_constructors expctdnumopt i nconstr = if i > nconstr then error "Not enough constructors." let constructor_tac with_evars expctdnumopt i lbind = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let cl = Tacmach.New.pf_concl gl in let reduce_to_quantified_ind = @@ -2208,19 +2189,16 @@ let constructor_tac with_evars expctdnumopt i lbind = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; - let Sigma ((cons, u), sigma, p) = Sigma.fresh_constructor_instance + let (sigma, (cons, u)) = Evd.fresh_constructor_instance (Proofview.Goal.env gl) sigma (fst mind, i) in let cons = mkConstructU (cons, EInstance.make u) in let apply_tac = general_apply true false with_evars None (Loc.tag (cons,lbind)) in - let tac = - (Tacticals.New.tclTHENLIST - [ - convert_concl_no_check redcl DEFAULTcast; - intros; apply_tac]) - in - Sigma (tac, sigma, p) - end } + Tacticals.New.tclTHENLIST + [ Proofview.Unsafe.tclEVARS sigma; + convert_concl_no_check redcl DEFAULTcast; + intros; apply_tac] + end let one_constructor i lbind = constructor_tac false None i lbind @@ -2237,7 +2215,7 @@ let rec tclANY tac = function let any_constructor with_evars tacopt = let t = match tacopt with None -> Proofview.tclUNIT () | Some t -> t in let tac i = Tacticals.New.tclTHEN (constructor_tac with_evars None i NoBindings) t in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let cl = Tacmach.New.pf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl @@ -2247,7 +2225,7 @@ let any_constructor with_evars tacopt = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; tclANY tac (List.interval 1 nconstr) - end } + end let left_with_bindings with_evars = constructor_tac with_evars (Some 2) 1 let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2 @@ -2298,7 +2276,7 @@ let my_find_eq_data_decompose gl t = | Constr_matching.PatternMatchingFailure -> None let intro_decomp_eq ?loc l thin tac id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in @@ -2309,10 +2287,10 @@ let intro_decomp_eq ?loc l thin tac id = (eq,t,eq_args) (c, t) | None -> Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") - end } + end let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in @@ -2324,7 +2302,7 @@ let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id = (Tacticals.New.tclTHEN (simplest_ecase c) (clear [id])) (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) nv_with_let ll) - end } + end let rewrite_hyp_then assert_style with_evars thin l2r id tac = let rew_on l2r = @@ -2334,7 +2312,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let clear_var_and_eq id' = clear [id';id] in let early_clear id' thin = List.filter (fun (_,id) -> not (Id.equal id id')) thin in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in @@ -2366,7 +2344,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = thin in (* Skip the side conditions of the rewriting step *) Tacticals.New.tclTHENFIRST eqtac (tac thin) - end } + end let prepare_naming ?loc = function | IntroIdentifier id -> NamingMustBe (Loc.tag ?loc id) @@ -2525,10 +2503,8 @@ and intro_pattern_action ?loc with_evars b style pat thin destopt tac id = Proofview.tclUNIT () (* apply_in_once do a replacement *) else clear [id] in - let f = { delayed = fun env sigma -> - let Sigma (c, sigma, p) = f.delayed env sigma in - Sigma ((c, NoBindings), sigma, p) - } in + let f env sigma = let (sigma, c) = f env sigma in (sigma,(c, NoBindings)) + in apply_in_delayed_once false true true with_evars naming id (None,(loc',f)) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) @@ -2547,12 +2523,12 @@ and prepare_intros ?loc with_evars dft destopt = function (str "Introduction pattern for one hypothesis expected.") let intro_patterns_head_core with_evars b destopt bound pat = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in check_name_unicity env [] [] pat; intro_patterns_core with_evars b [] [] [] destopt bound 0 (fun _ l -> clear_wildcards l) pat - end } + end let intro_patterns_bound_to with_evars n destopt = intro_patterns_head_core with_evars true destopt @@ -2602,7 +2578,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars let tac (naming,lemma) tac id = apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id lemma tac in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let destopt = if with_evars then MoveLast (* evars would depend on the whole context *) else get_previous_hyp_position id gl in @@ -2614,7 +2590,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars in (* We chain apply_in_once, ending with an intro pattern *) List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id - end } + end (* if sidecond_first then @@ -2625,7 +2601,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars *) let apply_in simple with_evars id lemmas ipat = - let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, { delayed = fun _ sigma -> Sigma.here l sigma })) lemmas in + let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, (fun _ sigma -> (sigma,l)))) lemmas in general_apply_in false simple simple with_evars id lemmas ipat let apply_delayed_in simple with_evars id lemmas ipat = @@ -2649,17 +2625,16 @@ let decode_hyp = function *) let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let Sigma (t, sigma, p) = match ty with - | Some t -> Sigma.here t sigma + let (sigma, t) = match ty with + | Some t -> (sigma, t) | None -> let t = typ_of env sigma c in - let sigma, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env (Sigma.to_evar_map sigma) t in - Sigma.Unsafe.of_pair (c, sigma) + Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t in - let Sigma ((newcl, eq_tac), sigma, q) = match with_eq with + let (sigma, (newcl, eq_tac)) = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl @@ -2667,33 +2642,31 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = | IntroIdentifier id -> id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in - let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in + let (sigma, eq) = Evd.fresh_global env sigma eqdata.eq in let eq = EConstr.of_constr eq in - let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in + let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in let refl = EConstr.of_constr refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in - let sigma = Sigma.to_evar_map sigma in let sigma, _ = Typing.type_of env sigma term in let ans = term, - Tacticals.New.tclTHEN - (intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false) - (clear_body [heq;id]) + Tacticals.New.tclTHENLIST + [ + intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false; + clear_body [heq;id]] in - Sigma.Unsafe.of_pair (ans, sigma) + (sigma, ans) | None -> - Sigma.here (mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) sigma + (sigma, (mkNamedLetIn id c t ccl, Proofview.tclUNIT ())) in - let tac = Tacticals.New.tclTHENLIST - [ convert_concl_no_check newcl DEFAULTcast; + [ Proofview.Unsafe.tclEVARS sigma; + convert_concl_no_check newcl DEFAULTcast; intro_gen (NamingMustBe (Loc.tag id)) (decode_hyp lastlhyp) true false; Tacticals.New.tclMAP convert_hyp_no_check depdecls; eq_tac ] - in - Sigma (tac, sigma, p +> q) - end } + end let insert_before decls lasthyp env = match lasthyp with @@ -2725,22 +2698,22 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in - let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in + let (sigma, eq) = Evd.fresh_global env sigma eqdata.eq in let eq = EConstr.of_constr eq in - let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in + let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in let refl = EConstr.of_constr refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in - let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store ccl in - Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r) + let (sigma, x) = new_evar newenv sigma ~principal:true ~store ccl in + (sigma, mkNamedLetIn id c t (mkNamedLetIn heq refl eq x)) | None -> let newenv = insert_before [decl] lastlhyp env in - let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in - Sigma (mkNamedLetIn id c t x, sigma, p) + let (sigma, x) = new_evar newenv sigma ~principal:true ~store ccl in + (sigma, mkNamedLetIn id c t x) let letin_tac with_eq id c ty occs = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in @@ -2748,41 +2721,39 @@ let letin_tac with_eq id c ty occs = let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in (* We keep the original term to match but record the potential side-effects of unifying universes. *) - let Sigma (c, sigma, p) = match res with - | None -> Sigma.here c sigma - | Some (Sigma (_, sigma, p)) -> Sigma (c, sigma, p) + let (sigma, c) = match res with + | None -> (sigma, c) + | Some (sigma, _) -> (sigma, c) in - let tac = letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty in - Sigma (tac, sigma, p) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty) + end -let letin_pat_tac with_eq id c occs = - Proofview.Goal.s_enter { s_enter = begin fun gl -> +let letin_pat_tac with_evars with_eq id c occs = + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let check t = true in let abs = AbstractPattern (false,check,id,c,occs,false) in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in - let Sigma (c, sigma, p) = match res with - | None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c + let (sigma, c) = match res with + | None -> finish_evar_resolution ~flags:(tactic_infer_flags with_evars) env sigma c | Some res -> res in - let tac = - (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) - in - Sigma (tac, sigma, p) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) + end (* Tactics "pose proof" (usetac=None) and "assert"/"enough" (otherwise) *) let forward b usetac ipat c = match usetac with | None -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let t = Tacmach.New.pf_get_type_of gl c in let sigma = Tacmach.New.project gl in let hd = head_ident sigma c in Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (exact_no_check c) - end } + end | Some tac -> let tac = match tac with | None -> Tacticals.New.tclIDTAC @@ -2847,7 +2818,7 @@ let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let generalize_dep ?(with_let=false) c = let open Tacmach.New in let open Tacticals.New in - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let env = pf_env gl in let sign = Proofview.Goal.hyps gl in let sigma = project gl in @@ -2881,16 +2852,14 @@ let generalize_dep ?(with_let=false) c = (** Check that the generalization is indeed well-typed *) let (evd, _) = Typing.type_of env evd cl'' in let args = Context.Named.to_instance mkVar to_quantify_rev in - let tac = - tclTHEN - (apply_type cl'' (if Option.is_empty body then c::args else args)) - (clear (List.rev tothin')) - in - Sigma.Unsafe.of_pair (tac, evd) - end } + tclTHENLIST + [ Proofview.Unsafe.tclEVARS evd; + apply_type cl'' (if Option.is_empty body then c::args else args); + clear (List.rev tothin')] + end (** *) -let generalize_gen_let lconstr = Proofview.Goal.s_enter { s_enter = begin fun gl -> +let generalize_gen_let lconstr = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let newcl, evd = List.fold_right_i (generalize_goal gl) 0 lconstr @@ -2898,16 +2867,15 @@ let generalize_gen_let lconstr = Proofview.Goal.s_enter { s_enter = begin fun gl in let (evd, _) = Typing.type_of env evd newcl in let map ((_, c, b),_) = if Option.is_empty b then Some c else None in - let tac = apply_type newcl (List.map_filter map lconstr) in - Sigma.Unsafe.of_pair (tac, evd) -end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) + (apply_type newcl (List.map_filter map lconstr)) +end let new_generalize_gen_let lconstr = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in - let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in let newcl, sigma, args = @@ -2919,14 +2887,12 @@ let new_generalize_gen_let lconstr = (cl, sigma, args)) 0 lconstr (concl, sigma, []) in - let tac = - Refine.refine { run = begin fun sigma -> - let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true newcl in - Sigma ((applist (ev, args)), sigma, p) - end } - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Refine.refine begin fun sigma -> + let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true newcl in + (sigma, applist (ev, args)) + end) + end let generalize_gen lconstr = generalize_gen_let (List.map (fun (occs_c,na) -> @@ -2954,30 +2920,70 @@ let quantify lconstr = (* Modifying/Adding an hypothesis *) +(* Instantiating some arguments (whatever their position) of an hypothesis + or any term, leaving other arguments quantified. If operating on an + hypothesis of the goal, the new hypothesis replaces it. + + (c,lbind) are supposed to be of the form + ((t t1 t2 ... tm) , someBindings) + + in which case we pose a proof with body + + (fun y1...yp => H t1 t2 ... tm u1 ... uq) where yi are the + remaining arguments of H that lbind could not resolve, ui are a mix + of inferred args and yi. The overall effect is to remove from H as + much quantification as possible given lbind. *) let specialize (c,lbind) ipat = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in let sigma, term = if lbind == NoBindings then sigma, c else - let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma c) lbind in + let typ_of_c = Retyping.get_type_of env sigma c in + (* If the term is lambda then we put a letin to put avoid + interaction between the term and the bindings. *) + let c = match EConstr.kind sigma c with + | Lambda(_,_,_) -> + mkLetIn(Name.Anonymous, c, typ_of_c, (mkRel 1)) + | _ -> c in + let clause = make_clenv_binding env sigma (c,typ_of_c) lbind in let flags = { (default_unify_flags ()) with resolve_evars = true } in let clause = clenv_unify_meta_types ~flags clause in - let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in - let rec chk = function - | [] -> [] - | t::l -> if occur_meta clause.evd t then [] else t :: chk l - in - let tstack = chk tstack in - let term = applist(thd,List.map (nf_evar clause.evd) tstack) in - if occur_meta clause.evd term then - user_err (str "Cannot infer an instance for " ++ - - pr_name (meta_name clause.evd (List.hd (collect_metas clause.evd term))) ++ - str "."); - clause.evd, term in + let sigma = clause.evd in + let (thd,tstack) = whd_nored_stack sigma (clenv_value clause) in + let c_hd , c_args = decompose_app sigma c in + let liftrel x = + match kind sigma x with + | Rel n -> mkRel (n+1) + | _ -> x in + (* We grab names used in product to remember them at re-abstracting phase *) + let typ_of_c_hd = pf_get_type_of gl c_hd in + let lprod, concl = decompose_prod_assum sigma typ_of_c_hd in + (* accumulator args: arguments to apply to c_hd: all infered + args + re-abstracted rels *) + let rec rebuild_lambdas sigma lprd args hd l = + match lprd , l with + | _, [] -> sigma,applist (hd, (List.map (nf_evar sigma) args)) + | Context.Rel.Declaration.LocalAssum(nme,_)::lp' , t::l' when occur_meta sigma t -> + (* nme has not been resolved, let us re-abstract it. Same + name but type updated by instanciation of other args. *) + let sigma,new_typ_of_t = Typing.type_of clause.env sigma t in + let liftedargs = List.map liftrel args in + (* lifting rels in the accumulator args *) + let sigma,hd' = rebuild_lambdas sigma lp' (liftedargs@[mkRel 1 ]) hd l' in + (* replace meta variable by the abstracted variable *) + let hd'' = subst_term sigma t hd' in + (* lambda expansion *) + sigma,mkLambda (nme,new_typ_of_t,hd'') + | Context.Rel.Declaration.LocalAssum(_,_)::lp' , t::l' -> + let sigma,hd' = rebuild_lambdas sigma lp' (args@[t]) hd l' in + sigma,hd' + | _ ,_ -> assert false in + let sigma,hd = rebuild_lambdas sigma (List.rev lprod) [] c_hd tstack in + sigma, hd + in let typ = Retyping.get_type_of env sigma term in let tac = match EConstr.kind sigma (fst(EConstr.decompose_app sigma (snd(EConstr.decompose_lam_assum sigma c)))) with @@ -2994,7 +3000,9 @@ let specialize (c,lbind) ipat = | None -> (* Like generalize with extra support for "with" bindings *) (* even though the "with" bindings forces full application *) - Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term) + (* TODO: add intro to be more homogeneous. It will break + scripts but will be easy to fix *) + (Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term)) | Some (loc,ipat) -> (* Like pose proof with extra support for "with" bindings *) (* even though the "with" bindings forces full application *) @@ -3004,7 +3012,7 @@ let specialize (c,lbind) ipat = (exact_no_check term) in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac - end } + end (*****************************) (* Ad hoc unfold *) @@ -3014,7 +3022,7 @@ let specialize (c,lbind) ipat = (* Unfolds x by its definition everywhere *) let unfold_body x = let open Context.Named.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (** 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 @@ -3030,7 +3038,7 @@ let unfold_body x = let reductc = reduct_in_concl (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] end - end } + end (* Either unfold and clear if defined or simply clear if not a definition *) let expand_hyp id = Tacticals.New.tclTRY (unfold_body id) <*> clear [id] @@ -3075,7 +3083,7 @@ let warn_unused_intro_pattern = strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc (Miscprint.pr_intro_pattern - (fun c -> Printer.pr_econstr (fst (run_delayed (Global.env()) Evd.empty c)))) names) + (fun c -> Printer.pr_econstr (snd (c (Global.env()) Evd.empty)))) names) let check_unused_names names = if not (List.is_empty names) then @@ -3159,7 +3167,7 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = match ra with | (RecArg,_,deprec,recvarname) :: (IndArg,_,depind,hyprecname) :: ra' -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (recpat,names) = match names with | [loc,IntroNaming (IntroIdentifier id) as pat] -> let id' = next_ident_away (add_prefix "IH" id) avoid in @@ -3167,37 +3175,37 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = | _ -> consume_pattern avoid (Name recvarname) deprec gl names in let dest = get_recarg_dest dests in dest_intro_patterns with_evars avoid thin dest [recpat] (fun ids thin -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (hyprec,names) = consume_pattern avoid (Name hyprecname) depind gl names in dest_intro_patterns with_evars avoid thin MoveLast [hyprec] (fun ids' thin -> peel_tac ra' (update_dest dests ids') names thin) - end }) - end } + end) + end | (IndArg,_,dep,hyprecname) :: ra' -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = consume_pattern avoid (Name hyprecname) dep gl names in dest_intro_patterns with_evars avoid thin MoveLast [pat] (fun ids thin -> peel_tac ra' (update_dest dests ids) names thin) - end } + end | (RecArg,_,dep,recvarname) :: ra' -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (pat,names) = consume_pattern avoid (Name recvarname) dep gl names in let dest = get_recarg_dest dests in dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) - end } + end | (OtherArg,_,dep,_) :: ra' -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (pat,names) = consume_pattern avoid Anonymous dep gl names in let dest = get_recarg_dest dests in safe_dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) - end } + end | [] -> check_unused_names names; Tacticals.New.tclTHEN (clear_wildcards thin) (tac dests) @@ -3220,7 +3228,7 @@ let expand_projections env sigma c = (* Marche pas... faut prendre en compte l'occurrence précise... *) let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in @@ -3274,7 +3282,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (x::avoid)) in atomize_one (List.length argl) [] [] [] - end } + end (* [cook_sign] builds the lists [beforetoclear] (preceding the ind. var.) and [aftertoclear] (coming after the ind. var.) of hyps @@ -3519,27 +3527,28 @@ let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in user_err ~hdr:"Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") -let glob c = EConstr.of_constr (Universes.constr_of_global c) +let coq_eq sigma = Evarutil.new_global sigma (Coqlib.build_coq_eq ()) +let coq_eq_refl sigma = Evarutil.new_global sigma (Coqlib.build_coq_eq_refl ()) -let coq_eq = lazy (glob (Coqlib.build_coq_eq ())) -let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ())) +let coq_heq_ref = lazy (Coqlib.coq_reference"mkHEq" ["Logic";"JMeq"] "JMeq") +let coq_heq sigma = Evarutil.new_global sigma (Lazy.force coq_heq_ref) +let coq_heq_refl sigma = Evarutil.new_global sigma (Coqlib.coq_reference "mkHEq" ["Logic";"JMeq"] "JMeq_refl") -let coq_heq = lazy (EConstr.of_constr @@ Universes.constr_of_global (Coqlib.coq_reference"mkHEq" ["Logic";"JMeq"] "JMeq")) -let coq_heq_refl = lazy (EConstr.of_constr @@ Universes.constr_of_global (Coqlib.coq_reference "mkHEq" ["Logic";"JMeq"] "JMeq_refl")) +let mkEq sigma t x y = + let sigma, eq = coq_eq sigma in + sigma, mkApp (eq, [| t; x; y |]) -let mkEq t x y = - mkApp (Lazy.force coq_eq, [| t; x; y |]) +let mkRefl sigma t x = + let sigma, refl = coq_eq_refl sigma in + sigma, mkApp (refl, [| t; x |]) -let mkRefl t x = - mkApp (Lazy.force coq_eq_refl, [| t; x |]) +let mkHEq sigma t x u y = + let sigma, c = coq_heq sigma in + sigma, mkApp (c,[| t; x; u; y |]) -let mkHEq t x u y = - mkApp (Lazy.force coq_heq, - [| t; x; u; y |]) - -let mkHRefl t x = - mkApp (Lazy.force coq_heq_refl, - [| t; x |]) +let mkHRefl sigma t x = + let sigma, c = coq_heq_refl sigma in + sigma, mkApp (c, [| t; x |]) let lift_togethern n l = let l', _ = @@ -3577,23 +3586,29 @@ let decompose_indapp sigma f args = mkApp (f, pars), args | _ -> f, args -let mk_term_eq env sigma ty t ty' t' = - let sigma = Sigma.to_evar_map sigma in - if Reductionops.is_conv env sigma ty ty' then - mkEq ty t t', mkRefl ty' t' +let mk_term_eq homogeneous env sigma ty t ty' t' = + if homogeneous then + let sigma, eq = mkEq sigma ty t t' in + let sigma, refl = mkRefl sigma ty' t' in + sigma, (eq, refl) else - mkHEq ty t ty' t', mkHRefl ty' t' + let sigma, heq = mkHEq sigma ty t ty' t' in + let sigma, hrefl = mkHRefl sigma ty' t' in + sigma, (heq, hrefl) let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = let open Context.Rel.Declaration in - Refine.refine { run = begin fun sigma -> + Refine.refine begin fun sigma -> let eqslen = List.length eqs in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) - let abshypeq, abshypt = + let sigma, abshypeq, abshypt = if dep then - let eq, refl = mk_term_eq (push_rel_context ctx env) sigma (lift 1 c) (mkRel 1) typ (mkVar id) in - mkProd (Anonymous, eq, lift 1 concl), [| refl |] - else concl, [||] + let ty = lift 1 c in + let homogeneous = Reductionops.is_conv env sigma ty typ in + let sigma, (eq, refl) = + mk_term_eq homogeneous (push_rel_context ctx env) sigma ty (mkRel 1) typ (mkVar id) in + sigma, mkProd (Anonymous, eq, lift 1 concl), [| refl |] + else sigma, concl, [||] in (* Abstract by equalities *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) @@ -3607,7 +3622,7 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn genarg ctx in (* The goal will become this product. *) - let Sigma (genc, sigma, p) = Evarutil.new_evar env sigma ~principal:true genctyp in + let (sigma, genc) = Evarutil.new_evar env sigma ~principal:true genctyp in (* Apply the old arguments giving the proper instantiation of the hyp *) let instc = mkApp (genc, Array.of_list args) in (* Then apply to the original instantiated hyp. *) @@ -3615,8 +3630,8 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = (* Apply the reflexivity proofs on the indices. *) let appeqs = mkApp (instc, Array.of_list refls) in (* Finally, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) - Sigma (mkApp (appeqs, abshypt), sigma, p) - end } + (sigma, mkApp (appeqs, abshypt)) + end let hyps_of_vars env sigma sign nogen hyps = if Id.Set.is_empty hyps then [] @@ -3699,9 +3714,13 @@ let abstract_args gl generalize_vars dep id defined f args = let liftarg = lift (List.length ctx) arg in let eq, refl = if leq then - mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl (lift (-lenctx) ty) arg + let sigma', eq = mkEq !sigma (lift 1 ty) (mkRel 1) liftarg in + let sigma', refl = mkRefl sigma' (lift (-lenctx) ty) arg in + sigma := sigma'; eq, refl else - mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg + let sigma', eq = mkHEq !sigma (lift 1 ty) (mkRel 1) liftargty liftarg in + let sigma', refl = mkHRefl sigma' argty arg in + sigma := sigma'; eq, refl in let eqs = eq :: lift_list eqs in let refls = refl :: refls in @@ -3744,7 +3763,7 @@ let abstract_args gl generalize_vars dep id defined f args = let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let open Context.Named.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Coqlib.check_required_library Coqlib.jmeq_module_name; let sigma = Tacmach.New.project gl in let (f, args, def, id, oldid) = @@ -3780,7 +3799,7 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = [revert vars ; Tacticals.New.tclMAP (fun id -> Tacticals.New.tclTRY (generalize_dep ~with_let:true (mkVar id))) vars]) - end } + end let compare_upto_variables sigma x y = let rec compare x y = @@ -3801,17 +3820,19 @@ let specialize_eqs id gl = match EConstr.kind !evars ty with | Prod (na, t, b) -> (match EConstr.kind !evars t with - | App (eq, [| eqty; x; y |]) when EConstr.eq_constr !evars (Lazy.force coq_eq) eq -> + | App (eq, [| eqty; x; y |]) when EConstr.is_global !evars (Lazy.force coq_eq_ref) eq -> let c = if noccur_between !evars 1 (List.length ctx) x then y else x in - let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in - let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in + let pt = mkApp (eq, [| eqty; c; c |]) in + let ind = destInd !evars eq in + let p = mkApp (mkConstructUi (ind,0), [| eqty; c |]) in if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty - | App (heq, [| eqty; x; eqty'; y |]) when EConstr.eq_constr !evars heq (Lazy.force coq_heq) -> + | App (heq, [| eqty; x; eqty'; y |]) when EConstr.is_global !evars (Lazy.force coq_heq_ref) heq -> let eqt, c = if noccur_between !evars 1 (List.length ctx) x then eqty', y else eqty, x in - let pt = mkApp (Lazy.force coq_heq, [| eqt; c; eqt; c |]) in - let p = mkApp (Lazy.force coq_heq_refl, [| eqt; c |]) in + let pt = mkApp (heq, [| eqt; c; eqt; c |]) in + let ind = destInd !evars heq in + let p = mkApp (mkConstructUi (ind,0), [| eqt; c |]) in if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty @@ -3839,12 +3860,12 @@ let specialize_eqs id gl = else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl -let specialize_eqs id = Proofview.Goal.enter { enter = begin fun gl -> +let specialize_eqs id = Proofview.Goal.enter begin fun gl -> let msg = str "Specialization not allowed on dependent hypotheses" in Proofview.tclOR (clear [id]) (fun _ -> Tacticals.New.tclZEROMSG msg) >>= fun () -> Proofview.V82.tactic (specialize_eqs id) -end } +end let occur_rel sigma n c = let res = not (noccurn sigma n c) in @@ -4058,17 +4079,17 @@ let guess_elim isrec dep s hyp0 gl = if isrec && not (is_nonrec mind) then find_ind_eliminator mind s gl else let env = Tacmach.New.pf_env gl in - let sigma = Sigma.Unsafe.of_evar_map (Tacmach.New.project gl) in + let sigma = Tacmach.New.project gl in let u = EInstance.kind (Tacmach.New.project gl) u in if use_dependent_propositions_elimination () && dep then - let Sigma (ind, sigma, _) = build_case_analysis_scheme env sigma (mind, u) true s in + let (sigma, ind) = build_case_analysis_scheme env sigma (mind, u) true s in let ind = EConstr.of_constr ind in - (Sigma.to_evar_map sigma, ind) + (sigma, ind) else - let Sigma (ind, sigma, _) = build_case_analysis_scheme_default env sigma (mind, u) s in + let (sigma, ind) = build_case_analysis_scheme_default env sigma (mind, u) s in let ind = EConstr.of_constr ind in - (Sigma.to_evar_map sigma, ind) + (sigma, ind) in let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in evd, ((elimc, NoBindings), elimt), mkIndU (mind, u) @@ -4175,7 +4196,7 @@ let recolle_clenv i params args elimclause gl = produce new ones). Then refine with the resulting term with holes. *) let induction_tac with_evars params indvars elim = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in let i = match i with None -> index_of_ind_arg sigma elimt | Some i -> i in @@ -4188,17 +4209,16 @@ let induction_tac with_evars params indvars elim = (* one last resolution (useless?) *) let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in enforce_prop_bound_names rename (Clenvtac.clenv_refine with_evars resolved) - end } + end (* Apply induction "in place" taking into account dependent hypotheses from the context, replacing the main hypothesis on which induction applies with the induction hypotheses *) let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_tac = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map sigma in let concl = Tacmach.New.pf_concl gl in let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env sigma in let dep_in_concl = Option.cata (fun id -> occur_var env sigma id concl) false hyp0 in @@ -4228,16 +4248,16 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ (re_intro_dependent_hypotheses statuslists)) indsign names) in - Sigma.Unsafe.of_pair (tac, sigma) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac + end let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let elim_info = find_induction_type isrec elim hyp0 (Proofview.Goal.assume gl) in atomize_param_of_ind_then elim_info hyp0 (fun indvars -> apply_induction_in_context with_evars (Some hyp0) inhyps (pi3 elim_info) indvars names (fun elim -> induction_tac with_evars [] [hyp0] elim)) - end } + end let msg_not_right_number_induction_arguments scheme = str"Not the right number of induction arguments (expected " ++ @@ -4254,7 +4274,7 @@ let msg_not_right_number_induction_arguments scheme = must be given, so we help a bit the unifier by making the "pattern" by hand before calling induction_tac *) let induction_without_atomization isrec with_evars elim names lid = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma, (indsign,scheme) = get_elim_signature elim (List.hd lid) gl in let nargs_indarg_farg = scheme.nargs + (if scheme.farg_in_concl then 1 else 0) in @@ -4285,11 +4305,11 @@ let induction_without_atomization isrec with_evars elim names lid = ] in let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in apply_induction_in_context with_evars None [] elim indvars names induct_tac - end } + end (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> if occur_var (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id (Tacmach.New.pf_concl gl) && cls.concl_occs == NoOccurrences then user_err @@ -4307,10 +4327,9 @@ let clear_unselected_context id inhyps cls = let ids = List.map_filter to_erase (Proofview.Goal.hyps gl) in clear ids | None -> Proofview.tclUNIT () - end } + end let use_bindings env sigma elim must_be_closed (c,lbind) typ = - let sigma = Sigma.to_evar_map sigma in let typ = if elim == None then (* w/o an scheme, the term has to be applied at least until @@ -4332,8 +4351,7 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = if must_be_closed && occur_meta indclause.evd (clenv_value indclause) then error "Need a fully applied argument."; (* We lose the possibility of coercions in with-bindings *) - let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in - Sigma.Unsafe.of_pair (c, sigma) + pose_all_metas_as_evars env indclause.evd (clenv_value indclause) with e when catchable_exception e -> try find_clause (try_red_product env sigma typ) with Redelimination -> raise e in @@ -4351,7 +4369,6 @@ let check_expected_type env sigma (elimc,bl) elimt = fun t -> Evarconv.e_cumul env (ref sigma) t u let check_enough_applied env sigma elim = - let sigma = Sigma.to_evar_map sigma in (* A heuristic to decide whether the induction arg is enough applied *) match elim with | None -> @@ -4376,13 +4393,13 @@ let guard_no_unifiable = Proofview.guard_no_unifiable >>= function let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in let check = check_enough_applied env sigma elim in - let Sigma (c, sigma', p) = use_bindings env sigma elim false (c0,lbind) t0 in + let (sigma', c) = use_bindings env sigma elim false (c0,lbind) t0 in let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in match res with @@ -4392,7 +4409,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (* we restart using bindings after having tried type-class resolution etc. on the term given by the user *) let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in - let Sigma (c0, sigma, q) = finish_evar_resolution ~flags env sigma (pending,c0) in + let (sigma, c0) = finish_evar_resolution ~flags env sigma (pending,c0) in let tac = (if isrec then (* Historically, induction has side conditions last *) @@ -4401,13 +4418,12 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (* and destruct has side conditions first *) Tacticals.New.tclTHENLAST) (Tacticals.New.tclTHENLIST [ - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> let b = not with_evars && with_eq != None in - let Sigma (c, sigma, p) = use_bindings env sigma elim b (c0,lbind) t0 in - let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in - let Sigma (ans, sigma, q) = mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) in - Sigma (ans, sigma, p +> q) - end }; + let (sigma, c) = use_bindings env sigma elim b (c0,lbind) t0 in + let t = Retyping.get_type_of env sigma c in + mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) + end; if with_evars then Proofview.shelve_unifiable else guard_no_unifiable; if is_arg_pure_hyp then Proofview.tclEVARMAP >>= fun sigma -> Tacticals.New.tclTRY (clear [destVar sigma c0]) @@ -4416,23 +4432,23 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim ]) tac in - Sigma (tac, sigma, q) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac - | Some (Sigma (c, sigma', q)) -> + | Some (sigma', c) -> (* pattern found *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) let env = reset_with_named_context sign env in let tac = Tacticals.New.tclTHENLIST [ - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None - end }; + end; tac ] in - Sigma (tac, sigma', p +> q) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma') tac + end let has_generic_occurrences_but_goal cls id env sigma ccl = clause_with_generic_context_selection cls && @@ -4444,19 +4460,18 @@ let induction_gen clear_flag isrec with_evars elim let inhyps = match cls with | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps | _ -> [] in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let evd = Sigma.to_evar_map sigma in + let evd = Proofview.Goal.sigma gl in let ccl = Proofview.Goal.concl gl in let cls = Option.default allHypsAndConcl cls in - let t = typ_of env sigma c in + let t = typ_of env evd c in let is_arg_pure_hyp = isVar evd c && not (mem_named_context_val (destVar evd c) (Global.named_context_val ())) && lbind == NoBindings && not with_evars && Option.is_empty eqname && clear_flag == None && has_generic_occurrences_but_goal cls (destVar evd c) env evd ccl in - let enough_applied = check_enough_applied env sigma elim t in + let enough_applied = check_enough_applied env evd elim t in if is_arg_pure_hyp && enough_applied then (* First case: induction on a variable already in an inductive type and with maximal abstraction over the variable. @@ -4480,7 +4495,7 @@ let induction_gen clear_flag isrec with_evars elim isrec with_evars info_arg elim id arg t inhyps cls (induction_with_atomization_of_ind_arg isrec with_evars elim names id inhyps) - end } + end (* Induction on a list of arguments. First make induction arguments atomic (using letins), then do induction. The specificity here is @@ -4506,7 +4521,7 @@ let induction_gen_l isrec with_evars elim names lc = atomize_list l' | _ -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in let sigma = Tacmach.New.project gl in let x = @@ -4518,7 +4533,7 @@ let induction_gen_l isrec with_evars elim names lc = Tacticals.New.tclTHEN (letin_tac None (Name id) c None allHypsAndConcl) (atomize_list newl') - end } in + end in Tacticals.New.tclTHENLIST [ (atomize_list lc); @@ -4535,7 +4550,7 @@ let induction_destruct isrec with_evars (lc,elim) = match lc with | [] -> assert false (* ensured by syntax, but if called inside caml? *) | [c,(eqname,names as allnames),cls] -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match elim with @@ -4552,9 +4567,9 @@ let induction_destruct isrec with_evars (lc,elim) = (* standard induction *) onOpenInductionArg env sigma (fun clear_flag c -> induction_gen clear_flag isrec with_evars elim (c,allnames) cls) c - end } + end | _ -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match elim with @@ -4570,12 +4585,12 @@ let induction_destruct isrec with_evars (lc,elim) = (onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag isrec with_evars None (a,b) cl) a) (Tacticals.New.tclMAP (fun (a,b,cl) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag false with_evars None (a,b) cl) a - end }) l) + end) l) | Some elim -> (* Several induction hyps with induction scheme *) let lc = List.map (on_pi1 (fun c -> snd (force_destruction_arg false env sigma c))) lc in @@ -4594,7 +4609,7 @@ let induction_destruct isrec with_evars (lc,elim) = error "'as' clause with multiple arguments and 'using' clause can only occur last."; let newlc = List.map (fun (x,_) -> (x,None)) newlc in induction_gen_l isrec with_evars elim names newlc - end } + end let induction ev clr c l e = induction_gen clr true ev e @@ -4636,7 +4651,7 @@ let simple_destruct = function *) let elim_scheme_type elim t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clause = mk_clenv_type_of gl elim in match EConstr.kind clause.evd (last_arg clause.evd clause.templval.rebus) with | Meta mv -> @@ -4645,27 +4660,27 @@ let elim_scheme_type elim t = clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t (clenv_meta_type clause mv) clause in Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false - | _ -> anomaly (Pp.str "elim_scheme_type") - end } + | _ -> anomaly (Pp.str "elim_scheme_type.") + end let elim_type t = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in - Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t) + end let case_type t = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Tacmach.New.pf_env gl in - let ((ind, u), t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in - let u = EInstance.kind (Sigma.to_evar_map sigma) u in + let ((ind, u), t) = reduce_to_atomic_ind env sigma t in + let u = EInstance.kind sigma u in let s = Tacticals.New.elimination_sort_of_goal gl in - let Sigma (elimc, evd, p) = build_case_analysis_scheme_default env sigma (ind, u) s in + let (evd, elimc) = build_case_analysis_scheme_default env sigma (ind, u) s in let elimc = EConstr.of_constr elimc in - Sigma (elim_scheme_type elimc t, evd, p) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t) + end (************************************************) @@ -4685,7 +4700,7 @@ let maybe_betadeltaiota_concl allowred gl = whd_all env sigma concl let reflexivity_red allowred = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (* PL: usual reflexivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) @@ -4694,7 +4709,7 @@ let reflexivity_red allowred = match match_with_equality_type sigma concl with | None -> Proofview.tclZERO NoEquationFound | Some _ -> one_constructor 1 NoBindings - end } + end let reflexivity = Proofview.tclORELSE @@ -4736,7 +4751,7 @@ let match_with_equation sigma c = Proofview.tclZERO NoEquationFound let symmetry_red allowred = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (* PL: usual symmetry don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) @@ -4749,7 +4764,7 @@ let symmetry_red allowred = (convert_concl_no_check concl DEFAULTcast) (Tacticals.New.pf_constr_of_global eq_data.sym >>= apply) | None,eq,eq_kind -> prove_symmetry eq eq_kind - end } + end let symmetry = Proofview.tclORELSE @@ -4763,7 +4778,7 @@ let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make () let symmetry_in id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in let sign,t = decompose_prod_assum sigma ctype in @@ -4783,7 +4798,7 @@ let symmetry_in id = | NoEquationFound -> Hook.get forward_setoid_symmetry_in id | e -> Proofview.tclZERO ~info e end - end } + end let intros_symmetry = Tacticals.New.onClause @@ -4808,7 +4823,7 @@ let (forward_setoid_transitivity, setoid_transitivity) = Hook.make () (* This is probably not very useful any longer *) let prove_transitivity hdcncl eq_kind t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (eq1,eq2) = match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]) @@ -4828,10 +4843,10 @@ let prove_transitivity hdcncl eq_kind t = [ Tacticals.New.tclDO 2 intro; Tacticals.New.onLastHyp simplest_case; assumption ])) - end } + end let transitivity_red allowred t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (* PL: usual transitivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) @@ -4849,7 +4864,7 @@ let transitivity_red allowred t = match t with | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.") | Some t -> prove_transitivity eq eq_kind t - end } + end let transitivity_gen t = Proofview.tclORELSE @@ -4934,11 +4949,10 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let current_sign = Global.named_context_val () and global_sign = Proofview.Goal.hyps gl in - let sigma = Sigma.to_evar_map sigma in let evdref = ref sigma in let sign,secsign = List.fold_right @@ -5005,8 +5019,8 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = tacK lem args in let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in - Sigma.Unsafe.of_pair (tac, evd) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) tac + end let abstract_subproof ~opaque id gk tac = cache_term_by_tactic_then ~opaque id gk tac (fun lem args -> exact_no_check (applist (lem, args))) @@ -5033,7 +5047,7 @@ let tclABSTRACT ?(opaque=true) name_op tac = abstract_subproof ~opaque s gk tac let unify ?(state=full_transparent_state) x y = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in try let core_flags = @@ -5046,12 +5060,11 @@ let unify ?(state=full_transparent_state) x y = merge_unify_flags = core_flags; subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } } in - let sigma = Sigma.to_evar_map sigma in let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in - Sigma.Unsafe.of_pair (Proofview.tclUNIT (), sigma) + Proofview.Unsafe.tclEVARS sigma with e when CErrors.noncritical e -> - Sigma.here (Tacticals.New.tclFAIL 0 (str"Not unifiable")) sigma - end } + Tacticals.New.tclFAIL 0 (str"Not unifiable") + end module Simple = struct (** Simplified version of some of the above tactics *) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 07a803542..ec8fe1145 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -29,7 +29,7 @@ open Locus (** {6 General functions. } *) -val is_quantified_hypothesis : Id.t -> ('a, 'r) Proofview.Goal.t -> bool +val is_quantified_hypothesis : Id.t -> 'a Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) @@ -75,7 +75,7 @@ val intros : unit Proofview.tactic (** [depth_of_quantified_hypothesis b h g] returns the index of [h] in the conclusion of goal [g], up to head-reduction if [b] is [true] *) val depth_of_quantified_hypothesis : - bool -> quantified_hypothesis -> ('a, 'r) Proofview.Goal.t -> int + bool -> quantified_hypothesis -> 'a Proofview.Goal.t -> int val intros_until : quantified_hypothesis -> unit Proofview.tactic @@ -131,7 +131,7 @@ val exact_proof : Constrexpr.constr_expr -> unit Proofview.tactic type tactic_reduction = env -> evar_map -> constr -> constr -type change_arg = patvar_map -> constr Sigma.run +type change_arg = patvar_map -> evar_map -> evar_map * constr val make_change_arg : constr -> change_arg val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic @@ -211,8 +211,6 @@ val apply_delayed_in : (clear_flag * delayed_open_constr_with_bindings located) list -> intro_pattern option -> unit Proofview.tactic -val run_delayed : Environ.env -> evar_map -> 'a delayed_open -> 'a * evar_map - (** {6 Elimination tactics. } *) (* @@ -385,7 +383,7 @@ val letin_tac : (bool * intro_pattern_naming) option -> (** Common entry point for user-level "set", "pose" and "remember" *) -val letin_pat_tac : (bool * intro_pattern_naming) option -> +val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> Name.t -> (evar_map * constr) -> clause -> unit Proofview.tactic (** {6 Generalize tactics. } *) @@ -437,7 +435,7 @@ end module New : sig - val refine : ?unsafe:bool -> constr Sigma.run -> unit Proofview.tactic + val refine : ?unsafe:bool -> (evar_map -> evar_map * constr) -> unit Proofview.tactic (** [refine ?unsafe c] is [Refine.refine ?unsafe c] followed by beta-iota-reduction of the conclusion. *) diff --git a/test-suite/Makefile b/test-suite/Makefile index 285460762..e15094ccf 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -27,8 +27,8 @@ # Default value when called from a freshly compiled Coq, but can be # easily overridden -BIN := $(shell cd ..; readlink -f bin)/ LIB := $(shell cd ..; pwd) +BIN := $(LIB)/bin/ coqtop := $(BIN)coqtop -coqlib $(LIB) -boot -q -batch -test-mode -R prerequisite TestSuite coqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite @@ -45,7 +45,7 @@ REDIR := $(if $(VERBOSE),,> /dev/null 2>&1) # read out an emacs config and look for coq-prog-args; if such exists, return it get_coq_prog_args_helper = sed -n s'/^.*coq-prog-args:[[:space:]]*(\([^)]*\)).*/\1/p' $(1) -get_coq_prog_args = $(strip $(shell $(call get_coq_prog_args_helper,$(1)))) +get_coq_prog_args = $(strip $(shell $(call get_coq_prog_args_helper,$(1)))) SINGLE_QUOTE=" #" # double up on the quotes, in a comment, to appease the emacs syntax highlighter # wrap the arguments in parens, but only if they exist @@ -68,6 +68,7 @@ ifeq (,$(bogomips)) $(warning cannot run complexity tests (no bogomips found)) endif +# keep these synced with test-suite/save-logs.sh log_success = "==========> SUCCESS <==========" log_segfault = "==========> FAILURE <==========" log_anomaly = "==========> FAILURE <==========" @@ -164,7 +165,13 @@ summary.log: $(SHOW) BUILDING SUMMARY FILE $(HIDE)$(MAKE) --quiet summary > "$@" +# if not on travis we can get the log files (they're just there for a +# local build, and downloadable on GitLab) report: summary.log + $(HIDE)./save-logs.sh + $(HIDE)if [ -n "${TRAVIS}" ]; then echo 'travis_fold:start:coq.logs'; fi + $(HIDE)if [ -n "${TRAVIS}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec cat '{}' ';'; fi + $(HIDE)if [ -n "${TRAVIS}" ]; then echo 'travis_fold:end:coq.logs'; fi $(HIDE)if grep -q -F 'Error!' summary.log ; then echo FAILURES; grep -F 'Error!' summary.log; false; else echo NO FAILURES; fi ####################################################################### diff --git a/test-suite/bugs/closed/5233.v b/test-suite/bugs/closed/5233.v new file mode 100644 index 000000000..06286c740 --- /dev/null +++ b/test-suite/bugs/closed/5233.v @@ -0,0 +1,2 @@ +(* Implicit arguments on type were missing for recursive records *) +Inductive foo {A : Type} : Type := { Foo : foo }. diff --git a/test-suite/bugs/closed/5523.v b/test-suite/bugs/closed/5523.v new file mode 100644 index 000000000..d7582a379 --- /dev/null +++ b/test-suite/bugs/closed/5523.v @@ -0,0 +1,6 @@ +(* Support for complex constructions in recursive notations, especially "match". *) + +Definition Let_In {A P} (x : A) (f : forall a : A, P a) : P x := let y := x in f y. +Notation "'dlet' x , y := v 'in' ( a , b , .. , c )" + := (Let_In v (fun '(x, y) => pair .. (pair a b) .. c)) + (at level 0). diff --git a/test-suite/coq-makefile/native1/run.sh b/test-suite/coq-makefile/native1/run.sh index bc9f846dd..f07966263 100755 --- a/test-suite/coq-makefile/native1/run.sh +++ b/test-suite/coq-makefile/native1/run.sh @@ -3,7 +3,8 @@ #set -x set -e -if which ocamlopt; then +NATIVECOMP=`grep "let no_native_compiler = false" ../../../config/coq_config.ml`||true +if [[ `which ocamlopt` && $NATIVECOMP ]]; then . ../template/init.sh diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 4d59a92cb..f4ecfd736 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -98,5 +98,10 @@ fun n : nat => foo4 n (fun _ y : nat => ETA z : nat, (fun _ : nat => y = 0)) : nat -> Prop tele (t : Type) '(y, z) (x : t0) := tt : forall t : Type, nat * nat -> t -> fpack +[fun x : nat => x + 0;; fun x : nat => x + 1;; fun x : nat => x + 2] + : (nat -> nat) * + ((nat -> nat) * + ((nat -> nat) * + ((nat -> nat) * ((nat -> nat) * ((nat -> nat) * (nat -> nat)))))) foo5 x nat x : nat -> nat diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 96d831944..71536c68f 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -140,6 +140,12 @@ Notation "'tele' x .. z := b" := Check tele (t:Type) '((y,z):nat*nat) (x:t) := tt. +(* Checking that "fun" in a notation does not mixed up with the + detection of a recursive binder *) + +Notation "[ x ;; .. ;; y ]" := ((x,((fun u => S u), .. (y,(fun u => S u,fun v:nat => v)) ..))). +Check [ fun x => x+0 ;; fun x => x+1 ;; fun x => x+2 ]. + (* Cyprien's part of bug #4765 *) Notation foo5 x T y := (fun x : T => y). diff --git a/test-suite/output/Show.out b/test-suite/output/Show.out index bf1bf2809..ca56f032f 100644 --- a/test-suite/output/Show.out +++ b/test-suite/output/Show.out @@ -1,12 +1,10 @@ -3 subgoals (ID 29) +3 subgoals (ID 31) H : 0 = 0 ============================ 1 = 1 -subgoal 2 (ID 33) is: +subgoal 2 (ID 35) is: 1 = S (S m') -subgoal 3 (ID 20) is: +subgoal 3 (ID 22) is: S (S n') = S m - -(dependent evars: (printing disabled) ) diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index c70467912..d28ee4276 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -6,13 +6,13 @@ fun e : option L => match e with : option L -> option L fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H : forall m n p : nat, S m <= S n + p -> m <= n + p -fun n : nat => let x : T n := A n in ?t ?y : T n +fun n : nat => let y : T n := A n in ?t ?x : T n : forall n : nat, T n where -?t : [n : nat x := A n : T n |- ?T -> T n] -?y : [n : nat x := A n : T n |- ?T] -fun n : nat => ?t ?y : T n +?t : [n : nat y := A n : T n |- ?T -> T n] +?x : [n : nat y := A n : T n |- ?T] +fun n : nat => ?t ?x : T n : forall n : nat, T n where ?t : [n : nat |- ?T -> T n] -?y : [n : nat |- ?T] +?x : [n : nat |- ?T] diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index 1825db167..f761a4dc5 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -27,5 +27,5 @@ Check (fun m n p (H : S m <= (S n) + p) => le_S_n _ _ H). (* Note: exact numbers of evars are not important... *) Inductive T (n:nat) : Type := A : T n. -Check fun n (x:=A n:T n) => _ _ : T n. +Check fun n (y:=A n:T n) => _ _ : T n. Check fun n => _ _ : T n. diff --git a/test-suite/output/names.out b/test-suite/output/names.out index 9471b892d..48be63a46 100644 --- a/test-suite/output/names.out +++ b/test-suite/output/names.out @@ -3,3 +3,9 @@ In environment y : nat The term "a y" has type "{y0 : nat | y = y0}" while it is expected to have type "{x : nat | x = y}". +1 focused subgoal +(shelved: 1) + + H : ?n <= 3 -> 3 <= ?n -> ?n = 3 + ============================ + True diff --git a/test-suite/output/names.v b/test-suite/output/names.v index b3b5071a0..f1efd0df2 100644 --- a/test-suite/output/names.v +++ b/test-suite/output/names.v @@ -3,3 +3,7 @@ Parameter a : forall x, {y:nat|x=y}. Fail Definition b y : {x:nat|x=y} := a y. + +Goal (forall n m, n <= m -> m <= n -> n = m) -> True. +intro H; epose proof (H _ 3) as H. +Show. diff --git a/test-suite/save-logs.sh b/test-suite/save-logs.sh new file mode 100755 index 000000000..fb8a1c1b0 --- /dev/null +++ b/test-suite/save-logs.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +SAVEDIR="logs" + +# reset for local builds +rm -rf "$SAVEDIR" +mkdir "$SAVEDIR" + +# keep this synced with test-suite/Makefile +FAILMARK="==========> FAILURE <==========" + +FAILED=$(mktemp) +find . '(' -path ./bugs/opened -prune ')' -o '(' -name '*.log' -exec grep "$FAILMARK" -q '{}' ';' -print0 ')' > "$FAILED" + +rsync -a --from0 --files-from="$FAILED" . "$SAVEDIR" +cp summary.log "$SAVEDIR"/ + +# cleanup +rm "$FAILED" diff --git a/test-suite/success/Abstract.v b/test-suite/success/Abstract.v index ffd50f6ef..69dc9aca7 100644 --- a/test-suite/success/Abstract.v +++ b/test-suite/success/Abstract.v @@ -1,4 +1,3 @@ - (* Cf coqbugs #546 *) Require Import Omega. diff --git a/test-suite/success/ImplicitArguments.v b/test-suite/success/ImplicitArguments.v index f07773f8b..921433cad 100644 --- a/test-suite/success/ImplicitArguments.v +++ b/test-suite/success/ImplicitArguments.v @@ -27,3 +27,8 @@ Parameters (a:_) (b:a=0). Definition foo6 (x:=1) : forall {n:nat}, n=n := fun n => eq_refl. Fixpoint foo7 (x:=1) (n:nat) {p:nat} {struct n} : nat. + +(* Some example which should succeed with local implicit arguments *) + +Inductive A {P:forall m {n}, n=m -> Prop} := C : P 0 eq_refl -> A. +Inductive B (P:forall m {n}, n=m -> Prop) := D : P 0 eq_refl -> B P. diff --git a/test-suite/success/Record.v b/test-suite/success/Record.v index 8334322c9..6f27c1d36 100644 --- a/test-suite/success/Record.v +++ b/test-suite/success/Record.v @@ -87,3 +87,8 @@ Record R : Type := { P (A : Type) : Prop := exists x : A -> A, x = x; Q A : P A -> P A }. + +(* We allow reusing an implicit parameter named in non-recursive types *) +(* This is used in a couple of development such as UniMatch *) + +Record S {A:Type} := { a : A; b : forall A:Type, A }. diff --git a/test-suite/success/Scopes.v b/test-suite/success/Scopes.v index 43e3493c1..ca3746716 100644 --- a/test-suite/success/Scopes.v +++ b/test-suite/success/Scopes.v @@ -20,3 +20,9 @@ Inductive U := A. Bind Scope u with U. Notation "'ε'" := A : u. Definition c := ε : U. + +(* Check activation of type scope for tactics such as assert *) + +Goal True. +assert (nat * nat). + diff --git a/test-suite/success/coindprim.v b/test-suite/success/coindprim.v index 5b9265b6a..05ab91393 100644 --- a/test-suite/success/coindprim.v +++ b/test-suite/success/coindprim.v @@ -13,9 +13,10 @@ Definition eta {A} (s : Stream A) := {| hd := s.(hd); tl := s.(tl) |}. CoFixpoint ones := {| hd := 1; tl := ones |}. CoFixpoint ticks := {| hd := tt; tl := ticks |}. -CoInductive stream_equiv {A} {s : Stream A} {s' : Stream A} : Prop := - mkStreamEq { hdeq : s.(hd) = s'.(hd); tleq : stream_equiv _ s.(tl) s'.(tl) }. -Arguments stream_equiv {A} s s'. +CoInductive stream_equiv {A} (s : Stream A) (s' : Stream A) : Prop := + mkStreamEq { hdeq : s.(hd) = s'.(hd); tleq : stream_equiv s.(tl) s'.(tl) }. +Arguments hdeq {A} {s} {s'}. +Arguments tleq {A} {s} {s'}. Program CoFixpoint ones_eq : stream_equiv ones ones.(tl) := {| hdeq := eq_refl; tleq := ones_eq |}. @@ -88,4 +89,4 @@ Lemma eq (x : U) : x = force x. Proof. Fail destruct x. Abort. - (* Impossible *)
\ No newline at end of file + (* Impossible *) diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v index 4e2bf4511..82f726fa7 100644 --- a/test-suite/success/evars.v +++ b/test-suite/success/evars.v @@ -62,7 +62,7 @@ Check Check (fun f:(forall (v:Type->Type), v (v nat) -> nat) => f _ (Some (Some O))). -(* This used to fail with anomaly (Pp.str "evar was not declared") in V8.0pl3 *) +(* This used to fail with anomaly (Pp.str "evar was not declared.") in V8.0pl3 *) Theorem contradiction : forall p, ~ p -> p -> False. Proof. trivial. Qed. diff --git a/test-suite/success/forward.v b/test-suite/success/forward.v new file mode 100644 index 000000000..0ed5b524f --- /dev/null +++ b/test-suite/success/forward.v @@ -0,0 +1,18 @@ +(* Testing forward reasoning *) + +Goal 0=0. +Fail assert (_ = _). +eassert (_ = _)by reflexivity. +eassumption. +Qed. + +Goal 0=0. +Fail set (S ?[nl]). +eset (S ?[n]). +remember (S ?n) as x. +instantiate (n:=0). +Fail remember (S (S _)). +eremember (S (S ?[x])). +instantiate (x:=0). +reflexivity. +Qed. diff --git a/test-suite/success/specialize.v b/test-suite/success/specialize.v index 4b41a509e..f12db8b08 100644 --- a/test-suite/success/specialize.v +++ b/test-suite/success/specialize.v @@ -17,6 +17,29 @@ specialize (eq_trans (x:=a)(y:=b)). intros _. specialize (eq_trans H H0). intros _. specialize (eq_trans H0 (z:=b)). intros _. +(* incomplete bindings: y is left quantified and z is instantiated. *) +specialize eq_trans with (x:=a)(z:=c). +intro h. +(* y can be instantiated now *) +specialize h with (y:=b). +(* z was instantiated above so this must fail. *) +Fail specialize h with (z:=c). +clear h. + +(* incomplete bindings: 1st dep hyp is instantiated thus A, x and y + instantiated too. *) +specialize eq_trans with (1:=H). +intro h. +(* 2nd dep hyp can be instantiated now, which instatiates z too. *) +specialize h with (1:=H0). +(* checking that there is no more products in h. *) +match type of h with +| _ = _ => idtac +| _ => fail "specialize test failed: hypothesis h should be an equality at this point" +end. +clear h. + + (* local "in place" specialization *) assert (Eq:=eq_trans). @@ -31,6 +54,27 @@ specialize (Eq _ a b c). Undo. specialize (Eq _ _ _ _ H H0). Undo. specialize (Eq _ _ _ b H0). Undo. +(* incomplete binding *) +specialize Eq with (y:=b). +(* A and y have been instantiated so this works *) +specialize (Eq _ _ H H0). +Undo 2. + +(* incomplete binding (dependent) *) +specialize Eq with (1:=H). +(* A, x and y have been instantiated so this works *) +specialize (Eq _ H0). +Undo 2. + +(* incomplete binding (dependent) *) +specialize Eq with (1:=H) (2:=H0). +(* A, x and y have been instantiated so this works *) +match type of Eq with +| _ = _ => idtac +| _ => fail "specialize test failed: hypothesis Eq should be an equality at this point" +end. +Undo 2. + (* (** strange behavior to inspect more precisely *) @@ -40,7 +84,7 @@ specialize (Eq _ _ _ b H0). Undo. (* 2) echoue moins lorsque zero premise de mangé *) specialize eq_trans with (1:=Eq). (* mal typé !! *) -(* 3) *) +(* 3) Seems fixed.*) specialize eq_trans with _ a b c. intros _. (* Anomaly: Evar ?88 was not declared. Please report. *) *) diff --git a/theories/Arith/vo.itarget b/theories/Arith/vo.itarget deleted file mode 100644 index 0b3d31e98..000000000 --- a/theories/Arith/vo.itarget +++ /dev/null @@ -1,22 +0,0 @@ -PeanoNat.vo -Arith_base.vo -Arith.vo -Between.vo -Bool_nat.vo -Compare_dec.vo -Compare.vo -Div2.vo -EqNat.vo -Euclid.vo -Even.vo -Factorial.vo -Gt.vo -Le.vo -Lt.vo -Max.vo -Minus.vo -Min.vo -Mult.vo -Peano_dec.vo -Plus.vo -Wf_nat.vo diff --git a/theories/Bool/vo.itarget b/theories/Bool/vo.itarget deleted file mode 100644 index 24cbf4edc..000000000 --- a/theories/Bool/vo.itarget +++ /dev/null @@ -1,7 +0,0 @@ -BoolEq.vo -Bool.vo -Bvector.vo -DecBool.vo -IfProp.vo -Sumbool.vo -Zerob.vo diff --git a/theories/Classes/vo.itarget b/theories/Classes/vo.itarget deleted file mode 100644 index 18147f2a4..000000000 --- a/theories/Classes/vo.itarget +++ /dev/null @@ -1,15 +0,0 @@ -DecidableClass.vo -Equivalence.vo -EquivDec.vo -Init.vo -Morphisms_Prop.vo -Morphisms_Relations.vo -Morphisms.vo -RelationClasses.vo -SetoidClass.vo -SetoidDec.vo -SetoidTactics.vo -RelationPairs.vo -CRelationClasses.vo -CMorphisms.vo -CEquivalence.vo diff --git a/theories/Compat/vo.itarget b/theories/Compat/vo.itarget deleted file mode 100644 index 7ffb86ebb..000000000 --- a/theories/Compat/vo.itarget +++ /dev/null @@ -1,4 +0,0 @@ -AdmitAxiom.vo -Coq84.vo -Coq85.vo -Coq86.vo diff --git a/theories/FSets/vo.itarget b/theories/FSets/vo.itarget deleted file mode 100644 index 0e7c11fb0..000000000 --- a/theories/FSets/vo.itarget +++ /dev/null @@ -1,21 +0,0 @@ -FMapAVL.vo -FMapFacts.vo -FMapFullAVL.vo -FMapInterface.vo -FMapList.vo -FMapPositive.vo -FMaps.vo -FMapWeakList.vo -FSetCompat.vo -FSetAVL.vo -FSetPositive.vo -FSetBridge.vo -FSetDecide.vo -FSetEqProperties.vo -FSetFacts.vo -FSetInterface.vo -FSetList.vo -FSetProperties.vo -FSets.vo -FSetToFiniteSet.vo -FSetWeakList.vo diff --git a/theories/Init/vo.itarget b/theories/Init/vo.itarget deleted file mode 100644 index 99877065e..000000000 --- a/theories/Init/vo.itarget +++ /dev/null @@ -1,11 +0,0 @@ -Datatypes.vo -Logic_Type.vo -Logic.vo -Notations.vo -Peano.vo -Prelude.vo -Specif.vo -Tactics.vo -Wf.vo -Nat.vo -Tauto.vo diff --git a/theories/Lists/vo.itarget b/theories/Lists/vo.itarget deleted file mode 100644 index 82dd1be82..000000000 --- a/theories/Lists/vo.itarget +++ /dev/null @@ -1,8 +0,0 @@ -ListSet.vo -ListTactics.vo -List.vo -ListDec.vo -SetoidList.vo -SetoidPermutation.vo -StreamMemo.vo -Streams.vo diff --git a/theories/MSets/vo.itarget b/theories/MSets/vo.itarget deleted file mode 100644 index 7c5b68995..000000000 --- a/theories/MSets/vo.itarget +++ /dev/null @@ -1,13 +0,0 @@ -MSetGenTree.vo -MSetAVL.vo -MSetRBT.vo -MSetDecide.vo -MSetEqProperties.vo -MSetFacts.vo -MSetInterface.vo -MSetList.vo -MSetProperties.vo -MSets.vo -MSetToFiniteSet.vo -MSetWeakList.vo -MSetPositive.vo
\ No newline at end of file diff --git a/theories/NArith/vo.itarget b/theories/NArith/vo.itarget deleted file mode 100644 index e76033f78..000000000 --- a/theories/NArith/vo.itarget +++ /dev/null @@ -1,10 +0,0 @@ -BinNatDef.vo -BinNat.vo -NArith.vo -Ndec.vo -Ndigits.vo -Ndist.vo -Nnat.vo -Ndiv_def.vo -Nsqrt_def.vo -Ngcd_def.vo
\ No newline at end of file diff --git a/theories/Numbers/vo.itarget b/theories/Numbers/vo.itarget deleted file mode 100644 index c69af03fc..000000000 --- a/theories/Numbers/vo.itarget +++ /dev/null @@ -1,91 +0,0 @@ -BinNums.vo -BigNumPrelude.vo -Cyclic/Abstract/CyclicAxioms.vo -Cyclic/Abstract/NZCyclic.vo -Cyclic/DoubleCyclic/DoubleAdd.vo -Cyclic/DoubleCyclic/DoubleBase.vo -Cyclic/DoubleCyclic/DoubleCyclic.vo -Cyclic/DoubleCyclic/DoubleDivn1.vo -Cyclic/DoubleCyclic/DoubleDiv.vo -Cyclic/DoubleCyclic/DoubleLift.vo -Cyclic/DoubleCyclic/DoubleMul.vo -Cyclic/DoubleCyclic/DoubleSqrt.vo -Cyclic/DoubleCyclic/DoubleSub.vo -Cyclic/DoubleCyclic/DoubleType.vo -Cyclic/Int31/Int31.vo -Cyclic/Int31/Cyclic31.vo -Cyclic/Int31/Ring31.vo -Cyclic/ZModulo/ZModulo.vo -Integer/Abstract/ZAddOrder.vo -Integer/Abstract/ZAdd.vo -Integer/Abstract/ZAxioms.vo -Integer/Abstract/ZBase.vo -Integer/Abstract/ZLt.vo -Integer/Abstract/ZMulOrder.vo -Integer/Abstract/ZMul.vo -Integer/Abstract/ZSgnAbs.vo -Integer/Abstract/ZDivFloor.vo -Integer/Abstract/ZDivTrunc.vo -Integer/Abstract/ZDivEucl.vo -Integer/Abstract/ZMaxMin.vo -Integer/Abstract/ZParity.vo -Integer/Abstract/ZPow.vo -Integer/Abstract/ZGcd.vo -Integer/Abstract/ZLcm.vo -Integer/Abstract/ZBits.vo -Integer/Abstract/ZProperties.vo -Integer/BigZ/BigZ.vo -Integer/BigZ/ZMake.vo -Integer/Binary/ZBinary.vo -Integer/NatPairs/ZNatPairs.vo -Integer/SpecViaZ/ZSig.vo -Integer/SpecViaZ/ZSigZAxioms.vo -NaryFunctions.vo -NatInt/NZAddOrder.vo -NatInt/NZAdd.vo -NatInt/NZAxioms.vo -NatInt/NZBase.vo -NatInt/NZMulOrder.vo -NatInt/NZMul.vo -NatInt/NZOrder.vo -NatInt/NZProperties.vo -NatInt/NZDomain.vo -NatInt/NZParity.vo -NatInt/NZDiv.vo -NatInt/NZPow.vo -NatInt/NZSqrt.vo -NatInt/NZLog.vo -NatInt/NZGcd.vo -NatInt/NZBits.vo -Natural/Abstract/NAddOrder.vo -Natural/Abstract/NAdd.vo -Natural/Abstract/NAxioms.vo -Natural/Abstract/NBase.vo -Natural/Abstract/NDefOps.vo -Natural/Abstract/NIso.vo -Natural/Abstract/NMulOrder.vo -Natural/Abstract/NOrder.vo -Natural/Abstract/NStrongRec.vo -Natural/Abstract/NSub.vo -Natural/Abstract/NProperties.vo -Natural/Abstract/NDiv.vo -Natural/Abstract/NMaxMin.vo -Natural/Abstract/NParity.vo -Natural/Abstract/NPow.vo -Natural/Abstract/NSqrt.vo -Natural/Abstract/NLog.vo -Natural/Abstract/NGcd.vo -Natural/Abstract/NLcm.vo -Natural/Abstract/NBits.vo -Natural/BigN/BigN.vo -Natural/BigN/Nbasic.vo -Natural/BigN/NMake_gen.vo -Natural/BigN/NMake.vo -Natural/Binary/NBinary.vo -Natural/Peano/NPeano.vo -Natural/SpecViaZ/NSigNAxioms.vo -Natural/SpecViaZ/NSig.vo -NumPrelude.vo -Rational/BigQ/BigQ.vo -Rational/BigQ/QMake.vo -Rational/SpecViaQ/QSig.vo diff --git a/theories/PArith/vo.itarget b/theories/PArith/vo.itarget deleted file mode 100644 index 73044e2c1..000000000 --- a/theories/PArith/vo.itarget +++ /dev/null @@ -1,5 +0,0 @@ -BinPosDef.vo -BinPos.vo -Pnat.vo -POrderedType.vo -PArith.vo
\ No newline at end of file diff --git a/theories/Program/vo.itarget b/theories/Program/vo.itarget deleted file mode 100644 index 864c815ae..000000000 --- a/theories/Program/vo.itarget +++ /dev/null @@ -1,9 +0,0 @@ -Basics.vo -Combinators.vo -Equality.vo -Program.vo -Subset.vo -Syntax.vo -Tactics.vo -Utils.vo -Wf.vo diff --git a/theories/QArith/vo.itarget b/theories/QArith/vo.itarget deleted file mode 100644 index b550b4712..000000000 --- a/theories/QArith/vo.itarget +++ /dev/null @@ -1,13 +0,0 @@ -Qabs.vo -QArith_base.vo -QArith.vo -Qcanon.vo -Qcabs.vo -Qfield.vo -Qpower.vo -Qreals.vo -Qreduction.vo -Qring.vo -Qround.vo -QOrderedType.vo -Qminmax.vo
\ No newline at end of file diff --git a/theories/Reals/vo.itarget b/theories/Reals/vo.itarget deleted file mode 100644 index 0c8f0b976..000000000 --- a/theories/Reals/vo.itarget +++ /dev/null @@ -1,62 +0,0 @@ -Alembert.vo -AltSeries.vo -ArithProp.vo -Binomial.vo -Cauchy_prod.vo -Cos_plus.vo -Cos_rel.vo -DiscrR.vo -Exp_prop.vo -Integration.vo -Machin.vo -MVT.vo -NewtonInt.vo -PartSum.vo -PSeries_reg.vo -Ranalysis1.vo -Ranalysis2.vo -Ranalysis3.vo -Ranalysis4.vo -Ranalysis5.vo -Ranalysis.vo -Ranalysis_reg.vo -Ratan.vo -Raxioms.vo -Rbase.vo -Rbasic_fun.vo -Rcomplete.vo -Rdefinitions.vo -Rderiv.vo -Reals.vo -Rfunctions.vo -Rgeom.vo -RiemannInt_SF.vo -RiemannInt.vo -R_Ifp.vo -RIneq.vo -Rlimit.vo -RList.vo -Rlogic.vo -Rpow_def.vo -Rpower.vo -Rprod.vo -Rseries.vo -Rsigma.vo -Rsqrt_def.vo -R_sqrt.vo -R_sqr.vo -Rtopology.vo -Rtrigo_alt.vo -Rtrigo_calc.vo -Rtrigo_def.vo -Rtrigo_fun.vo -Rtrigo_reg.vo -Rtrigo1.vo -Rtrigo.vo -SeqProp.vo -SeqSeries.vo -SplitAbsolu.vo -SplitRmult.vo -Sqrt_reg.vo -ROrderedType.vo -Rminmax.vo diff --git a/theories/Relations/vo.itarget b/theories/Relations/vo.itarget deleted file mode 100644 index 9d81dd07a..000000000 --- a/theories/Relations/vo.itarget +++ /dev/null @@ -1,4 +0,0 @@ -Operators_Properties.vo -Relation_Definitions.vo -Relation_Operators.vo -Relations.vo diff --git a/theories/Setoids/vo.itarget b/theories/Setoids/vo.itarget deleted file mode 100644 index 8d608cf75..000000000 --- a/theories/Setoids/vo.itarget +++ /dev/null @@ -1 +0,0 @@ -Setoid.vo
\ No newline at end of file diff --git a/theories/Sets/vo.itarget b/theories/Sets/vo.itarget deleted file mode 100644 index 9ebe92f52..000000000 --- a/theories/Sets/vo.itarget +++ /dev/null @@ -1,22 +0,0 @@ -Classical_sets.vo -Constructive_sets.vo -Cpo.vo -Ensembles.vo -Finite_sets_facts.vo -Finite_sets.vo -Image.vo -Infinite_sets.vo -Integers.vo -Multiset.vo -Partial_Order.vo -Permut.vo -Powerset_Classical_facts.vo -Powerset_facts.vo -Powerset.vo -Relations_1_facts.vo -Relations_1.vo -Relations_2_facts.vo -Relations_2.vo -Relations_3_facts.vo -Relations_3.vo -Uniset.vo diff --git a/theories/Sorting/vo.itarget b/theories/Sorting/vo.itarget deleted file mode 100644 index 079eaad18..000000000 --- a/theories/Sorting/vo.itarget +++ /dev/null @@ -1,7 +0,0 @@ -Heap.vo -Permutation.vo -PermutSetoid.vo -PermutEq.vo -Sorted.vo -Sorting.vo -Mergesort.vo diff --git a/theories/Strings/vo.itarget b/theories/Strings/vo.itarget deleted file mode 100644 index 20813b427..000000000 --- a/theories/Strings/vo.itarget +++ /dev/null @@ -1,2 +0,0 @@ -Ascii.vo -String.vo diff --git a/theories/Structures/vo.itarget b/theories/Structures/vo.itarget deleted file mode 100644 index 674e9fba9..000000000 --- a/theories/Structures/vo.itarget +++ /dev/null @@ -1,14 +0,0 @@ -Equalities.vo -EqualitiesFacts.vo -Orders.vo -OrdersEx.vo -OrdersFacts.vo -OrdersLists.vo -OrdersTac.vo -OrdersAlt.vo -GenericMinMax.vo -DecidableType.vo -DecidableTypeEx.vo -OrderedTypeAlt.vo -OrderedTypeEx.vo -OrderedType.vo diff --git a/theories/Unicode/vo.itarget b/theories/Unicode/vo.itarget deleted file mode 100644 index 7be1b9961..000000000 --- a/theories/Unicode/vo.itarget +++ /dev/null @@ -1,2 +0,0 @@ -Utf8.vo -Utf8_core.vo diff --git a/theories/Vectors/vo.itarget b/theories/Vectors/vo.itarget deleted file mode 100644 index 779b1821c..000000000 --- a/theories/Vectors/vo.itarget +++ /dev/null @@ -1,5 +0,0 @@ -Fin.vo -VectorDef.vo -VectorSpec.vo -VectorEq.vo -Vector.vo diff --git a/theories/Wellfounded/vo.itarget b/theories/Wellfounded/vo.itarget deleted file mode 100644 index 034d53106..000000000 --- a/theories/Wellfounded/vo.itarget +++ /dev/null @@ -1,9 +0,0 @@ -Disjoint_Union.vo -Inclusion.vo -Inverse_Image.vo -Lexicographic_Exponentiation.vo -Lexicographic_Product.vo -Transitive_Closure.vo -Union.vo -Wellfounded.vo -Well_Ordering.vo diff --git a/theories/ZArith/vo.itarget b/theories/ZArith/vo.itarget deleted file mode 100644 index 178111cdf..000000000 --- a/theories/ZArith/vo.itarget +++ /dev/null @@ -1,33 +0,0 @@ -auxiliary.vo -BinIntDef.vo -BinInt.vo -Int.vo -Wf_Z.vo -Zabs.vo -ZArith_base.vo -ZArith_dec.vo -ZArith.vo -Zdigits.vo -Zbool.vo -Zcompare.vo -Zcomplements.vo -Zdiv.vo -Zeven.vo -Zgcd_alt.vo -Zpow_alt.vo -Zhints.vo -Zlogarithm.vo -Zmax.vo -Zminmax.vo -Zmin.vo -Zmisc.vo -Znat.vo -Znumtheory.vo -Zquot.vo -Zorder.vo -Zpow_def.vo -Zpower.vo -Zpow_facts.vo -Zsqrt_compat.vo -Zwf.vo -Zeuclid.vo diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 13a57a37d..c25ad1f37 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -374,7 +374,7 @@ uninstall:: instf="$(DESTDIR)$(COQLIBINSTALL)/$$df/`basename $$f`"; \ rm -f "$$instf";\ echo RM "$$instf"; \ - rmdir --ignore-fail-on-non-empty "$(DESTDIR)$(COQLIBINSTALL)/$$df/"; \ + rmdir "$(DESTDIR)$(COQLIBINSTALL)/$$df/" || true; \ done .PHONY: uninstall @@ -384,8 +384,7 @@ uninstall-doc:: $(HIDE)rm -rf "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" $(SHOW)'RM $(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' $(HIDE)rm -rf "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" - $(HIDE)rmdir --ignore-fail-on-non-empty \ - "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" + $(HIDE) rmdir "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" || true .PHONY: uninstall-doc # Cleaning #################################################################### diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 78c92e68b..8e2f75fc9 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -119,14 +119,8 @@ let read_whole_file s = Buffer.contents b let makefile_template = - let open Filename in let template = "/tools/CoqMakefile.in" in - if Coq_config.local then - let coqbin = CUnix.canonical_path_name (dirname Sys.executable_name) in - dirname coqbin ^ template - else match Coq_config.coqlib with - | None -> assert false - | Some dir -> dir ^ template + Coq_config.coqlib ^ template let quote s = if String.contains s ' ' then "\"" ^ s ^ "\"" else s diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 6e7935d09..f5e93527c 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -36,6 +36,10 @@ let norec_dirs = ref StrSet.empty let suffixe = ref ".vo" +[@@@ocaml.warning "-3"] (* String.capitalize_ascii since 4.03.0 GPR#124 *) +let capitalize = String.capitalize +[@@@ocaml.warning "+3"] + type dir = string option (** [get_extension f l] checks whether [f] has one of the extensions @@ -455,7 +459,7 @@ let mL_dependencies () = printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname (String.concat " " dep); printf "%s.cmo:$(addsuffix .cmo,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; printf "%s.cmx:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; - let efullname_capital = String.capitalize (Filename.basename efullname) in + let efullname_capital = capitalize (Filename.basename efullname) in List.iter (fun dep -> printf "%s.cmx : FOR_PACK=-for-pack %s\n" dep efullname_capital) dep; diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index eb233b8f9..c68c34bbb 100644 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -39,6 +39,10 @@ let syntax_error lexbuf = raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) + + [@@@ocaml.warning "-3"] (* String.uncapitalize_ascii since 4.03.0 GPR#124 *) + let uncapitalize = String.uncapitalize + [@@@ocaml.warning "+3"] } let space = [' ' '\t' '\n' '\r'] @@ -154,7 +158,7 @@ and caml_action = parse | space + { caml_action lexbuf } | "open" space* (caml_up_ident as id) - { Use_module (String.uncapitalize id) } + { Use_module (uncapitalize id) } | "module" space+ caml_up_ident { caml_action lexbuf } | caml_low_ident { caml_action lexbuf } @@ -321,12 +325,12 @@ and modules mllist = parse and qual_id ml_module_name = parse | '.' [^ '.' '(' '['] - { Use_module (String.uncapitalize ml_module_name) } + { Use_module (uncapitalize ml_module_name) } | eof { raise Fin_fichier } | _ { caml_action lexbuf } and mllib_list = parse - | caml_up_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf) + | caml_up_ident { let s = uncapitalize (Lexing.lexeme lexbuf) in s :: mllib_list lexbuf } | "*predef*" { mllib_list lexbuf } | space+ { mllib_list lexbuf } diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml index 3d92c9356..6a6db9556 100644 --- a/tools/coqdoc/alpha.ml +++ b/tools/coqdoc/alpha.ml @@ -8,7 +8,11 @@ open Cdglobals -let norm_char_latin1 c = match Char.uppercase c with +[@@@ocaml.warning "-3"] (* Char.uppercase_ascii since 4.03.0 GPR#124 *) +let uppercase = Char.uppercase +[@@@ocaml.warning "+3"] + +let norm_char_latin1 c = match uppercase c with | '\192'..'\198' -> 'A' | '\199' -> 'C' | '\200'..'\203' -> 'E' @@ -19,12 +23,12 @@ let norm_char_latin1 c = match Char.uppercase c with | '\221' -> 'Y' | c -> c -let norm_char_utf8 c = Char.uppercase c +let norm_char_utf8 c = uppercase c let norm_char c = if !utf8 then norm_char_utf8 c else if !latin1 then norm_char_latin1 c else - Char.uppercase c + uppercase c let norm_string = String.map (fun s -> norm_char s) diff --git a/tools/coqdoc/cdglobals.ml b/tools/coqdoc/cdglobals.ml index 5d48473d8..ef203960b 100644 --- a/tools/coqdoc/cdglobals.ml +++ b/tools/coqdoc/cdglobals.ml @@ -70,23 +70,21 @@ let normalize_filename f = let dirname = Filename.dirname f in normalize_path dirname, basename +(** Add a local installation suffix (unless the suffix is itself + absolute in which case the prefix does not matter) *) +let use_suffix prefix suffix = + if String.length suffix > 0 && suffix.[0] = '/' then suffix else prefix / suffix + (** A weaker analog of the function in Envars *) let guess_coqlib () = let file = "theories/Init/Prelude.vo" in - match Coq_config.coqlib with - | Some coqlib when Sys.file_exists (coqlib / file) -> coqlib - | Some _ | None -> - let coqbin = normalize_path (Filename.dirname Sys.executable_name) in - let prefix = Filename.dirname coqbin in - let rpath = - if Coq_config.local then [] - else if Coq_config.arch_is_win32 then ["lib"] - else ["lib/coq"] - in - let coqlib = List.fold_left (/) prefix rpath in - if Sys.file_exists (coqlib / file) then coqlib - else prefix + let coqbin = normalize_path (Filename.dirname Sys.executable_name) in + let prefix = Filename.dirname coqbin in + let coqlib = use_suffix prefix Coq_config.coqlibsuffix in + if Sys.file_exists (coqlib / file) then coqlib else + if not Coq_config.local && Sys.file_exists (Coq_config.coqlib / file) + then Coq_config.coqlib else prefix let header_trailer = ref true let header_file = ref "" diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 34108eff4..4d118b978 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -155,10 +155,14 @@ let sort_entries el = let display_letter c = if c = '*' then "other" else String.make 1 c +[@@@ocaml.warning "-3"] (* String.lowercase_ascii since 4.03.0 GPR#124 *) +let lowercase = String.lowercase +[@@@ocaml.warning "+3"] + let type_name = function | Library -> let ln = !lib_name in - if ln <> "" then String.lowercase ln else "library" + if ln <> "" then lowercase ln else "library" | Module -> "module" | Definition -> "definition" | Inductive -> "inductive" diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index e06ef9d76..972390579 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -19,6 +19,10 @@ let printf s = Printf.fprintf !out_channel s let sprintf = Printf.sprintf +[@@@ocaml.warning "-3"] (* String.{capitalize,lowercase}_ascii since 4.03.0 GPR#124 *) +let capitalize = String.capitalize +let lowercase = String.lowercase +[@@@ocaml.warning "+3"] (*s Coq keywords *) @@ -846,7 +850,7 @@ module Html = struct if t = Library then let ln = !lib_name in if ln <> "" then - "[" ^ String.lowercase ln ^ "]", m ^ ".html", t + "[" ^ lowercase ln ^ "]", m ^ ".html", t else "[library]", m ^ ".html", t else @@ -864,7 +868,7 @@ module Html = struct (* Impression de la table d'index *) let print_index_table_item i = - printf "<tr>\n<td>%s Index</td>\n" (String.capitalize i.idx_name); + printf "<tr>\n<td>%s Index</td>\n" (capitalize i.idx_name); List.iter (fun (c,l) -> if l <> [] then @@ -912,7 +916,7 @@ module Html = struct let print_table () = print_index_table all_index in let print_one_index i = if i.idx_size > 0 then begin - printf "<hr/>\n<h1>%s Index</h1>\n" (String.capitalize i.idx_name); + printf "<hr/>\n<h1>%s Index</h1>\n" (capitalize i.idx_name); all_letters i end in diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml index defc80338..9bca13512 100644 --- a/tools/coqmktop.ml +++ b/tools/coqmktop.ml @@ -20,6 +20,10 @@ let split_list = let spaces = Str.regexp "[ \t\n]+" in fun str -> Str.split spaces str +[@@@ocaml.warning "-3"] (* String.uncapitalize_ascii since 4.03.0 GPR#124 *) +let capitalize = String.capitalize +[@@@ocaml.warning "+3"] + let (/) = Filename.concat (** Which user files do we support (and propagate to ocamlopt) ? @@ -39,8 +43,7 @@ let native_suffix f = match CUnix.get_extension f with (** Transforms a file name in the corresponding Caml module name. *) let module_of_file name = - String.capitalize - (try Filename.chop_extension name with Invalid_argument _ -> name) + capitalize (try Filename.chop_extension name with Invalid_argument _ -> name) (** Run a command [prog] with arguments [args]. We do not use [Sys.command] anymore, see comment in [CUnix.sys_command]. @@ -262,7 +265,7 @@ let main () = (* Which ocaml compiler to invoke *) let prog = if !opt then "opt" else "ocamlc" in (* Which arguments ? *) - if !opt && !top then failwith "no custom toplevel in native code !"; + if !opt && !top then failwith "no custom toplevel in native code!"; let flags = if !opt then [] else Coq_config.vmbyteflags in let topstart = if !top then [ "topstart.cmo" ] else [] in let (modules, tolink) = files_to_link userfiles in diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index bf82be09f..5d11e3008 100644 --- a/tools/ocamllibdep.mll +++ b/tools/ocamllibdep.mll @@ -11,6 +11,12 @@ let syntax_error lexbuf = raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) + + [@@@ocaml.warning "-3"] (* String.(un)capitalize_ascii since 4.03.0 GPR#124 *) + let uncapitalize = String.uncapitalize + + let capitalize = String.capitalize + [@@@ocaml.warning "+3"] } let space = [' ' '\t' '\n' '\r'] @@ -22,7 +28,9 @@ let caml_up_ident = uppercase identchar* let caml_low_ident = lowercase identchar* rule mllib_list = parse - | caml_up_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf) + | uppercase+ { let s = Lexing.lexeme lexbuf in + s :: mllib_list lexbuf } + | caml_up_ident { let s = uncapitalize (Lexing.lexeme lexbuf) in s :: mllib_list lexbuf } | "*predef*" { mllib_list lexbuf } | space+ { mllib_list lexbuf } @@ -185,7 +193,7 @@ let mlpack_dependencies () = List.iter (fun (name,dirname) -> let fullname = file_name name dirname in - let modname = String.capitalize name in + let modname = capitalize name in let deps = traite_fichier_modules fullname ".mlpack" in let sdeps = String.concat " " deps in let efullname = escape fullname in diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index ab5104c78..908786565 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -8,6 +8,8 @@ open Pp +let print_emacs = ref false + let top_stderr x = Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with x @@ -45,9 +47,8 @@ let resynch_buffer ibuf = (* emacs special prompt tag for easy detection. No special character, to avoid interfering with utf8. Compatibility code removed. *) - -let emacs_prompt_startstring() = Printer.emacs_str "<prompt>" -let emacs_prompt_endstring() = Printer.emacs_str "</prompt>" +let emacs_prompt_startstring () = if !print_emacs then "<prompt>" else "" +let emacs_prompt_endstring () = if !print_emacs then "</prompt>" else "" (* Read a char in an input channel, displaying a prompt at every beginning of line. *) @@ -56,7 +57,7 @@ let prompt_char ic ibuf count = | ll::_ -> Int.equal ibuf.len ll | [] -> Int.equal ibuf.len 0 in - if bol && not !Flags.print_emacs then top_stderr (str (ibuf.prompt())); + if bol && not !print_emacs then top_stderr (str (ibuf.prompt())); try let c = input_char ic in if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols; @@ -84,7 +85,7 @@ module TopErr = struct let get_bols_of_loc ibuf (bp,ep) = let add_line (b,e) lines = - if b < 0 || e < b then CErrors.anomaly (Pp.str "Bad location"); + if b < 0 || e < b then CErrors.anomaly (Pp.str "Bad location."); match lines with | ([],None) -> ([], Some (b,e)) | (fl,oe) -> ((b,e)::fl, oe) @@ -168,7 +169,7 @@ let error_info_for_buffer ?loc buf = (* Actual printing routine *) let print_error_for_buffer ?loc lvl msg buf = let pre_hdr = error_info_for_buffer ?loc buf in - if !Flags.print_emacs + if !print_emacs then Topfmt.emacs_logger ?pre_hdr lvl msg else Topfmt.std_logger ?pre_hdr lvl msg @@ -207,7 +208,7 @@ let make_emacs_prompt() = (fun acc x -> acc ^ (if CString.is_empty acc then "" else "|") ^ Names.Id.to_string x) "" pending in let proof_info = if dpth >= 0 then string_of_int dpth else "0" in - if !Flags.print_emacs then statnum ^ " |" ^ pendingprompt ^ "| " ^ proof_info ^ " < " + if !print_emacs then statnum ^ " |" ^ pendingprompt ^ "| " ^ proof_info ^ " < " else "" (* A buffer to store the current command read on stdin. It is @@ -299,7 +300,7 @@ let coqloop_feed (fb : Feedback.feedback) = let open Feedback in let do_vernac sid = top_stderr (fnl()); - if !Flags.print_emacs then top_stderr (str (top_buffer.prompt())); + if !print_emacs then top_stderr (str (top_buffer.prompt())); resynch_buffer top_buffer; try let input = (top_buffer.tokens, None) in diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index 13e860a88..a0e2f1e02 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -8,6 +8,9 @@ (** The Coq toplevel loop. *) +(** -emacs option: printing includes emacs tags. *) +val print_emacs : bool ref + (** A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 7834b5113..26ee413fb 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -246,21 +246,21 @@ let compile_files () = let set_emacs () = if not (Option.is_empty !toploop) then user_err Pp.(str "Flag -emacs is incompatible with a custom toplevel loop"); - Flags.print_emacs := true; + Coqloop.print_emacs := true; Printer.enable_goal_tags_printing := true; color := `OFF (** Options for CoqIDE *) let set_ideslave () = - if !Flags.print_emacs then user_err Pp.(str "Flags -ideslave and -emacs are incompatible"); + if !Coqloop.print_emacs then user_err Pp.(str "Flags -ideslave and -emacs are incompatible"); toploop := Some "coqidetop"; Flags.ide_slave := true (** Options for slaves *) let set_toploop name = - if !Flags.print_emacs then user_err Pp.(str "Flags -toploop and -emacs are incompatible"); + if !Coqloop.print_emacs then user_err Pp.(str "Flags -toploop and -emacs are incompatible"); toploop := Some name (** GC tweaking *) diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index bf274901b..726115653 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -131,7 +131,7 @@ let lookup_constant_in_impl cst fallback = - The label has not been found in the structure. This is an error *) match fallback with | Some cb -> cb - | None -> anomaly (str "Print Assumption: unknown constant " ++ pr_con cst) + | None -> anomaly (str "Print Assumption: unknown constant " ++ pr_con cst ++ str ".") let lookup_constant cst = try @@ -146,7 +146,7 @@ let lookup_mind_in_impl mind = let fields = memoize_fields_of_mp mp in search_mind_label lab fields with Not_found -> - anomaly (str "Print Assumption: unknown inductive " ++ MutInd.print mind) + anomaly (str "Print Assumption: unknown inductive " ++ MutInd.print mind ++ str ".") let lookup_mind mind = try Global.lookup_mind mind diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index cf534f13a..9e6e5e313 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -365,7 +365,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = ))) ) in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of_pq = Tacmach.New.pf_unsafe_type_of gl p in let sigma = Tacmach.New.project gl in let u,v = destruct_ind sigma type_of_pq @@ -397,7 +397,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = Tacticals.New.tclTHENLIST [ Proofview.tclEFFECTS eff; Equality.replace p q ; apply app ; Auto.default_auto] - end } + end (* used in the bool -> leib side *) let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = @@ -430,7 +430,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let rec aux l1 l2 = match (l1,l2) with | (t1::q1,t2::q2) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let tt1 = Tacmach.New.pf_unsafe_type_of gl t1 in let sigma = Tacmach.New.project gl in if EConstr.eq_constr sigma t1 t2 then aux q1 q2 @@ -472,7 +472,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = aux q1 q2 ] ) ) - end } + end | ([],[]) -> Proofview.tclUNIT () | _ -> Tacticals.New.tclZEROMSG (str "Both side of the equality must have the same arity.") in @@ -533,7 +533,7 @@ open Namegen let compute_bl_goal ind lnamesparrec nparrec = let eqI, eff = eqI ind lnamesparrec in let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in let create_input c = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in @@ -581,7 +581,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in avoid := fresh::(!avoid); fresh in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in let freshn = fresh_id (Id.of_string "x") gl in let freshm = fresh_id (Id.of_string "y") gl in @@ -604,18 +604,18 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). Tacticals.New.tclREPEAT ( Tacticals.New.tclTHENLIST [ Simple.apply_in freshz (EConstr.of_constr (andb_prop())); - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let fresht = fresh_id (Id.of_string "Z") gl in destruct_on_as (EConstr.mkVar freshz) (IntroOrPattern [[Loc.tag @@ IntroNaming (IntroIdentifier fresht); Loc.tag @@ IntroNaming (IntroIdentifier freshz)]]) - end } + end ]); (* Ci a1 ... an = Ci b1 ... bn replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto *) - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in match EConstr.kind sigma concl with @@ -635,10 +635,10 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.") ) | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") - end } + end ] - end } + end let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") @@ -676,7 +676,7 @@ let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in - let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in let eqI, eff = eqI ind lnamesparrec in let create_input c = let x = next_ident_away (Id.of_string "x") avoid and @@ -725,7 +725,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in avoid := fresh::(!avoid); fresh in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in let freshn = fresh_id (Id.of_string "x") gl in let freshm = fresh_id (Id.of_string "y") gl in @@ -748,7 +748,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = Tacticals.New.tclTHENLIST [apply (EConstr.of_constr (andb_true_intro())); simplest_split ;Auto.default_auto ] ); - Proofview.Goal.enter { enter = begin fun gls -> + Proofview.Goal.enter begin fun gls -> let concl = Proofview.Goal.concl gls in let sigma = Tacmach.New.project gl in (* assume the goal to be eq (eq_type ...) = true *) @@ -765,9 +765,9 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = ) | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") - end } + end ] - end } + end let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") @@ -806,7 +806,7 @@ let compute_dec_goal ind lnamesparrec nparrec = check_not_is_defined (); let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in let create_input c = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in @@ -873,7 +873,7 @@ let compute_dec_tact ind lnamesparrec nparrec = let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in avoid := fresh::(!avoid); fresh in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in let freshn = fresh_id (Id.of_string "x") gl in let freshm = fresh_id (Id.of_string "y") gl in @@ -904,7 +904,7 @@ let compute_dec_tact ind lnamesparrec nparrec = )) (Tacticals.New.tclTHEN (destruct_on (EConstr.of_constr eqbnm)) Auto.default_auto); - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let freshH2 = fresh_id (Id.of_string "H") gl in Tacticals.New.tclTHENS (destruct_on_using (EConstr.mkVar freshH) freshH2) [ (* left *) @@ -916,7 +916,7 @@ let compute_dec_tact ind lnamesparrec nparrec = ; (*right *) - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let freshH3 = fresh_id (Id.of_string "H") gl in Tacticals.New.tclTHENLIST [ simplest_right ; @@ -938,11 +938,11 @@ let compute_dec_tact ind lnamesparrec nparrec = true; Equality.discr_tac false None ] - end } + end ] - end } + end ] - end } + end let make_eq_decidability mode mind = let mib = Global.lookup_mind mind in diff --git a/vernac/classes.ml b/vernac/classes.ml index 004083dcf..dc5ce1a53 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -20,7 +20,6 @@ open Libnames open Globnames open Constrintern open Constrexpr -open Sigma.Notations open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration @@ -342,7 +341,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p if not (Option.is_empty term) then let init_refine = Tacticals.New.tclTHENLIST [ - Refine.refine { run = fun evm -> Sigma (EConstr.of_constr (Option.get term), evm, Sigma.refl) }; + Refine.refine (fun evm -> (evm,EConstr.of_constr (Option.get term))); Proofview.Unsafe.tclNEWGOALS gls; Tactics.New.reduce_after_refine; ] diff --git a/vernac/command.ml b/vernac/command.ml index e2ebb4d7f..b1425d703 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -35,7 +35,6 @@ open Evarconv open Indschemes open Misctypes open Vernacexpr -open Sigma.Notations open Context.Rel.Declaration open Entries @@ -78,8 +77,7 @@ let red_constant_entry n ce sigma = function let env = Global.env () in let (redfun, _) = reduction_of_red_expr env red in let redfun env sigma c = - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (c, _, _) = redfun.e_redfun env sigma c in + let (_, c) = redfun env sigma c in EConstr.Unsafe.to_constr c in { ce with const_entry_body = Future.chain ~pure:true proof_out @@ -211,7 +209,7 @@ let do_definition ident k pl bl red_option c ctypopt hook = assert(Univ.ContextSet.is_empty ctx); let typ = match ce.const_entry_type with | Some t -> t - | None -> EConstr.Unsafe.to_constr (Retyping.get_type_of env evd (EConstr.of_constr c)) + | None -> EConstr.to_constr evd (Retyping.get_type_of env evd (EConstr.of_constr c)) in Obligations.check_evars env evd; let obls, _, c, cty = @@ -411,8 +409,8 @@ let mk_mltype_data evdref env assums arity indname = (is_ml_type,indname,assums) let prepare_param = function - | LocalAssum (na,t) -> out_name na, LocalAssumEntry t - | LocalDef (na,b,_) -> out_name na, LocalDefEntry b + | LocalAssum (na,t) -> Name.get_id na, LocalAssumEntry t + | LocalDef (na,b,_) -> Name.get_id na, LocalDefEntry b (** Make the arity conclusion flexible to avoid generating an upper bound universe now, only if the universe does not appear anywhere else. @@ -582,7 +580,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = let pl = (List.hd indl).ind_univs in let ctx = Evd.make_evar_universe_context env0 pl in let evdref = ref Evd.(from_ctx ctx) in - let _, ((env_params, ctx_params), userimpls) = + let impls, ((env_params, ctx_params), userimpls) = interp_context_evars env0 evdref paramsl in let ctx_params = List.map (fun d -> map_rel_decl EConstr.Unsafe.to_constr d) ctx_params in @@ -590,7 +588,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 (RelDecl.get_name %> out_name) assums in + let params = List.map (RelDecl.get_name %> Name.get_id) assums in (* Interpret the arities *) let arities = List.map (interp_ind_arity env_params evdref) indl in @@ -603,7 +601,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = let indimpls = List.map (fun (_, _, impls) -> userimpls @ lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in - let impls = compute_internalization_env env0 (Inductive params) indnames fullarities indimpls in + let impls = compute_internalization_env env0 ~impls (Inductive (params,true)) indnames fullarities indimpls in let implsforntn = compute_internalization_env env0 Variable indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in @@ -674,7 +672,7 @@ let extract_coercions indl = let extract_params indl = let paramsl = List.map (fun (_,params,_,_) -> params) indl in match paramsl with - | [] -> anomaly (Pp.str "empty list of inductive types") + | [] -> anomaly (Pp.str "empty list of inductive types.") | params::paramsl -> if not (List.for_all (eq_local_binders params) paramsl) then user_err Pp.(str "Parameters should be syntactically the same for each inductive type."); @@ -907,23 +905,25 @@ let fixsub_module = subtac_dir @ ["Wf"] let tactics_module = subtac_dir @ ["Tactics"] let init_reference dir s () = Coqlib.coq_reference "Command" dir s -let init_constant dir s () = EConstr.of_constr @@ Universes.constr_of_global (Coqlib.coq_reference "Command" dir s) +let init_constant dir s evdref = + let (sigma, c) = Evarutil.new_global !evdref (Coqlib.coq_reference "Command" dir s) + in evdref := sigma; c let make_ref l s = init_reference l s let fix_proto = init_constant tactics_module "fix_proto" let fix_sub_ref = make_ref fixsub_module "Fix_sub" let measure_on_R_ref = make_ref fixsub_module "MR" let well_founded = init_constant ["Init"; "Wf"] "well_founded" -let mkSubset name typ prop = +let mkSubset evdref name typ prop = let open EConstr in - mkApp (EConstr.of_constr (Universes.constr_of_global (delayed_force build_sigma).typ), + mkApp (Evarutil.e_new_global evdref (delayed_force build_sigma).typ, [| typ; mkLambda (name, typ, prop) |]) let sigT = Lazy.from_fun build_sigma_type let make_qref s = Qualid (Loc.tag @@ qualid_of_string s) let lt_ref = make_qref "Init.Peano.lt" -let rec telescope l = +let rec telescope evdref l = let open EConstr in let open Vars in match l with @@ -935,10 +935,8 @@ let rec telescope l = (fun (ty, tys, (k, constr)) decl -> 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 ty = EConstr.of_constr ty in - let intro = Universes.constr_of_global (Lazy.force sigT).intro in - let intro = EConstr.of_constr intro in + let ty = Evarutil.e_new_global evdref (Lazy.force sigT).typ in + let intro = Evarutil.e_new_global evdref (Lazy.force sigT).intro in let sigty = mkApp (ty, [|t; pred|]) in let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in (sigty, pred :: tys, (succ k, intro))) @@ -947,17 +945,15 @@ let rec telescope l = let (last, subst) = List.fold_right2 (fun pred decl (prev, subst) -> let t = RelDecl.get_type decl in - let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in - let p1 = EConstr.of_constr p1 in - let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in - let p2 = EConstr.of_constr p2 in + let p1 = Evarutil.e_new_global evdref (Lazy.force sigT).proj1 in + let p2 = Evarutil.e_new_global evdref (Lazy.force sigT).proj2 in let proj1 = applist (p1, [t; pred; prev]) in let proj2 = applist (p2, [t; pred; prev]) in (lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst)) (List.rev tys) tl (mkRel 1, []) in ty, (LocalDef (n, last, t) :: subst), constr - | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope tl in + | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope evdref tl in ty, (LocalDef (n, b, t) :: subst), lift 1 term let nf_evar_context sigma ctx = @@ -976,7 +972,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let top_env = push_rel_context binders_rel env in let top_arity = interp_type_evars top_env evdref arityc in let full_arity = it_mkProd_or_LetIn top_arity binders_rel in - let argtyp, letbinders, make = telescope binders_rel in + let argtyp, letbinders, make = telescope evdref binders_rel in let argname = Id.of_string "recarg" in let arg = LocalAssum (Name argname, argtyp) in let binders = letbinders @ [arg] in @@ -1004,7 +1000,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = it_mkLambda_or_LetIn measure letbinders, it_mkLambda_or_LetIn measure binders in - let comb = EConstr.of_constr (Universes.constr_of_global (delayed_force measure_on_R_ref)) in + let comb = Evarutil.e_new_global evdref (delayed_force measure_on_R_ref) in let relargty = EConstr.of_constr relargty in let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in let wf_rel_fun x y = @@ -1012,15 +1008,15 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = subst1 y measure_body |]) in wf_rel, wf_rel_fun, measure in - let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in + let wf_proof = mkApp (well_founded evdref, [| argtyp ; wf_rel |]) in let argid' = Id.of_string (Id.to_string argname ^ "'") in let wfarg len = LocalAssum (Name argid', - mkSubset (Name argid') argtyp + mkSubset evdref (Name argid') argtyp (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) in let intern_bl = wfarg 1 :: [arg] in let _intern_env = push_rel_context intern_bl env in - let proj = (*FIXME*)EConstr.of_constr (Universes.constr_of_global (delayed_force build_sigma).Coqlib.proj1) in + let proj = Evarutil.e_new_global evdref (delayed_force build_sigma).Coqlib.proj1 in let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in let projection = (* in wfarg :: arg :: before *) mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) @@ -1033,7 +1029,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in let curry_fun = let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in - let intro = (*FIXME*)EConstr.of_constr (Universes.constr_of_global (delayed_force build_sigma).Coqlib.intro) in + let intro = Evarutil.e_new_global evdref (delayed_force build_sigma).Coqlib.intro in let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in let rcurry = mkApp (rel, [| measure; lift len measure |]) in @@ -1059,10 +1055,10 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in let prop = mkLambda (Name argname, argtyp, top_arity_let) in let def = - mkApp (EConstr.of_constr (Universes.constr_of_global (delayed_force fix_sub_ref)), + mkApp (Evarutil.e_new_global evdref (delayed_force fix_sub_ref), [| argtyp ; wf_rel ; Evarutil.e_new_evar env evdref - ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof; + ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false,Anonymous)) wf_proof; prop |]) in let def = Typing.e_solve_evars env evdref def in @@ -1075,12 +1071,12 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = if List.length binders_rel > 1 then let name = add_suffix recname "_func" in let hook l gr _ = - let body = it_mkLambda_or_LetIn (mkApp (EConstr.of_constr (Universes.constr_of_global gr), [|make|])) binders_rel in + let body = it_mkLambda_or_LetIn (mkApp (Evarutil.e_new_global evdref gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in let ty = EConstr.Unsafe.to_constr ty in let pl, univs = Evd.universe_context ?names:pl !evdref in (*FIXME poly? *) - let ce = definition_entry ~poly ~types:ty ~univs (EConstr.Unsafe.to_constr (Evarutil.nf_evar !evdref body)) in + let ce = definition_entry ~poly ~types:ty ~univs (EConstr.to_constr !evdref body) in (** FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in @@ -1097,10 +1093,8 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = in hook, recname, typ in let hook = Lemmas.mk_hook hook in - let fullcoqc = Evarutil.nf_evar !evdref def in - let fullctyp = Evarutil.nf_evar !evdref typ in - let fullcoqc = EConstr.Unsafe.to_constr fullcoqc in - let fullctyp = EConstr.Unsafe.to_constr fullctyp in + let fullcoqc = EConstr.to_constr !evdref def in + let fullctyp = EConstr.to_constr !evdref typ in Obligations.check_evars env !evdref; let evars, _, evars_def, evars_typ = Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp @@ -1143,7 +1137,7 @@ let interp_recursive isfix fixl notations = let sort = Evarutil.evd_comb1 (Typing.type_of ~refresh:true env) evdref t in let fixprot = try - let app = mkApp (delayed_force fix_proto, [|sort; t|]) in + let app = mkApp (fix_proto evdref, [|sort; t|]) in Typing.e_solve_evars env evdref app with e when CErrors.noncritical e -> t in @@ -1303,9 +1297,9 @@ let do_program_recursive local p fixkind fixl ntns = let collect_evars id def typ imps = (* Generalize by the recursive prototypes *) let def = - EConstr.Unsafe.to_constr (nf_evar evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign)) + EConstr.to_constr evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign) and typ = - EConstr.Unsafe.to_constr (nf_evar evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign)) + EConstr.to_constr evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign) in let evm = collect_evars_of_term evd def typ in let evars, _, def, typ = diff --git a/vernac/discharge.ml b/vernac/discharge.ml index b898f3e83..65ade7887 100644 --- a/vernac/discharge.ml +++ b/vernac/discharge.ml @@ -23,7 +23,7 @@ let detype_param = function | LocalAssum (Name id, p) -> id, LocalAssumEntry p | LocalDef (Name id, p,_) -> id, LocalDefEntry p - | _ -> anomaly (Pp.str "Unnamed inductive local variable") + | _ -> anomaly (Pp.str "Unnamed inductive local variable.") (* Replace diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 040c86805..021fde961 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -109,7 +109,7 @@ let process_vernac_interp_error ?(allow_uncaught=true) (exc, info) = let () = if not allow_uncaught && not (CErrors.handled (fst e)) then let (e, info) = e in - let msg = str "Uncaught exception " ++ str (Printexc.to_string e) in + let msg = str "Uncaught exception " ++ str (Printexc.to_string e) ++ str "." in let err = CErrors.make_anomaly msg in Util.iraise (err, info) in diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 17bb87f2a..6d8dd82ac 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -682,12 +682,12 @@ let explain_wrong_abstraction_type env sigma na abs expected result = let explain_abstraction_over_meta _ m n = strbrk "Too complex unification problem: cannot find a solution for both " ++ - pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "." + Name.print m ++ spc () ++ str "and " ++ Name.print n ++ str "." let explain_non_linear_unification env sigma m t = let t = EConstr.to_constr sigma t in strbrk "Cannot unambiguously instantiate " ++ - pr_name m ++ str ":" ++ + Name.print m ++ str ":" ++ strbrk " which would require to abstract twice on " ++ pr_lconstr_env env sigma t ++ str "." @@ -1055,7 +1055,7 @@ let explain_refiner_bad_type arg ty conclty = let explain_refiner_unresolved_bindings l = str "Unable to find an instance for the " ++ str (String.plural (List.length l) "variable") ++ spc () ++ - prlist_with_sep pr_comma pr_name l ++ str"." + prlist_with_sep pr_comma Name.print l ++ str"." let explain_refiner_cannot_apply t harg = str "In refiner, a term of type" ++ brk(1,1) ++ diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index f57b1bba0..c2c27eb78 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -453,11 +453,14 @@ let fold_left' f = function [] -> invalid_arg "fold_left'" | hd :: tl -> List.fold_left f hd tl +let mk_coq_and sigma = Evarutil.new_global sigma (Coqlib.build_coq_and ()) +let mk_coq_conj sigma = Evarutil.new_global sigma (Coqlib.build_coq_conj ()) + let build_combined_scheme env schemes = - let defs = List.map (fun cst -> (* FIXME *) - let evd, c = Evd.fresh_constant_instance env (Evd.from_env env) cst in - (c, Typeops.type_of_constant_in env c)) schemes in -(* let nschemes = List.length schemes in *) + let evdref = ref (Evd.from_env env) in + let defs = List.map (fun cst -> + let evd, c = Evd.fresh_constant_instance env !evdref cst in + evdref := evd; (c, Typeops.type_of_constant_in env c)) schemes in let find_inductive ty = let (ctx, arity) = decompose_prod ty in let (_, last) = List.hd ctx in @@ -471,26 +474,27 @@ let build_combined_scheme env schemes = let (c, t) = List.hd defs in let ctx, ind, nargs = find_inductive t in (* Number of clauses, including the predicates quantification *) - let prods = nb_prod Evd.empty (EConstr.of_constr t) - (nargs + 1) (** FIXME *) in - let coqand = Universes.constr_of_global @@ Coqlib.build_coq_and () in - let coqconj = Universes.constr_of_global @@ Coqlib.build_coq_conj () in + let prods = nb_prod !evdref (EConstr.of_constr t) - (nargs + 1) in + let sigma, coqand = mk_coq_and !evdref in + let sigma, coqconj = mk_coq_conj sigma in + let () = evdref := sigma in let relargs = rel_vect 0 prods in let concls = List.rev_map - (fun (cst, t) -> (* FIXME *) + (fun (cst, t) -> mkApp(mkConstU cst, relargs), snd (decompose_prod_n prods t)) defs in let concl_bod, concl_typ = fold_left' (fun (accb, acct) (cst, x) -> - mkApp (coqconj, [| x; acct; cst; accb |]), - mkApp (coqand, [| x; acct |])) concls + mkApp (EConstr.to_constr !evdref coqconj, [| x; acct; cst; accb |]), + mkApp (EConstr.to_constr !evdref coqand, [| x; acct |])) concls in let ctx, _ = list_split_rev_at prods (List.rev_map (fun (x, y) -> LocalAssum (x, y)) ctx) in let typ = List.fold_left (fun d c -> Term.mkProd_wo_LetIn c d) concl_typ ctx in let body = it_mkLambda_or_LetIn concl_bod ctx in - (body, typ) + (!evdref, body, typ) let do_combined_scheme name schemes = let csts = @@ -501,9 +505,9 @@ let do_combined_scheme name schemes = with Not_found -> user_err Pp.(pr_qualid (snd qualid) ++ str " is not declared.")) schemes in - let body,typ = build_combined_scheme (Global.env ()) csts in + let sigma,body,typ = build_combined_scheme (Global.env ()) csts in let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in - ignore (define (snd name) UserIndividualRequest Evd.empty proof_output (Some typ)); + ignore (define (snd name) UserIndividualRequest sigma proof_output (Some typ)); fixpoint_message None [snd name] (**********************************************************************) diff --git a/vernac/indschemes.mli b/vernac/indschemes.mli index e5d79fd51..0f559d2bd 100644 --- a/vernac/indschemes.mli +++ b/vernac/indschemes.mli @@ -40,7 +40,7 @@ val do_scheme : (Id.t located option * scheme) list -> unit (** Combine a list of schemes into a conjunction of them *) -val build_combined_scheme : env -> constant list -> constr * types +val build_combined_scheme : env -> constant list -> Evd.evar_map * constr * types val do_combined_scheme : Id.t located -> Id.t located list -> unit diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index d6ae0ea86..77e356eb2 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -242,7 +242,7 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i, | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2) | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) | App (t, args) -> mkApp (body_i t, args) - | _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body) in + | _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body ++ str ".") in let body_i = body_i body in match locality with | Discharge -> @@ -402,7 +402,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = let () = match thms with [_] -> () | _ -> assert false in (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in match thms with - | [] -> anomaly (Pp.str "No proof to start") + | [] -> anomaly (Pp.str "No proof to start.") | ((id,pl),(t,(_,imps)))::other_thms -> let hook ctx strength ref = let ctx = match ctx with diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 42494dd28..34b9b97d8 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -250,7 +250,7 @@ let rec find_pattern nt xl = function | _, [] -> user_err Pp.(str msg_expected_form_of_recursive_notation) | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) -> - anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right") + anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right.") let rec interp_list_parser hd = function | [] -> [], List.rev hd @@ -271,7 +271,7 @@ let rec interp_list_parser hd = function | NonTerminal _ as x :: tl -> let xyl,tl' = interp_list_parser [x] tl in xyl, List.rev_append hd tl' - | SProdList _ :: _ -> anomaly (Pp.str "Unexpected SProdList in interp_list_parser") + | SProdList _ :: _ -> anomaly (Pp.str "Unexpected SProdList in interp_list_parser.") (* Find non-terminal tokens of notation *) @@ -645,7 +645,7 @@ let make_production etyps symbols = let tkl = List.flatten (List.map (function Terminal s -> [CLexer.terminal s] | Break _ -> [] - | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator")) sl) in + | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator.")) sl) in match List.assoc x etyps with | ETConstr typ -> expand_list_rule typ tkl x 1 0 [] ll | ETBinder o -> diff --git a/vernac/obligations.ml b/vernac/obligations.ml index be58c67a9..6dee95bc5 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -64,7 +64,7 @@ let subst_evar_constr evs n idf t = ev_hyps = hyps ; ev_chop = chop } = try evar_info k with Not_found -> - anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found") + anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found.") in seen := Int.Set.add id !seen; (* Evar arguments are created in inverse order, @@ -221,7 +221,7 @@ let eterm_obligations env name evm fs ?status t ty = in let loc, k = evar_source id evm in let status = match k with - | Evar_kinds.QuestionMark o -> o + | Evar_kinds.QuestionMark (o,_) -> o | _ -> match status with | Some o -> o | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ())) @@ -325,7 +325,7 @@ type program_info = program_info_aux CEphemeron.key let get_info x = try CEphemeron.get x with CEphemeron.InvalidKey -> - CErrors.anomaly Pp.(str "Program obligation can't be accessed by a worker") + CErrors.anomaly Pp.(str "Program obligation can't be accessed by a worker.") let assumption_message = Declare.assumption_message diff --git a/vernac/record.ml b/vernac/record.ml index 5accc8e37..2400fa681 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -24,7 +24,6 @@ open Type_errors open Constrexpr open Constrexpr_ops open Goptions -open Sigma.Notations open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration @@ -63,29 +62,28 @@ let interp_fields_evars env evars impls_env nots l = List.fold_left2 (fun (env, uimpls, params, impls) no ((loc, i), b, t) -> let t', impl = interp_type_evars_impls env evars ~impls t in - let b' = Option.map (fun x -> EConstr.Unsafe.to_constr (fst (interp_casted_constr_evars_impls env evars ~impls x t'))) b in - let t' = EConstr.Unsafe.to_constr t' in + let b' = Option.map (fun x -> fst (interp_casted_constr_evars_impls env evars ~impls x t')) b in let impls = match i with | Anonymous -> impls - | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method t' impl) impls + | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method (EConstr.to_constr !evars t') impl) impls in let d = match b' with | None -> LocalAssum (i,t') | Some b' -> LocalDef (i,b',t') in List.iter (Metasyntax.set_notation_for_interpretation impls) no; - (push_rel d env, impl :: uimpls, d::params, impls)) + (EConstr.push_rel d env, impl :: uimpls, d::params, impls)) (env, [], [], impls_env) nots l 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 (EConstr.of_constr (RelDecl.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)) + in (EConstr.push_rel d env, univ)) l (env, Univ.type0m_univ) let binder_of_decl = function @@ -95,7 +93,7 @@ let binder_of_decl = function let binders_of_decls = List.map binder_of_decl -let typecheck_params_and_fields def id pl t ps nots fs = +let typecheck_params_and_fields finite def id pl t ps nots fs = let env0 = Global.env () in let ctx = Evd.make_evar_universe_context env0 pl in let evars = ref (Evd.from_ctx ctx) in @@ -113,68 +111,68 @@ let typecheck_params_and_fields def id pl t ps nots fs = Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters.")) ps in let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in - let newps = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) newps in - let t', template = match t with + let typ, sort, template = match t with | Some t -> - let env = push_rel_context newps env0 in + let env = EConstr.push_rel_context newps env0 in let poly = match t with | { CAst.v = CSort (Misctypes.GType []) } -> true | _ -> false in let s = interp_type_evars env evars ~impls:empty_internalization_env t in let sred = Reductionops.whd_all env !evars s in - let s = EConstr.Unsafe.to_constr s in - let sred = EConstr.Unsafe.to_constr sred in - (match kind_of_term sred with - | Sort s' -> + (match EConstr.kind !evars sred with + | Sort s' -> + let s' = EConstr.ESorts.kind !evars s' in (if poly then match Evd.is_sort_variable !evars s' with | Some l -> evars := Evd.make_flexible_variable !evars true l; - sred, true - | None -> s, false - else s, false) + s, s', true + | None -> s, s', false + else s, s', false) | _ -> 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 + let s = Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars in + EConstr.mkSort s, s, true in - let fullarity = it_mkProd_or_LetIn t' newps in - let env_ar = push_rel_context newps (push_rel (LocalAssum (Name id,fullarity)) env0) in + let arity = EConstr.it_mkProd_or_LetIn typ newps in + let env_ar = EConstr.push_rel_context newps (EConstr.push_rel (LocalAssum (Name id,arity)) env0) in + let assums = List.filter is_local_assum newps in + let params = List.map (RelDecl.get_name %> out_name) assums in + let ty = Inductive (params,(finite != BiFinite)) in + let impls_env = compute_internalization_env env0 ~impls:impls_env ty [id] [EConstr.to_constr !evars arity] [imps] in let env2,impls,newfs,data = interp_fields_evars env_ar evars impls_env nots (binders_of_decls fs) in - let sigma = + let evars = Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar !evars Evd.empty in - let evars, nf = Evarutil.nf_evars_and_universes sigma in - let arity = nf t' in - let arity, evars = + let typ, evars = let _, univ = compute_constructor_level evars env_ar newfs in - let ctx, aritysort = Reduction.dest_arity env0 arity in - assert(List.is_empty ctx); (* Ensured by above analysis *) - if not def && (Sorts.is_prop aritysort || - (Sorts.is_set aritysort && is_impredicative_set env0)) then - arity, evars + if not def && (Sorts.is_prop sort || + (Sorts.is_set sort && is_impredicative_set env0)) then + typ, evars else - let evars = Evd.set_leq_sort env_ar evars (Type univ) aritysort in + let evars = Evd.set_leq_sort env_ar evars (Type univ) sort in if Univ.is_small_univ univ && - Option.cata (Evd.is_flexible_level evars) false (Evd.is_sort_variable evars aritysort) then + Option.cata (Evd.is_flexible_level evars) false (Evd.is_sort_variable evars sort) then (* We can assume that the level in aritysort is not constrained and clear it, if it is flexible *) - mkArity (ctx, Sorts.sort_of_univ univ), - Evd.set_eq_sort env_ar evars (Prop Pos) aritysort - else arity, evars + EConstr.mkSort (Sorts.sort_of_univ univ), + Evd.set_eq_sort env_ar evars (Prop Pos) sort + else typ, evars in let evars, nf = Evarutil.nf_evars_and_universes evars in - let newps = Context.Rel.map nf newps in - let newfs = Context.Rel.map nf newfs in + let newfs = List.map (EConstr.to_rel_decl evars) newfs in + let newps = List.map (EConstr.to_rel_decl evars) newps in + let typ = EConstr.to_constr evars typ in let ce t = Pretyping.check_evars env0 Evd.empty evars (EConstr.of_constr t) in List.iter (iter_constr ce) (List.rev newps); List.iter (iter_constr ce) (List.rev newfs); - Evd.universe_context ?names:pl evars, nf arity, template, imps, newps, impls, newfs + Evd.universe_context ?names:pl evars, typ, template, imps, newps, impls, newfs let degenerate_decl decl = let id = match RelDecl.get_name decl with | Name id -> id - | Anonymous -> anomaly (Pp.str "Unnamed record variable") in + | Anonymous -> anomaly (Pp.str "Unnamed record variable.") in match decl with | LocalAssum (_,t) -> (id, LocalAssumEntry t) | LocalDef (_,b,_) -> (id, LocalDefEntry b) @@ -366,15 +364,11 @@ let structure_signature ctx = match l with [] -> Evd.empty | [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 (EConstr.of_constr (RelDecl.get_type decl)) in - let evm = Sigma.to_evar_map evm in + let (evm, _) = Evarutil.new_pure_evar env evm (EConstr.of_constr (RelDecl.get_type decl)) 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 (EConstr.of_constr (RelDecl.get_type decl)) in - let evm = Sigma.to_evar_map evm in + let (evm, ev) = Evarutil.new_pure_evar env evm (EConstr.of_constr (RelDecl.get_type decl)) in let new_tl = Util.List.map_i (fun pos decl -> RelDecl.map_type (fun t -> EConstr.Unsafe.to_constr (Termops.replace_term evm (EConstr.mkRel pos) (EConstr.mkEvar(ev,[||])) (EConstr.of_constr t))) decl) 1 tl in @@ -565,7 +559,7 @@ let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,id (* Now, younger decl in params and fields is on top *) let (pl, ctx), arity, template, implpars, params, implfs, fields = States.with_state_protection (fun () -> - typecheck_params_and_fields (kind = Class true) idstruc pl s ps notations fs) () in + typecheck_params_and_fields finite (kind = Class true) idstruc pl s ps notations fs) () in let sign = structure_signature (fields@params) in let gr = match kind with | Class def -> diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 6c1d64cfe..69492759b 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -31,7 +31,6 @@ open Redexpr open Lemmas open Misctypes open Locality -open Sigma.Notations module NamedDecl = Context.Named.Declaration @@ -67,7 +66,7 @@ let show_node () = could, possibly, be cleaned away. (Feb. 2010) *) () -let show_thesis () = CErrors.anomaly (Pp.str "Show Thesis: TODO") +let show_thesis () = CErrors.anomaly (Pp.str "Show Thesis: TODO.") let show_top_evars () = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) @@ -1003,12 +1002,12 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags let err_extra_args names = user_err ~hdr:"vernac_declare_arguments" (strbrk "Extra arguments: " ++ - prlist_with_sep pr_comma pr_name names ++ str ".") + prlist_with_sep pr_comma Name.print names ++ str ".") in let err_missing_args names = user_err ~hdr:"vernac_declare_arguments" (strbrk "The following arguments are not declared: " ++ - prlist_with_sep pr_comma pr_name names ++ str ".") + prlist_with_sep pr_comma Name.print names ++ str ".") in let rec check_extra_args extra_args = @@ -1093,14 +1092,14 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags match !example_renaming with | None -> mt () | Some (o,n) -> - str "Argument " ++ pr_name o ++ - str " renamed to " ++ pr_name n ++ str "."); + str "Argument " ++ Name.print o ++ + str " renamed to " ++ Name.print n ++ str "."); let duplicate_names = List.duplicates Name.equal (List.filter ((!=) Anonymous) names) in if not (List.is_empty duplicate_names) then begin - let duplicates = prlist_with_sep pr_comma pr_name duplicate_names in + let duplicates = prlist_with_sep pr_comma Name.print duplicate_names in user_err (strbrk "Some argument names are duplicated: " ++ duplicates) end; @@ -1129,7 +1128,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags anonymous argument implicit *) | Anonymous :: _, (name, _) :: _ -> user_err ~hdr:"vernac_declare_arguments" - (strbrk"Argument "++ pr_name name ++ + (strbrk"Argument "++ Name.print name ++ strbrk " cannot be declared implicit.") | Name id :: inf_names, (name, impl) :: implicits -> @@ -1550,8 +1549,7 @@ let vernac_check_may_eval ?loc redexp glopt rc = let (sigma',r_interp) = Hook.get f_interp_redexp env sigma' r in let redfun env evm c = let (redfun, _) = reduction_of_red_expr env r_interp in - let evm = Sigma.Unsafe.of_evar_map evm in - let Sigma (c, _, _) = redfun.Reductionops.e_redfun env evm c in + let (_, c) = redfun env evm c in c in Feedback.msg_notice (print_eval redfun env sigma' rc j) @@ -1765,12 +1763,11 @@ let vernac_locate = let open Feedback in function let vernac_register id r = if Pfedit.refining () then user_err Pp.(str "Cannot register a primitive while in proof editing mode."); - let t = (Constrintern.global_reference (snd id)) in - if not (isConst t) then + let kn = Constrintern.global_reference (snd id) in + if not (isConstRef kn) then user_err Pp.(str "Register inline: a constant is expected"); - let kn = destConst t in match r with - | RegisterInline -> Global.register_inline (Univ.out_punivs kn) + | RegisterInline -> Global.register_inline (destConstRef kn) (********************) (* Proof management *) @@ -1871,8 +1868,8 @@ exception End_of_input *) let vernac_load interp fname = let interp x = - let proof_mode = Proof_global.get_default_proof_mode_name () in - Proof_global.activate_proof_mode proof_mode; + let proof_mode = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] in + Proof_global.activate_proof_mode proof_mode [@ocaml.warning "-3"]; interp x in let parse_sentence = Flags.with_option Flags.we_are_parsing (fun po -> @@ -1919,10 +1916,10 @@ let interp ?proof ?loc locality poly c = | VernacToplevelControl e -> raise e (* Resetting *) - | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm") - | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm") - | VernacBack _ -> anomaly (str "VernacBack not handled by Stm") - | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm") + | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm.") + | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm.") + | VernacBack _ -> anomaly (str "VernacBack not handled by Stm.") + | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm.") (* This one is possible to handle here *) | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") @@ -2055,7 +2052,7 @@ let interp ?proof ?loc locality poly c = | VernacProof (Some tac, Some l) -> Aux_file.record_in_aux_at ?loc "VernacProof" "tac:yes using:yes"; vernac_set_end_tac tac; vernac_set_used_variables l - | VernacProofMode mn -> Proof_global.set_proof_mode mn + | VernacProofMode mn -> Proof_global.set_proof_mode mn [@ocaml.warning "-3"] (* Extensions *) | VernacExtend (opn,args) -> Vernacinterp.call ?locality (opn,args) |