diff options
183 files changed, 3865 insertions, 1306 deletions
diff --git a/.circleci/config.yml b/.circleci/config.yml deleted file mode 100644 index adab42c622..0000000000 --- a/.circleci/config.yml +++ /dev/null @@ -1,202 +0,0 @@ -# This file used to contain configuration to also build documentation and CoqIDE, -# run the test-suite and the validate targets, -# including with 32-bits architecture or bleeding-edge compiler. - -defaults: - params: ¶ms - # Following parameters are used in Coq CircleCI Job (using yaml - # reference syntax) - working_directory: ~/coq - docker: - - image: $CI_REGISTRY_IMAGE:$CACHEKEY - - environment: &envvars - CACHEKEY: "bionic_coq-V2018-07-11-V2" - CI_REGISTRY_IMAGE: registry.gitlab.com/coq/coq - -version: 2 - -before_script: &before_script - name: Setup OPAM Switch - command: | - echo export TERM=xterm >> ~/.profile - source ~/.profile - echo . ~/.profile >> $BASH_ENV - printenv | sort - opam switch "$COMPILER" - opam config list - opam list - -.build-template: &build-template - <<: *params - steps: - - checkout - - run: *before_script - - run: &build-clean - name: Clean - command: | - make clean # ensure that `make clean` works on a fresh clone - - run: &build-configure - name: Configure - command: | - ./configure -local -native-compiler ${NATIVE_COMP} -coqide no - - run: &build-build - name: Build - command: | - make -j ${NJOBS} byte - make -j ${NJOBS} - make test-suite/misc/universes/all_stdlib.v - - persist_to_workspace: - root: &workspace ~/ - paths: - - coq/ - - environment: - <<: *envvars - NATIVE_COMP: "yes" - -.ci-template: &ci-template - <<: *params - steps: - - run: *before_script - - attach_workspace: &attach_workspace - at: *workspace - - - run: - name: Test - command: | - dev/ci/ci-wrapper.sh ${CIRCLE_JOB} - - persist_to_workspace: - root: *workspace - paths: - - coq/ - environment: *envvars - -# Defines individual jobs, see the workflows section below for job orchestration -jobs: - - # Build and prepare test environment - build: *build-template - - bignums: - <<: *ci-template - - color: - <<: *ci-template - - compcert: - <<: *ci-template - - coq-dpdgraph: - <<: *ci-template - - coquelicot: - <<: *ci-template - - cross-crypto: - <<: *ci-template - - elpi: - <<: *ci-template - - equations: - <<: *ci-template - - geocoq: - <<: *ci-template - - fcsl-pcm: - <<: *ci-template - - fiat-crypto: - <<: *ci-template - - fiat-parsers: - <<: *ci-template - - flocq: - <<: *ci-template - - math-classes: - <<: *ci-template - - corn: - <<: *ci-template - - formal-topology: - <<: *ci-template - - hott: - <<: *ci-template - - iris-lambda-rust: - <<: *ci-template - - ltac2: - <<: *ci-template - - math-comp: - <<: *ci-template - - mtac2: - <<: *ci-template - - pidetop: - <<: *ci-template - - sf: - <<: *ci-template - - unimath: - <<: *ci-template - - vst: - <<: *ci-template - -workflows: - version: 2 - - # Run on each push - main: - jobs: - - build - - - bignums: &req-main - requires: - - build - - color: - requires: - - build - - bignums - # - compcert: *req-main - # - coq-dpdgraph: *req-main - # - coquelicot: *req-main - # - cross-crypto: *req-main - # - elpi: *req-main - # - equations: *req-main - # - geocoq: *req-main - # - fcsl-pcm: *req-main - # - fiat-crypto: *req-main - # - fiat-parsers: *req-main - # - flocq: *req-main - - math-classes: - requires: - - build - - bignums - # - mtac2: *req-main - - corn: - requires: - - build - - math-classes - - formal-topology: - requires: - - build - - corn - # - hott: *req-main - # - iris-lambda-rust: *req-main - # - ltac2: *req-main - # - math-comp: *req-main - # - pidetop: *req-main - # - sf: *req-main - # - unimath: *req-main - # - vst: *req-main diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 384e46723a..20d49e675f 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -9,7 +9,6 @@ ########## CI infrastructure ########## /dev/ci/ @coq/ci-maintainers -/.circleci/ @coq/ci-maintainers /.travis.yml @coq/ci-maintainers /.gitlab-ci.yml @coq/ci-maintainers diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index be19a93a37..c2ca6ebaa4 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -200,7 +200,7 @@ build:edge+flambda: variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" - COQ_EXTRA_CONF: "-native-compiler no -coqide opt -flambda-opts " + COQ_EXTRA_CONF: "-native-compiler yes -coqide opt -flambda-opts " COQ_EXTRA_CONF_QUOTE: "-O3 -unbox-closures" windows64: diff --git a/.travis.yml b/.travis.yml index 53fbe5821a..f8b047ea18 100644 --- a/.travis.yml +++ b/.travis.yml @@ -65,7 +65,7 @@ matrix: - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" - if: NOT (type = pull_request) env: - - TEST_TARGET="validate" COMPILER="${COMPILER_BE}+flambda" CAMLP5_VER="${CAMLP5_VER_BE}" NATIVE_COMP="no" EXTRA_CONF="-flambda-opts -O3" FINDLIB_VER="${FINDLIB_VER_BE}" + - TEST_TARGET="validate" COMPILER="${COMPILER_BE}+flambda" CAMLP5_VER="${CAMLP5_VER_BE}" EXTRA_CONF="-flambda-opts -O3" FINDLIB_VER="${FINDLIB_VER_BE}" - if: NOT (type = pull_request) env: - TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" @@ -154,7 +154,6 @@ matrix: - COMPILER="${COMPILER_BE}+flambda" - FINDLIB_VER="${FINDLIB_VER_BE}" - CAMLP5_VER="${CAMLP5_VER_BE}" - - NATIVE_COMP="no" - EXTRA_CONF="-coqide opt -with-doc yes -flambda-opts -O3" - EXTRA_OPAM="${LABLGTK_BE} ounit" before_install: *sphinx-install @@ -13,7 +13,7 @@ Tactics - The undocumented "nameless" forms `fix N`, `cofix` that were deprecated in 8.8 have been removed from LTAC's syntax; please use - `fix ident N/cofix ident` to explicitely name the (co)fixpoint + `fix ident N/cofix ident` to explicitly name the (co)fixpoint hypothesis to be introduced. - Introduction tactics "intro"/"intros" on a goal which is an @@ -43,6 +43,15 @@ Tactics may need to add `Require Import Lra` to your developments. For compatibility, we now define `fourier` as a deprecated alias of `lra`. +Standard Library + +- Added `Ascii.eqb` and `String.eqb` and the `=?` notation for them, + and proved some lemmas about them. Note that this might cause + incompatibilities if you have, e.g., string_scope and Z_scope both + open with string_scope on top, and expect `=?` to refer to `Z.eqb`. + Solution: wrap `_ =? _` in `(_ =? _)%Z` (or whichever scope you + want). + Tools - Coq_makefile lets one override or extend the following variables from @@ -78,6 +87,7 @@ Vernacular Commands - The `Set SsrHave NoTCResolution` command no longer has special global scope. If you want the previous behavior, use `Global Set SsrHave NoTCResolution`. +- Multiple sections with the same name are allowed. Coq binaries and process model @@ -105,12 +115,25 @@ SSReflect In particular rule 3 lets one write {x}/v even if v uses the variable x: indeed the view is executed before the renaming. -- An empty clear switch is now accepted in intro patterns before a +- An empty clear switch is now accepted in intro patterns before a view application whenever the view is a variable. One can now write {}/v to mean {v}/v. Remark that {}/x is very similar to the idiom {}e for the rewrite tactic (the equation e is used for rewriting and then discarded). +Standard Library + +- There are now conversions between [string] and [positive], [Z], + [nat], and [N] in binary, octal, and hex. + +Display diffs between proof steps + +- coqtop and coqide can now highlight the differences between proof steps + in color. This can be enabled from the command line or the + "Set Diffs on|off|removed" command. Please see the documentation for + details. Showing diffs in Proof General requires small changes to PG + (under discussion). + Changes from 8.8.0 to 8.8.1 =========================== @@ -3,7 +3,6 @@ [](https://gitlab.com/coq/coq/commits/master) [](https://travis-ci.org/coq/coq/builds) [](https://ci.appveyor.com/project/coq/coq/branch/master) -[](https://circleci.com/gh/coq/workflows/coq/tree/master) [](https://gitter.im/coq/coq) [](https://doi.org/10.5281/zenodo.1003420) diff --git a/checker/cic.mli b/checker/cic.mli index 4846a9af8c..df747692a4 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -202,16 +202,6 @@ type inline = int option (** A constant can have no body (axiom/parameter), or a transparent body, or an opaque one *) -(** Projections are a particular kind of constant: - always transparent. *) - -type projection_body = { - proj_ind : inductive; - proj_npars : int; - proj_arg : int; - proj_type : constr; (* Type under params *) -} - type constant_def = | Undef of inline | Def of constr_substituted @@ -254,7 +244,7 @@ type wf_paths = recarg Rtree.t type record_info = | NotRecord | FakeRecord -| PrimRecord of (Id.t * Constant.t array * projection_body array) array +| PrimRecord of (Id.t * Label.t array * constr array) array type regular_inductive_arity = { mind_user_arity : constr; diff --git a/checker/closure.ml b/checker/closure.ml index 2dcc1a9840..5706011607 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -273,7 +273,7 @@ let update v1 (no,t) = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * Projection.t + | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -497,8 +497,8 @@ let rec zip m stk = | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in zip {norm=neutr m.norm; term=t} s - | Zproj (i,j,cst) :: s -> - zip {norm=neutr m.norm; term=FProj (cst,m)} s + | Zproj p :: s -> + zip {norm=neutr m.norm; term=FProj (Projection.make p true,m)} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> @@ -618,21 +618,25 @@ let drop_parameters depth n argstk = let eta_expand_ind_stack env ind m s (f, s') = let mib = lookup_mind (fst ind) env in - match mib.mind_record with - | PrimRecord info when mib.mind_finite <> CoFinite -> - let (_, projs, pbs) = info.(snd ind) in - (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> - arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) - let pars = mib.mind_nparams in - let right = fapp_stack (f, s') in - let (depth, args, s) = strip_update_shift_app m s in - (** Try to drop the params, might fail on partially applied constructors. *) - let argss = try_drop_parameters depth pars args in - let hstack = - Array.map (fun p -> { norm = Red; (* right can't be a constructor though *) - term = FProj (Projection.make p false, right) }) projs in - argss, [Zapp hstack] - | _ -> raise Not_found (* disallow eta-exp for non-primitive records *) + (* disallow eta-exp for non-primitive records *) + if not (mib.mind_finite == BiFinite) then raise Not_found; + match Declarations.inductive_make_projections ind mib with + | Some projs -> + (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> + arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) + let pars = mib.mind_nparams in + let right = fapp_stack (f, s') in + let (depth, args, s) = strip_update_shift_app m s in + (** Try to drop the params, might fail on partially applied constructors. *) + let argss = try_drop_parameters depth pars args in + let hstack = + Array.map (fun p -> + { norm = Red; (* right can't be a constructor though *) + term = FProj (Projection.make p false, right) }) + projs + in + argss, [Zapp hstack] + | None -> raise Not_found (* disallow eta-exp for non-primitive records *) let rec project_nth_arg n argstk = match argstk with @@ -669,8 +673,7 @@ let contract_fix_vect fix = (subs_cons(Array.init nfix make_body, env), thisbody) let unfold_projection env p = - let pb = lookup_projection p env in - Zproj (pb.proj_npars, pb.proj_arg, p) + Zproj (Projection.repr p) (*********************************************************************) (* A machine that inspects the head of a term until it finds an @@ -748,9 +751,9 @@ let rec knr info m stk = let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info fxe fxbd stk' - | (depth, args, Zproj (n, m, cst)::s) -> - let rargs = drop_parameters depth n args in - let rarg = project_nth_arg m rargs in + | (depth, args, Zproj p::s) -> + let rargs = drop_parameters depth (Projection.Repr.npars p) args in + let rarg = project_nth_arg (Projection.Repr.arg p) rargs in kni info rarg s | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> diff --git a/checker/closure.mli b/checker/closure.mli index 49b07f730d..cec785699d 100644 --- a/checker/closure.mli +++ b/checker/closure.mli @@ -103,7 +103,7 @@ type fterm = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * Projection.t + | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr diff --git a/checker/declarations.ml b/checker/declarations.ml index a744a02279..0540227ccb 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -214,11 +214,7 @@ let rec map_kn f f' c = match c with | Const (kn, u) -> (try snd (f' kn u) with No_subst -> c) | Proj (p,t) -> - let p' = - Projection.map (fun kn -> - try fst (f' kn Univ.Instance.empty) - with No_subst -> kn) p - in + let p' = Projection.map f p in let t' = func t in if p' == p && t' == t then c else Proj (p', t') @@ -495,6 +491,16 @@ let eq_recarg r1 r2 = match r1, r2 with let eq_wf_paths = Rtree.equal eq_recarg +let inductive_make_projections ind mib = + match mib.mind_record with + | NotRecord | FakeRecord -> None + | PrimRecord infos -> + let projs = Array.mapi (fun proj_arg lab -> + Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab) + (pi2 infos.(snd ind)) + in + Some projs + (**********************************************************************) (* Representation of mutual inductive types in the kernel *) (* diff --git a/checker/declarations.mli b/checker/declarations.mli index 7458b3e0b0..ce852644ef 100644 --- a/checker/declarations.mli +++ b/checker/declarations.mli @@ -25,6 +25,9 @@ val dest_subterms : wf_paths -> wf_paths list array val eq_recarg : recarg -> recarg -> bool val eq_wf_paths : wf_paths -> wf_paths -> bool +val inductive_make_projections : Names.inductive -> mutual_inductive_body -> + Names.Projection.Repr.t array option + (* Modules *) val empty_delta_resolver : delta_resolver diff --git a/checker/environ.ml b/checker/environ.ml index ba1eb0ddb4..74cf237763 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -7,7 +7,6 @@ open Declarations type globals = { env_constants : constant_body Cmap_env.t; - env_projections : projection_body Cmap_env.t; env_inductives : mutual_inductive_body Mindmap_env.t; env_inductives_eq : KerName.t KNmap.t; env_modules : module_body MPmap.t; @@ -35,7 +34,6 @@ let empty_oracle = { let empty_env = { env_globals = { env_constants = Cmap_env.empty; - env_projections = Cmap_env.empty; env_inductives = Mindmap_env.empty; env_inductives_eq = KNmap.empty; env_modules = MPmap.empty; @@ -166,9 +164,6 @@ let evaluable_constant cst env = try let _ = constant_value env (cst, Univ.Instance.empty) in true with Not_found | NotEvaluableConst _ -> false -let lookup_projection p env = - Cmap_env.find (Projection.constant p) env.env_globals.env_projections - (* Mutual Inductives *) let scrape_mind env kn= try @@ -191,14 +186,6 @@ let add_mind kn mib env = 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 new_projections = match mib.mind_record with - | NotRecord | FakeRecord -> env.env_globals.env_projections - | PrimRecord projs -> - Array.fold_left (fun accu (id, kns, pbs) -> - Array.fold_left2 (fun accu kn pb -> - Cmap_env.add kn pb accu) accu kns pbs) - env.env_globals.env_projections projs - in let kn1,kn2 = MutInd.user kn, MutInd.canonical kn in let new_inds_eq = if KerName.equal kn1 kn2 then env.env_globals.env_inductives_eq @@ -207,10 +194,22 @@ let add_mind kn mib env = let new_globals = { env.env_globals with env_inductives = new_inds; - env_projections = new_projections; env_inductives_eq = new_inds_eq} in { env with env_globals = new_globals } +let lookup_projection p env = + let mind,i = Projection.inductive p in + let mib = lookup_mind mind env in + match mib.mind_record with + | NotRecord | FakeRecord -> CErrors.anomaly ~label:"lookup_projection" Pp.(str "not a projection") + | PrimRecord infos -> + let _,labs,typs = infos.(i) in + let parg = Projection.arg p in + if not (Label.equal labs.(parg) (Projection.label p)) + then CErrors.anomaly ~label:"lookup_projection" Pp.(str "incorrect label on projection") + else if not (Int.equal mib.mind_nparams (Projection.npars p)) + then CErrors.anomaly ~label:"lookup_projection" Pp.(str "incorrect param number on projection") + else typs.(parg) (* Modules *) diff --git a/checker/environ.mli b/checker/environ.mli index acb29d7d2d..af1b2a6228 100644 --- a/checker/environ.mli +++ b/checker/environ.mli @@ -5,7 +5,6 @@ open Cic type globals = { env_constants : constant_body Cmap_env.t; - env_projections : projection_body Cmap_env.t; env_inductives : mutual_inductive_body Mindmap_env.t; env_inductives_eq : KerName.t KNmap.t; env_modules : module_body MPmap.t; @@ -58,7 +57,8 @@ exception NotEvaluableConst of const_evaluation_result val constant_value : env -> Constant.t puniverses -> constr val evaluable_constant : Constant.t -> env -> bool -val lookup_projection : Projection.t -> env -> projection_body +(** NB: here in the checker we check the inferred info (npars, label) *) +val lookup_projection : Projection.t -> env -> constr (* Inductives *) val mind_equiv : env -> inductive -> inductive -> bool diff --git a/checker/reduction.ml b/checker/reduction.ml index 16c7012138..d36c0ef2c9 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -43,7 +43,7 @@ let compare_stack_shape stk1 stk2 = | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 - | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> + | (Zproj p1::s1, Zproj p2::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 | ((ZcaseT(c1,_,_,_))::s1, (ZcaseT(c2,_,_,_))::s2) -> @@ -55,7 +55,7 @@ let compare_stack_shape stk1 stk2 = type lft_constr_stack_elt = Zlapp of (lift * fconstr) array - | Zlproj of Names.Projection.t * lift + | Zlproj of Names.Projection.Repr.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list @@ -74,8 +74,8 @@ let pure_stack lfts stk = | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (Array.map (fun t -> (l,t)) a) pstk) - | (Zproj (n,m,c), (l,pstk)) -> - (l, Zlproj (c,l)::pstk) + | (Zproj p, (l,pstk)) -> + (l, Zlproj (p,l)::pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) @@ -133,7 +133,7 @@ let convert_universes univ u u' = if Univ.Instance.check_eq univ u u' then () else raise NotConvertible -let compare_stacks f fmind lft1 stk1 lft2 stk2 = +let compare_stacks f fmind fproj lft1 stk1 lft2 stk2 = let rec cmp_rec pstk1 pstk2 = match (pstk1,pstk2) with | (z1::s1, z2::s2) -> @@ -143,10 +143,8 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 = | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> f fx1 fx2; cmp_rec a1 a2 | (Zlproj (c1,l1),Zlproj (c2,l2)) -> - if not (Names.Constant.UserOrd.equal - (Names.Projection.constant c1) - (Names.Projection.constant c2)) then - raise NotConvertible + if not (fproj c1 c2) then + raise NotConvertible | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) -> if not (fmind ci1.ci_ind ci2.ci_ind) then raise NotConvertible; @@ -257,7 +255,7 @@ let rec no_case_available = function | Zupdate _ :: stk -> no_case_available stk | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk - | Zproj (_,_,_) :: _ -> false + | Zproj _ :: _ -> false | ZcaseT _ :: _ -> false | Zfix _ :: _ -> true @@ -300,6 +298,10 @@ let eq_table_key univ = Constant.UserOrd.equal c1 c2 && Univ.Instance.check_eq univ u1 u2) +let proj_equiv_infos infos p1 p2 = + Int.equal (Projection.Repr.arg p1) (Projection.Repr.arg p2) && + mind_equiv (infos_env infos) (Projection.Repr.inductive p1) (Projection.Repr.inductive p2) + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 = eqappr univ cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) @@ -523,7 +525,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = and convert_stacks univ infos lft1 lft2 stk1 stk2 = compare_stacks (fun (l1,t1) (l2,t2) -> ccnv univ CONV infos l1 l2 t1 t2) - (mind_equiv_infos infos) + (mind_equiv_infos infos) (proj_equiv_infos infos) lft1 stk1 lft2 stk2 and convert_vect univ infos lft1 lft2 v1 v2 = diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 3f7f844704..0916d98ddf 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -12,7 +12,6 @@ open Util open Names open Cic -open Term open Declarations open Environ open Reduction @@ -123,14 +122,6 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= env, Univ.make_abstract_instance auctx' | _ -> error () in - let eq_projection_body p1 p2 = - let check eq f = if not (eq (f p1) (f p2)) then error () in - check eq_ind (fun x -> x.proj_ind); - check (==) (fun x -> x.proj_npars); - check (==) (fun x -> x.proj_arg); - check (eq_constr) (fun x -> x.proj_type); - true - in let check_inductive_type t1 t2 = check_conv conv_leq env t1 t2 in let check_packet p1 p2 = @@ -188,9 +179,9 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= | FakeRecord, FakeRecord -> true | PrimRecord info1, PrimRecord info2 -> let check (id1, p1, pb1) (id2, p2, pb2) = - Id.equal id1 id2 && - Array.for_all2 Constant.UserOrd.equal p1 p2 && - Array.for_all2 eq_projection_body pb1 pb2 + (* we don't care about the id, the types are inferred from the inductive + (ie checked before now) *) + Array.for_all2 Label.equal p1 p2 in Array.equal check info1 info2 | _, _ -> false diff --git a/checker/typeops.ml b/checker/typeops.ml index 19ede4b9a2..138fe8bc95 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -198,14 +198,13 @@ let judge_of_case env ci pj (c,cj) lfj = (* Projection. *) let judge_of_projection env p c ct = - let pb = lookup_projection p env in + let pty = lookup_projection p env in let (ind,u), args = try find_rectype env ct with Not_found -> error_case_not_inductive env (c, ct) in - assert(eq_ind pb.proj_ind ind); - let ty = subst_instance_constr u pb.proj_type in - substl (c :: List.rev args) ty + let ty = subst_instance_constr u pty in + substl (c :: List.rev args) ty (* Fixpoints. *) diff --git a/checker/values.ml b/checker/values.ml index 88cdb644db..e68cd18b87 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -15,7 +15,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 c395aa2dbfc18794b3b7192f3dc5b2e5 checker/cic.mli +MD5 064cd8d9651d37aebf77fb638b889cad checker/cic.mli *) @@ -135,7 +135,9 @@ let v_caseinfo = v_tuple "case_info" [|v_ind;Int;Array Int;Array Int;v_cprint|] let v_cast = v_enum "cast_kind" 4 -let v_proj = v_tuple "projection" [|v_cst; v_bool|] + +let v_proj_repr = v_tuple "projection_repr" [|v_ind;Int;Int;v_id|] +let v_proj = v_tuple "projection" [|v_proj_repr; v_bool|] let rec v_constr = Sum ("constr",0,[| @@ -223,10 +225,6 @@ let v_cst_def = v_sum "constant_def" 0 [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]|] -let v_projbody = - v_tuple "projection_body" - [|v_ind;Int;Int;v_constr|] - let v_typing_flags = v_tuple "typing_flags" [|v_bool; v_bool; v_oracle|] @@ -277,7 +275,7 @@ let v_finite = v_enum "recursivity_kind" 3 let v_record_info = v_sum "record_info" 2 - [| [| Array (v_tuple "record" [| v_id; Array v_cst; Array v_projbody |]) |] |] + [| [| Array (v_tuple "record" [| v_id; Array v_id; Array v_constr |]) |] |] let v_ind_pack_univs = v_sum "abstract_inductive_universes" 0 diff --git a/clib/cArray.ml b/clib/cArray.ml index fc87a74cf6..d509c55b9a 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -59,6 +59,7 @@ sig ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val map_left : ('a -> 'b) -> 'a array -> 'b array val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit + val iter2_i : (int -> 'a -> 'b -> unit) -> 'a array -> 'b array -> unit val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array val fold_right_map : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array @@ -407,6 +408,12 @@ let iter2 f v1 v2 = let () = if not (Int.equal len2 len1) then invalid_arg "Array.iter2" in for i = 0 to len1 - 1 do f (uget v1 i) (uget v2 i) done +let iter2_i f v1 v2 = + let len1 = Array.length v1 in + let len2 = Array.length v2 in + let () = if not (Int.equal len2 len1) then invalid_arg "Array.iter2" in + for i = 0 to len1 - 1 do f i (uget v1 i) (uget v2 i) done + let pure_functional = false let fold_right_map f v e = diff --git a/clib/cArray.mli b/clib/cArray.mli index 8bf33f82f9..5c7e09eeac 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -101,6 +101,9 @@ sig val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit (** Iter on two arrays. Raise [Invalid_argument "Array.iter2"] if sizes differ. *) + val iter2_i : (int -> 'a -> 'b -> unit) -> 'a array -> 'b array -> unit + (** Iter on two arrays. Raise [Invalid_argument "Array.iter2_i"] if sizes differ. *) + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array (** [fold_left_map f e_0 [|l_1...l_n|] = e_n,[|k_1...k_n|]] where [(e_i,k_i)=f e_{i-1} l_i]; see also [Smart.fold_left_map] *) diff --git a/clib/clib.mllib b/clib/clib.mllib index afece4074c..5a2c9a9ce9 100644 --- a/clib/clib.mllib +++ b/clib/clib.mllib @@ -37,3 +37,5 @@ Backtrace IStream Terminal Monad + +Diff2 diff --git a/clib/diff2.ml b/clib/diff2.ml new file mode 100644 index 0000000000..42c4733fed --- /dev/null +++ b/clib/diff2.ml @@ -0,0 +1,158 @@ +(* copied from https://github.com/leque/ocaml-diff.git and renamed from "diff.ml" *) + +(* + * Copyright (C) 2016 OOHASHI Daichi + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + * THE SOFTWARE. + *) + +type 'a common = + [ `Common of int * int * 'a ] + +type 'a edit = + [ `Added of int * 'a + | `Removed of int * 'a + | 'a common + ] + +module type SeqType = sig + type t + type elem + val get : t -> int -> elem + val length : t -> int +end + +module type S = sig + type t + type elem + + val lcs : + ?equal:(elem -> elem -> bool) -> + t -> t -> elem common list + + val diff : + ?equal:(elem -> elem -> bool) -> + t -> t -> elem edit list + + val fold_left : + ?equal:(elem -> elem -> bool) -> + f:('a -> elem edit -> 'a) -> + init:'a -> + t -> t -> 'a + + val iter : + ?equal:(elem -> elem -> bool) -> + f:(elem edit -> unit) -> + t -> t -> unit +end + +module Make(M : SeqType) : (S with type t = M.t and type elem = M.elem) = struct + type t = M.t + type elem = M.elem + + let lcs ?(equal = (=)) a b = + let n = M.length a in + let m = M.length b in + let mn = m + n in + let sz = 2 * mn + 1 in + let vd = Array.make sz 0 in + let vl = Array.make sz 0 in + let vr = Array.make sz [] in + let get v i = Array.get v (i + mn) in + let set v i x = Array.set v (i + mn) x in + let finish () = + let rec loop i maxl r = + if i > mn then + List.rev r + else if get vl i > maxl then + loop (i + 1) (get vl i) (get vr i) + else + loop (i + 1) maxl r + in loop (- mn) 0 [] + in + if mn = 0 then + [] + else + (* For d <- 0 to mn Do *) + let rec dloop d = + assert (d <= mn); + (* For k <- -d to d in steps of 2 Do *) + let rec kloop k = + if k > d then + dloop @@ d + 1 + else + let x, l, r = + if k = -d || (k <> d && get vd (k - 1) < get vd (k + 1)) then + get vd (k + 1), get vl (k + 1), get vr (k + 1) + else + get vd (k - 1) + 1, get vl (k - 1), get vr (k - 1) + in + let x, y, l, r = + let rec xyloop x y l r = + if x < n && y < m && equal (M.get a x) (M.get b y) then + xyloop (x + 1) (y + 1) (l + 1) (`Common(x, y, M.get a x) :: r) + else + x, y, l, r + in xyloop x (x - k) l r + in + set vd k x; + set vl k l; + set vr k r; + if x >= n && y >= m then + (* Stop *) + finish () + else + kloop @@ k + 2 + in kloop @@ -d + in dloop 0 + + let fold_left ?(equal = (=)) ~f ~init a b = + let ff x y = f y x in + let fold_map f g x from to_ init = + let rec loop i init = + if i >= to_ then + init + else + loop (i + 1) (f (g i @@ M.get x i) init) + in loop from init + in + let added i x = `Added (i, x) in + let removed i x = `Removed (i, x) in + let rec loop cs apos bpos init = + match cs with + | [] -> + init + |> fold_map ff removed a apos (M.length a) + |> fold_map ff added b bpos (M.length b) + | `Common (aoff, boff, _) as e :: rest -> + init + |> fold_map ff removed a apos aoff + |> fold_map ff added b bpos boff + |> ff e + |> loop rest (aoff + 1) (boff + 1) + in loop (lcs ~equal a b) 0 0 init + + let diff ?(equal = (=)) a b = + fold_left ~equal ~f:(fun xs x -> x::xs) ~init:[] a b + + let iter ?(equal = (=)) ~f a b = + fold_left a b + ~equal + ~f:(fun () x -> f x) + ~init:() +end diff --git a/clib/diff2.mli b/clib/diff2.mli new file mode 100644 index 0000000000..a085f4ffe8 --- /dev/null +++ b/clib/diff2.mli @@ -0,0 +1,101 @@ +(* copied from https://github.com/leque/ocaml-diff.git and renamed from "diff.mli" *) +(** + An implementation of Eugene Myers' O(ND) Difference Algorithm\[1\]. + This implementation is a port of util.lcs module of + {{:http://practical-scheme.net/gauche} Gauche Scheme interpreter}. + + - \[1\] Eugene Myers, An O(ND) Difference Algorithm and Its Variations, Algorithmica Vol. 1 No. 2, pp. 251-266, 1986. + *) + +type 'a common = [ + `Common of int * int * 'a + ] +(** an element of lcs of seq1 and seq2 *) + +type 'a edit = + [ `Removed of int * 'a + | `Added of int * 'a + | 'a common + ] +(** an element of diff of seq1 and seq2. *) + +module type SeqType = sig + type t + (** The type of the sequence. *) + + type elem + (** The type of the elements of the sequence. *) + + val get : t -> int -> elem + (** [get t n] returns [n]-th element of the sequence [t]. *) + + val length : t -> int + (** [length t] returns the length of the sequence [t]. *) +end +(** Input signature of {!Diff.Make}. *) + +module type S = sig + type t + (** The type of input sequence. *) + + type elem + (** The type of the elements of result / input sequence. *) + + val lcs : + ?equal:(elem -> elem -> bool) -> + t -> t -> elem common list + (** + [lcs ~equal seq1 seq2] computes the LCS (longest common sequence) of + [seq1] and [seq2]. + Elements of [seq1] and [seq2] are compared with [equal]. + [equal] defaults to [Pervasives.(=)]. + + Elements of lcs are [`Common (pos1, pos2, e)] + where [e] is an element, [pos1] is a position in [seq1], + and [pos2] is a position in [seq2]. + *) + + val diff : + ?equal:(elem -> elem -> bool) -> + t -> t -> elem edit list + (** + [diff ~equal seq1 seq2] computes the diff of [seq1] and [seq2]. + Elements of [seq1] and [seq2] are compared with [equal]. + + Elements only in [seq1] are represented as [`Removed (pos, e)] + where [e] is an element, and [pos] is a position in [seq1]; + those only in [seq2] are represented as [`Added (pos, e)] + where [e] is an element, and [pos] is a position in [seq2]; + those common in [seq1] and [seq2] are represented as + [`Common (pos1, pos2, e)] + where [e] is an element, [pos1] is a position in [seq1], + and [pos2] is a position in [seq2]. + *) + + val fold_left : + ?equal:(elem -> elem -> bool) -> + f:('a -> elem edit -> 'a) -> + init:'a -> + t -> t -> 'a + (** + [fold_left ~equal ~f ~init seq1 seq2] is same as + [diff ~equal seq1 seq2 |> ListLabels.fold_left ~f ~init], + but does not create an intermediate list. + *) + + val iter : + ?equal:(elem -> elem -> bool) -> + f:(elem edit -> unit) -> + t -> t -> unit + (** + [iter ~equal ~f seq1 seq2] is same as + [diff ~equal seq1 seq2 |> ListLabels.iter ~f], + but does not create an intermediate list. + *) +end +(** Output signature of {!Diff.Make}. *) + +module Make : + functor (M : SeqType) -> (S with type t = M.t and type elem = M.elem) +(** Functor building an implementation of the diff structure + given a sequence type. *) diff --git a/clib/terminal.ml b/clib/terminal.ml index 1d9468137b..d243d6599e 100644 --- a/clib/terminal.ml +++ b/clib/terminal.ml @@ -59,6 +59,19 @@ let default = { suffix = None; } +let reset = "\027[0m" + +let reset_style = { + fg_color = Some `DEFAULT; + bg_color = Some `DEFAULT; + bold = Some false; + italic = Some false; + underline = Some false; + negative = Some false; + prefix = None; + suffix = None; +} + let make ?fg_color ?bg_color ?bold ?italic ?underline ?negative ?style ?prefix ?suffix () = let st = match style with | None -> default @@ -87,6 +100,25 @@ let merge s1 s2 = suffix = set s1.suffix s2.suffix; } +let diff s1 s2 = + let diff_op o1 o2 reset_val = match o1 with + | None -> o2 + | Some _ -> + match o2 with + | None -> reset_val + | Some _ -> if o1 = o2 then None else o2 in + + { + fg_color = diff_op s1.fg_color s2.fg_color reset_style.fg_color; + bg_color = diff_op s1.bg_color s2.bg_color reset_style.bg_color; + bold = diff_op s1.bold s2.bold reset_style.bold; + italic = diff_op s1.italic s2.italic reset_style.italic; + underline = diff_op s1.underline s2.underline reset_style.underline; + negative = diff_op s1.negative s2.negative reset_style.negative; + prefix = diff_op s1.prefix s2.prefix reset_style.prefix; + suffix = diff_op s1.suffix s2.suffix reset_style.suffix; + } + let base_color = function | `DEFAULT -> 9 | `BLACK -> 0 @@ -167,20 +199,8 @@ let repr st = let eval st = let tags = repr st in let tags = List.map string_of_int tags in - Printf.sprintf "\027[%sm" (String.concat ";" tags) - -let reset = "\027[0m" - -let reset_style = { - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; - prefix = None; - suffix = None; -} + if List.length tags = 0 then "" else + Printf.sprintf "\027[%sm" (String.concat ";" tags) let has_style t = Unix.isatty t && Sys.os_type = "Unix" diff --git a/clib/terminal.mli b/clib/terminal.mli index dbf8d4640c..bc30b0016f 100644 --- a/clib/terminal.mli +++ b/clib/terminal.mli @@ -51,6 +51,9 @@ val make : ?fg_color:color -> ?bg_color:color -> val merge : style -> style -> style (** [merge s1 s2] returns [s1] with all defined values of [s2] overwritten. *) +val diff : style -> style -> style +(** [diff s1 s2] returns the differences between [s1] and [s2]. *) + val repr : style -> int list (** Generate the ANSI code representing the given style. *) @@ -60,6 +63,9 @@ val eval : style -> string val reset : string (** This escape sequence resets all attributes. *) +val reset_style : style +(** The default style *) + val has_style : Unix.file_descr -> bool (** Whether an output file descriptor handles styles. Very heuristic, only checks it is a terminal. *) diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index e76a1e9ed8..fd425ef4ff 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -326,10 +326,14 @@ let print_ast fmt ext = end +let declare_plugin fmt name = + fprintf fmt "let %s = \"%s\"@\n" plugin_name name; + fprintf fmt "let _ = Mltop.add_known_module %s@\n" plugin_name + let pr_ast fmt = function | Code s -> fprintf fmt "%s@\n" s.code | Comment s -> fprintf fmt "%s@\n" s -| DeclarePlugin name -> fprintf fmt "let %s = \"%s\"@\n" plugin_name name +| DeclarePlugin name -> declare_plugin fmt name | GramExt gram -> fprintf fmt "%a@\n" GramExt.print_ast gram | VernacExt -> fprintf fmt "VERNACEXT@\n" | TacticExt tac -> fprintf fmt "%a@\n" TacticExt.print_ast tac diff --git a/dev/ci/README.md b/dev/ci/README.md index 45176581cd..43d680af61 100644 --- a/dev/ci/README.md +++ b/dev/ci/README.md @@ -75,9 +75,6 @@ We are currently running tests on the following platforms: camlp5, and with warnings as errors; it runs the test-suite and tests the compilation of several external developments. -- Circle CI runs tests that are redundant with GitLab CI and may be removed - eventually. - - Travis CI is used to test the compilation of Coq and run the test-suite on macOS. It also runs a linter that checks whitespace discipline. A [pre-commit hook](../tools/pre-commit) is automatically installed by @@ -165,8 +162,7 @@ automatically built and uploaded to your GitLab registry, and is loaded by subsequent jobs. **IMPORTANT**: When updating Coq's CI docker image, you must modify -the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml), -[`.circleci/config.yml`](../../.circleci/config.yml), +the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml) and [`Dockerfile`](docker/bionic_coq/Dockerfile) The Docker building job reuses the uploaded image if it is available, diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index a68cd0933e..9259a6e0c8 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -20,10 +20,6 @@ else then export CI_PULL_REQUEST="$TRAVIS_PULL_REQUEST" export CI_BRANCH="$TRAVIS_BRANCH" - elif [ -n "${CIRCLECI}" ]; - then - export CI_PULL_REQUEST="$CIRCLE_PR_NUMBER" - export CI_BRANCH="$CIRCLE_BRANCH" else # assume local CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" export CI_BRANCH diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 6ded97984e..184b90a50b 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -7,4 +7,4 @@ HoTT_CI_DIR="${CI_BUILD_DIR}"/HoTT git_checkout "${HoTT_CI_BRANCH}" "${HoTT_CI_GITURL}" "${HoTT_CI_DIR}" -( cd "${HoTT_CI_DIR}" && ./autogen.sh && ./configure && make ) +( cd "${HoTT_CI_DIR}" && ./autogen.sh && ./configure && make && make validate ) diff --git a/dev/ci/user-overlays/07859-printers.sh b/dev/ci/user-overlays/07859-printers.sh new file mode 100644 index 0000000000..27f588e214 --- /dev/null +++ b/dev/ci/user-overlays/07859-printers.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "7859" ] || [ "$CI_BRANCH" = "rm-univ-broken-printing" ]; then + Equations_CI_BRANCH=fix-printers + Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations +fi diff --git a/dev/ci/user-overlays/07908-proj-mind.sh b/dev/ci/user-overlays/07908-proj-mind.sh new file mode 100644 index 0000000000..293eeb5a5a --- /dev/null +++ b/dev/ci/user-overlays/07908-proj-mind.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "7908" ] || [ "$CI_BRANCH" = "proj-mind" ]; then + Equations_CI_BRANCH=fix-proj-mind + Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations +fi diff --git a/dev/ci/user-overlays/08063-jasongross-string-eqb.sh b/dev/ci/user-overlays/08063-jasongross-string-eqb.sh new file mode 100644 index 0000000000..99a11b9fbf --- /dev/null +++ b/dev/ci/user-overlays/08063-jasongross-string-eqb.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "8063" ] || [ "$CI_BRANCH" = "string-eqb" ]; then + quickchick_CI_BRANCH=fix-for-pr-8063 + quickchick_CI_GITURL=https://github.com/JasonGross/QuickChick +fi diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index c8385da618..98190b05b5 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -17,7 +17,7 @@ let ppripos (ri,pos) = | Reloc_getglobal kn -> print_string ("getglob "^(Constant.to_string kn)^"\n") | Reloc_proj_name p -> - print_string ("proj "^(Constant.to_string p)^"\n") + print_string ("proj "^(Projection.Repr.to_string p)^"\n") ); print_flush () diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index d9b2490452..394b928ada 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -781,7 +781,8 @@ Section :ref:`gallina-definitions`). .. cmd:: Section @ident - This command is used to open a section named `ident`. + This command is used to open a section named :token:`ident`. + Section names do not need to be unique. .. cmd:: End @ident diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index bdaa2aa1a2..e15bcb8e2c 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -546,12 +546,12 @@ The printing for one token can be removed with Initially, the pretty-printing table contains the following mapping: -==== === ==== ===== === ==== ==== === -`->` → `<-` ← `*` × -`<=` ≤ `>=` ≥ `=>` ⇒ -`<>` ≠ `<->` ↔ `|-` ⊢ -`\/` ∨ `/\\` ∧ `~` ¬ -==== === ==== ===== === ==== ==== === +===== === ==== ===== === ==== ==== === +`->` → `<-` ← `*` × +`<=` ≤ `>=` ≥ `=>` ⇒ +`<>` ≠ `<->` ↔ `|-` ⊢ +`\\/` ∨ `/\\` ∧ `~` ¬ +===== === ==== ===== === ==== ==== === Any of these can be overwritten or suppressed using the printing commands. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 9b4d724e02..306673d9a2 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -281,7 +281,7 @@ Applying theorems :g:`t`:sub:`n` in the goal. See :tacn:`pattern` to transform the goal so that it gets the form :g:`(fun x => Q) u`:sub:`1` :g:`...` :g:`u`:sub:`n`. - .. exn:: Unable to unify ... with ... . + .. exn:: Unable to unify @term with @term. The apply tactic failed to match the conclusion of :token:`term` and the current goal. You can help the apply tactic by transforming your goal with @@ -3935,7 +3935,7 @@ match against it. discriminable equality but this proof could not be built in Coq because of dependently-typed functions. -.. exn:: Goal is solvable by congruence but some arguments are missing. Try congruence with ..., replacing metavariables by arbitrary terms. +.. exn:: Goal is solvable by congruence but some arguments are missing. Try congruence with {+ @term}, replacing metavariables by arbitrary terms. The decision procedure could solve the goal with the provision that additional arguments are supplied for some partially applied constructors. Any term of an diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 8c09b23a5a..f448248468 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -498,6 +498,9 @@ through the <tt>Require Import</tt> command.</p> <dd> theories/Strings/Ascii.v theories/Strings/String.v + theories/Strings/BinaryString.v + theories/Strings/HexString.v + theories/Strings/OctalString.v </dd> <dt> <b>Reals</b>: diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 005ef16351..3dc1933a14 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -565,9 +565,8 @@ let compare_head_gen_proj env sigma equ eqs eqc' nargs m n = | App (f, args), Proj (p, c) -> (match kind_upto sigma f with | Const (p', u) when Constant.equal (Projection.constant p) p' -> - let pb = Environ.lookup_projection p env in - let npars = pb.Declarations.proj_npars in - if Array.length args == npars + 1 then + let npars = Projection.npars p in + if Array.length args == npars + 1 then eqc' 0 c args.(npars) else false | _ -> false) diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 323a12357d..f3af318b60 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -48,3 +48,5 @@ val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.ex val type_of_user_symbol : user_symbol -> argument_type val parse_user_entry : string -> string -> user_symbol + +val mlexpr_of_symbol : user_symbol -> MLast.expr diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp index 0b8d7fda7a..0e2bf55d86 100644 --- a/grammar/q_util.mlp +++ b/grammar/q_util.mlp @@ -128,3 +128,17 @@ let rec parse_user_entry s sep = let s = match s with "hyp" -> "var" | _ -> s in check_separator sep; Uentry s + +let rec mlexpr_of_symbol = function +| Ulist1 s -> <:expr< Extend.TUlist1 $mlexpr_of_symbol s$ >> +| Ulist1sep (s,sep) -> <:expr< Extend.TUlist1sep $mlexpr_of_symbol s$ $str:sep$ >> +| Ulist0 s -> <:expr< Extend.TUlist0 $mlexpr_of_symbol s$ >> +| Ulist0sep (s,sep) -> <:expr< Extend.TUlist0sep $mlexpr_of_symbol s$ $str:sep$ >> +| Uopt s -> <:expr< Extend.TUopt $mlexpr_of_symbol s$ >> +| Uentry e -> + let wit = <:expr< $lid:"wit_"^e$ >> in + <:expr< Extend.TUentry (Genarg.get_arg_tag $wit$) >> +| Uentryl (e, l) -> + assert (e = "tactic"); + let wit = <:expr< $lid:"wit_"^e$ >> in + <:expr< Extend.TUentryl (Genarg.get_arg_tag $wit$) $mlexpr_of_int l$>> diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index 02da61ef77..07239e7af0 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -15,20 +15,6 @@ open Argextend let plugin_name = <:expr< __coq_plugin_name >> -let rec mlexpr_of_symbol = function -| Ulist1 s -> <:expr< Extend.TUlist1 $mlexpr_of_symbol s$ >> -| Ulist1sep (s,sep) -> <:expr< Extend.TUlist1sep $mlexpr_of_symbol s$ $str:sep$ >> -| Ulist0 s -> <:expr< Extend.TUlist0 $mlexpr_of_symbol s$ >> -| Ulist0sep (s,sep) -> <:expr< Extend.TUlist0sep $mlexpr_of_symbol s$ $str:sep$ >> -| Uopt s -> <:expr< Extend.TUopt $mlexpr_of_symbol s$ >> -| Uentry e -> - let wit = <:expr< $lid:"wit_"^e$ >> in - <:expr< Extend.TUentry (Genarg.get_arg_tag $wit$) >> -| Uentryl (e, l) -> - assert (e = "tactic"); - let wit = <:expr< $lid:"wit_"^e$ >> in - <:expr< Extend.TUentryl (Genarg.get_arg_tag $wit$) $mlexpr_of_int l$>> - let rec mlexpr_of_clause = function | [] -> <:expr< TyNil >> | ExtTerminal s :: cl -> <:expr< TyIdent($str:s$, $mlexpr_of_clause cl$) >> diff --git a/grammar/vernacextend.mlp b/grammar/vernacextend.mlp index a2872d07f6..f30c96a7f5 100644 --- a/grammar/vernacextend.mlp +++ b/grammar/vernacextend.mlp @@ -14,134 +14,42 @@ open Q_util open Argextend type rule = { - r_head : string option; - (** The first terminal grammar token *) r_patt : extend_token list; (** The remaining tokens of the parsing rule *) r_class : MLast.expr option; (** An optional classifier for the STM *) r_branch : MLast.expr; (** The action performed by this rule. *) - r_depr : unit option; + r_depr : bool; (** Whether this entry is deprecated *) } -(** Quotation difference for match clauses *) - -let default_patt loc = - (<:patt< _ >>, ploc_vala None, <:expr< failwith "Extension: cannot occur" >>) - -let make_fun loc cl = - let l = cl @ [default_patt loc] in - MLast.ExFun (loc, ploc_vala l) (* correspond to <:expr< fun [ $list:l$ ] >> *) - -let rec make_patt = function - | [] -> <:patt< [] >> - | ExtNonTerminal (_, Some p) :: l -> - <:patt< [ $lid:p$ :: $make_patt l$ ] >> - | _::l -> make_patt l - -let rec make_let e = function - | [] -> e - | ExtNonTerminal (g, Some p) :: l -> - let t = type_of_user_symbol g in - let loc = MLast.loc_of_expr e in - let e = make_let e l in - <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> - | _::l -> make_let e l - -let make_clause { r_patt = pt; r_branch = e; } = - (make_patt pt, - ploc_vala None, - make_let e pt) - -(* To avoid warnings *) -let mk_ignore c pt = - let fold accu = function - | ExtNonTerminal (_, Some p) -> p :: accu - | _ -> accu - in - let names = List.fold_left fold [] pt in - let fold accu id = <:expr< let _ = $lid:id$ in $accu$ >> in - let names = List.fold_left fold <:expr< () >> names in - <:expr< do { let _ = $names$ in $c$ } >> - -let make_clause_classifier cg s { r_patt = pt; r_class = c; } = - match c ,cg with - | Some c, _ -> - (make_patt pt, - ploc_vala None, - make_let (mk_ignore c pt) pt) - | None, Some cg -> - (make_patt pt, - ploc_vala None, - <:expr< fun loc -> $cg$ $str:s$ >>) - | None, None -> prerr_endline - (("Vernac entry \""^s^"\" misses a classifier. "^ - "A classifier is a function that returns an expression "^ - "of type vernac_classification (see Vernacexpr). You can: ") ^ - "- " ^ ( - ("Use '... EXTEND "^s^" CLASSIFIED AS QUERY ...' if the "^ - "new vernacular command does not alter the system state;"))^ "\n" ^ - "- " ^ ( - ("Use '... EXTEND "^s^" CLASSIFIED AS SIDEFF ...' if the "^ - "new vernacular command alters the system state but not the "^ - "parser nor it starts a proof or ends one;"))^ "\n" ^ - "- " ^ ( - ("Use '... EXTEND "^s^" CLASSIFIED BY f ...' to specify "^ - "a global function f. The function f will be called passing "^ - "\""^s^"\" as the only argument;")) ^ "\n" ^ - "- " ^ ( - "Add a specific classifier in each clause using the syntax:" - ^ "\n" ^("'[...] => [ f ] -> [...]'. "))^ "\n" ^ - ("Specific classifiers have precedence over global "^ - "classifiers. Only one classifier is called.") ^ "\n"); - (make_patt pt, - ploc_vala None, - <:expr< fun () -> ( CErrors.anomaly (Pp.str "No classification given for command " ^ s ) ) >>) - -let make_fun_clauses loc s l = - let map c = - let depr = match c.r_depr with - | None -> false - | Some () -> true - in - let cl = make_fun loc [make_clause c] in - <:expr< ($mlexpr_of_bool depr$, $cl$)>> - in - mlexpr_of_list map l - -let make_fun_classifiers loc s c l = - let cl = List.map (fun x -> make_fun loc [make_clause_classifier c s x]) l in - mlexpr_of_list (fun x -> x) cl - -let make_prod_item = function - | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> - | ExtNonTerminal (g, ido) -> - let nt = type_of_user_symbol g in - let base s = <:expr< Pcoq.genarg_grammar ($mk_extraarg loc s$) >> in - let typ = match ido with None -> None | Some _ -> Some nt in - <:expr< Egramml.GramNonTerminal ( Loc.tag ( $mlexpr_of_option (make_rawwit loc) typ$ , - $mlexpr_of_prod_entry_key base g$ ) ) >> - -let mlexpr_of_clause cl = - let mkexpr { r_head = a; r_patt = b; } = match a with - | None -> mlexpr_of_list make_prod_item b - | Some a -> mlexpr_of_list make_prod_item (ExtTerminal a :: b) - in - mlexpr_of_list mkexpr cl +let rec make_patt r = function +| [] -> r +| ExtNonTerminal (_, Some p) :: l -> <:expr< fun $lid:p$ -> $make_patt r l$ >> +| ExtNonTerminal (_, None) :: l -> <:expr< fun _ -> $make_patt r l$ >> +| ExtTerminal _ :: l -> make_patt r l + +let rec mlexpr_of_clause = function +| [] -> <:expr< Vernacentries.TyNil >> +| ExtTerminal s :: cl -> <:expr< Vernacentries.TyTerminal ($str:s$, $mlexpr_of_clause cl$) >> +| ExtNonTerminal (g, id) :: cl -> + let id = mlexpr_of_option mlexpr_of_string id in + <:expr< Vernacentries.TyNonTerminal ($id$, $mlexpr_of_symbol g$, $mlexpr_of_clause cl$) >> + +let make_rule r = + let ty = mlexpr_of_clause r.r_patt in + let cmd = make_patt r.r_branch r.r_patt in + let make_classifier c = make_patt c r.r_patt in + let classif = mlexpr_of_option make_classifier r.r_class in + <:expr< Vernacentries.TyML ($mlexpr_of_bool r.r_depr$, $ty$, $cmd$, $classif$) >> let declare_command loc s c nt cl = let se = mlexpr_of_string s in - let gl = mlexpr_of_clause cl in - let funcl = make_fun_clauses loc s cl in - let classl = make_fun_classifiers loc s c cl in + let c = mlexpr_of_option (fun x -> x) c in + let rules = mlexpr_of_list make_rule cl in declare_str_items loc - [ <:str_item< do { - CList.iteri (fun i (depr, f) -> Vernacinterp.vinterp_add depr ($se$, i) f) $funcl$; - CList.iteri (fun i f -> Vernac_classifier.declare_vernac_classifier ($se$, i) f) $classl$; - CList.iteri (fun i r -> Egramml.extend_vernac_command_grammar ($se$, i) $nt$ r) $gl$; - } >> ] + [ <:str_item< Vernacentries.vernac_extend ?{ classifier = $c$ } ~{ command = $se$ } ?{ entry = $nt$ } $rules$ >> ] open Pcaml @@ -176,38 +84,25 @@ EXTEND ] ] ; deprecation: - [ [ "DEPRECATED" -> () ] ] + [ [ -> false | "DEPRECATED" -> true ] ] ; - (* spiwack: comment-by-guessing: it seems that the isolated string - (which otherwise could have been another argument) is not passed - to the VernacExtend interpreter function to discriminate between - the clauses. *) rule: - [ [ "["; s = STRING; l = LIST0 args; "]"; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let () = if s = "" then failwith "Command name is empty." in - let b = <:expr< fun ~{atts} ~{st} -> ( let () = $e$ in st ) >> in - { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } - | "[" ; "-" ; l = LIST1 args ; "]" ; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> + [ [ "["; OPT "-"; l = LIST1 args; "]"; + d = deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> let b = <:expr< fun ~{atts} ~{st} -> ( let () = $e$ in st ) >> in - { r_head = None; r_patt = l; r_class = c; r_branch = b; r_depr = d; } + { r_patt = l; r_class = c; r_branch = b; r_depr = d; } ] ] ; + (** The [OPT "-"] argument serves no purpose nowadays, it is left here for + backward compatibility. *) fun_rule: - [ [ "["; s = STRING; l = LIST0 args; "]"; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let () = if s = "" then failwith "Command name is empty." in - let b = <:expr< $e$ >> in - { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } - | "[" ; "-" ; l = LIST1 args ; "]" ; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let b = <:expr< $e$ >> in - { r_head = None; r_patt = l; r_class = c; r_branch = b; r_depr = d; } + [ [ "["; OPT "-"; l = LIST1 args; "]"; + d = deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> + { r_patt = l; r_class = c; r_branch = e; r_depr = d; } ] ] ; classifier: - [ [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< fun loc -> $c$>> ] ] + [ [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< $c$>> ] ] ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> diff --git a/ide/coq.ml b/ide/coq.ml index 63986935aa..e948360191 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -530,20 +530,31 @@ let break_coqtop coqtop workers = module PrintOpt = struct - type t = string list + type _ t = + | BoolOpt : string list -> bool t + | StringOpt : string list -> string t + + let opt_name (type a) : a t -> string list = function + | BoolOpt l -> l + | StringOpt l -> l + + let opt_data (type a) (key : a t) (v : a) = match key with + | BoolOpt l -> Interface.BoolValue v + | StringOpt l -> Interface.StringValue v (* Boolean options *) - let implicit = ["Printing"; "Implicit"] - let coercions = ["Printing"; "Coercions"] - let raw_matching = ["Printing"; "Matching"] - let notations = ["Printing"; "Notations"] - let all_basic = ["Printing"; "All"] - let existential = ["Printing"; "Existential"; "Instances"] - let universes = ["Printing"; "Universes"] - let unfocused = ["Printing"; "Unfocused"] + let implicit = BoolOpt ["Printing"; "Implicit"] + let coercions = BoolOpt ["Printing"; "Coercions"] + let raw_matching = BoolOpt ["Printing"; "Matching"] + let notations = BoolOpt ["Printing"; "Notations"] + let all_basic = BoolOpt ["Printing"; "All"] + let existential = BoolOpt ["Printing"; "Existential"; "Instances"] + let universes = BoolOpt ["Printing"; "Universes"] + let unfocused = BoolOpt ["Printing"; "Unfocused"] + let diff = StringOpt ["Diffs"] - type bool_descr = { opts : t list; init : bool; label : string } + type 'a descr = { opts : 'a t list; init : 'a; label : string } let bool_items = [ { opts = [implicit]; init = false; label = "Display _implicit arguments" }; @@ -561,24 +572,32 @@ struct { opts = [unfocused]; init = false; label = "Display _unfocused goals" } ] + let diff_item = { opts = [diff]; init = "off"; label = "Display _proof diffs" } + (** The current status of the boolean options *) let current_state = Hashtbl.create 11 - let set opt v = Hashtbl.replace current_state opt v + let set (type a) (opt : a t) (v : a) = + Hashtbl.replace current_state (opt_name opt) (opt_data opt v) let reset () = let init_descr d = List.iter (fun o -> set o d.init) d.opts in - List.iter init_descr bool_items + List.iter init_descr bool_items; + List.iter (fun o -> set o diff_item.init) diff_item.opts let _ = reset () - let printing_unfocused () = Hashtbl.find current_state unfocused + let printing_unfocused () = + let BoolOpt unfocused = unfocused in + match Hashtbl.find current_state unfocused with + | Interface.BoolValue b -> b + | _ -> assert false (** Transmitting options to coqtop *) let enforce h k = - let mkopt o v acc = (o, Interface.BoolValue v) :: acc in + let mkopt o v acc = (o, v) :: acc in let opts = Hashtbl.fold mkopt current_state [] in eval_call (Xmlprotocol.set_options opts) h (function diff --git a/ide/coq.mli b/ide/coq.mli index 40a6dea8d3..3af0aa697e 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -134,13 +134,15 @@ val stop_worker: Interface.stop_worker_sty-> Interface.stop_worker_rty query module PrintOpt : sig - type t (** Representation of an option *) + type 'a t (** Representation of an option *) - type bool_descr = { opts : t list; init : bool; label : string } + type 'a descr = { opts : 'a t list; init : 'a; label : string } - val bool_items : bool_descr list + val bool_items : bool descr list - val set : t -> bool -> unit + val diff_item : string descr + + val set : 'a t -> 'a -> unit val printing_unfocused: unit -> bool diff --git a/ide/coqide.ml b/ide/coqide.ml index aa816f2b8b..09a82ba91e 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -826,6 +826,7 @@ let refresh_notebook_pos () = let menu = GAction.add_actions let item = GAction.add_action +let radio = GAction.add_radio_action (** Toggle items in menus for printing options *) @@ -1043,7 +1044,19 @@ let build_ui () = ~callback:(fun _ -> show_toolbar#set (not show_toolbar#get)); item "Query Pane" ~label:"_Query Pane" ~accel:"F1" - ~callback:(cb_on_current_term MiscMenu.show_hide_query_pane) + ~callback:(cb_on_current_term MiscMenu.show_hide_query_pane); + GAction.group_radio_actions + ~callback:begin function + | 0 -> List.iter (fun o -> Opt.set o "off") Opt.diff_item.Opt.opts + | 1 -> List.iter (fun o -> Opt.set o "on") Opt.diff_item.Opt.opts + | 2 -> List.iter (fun o -> Opt.set o "removed") Opt.diff_item.Opt.opts + | _ -> assert false + end + [ + radio "Unset diff" 0 ~label:"Unset _Diff"; + radio "Set diff" 1 ~label:"Set Di_ff"; + radio "Set removed diff" 2 ~label:"Set _Removed Diff"; + ]; ]; toggle_items view_menu Coq.PrintOpt.bool_items; @@ -1106,15 +1119,15 @@ let build_ui () = ]; alpha_items templates_menu "Template" Coq_commands.commands; - let qitem s sc ?(dots = true) = - let query = if dots then s ^ "..." else s in + let qitem s sc = + let query = s ^ "..." in item s ~label:("_"^s) ~accel:(modifier_for_queries#get^sc) ~callback:(Query.query query) in menu queries_menu [ item "Queries" ~label:"_Queries"; - qitem "Search" "K" ~dots:false; + qitem "Search" "K"; qitem "Check" "C"; qitem "Print" "P"; qitem "About" "A"; diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index 717c4000f5..91c529932f 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -86,6 +86,10 @@ let init () = \n <menuitem action='Display universe levels' />\ \n <menuitem action='Display all low-level contents' />\ \n <menuitem action='Display unfocused goals' />\ +\n <separator/>\ +\n <menuitem action='Unset diff' />\ +\n <menuitem action='Set diff' />\ +\n <menuitem action='Set removed diff' />\ \n </menu>\ \n <menu action='Navigation'>\ \n <menuitem action='Forward' />\ diff --git a/ide/idetop.ml b/ide/idetop.ml index 0c3328ee08..854b1abe31 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -202,13 +202,30 @@ let export_pre_goals pgs = Interface.given_up_goals = pgs.Proof.given_up_goals } +let add_diffs oldp newp intf = + let open Interface in + let (hyps_pp_list, concl_pp) = Proof_diffs.diff_first_goal oldp newp in + match intf.fg_goals with + | [] -> intf + | first_goal :: tl -> + { intf with fg_goals = { first_goal with goal_hyp = hyps_pp_list; goal_ccl = concl_pp } :: tl } + let goals () = + let oldp = + try Some (Proof_global.give_me_the_proof ()) + with Proof_global.NoCurrentProof -> None in let doc = get_doc () in set_doc @@ Stm.finish ~doc; try - let pfts = Proof_global.give_me_the_proof () in - Some (export_pre_goals (Proof.map_structured_proof pfts process_goal)) - with Proof_global.NoCurrentProof -> None + let newp = Proof_global.give_me_the_proof () in + let intf = export_pre_goals (Proof.map_structured_proof newp process_goal) in + if Proof_diffs.show_diffs () then + try + Some (add_diffs oldp (Some newp) intf) + with Pp_diff.Diff_Failure _ -> Some intf + else + Some intf + with Proof_global.NoCurrentProof -> None;; let evars () = try diff --git a/ide/ideutils.ml b/ide/ideutils.ml index e96b992999..960beb8455 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -37,6 +37,11 @@ let flash_info = let flash_context = status#new_context ~name:"Flash" in (fun ?(delay=5000) s -> flash_context#flash ~delay s) +(* Note: Setting the same attribute with two separate tags appears to use +the first value applied and not the second. I saw this trying to set the background +color on Windows. A clean fix, if ever needed, would be to combine the attributes +of the tags into a single composite tag before applying. This is left as an +exercise for the reader. *) let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text = (** FIXME: LablGTK2 does not export the C insert_with_tags function, so that it has to reimplement its own helper function. Unluckily, it relies on @@ -50,21 +55,51 @@ let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text = let start = buf#get_iter_at_mark mark in let stop = buf#get_iter_at_mark rmark in let iter tag = buf#apply_tag tag ~start ~stop in - List.iter iter tags + List.iter iter (List.rev tags) + +let nl_white_regex = Str.regexp "^\\( *\n *\\)" +let diff_regex = Str.regexp "^diff." let insert_xml ?(mark = `INSERT) ?(tags = []) (buf : #GText.buffer_skel) msg = let open Xml_datatype in + let dtags = ref [] in let tag name = match GtkText.TagTable.lookup buf#tag_table name with | None -> raise Not_found | Some tag -> new GText.tag tag in let rmark = `MARK (buf#create_mark buf#start_iter) in + (* insert the string, but don't apply diff highlights to white space at the begin/end of line *) + let rec insert_str tags s = + try + let _ = Str.search_forward nl_white_regex s 0 in + insert_with_tags buf mark rmark tags (Str.matched_group 1 s); + let mend = Str.match_end () in + insert_str tags (String.sub s mend (String.length s - mend)) + with Not_found -> begin + let etags = try List.hd !dtags :: tags with hd -> tags in + insert_with_tags buf mark rmark etags s + end + in let rec insert tags = function - | PCData s -> insert_with_tags buf mark rmark tags s + | PCData s -> insert_str tags s | Element (t, _, children) -> - let tags = try tag t :: tags with Not_found -> tags in - List.iter (fun xml -> insert tags xml) children + let (pfx, tname) = Pp.split_tag t in + let is_diff = try let _ = Str.search_forward diff_regex tname 0 in true with Not_found -> false in + let (tags, have_tag) = + try + let t = tag tname in + if is_diff && pfx <> Pp.end_pfx then + dtags := t :: !dtags; + if pfx = "" then + ((if is_diff then tags else t :: tags), true) + else + (tags, true) + with Not_found -> (tags, false) + in + List.iter (fun xml -> insert tags xml) children; + if have_tag && is_diff && pfx <> Pp.start_pfx then + dtags := (try List.tl !dtags with tl -> []); in let () = try insert tags msg with _ -> () in buf#delete_mark rmark diff --git a/ide/preferences.ml b/ide/preferences.ml index 11aaf6e8cc..526d94a939 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -25,6 +25,7 @@ type tag = { tag_bold : bool; tag_italic : bool; tag_underline : bool; + tag_strikethrough : bool; } (** Generic preferences *) @@ -215,15 +216,17 @@ object string_of_bool tag.tag_bold; string_of_bool tag.tag_italic; string_of_bool tag.tag_underline; + string_of_bool tag.tag_strikethrough; ] method into = function - | [fg; bg; bd; it; ul] -> + | [fg; bg; bd; it; ul; st] -> (try Some { tag_fg_color = _to fg; tag_bg_color = _to bg; tag_bold = bool_of_string bd; tag_italic = bool_of_string it; tag_underline = bool_of_string ul; + tag_strikethrough = bool_of_string st; } with _ -> None) | _ -> None @@ -429,12 +432,13 @@ let tags = ref Util.String.Map.empty let list_tags () = !tags -let make_tag ?fg ?bg ?(bold = false) ?(italic = false) ?(underline = false) () = { +let make_tag ?fg ?bg ?(bold = false) ?(italic = false) ?(underline = false) ?(strikethrough = false) () = { tag_fg_color = fg; tag_bg_color = bg; tag_bold = bold; tag_italic = italic; tag_underline = underline; + tag_strikethrough = strikethrough; } let create_tag name default = @@ -470,6 +474,12 @@ let create_tag name default = tag#set_property (`UNDERLINE_SET true); tag#set_property (`UNDERLINE `SINGLE) end; + begin match pref#get.tag_strikethrough with + | false -> tag#set_property (`STRIKETHROUGH_SET false) + | true -> + tag#set_property (`STRIKETHROUGH_SET true); + tag#set_property (`STRIKETHROUGH true) + end; in let iter table = let tag = GText.tag ~name () in @@ -480,6 +490,8 @@ let create_tag name default = List.iter iter [Tags.Script.table; Tags.Proof.table; Tags.Message.table]; tags := Util.String.Map.add name pref !tags +(* note these appear to only set the defaults; they don't override +the user selection from the Edit/Preferences/Tags dialog *) let () = let iter (name, tag) = create_tag name tag in List.iter iter [ @@ -498,6 +510,10 @@ let () = ("tactic.keyword", make_tag ()); ("tactic.primitive", make_tag ()); ("tactic.string", make_tag ()); + ("diff.added", make_tag ~bg:"#b6f1c0" ~underline:true ()); + ("diff.removed", make_tag ~bg:"#f6b9c1" ~strikethrough:true ()); + ("diff.added.bg", make_tag ~bg:"#e9feee" ()); + ("diff.removed.bg", make_tag ~bg:"#fce9eb" ()); ] let processed_color = @@ -561,6 +577,7 @@ object (self) val bold = GButton.toggle_button () val italic = GButton.toggle_button () val underline = GButton.toggle_button () + val strikethrough = GButton.toggle_button () method set_tag tag = let track c but set = match c with @@ -574,6 +591,7 @@ object (self) bold#set_active tag.tag_bold; italic#set_active tag.tag_italic; underline#set_active tag.tag_underline; + strikethrough#set_active tag.tag_strikethrough; method tag = let get but set = @@ -586,6 +604,7 @@ object (self) tag_bold = bold#active; tag_italic = italic#active; tag_underline = underline#active; + tag_strikethrough = strikethrough#active; } initializer @@ -599,6 +618,7 @@ object (self) set_stock bold `BOLD; set_stock italic `ITALIC; set_stock underline `UNDERLINE; + set_stock strikethrough `STRIKETHROUGH; box#pack fg_color#coerce; box#pack fg_unset#coerce; box#pack bg_color#coerce; @@ -606,6 +626,7 @@ object (self) box#pack bold#coerce; box#pack italic#coerce; box#pack underline#coerce; + box#pack strikethrough#coerce; let cb but obj = obj#set_sensitive (not but#active) in let _ = fg_unset#connect#toggled ~callback:(fun () -> cb fg_unset fg_color#misc) in let _ = bg_unset#connect#toggled ~callback:(fun () -> cb bg_unset bg_color#misc) in diff --git a/ide/preferences.mli b/ide/preferences.mli index ccf028aee4..f3882d486d 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -21,6 +21,7 @@ type tag = { tag_bold : bool; tag_italic : bool; tag_underline : bool; + tag_strikethrough : bool; } class type ['a] repr = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index cb50245d5a..715823e5d0 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1891,9 +1891,9 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = intern_applied_reference intern env (Environ.named_context globalenv) lvar us args ref in - (* Rem: GApp(_,f,[]) stands for @f *) - DAst.make ?loc @@ - GApp (f, intern_args env args_scopes (List.map fst args)) + (* Rem: GApp(_,f,[]) stands for @f *) + if args = [] then DAst.make ?loc @@ GApp (f,[]) else + smart_gapp f loc (intern_args env args_scopes (List.map fst args)) | CApp ((isproj,f), args) -> let f,args = match f.CAst.v with @@ -2059,6 +2059,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CProj (pr, c) -> match intern_reference pr with | ConstRef p -> + let p = Option.get @@ Recordops.find_primitive_projection p in DAst.make ?loc @@ GProj (Projection.make p false, intern env c) | _ -> raise (InternalizationError (loc,IllegalMetavariable)) (* FIXME *) diff --git a/interp/declare.ml b/interp/declare.ml index fcb62ac8c4..532339c03c 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -382,40 +382,44 @@ let inInductive : inductive_obj -> obj = discharge_function = discharge_inductive; rebuild_function = infer_inductive_subtyping } +let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = + let id = Label.to_id label in + let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in + Recordops.declare_primitive_projection p; + (* ^ needs to happen before declaring the constant, otherwise + Heads gets confused. *) + let univs = match univs with + | Monomorphic_ind_entry _ -> + (** Global constraints already defined through the inductive *) + Monomorphic_const_entry Univ.ContextSet.empty + | Polymorphic_ind_entry ctx -> + Polymorphic_const_entry ctx + | Cumulative_ind_entry ctx -> + Polymorphic_const_entry (Univ.CumulativityInfo.univ_context ctx) + in + let term, types = match univs with + | Monomorphic_const_entry _ -> term, types + | Polymorphic_const_entry ctx -> + let u = Univ.UContext.instance ctx in + Vars.subst_instance_constr u term, Vars.subst_instance_constr u types + in + let entry = definition_entry ~types ~univs term in + ignore(declare_constant id (DefinitionEntry entry, IsDefinition StructureComponent)) + let declare_projections univs mind = let env = Global.env () in let mib = Environ.lookup_mind mind env in match mib.mind_record with | PrimRecord info -> - let iter i (_, kns, _) = - let mind = (mind, i) in - let projs = Inductiveops.compute_projections env mind in - Array.iter2 (fun kn (term, types) -> - let id = Label.to_id (Constant.label kn) in - let univs = match univs with - | Monomorphic_ind_entry _ -> - (** Global constraints already defined through the inductive *) - Monomorphic_const_entry Univ.ContextSet.empty - | Polymorphic_ind_entry ctx -> - Polymorphic_const_entry ctx - | Cumulative_ind_entry ctx -> - Polymorphic_const_entry (Univ.CumulativityInfo.univ_context ctx) - in - let term, types = match univs with - | Monomorphic_const_entry _ -> term, types - | Polymorphic_const_entry ctx -> - let u = Univ.UContext.instance ctx in - Vars.subst_instance_constr u term, Vars.subst_instance_constr u types - in - let entry = definition_entry ~types ~univs term in - let kn' = declare_constant id (DefinitionEntry entry, IsDefinition StructureComponent) in - assert (Constant.equal kn kn') - ) kns projs + let iter_ind i (_, labs, _) = + let ind = (mind, i) in + let projs = Inductiveops.compute_projections env ind in + Array.iter2_i (declare_one_projection univs ind ~proj_npars:mib.mind_nparams) labs projs in - let () = Array.iteri iter info in - true, true - | FakeRecord -> true, false - | NotRecord -> false, false + let () = Array.iteri iter_ind info in + true + | FakeRecord -> false + | NotRecord -> false (* for initial declaration *) let declare_mind mie = @@ -424,7 +428,7 @@ let declare_mind mie = | [] -> 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 mie.mind_entry_universes mind in + let isprim = declare_projections mie.mind_entry_universes mind in declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; oname, isprim @@ -593,27 +597,8 @@ let do_universe poly l = ignore(Lib.add_leaf id (input_universe (src, lev)))) l -type constraint_decl = polymorphic * Univ.Constraint.t - -let cache_constraints (na, (p, c)) = - let ctx = - Univ.ContextSet.add_constraints c - Univ.ContextSet.empty (* No declared universes here, just constraints *) - in cache_universe_context (p,ctx) - -let discharge_constraints (_, (p, c as a)) = - if p then None else Some a - -let input_constraints : constraint_decl -> Libobject.obj = - let open Libobject in - declare_object - { (default_object "Global universe constraints") with - cache_function = cache_constraints; - load_function = (fun _ -> cache_constraints); - discharge_function = discharge_constraints; - classify_function = (fun a -> Keep a) } - let do_constraint poly l = + let open Univ in let u_of_id x = let level = Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in UnivNames.is_polymorphic level, level @@ -635,7 +620,8 @@ let do_constraint poly l = let constraints = List.fold_left (fun acc (l, d, r) -> let p, lu = u_of_id l and p', ru = u_of_id r in check_poly p p'; - Univ.Constraint.add (lu, d, ru) acc) - Univ.Constraint.empty l + Constraint.add (lu, d, ru) acc) + Constraint.empty l in - Lib.add_anonymous_leaf (input_constraints (poly, constraints)) + let uctx = ContextSet.add_constraints constraints ContextSet.empty in + declare_universe_context poly uctx diff --git a/interp/impargs.ml b/interp/impargs.ml index 8aa1e62504..e542b818f6 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -689,8 +689,8 @@ let check_rigidity isrigid = user_err (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") let projection_implicits env p impls = - let pb = Environ.lookup_projection p env in - CList.skipn_at_least pb.Declarations.proj_npars impls + let npars = Projection.npars p in + CList.skipn_at_least npars impls let declare_manual_implicits local ref ?enriching l = let flags = !implicit_args in diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index ab0bf9c6fe..7cde563cd2 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -641,11 +641,9 @@ let rec subst_notation_constr subst bound raw = if r1' == r1 && k' == k then raw else NCast(r1',k') | NProj (p, c) -> - let kn = Projection.constant p in - let b = Projection.unfolded p in - let kn' = subst_constant subst kn in + let p' = subst_proj subst p in let c' = subst_notation_constr subst bound c in - if kn' == kn && c' == c then raw else NProj(Projection.make kn' b, c') + if p' == p && c' == c then raw else NProj(p', c') let subst_interpretation subst (metas,pat) = diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 61ed40394e..ac4c6c52c6 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -397,7 +397,7 @@ let update v1 no t = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * Constant.t + | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -691,8 +691,8 @@ let rec zip m stk = | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in zip {norm=neutr m.norm; term=t} s - | Zproj (i,j,cst) :: s -> - zip {norm=neutr m.norm; term=FProj(Projection.make cst true,m)} s + | Zproj p :: s -> + zip {norm=neutr m.norm; term=FProj(Projection.make p true,m)} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> @@ -822,21 +822,24 @@ let drop_parameters depth n argstk = let eta_expand_ind_stack env ind m s (f, s') = let open Declarations in let mib = lookup_mind (fst ind) env in - match mib.Declarations.mind_record with - | PrimRecord infos when - mib.Declarations.mind_finite == Declarations.BiFinite -> - let (_, projs, _) = infos.(snd ind) in - (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> + (* disallow eta-exp for non-primitive records *) + if not (mib.mind_finite == BiFinite) then raise Not_found; + match Declareops.inductive_make_projections ind mib with + | Some projs -> + (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) - let pars = mib.Declarations.mind_nparams in - let right = fapp_stack (f, s') in - let (depth, args, s) = strip_update_shift_app m s in - (** Try to drop the params, might fail on partially applied constructors. *) - let argss = try_drop_parameters depth pars args in - let hstack = Array.map (fun p -> { norm = Red; (* right can't be a constructor though *) - term = FProj (Projection.make p true, right) }) projs in - argss, [Zapp hstack] - | PrimRecord _ | NotRecord | FakeRecord -> raise Not_found (* disallow eta-exp for non-primitive records *) + let pars = mib.Declarations.mind_nparams in + let right = fapp_stack (f, s') in + let (depth, args, s) = strip_update_shift_app m s in + (** Try to drop the params, might fail on partially applied constructors. *) + let argss = try_drop_parameters depth pars args in + let hstack = Array.map (fun p -> + { norm = Red; (* right can't be a constructor though *) + term = FProj (Projection.make p true, right) }) + projs + in + argss, [Zapp hstack] + | None -> raise Not_found (* disallow eta-exp for non-primitive records *) let rec project_nth_arg n argstk = match argstk with @@ -875,9 +878,7 @@ let contract_fix_vect fix = let unfold_projection info p = if red_projection info.i_flags p then - let open Declarations in - let pb = lookup_projection p (info_env info) in - Some (Zproj (pb.proj_npars, pb.proj_arg, Projection.constant p)) + Some (Zproj (Projection.repr p)) else None (*********************************************************************) @@ -958,9 +959,9 @@ let rec knr info tab m stk = let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info tab fxe fxbd stk' - | (depth, args, Zproj (n, m, cst)::s) when use_match -> - let rargs = drop_parameters depth n args in - let rarg = project_nth_arg m rargs in + | (depth, args, Zproj p::s) when use_match -> + let rargs = drop_parameters depth (Projection.Repr.npars p) args in + let rarg = project_nth_arg (Projection.Repr.arg p) rargs in kni info tab rarg s | (_,args,s) -> (m,args@s)) else (m,stk) @@ -1002,7 +1003,7 @@ let rec zip_term zfun m stk = let t = mkCase(ci, zfun (mk_clos e p), m, Array.map (fun b -> zfun (mk_clos e b)) br) in zip_term zfun t s - | Zproj(_,_,p)::s -> + | Zproj p::s -> let t = mkProj (Projection.make p true, m) in zip_term zfun t s | Zfix(fx,par)::s -> diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index f8f98f0abe..1e3e7b48ac 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -152,7 +152,7 @@ type fterm = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * Constant.t + | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 3095ce148b..9a1224aab2 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -128,8 +128,7 @@ type instruction = | Ksetfield of int | Kstop | Ksequence of bytecodes * bytecodes - | Kproj of int * Constant.t (* index of the projected argument, - name of projection *) + | Kproj of Projection.Repr.t | Kensurestackcapacity of int (* spiwack: instructions concerning integers *) | Kbranch of Label.t (* jump to label *) @@ -311,7 +310,7 @@ let rec pp_instr i = | Kbranch lbl -> str "branch " ++ pp_lbl lbl - | Kproj(n,p) -> str "proj " ++ int n ++ str " " ++ Constant.print p + | Kproj p -> str "proj " ++ Projection.Repr.print p | Kensurestackcapacity size -> str "growstack " ++ int size diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index de21401b31..f17a1e657e 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -88,8 +88,7 @@ type instruction = | Ksetfield of int (** accu[n] = sp[0] ; sp = pop sp *) | Kstop | Ksequence of bytecodes * bytecodes - | Kproj of int * Constant.t (** index of the projected argument, - name of projection *) + | Kproj of Projection.Repr.t | Kensurestackcapacity of int (** spiwack: instructions concerning integers *) diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 6677db2fd9..e336ea922d 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -492,8 +492,8 @@ let rec compile_lam env cenv lam sz cont = | Lval v -> compile_structured_constant cenv v sz cont - | Lproj (n,kn,arg) -> - compile_lam env cenv arg sz (Kproj (n,kn) :: cont) + | Lproj (p,arg) -> + compile_lam env cenv arg sz (Kproj p :: cont) | Lvar id -> pos_named id cenv :: cont @@ -501,6 +501,9 @@ let rec compile_lam env cenv lam sz cont = if Array.is_empty args then compile_fv_elem cenv (FVevar evk) sz cont else + (** Arguments are reversed in evar instances *) + let args = Array.copy args in + let () = Array.rev args in comp_app compile_fv_elem (compile_lam env) cenv (FVevar evk) args sz cont | Lconst (kn,u) -> compile_constant env cenv kn u [||] sz cont diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 2426255e48..ca24f9b689 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -27,7 +27,7 @@ type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of Names.Constant.t - | Reloc_proj_name of Constant.t + | Reloc_proj_name of Projection.Repr.t let eq_reloc_info r1 r2 = match r1, r2 with | Reloc_annot sw1, Reloc_annot sw2 -> eq_annot_switch sw1 sw2 @@ -36,7 +36,7 @@ let eq_reloc_info r1 r2 = match r1, r2 with | Reloc_const _, _ -> false | Reloc_getglobal c1, Reloc_getglobal c2 -> Constant.equal c1 c2 | Reloc_getglobal _, _ -> false -| Reloc_proj_name p1, Reloc_proj_name p2 -> Constant.equal p1 p2 +| Reloc_proj_name p1, Reloc_proj_name p2 -> Projection.Repr.equal p1 p2 | Reloc_proj_name _, _ -> false let hash_reloc_info r = @@ -45,7 +45,7 @@ let hash_reloc_info r = | Reloc_annot sw -> combinesmall 1 (hash_annot_switch sw) | Reloc_const c -> combinesmall 2 (hash_structured_constant c) | Reloc_getglobal c -> combinesmall 3 (Constant.hash c) - | Reloc_proj_name p -> combinesmall 4 (Constant.hash p) + | Reloc_proj_name p -> combinesmall 4 (Projection.Repr.hash p) module RelocTable = Hashtbl.Make(struct type t = reloc_info @@ -284,7 +284,7 @@ let emit_instr env = function if n <= 1 then out env (opSETFIELD0+n) else (out env opSETFIELD;out_int env n) | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" - | Kproj (n,p) -> out env opPROJ; out_int env n; slot_for_proj_name env p + | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size (* spiwack *) | Kbranch lbl -> out env opBRANCH; out_label env lbl @@ -371,7 +371,7 @@ let subst_reloc s ri = Reloc_annot {a with ci = ci} | Reloc_const sc -> Reloc_const (subst_strcst s sc) | Reloc_getglobal kn -> Reloc_getglobal (subst_constant s kn) - | Reloc_proj_name p -> Reloc_proj_name (subst_constant s p) + | Reloc_proj_name p -> Reloc_proj_name (subst_proj_repr s p) let subst_patches subst p = let infos = CArray.map (fun (r, pos) -> (subst_reloc subst r, pos)) p.reloc_infos in diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index 696721c375..9009926bdb 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -5,7 +5,7 @@ type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of Constant.t - | Reloc_proj_name of Constant.t + | Reloc_proj_name of Projection.Repr.t type patches type emitcodes diff --git a/kernel/cinstr.mli b/kernel/cinstr.mli index f42c46175c..171ca38830 100644 --- a/kernel/cinstr.mli +++ b/kernel/cinstr.mli @@ -36,7 +36,7 @@ and lambda = | Lval of structured_constant | Lsort of Sorts.t | Lind of pinductive - | Lproj of int * Constant.t * lambda + | Lproj of Projection.Repr.t * lambda | Luint of uint (* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation diff --git a/kernel/clambda.ml b/kernel/clambda.ml index f1b6f3dffc..7c00e40fb0 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -111,9 +111,9 @@ let rec pp_lam lam = (str "(PRIM " ++ pr_con kn ++ spc() ++ prlist_with_sep spc pp_lam (Array.to_list args) ++ str")") - | Lproj(i,kn,arg) -> + | Lproj(p,arg) -> hov 1 - (str "(proj#" ++ int i ++ spc() ++ pr_con kn ++ str "(" ++ pp_lam arg + (str "(proj " ++ Projection.Repr.print p ++ str "(" ++ pp_lam arg ++ str ")") | Luint _ -> str "(uint)" @@ -205,9 +205,9 @@ let rec map_lam_with_binders g f n lam = | Lprim(kn,ar,op,args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Lprim(kn,ar,op,args') - | Lproj(i,kn,arg) -> + | Lproj(p,arg) -> let arg' = f n arg in - if arg == arg' then lam else Lproj(i,kn,arg') + if arg == arg' then lam else Lproj(p,arg') | Luint u -> let u' = map_uint g f n u in if u == u' then lam else Luint u' @@ -376,7 +376,7 @@ let rec occurrence k kind lam = let kind = occurrence_args k kind ltypes in let _ = occurrence_args (k+Array.length ids) false lbodies in kind - | Lproj(_,_,arg) -> + | Lproj(_,arg) -> occurrence k kind arg | Luint u -> occurrence_uint k kind u @@ -708,10 +708,8 @@ let rec lambda_of_constr env c = Lcofix(init, (names, ltypes, lbodies)) | Proj (p,c) -> - let pb = lookup_projection p env.global_env in - let n = pb.proj_arg in let lc = lambda_of_constr env c in - Lproj (n,Projection.constant p,lc) + Lproj (Projection.repr p,lc) and lambda_of_app env f args = match Constr.kind f with diff --git a/kernel/context.ml b/kernel/context.ml index 831dc850fb..4a7204b75c 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -149,6 +149,10 @@ struct | LocalAssum (na, ty) -> na, None, ty | LocalDef (na, v, ty) -> na, Some v, ty + let drop_body = function + | LocalAssum _ as d -> d + | LocalDef (na, v, ty) -> LocalAssum (na, ty) + end (** Rel-context is represented as a list of declarations. @@ -211,6 +215,8 @@ struct | Declaration.LocalAssum _ :: ctx -> aux (false::l) ctx in aux [] l + let drop_bodies l = List.Smart.map Declaration.drop_body l + (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] with n = |Δ| and with the {e local definitions} of [Γ] skipped in [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) @@ -348,6 +354,10 @@ struct | id, None, ty -> LocalAssum (id, ty) | id, Some v, ty -> LocalDef (id, v, ty) + let drop_body = function + | LocalAssum _ as d -> d + | LocalDef (id, v, ty) -> LocalAssum (id, ty) + let of_rel_decl f = function | Rel.Declaration.LocalAssum (na,t) -> LocalAssum (f na, t) @@ -403,6 +413,8 @@ struct let to_vars l = List.fold_left (fun accu decl -> Id.Set.add (Declaration.get_id decl) accu) Id.Set.empty l + let drop_bodies l = List.Smart.map Declaration.drop_body l + (** [instance_from_named_context Ω] builds an instance [args] such that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it diff --git a/kernel/context.mli b/kernel/context.mli index 957ac4b3d6..2b0d36cb8c 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -85,6 +85,9 @@ sig val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a val to_tuple : ('c, 't) pt -> Name.t * 'c option * 't + + (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) + val drop_body : ('c, 't) pt -> ('c, 't) pt end (** Rel-context is represented as a list of declarations. @@ -129,6 +132,9 @@ sig and each {e local definition} is mapped to [false]. *) val to_tags : ('c, 't) pt -> bool list + (** Turn all [LocalDef] into [LocalAssum], leave [LocalAssum] unchanged. *) + val drop_bodies : ('c, 't) pt -> ('c, 't) pt + (** [extended_list mk n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] with n = |Δ| and with the {e local definitions} of [Γ] skipped in [args] where [mk] is used to build the corresponding variables. @@ -202,6 +208,9 @@ sig val to_tuple : ('c, 't) pt -> Id.t * 'c option * 't val of_tuple : Id.t * 'c option * 't -> ('c, 't) pt + (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) + val drop_body : ('c, 't) pt -> ('c, 't) pt + (** Convert [Rel.Declaration.t] value to the corresponding [Named.Declaration.t] value. The function provided as the first parameter determines how to translate "names" to "ids". *) val of_rel_decl : (Name.t -> Id.t) -> ('c, 't) Rel.Declaration.pt -> ('c, 't) pt @@ -249,6 +258,9 @@ sig (** Return the set of all identifiers bound in a given named-context. *) val to_vars : ('c, 't) pt -> Id.Set.t + (** Turn all [LocalDef] into [LocalAssum], leave [LocalAssum] unchanged. *) + val drop_bodies : ('c, 't) pt -> ('c, 't) pt + (** [to_instance Ω] builds an instance [args] such that [Ω ⊢ args:Ω] where [Ω] is a named-context and with the local definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 094609b963..c06358054e 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -126,16 +126,13 @@ let expmod_constr cache modlist c = | Not_found -> Constr.map substrec c) | Proj (p, c') -> - (try - (** No need to expand parameters or universes for projections *) - let map cst = - let _ = Cmap.find cst (fst modlist) in - pop_con cst - in - let p = Projection.map map p in - let c' = substrec c' in - mkProj (p, c') - with Not_found -> Constr.map substrec c) + let map cst npars = + let _, newpars = Mindmap.find cst (snd modlist) in + pop_mind cst, npars + Array.length newpars + in + let p' = try Projection.map_npars map p with Not_found -> p in + let c'' = substrec c' in + if p == p' && c' == c'' then c else mkProj (p', c'') | _ -> Constr.map substrec c diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index bbe0937820..bb9231d000 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -77,11 +77,7 @@ module AnnotTable = Hashtbl.Make (struct let hash = hash_annot_switch end) -module ProjNameTable = Hashtbl.Make (struct - type t = Constant.t - let equal = Constant.equal - let hash = Constant.hash -end) +module ProjNameTable = Hashtbl.Make (Projection.Repr) let str_cst_tbl : int SConstTable.t = SConstTable.create 31 diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 95078800e7..0811eb72fd 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -46,16 +46,6 @@ type inline = int option (** A constant can have no body (axiom/parameter), or a transparent body, or an opaque one *) -(** Projections are a particular kind of constant: - always transparent. *) - -type projection_body = { - proj_ind : inductive; - proj_npars : int; - proj_arg : int; (** Projection index, starting from 0 *) - proj_type : types; (* Type under params *) -} - (* Global declarations (i.e. constants) can be either: *) type constant_def = | Undef of inline (** a global assumption *) @@ -114,7 +104,7 @@ v} If it is a primitive record, for every type in the block, we get: - The identifier for the binder name of the record in primitive projections. - The constants associated to each projection. - - The checked projection bodies. + - The projection types (under parameters). The kernel does not exploit the difference between [NotRecord] and [FakeRecord]. It is mostly used by extraction, and should be extruded from @@ -124,7 +114,7 @@ v} type record_info = | NotRecord | FakeRecord -| PrimRecord of (Id.t * Constant.t array * projection_body array) array +| PrimRecord of (Id.t * Label.t array * types array) array type regular_inductive_arity = { mind_user_arity : types; diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 3e6c4858e0..bbe4bc0dcb 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -83,11 +83,6 @@ let subst_const_def sub def = match def with | Def c -> Def (subst_constr sub c) | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o) -let subst_const_proj sub pb = - { pb with proj_ind = subst_ind sub pb.proj_ind; - proj_type = subst_mps sub pb.proj_type; - } - let subst_const_body sub cb = assert (List.is_empty cb.const_hyps); (* we're outside sections *) if is_empty_subst sub then cb @@ -213,10 +208,9 @@ let subst_mind_record sub r = match r with | FakeRecord -> FakeRecord | PrimRecord infos -> let map (id, ps, pb as info) = - let ps' = Array.Smart.map (subst_constant sub) ps in - let pb' = Array.Smart.map (subst_const_proj sub) pb in - if ps' == ps && pb' == pb then info - else (id, ps', pb') + let pb' = Array.Smart.map (subst_mps sub) pb in + if pb' == pb then info + else (id, ps, pb') in let infos' = Array.Smart.map map infos in if infos' == infos then r else PrimRecord infos' @@ -254,6 +248,25 @@ let inductive_is_cumulative mib = | Polymorphic_ind ctx -> false | Cumulative_ind cumi -> true +let inductive_make_projection ind mib ~proj_arg = + match mib.mind_record with + | NotRecord | FakeRecord -> None + | PrimRecord infos -> + Some (Names.Projection.Repr.make ind + ~proj_npars:mib.mind_nparams + ~proj_arg + (pi2 infos.(snd ind)).(proj_arg)) + +let inductive_make_projections ind mib = + match mib.mind_record with + | NotRecord | FakeRecord -> None + | PrimRecord infos -> + let projs = Array.mapi (fun proj_arg lab -> + Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab) + (pi2 infos.(snd ind)) + in + Some projs + (** {6 Hash-consing of inductive declarations } *) let hcons_regular_ind_arity a = diff --git a/kernel/declareops.mli b/kernel/declareops.mli index fb46112ea7..f91e69807f 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -66,6 +66,11 @@ val inductive_is_polymorphic : mutual_inductive_body -> bool (** Is the inductive cumulative? *) val inductive_is_cumulative : mutual_inductive_body -> bool +val inductive_make_projection : Names.inductive -> mutual_inductive_body -> proj_arg:int -> + Names.Projection.Repr.t option +val inductive_make_projections : Names.inductive -> mutual_inductive_body -> + Names.Projection.Repr.t array option + (** {6 Kernel flags} *) (** A default, safe set of flags for kernel type-checking *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 4ab4698031..e7efa5e2c9 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -52,7 +52,6 @@ type mind_key = mutual_inductive_body * link_info ref type globals = { env_constants : constant_key Cmap_env.t; - env_projections : projection_body Cmap_env.t; env_inductives : mind_key Mindmap_env.t; env_modules : module_body MPmap.t; env_modtypes : module_type_body MPmap.t; @@ -110,7 +109,6 @@ let empty_rel_context_val = { let empty_env = { env_globals = { env_constants = Cmap_env.empty; - env_projections = Cmap_env.empty; env_inductives = Mindmap_env.empty; env_modules = MPmap.empty; env_modtypes = MPmap.empty}; @@ -490,11 +488,24 @@ let polymorphic_pconstant (cst,u) env = let type_in_type_constant cst env = not (lookup_constant cst env).const_typing_flags.check_universes -let lookup_projection cst env = - Cmap_env.find (Projection.constant cst) env.env_globals.env_projections - -let is_projection cst env = - Cmap_env.mem cst env.env_globals.env_projections +let lookup_projection p env = + let mind,i = Projection.inductive p in + let mib = lookup_mind mind env in + (if not (Int.equal mib.mind_nparams (Projection.npars p)) + then anomaly ~label:"lookup_projection" Pp.(str "Bad number of parameters on projection.")); + match mib.mind_record with + | NotRecord | FakeRecord -> anomaly ~label:"lookup_projection" Pp.(str "not a projection") + | PrimRecord infos -> + let _,_,typs = infos.(i) in + typs.(Projection.arg p) + +let get_projection env ind ~proj_arg = + let mib = lookup_mind (fst ind) env in + Declareops.inductive_make_projection ind mib ~proj_arg + +let get_projections env ind = + let mib = lookup_mind (fst ind) env in + Declareops.inductive_make_projections ind mib (* Mutual Inductives *) let polymorphic_ind (mind,i) env = @@ -518,17 +529,9 @@ let template_polymorphic_pind (ind,u) env = let add_mind_key kn (mind, _ as mind_key) env = let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in - let new_projections = match mind.mind_record with - | NotRecord | FakeRecord -> env.env_globals.env_projections - | PrimRecord projs -> - Array.fold_left (fun accu (id, kns, pbs) -> - Array.fold_left2 (fun accu kn pb -> - Cmap_env.add kn pb accu) accu kns pbs) - env.env_globals.env_projections projs - in let new_globals = { env.env_globals with - env_inductives = new_inds; env_projections = new_projections; } in + env_inductives = new_inds; } in { env with env_globals = new_globals } let add_mind kn mib env = diff --git a/kernel/environ.mli b/kernel/environ.mli index 0259dbbdda..f45b7be821 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -217,8 +217,11 @@ val constant_opt_value_in : env -> Constant.t puniverses -> constr option (** {6 Primitive projections} *) -val lookup_projection : Names.Projection.t -> env -> projection_body -val is_projection : Constant.t -> env -> bool +(** Checks that the number of parameters is correct. *) +val lookup_projection : Names.Projection.t -> env -> types + +val get_projection : env -> inductive -> proj_arg:int -> Names.Projection.Repr.t option +val get_projections : env -> inductive -> Names.Projection.Repr.t array option (** {5 Inductive types } *) val lookup_mind_key : MutInd.t -> env -> mind_key diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 5d45c2c1ad..d7eb865e0a 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -796,7 +796,6 @@ let compute_projections (kn, i as ind) mib = let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in - let mp, dp, l = MutInd.repr3 kn in (** We build a substitution smashing the lets in the record parameters so that typechecking projections requires just a substitution and not matching with a parameter context. *) @@ -810,7 +809,7 @@ let compute_projections (kn, i as ind) mib = mkRel 1 :: List.map (lift 1) subst in subst in - let projections decl (i, j, kns, pbs, letsubst) = + let projections decl (i, j, labs, pbs, letsubst) = match decl with | LocalDef (na,c,t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] @@ -822,11 +821,12 @@ let compute_projections (kn, i as ind) mib = (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)] to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *) let letsubst = c2 :: letsubst in - (i, j+1, kns, pbs, letsubst) + (i, j+1, labs, pbs, letsubst) | LocalAssum (na,t) -> match na with | Name id -> - let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in + let lab = Label.of_id id in + let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:i lab in (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *) let t = liftn 1 j t in @@ -836,15 +836,13 @@ let compute_projections (kn, i as ind) mib = (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] to [params, x:I |- t(proj1 x,..,projj x)] *) let fterm = mkProj (Projection.make kn false, mkRel 1) in - let body = { proj_ind = ind; proj_npars = mib.mind_nparams; - proj_arg = i; proj_type = projty; } in - (i + 1, j + 1, kn :: kns, body :: pbs, fterm :: letsubst) + (i + 1, j + 1, lab :: labs, projty :: pbs, fterm :: letsubst) | Anonymous -> raise UndefinableExpansion in - let (_, _, kns, pbs, letsubst) = + let (_, _, labs, pbs, letsubst) = List.fold_right projections ctx (0, 1, [], [], paramsletsubst) in - Array.of_list (List.rev kns), + Array.of_list (List.rev labs), Array.of_list (List.rev pbs) let abstract_inductive_universes iu = @@ -954,8 +952,8 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r (** The elimination criterion ensures that all projections can be defined. *) if Array.for_all is_record packets then let map i id = - let kn, projs = compute_projections (kn, i) mib in - (id, kn, projs) + let labs, projs = compute_projections (kn, i) mib in + (id, labs, projs) in try PrimRecord (Array.mapi map rid) with UndefinableExpansion -> FakeRecord diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 7c36dac67d..cb09cfa827 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -42,6 +42,3 @@ val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_induct val enforce_indices_matter : unit -> unit val is_indices_matter : unit -> bool - -val compute_projections : inductive -> - mutual_inductive_body -> (Constant.t array * projection_body array) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 88b00600e4..4d13a5fcb8 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -798,8 +798,7 @@ let rec subterm_specif renv stack t = (* We take the subterm specs of the constructor of the record *) let wf_args = (dest_subterms wf).(0) in (* We extract the tree of the projected argument *) - let pb = lookup_projection p renv.env in - let n = pb.proj_arg in + let n = Projection.arg p in spec_of_tree (List.nth wf_args n) | Dead_code -> Dead_code | Not_subterm -> Not_subterm) diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index a47af56ca5..b35b9dda31 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -332,6 +332,12 @@ let subst_constant sub con = try fst (subst_con0 sub (con,Univ.Instance.empty)) with No_subst -> con +let subst_proj_repr sub p = + Projection.Repr.map (subst_mind sub) p + +let subst_proj sub p = + Projection.map (subst_mind sub) p + (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" @@ -346,11 +352,7 @@ let rec map_kn f f' c = match kind c with | Const kn -> (try snd (f' kn) with No_subst -> c) | Proj (p,t) -> - let p' = - try - Projection.map (fun kn -> fst (f' (kn,Univ.Instance.empty))) p - with No_subst -> p - in + let p' = Projection.map f p in let t' = func t in if p' == p && t' == t then c else mkProj (p', t') diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 76a1d173b9..2e5211c770 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -147,6 +147,9 @@ val subst_con_kn : val subst_constant : substitution -> Constant.t -> Constant.t +val subst_proj_repr : substitution -> Projection.Repr.t -> Projection.Repr.t +val subst_proj : substitution -> Projection.t -> Projection.t + (** Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" diff --git a/kernel/names.ml b/kernel/names.ml index 1d2a7c4ce5..e1d70e8111 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -771,29 +771,141 @@ type module_path = ModPath.t = module Projection = struct - type t = Constant.t * bool + module Repr = struct + type t = + { proj_ind : inductive; + proj_npars : int; + proj_arg : int; + proj_name : Label.t; } + + let make proj_ind ~proj_npars ~proj_arg proj_name = + {proj_ind;proj_npars;proj_arg;proj_name} + + let inductive c = c.proj_ind + + let mind c = fst c.proj_ind + + let constant c = KerPair.change_label (mind c) c.proj_name + + let label c = c.proj_name + + let npars c = c.proj_npars + + let arg c = c.proj_arg + + let equal a b = + eq_ind a.proj_ind b.proj_ind && Int.equal a.proj_arg b.proj_arg + + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) + + module SyntacticOrd = struct + let compare a b = + let c = ind_syntactic_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + + let equal a b = + a.proj_arg == b.proj_arg && eq_syntactic_ind a.proj_ind b.proj_ind + + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) + end + module CanOrd = struct + let compare a b = + let c = ind_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + + let equal a b = + a.proj_arg == b.proj_arg && eq_ind a.proj_ind b.proj_ind + + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) + end + module UserOrd = struct + let compare a b = + let c = ind_user_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + + let equal a b = + a.proj_arg == b.proj_arg && eq_user_ind a.proj_ind b.proj_ind + + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_user_hash p.proj_ind) + end + + let compare a b = + let c = ind_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + + module Self_Hashcons = struct + type nonrec t = t + type u = (inductive -> inductive) * (Id.t -> Id.t) + let hashcons (hind,hid) p = + { proj_ind = hind p.proj_ind; + proj_npars = p.proj_npars; + proj_arg = p.proj_arg; + proj_name = hid p.proj_name } + let eq p p' = + p == p' || (p.proj_ind == p'.proj_ind && p.proj_npars == p'.proj_npars && p.proj_arg == p'.proj_arg && p.proj_name == p'.proj_name) + let hash = hash + end + module HashRepr = Hashcons.Make(Self_Hashcons) + let hcons = Hashcons.simple_hcons HashRepr.generate HashRepr.hcons (hcons_ind,Id.hcons) + + let map_npars f p = + let ind = fst p.proj_ind in + let npars = p.proj_npars in + let ind', npars' = f ind npars in + if ind == ind' && npars == npars' then p + else {p with proj_ind = (ind',snd p.proj_ind); proj_npars = npars'} + + let map f p = map_npars (fun mind n -> f mind, n) p + + let to_string p = Constant.to_string (constant p) + let print p = Constant.print (constant p) + end + + type t = Repr.t * bool let make c b = (c, b) - let constant = fst + let mind (c,_) = Repr.mind c + let inductive (c,_) = Repr.inductive c + let npars (c,_) = Repr.npars c + let arg (c,_) = Repr.arg c + let constant (c,_) = Repr.constant c + let label (c,_) = Repr.label c + let repr = fst let unfolded = snd let unfold (c, b as p) = if b then p else (c, true) - let equal (c, b) (c', b') = Constant.equal c c' && b == b' - let hash (c, b) = (if b then 0 else 1) + Constant.hash c + let equal (c, b) (c', b') = Repr.equal c c' && b == b' + + let hash (c, b) = (if b then 0 else 1) + Repr.hash c module SyntacticOrd = struct let compare (c, b) (c', b') = - if b = b' then Constant.SyntacticOrd.compare c c' else -1 + if b = b' then Repr.SyntacticOrd.compare c c' else -1 + let equal (c, b as x) (c', b' as x') = + x == x' || b = b' && Repr.SyntacticOrd.equal c c' + let hash (c, b) = (if b then 0 else 1) + Repr.SyntacticOrd.hash c + end + module CanOrd = struct + let compare (c, b) (c', b') = + if b = b' then Repr.CanOrd.compare c c' else -1 let equal (c, b as x) (c', b' as x') = - x == x' || b = b' && Constant.SyntacticOrd.equal c c' - let hash (c, b) = (if b then 0 else 1) + Constant.SyntacticOrd.hash c + x == x' || b = b' && Repr.CanOrd.equal c c' + let hash (c, b) = (if b then 0 else 1) + Repr.CanOrd.hash c end module Self_Hashcons = struct type nonrec t = t - type u = Constant.t -> Constant.t + type u = Repr.t -> Repr.t let hashcons hc (c,b) = (hc c,b) let eq ((c,b) as x) ((c',b') as y) = x == y || (c == c' && b == b') @@ -802,15 +914,19 @@ struct module HashProjection = Hashcons.Make(Self_Hashcons) - let hcons = Hashcons.simple_hcons HashProjection.generate HashProjection.hcons hcons_con + let hcons = Hashcons.simple_hcons HashProjection.generate HashProjection.hcons Repr.hcons let compare (c, b) (c', b') = - if b == b' then Constant.CanOrd.compare c c' + if b == b' then Repr.compare c c' else if b then 1 else -1 let map f (c, b as x) = - let c' = f c in - if c' == c then x else (c', b) + let c' = Repr.map f c in + if c' == c then x else (c', b) + + let map_npars f (c, b as x) = + let c' = Repr.map_npars f c in + if c' == c then x else (c', b) let to_string p = Constant.to_string (constant p) let print p = Constant.print (constant p) diff --git a/kernel/names.mli b/kernel/names.mli index 4eb5adb62f..1cdf5c2402 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -549,17 +549,68 @@ type module_path = ModPath.t = [@@ocaml.deprecated "Alias type"] module Projection : sig - type t + module Repr : sig + type t + + val make : inductive -> proj_npars:int -> proj_arg:int -> Label.t -> t + + module SyntacticOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + module CanOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + module UserOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + + val constant : t -> Constant.t + (** Don't use this if you don't have to. *) + + val inductive : t -> inductive + val mind : t -> MutInd.t + val npars : t -> int + val arg : t -> int + val label : t -> Label.t + + val equal : t -> t -> bool + val hash : t -> int + val compare : t -> t -> int + + val map : (MutInd.t -> MutInd.t) -> t -> t + val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t + + val print : t -> Pp.t + val to_string : t -> string + end + type t (* = Repr.t * bool *) - val make : Constant.t -> bool -> t + val make : Repr.t -> bool -> t + val repr : t -> Repr.t module SyntacticOrd : sig val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end + module CanOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end val constant : t -> Constant.t + val mind : t -> MutInd.t + val inductive : t -> inductive + val npars : t -> int + val arg : t -> int + val label : t -> Label.t val unfolded : t -> bool val unfold : t -> t @@ -570,7 +621,8 @@ module Projection : sig val compare : t -> t -> int - val map : (Constant.t -> Constant.t) -> t -> t + val map : (MutInd.t -> MutInd.t) -> t -> t + val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t val to_string : t -> string val print : t -> Pp.t diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index ec6c5b297a..cc35a70cbf 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1980,8 +1980,7 @@ let compile_mind mb mind stack = (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc in let constructors = Array.fold_left_i add_construct [] ob.mind_reloc_tbl in - let add_proj j acc pb = - let () = assert (eq_ind ind pb.proj_ind) in + let add_proj proj_arg acc pb = let tbl = ob.mind_reloc_tbl in (* Building info *) let ci = { ci_ind = ind; ci_npar = nparams; @@ -1995,14 +1994,14 @@ let compile_mind mb mind stack = let _, arity = tbl.(0) in let ci_uid = fresh_lname Anonymous in let cargs = Array.init arity - (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None) + (fun i -> if Int.equal i proj_arg then Some ci_uid else None) in let i = push_symbol (SymbProj (ind, j)) in let accu = MLapp (MLprimitive Cast_accu, [|MLlocal cf_uid|]) in let accu_br = MLapp (MLprimitive Mk_proj, [|get_proj_code i;accu|]) in let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in let code = MLlet(cf_uid, MLapp (MLprimitive Force_cofix, [|MLlocal c_uid|]), code) in - let gn = Gproj ("", ind, pb.proj_arg) in + let gn = Gproj ("", ind, proj_arg) in Glet (gn, mkMLlam [|c_uid|] code) :: acc in let projs = match mb.mind_record with @@ -2070,8 +2069,7 @@ let compile_deps env sigma prefix ~interactive init t = comp_stack, (mind_updates, const_updates) | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind | Proj (p,c) -> - let pb = lookup_projection p env in - let init = compile_mind_deps env prefix ~interactive init (fst pb.proj_ind) in + let init = compile_mind_deps env prefix ~interactive init (Projection.mind p) in aux env lvl init c | Case (ci, p, c, ac) -> let mind = fst ci.ci_ind in diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index e97dbd0d67..931b8bbc86 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -135,7 +135,18 @@ and conv_fix env lvl t1 f1 t2 f2 cu = else aux (i+1) (conv_val env CONV flvl fi1 fi2 cu) in aux 0 cu +let warn_no_native_compiler = + let open Pp in + CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" + (fun () -> strbrk "Native compiler is disabled," ++ + strbrk " falling back to VM conversion test.") + let native_conv_gen pb sigma env univs t1 t2 = + if not Coq_config.native_compiler then begin + warn_no_native_compiler (); + Vconv.vm_conv_gen pb env univs t1 t2 + end + else let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code env sigma prefix t1 t2 in match compile ml_filename code ~profile:false with @@ -152,19 +163,8 @@ let native_conv_gen pb sigma env univs t1 t2 = end | _ -> anomaly (Pp.str "Compilation failure.") -let warn_no_native_compiler = - let open Pp in - CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" - (fun () -> strbrk "Native compiler is disabled," ++ - strbrk " falling back to VM conversion test.") - (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = - if not Coq_config.native_compiler then begin - warn_no_native_compiler (); - Vconv.vm_conv cv_pb env t1 t2 - end - else let univs = Environ.universes env in let b = if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index a5cdd0a19c..cec0ee57d5 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -464,10 +464,9 @@ let rec lambda_of_constr cache env sigma c = | Construct _ -> lambda_of_app cache env sigma c empty_args | Proj (p, c) -> - let pb = lookup_projection p env in - let ind = pb.proj_ind in + let ind = Projection.inductive p in let prefix = get_mind_prefix env (fst ind) in - mkLapp (Lproj (prefix, ind, pb.proj_arg)) [|lambda_of_constr cache env sigma c|] + mkLapp (Lproj (prefix, ind, Projection.arg p)) [|lambda_of_constr cache env sigma c|] | Case(ci,t,a,branches) -> let (mind,i as ind) = ci.ci_ind in diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 31ad364911..f784509b6f 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -67,6 +67,7 @@ let warn_native_compiler_failed = CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print let call_compiler ?profile:(profile=false) ml_filename = + let () = assert Coq_config.native_compiler in let load_path = !get_load_paths () in let load_path = List.map (fun dn -> dn / output_dir) load_path in let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 3901cb9ce4..91f6add1c3 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -68,28 +68,29 @@ type atom = let accumulate_tag = 0 -let accumulate_code (k:accumulator) (x:t) = - let o = Obj.repr k in - let osize = Obj.size o in - let r = Obj.new_block accumulate_tag (osize + 1) in - for i = 0 to osize - 1 do - Obj.set_field r i (Obj.field o i) - done; - Obj.set_field r osize (Obj.repr x); - (Obj.obj r:t) - -let rec accumulate (x:t) = - accumulate_code (Obj.magic accumulate) x - -let mk_accu_gen rcode (a:atom) = -(* Format.eprintf "size rcode =%i\n" (Obj.size (Obj.magic rcode)); *) - let r = Obj.new_block 0 3 in - Obj.set_field r 0 (Obj.field (Obj.magic rcode) 0); - Obj.set_field r 1 (Obj.field (Obj.magic rcode) 1); - Obj.set_field r 2 (Obj.magic a); - (Obj.magic r:t);; - -let mk_accu (a:atom) = mk_accu_gen accumulate a +(** Unique pointer used to drive the accumulator function *) +let ret_accu = Obj.repr (ref ()) + +type accu_val = { mutable acc_atm : atom; acc_arg : Obj.t list } + +let mk_accu (a : atom) : t = + let rec accumulate data x = + if x == ret_accu then Obj.repr data + else + let data = { data with acc_arg = x :: data.acc_arg } in + let ans = Obj.repr (accumulate data) in + let () = Obj.set_tag ans accumulate_tag in + ans + in + let acc = { acc_atm = a; acc_arg = [] } in + let ans = Obj.repr (accumulate acc) in + (** FIXME: use another representation for accumulators, this causes naked + pointers. *) + let () = Obj.set_tag ans accumulate_tag in + (Obj.obj ans : t) + +let get_accu (k : accumulator) = + (Obj.magic k : Obj.t -> accu_val) ret_accu let mk_rel_accu i = mk_accu (Arel i) @@ -141,31 +142,27 @@ let mk_proj_accu kn c = mk_accu (Aproj (kn,c)) let atom_of_accu (k:accumulator) = - (Obj.magic (Obj.field (Obj.magic k) 2) : atom) + (get_accu k).acc_atm let set_atom_of_accu (k:accumulator) (a:atom) = - Obj.set_field (Obj.magic k) 2 (Obj.magic a) + (get_accu k).acc_atm <- a let accu_nargs (k:accumulator) = - let nargs = Obj.size (Obj.magic k) - 3 in -(* if nargs < 0 then Format.eprintf "nargs = %i\n" nargs; *) - assert (nargs >= 0); - nargs + List.length (get_accu k).acc_arg let args_of_accu (k:accumulator) = - let nargs = accu_nargs k in - let f i = (Obj.magic (Obj.field (Obj.magic k) (nargs-i+2)) : t) in - Array.init nargs f + let acc = (get_accu k).acc_arg in + (Obj.magic (Array.of_list acc) : t array) let is_accu x = let o = Obj.repr x in Obj.is_block o && Int.equal (Obj.tag o) accumulate_tag let mk_fix_accu rec_pos pos types bodies = - mk_accu_gen accumulate (Afix(types,bodies,rec_pos, pos)) + mk_accu (Afix(types,bodies,rec_pos, pos)) let mk_cofix_accu pos types norm = - mk_accu_gen accumulate (Acofix(types,norm,pos,(Obj.magic 0 : t))) + mk_accu (Acofix(types,norm,pos,(Obj.magic 0 : t))) let upd_cofix (cofix :t) (cofix_fun : t) = let atom = atom_of_accu (Obj.magic cofix) in diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 3228a155f3..c701b53fe4 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -53,7 +53,7 @@ let compare_stack_shape stk1 stk2 = | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 - | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> + | (Zproj p1::s1, Zproj p2::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 | (ZcaseT(c1,_,_,_)::s1, ZcaseT(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 @@ -66,7 +66,7 @@ let compare_stack_shape stk1 stk2 = type lft_constr_stack_elt = Zlapp of (lift * fconstr) array - | Zlproj of Constant.t * lift + | Zlproj of Projection.Repr.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list @@ -96,8 +96,8 @@ let pure_stack lfts stk = | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (map_lift l a) pstk) - | (Zproj (n,m,c), (l,pstk)) -> - (l, Zlproj (c,l)::pstk) + | (Zproj p, (l,pstk)) -> + (l, Zlproj (p,l)::pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) @@ -297,7 +297,7 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = | (Zlapp a1,Zlapp a2) -> Array.fold_right2 f a1 a2 cu1 | (Zlproj (c1,l1),Zlproj (c2,l2)) -> - if not (Constant.equal c1 c2) then + if not (Projection.Repr.equal c1 c2) then raise NotConvertible else cu1 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> @@ -408,7 +408,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | Some s2 -> eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv | None -> - if Constant.equal (Projection.constant p1) (Projection.constant p2) + if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) && compare_stack_shape v1 v2 then let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 7c0057696e..7f36f3813f 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -296,13 +296,13 @@ let type_of_case env ci p pt c ct lf lft = rslty let type_of_projection env p c ct = - let pb = lookup_projection p env in + let pty = lookup_projection p env in let (ind,u), args = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in - assert(eq_ind pb.proj_ind ind); - let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in + assert(eq_ind (Projection.inductive p) ind); + let ty = Vars.subst_instance_constr u pty in substl (c :: CList.rev args) ty diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 4e4168922d..d19bea5199 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -139,7 +139,7 @@ and conv_stack env k stk1 stk2 cu = conv_stack env k stk1 stk2 !rcu else raise NotConvertible | Zproj p1 :: stk1, Zproj p2 :: stk2 -> - if Constant.equal p1 p2 then conv_stack env k stk1 stk2 cu + if Projection.Repr.equal p1 p2 then conv_stack env k stk1 stk2 cu else raise NotConvertible | [], _ | Zapp _ :: _, _ | Zfix _ :: _, _ | Zswitch _ :: _, _ | Zproj _ :: _, _ -> raise NotConvertible diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 8524c44d21..d6d9312938 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -150,7 +150,7 @@ type zipper = | Zapp of arguments | Zfix of vfix*arguments (* Possibly empty *) | Zswitch of vswitch - | Zproj of Constant.t (* name of the projection *) + | Zproj of Projection.Repr.t (* name of the projection *) type stack = zipper list @@ -354,7 +354,7 @@ let val_of_constant c = val_of_idkey (ConstKey c) let val_of_evar evk = val_of_idkey (EvarKey evk) external val_of_annot_switch : annot_switch -> values = "%identity" -external val_of_proj_name : Constant.t -> values = "%identity" +external val_of_proj_name : Projection.Repr.t -> values = "%identity" (*************************************************) (** Operations manipulating data types ***********) @@ -553,4 +553,4 @@ and pr_zipper z = | Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")" | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" | Zswitch s -> str "Zswitch(...)" - | Zproj c -> str "Zproj(" ++ Constant.print c ++ str ")") + | Zproj c -> str "Zproj(" ++ Projection.Repr.print c ++ str ")") diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli index 08d05a038c..6eedcf1d37 100644 --- a/kernel/vmvalues.mli +++ b/kernel/vmvalues.mli @@ -81,7 +81,7 @@ type zipper = | Zapp of arguments | Zfix of vfix * arguments (** might be empty *) | Zswitch of vswitch - | Zproj of Constant.t (* name of the projection *) + | Zproj of Projection.Repr.t (* name of the projection *) type stack = zipper list @@ -108,11 +108,11 @@ val val_of_rel : int -> values val val_of_named : Id.t -> values val val_of_constant : Constant.t -> values val val_of_evar : Evar.t -> values -val val_of_proj : Constant.t -> values -> values +val val_of_proj : Projection.Repr.t -> values -> values val val_of_atom : atom -> values external val_of_annot_switch : annot_switch -> values = "%identity" -external val_of_proj_name : Constant.t -> values = "%identity" +external val_of_proj_name : Projection.Repr.t -> values = "%identity" (** Destructors *) diff --git a/lib/lib.mllib b/lib/lib.mllib index 0891859423..41b3622a99 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -6,6 +6,7 @@ Control Util Pp +Pp_diff Stateid Loc Feedback @@ -139,7 +139,7 @@ let v n s = Ppcmd_box(Pp_vbox n,s) let hv n s = Ppcmd_box(Pp_hvbox n,s) let hov n s = Ppcmd_box(Pp_hovbox n,s) -(* Opening and closed of tags *) +(* Opening and closing of tags *) let tag t s = Ppcmd_tag(t,s) (* In new syntax only double quote char is escaped by repeating it *) @@ -167,6 +167,20 @@ let rec pr_com ft s = Some s2 -> Format.pp_force_newline ft (); pr_com ft s2 | None -> () +let start_pfx = "start." +let end_pfx = "end." + +let split_pfx pfx str = + let (str_len, pfx_len) = (String.length str, String.length pfx) in + if str_len >= pfx_len && (String.sub str 0 pfx_len) = pfx then + (pfx, String.sub str pfx_len (str_len - pfx_len)) else ("", str);; + +let split_tag tag = + let (pfx, ttag) = split_pfx start_pfx tag in + if pfx <> "" then (pfx, ttag) else + let (pfx, ttag) = split_pfx end_pfx tag in + (pfx, ttag);; + (* pretty printing functions *) let pp_with ft pp = let cpp_open_box = function @@ -297,3 +311,62 @@ let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v let prvect elem v = prvect_with_sep mt elem v let surround p = hov 1 (str"(" ++ p ++ str")") + +(*** DEBUG code ***) + +let db_print_pp fmt pp = + let open Format in + let block_type fmt btype = + let (bt, v) = + match btype with + | Pp_hbox v -> ("Pp_hbox", v) + | Pp_vbox v -> ("Pp_vbox", v) + | Pp_hvbox v -> ("Pp_hvbox", v) + | Pp_hovbox v -> ("Pp_hovbox", v) + in + fprintf fmt "%s %d" bt v + in + let rec db_print_pp_r indent pp = + let ind () = fprintf fmt "%s" (String.make (2 * indent) ' ') in + ind(); + match pp with + | Ppcmd_empty -> + fprintf fmt "Ppcmd_empty@;" + | Ppcmd_string str -> + fprintf fmt "Ppcmd_string '%s'@;" str + | Ppcmd_glue list -> + fprintf fmt "Ppcmd_glue@;"; + List.iter (fun x -> db_print_pp_r (indent + 1) (repr x)) list; + | Ppcmd_box (block, pp) -> + fprintf fmt "Ppcmd_box %a@;" block_type block; + db_print_pp_r (indent + 1) (repr pp); + | Ppcmd_tag (tag, pp) -> + fprintf fmt "Ppcmd_tag %s@;" tag; + db_print_pp_r (indent + 1) (repr pp); + | Ppcmd_print_break (i, j) -> + fprintf fmt "Ppcmd_print_break %d %d@;" i j + | Ppcmd_force_newline -> + fprintf fmt "Ppcmd_force_newline@;" + | Ppcmd_comment list -> + fprintf fmt "Ppcmd_comment@;"; + List.iter (fun x -> ind(); (fprintf fmt "%s@;" x)) list + in + pp_open_vbox fmt 0; + db_print_pp_r 0 pp; + pp_close_box fmt (); + pp_print_flush fmt () + +let db_string_of_pp pp = + Format.asprintf "%a" db_print_pp pp + +let rec flatten pp = + match pp with + | Ppcmd_glue l -> Ppcmd_glue (List.concat (List.map + (fun x -> let x = flatten x in + match x with + | Ppcmd_glue l2 -> l2 + | p -> [p]) + l)) + | Ppcmd_box (block, pp) -> Ppcmd_box (block, flatten pp) + | Ppcmd_tag (tag, pp) -> Ppcmd_tag (tag, flatten pp) + | p -> p diff --git a/lib/pp.mli b/lib/pp.mli index f3a0a29b8a..ed31daa561 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -189,3 +189,22 @@ val pr_vertical_list : ('b -> t) -> 'b list -> t val pp_with : Format.formatter -> t -> unit val string_of_ppcmds : t -> string + + +(** Tag prefix to start a multi-token diff span *) +val start_pfx : string + +(** Tag prefix to end a multi-token diff span *) +val end_pfx : string + +(** Split a tag into prefix and base tag *) +val split_tag : string -> string * string + +(** Print the Pp in tree form for debugging *) +val db_print_pp : Format.formatter -> t -> unit + +(** Print the Pp in tree form for debugging, return as a string *) +val db_string_of_pp : t -> string + +(** Combine nested Ppcmd_glues *) +val flatten : t -> t diff --git a/lib/pp_diff.ml b/lib/pp_diff.ml new file mode 100644 index 0000000000..7b4b1eab73 --- /dev/null +++ b/lib/pp_diff.ml @@ -0,0 +1,303 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* DEBUG/UNIT TEST *) +let cfprintf oc = Printf.(kfprintf (fun oc -> fprintf oc "") oc) +let log_out_ch = ref stdout +let cprintf s = cfprintf !log_out_ch s + + +module StringDiff = Diff2.Make(struct + type elem = String.t + type t = elem array + let get t i = Array.get t i + let length t = Array.length t +end) + +type diff_type = + [ `Removed + | `Added + | `Common + ] + +type diff_list = StringDiff.elem Diff2.edit list + +(* debug print diff data structure *) +let db_print_diffs fmt diffs = + let open Format in + let print_diff = function + | `Common (opos, npos, s) -> + fprintf fmt "Common '%s' opos = %d npos = %d\n" s opos npos; + | `Removed (pos, s) -> + fprintf fmt "Removed '%s' opos = %d\n" s pos; + | `Added (pos, s) -> + fprintf fmt "Added '%s' npos = %d\n" s pos; + in + pp_open_vbox fmt 0; + List.iter print_diff diffs; + pp_close_box fmt (); + pp_print_flush fmt () + +let string_of_diffs diffs = + Format.asprintf "%a" db_print_diffs diffs + +(* Adjust the diffs returned by the Myers algorithm to reduce the span of the +changes. This gives more natural-looking diffs. + +While the Myers algorithm minimizes the number of changes between two +sequences, it doesn't minimize the span of the changes. For example, +representing elements in common in lower case and inserted elements in upper +case (but ignoring case in the algorithm), ABabC and abABC both have 3 changes +(A, B and C). However the span of the first sequence is 5 elements (ABabC) +while the span of the second is 3 elements (ABC). + +The algorithm modifies the changes iteratively, for example ABabC -> aBAbC -> abABC + +dtype: identifies which of Added OR Removed to use; the other one is ignored. +diff_list: output from the Myers algorithm +*) +let shorten_diff_span dtype diff_list = + let changed = ref false in + let diffs = Array.of_list diff_list in + let len = Array.length diffs in + let vinfo index = + match diffs.(index) with + | `Common (opos, npos, s) -> (`Common, opos, npos, s) + | `Removed (pos, s) -> (`Removed, pos, 0, s) + | `Added (pos, s) -> (`Added, 0, pos, s) in + let get_variant index = + let (v, _, _, _) = vinfo index in + v in + let get_str index = + let (_, _, _, s) = vinfo index in + s in + + let iter start len lt incr = begin + let src = ref start in + let dst = ref start in + while (lt !src len) do + if (get_variant !src) = dtype then begin + if (lt !dst !src) then + dst := !src; + while (lt !dst len) && (get_variant !dst) <> `Common do + dst := !dst + incr; + done; + if (lt !dst len) && (get_str !src) = (get_str !dst) then begin + (* swap diff *) + let (_, c_opos, c_npos, str) = vinfo !dst + and (_, v_opos, v_npos, _) = vinfo !src in + changed := true; + if dtype = `Added then begin + diffs.(!src) <- `Common (c_opos, v_npos, str); + diffs.(!dst) <- `Added (c_npos, str); + end else begin + diffs.(!src) <- `Common (v_opos, c_npos, str); + diffs.(!dst) <- `Removed (c_opos, str) + end + end + end; + src := !src + incr + done + end in + + iter 0 len (<) 1; (* left to right *) + iter (len-1) (-1) (>) (-1); (* right to left *) + if !changed then Array.to_list diffs else diff_list;; + +let has_changes diffs = + let rec has_changes_r diffs added removed = + match diffs with + | `Added _ :: t -> has_changes_r t true removed + | `Removed _ :: t -> has_changes_r t added true + | h :: t -> has_changes_r t added removed + | [] -> (added, removed) in + has_changes_r diffs false false;; + +(* get the Myers diff of 2 lists of strings *) +let diff_strs old_strs new_strs = + let diffs = List.rev (StringDiff.diff old_strs new_strs) in + shorten_diff_span `Removed (shorten_diff_span `Added diffs);; + +(* Default string tokenizer. Makes each character a separate strin. +Whitespace is not ignored. Doesn't handle UTF-8 differences well. *) +let def_tokenize_string s = + let limit = (String.length s) - 1 in + let strs : string list ref = ref [] in + for i = 0 to limit do + strs := (String.make 1 s.[i]) :: !strs + done; + List.rev !strs + +(* get the Myers diff of 2 strings *) +let diff_str ?(tokenize_string=def_tokenize_string) old_str new_str = + let old_toks = Array.of_list (tokenize_string old_str) + and new_toks = Array.of_list (tokenize_string new_str) in + diff_strs old_toks new_toks;; + +let get_dinfo = function + | `Common (_, _, s) -> (`Common, s) + | `Removed (_, s) -> (`Removed, s) + | `Added (_, s) -> (`Added, s) + +[@@@ocaml.warning "-32"] +let string_of_diff_type = function + | `Common -> "Common" + | `Removed -> "Removed" + | `Added -> "Added" +[@@@ocaml.warning "+32"] + +let wrap_in_bg diff_tag pp = + let open Pp in + (tag (Pp.start_pfx ^ diff_tag ^ ".bg") (str "")) ++ pp ++ + (tag (Pp.end_pfx ^ diff_tag ^ ".bg") (str "")) + +exception Diff_Failure of string + +let add_diff_tags which pp diffs = + let open Pp in + let diff_tag = if which = `Added then "diff.added" else "diff.removed" in + let diffs : diff_list ref = ref diffs in + let in_diff = ref false in (* true = buf chars need a tag *) + let in_span = ref false in (* true = last pp had a start tag *) + let trans = ref false in (* true = this diff starts/ends highlight *) + let buf = Buffer.create 16 in + let acc_pp = ref [] in + let diff_str, diff_ind, diff_len = ref "", ref 0, ref 0 in + let prev_dtype, dtype, next_dtype = ref `Common, ref `Common, ref `Common in + let is_white c = List.mem c [' '; '\t'; '\n'; '\r'] in + + let skip () = + while !diffs <> [] && + (let (t, _) = get_dinfo (List.hd !diffs) in + t <> `Common && t <> which) + do + diffs := List.tl !diffs + done + in + + let put_tagged case = + if Buffer.length buf > 0 then begin + let pp = str (Buffer.contents buf) in + Buffer.clear buf; + let tagged = match case with + | "" -> pp + | "tag" -> tag diff_tag pp + | "start" -> in_span := true; tag (start_pfx ^ diff_tag) pp + | "end" -> in_span := false; tag (end_pfx ^ diff_tag) pp + | _ -> raise (Diff_Failure "invalid tag id in put_tagged, should be impossible") in + acc_pp := tagged :: !acc_pp + end + in + + let output_pps () = + let next_diff_char_hl = if !diff_ind < !diff_len then !dtype = which else !next_dtype = which in + let tag = if not !in_diff then "" + else if !in_span then + if next_diff_char_hl then "" else "end" + else + if next_diff_char_hl then "start" else "tag" in + put_tagged tag; (* flush any remainder *) + let l = !acc_pp in + acc_pp := []; + match List.length l with + | 0 -> str "" + | 1 -> List.hd l + | _ -> seq (List.rev l) + in + + let maybe_next_diff () = + if !diff_ind = !diff_len && (skip(); !diffs <> []) then begin + let (t, s) = get_dinfo (List.hd !diffs) in + diff_str := s; diff_ind := 0; diff_len := String.length !diff_str; + diffs := List.tl !diffs; skip(); + prev_dtype := !dtype; + dtype := t; + next_dtype := (match !diffs with + | diff2 :: _ -> let (nt, _) = get_dinfo diff2 in nt + | [] -> `Common); + trans := !dtype <> !prev_dtype + end; + in + + let s_char c = + maybe_next_diff (); + (* matching first should handle tokens with spaces, e.g. in comments/strings *) + if !diff_ind < !diff_len && c = !diff_str.[!diff_ind] then begin + if !dtype = which && !trans && !diff_ind = 0 then begin + put_tagged ""; + in_diff := true + end; + Buffer.add_char buf c; + diff_ind := !diff_ind + 1; + if !dtype = which && !dtype <> !next_dtype && !diff_ind = !diff_len then begin + put_tagged (if !in_span then "end" else "tag"); + in_diff := false + end + end else if is_white c then + Buffer.add_char buf c + else begin + cprintf "mismatch: expected '%c' but got '%c'\n" !diff_str.[!diff_ind] c; + raise (Diff_Failure "string mismatch, shouldn't happen") + end + in + + (* rearrange so existing tags are inside diff tags, provided that those tags + only contain Ppcmd_string's. Other cases (e.g. tag of a box) are not supported. *) + (* todo: Is there a better way to do this in OCaml without multiple 'repr's? *) + let reorder_tags child pp_tag pp = + match repr child with + | Ppcmd_tag (t1, pp) -> tag t1 (tag pp_tag pp) + | Ppcmd_glue l -> + if List.exists (fun x -> + match repr x with + | Ppcmd_tag (_, _) -> true + | _ -> false) l + then seq (List.map (fun x -> + match repr x with + | Ppcmd_tag (t2, pp2) -> tag t2 (tag pp_tag pp2) + | pp2 -> tag pp_tag (unrepr pp2)) l) + else child + | _ -> tag pp_tag child + in + + let rec add_tags_r pp = + let r_pp = repr pp in + match r_pp with + | Ppcmd_string s -> String.iter s_char s; output_pps () + | Ppcmd_glue l -> seq (List.map add_tags_r l) + | Ppcmd_box (block_type, pp) -> unrepr (Ppcmd_box (block_type, add_tags_r pp)) + | Ppcmd_tag (pp_tag, pp) -> reorder_tags (add_tags_r pp) pp_tag pp + | _ -> pp + in + let (has_added, has_removed) = has_changes !diffs in + let rv = add_tags_r pp in + skip (); + if !diffs <> [] then + raise (Diff_Failure "left-over diff info at end of Pp.t, should be impossible"); + if has_added || has_removed then wrap_in_bg diff_tag rv else rv;; + +let diff_pp ?(tokenize_string=def_tokenize_string) o_pp n_pp = + let open Pp in + let o_str = string_of_ppcmds o_pp in + let n_str = string_of_ppcmds n_pp in + let diffs = diff_str ~tokenize_string o_str n_str in + (add_diff_tags `Removed o_pp diffs, add_diff_tags `Added n_pp diffs);; + +let diff_pp_combined ?(tokenize_string=def_tokenize_string) ?(show_removed=false) o_pp n_pp = + let open Pp in + let o_str = string_of_ppcmds o_pp in + let n_str = string_of_ppcmds n_pp in + let diffs = diff_str ~tokenize_string o_str n_str in + let (_, has_removed) = has_changes diffs in + let added = add_diff_tags `Added n_pp diffs in + if show_removed && has_removed then + let removed = add_diff_tags `Removed o_pp diffs in + (v 0 (removed ++ cut() ++ added)) + else added;; diff --git a/lib/pp_diff.mli b/lib/pp_diff.mli new file mode 100644 index 0000000000..03468271d2 --- /dev/null +++ b/lib/pp_diff.mli @@ -0,0 +1,116 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** +Computes the differences between 2 Pp's and adds additional tags to a Pp +to highlight them. Strings are split into tokens using the Coq lexer, +then the lists of tokens are diffed using the Myers algorithm. A fixup routine, +shorten_diff_span, shortens the span of the diff result in some cases. + +Highlights use 4 tags to specify the color and underline/strikeout. These are +"diffs.added", "diffs.removed", "diffs.added.bg" and "diffs.removed.bg". The +first two are for added or removed text; the last two are for unmodified parts +of a modified item. Diffs that span multiple strings in the Pp are tagged with +"start.diff.*" and "end.diff.*", but only on the first and last strings of the span. + +If the inputs are not acceptable to the lexer, break the strings into +lists of tokens and call diff_strs, then add_diff_tags with a Pp.t that matches +the input lists of strings. Tokens that the lexer doesn't return exactly as they +appeared in the input will raise an exception in add_diff_tags (e.g. comments +and quoted strings). Fixing that requires tweaking the lexer. + +Limitations/Possible enhancements: + +- Make diff_pp immune to unlexable strings by adding a flag to the lexer. +*) + +(** Compute the diff between two Pp.t structures and return +versions of each with diffs highlighted as (old, new) *) +val diff_pp : ?tokenize_string:(string -> string list) -> Pp.t -> Pp.t -> Pp.t * Pp.t + +(** Compute the diff between two Pp.t structures and return +a highlighted Pp.t. If [show_removed] is true, show separate lines for +removals and additions, otherwise only show additions *) +val diff_pp_combined : ?tokenize_string:(string -> string list) -> ?show_removed:bool -> Pp.t -> Pp.t -> Pp.t + +(** Raised if the diff fails *) +exception Diff_Failure of string + +module StringDiff : +sig + type elem = String.t + type t = elem array +end + +type diff_type = + [ `Removed + | `Added + | `Common + ] + +type diff_list = StringDiff.elem Diff2.edit list + +(** Compute the difference between 2 strings in terms of tokens, using the +lexer to identify tokens. + +If the strings are not lexable, this routine will raise Diff_Failure. +(I expect to modify the lexer soon so this won't happen.) + +Therefore you should catch any exceptions. The workaround for now is for the +caller to tokenize the strings itself and then call diff_strs. +*) +val diff_str : ?tokenize_string:(string -> string list) -> string -> string -> StringDiff.elem Diff2.edit list + +(** Compute the differences between 2 lists of strings, treating the strings +in the lists as indivisible units. +*) +val diff_strs : StringDiff.t -> StringDiff.t -> StringDiff.elem Diff2.edit list + +(** Generate a new Pp that adds tags marking diffs to a Pp structure: +which: either `Added or `Removed, indicates which type of diffs to add +pp: the original structure. For `Added, must be the new pp passed to diff_pp + For `Removed, must be the old pp passed to diff_pp. Passing the wrong one + will likely raise Diff_Failure. +diffs: the diff list returned by diff_pp + +Diffs of single strings in the Pp are tagged with "diff.added" or "diff.removed". +Diffs that span multiple strings in the Pp are tagged with "start.diff.*" or +"end.diff.*", but only on the first and last strings of the span. + +Ppcmd_strings will be split into multiple Ppcmd_strings if a diff starts or ends +in the middle of the string. Whitespace just before or just after a diff will +not be part of the highlight. + +Prexisting tags in pp may contain only a single Ppcmd_string. Those tags will be +placed inside the diff tags to ensure proper nesting of tags within spans of +"start.diff.*" ... "end.diff.*". + +Under some "impossible" conditions, this routine may raise Diff_Failure. +If you want to make your call especially bulletproof, catch this +exception, print a user-visible message, then recall this routine with +the first argument set to None, which will skip the diff. +*) +val add_diff_tags : diff_type -> Pp.t -> StringDiff.elem Diff2.edit list -> Pp.t + +(** Returns a boolean pair (added, removed) for [diffs] where a true value +indicates that something was added/removed in the diffs. +*) +val has_changes : diff_list -> bool * bool + +val get_dinfo : StringDiff.elem Diff2.edit -> diff_type * string + +(** Returns a modified [pp] with the background highlighted with +"start.<diff_tag>.bg" and "end.<diff_tag>.bg" tags at the beginning +and end of the returned Pp.t +*) +val wrap_in_bg : string -> Pp.t -> Pp.t + +(** Displays the diffs to a printable format for debugging *) +val string_of_diffs : diff_list -> string diff --git a/library/goptions.ml b/library/goptions.ml index f14ad333e9..eafcb8fea6 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -318,26 +318,35 @@ let set_option_value ?(locality = OptDefault) check_and_cast key v = | Some (name, depr, (read,write,append)) -> write locality (check_and_cast v (read ())) -let bad_type_error () = user_err Pp.(str "Bad type of value for this option.") +let show_value_type = function + | BoolValue _ -> "bool" + | IntValue _ -> "int" + | StringValue _ -> "string" + | StringOptValue _ -> "string" + +let bad_type_error opt_value actual_type = + user_err Pp.(str "Bad type of value for this option:" ++ spc() ++ + str "expected " ++ str (show_value_type opt_value) ++ + str ", got " ++ str actual_type ++ str ".") let check_int_value v = function | IntValue _ -> IntValue v - | _ -> bad_type_error () + | optv -> bad_type_error optv "int" let check_bool_value v = function | BoolValue _ -> BoolValue v - | _ -> bad_type_error () + | optv -> bad_type_error optv "bool" let check_string_value v = function | StringValue _ -> StringValue v | StringOptValue _ -> StringOptValue (Some v) - | _ -> bad_type_error () + | optv -> bad_type_error optv "string" let check_unset_value v = function | BoolValue _ -> BoolValue false | IntValue _ -> IntValue None | StringOptValue _ -> StringOptValue None - | _ -> bad_type_error () + | optv -> bad_type_error optv "nothing" (* Nota: For compatibility reasons, some errors are treated as warning. This allows a script to refer to an option that doesn't diff --git a/library/lib.ml b/library/lib.ml index a20de55bf6..8ebe44890c 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -26,13 +26,11 @@ type node = | Leaf of obj | CompilingLibrary of object_prefix | OpenedModule of is_type * export * object_prefix * Summary.frozen - | ClosedModule of library_segment | OpenedSection of object_prefix * Summary.frozen - | ClosedSection of library_segment -and library_entry = object_name * node +type library_entry = object_name * node -and library_segment = library_entry list +type library_segment = library_entry list type lib_objects = (Names.Id.t * obj) list @@ -73,10 +71,6 @@ let classify_segment seg = clean ((id,o')::substl, keepl, anticipl) stk | Anticipate o' -> clean (substl, keepl, o'::anticipl) stk) - | (_,ClosedSection _) :: stk -> clean acc stk - (* LEM; TODO: Understand what this does and see if what I do is the - correct thing for ClosedMod(ule|type) *) - | (_,ClosedModule _) :: stk -> clean acc stk | (_,OpenedSection _) :: _ -> user_err Pp.(str "there are still opened sections") | (_,OpenedModule (ty,_,_,_)) :: _ -> user_err ~hdr:"Lib.classify_segment" @@ -307,7 +301,6 @@ let end_mod is_type = in let (after,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; - add_entry oname (ClosedModule (List.rev (mark::after))); let prefix = !lib_state.path_prefix in recalc_path_prefix (); (oname, prefix, fs, after) @@ -555,7 +548,6 @@ let discharge_item ((sp,_ as oname),e) = match e with | Leaf lobj -> Option.map (fun o -> (basename sp,o)) (discharge_object (oname,lobj)) - | ClosedSection _ | ClosedModule _ -> None | OpenedSection _ | OpenedModule _ | CompilingLibrary _ -> anomaly (Pp.str "discharge_item.") @@ -570,7 +562,6 @@ let close_section () = let (secdecls,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; pop_path_prefix (); - add_entry oname (ClosedSection (List.rev (mark::secdecls))); let newdecls = List.map discharge_item secdecls in Summary.unfreeze_summaries fs; List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls @@ -589,10 +580,8 @@ let freeze ~marshallable = | n, (CompilingLibrary _ as x) -> Some (n,x) | n, OpenedModule (it,e,op,_) -> Some(n,OpenedModule(it,e,op,Summary.empty_frozen)) - | n, ClosedModule _ -> Some (n,ClosedModule []) | n, OpenedSection (op, _) -> - Some(n,OpenedSection(op,Summary.empty_frozen)) - | n, ClosedSection _ -> Some (n,ClosedSection [])) + Some(n,OpenedSection(op,Summary.empty_frozen))) !lib_state.lib_stk in { !lib_state with lib_stk } | _ -> @@ -656,6 +645,14 @@ let discharge_kn kn = let discharge_con cst = if con_defined_in_sec cst then Globnames.pop_con cst else cst +let discharge_proj_repr = + Projection.Repr.map_npars (fun mind npars -> + if not (defined_in_sec mind) then mind, npars + else + let modlist = replacement_context () in + let _, newpars = Mindmap.find mind (snd modlist) in + Globnames.pop_kn mind, npars + Array.length newpars) + let discharge_inductive (kn,i) = (discharge_kn kn,i) diff --git a/library/lib.mli b/library/lib.mli index 5abfccfc7d..9933b762ba 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -23,11 +23,9 @@ type node = | Leaf of Libobject.obj | CompilingLibrary of Libnames.object_prefix | OpenedModule of is_type * export * Libnames.object_prefix * Summary.frozen - | ClosedModule of library_segment | OpenedSection of Libnames.object_prefix * Summary.frozen - | ClosedSection of library_segment -and library_segment = (Libnames.object_name * node) list +type library_segment = (Libnames.object_name * node) list type lib_objects = (Id.t * Libobject.obj) list @@ -189,6 +187,7 @@ val replacement_context : unit -> Opaqueproof.work_list val discharge_kn : MutInd.t -> MutInd.t val discharge_con : Constant.t -> Constant.t +val discharge_proj_repr : Projection.Repr.t -> Projection.Repr.t val discharge_global : GlobRef.t -> GlobRef.t val discharge_inductive : inductive -> inductive val discharge_abstract_universe_context : diff --git a/library/library.mllib b/library/library.mllib index 2ac4266fc0..9cacaba4a7 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -14,6 +14,5 @@ Kindops Dischargedhypsmap Goptions Decls -Heads Keys Coqlib diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 4a691e442c..ce620d5312 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -460,7 +460,7 @@ let rec canonize_name sigma c = mkApp (func ct,Array.Smart.map func l) | Proj(p,c) -> let p' = Projection.map (fun kn -> - Constant.make1 (Constant.canonical kn)) p in + MutInd.make1 (MutInd.canonical kn)) p in (mkProj (p', func c)) | _ -> c diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 04ff11fc49..2eaa6146e1 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -84,8 +84,8 @@ let rec decompose_term env sigma t= let canon_const = Constant.make1 (Constant.canonical c) in (Symb (Constr.mkConstU (canon_const,u))) | Proj (p, c) -> - let canon_const kn = Constant.make1 (Constant.canonical kn) in - let p' = Projection.map canon_const p in + let canon_mind kn = MutInd.make1 (MutInd.canonical kn) in + let p' = Projection.map canon_mind p in let c = Retyping.expand_projection env sigma p' c [] in decompose_term env sigma c | _ -> diff --git a/plugins/extraction/ExtrHaskellString.v b/plugins/extraction/ExtrHaskellString.v index ac1f6f9130..a4a40d3c5a 100644 --- a/plugins/extraction/ExtrHaskellString.v +++ b/plugins/extraction/ExtrHaskellString.v @@ -35,6 +35,8 @@ Extract Inductive ascii => "Prelude.Char" (Data.Bits.testBit (Data.Char.ord a) 6) (Data.Bits.testBit (Data.Char.ord a) 7))". Extract Inlined Constant Ascii.ascii_dec => "(Prelude.==)". +Extract Inlined Constant Ascii.eqb => "(Prelude.==)". Extract Inductive string => "Prelude.String" [ "([])" "(:)" ]. Extract Inlined Constant String.string_dec => "(Prelude.==)". +Extract Inlined Constant String.eqb => "(Prelude.==)". diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v index 030b486b26..a2a6a8fe67 100644 --- a/plugins/extraction/ExtrOcamlString.v +++ b/plugins/extraction/ExtrOcamlString.v @@ -33,6 +33,7 @@ Extract Constant shift => "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". Extract Inlined Constant ascii_dec => "(=)". +Extract Inlined Constant Ascii.eqb => "(=)". Extract Inductive string => "char list" [ "[]" "(::)" ]. diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 71e09992cc..67c605ea1d 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -1065,13 +1065,13 @@ let extract_constant env kn cb = (match cb.const_body with | Undef _ -> warn_info (); mk_typ_ax () | Def c -> - (match Environ.is_projection kn env with - | false -> mk_typ (get_body c) - | true -> - let pb = lookup_projection (Projection.make kn false) env in - let ind = pb.Declarations.proj_ind in + (match Recordops.find_primitive_projection kn with + | None -> mk_typ (get_body c) + | Some p -> + let p = Projection.make p false in + let ind = Projection.inductive p in let bodies = Inductiveops.legacy_match_projection env ind in - let body = bodies.(pb.Declarations.proj_arg) in + let body = bodies.(Projection.arg p) in mk_typ (EConstr.of_constr body)) | OpaqueDef c -> add_opaque r; @@ -1081,13 +1081,13 @@ let extract_constant env kn cb = (match cb.const_body with | Undef _ -> warn_info (); mk_ax () | Def c -> - (match Environ.is_projection kn env with - | false -> mk_def (get_body c) - | true -> - let pb = lookup_projection (Projection.make kn false) env in - let ind = pb.Declarations.proj_ind in + (match Recordops.find_primitive_projection kn with + | None -> mk_def (get_body c) + | Some p -> + let p = Projection.make p false in + let ind = Projection.inductive p in let bodies = Inductiveops.legacy_match_projection env ind in - let body = bodies.(pb.Declarations.proj_arg) in + let body = bodies.(Projection.arg p) in mk_def (EConstr.of_constr body)) | OpaqueDef c -> add_opaque r; diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 4e3ba57308..516b04ea21 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -13,23 +13,21 @@ open Formula open Sequent open Rules open Instances -open Constr open Tacmach.New open Tacticals.New +open Globnames let update_flags ()= - let predref=ref Names.Cpred.empty in - let f coe= - try - let kn= fst (destConst (Classops.get_coercion_value coe)) in - predref:=Names.Cpred.add kn !predref - with DestKO -> () + let f acc coe = + match coe.Classops.coe_value with + | ConstRef c -> Names.Cpred.add c acc + | _ -> acc in - List.iter f (Classops.coercions ()); + let pred = List.fold_left f Names.Cpred.empty (Classops.coercions ()) in red_flags:= CClosure.RedFlags.red_add_transparent CClosure.betaiotazeta - (Names.Id.Pred.full,Names.Cpred.complement !predref) + (Names.Id.Pred.full,Names.Cpred.complement pred) let ground_tac solver startseq = Proofview.Goal.enter begin fun gl -> diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 4b834d66d3..636cb8ebf8 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -594,15 +594,6 @@ let rec clause_of_sign : type a. a ty_sig -> Genarg.ArgT.any Extend.user_symbol let clause_of_ty_ml = function | TyML (t,_) -> clause_of_sign t -let rec prj : type a b c. (a,b,c) Extend.ty_user_symbol -> (a,b,c) genarg_type = function - | TUentry a -> ExtraArg a - | TUentryl (a,l) -> ExtraArg a - | TUopt(o) -> OptArg (prj o) - | TUlist1 l -> ListArg (prj l) - | TUlist1sep (l,_) -> ListArg (prj l) - | TUlist0 l -> ListArg (prj l) - | TUlist0sep (l,_) -> ListArg (prj l) - let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = fun sign tac -> match sign with @@ -617,7 +608,7 @@ let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.i begin fun tac vals ist -> match vals with | [] -> assert false | v :: vals -> - let v' = Taccoerce.Value.cast (topwit (prj a)) v in + let v' = Taccoerce.Value.cast (topwit (Egramml.proj_symbol a)) v in f (tac v') vals ist end tac | TyAnonArg (a, sig') -> eval_sign sig' tac diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index 7d05b64384..0865f75ec5 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -61,8 +61,8 @@ Require Import ssreflect ssrfun. (* 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. *) +(* implies P Q == wrapper variant 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 *) @@ -456,7 +456,7 @@ 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 := +Variant 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. @@ -585,7 +585,7 @@ 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 := +Variant alt_spec : bool -> Type := | AltTrue of P : alt_spec true | AltFalse of ~~ b : alt_spec false. @@ -603,7 +603,7 @@ 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. +Variant 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. @@ -1119,7 +1119,7 @@ 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. +Variant mem_pred := Mem of pred T. Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). @@ -1329,7 +1329,7 @@ End simpl_mem. (* Qualifiers and keyed predicates. *) -CoInductive qualifier (q : nat) T := Qualifier of predPredType T. +Variant 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. @@ -1376,7 +1376,7 @@ Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) Section KeyPred. Variable T : Type. -CoInductive pred_key (p : predPredType T) := DefaultPredKey. +Variant pred_key (p : predPredType T) := DefaultPredKey. Variable p : predPredType T. Structure keyed_pred (k : pred_key p) := diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index b0a9441385..b4144aa45e 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -184,7 +184,7 @@ Inductive external_view : Type := tactic_view of Type. Module TheCanonical. -CoInductive put vT sT (v1 v2 : vT) (s : sT) := Put. +Variant 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. @@ -275,10 +275,10 @@ Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) (* 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. +Variant phantom T (p : T) := Phantom. Arguments phantom : clear implicits. Arguments Phantom : clear implicits. -CoInductive phant (p : Type) := Phant. +Variant phant (p : Type) := Phant. (* Internal tagging used by the implementation of the ssreflect elim. *) diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index ac2c78249b..b2d5143e36 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -326,7 +326,7 @@ Section SimplFun. Variables aT rT : Type. -CoInductive simpl_fun := SimplFun of aT -> rT. +Variant simpl_fun := SimplFun of aT -> rT. Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. @@ -684,7 +684,7 @@ Section Bijections. Variables (A B : Type) (f : B -> A). -CoInductive bijective : Prop := Bijective g of cancel f g & cancel g f. +Variant bijective : Prop := Bijective g of cancel f g & cancel g f. Hypothesis bijf : bijective. diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 7ce2dd64af..8ce0316f53 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -24,7 +24,6 @@ open Ltac_plugin open Notation_ops open Notation_term open Glob_term -open Globnames open Stdarg open Genarg open Decl_kinds @@ -359,13 +358,12 @@ let coerce_search_pattern_to_sort hpat = true, cp with _ -> false, [] in let coerce hp coe_index = - let coe = Classops.get_coercion_value coe_index in + let coe_ref = coe_index.Classops.coe_value in try - let coe_ref = global_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_env env sigma coe ++ spc () + with Not_found | Option.IsNone -> + errorstrm (str "need explicit coercion " ++ pr_global coe_ref ++ spc () ++ str "to interpret head search pattern as type") in filter_head, List.fold_left coerce hpat' coe_path diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 6a63fb02f8..ad33297f0a 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -373,6 +373,11 @@ let ltac_interp_realnames lvar = function | t, IsInd (ty,ind,realnal) -> t, IsInd (ty,ind,List.map (ltac_interp_name lvar) realnal) | _ as x -> x +let is_patvar pat = + match DAst.get pat with + | PatVar _ -> true + | _ -> false + let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let loc = loc_of_glob_constr tomatch in let tycon,realnames = find_tomatch_tycon evdref env loc indopt in @@ -381,6 +386,7 @@ let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let typ = nf_evar !evdref j.uj_type in lvar := make_return_predicate_ltac_lvar !evdref na tomatch j.uj_val !lvar; let t = + if realnames = None && pats <> [] && List.for_all is_patvar pats then NotInd (None,typ) else try try_find_ind env !evdref typ realnames with Not_found -> unify_tomatch_with_patterns evdref env loc typ pats realnames in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index cb0fc32575..da6e26cc4b 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -71,7 +71,7 @@ and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack - | PROJ of Projection.t * Declarations.projection_body * cbv_stack + | PROJ of Projection.t * cbv_stack (* les vars pourraient etre des constr, cela permet de retarder les lift: utile ?? *) @@ -126,7 +126,7 @@ let rec stack_concat stk1 stk2 = TOP -> stk2 | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) | CASE(c,b,i,s,stk1') -> CASE(c,b,i,s,stack_concat stk1' stk2) - | PROJ (p,pinfo,stk1') -> PROJ (p,pinfo,stack_concat stk1' stk2) + | PROJ (p,stk1') -> PROJ (p,stack_concat stk1' stk2) (* merge stacks when there is no shifts in between *) let mkSTACK = function @@ -200,7 +200,7 @@ let rec reify_stack t = function reify_stack (mkCase (ci, ty, t,br)) st - | PROJ (p, pinfo, st) -> + | PROJ (p, st) -> reify_stack (mkProj (p, t)) st and reify_value = function (* reduction under binders *) @@ -265,8 +265,7 @@ let rec norm_head info env t stack = then Projection.unfold p else p in - let pinfo = Environ.lookup_projection p (info_env info.infos) in - norm_head info env c (PROJ (p', pinfo, stack)) + norm_head info env c (PROJ (p', stack)) (* constants, axioms * the first pattern is CRUCIAL, n=0 happens very often: @@ -281,8 +280,9 @@ let rec norm_head info env t stack = | Var id -> norm_head_ref 0 info env stack (VarKey id) | Const sp -> - Reductionops.reduction_effect_hook (env_of_infos info.infos) info.sigma t (lazy (reify_stack t stack)); - norm_head_ref 0 info env stack (ConstKey sp) + Reductionops.reduction_effect_hook (env_of_infos info.infos) info.sigma + (fst sp) (lazy (reify_stack t stack)); + norm_head_ref 0 info env stack (ConstKey sp) | LetIn (_, b, _, c) -> (* zeta means letin are contracted; delta without zeta means we *) @@ -380,9 +380,9 @@ and cbv_stack_value info env = function cbv_stack_term info stk env br.(n-1) (* constructor in a Projection -> IOTA *) - | (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,pi,stk))) + | (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,stk))) when red_set (info_flags info.infos) fMATCH && Projection.unfolded p -> - let arg = args.(pi.Declarations.proj_npars + pi.Declarations.proj_arg) in + let arg = args.(Projection.npars p + Projection.arg p) in cbv_stack_value info env (strip_appl arg stk) (* may be reduced later by application *) @@ -407,7 +407,7 @@ let rec apply_stack info t = function (mkCase (ci, cbv_norm_term info env ty, t, Array.map (cbv_norm_term info env) br)) st - | PROJ (p, pinfo, st) -> + | PROJ (p, st) -> apply_stack info (mkProj (p, t)) st (* performs the reduction on a constr, and returns a constr *) diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index cdaa39c53c..83844c95a7 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -41,7 +41,7 @@ and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack - | PROJ of Projection.t * Declarations.projection_body * cbv_stack + | PROJ of Projection.t * cbv_stack val shift_value : int -> cbv_value -> cbv_value diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 7dbef01c22..542fb5456c 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -31,7 +31,7 @@ type cl_typ = | CL_SECVAR of variable | CL_CONST of Constant.t | CL_IND of inductive - | CL_PROJ of Constant.t + | CL_PROJ of Projection.Repr.t type cl_info_typ = { cl_param : int @@ -42,18 +42,15 @@ type coe_typ = GlobRef.t module CoeTypMap = Refmap_env type coe_info_typ = { - coe_value : constr; - coe_type : types; + coe_value : GlobRef.t; coe_local : bool; - coe_context : Univ.ContextSet.t; coe_is_identity : bool; - coe_is_projection : bool; - coe_param : int } + coe_is_projection : Projection.Repr.t option; + coe_param : int; +} let coe_info_typ_equal c1 c2 = - let eq_constr c1 c2 = Termops.eq_constr Evd.empty (EConstr.of_constr c1) (EConstr.of_constr c2) in - eq_constr c1.coe_value c2.coe_value && - eq_constr c1.coe_type c2.coe_type && + GlobRef.equal c1.coe_value c2.coe_value && c1.coe_local == c2.coe_local && c1.coe_is_identity == c2.coe_is_identity && c1.coe_is_projection == c2.coe_is_projection && @@ -62,7 +59,7 @@ let coe_info_typ_equal c1 c2 = let cl_typ_ord t1 t2 = match t1, t2 with | CL_SECVAR v1, CL_SECVAR v2 -> Id.compare v1 v2 | CL_CONST c1, CL_CONST c2 -> Constant.CanOrd.compare c1 c2 - | CL_PROJ c1, CL_PROJ c2 -> Constant.CanOrd.compare c1 c2 + | CL_PROJ c1, CL_PROJ c2 -> Projection.Repr.CanOrd.compare c1 c2 | CL_IND i1, CL_IND i2 -> ind_ord i1 i2 | _ -> Pervasives.compare t1 t2 (** OK *) @@ -77,9 +74,7 @@ module IntMap = Map.Make(Int) let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0 -type coe_index = coe_info_typ - -type inheritance_path = coe_index list +type inheritance_path = coe_info_typ list (* table des classes, des coercions et graphe d'heritage *) @@ -199,7 +194,7 @@ let find_class_type sigma t = | Var id -> CL_SECVAR id, EInstance.empty, args | Const (sp,u) -> CL_CONST sp, u, args | Proj (p, c) when not (Projection.unfolded p) -> - CL_PROJ (Projection.constant p), EInstance.empty, (c :: args) + CL_PROJ (Projection.repr p), EInstance.empty, (c :: args) | Ind (ind_sp,u) -> CL_IND ind_sp, u, args | Prod (_,_,_) -> CL_FUN, EInstance.empty, [] | Sort _ -> CL_SORT, EInstance.empty, [] @@ -211,7 +206,7 @@ let subst_cl_typ subst ct = match ct with | CL_FUN | CL_SECVAR _ -> ct | CL_PROJ c -> - let c',t = subst_con_kn subst c in + let c' = subst_proj_repr subst c in if c' == c then ct else CL_PROJ c' | CL_CONST c -> let c',t = subst_con_kn subst c in @@ -248,8 +243,11 @@ let class_args_of env sigma c = pi3 (find_class_type sigma c) let string_of_class = function | CL_FUN -> "Funclass" | CL_SORT -> "Sortclass" - | CL_CONST sp | CL_PROJ sp -> - string_of_qualid (shortest_qualid_of_global Id.Set.empty (ConstRef sp)) + | CL_CONST sp -> + string_of_qualid (shortest_qualid_of_global Id.Set.empty (ConstRef sp)) + | CL_PROJ sp -> + let sp = Projection.Repr.constant sp in + string_of_qualid (shortest_qualid_of_global Id.Set.empty (ConstRef sp)) | CL_IND sp -> string_of_qualid (shortest_qualid_of_global Id.Set.empty (IndRef sp)) | CL_SECVAR sp -> @@ -297,31 +295,25 @@ let lookup_path_to_fun_from env sigma s = let lookup_path_to_sort_from env sigma s = apply_on_class_of env sigma s lookup_path_to_sort_from_class +let mkNamed = function + | GlobRef.ConstRef c -> EConstr.mkConst c + | VarRef v -> EConstr.mkVar v + | ConstructRef c -> EConstr.mkConstruct c + | IndRef i -> EConstr.mkInd i + let get_coercion_constructor env coe = - let c, _ = - Reductionops.whd_all_stack env Evd.empty (EConstr.of_constr coe.coe_value) - in - match EConstr.kind Evd.empty (** FIXME *) c with - | Construct (cstr,u) -> - (cstr, Inductiveops.constructor_nrealargs cstr -1) - | _ -> - raise Not_found + let evd = Evd.from_env env in + let red x = fst (Reductionops.whd_all_stack env evd x) in + match EConstr.kind evd (red (mkNamed coe.coe_value)) with + | Constr.Construct (c, _) -> + c, Inductiveops.constructor_nrealargs c -1 + | _ -> raise Not_found let lookup_pattern_path_between env (s,t) = let i = inductive_class_of s in let j = inductive_class_of t in List.map (get_coercion_constructor env) (ClPairMap.find (i,j) !inheritance_graph) -(* coercion_value : coe_index -> unsafe_judgment * bool *) - -let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; - coe_is_identity = b; coe_is_projection = b' } = - let subst, ctx = UnivGen.fresh_universe_context_set_instance ctx in - let c' = Vars.subst_univs_level_constr subst c - and t' = Vars.subst_univs_level_constr subst t in - (make_judge (EConstr.of_constr c') (EConstr.of_constr t'), b, b'), ctx - -(* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) let path_printer : (env -> Evd.evar_map -> (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) ref = @@ -395,7 +387,7 @@ type coercion = { coercion_type : coe_typ; coercion_local : bool; coercion_is_id : bool; - coercion_is_proj : bool; + coercion_is_proj : Projection.Repr.t option; coercion_source : cl_typ; coercion_target : cl_typ; coercion_params : int; @@ -408,9 +400,8 @@ let reference_arity_length ref = List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty (EConstr.of_constr t))) (** FIXME *) let projection_arity_length p = - let len = reference_arity_length (ConstRef p) in - let pb = Environ.lookup_projection (Projection.make p false) (Global.env ()) in - len - pb.Declarations.proj_npars + let len = reference_arity_length (ConstRef (Projection.Repr.constant p)) in + len - Projection.Repr.npars p let class_params = function | CL_FUN | CL_SORT -> 0 @@ -440,17 +431,13 @@ let cache_coercion env sigma (_, c) = let () = add_class c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in - let value, ctx = UnivGen.fresh_global_instance env c.coercion_type in - let typ = Retyping.get_type_of env sigma (EConstr.of_constr value) in - let typ = EConstr.Unsafe.to_constr typ in let xf = - { coe_value = value; - coe_type = typ; - coe_context = ctx; + { coe_value = c.coercion_type; coe_local = c.coercion_local; coe_is_identity = c.coercion_is_id; coe_is_projection = c.coercion_is_proj; - coe_param = c.coercion_params } in + coe_param = c.coercion_params; + } in let () = add_new_coercion c.coercion_type xf in add_coercion_in_graph env sigma (xf,is,it) @@ -466,13 +453,17 @@ let subst_coercion (subst, c) = let coe = subst_coe_typ subst c.coercion_type in let cls = subst_cl_typ subst c.coercion_source in let clt = subst_cl_typ subst c.coercion_target in - if c.coercion_type == coe && c.coercion_source == cls && c.coercion_target == clt then c - else { c with coercion_type = coe; coercion_source = cls; coercion_target = clt } + let clp = Option.Smart.map (subst_proj_repr subst) c.coercion_is_proj in + if c.coercion_type == coe && c.coercion_source == cls && + c.coercion_target == clt && c.coercion_is_proj == clp + then c + else { c with coercion_type = coe; coercion_source = cls; + coercion_target = clt; coercion_is_proj = clp; } let discharge_cl = function | CL_CONST kn -> CL_CONST (Lib.discharge_con kn) | CL_IND ind -> CL_IND (Lib.discharge_inductive ind) - | CL_PROJ p -> CL_PROJ (Lib.discharge_con p) + | CL_PROJ p -> CL_PROJ (Lib.discharge_proj_repr p) | cl -> cl let discharge_coercion (_, c) = @@ -489,6 +480,7 @@ let discharge_coercion (_, c) = coercion_source = discharge_cl c.coercion_source; coercion_target = discharge_cl c.coercion_target; coercion_params = n + c.coercion_params; + coercion_is_proj = Option.map Lib.discharge_proj_repr c.coercion_is_proj; } in Some nc @@ -509,8 +501,8 @@ let inCoercion : coercion -> obj = let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = let isproj = match coef with - | ConstRef c -> Environ.is_projection c (Global.env ()) - | _ -> false + | ConstRef c -> Recordops.find_primitive_projection c + | _ -> None in let c = { coercion_type = coef; @@ -524,8 +516,6 @@ let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps Lib.add_anonymous_leaf (inCoercion c) (* For printing purpose *) -let get_coercion_value v = v.coe_value - let pr_cl_index = Bijint.Index.print let classes () = Bijint.dom !class_tab diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 35691ea37a..af00c0a8dc 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -21,7 +21,7 @@ type cl_typ = | CL_SECVAR of variable | CL_CONST of Constant.t | CL_IND of inductive - | CL_PROJ of Constant.t + | CL_PROJ of Projection.Repr.t (** Equality over [cl_typ] *) val cl_typ_eq : cl_typ -> cl_typ -> bool @@ -39,16 +39,19 @@ type cl_info_typ = { type coe_typ = GlobRef.t (** This is the type of infos for declared coercions *) -type coe_info_typ +type coe_info_typ = { + coe_value : GlobRef.t; + coe_local : bool; + coe_is_identity : bool; + coe_is_projection : Projection.Repr.t option; + coe_param : int; +} (** [cl_index] is the type of class keys *) type cl_index -(** [coe_index] is the type of coercion keys *) -type coe_index - (** This is the type of paths from a class to another *) -type inheritance_path = coe_index list +type inheritance_path = coe_info_typ list (** {6 Access to classes infos } *) @@ -79,8 +82,6 @@ val declare_coercion : (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool -val coercion_value : coe_index -> (unsafe_judgment * bool * bool) Univ.in_universe_context_set - (** {6 Lookup functions for coercion paths } *) (** @raise Not_found in the following functions when no path exists *) @@ -105,10 +106,9 @@ val install_path_printer : val string_of_class : cl_typ -> string val pr_class : cl_typ -> Pp.t val pr_cl_index : cl_index -> Pp.t -val get_coercion_value : coe_index -> Constr.t val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list val classes : unit -> cl_typ list -val coercions : unit -> coe_index list +val coercions : unit -> coe_info_typ list (** [hide_coercion] returns the number of params to skip if the coercion must be hidden, [None] otherwise; it raises [Not_found] if not a coercion *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 7be05ea600..5e3821edf1 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -52,17 +52,17 @@ exception NoCoercionNoUnifier of evar_map * unification_error let apply_coercion_args env sigma check isproj argl funj = let rec apply_rec sigma acc typ = function | [] -> - if isproj then - let cst = fst (destConst sigma (j_val funj)) in - let p = Projection.make cst false in - let pb = lookup_projection p env in - let args = List.skipn pb.Declarations.proj_npars argl in - let hd, tl = match args with hd :: tl -> hd, tl | [] -> assert false in - sigma, { uj_val = applist (mkProj (p, hd), tl); - uj_type = typ } - else - sigma, { uj_val = applist (j_val funj,argl); - uj_type = typ } + (match isproj with + | Some p -> + let npars = Projection.Repr.npars p in + let p = Projection.make p false in + let args = List.skipn npars argl in + let hd, tl = match args with hd :: tl -> hd, tl | [] -> assert false in + sigma, { uj_val = applist (mkProj (p, hd), tl); + uj_type = typ } + | None -> + sigma, { uj_val = applist (j_val funj,argl); + uj_type = typ }) | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *) match EConstr.kind sigma (whd_all env sigma typ) with | Prod (_,c1,c2) -> @@ -369,8 +369,11 @@ let apply_coercion env sigma p hj typ_cl = let j,t,evd = List.fold_left (fun (ja,typ_cl,sigma) i -> - let ((fv,isid,isproj),ctx) = coercion_value i in - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + let isid = i.coe_is_identity in + let isproj = i.coe_is_projection in + let sigma, c = new_global sigma i.coe_value in + let typ = Retyping.get_type_of env sigma c in + let fv = make_judge c typ in let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in let sigma, jres = apply_coercion_args env sigma true isproj argl fv diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index d0de2f8c0c..6a9a042f57 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -689,10 +689,9 @@ and detype_r d flags avoid env sigma t = (** Print the compatibility match version *) let c' = try - let pb = Environ.lookup_projection p (snd env) in - let ind = pb.Declarations.proj_ind in + let ind = Projection.inductive p in let bodies = Inductiveops.legacy_match_projection (snd env) ind in - let body = bodies.(pb.Declarations.proj_arg) in + let body = bodies.(Projection.arg p) in let ty = Retyping.get_type_of (snd env) sigma c in let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma ty in let body' = strip_lam_assum body in @@ -1032,11 +1031,9 @@ let rec subst_glob_constr subst = DAst.map (function if r1' == r1 && k' == k then raw else GCast (r1',k') | GProj (p,c) as raw -> - let kn = Projection.constant p in - let b = Projection.unfolded p in - let kn' = subst_constant subst kn in + let p' = subst_proj subst p in let c' = subst_glob_constr subst c in - if kn' == kn && c' == c then raw else GProj(Projection.make kn' b, c') + if p' == p && c' == c then raw else GProj(p', c') ) (* Utilities to transform kernel cases to simple pattern-matching problem *) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index a71ef65081..984fa92c0e 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -71,7 +71,7 @@ let coq_unit_judge = let unfold_projection env evd ts p c = let cst = Projection.constant p in if is_transparent_constant ts cst then - Some (mkProj (Projection.make cst true, c)) + Some (mkProj (Projection.unfold p, c)) else None let eval_flexible_term ts env evd c = @@ -292,8 +292,8 @@ let ise_stack2 no_app env evd f sk1 sk2 = | Success i'' -> ise_stack2 true i'' q1 q2 | UnifFailure _ as x -> fail x) | UnifFailure _ as x -> fail x) - | Stack.Proj (n1,a1,p1,_)::q1, Stack.Proj (n2,a2,p2,_)::q2 -> - if Constant.equal (Projection.constant p1) (Projection.constant p2) + | Stack.Proj (p1,_)::q1, Stack.Proj (p2,_)::q2 -> + if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) then ise_stack2 true i q1 q2 else fail (UnifFailure (i, NotSameHead)) | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1, @@ -334,8 +334,8 @@ let exact_ise_stack2 env evd f sk1 sk2 = (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); (fun i -> ise_stack2 i a1 a2)] else UnifFailure (i,NotSameHead) - | Stack.Proj (n1,a1,p1,_)::q1, Stack.Proj (n2,a2,p2,_)::q2 -> - if Constant.equal (Projection.constant p1) (Projection.constant p2) + | Stack.Proj (p1,_)::q1, Stack.Proj (p2,_)::q2 -> + if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) then ise_stack2 i q1 q2 else (UnifFailure (i, NotSameHead)) | Stack.App _ :: _, Stack.App _ :: _ -> @@ -986,10 +986,9 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = let open Declarations in let mib = lookup_mind (fst ind) env in - match mib.Declarations.mind_record with - | PrimRecord info when mib.Declarations.mind_finite == Declarations.BiFinite -> - let (_, projs, _) = info.(snd ind) in - let pars = mib.Declarations.mind_nparams in + match get_projections env ind with + | Some projs when mib.mind_finite == BiFinite -> + let pars = mib.mind_nparams in (try let l1' = Stack.tail pars sk1 in let l2' = diff --git a/library/heads.ml b/pretyping/heads.ml index d9d650ac07..7d9debce34 100644 --- a/library/heads.ml +++ b/pretyping/heads.ml @@ -128,8 +128,8 @@ let compute_head = function let env = Global.env() in let cb = Environ.lookup_constant cst env in let is_Def = function Declarations.Def _ -> true | _ -> false in - let body = - if not (Environ.is_projection cst env) && is_Def cb.Declarations.const_body + let body = + if not (Recordops.is_primitive_projection cst) && is_Def cb.Declarations.const_body then Global.body_of_constant cst else None in (match body with diff --git a/library/heads.mli b/pretyping/heads.mli index 421242996c..421242996c 100644 --- a/library/heads.mli +++ b/pretyping/heads.mli diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 551cc67b60..dc900ab814 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -79,7 +79,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in let indf = make_ind_family(pind, Context.Rel.to_extended_list mkRel 0 lnamespar) in let constrs = get_constructors env indf in - let projs = get_projections env indf in + let projs = get_projections env ind in let () = if Option.is_empty projs then check_privacy_block mib in let () = diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 5760733442..b379cdf410 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -51,7 +51,7 @@ let arities_of_constructors env (ind,u as indu) = type inductive_family = pinductive * constr list let make_ind_family (mis, params) = (mis,params) -let dest_ind_family (mis,params) = (mis,params) +let dest_ind_family (mis,params) : inductive_family = (mis,params) let map_ind_family f (mis,params) = (mis, List.map f params) @@ -269,11 +269,9 @@ let allowed_sorts env (kn,i as ind) = let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_kelim -let projection_nparams_env env p = - let pb = lookup_projection p env in - pb.proj_npars +let projection_nparams_env _ p = Projection.npars p -let projection_nparams p = projection_nparams_env (Global.env ()) p +let projection_nparams p = Projection.npars p let has_dependent_elim mib = match mib.mind_record with @@ -343,17 +341,11 @@ let get_constructors env (ind,params) = Array.init (Array.length mip.mind_consnames) (fun j -> get_constructor (ind,mib,mip,params) (j+1)) -let get_projections env (ind,params) = - let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in - match mib.mind_record with - | PrimRecord infos -> - let (_, projs, _) = infos.(snd (fst ind)) in - Some projs - | NotRecord | FakeRecord -> None +let get_projections = Environ.get_projections let make_case_or_project env sigma indf ci pred c branches = let open EConstr in - let projs = get_projections env indf in + let projs = get_projections env (fst (fst indf)) in match projs with | None -> (mkCase (ci, pred, c, branches)) | Some ps -> @@ -481,7 +473,6 @@ let compute_projections env (kn, i as ind) = let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in - let mp, dp, l = MutInd.repr3 kn in (** We build a substitution smashing the lets in the record parameters so that typechecking projections requires just a substitution and not matching with a parameter context. *) @@ -512,7 +503,7 @@ let compute_projections env (kn, i as ind) = let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in it_mkLambda_or_LetIn (mkLambda (x,indty,body)) params in - let projections decl (j, pbs, subst) = + let projections decl (proj_arg, j, pbs, subst) = match decl with | LocalDef (na,c,t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] @@ -525,11 +516,12 @@ let compute_projections env (kn, i as ind) = to [params, x:I |- subst:field1,..,fieldj+1] where [subst] is represented with instance of field1 last *) let subst = c1 :: subst in - (j+1, pbs, subst) + (proj_arg, j+1, pbs, subst) | LocalAssum (na,t) -> match na with | Name id -> - let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in + let lab = Label.of_id id in + let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab in (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *) let t = liftn 1 j t in @@ -544,12 +536,12 @@ let compute_projections env (kn, i as ind) = let etab = it_mkLambda_or_LetIn (mkLambda (x, indty, term)) params in let etat = it_mkProd_or_LetIn (mkProd (x, indty, ty)) params in let body = (etab, etat, compat) in - (j + 1, body :: pbs, fterm :: subst) + (proj_arg + 1, j + 1, body :: pbs, fterm :: subst) | Anonymous -> anomaly Pp.(str "Trying to build primitive projections for a non-primitive record") in - let (_, pbs, subst) = - List.fold_right projections ctx (1, [], []) + let (_, _, pbs, subst) = + List.fold_right projections ctx (0, 1, [], []) in Array.rev_of_list pbs @@ -738,8 +730,8 @@ let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty = !evdref, EConstr.of_constr (mkArity (List.rev ctx,scl)) let type_of_projection_constant env (p,u) = - let pb = lookup_projection p env in - Vars.subst_instance_constr u pb.proj_type + let pty = lookup_projection p env in + Vars.subst_instance_constr u pty let type_of_projection_knowing_arg env sigma p c ty = let c = EConstr.Unsafe.to_constr c in diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 8eaef24c48..ea34707bfc 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -130,7 +130,10 @@ val has_dependent_elim : mutual_inductive_body -> bool (** Primitive projections *) val projection_nparams : Projection.t -> int +[@@ocaml.deprecated "Use [Projection.npars]"] val projection_nparams_env : env -> Projection.t -> int +[@@ocaml.deprecated "Use [Projection.npars]"] + val type_of_projection_knowing_arg : env -> evar_map -> Projection.t -> EConstr.t -> EConstr.types -> types @@ -149,7 +152,8 @@ val get_constructor : pinductive * mutual_inductive_body * one_inductive_body * constr list -> int -> constructor_summary val get_constructors : env -> inductive_family -> constructor_summary array -val get_projections : env -> inductive_family -> Constant.t array option +val get_projections : env -> inductive -> Projection.Repr.t array option +[@@ocaml.deprecated "Use [Environ.get_projections]"] (** [get_arity] returns the arity of the inductive family instantiated with the parameters; if recursively non-uniform parameters are not diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 21c2022057..5df41ef76a 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -185,14 +185,13 @@ let branch_of_switch lvl ans bs = bs ci in Array.init (Array.length tbl) branch -let get_proj env ((mind, n), i) = - let mib = Environ.lookup_mind mind env in - match mib.mind_record with - | NotRecord | FakeRecord -> +let get_proj env (ind, proj_arg) = + let mib = Environ.lookup_mind (fst ind) env in + match Declareops.inductive_make_projection ind mib ~proj_arg with + | None -> CErrors.anomaly (Pp.strbrk "Return type is not a primitive record") - | PrimRecord info -> - let _, projs, _ = info.(n) in - Projection.make projs.(i) true + | Some p -> + Projection.make p true let rec nf_val env sigma v typ = match kind_of_value v with diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 685aa400b8..f7fea22c0f 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -287,8 +287,7 @@ let rec subst_pattern subst pat = | PEvar _ | PRel _ -> pat | PProj (p,c) -> - let p' = Projection.map (fun p -> - destConstRef (fst (subst_global subst (ConstRef p)))) p in + let p' = Projection.map (subst_mind subst) p in let c' = subst_pattern subst c in if p' == p && c' == c then pat else PProj(p',c') diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 122979c1a0..3b9a8e6a1d 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -773,11 +773,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre in let app_f = match EConstr.kind !evdref fj.uj_val with - | Const (p, u) when Environ.is_projection p env.ExtraEnv.env -> + | Const (p, u) when Recordops.is_primitive_projection p -> + let p = Option.get @@ Recordops.find_primitive_projection p in let p = Projection.make p false in - let pb = Environ.lookup_projection p env.ExtraEnv.env in - let npars = pb.Declarations.proj_npars in - fun n -> + let npars = Projection.npars p in + fun n -> if n == npars + 1 then fun _ v -> mkProj (p, v) else fun f v -> applist (f, [v]) | _ -> fun _ f v -> applist (f, [v]) @@ -905,6 +905,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let cloc = loc_of_glob_constr c in error_case_not_inductive ?loc:cloc env.ExtraEnv.env !evdref cj in + let ind = fst (fst (dest_ind_family indf)) in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 1) then user_err ?loc (str "Destructing let is only for inductive types" ++ @@ -915,7 +916,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre int cs.cs_nargs ++ str " variables."); let fsign, record = let set_name na d = set_name na (map_rel_decl EConstr.of_constr d) in - match get_projections env.ExtraEnv.env indf with + match Environ.get_projections env.ExtraEnv.env ind with | None -> List.map2 set_name (List.rev nal) cs.cs_args, false | Some ps -> diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 3d9b5d3cfc..5da5aff449 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -14,6 +14,7 @@ Find_subterm Evardefine Evarsolve Recordops +Heads Evarconv Typing Miscops diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 56a8830991..2f861c117b 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -44,7 +44,7 @@ type struc_typ = { let structure_table = Summary.ref (Indmap.empty : struc_typ Indmap.t) ~name:"record-structs" let projection_table = - Summary.ref Cmap.empty ~name:"record-projs" + Summary.ref (Cmap.empty : struc_typ Cmap.t) ~name:"record-projs" (* TODO: could be unify struc_typ and struc_tuple ? in particular, is the inductive always (fst constructor) ? It seems so... *) @@ -53,7 +53,9 @@ type struc_tuple = inductive * constructor * (Name.t * bool) list * Constant.t option list let load_structure i (_,(ind,id,kl,projs)) = - let n = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in + let open Declarations in + let mib, mip = Global.lookup_inductive ind in + let n = mib.mind_nparams in let struc = { s_CONST = id; s_EXPECTEDPARAM = n; s_PROJ = projs; s_PROJKIND = kl } in structure_table := Indmap.add ind struc !structure_table; @@ -107,6 +109,34 @@ let find_projection = function | ConstRef cst -> Cmap.find cst !projection_table | _ -> raise Not_found +let prim_table = + Summary.ref (Cmap_env.empty : Projection.Repr.t Cmap_env.t) ~name:"record-prim-projs" + +let load_prim i (_,p) = + prim_table := Cmap_env.add (Projection.Repr.constant p) p !prim_table + +let cache_prim p = load_prim 1 p + +let subst_prim (subst,p) = subst_proj_repr subst p + +let discharge_prim (_,p) = Some (Lib.discharge_proj_repr p) + +let inPrim : Projection.Repr.t -> obj = + declare_object { + (default_object "PRIMPROJS") with + cache_function = cache_prim ; + load_function = load_prim; + subst_function = subst_prim; + classify_function = (fun x -> Substitute x); + discharge_function = discharge_prim } + +let declare_primitive_projection p = Lib.add_anonymous_leaf (inPrim p) + +let is_primitive_projection c = Cmap_env.mem c !prim_table + +let find_primitive_projection c = + try Some (Cmap_env.find c !prim_table) with Not_found -> None + (************************************************************************) (*s A canonical structure declares "canonical" conversion hints between *) (* the effective components of a structure and the projections of the *) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 748f053b2f..415b964168 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -44,6 +44,13 @@ val find_projection_nparams : GlobRef.t -> int (** raise [Not_found] if not a projection *) val find_projection : GlobRef.t -> struc_typ +(** Sets up the mapping from constants to primitive projections *) +val declare_primitive_projection : Projection.Repr.t -> unit + +val is_primitive_projection : Constant.t -> bool + +val find_primitive_projection : Constant.t -> Projection.Repr.t option + (** {6 Canonical structures } *) (** A canonical structure declares "canonical" conversion hints between the effective components of a structure and the projections of the diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 7fb1a0a578..ba40262815 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -47,29 +47,28 @@ open Libobject type effect_name = string (** create a persistent set to store effect functions *) -module ConstrMap = Map.Make (Constr) (* Table bindings a constant to an effect *) -let constant_effect_table = Summary.ref ~name:"reduction-side-effect" ConstrMap.empty +let constant_effect_table = Summary.ref ~name:"reduction-side-effect" Cmap.empty (* Table bindings function key to effective functions *) let effect_table = Summary.ref ~name:"reduction-function-effect" String.Map.empty (** a test to know whether a constant is actually the effect function *) -let reduction_effect_hook env sigma termkey c = +let reduction_effect_hook env sigma con c = try - let funkey = ConstrMap.find termkey !constant_effect_table in + let funkey = Cmap.find con !constant_effect_table in let effect = String.Map.find funkey !effect_table in effect env sigma (Lazy.force c) with Not_found -> () -let cache_reduction_effect (_,(termkey,funkey)) = - constant_effect_table := ConstrMap.add termkey funkey !constant_effect_table +let cache_reduction_effect (_,(con,funkey)) = + constant_effect_table := Cmap.add con funkey !constant_effect_table -let subst_reduction_effect (subst,(termkey,funkey)) = - (subst_mps subst termkey,funkey) +let subst_reduction_effect (subst,(con,funkey)) = + (subst_constant subst con,funkey) -let inReductionEffect : Constr.constr * string -> obj = +let inReductionEffect : Constant.t * string -> obj = declare_object {(default_object "REDUCTION-EFFECT") with cache_function = cache_reduction_effect; open_function = (fun i o -> if Int.equal i 1 then cache_reduction_effect o); @@ -83,8 +82,7 @@ let declare_reduction_effect funkey f = (** A function to set the value of the print function *) let set_reduction_effect x funkey = - let termkey = UnivGen.constr_of_global x in - Lib.add_anonymous_leaf (inReductionEffect (termkey,funkey)) + Lib.add_anonymous_leaf (inReductionEffect (x,funkey)) (** Machinery to custom the behavior of the reduction *) @@ -280,7 +278,7 @@ sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * Cst_stack.t - | Proj of int * int * Projection.t * Cst_stack.t + | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t and 'a t = 'a member list @@ -337,7 +335,7 @@ struct type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * Cst_stack.t - | Proj of int * int * Projection.t * Cst_stack.t + | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t and 'a t = 'a member list @@ -351,9 +349,8 @@ struct str "ZCase(" ++ prvect_with_sep (pr_bar) pr_c br ++ str ")" - | Proj (n,m,p,cst) -> - str "ZProj(" ++ int n ++ pr_comma () ++ int m ++ - pr_comma () ++ Constant.print (Projection.constant p) ++ str ")" + | Proj (p,cst) -> + str "ZProj(" ++ Constant.print (Projection.constant p) ++ str ")" | Fix (f,args,cst) -> str "ZFix(" ++ Termops.pr_fix pr_c f ++ pr_comma () ++ pr pr_c args ++ str ")" @@ -413,10 +410,9 @@ struct (f t1 t2) && (equal_rec s1' s2') | Case (_,t1,a1,_) :: s1, Case (_,t2,a2,_) :: s2 -> f t1 t2 && CArray.equal (fun x y -> f x y) a1 a2 && equal_rec s1 s2 - | (Proj (n1,m1,p,_)::s1, Proj(n2,m2,p2,_)::s2) -> - Int.equal n1 n2 && Int.equal m1 m2 - && Constant.equal (Projection.constant p) (Projection.constant p2) - && equal_rec s1 s2 + | (Proj (p,_)::s1, Proj(p2,_)::s2) -> + Projection.Repr.equal (Projection.repr p) (Projection.repr p2) + && equal_rec s1 s2 | Fix (f1,s1,_) :: s1', Fix (f2,s2,_) :: s2' -> f_fix f1 f2 && equal_rec (List.rev s1) (List.rev s2) @@ -436,7 +432,7 @@ struct | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 - | (Proj (n1,m1,p,_)::s1, Proj(n2,m2,p2,_)::s2) -> + | (Proj (p,_)::s1, Proj(p2,_)::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 | (Fix(_,a1,_)::s1, Fix(_,a2,_)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 @@ -456,7 +452,7 @@ struct aux (f o t1 t2) l1 l2 | Case (_,t1,a1,_) :: q1, Case (_,t2,a2,_) :: q2 -> aux (Array.fold_left2 f (f o t1 t2) a1 a2) q1 q2 - | Proj (n1,m1,p1,_) :: q1, Proj (n2,m2,p2,_) :: q2 -> + | Proj (p1,_) :: q1, Proj (p2,_) :: q2 -> aux o q1 q2 | Fix ((_,(_,a1,b1)),s1,_) :: q1, Fix ((_,(_,a2,b2)),s2,_) :: q2 -> let o' = aux (Array.fold_left2 f (Array.fold_left2 f o b1 b2) a1 a2) (List.rev s1) (List.rev s2) in @@ -469,7 +465,7 @@ struct in aux o (List.rev sk1) (List.rev sk2) let rec map f x = List.map (function - | (Proj (_,_,_,_)) as e -> e + | (Proj (_,_)) as e -> e | App (i,a,j) -> let le = j - i + 1 in App (0,Array.map f (Array.sub a i le), le-1) @@ -513,7 +509,7 @@ struct let will_expose_iota args = List.exists (function (Fix (_,_,l) | Case (_,_,_,l) | - Proj (_,_,_,l) | Cst (_,_,_,_,l)) when Cst_stack.is_empty l -> true | _ -> false) + Proj (_,l) | Cst (_,_,_,_,l)) when Cst_stack.is_empty l -> true | _ -> false) args let list_of_app_stack s = @@ -590,9 +586,9 @@ struct zip (best_state sigma (constr_of_cst_member cst (params @ (append_app [|f|] s))) cst_l) | f, (Cst (cst,_,_,params,_)::s) -> zip (constr_of_cst_member cst (params @ (append_app [|f|] s))) - | f, (Proj (n,m,p,cst_l)::s) when refold -> + | f, (Proj (p,cst_l)::s) when refold -> zip (best_state sigma (mkProj (p,f),s) cst_l) - | f, (Proj (n,m,p,_)::s) -> zip (mkProj (p,f),s) + | f, (Proj (p,_)::s) -> zip (mkProj (p,f),s) in zip s @@ -874,7 +870,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Some body -> whrec cst_l (body, stack) | None -> fold ()) | Const (c,u as const) -> - reduction_effect_hook env sigma (EConstr.to_constr sigma x) + reduction_effect_hook env sigma c (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,stack)))); if CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) then let u' = EInstance.kind sigma u in @@ -920,16 +916,13 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') ) else fold () | Proj (p, c) when CClosure.RedFlags.red_projection flags p -> - (let pb = lookup_projection p env in - let kn = Projection.constant p in - let npars = pb.Declarations.proj_npars - and arg = pb.Declarations.proj_arg in - if not tactic_mode then - let stack' = (c, Stack.Proj (npars, arg, p, Cst_stack.empty (*cst_l*)) :: stack) in + (let npars = Projection.npars p in + if not tactic_mode then + let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in whrec Cst_stack.empty stack' - else match ReductionBehaviour.get (Globnames.ConstRef kn) with + else match ReductionBehaviour.get (Globnames.ConstRef (Projection.constant p)) with | None -> - let stack' = (c, Stack.Proj (npars, arg, p, cst_l) :: stack) in + let stack' = (c, Stack.Proj (p, cst_l) :: stack) in let stack'', csts = whrec Cst_stack.empty stack' in if equal_stacks sigma stack' stack'' then fold () else stack'', csts @@ -946,7 +939,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |[] -> (* if nargs has been specified *) (* CAUTION : the constant is NEVER refold (even when it hides a (co)fix) *) - let stack' = (c, Stack.Proj (npars, arg, p, cst_l) :: stack) in + let stack' = (c, Stack.Proj (p, cst_l) :: stack) in whrec Cst_stack.empty(* cst_l *) stack' | curr::remains -> if curr == 0 then (* Try to reduce the record argument *) @@ -1005,8 +998,8 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') when use_match -> whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') - |args, (Stack.Proj (n,m,p,_)::s') when use_match -> - whrec Cst_stack.empty (Stack.nth args (n+m), s') + |args, (Stack.Proj (p,_)::s') when use_match -> + whrec Cst_stack.empty (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> let x' = Stack.zip sigma (x, args) in let out_sk = s' @ (Stack.append_app [|x'|] s'') in @@ -1025,14 +1018,11 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) (body, s' @ (Stack.append_app [|x'|] s''))) | Stack.Cst_proj p -> - let pb = lookup_projection p env in - let npars = pb.Declarations.proj_npars in - let narg = pb.Declarations.proj_arg in - let stack = s' @ (Stack.append_app [|x'|] s'') in + let stack = s' @ (Stack.append_app [|x'|] s'') in match Stack.strip_n_app 0 stack with | None -> assert false | Some (_,arg,s'') -> - whrec Cst_stack.empty (arg, Stack.Proj (npars,narg,p,cst_l) :: s'')) + whrec Cst_stack.empty (arg, Stack.Proj (p,cst_l) :: s'')) | next :: remains' -> match Stack.strip_n_app (next-curr-1) s'' with | None -> fold () | Some (bef,arg,s''') -> @@ -1090,10 +1080,7 @@ let local_whd_state_gen flags sigma = | _ -> s) | Proj (p,c) when CClosure.RedFlags.red_projection flags p -> - (let pb = lookup_projection p (Global.env ()) in - whrec (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, - p, Cst_stack.empty) - :: stack)) + (whrec (c, Stack.Proj (p, Cst_stack.empty) :: stack)) | Case (ci,p,d,lf) -> whrec (d, Stack.Case (ci,p,lf,Cst_stack.empty) :: stack) @@ -1116,8 +1103,8 @@ let local_whd_state_gen flags sigma = match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') when use_match -> whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') - |args, (Stack.Proj (n,m,p,_) :: s') when use_match -> - whrec (Stack.nth args (n+m), s') + |args, (Stack.Proj (p,_) :: s') when use_match -> + whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s',cst)::s'') when use_fix -> let x' = Stack.zip sigma (x,args) in whrec (contract_fix sigma f, s' @ (Stack.append_app [|x'|] s'')) @@ -1576,11 +1563,11 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in if isConstruct sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' - |args, (Stack.Proj (n,m,p,_) :: stack'') -> + |args, (Stack.Proj (p,_) :: stack'') -> let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in if isConstruct sigma t_o then - whrec Cst_stack.empty (Stack.nth stack_o (n+m), stack'') + whrec Cst_stack.empty (Stack.nth stack_o (Projection.npars p + Projection.arg p), stack'') else s,csts' |_, ((Stack.App _|Stack.Cst _) :: _|[]) -> s,csts' in whrec csts s diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 9256fa7ce6..07eeec9276 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -41,10 +41,10 @@ val declare_reduction_effect : effect_name -> (Environ.env -> Evd.evar_map -> Constr.constr -> unit) -> unit (* [set_reduction_effect cst name] declares effect [name] to be called when [cst] is found *) -val set_reduction_effect : GlobRef.t -> effect_name -> unit +val set_reduction_effect : Constant.t -> effect_name -> unit (* [effect_hook env sigma key term] apply effect associated to [key] on [term] *) -val reduction_effect_hook : Environ.env -> Evd.evar_map -> Constr.constr -> +val reduction_effect_hook : Environ.env -> Evd.evar_map -> Constant.t -> Constr.constr Lazy.t -> unit (** {6 Machinery about a stack of unfolded constant } @@ -75,7 +75,7 @@ module Stack : sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * Cst_stack.t - | Proj of int * int * Projection.t * Cst_stack.t + | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int (** current foccussed arg *) * int list (** remaining args *) * 'a t * Cst_stack.t diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 40c4cfaa45..8911a2f343 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -49,7 +49,7 @@ let error_not_evaluable r = let is_evaluable_const env cst = is_transparent env (ConstKey cst) && - (evaluable_constant cst env || is_projection cst env) + evaluable_constant cst env let is_evaluable_var env id = is_transparent env (VarKey id) && evaluable_named id env @@ -539,7 +539,7 @@ let reduce_mind_case_use_function func env sigma mia = let match_eval_ref env sigma constr stack = match EConstr.kind sigma constr with | Const (sp, u) -> - reduction_effect_hook env sigma (EConstr.to_constr sigma constr) + reduction_effect_hook env sigma sp (lazy (EConstr.to_constr sigma (applist (constr,stack)))); if is_evaluable env (EvalConstRef sp) then Some (EvalConst sp, u) else None | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, EInstance.empty) @@ -550,7 +550,7 @@ let match_eval_ref env sigma constr stack = let match_eval_ref_value env sigma constr stack = match EConstr.kind sigma constr with | Const (sp, u) -> - reduction_effect_hook env sigma (EConstr.to_constr sigma constr) + reduction_effect_hook env sigma sp (lazy (EConstr.to_constr sigma (applist (constr,stack)))); if is_evaluable env (EvalConstRef sp) then let u = EInstance.kind sigma u in @@ -558,8 +558,6 @@ let match_eval_ref_value env sigma constr stack = else None | Proj (p, c) when not (Projection.unfolded p) -> - reduction_effect_hook env sigma (EConstr.to_constr ~abort_on_undefined_evars:false sigma constr) - (lazy (EConstr.to_constr sigma (applist (constr,stack)))); if is_evaluable env (EvalConstRef (Projection.constant p)) then Some (mkProj (Projection.unfold p, c)) else None @@ -597,12 +595,11 @@ let recargs = function | EvalVar _ | EvalRel _ | EvalEvar _ -> None | EvalConst c -> ReductionBehaviour.get (ConstRef c) -let reduce_projection env sigma pb (recarg'hd,stack') stack = +let reduce_projection env sigma p ~npars (recarg'hd,stack') stack = (match EConstr.kind sigma recarg'hd with | Construct _ -> - let proj_narg = - pb.Declarations.proj_npars + pb.Declarations.proj_arg - in Reduced (List.nth stack' proj_narg, stack) + let proj_narg = npars + Projection.arg p in + Reduced (List.nth stack' proj_narg, stack) | _ -> NotReducible) let reduce_proj env sigma whfun whfun' c = @@ -613,10 +610,8 @@ let reduce_proj env sigma whfun whfun' c = let constr, cargs = whfun c' in (match EConstr.kind sigma constr with | Construct _ -> - let proj_narg = - let pb = lookup_projection proj env in - pb.Declarations.proj_npars + pb.Declarations.proj_arg - in List.nth cargs proj_narg + let proj_narg = Projection.npars proj + Projection.arg proj in + List.nth cargs proj_narg | _ -> raise Redelimination) | Case (n,p,c,brs) -> let c' = redrec c in @@ -765,22 +760,22 @@ and whd_simpl_stack env sigma = (try let unf = Projection.unfolded p in if unf || is_evaluable env (EvalConstRef (Projection.constant p)) then - let pb = lookup_projection p env in + let npars = Projection.npars p in (match unf, ReductionBehaviour.get (ConstRef (Projection.constant p)) with | false, Some (l, n, f) when List.mem `ReductionNeverUnfold f -> (* simpl never *) s' | false, Some (l, n, f) when not (List.is_empty l) -> let l' = List.map_filter (fun i -> - let idx = (i - (pb.Declarations.proj_npars + 1)) in + let idx = (i - (npars + 1)) in if idx < 0 then None else Some idx) l in let stack = reduce_params env sigma stack l' in - (match reduce_projection env sigma pb + (match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with | Reduced s' -> redrec (applist s') | NotReducible -> s') | _ -> - match reduce_projection env sigma pb (whd_construct_stack env sigma c) stack with + match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with | Reduced s' -> redrec (applist s') | NotReducible -> s') else s' @@ -852,8 +847,8 @@ let try_red_product env sigma c = | Construct _ -> c | _ -> redrec env c in - let pb = lookup_projection p env in - (match reduce_projection env sigma pb (whd_betaiotazeta_stack sigma c') [] with + let npars = Projection.npars p in + (match reduce_projection env sigma p ~npars (whd_betaiotazeta_stack sigma c') [] with | Reduced s -> simpfun (applist s) | NotReducible -> raise Redelimination) | _ -> @@ -946,8 +941,8 @@ let whd_simpl_orelse_delta_but_fix env sigma c = (match EConstr.kind sigma constr with | Const (c', _) -> Constant.equal (Projection.constant p) c' | _ -> false) -> - let pb = Environ.lookup_projection p env in - if List.length stack <= pb.Declarations.proj_npars then + let npars = Projection.npars p in + if List.length stack <= npars then (** Do not show the eta-expanded form *) s' else redrec (applist (c, stack)) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index ca2702d741..4ba715f0d5 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -253,16 +253,16 @@ let judge_of_variable env id = Termops.on_judgment EConstr.of_constr (judge_of_variable env id) let judge_of_projection env sigma p cj = - let pb = lookup_projection p env in + let pty = lookup_projection p env in let (ind,u), args = try find_mrectype env sigma cj.uj_type with Not_found -> error_case_not_inductive env sigma cj in let u = EInstance.kind sigma u in - let ty = EConstr.of_constr (CVars.subst_instance_constr u pb.Declarations.proj_type) in - let ty = substl (cj.uj_val :: List.rev args) ty in - {uj_val = EConstr.mkProj (p,cj.uj_val); - uj_type = ty} + let ty = EConstr.of_constr (CVars.subst_instance_constr u pty) in + let ty = substl (cj.uj_val :: List.rev args) ty in + {uj_val = EConstr.mkProj (p,cj.uj_val); + uj_type = ty} let judge_of_abstraction env name var j = { uj_val = mkLambda (name, var.utj_val, j.uj_val); diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 4ba5d27947..fc1f6fc81e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -478,12 +478,8 @@ let expand_table_key env = function | RelKey _ -> None let unfold_projection env p stk = - (match try Some (lookup_projection p env) with Not_found -> None with - | Some pb -> - let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, - p, Cst_stack.empty) in - s :: stk - | None -> assert false) + let s = Stack.Proj (p, Cst_stack.empty) in + s :: stk let expand_key ts env sigma = function | Some (IsKey k) -> Option.map EConstr.of_constr (expand_table_key env k) @@ -512,7 +508,7 @@ let key_of env sigma b flags f = match EConstr.kind sigma f with | Const (cst, u) when is_transparent env (ConstKey cst) && (Cpred.mem cst (snd flags.modulo_delta) - || Environ.is_projection cst env) -> + || Recordops.is_primitive_projection cst) -> let u = EInstance.kind sigma u in Some (IsKey (ConstKey (cst, u))) | Var id when is_transparent env (VarKey id) && @@ -669,17 +665,15 @@ let is_eta_constructor_app env sigma ts f l1 term = | _ -> false let eta_constructor_app env sigma f l1 term = - let open Declarations in match EConstr.kind sigma f with | Construct (((_, i as ind), j), u) -> let mib = lookup_mind (fst ind) env in - (match mib.Declarations.mind_record with - | PrimRecord info -> - let (_, projs, _) = info.(i) in + (match get_projections env ind with + | Some projs -> let npars = mib.Declarations.mind_nparams in let pars, l1' = Array.chop npars l1 in let arg = Array.append pars [|term|] in - let l2 = Array.map (fun p -> mkApp (mkConstU (p,u), arg)) projs in + let l2 = Array.map (fun p -> mkApp (mkConstU (Projection.Repr.constant p,u), arg)) projs in l1', l2 | _ -> assert false) | _ -> assert false diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index c944080503..255707dc7b 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -209,6 +209,9 @@ and nf_evar env sigma evk stk = | Zapp args :: stk -> (** We assume that there is no consecutive Zapp nodes in a VM stack. Is that really an invariant? *) + (** Let-bound arguments are present in the evar arguments but not in the + type, so we turn the let into a product. *) + let hyps = Context.Named.drop_bodies hyps in let fold accu d = Term.mkNamedProd_or_LetIn d accu in let t = List.fold_left fold concl hyps in let t, args = nf_args env sigma args t in diff --git a/printing/prettyp.ml b/printing/prettyp.ml index fd7135b6a6..1810cc6588 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -98,7 +98,8 @@ let print_ref reduce ref udecl = (Array.to_list (Univ.Instance.to_array inst)) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in let inst = - if Global.is_polymorphic ref then Printer.pr_universe_instance sigma univs + if Global.is_polymorphic ref + then Printer.pr_universe_instance sigma (Univ.UContext.instance univs) else mt () in hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++ @@ -552,8 +553,7 @@ let print_instance sigma cb = if Declareops.constant_is_polymorphic cb then let univs = Declareops.constant_polymorphic_context cb in let inst = Univ.AUContext.instance univs in - let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) in - pr_universe_instance sigma univs + pr_universe_instance sigma inst else mt() let print_constant with_values sep sp udecl = @@ -657,14 +657,10 @@ let gallina_print_library_entry env sigma with_values ent = gallina_print_leaf_entry env sigma with_values (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> Some (str " >>>>>>> Section " ++ pr_name oname) - | (oname,Lib.ClosedSection _) -> - Some (str " >>>>>>> Closed Section " ++ pr_name oname) | (_,Lib.CompilingLibrary { obj_dir; _ }) -> Some (str " >>>>>>> Library " ++ DirPath.print obj_dir) | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) - | (oname,Lib.ClosedModule _) -> - Some (str " >>>>>>> Closed Module " ++ pr_name oname) let gallina_print_context env sigma with_values = let rec prec n = function @@ -793,9 +789,6 @@ let read_sec_context qid = let rec get_cxt in_cxt = function | (_,Lib.OpenedSection ({obj_dir;_},_) as hd)::rest -> if DirPath.equal dir obj_dir then (hd::in_cxt) else get_cxt (hd::in_cxt) rest - | (_,Lib.ClosedSection _)::rest -> - user_err Pp.(str "Cannot print the contents of a closed section.") - (* LEM: Actually, we could if we wanted to. *) | [] -> [] | hd::rest -> get_cxt (hd::in_cxt) rest in @@ -909,7 +902,7 @@ let inspect env sigma depth = open Classops -let print_coercion_value env sigma v = pr_lconstr_env env sigma (get_coercion_value v) +let print_coercion_value env sigma v = Printer.pr_global v.coe_value let print_class i = let cl,_ = class_info_from_index i in diff --git a/printing/printer.ml b/printing/printer.ml index 92224c992c..a77c1ced56 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -290,11 +290,13 @@ let pr_cumulativity_info sigma cumi = let pr_global_env = pr_global_env let pr_global = pr_global_env Id.Set.empty -let pr_puniverses f env (c,u) = - f env c ++ - (if !Constrextern.print_universes then - str"(*" ++ Univ.Instance.pr UnivNames.pr_with_global_universes u ++ str"*)" - else mt ()) +let pr_universe_instance evd inst = + str"@{" ++ Univ.Instance.pr (Termops.pr_evd_level evd) inst ++ str"}" + +let pr_puniverses f env sigma (c,u) = + if !Constrextern.print_universes + then f env c ++ pr_universe_instance sigma u + else f env c let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst) let pr_existential_key = Termops.pr_existential_key @@ -493,16 +495,23 @@ let pr_transparent_state (ids, csts) = hv 0 (str"VARIABLES: " ++ pr_idpred ids ++ fnl () ++ str"CONSTANTS: " ++ pr_cpred csts ++ fnl ()) -(* display complete goal *) -let pr_goal gs = +(* display complete goal + prev_gs has info on the previous proof step for diffs + gs has info on the current proof step + *) +let pr_goal ?(diffs=false) ?prev_gs gs = let g = sig_it gs in let sigma = project gs in let env = Goal.V82.env sigma g in let concl = Goal.V82.concl sigma g in let goal = - pr_context_of env sigma ++ cut () ++ - str "============================" ++ cut () ++ - pr_goal_concl_style_env env sigma concl in + if diffs then + Proof_diffs.diff_goals ?prev_gs (Some gs) + else + pr_context_of env sigma ++ cut () ++ + str "============================" ++ cut () ++ + pr_goal_concl_style_env env sigma concl + in str " " ++ v 0 goal (* display a goal tag *) @@ -695,7 +704,8 @@ let print_dependent_evars gl sigma seeds = (* spiwack: [seeds] is for printing dependent evars in emacs mode. *) (* spiwack: [pr_first] is true when the first goal must be singled out and printed in its entirety. *) -let pr_subgoals ?(pr_first=true) +(* [prev] is the previous proof step, used for diffs *) +let pr_subgoals ?(pr_first=true) ?(diffs=false) ?prev close_cmd sigma ~seeds ~shelf ~stack ~unfocused ~goals = (** Printing functions for the extra informations. *) let rec print_stack a = function @@ -729,7 +739,7 @@ let pr_subgoals ?(pr_first=true) if needed then str" focused " else str" " (* non-breakable space *) in - (** Main function *) + let rec pr_rec n = function | [] -> (mt ()) | g::rest -> @@ -739,7 +749,14 @@ let pr_subgoals ?(pr_first=true) in let print_multiple_goals g l = if pr_first then - pr_goal { it = g ; sigma = sigma; } + let prev_gs = + match prev with + | Some (prev_goals, prev_sigma) -> + if prev_goals = [] then None + else Some { it = List.hd prev_goals; sigma = prev_sigma} + | None -> None + in + pr_goal ~diffs ?prev_gs { it = g ; sigma = sigma } ++ (if l=[] then mt () else cut ()) ++ pr_rec 2 l else @@ -751,6 +768,8 @@ let pr_subgoals ?(pr_first=true) | Some cmd -> Feedback.msg_info cmd | None -> () in + + (** Main function *) match goals with | [] -> begin @@ -780,7 +799,7 @@ let pr_subgoals ?(pr_first=true) ++ print_dependent_evars (Some g1) sigma seeds ) -let pr_open_subgoals ~proof = +let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?prev_proof proof = (* spiwack: it shouldn't be the job of the printer to look up stuff in the [evar_map], I did stuff that way because it was more straightforward, but seriously, [Proof.proof] should return @@ -803,21 +822,33 @@ let pr_open_subgoals ~proof = fnl () ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:shelf | _ , _, _ -> - let end_cmd = - str "This subproof is complete, but there are some unfocused goals." ++ - (let s = Proof_bullet.suggest p in - if Pp.ismt s then s else fnl () ++ s) ++ - fnl () + let cmd = if quiet then None else + Some + (str "This subproof is complete, but there are some unfocused goals." ++ + (let s = Proof_bullet.suggest p in + if Pp.ismt s then s else fnl () ++ s) ++ + fnl ()) in - pr_subgoals ~pr_first:false (Some end_cmd) bsigma ~seeds ~shelf ~stack:[] ~unfocused:[] ~goals:bgoals + pr_subgoals ~pr_first:false cmd bsigma ~seeds ~shelf ~stack:[] ~unfocused:[] ~goals:bgoals end | _ -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in let bgoals_focused, bgoals_unfocused = List.partition (fun x -> List.mem x goals) bgoals in let unfocused_if_needed = if should_unfoc() then bgoals_unfocused else [] in - pr_subgoals ~pr_first:true None bsigma ~seeds ~shelf ~stack:[] ~unfocused:unfocused_if_needed ~goals:bgoals_focused + let prev = match prev_proof with + | Some op -> + let (ogoals , _, _, _, _) = Proof.proof op in + let { Evd.it = obgoals; sigma = osigma } = Proof.V82.background_subgoals op in + let obgoals_focused = List.filter (fun x -> List.mem x ogoals) obgoals in + Some (obgoals_focused, osigma) + | None -> None + in + pr_subgoals ~pr_first:true ~diffs ?prev None bsigma ~seeds ~shelf ~stack:[] ~unfocused:unfocused_if_needed ~goals:bgoals_focused end +let pr_open_subgoals ~proof = + pr_open_subgoals_diff proof + let pr_nth_open_subgoal ~proof n = let gls,_,_,_,sigma = Proof.proof proof in pr_subgoal n sigma gls @@ -987,6 +1018,29 @@ let pr_polymorphic b = if b then str"Polymorphic " else str"Monomorphic " else mt () -let pr_universe_instance evd ctx = - let inst = Univ.UContext.instance ctx in - str"@{" ++ Univ.Instance.pr (Termops.pr_evd_level evd) inst ++ str"}" +(* print the proof step, possibly with diffs highlighted, *) +let print_and_diff oldp newp = + match newp with + | None -> () + | Some proof -> + let output = + if Proof_diffs.show_diffs () then + try pr_open_subgoals_diff ~diffs:true ?prev_proof:oldp proof + with Pp_diff.Diff_Failure msg -> begin + (* todo: print the unparsable string (if we know it) *) + Feedback.msg_warning Pp.(str ("Diff failure:" ^ msg ^ "; showing results without diff highlighting" )); + pr_open_subgoals ~proof + end + else + pr_open_subgoals ~proof + in + Feedback.msg_notice output;; + +(* Do diffs on the first goal returning a Pp. *) +let diff_pr_open_subgoals ?(quiet=false) o_proof n_proof = + match n_proof with + | None -> Pp.mt () + | Some proof -> + try pr_open_subgoals_diff ~quiet ~diffs:true ?prev_proof:o_proof proof + with Pp_diff.Diff_Failure _ -> pr_open_subgoals ~proof + (* todo: print the unparsable string (if we know it) *) diff --git a/printing/printer.mli b/printing/printer.mli index eddfef6fad..971241d5f9 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -120,7 +120,7 @@ val pr_sort : evar_map -> Sorts.t -> Pp.t val pr_polymorphic : bool -> Pp.t val pr_cumulative : bool -> bool -> Pp.t -val pr_universe_instance : evar_map -> Univ.UContext.t -> Pp.t +val pr_universe_instance : evar_map -> Univ.Instance.t -> Pp.t val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> Univ.UContext.t -> Pp.t val pr_universe_ctx_set : evar_map -> Univ.ContextSet.t -> Pp.t @@ -139,9 +139,9 @@ val pr_constructor : env -> constructor -> Pp.t val pr_inductive : env -> inductive -> Pp.t val pr_evaluable_reference : evaluable_global_reference -> Pp.t -val pr_pconstant : env -> pconstant -> Pp.t -val pr_pinductive : env -> pinductive -> Pp.t -val pr_pconstructor : env -> pconstructor -> Pp.t +val pr_pconstant : env -> evar_map -> pconstant -> Pp.t +val pr_pinductive : env -> evar_map -> pinductive -> Pp.t +val pr_pconstructor : env -> evar_map -> pconstructor -> Pp.t (** Contexts *) @@ -171,22 +171,26 @@ val pr_transparent_state : transparent_state -> Pp.t (** Proofs, these functions obey [Hyps Limit] and [Compact contexts]. *) -val pr_goal : goal sigma -> Pp.t +val pr_goal : ?diffs:bool -> ?prev_gs:(goal sigma) -> goal sigma -> Pp.t -(** [pr_subgoals ~pr_first pp sigma seeds shelf focus_stack unfocused goals] +(** [pr_subgoals ~pr_first ~prev_proof pp sigma seeds shelf focus_stack unfocused goals] prints the goals of the list [goals] followed by the goals in [unfocused], in a short way (typically only the conclusion) except - for the first goal if [pr_first] is true. This function can be - replaced by another one by calling [set_printer_pr] (see below), - typically by plugin writers. The default printer prints only the + for the first goal if [pr_first] is true. Also, if [diffs] is true + and [pr_first] is true, then highlight diffs relative to [prev] in the + output for first goal. This function prints only the focused goals unless the conrresponding option [enable_unfocused_goal_printing] is set. [seeds] is for printing dependent evars (mainly for emacs proof tree mode). *) -val pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> seeds:goal list -> shelf:goal list -> stack:int list -> unfocused:goal list -> goals:goal list -> Pp.t +val pr_subgoals : ?pr_first:bool -> ?diffs:bool -> ?prev:(goal list * evar_map) -> Pp.t option -> evar_map + -> seeds:goal list -> shelf:goal list -> stack:int list + -> unfocused: goal list -> goals:goal list -> Pp.t val pr_subgoal : int -> evar_map -> goal list -> Pp.t val pr_concl : int -> evar_map -> goal -> Pp.t +val pr_open_subgoals_diff : ?quiet:bool -> ?diffs:bool -> ?prev_proof:Proof.t -> Proof.t -> Pp.t +val diff_pr_open_subgoals : ?quiet:bool -> Proof.t option -> Proof.t option -> Pp.t val pr_open_subgoals : proof:Proof.t -> Pp.t val pr_nth_open_subgoal : proof:Proof.t -> int -> Pp.t val pr_evar : evar_map -> (Evar.t * evar_info) -> Pp.t @@ -197,6 +201,8 @@ val pr_ne_evar_set : Pp.t -> Pp.t -> evar_map -> val pr_prim_rule : prim_rule -> Pp.t +val print_and_diff : Proof.t option -> Proof.t option -> unit + (** Backwards compatibility *) val prterm : constr -> Pp.t (** = pr_lconstr *) diff --git a/printing/printing.mllib b/printing/printing.mllib index b69d8a9ef8..deb52ad270 100644 --- a/printing/printing.mllib +++ b/printing/printing.mllib @@ -1,6 +1,7 @@ Genprint Pputils Ppconstr +Proof_diffs Printer Printmod Prettyp diff --git a/printing/printmod.ml b/printing/printmod.ml index 3f95dcfb6d..e2d9850bf8 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -103,9 +103,7 @@ let print_one_inductive env sigma mib ((_,i) as ind) = let envpar = push_rel_context params env in let inst = if Declareops.inductive_is_polymorphic mib then - let ctx = Declareops.inductive_polymorphic_context mib in - let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u ctx) in - Printer.pr_universe_instance sigma ctx + Printer.pr_universe_instance sigma u else mt () in hov 0 ( diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml new file mode 100644 index 0000000000..7131ced15b --- /dev/null +++ b/printing/proof_diffs.ml @@ -0,0 +1,339 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* +Displays the differences between successive proof steps in coqtop and CoqIDE. +Proof General requires minor changes to make the diffs visible, but this code +shouldn't break the existing version of PG. See pp_diff.ml for details on how +the diff works. + +Diffs are computed for the hypotheses and conclusion of the first goal between +the old and new proofs. + +Diffs can be enabled with the Coq commmand "Set Diffs on|off|removed." or +'-diffs "on"|"off"|"removed"' on the OS command line. The "on" option shows only the +new item with added text, while "removed" shows each modified item twice--once +with the old value showing removed text and once with the new value showing +added text. + +In CoqIDE, colors and highlights can be set in the Edit/Preferences/Tags panel. +For coqtop, these can be set through the COQ_COLORS environment variable. + +Limitations/Possible enhancements: + +- If you go back to a prior proof step, diffs are not shown on the new current +step. Diffs will be shown again once you do another proof step. + +- Diffs are done between the first active goal in the old and new proofs. +If, for example, the proof step completed a goal, then the new goal is a +different goal, not a transformation of the old goal, so a diff is probably +not appropriate. (There's currently no way to tell when this happens or to +accurately match goals across old and new proofs. +See https://github.com/coq/coq/issues/7653) This is also why only the +first goal is diffed. + +- "Set Diffs "xx"." should reprint the current goal using the new option. + +- coqtop colors were chosen for white text on a black background. They're +not the greatest. I didn't want to change the existing green highlight. +Suggestions welcome. + +- coqtop underlines removed text because (per Wikipedia) the ANSI escape code +for strikeout is not commonly supported (it didn't work on mine). CoqIDE +uses strikeout on removed text. +*) + +open Pp_diff + +let diff_option = ref `OFF + +(* todo: Is there a way to persist the setting between sessions? + Eg if the user wants this as a permanent config setting? *) +let read_diffs_option () = match !diff_option with +| `OFF -> "off" +| `ON -> "on" +| `REMOVED -> "removed" + +let write_diffs_option = function +| "off" -> diff_option := `OFF +| "on" -> diff_option := `ON +| "removed" -> diff_option := `REMOVED +| _ -> CErrors.user_err Pp.(str "Diffs option only accepts the following values: \"off\", \"on\", \"removed\".") + +let _ = + Goptions.(declare_string_option { + optdepr = false; + optname = "show diffs in proofs"; + optkey = ["Diffs"]; + optread = read_diffs_option; + optwrite = write_diffs_option + }) + +let show_diffs () = !diff_option <> `OFF;; +let show_removed () = !diff_option = `REMOVED;; + + +(* DEBUG/UNIT TEST *) +let cfprintf oc = Printf.(kfprintf (fun oc -> fprintf oc "") oc) +let log_out_ch = ref stdout +[@@@ocaml.warning "-32"] +let cprintf s = cfprintf !log_out_ch s +[@@@ocaml.warning "+32"] + +module StringMap = Map.Make(String);; + +let tokenize_string s = + (* todo: cLexer changes buff as it proceeds. Seems like that should be saved, too. + But I don't understand how it's used--it looks like things get appended to it but + it never gets cleared. *) + let rec stream_tok acc str = + let e = Stream.next str in + if Tok.(equal e EOI) then + List.rev acc + else + stream_tok ((Tok.extract_string e) :: acc) str + in + let st = CLexer.get_lexer_state () in + try + let istr = Stream.of_string s in + let lex = CLexer.lexer.Plexing.tok_func istr in + let toks = stream_tok [] (fst lex) in + CLexer.set_lexer_state st; + toks + with exn -> + CLexer.set_lexer_state st; + raise (Diff_Failure "Input string is not lexable");; + + +type hyp_info = { + idents: string list; + rhs_pp: Pp.t; + mutable done_: bool; +} + +(* Generate the diffs between the old and new hyps. + This works by matching lines with the hypothesis name and diffing the right-hand side. + Lines that have multiple names such as "n, m : nat" are handled specially to account + for, say, the addition of m to a pre-existing "n : nat". + *) +let diff_hyps o_line_idents o_map n_line_idents n_map = + let rv : Pp.t list ref = ref [] in + + let is_done ident map = (StringMap.find ident map).done_ in + let exists ident map = + try let _ = StringMap.find ident map in true + with Not_found -> false in + let contains l ident = try [List.find (fun x -> x = ident) l] with Not_found -> [] in + + let output old_ids_uo new_ids = + (* use the order from the old line in case it's changed in the new *) + let old_ids = if old_ids_uo = [] then [] else + let orig = (StringMap.find (List.hd old_ids_uo) o_map).idents in + List.concat (List.map (contains orig) old_ids_uo) in + + let setup ids map = if ids = [] then ("", Pp.mt ()) else + let open Pp in + let rhs_pp = (StringMap.find (List.hd ids) map).rhs_pp in + let pp_ids = List.map (fun x -> str x) ids in + let hyp_pp = List.fold_left (fun l1 l2 -> l1 ++ str ", " ++ l2) (List.hd pp_ids) (List.tl pp_ids) ++ rhs_pp in + (string_of_ppcmds hyp_pp, hyp_pp) + in + + let (o_line, o_pp) = setup old_ids o_map in + let (n_line, n_pp) = setup new_ids n_map in + + let hyp_diffs = diff_str ~tokenize_string o_line n_line in + let (has_added, has_removed) = has_changes hyp_diffs in + if show_removed () && has_removed then begin + let o_entry = StringMap.find (List.hd old_ids) o_map in + o_entry.done_ <- true; + rv := (add_diff_tags `Removed o_pp hyp_diffs) :: !rv; + end; + if n_line <> "" then begin + let n_entry = StringMap.find (List.hd new_ids) n_map in + n_entry.done_ <- true; + rv := (add_diff_tags `Added n_pp hyp_diffs) :: !rv + end + in + + (* process identifier level diff *) + let process_ident_diff diff = + let (dtype, ident) = get_dinfo diff in + match dtype with + | `Removed -> + if dtype = `Removed then begin + let o_idents = (StringMap.find ident o_map).idents in + (* only show lines that have all idents removed here; other removed idents appear later *) + if show_removed () && + List.for_all (fun x -> not (exists x n_map)) o_idents then + output (List.rev o_idents) [] + end + | _ -> begin (* Added or Common case *) + let n_idents = (StringMap.find ident n_map).idents in + + (* Process a new hyp line, possibly splitting it. Duplicates some of + process_ident iteration, but easier to understand this way *) + let process_line ident2 = + if not (is_done ident2 n_map) then begin + let n_ids_list : string list ref = ref [] in + let o_ids_list : string list ref = ref [] in + let fst_omap_idents = ref None in + let add ids id map = + ids := id :: !ids; + (StringMap.find id map).done_ <- true in + + (* get identifiers shared by one old and one new line, plus + other Added in new and other Removed in old *) + let process_split ident3 = + if not (is_done ident3 n_map) then begin + let this_omap_idents = try Some (StringMap.find ident3 o_map).idents + with Not_found -> None in + if !fst_omap_idents = None then + fst_omap_idents := this_omap_idents; + match (!fst_omap_idents, this_omap_idents) with + | (Some fst, Some this) when fst == this -> (* yes, == *) + add n_ids_list ident3 n_map; + (* include, in old order, all undone Removed idents in old *) + List.iter (fun x -> if x = ident3 || not (is_done x o_map) && not (exists x n_map) then + (add o_ids_list x o_map)) fst + | (_, None) -> + add n_ids_list ident3 n_map (* include all undone Added idents in new *) + | _ -> () + end in + List.iter process_split n_idents; + output (List.rev !o_ids_list) (List.rev !n_ids_list) + end in + List.iter process_line n_idents (* O(n^2), so sue me *) + end in + + let cvt s = Array.of_list (List.concat s) in + let ident_diffs = diff_strs (cvt o_line_idents) (cvt n_line_idents) in + List.iter process_ident_diff ident_diffs; + List.rev !rv;; + + +type 'a hyp = (Names.Id.t list * 'a option * 'a) +type 'a reified_goal = { name: string; ty: 'a; hyps: 'a hyp list; env : Environ.env; sigma: Evd.evar_map } + +(* XXX: Port to proofview, one day. *) +(* open Proofview *) +module CDC = Context.Compacted.Declaration + +let to_tuple : Constr.compacted_declaration -> (Names.Id.t list * 'pc option * 'pc) = + let open CDC in function + | LocalAssum(idl, tm) -> (idl, None, tm) + | LocalDef(idl,tdef,tm) -> (idl, Some tdef, tm);; + +(* XXX: Very unfortunately we cannot use the Proofview interface as + Proof is still using the "legacy" one. *) +let process_goal sigma g : Constr.t reified_goal = + let env = Goal.V82.env sigma g in + let hyps = Goal.V82.hyps sigma g in + let ty = Goal.V82.concl sigma g in + let name = Goal.uid g in + (* There is a Constr/Econstr mess here... *) + let ty = EConstr.to_constr sigma ty in + (* compaction is usually desired [eg for better display] *) + let hyps = Termops.compact_named_context (Environ.named_context_of_val hyps) in + let hyps = List.map to_tuple hyps in + { name; ty; hyps; env; sigma };; + +let pr_letype_core goal_concl_style env sigma t = + Ppconstr.pr_lconstr_expr (Constrextern.extern_type goal_concl_style env sigma t) + +let pp_of_type env sigma ty = + pr_letype_core true env sigma EConstr.(of_constr ty) + +(* fetch info from a goal, returning (idents, map, concl_pp) where +idents is a list with one entry for each hypothesis, each entry is the list of +idents on the lhs of the hypothesis. map is a map from ident to hyp_info +reoords. For example: for the hypotheses: + b : bool + n, m : nat + +list will be [ ["b"]; ["n"; "m"] ] + +map will contain: + "b" -> { ["b"], Pp.t for ": bool"; false } + "n" -> { ["n"; "m"], Pp.t for ": nat"; false } + "m" -> { ["n"; "m"], Pp.t for ": nat"; false } + where the last two entries share the idents list. + +concl_pp is the conclusion as a Pp.t +*) +let goal_info goal sigma = + let map = ref StringMap.empty in + let line_idents = ref [] in + let build_hyp_info env sigma hyp = + let (names, body, ty) = hyp in + let open Pp in + let idents = List.map (fun x -> Names.Id.to_string x) names in + + line_idents := idents :: !line_idents; + let mid = match body with + | Some x -> str " := " ++ pp_of_type env sigma ty ++ str " : " + | None -> str " : " in + let ts = pp_of_type env sigma ty in + let rhs_pp = mid ++ ts in + + let make_entry () = { idents; rhs_pp; done_ = false } in + List.iter (fun ident -> map := (StringMap.add ident (make_entry ()) !map); ()) idents + in + + try + let { ty=ty; hyps=hyps; env=env } = process_goal sigma goal in + List.iter (build_hyp_info env sigma) (List.rev hyps); + let concl_pp = pp_of_type env sigma ty in + ( List.rev !line_idents, !map, concl_pp ) + with _ -> ([], !map, Pp.mt ());; + +let diff_goal_info o_info n_info = + let (o_line_idents, o_hyp_map, o_concl_pp) = o_info in + let (n_line_idents, n_hyp_map, n_concl_pp) = n_info in + let show_removed = Some (show_removed ()) in + let concl_pp = diff_pp_combined ~tokenize_string ?show_removed o_concl_pp n_concl_pp in + + let hyp_diffs_list = diff_hyps o_line_idents o_hyp_map n_line_idents n_hyp_map in + (hyp_diffs_list, concl_pp) + +let hyp_list_to_pp hyps = + let open Pp in + match hyps with + | h :: tl -> List.fold_left (fun x y -> x ++ cut () ++ y) h tl + | [] -> mt ();; + +(* Special purpuse, use only for the IDE interface, *) +let diff_first_goal o_proof n_proof = + let first_goal_info proof = + match proof with + | None -> ([], StringMap.empty, Pp.mt ()) + | Some proof2 -> + let (goals,_,_,_,sigma) = Proof.proof proof2 in + match goals with + | hd :: tl -> goal_info hd sigma; + | _ -> ([], StringMap.empty, Pp.mt ()) + in + diff_goal_info (first_goal_info o_proof) (first_goal_info n_proof);; + +let diff_goals ?prev_gs n_gs = + let unwrap gs = + match gs with + | Some gs -> + let goal = Evd.sig_it gs in + let sigma = Refiner.project gs in + goal_info goal sigma + | None -> ([], StringMap.empty, Pp.mt ()) + in + let (hyps_pp_list, concl_pp) = diff_goal_info (unwrap prev_gs) (unwrap n_gs) in + let open Pp in + v 0 ( + (hyp_list_to_pp hyps_pp_list) ++ cut () ++ + str "============================" ++ cut () ++ + concl_pp);; diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli new file mode 100644 index 0000000000..0d3b5821e5 --- /dev/null +++ b/printing/proof_diffs.mli @@ -0,0 +1,67 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* diff options *) + +(** Controls whether to show diffs. Takes values "on", "off", "removed" *) +val write_diffs_option : string -> unit +(** Returns true if the diffs option is "on" or "removed" *) +val show_diffs : unit -> bool + +(** Computes the diff between the first goal of two Proofs and returns +the highlighted hypotheses and conclusion. + +If the strings used to display the goal are not lexable (this is believed +unlikely), this routine will generate a Diff_Failure. This routine may also +raise Diff_Failure under some "impossible" conditions. + +If you want to make your call especially bulletproof, catch these +exceptions, print a user-visible message, then recall this routine with +the first argument set to None, which will skip the diff. +*) +val diff_first_goal : Proof.t option -> Proof.t option -> Pp.t list * Pp.t + +open Evd +open Proof_type + +(** Computes the diff between two goals + +If the strings used to display the goal are not lexable (this is believed +unlikely), this routine will generate a Diff_Failure. This routine may also +raise Diff_Failure under some "impossible" conditions. + +If you want to make your call especially bulletproof, catch these +exceptions, print a user-visible message, then recall this routine with +the first argument set to None, which will skip the diff. +*) +val diff_goals : ?prev_gs:(goal sigma) -> goal sigma option -> Pp.t + +(** Convert a string to a list of token strings using the lexer *) +val tokenize_string : string -> string list + +(* Exposed for unit test, don't use these otherwise *) +(* output channel for the test log file *) +val log_out_ch : out_channel ref + + +type hyp_info = { + idents: string list; + rhs_pp: Pp.t; + mutable done_: bool; +} + +module StringMap : +sig + type +'a t + val empty: hyp_info t + val add : string -> hyp_info -> hyp_info t -> hyp_info t +end + +val diff_hyps : string list list -> hyp_info StringMap.t -> string list list -> hyp_info StringMap.t -> Pp.t list diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 6be80d29a5..eca0c6674b 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -42,13 +42,6 @@ let string_of_vernac_when = function let string_of_vernac_classification (t,w) = string_of_vernac_type t ^ " " ^ string_of_vernac_when w -let classifiers = ref [] -let declare_vernac_classifier - (s : Vernacexpr.extend_name) - (f : Genarg.raw_generic_argument list -> unit -> vernac_classification) -= - classifiers := !classifiers @ [s,f] - let idents_of_name : Names.Name.t -> Names.Id.t list = function | Names.Anonymous -> [] @@ -194,7 +187,7 @@ let classify_vernac e = | VernacWriteState _ -> VtSideff [], VtNow (* Plugins should classify their commands *) | VernacExtend (s,l) -> - try List.assoc s !classifiers l () + try Vernacentries.get_vernac_classifier s l with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in let rec static_control_classifier ~poly = function diff --git a/stm/vernac_classifier.mli b/stm/vernac_classifier.mli index 45fbfb42af..e82b191418 100644 --- a/stm/vernac_classifier.mli +++ b/stm/vernac_classifier.mli @@ -9,17 +9,12 @@ (************************************************************************) open Vernacexpr -open Genarg val string_of_vernac_classification : vernac_classification -> string (** What does a vernacular do *) val classify_vernac : vernac_control -> vernac_classification -(** Install a vernacular classifier for VernacExtend *) -val declare_vernac_classifier : - Vernacexpr.extend_name -> (raw_generic_argument list -> unit -> vernac_classification) -> unit - (** Standard constant classifiers *) val classify_as_query : vernac_classification val classify_as_sideeff : vernac_classification diff --git a/tactics/hints.ml b/tactics/hints.ml index 748e0362c4..43a450ea71 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -299,16 +299,16 @@ let strip_params env sigma c = match EConstr.kind sigma c with | App (f, args) -> (match EConstr.kind sigma f with - | Const (p,_) -> - let p = Projection.make p false in - (match lookup_projection p env with - | pb -> - let n = pb.Declarations.proj_npars in - if Array.length args > n then - mkApp (mkProj (p, args.(n)), - Array.sub args (n+1) (Array.length args - (n + 1))) + | Const (cst,_) -> + (match Recordops.find_primitive_projection cst with + | Some p -> + let p = Projection.make p false in + let npars = Projection.npars p in + if Array.length args > npars then + mkApp (mkProj (p, args.(npars)), + Array.sub args (npars+1) (Array.length args - (npars + 1))) else c - | exception Not_found -> c) + | None -> c) | _ -> c) | _ -> c @@ -886,20 +886,6 @@ let pr_hint_term env sigma ctx = function let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in pr_econstr_env env sigma c -(** We need an object to record the side-effect of registering - global universes associated with a hint. *) -let cache_context_set (_,c) = - Global.push_context_set false c - -let input_context_set : Univ.ContextSet.t -> Libobject.obj = - let open Libobject in - declare_object - { (default_object "Global universe context") with - cache_function = cache_context_set; - load_function = (fun _ -> cache_context_set); - discharge_function = (fun (_,a) -> Some a); - classify_function = (fun a -> Keep a) } - let warn_polymorphic_hint = CWarnings.create ~name:"polymorphic-hint" ~category:"automation" (fun hint -> strbrk"Using polymorphic hint " ++ hint ++ @@ -919,7 +905,7 @@ let fresh_global_or_constr env sigma poly cr = else begin if isgr then warn_polymorphic_hint (pr_hint_term env sigma ctx cr); - Lib.add_anonymous_leaf (input_context_set ctx); + Declare.declare_universe_context false ctx; (c, Univ.ContextSet.empty) end @@ -1315,7 +1301,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) else if local then IsConstr (c', diff) - else (Lib.add_anonymous_leaf (input_context_set diff); + else (Declare.declare_universe_context false diff; IsConstr (c', Univ.ContextSet.empty)) let project_hint ~poly pri l2r r = diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 928530744a..5fc34619e8 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1581,9 +1581,10 @@ let make_projection env sigma params cstr sign elim i n c u = | Some proj -> let args = Context.Rel.to_extended_vect mkRel 0 sign in let proj = - if Environ.is_projection proj env then + match Recordops.find_primitive_projection proj with + | Some proj -> mkProj (Projection.make proj false, mkApp (c, args)) - else + | None -> mkApp (mkConstU (proj,u), Array.append (Array.of_list params) [|mkApp (c, args)|]) in diff --git a/test-suite/Makefile b/test-suite/Makefile index 33b4023272..b8aac8b6f8 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -192,10 +192,6 @@ PRINT_LOGS?= TRAVIS?= # special because we want to print travis_fold directives ifdef APPVEYOR PRINT_LOGS:=APPVEYOR -else -ifdef CIRCLECI -PRINT_LOGS:=CIRCLECI -endif #CIRCLECI endif #APPVEYOR report: summary.log diff --git a/test-suite/bugs/closed/2733.v b/test-suite/bugs/closed/2733.v index 832de4f913..24dd30b32e 100644 --- a/test-suite/bugs/closed/2733.v +++ b/test-suite/bugs/closed/2733.v @@ -16,6 +16,21 @@ match k,l with |B,l' => Bcons true (Ncons 0 l') end. +(* At some time, the success of trullynul was dependent on the name of + the variables! *) + +Definition trullynul2 k {a} (l : alt_list k a) := +match k,l with + |N,l' => Ncons 0 (Bcons true l') + |B,l' => Bcons true (Ncons 0 l') +end. + +Definition trullynul3 k {z} (l : alt_list k z) := +match k,l with + |N,l' => Ncons 0 (Bcons true l') + |B,l' => Bcons true (Ncons 0 l') +end. + Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 -> alt_list t1 t3 := match l with diff --git a/test-suite/bugs/closed/7854.v b/test-suite/bugs/closed/7854.v new file mode 100644 index 0000000000..ab1a29b632 --- /dev/null +++ b/test-suite/bugs/closed/7854.v @@ -0,0 +1,10 @@ +Set Primitive Projections. + +CoInductive stream (A : Type) := cons { + hd : A; + tl : stream A; +}. + +CoFixpoint const {A} (x : A) := cons A x (const x). + +Check (@eq_refl _ (const tt) <<: tl unit (const tt) = const tt). diff --git a/test-suite/bugs/closed/8081.v b/test-suite/bugs/closed/8081.v new file mode 100644 index 0000000000..0f2501aaa8 --- /dev/null +++ b/test-suite/bugs/closed/8081.v @@ -0,0 +1,4 @@ +Section foo. +End foo. +Section foo. +End foo. diff --git a/test-suite/bugs/closed/8119.v b/test-suite/bugs/closed/8119.v new file mode 100644 index 0000000000..c6329a7328 --- /dev/null +++ b/test-suite/bugs/closed/8119.v @@ -0,0 +1,46 @@ +Require Import Coq.Strings.String. + +Section T. + Eval vm_compute in let x := tt in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Eval vm_compute in let _ := Set in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Eval vm_compute in let _ := Prop in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) +End T. + +Section U0. + Let n : unit := tt. + Eval vm_compute in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) +End U0. + +Section S0. + Let LF : string := String (Coq.Strings.Ascii.Ascii false true false true false false false false) "". + Eval vm_compute in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) +End S0. + +Class T := { }. +Section S1. + Context {p : T}. + Let LF : string := String (Coq.Strings.Ascii.Ascii false true false true false false false false) "". + Eval vm_compute in _. +(* Error: Anomaly "Uncaught exception Not_found." Please report at http://coq.inria.fr/bugs/. *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "Uncaught exception Not_found." Please report at http://coq.inria.fr/bugs/. *) +End S1. + +Class M := { m : Type }. +Section S2. + Context {p : M}. + Let LF : string := String (Coq.Strings.Ascii.Ascii false true false true false false false false) "". + Eval vm_compute in _. +(* Error: Anomaly "File "pretyping/vnorm.ml", line 60, characters 9-15: Assertion failed." *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "File "pretyping/vnorm.ml", line 60, characters 9-15: Assertion failed." *) +End S2. diff --git a/test-suite/bugs/closed/8126.v b/test-suite/bugs/closed/8126.v new file mode 100644 index 0000000000..f52dfc6b47 --- /dev/null +++ b/test-suite/bugs/closed/8126.v @@ -0,0 +1,13 @@ +(* See also output test Notations4.v *) + +Inductive foo := tt. +Bind Scope foo_scope with foo. +Delimit Scope foo_scope with foo. +Notation "'HI'" := tt : foo_scope. +Definition myfoo (x : nat) (y : nat) (z : foo) := y. +Notation myfoo0 := (@myfoo 0). +Notation myfoo01 := (@myfoo0 1). +Check myfoo 0 1 HI. (* prints [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo0 1 HI. (* prints [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo01 tt. (* prints [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo01 HI. (* was failing *) diff --git a/test-suite/coqchk/include_primproj.v b/test-suite/coqchk/include_primproj.v new file mode 100644 index 0000000000..804ba1d378 --- /dev/null +++ b/test-suite/coqchk/include_primproj.v @@ -0,0 +1,13 @@ +(* #7329 *) +Set Primitive Projections. + +Module M. + Module Bar. + Record Box := box { unbox : Type }. + + Axiom foo : Box. + Axiom baz : forall _ : unbox foo, unbox foo. + End Bar. +End M. + +Include M. diff --git a/test-suite/output/BadOptionValueType.out b/test-suite/output/BadOptionValueType.out new file mode 100644 index 0000000000..34d8518a75 --- /dev/null +++ b/test-suite/output/BadOptionValueType.out @@ -0,0 +1,8 @@ +The command has indeed failed with message: +Bad type of value for this option: expected int, got string. +The command has indeed failed with message: +Bad type of value for this option: expected bool, got string. +The command has indeed failed with message: +Bad type of value for this option: expected bool, got int. +The command has indeed failed with message: +Bad type of value for this option: expected bool, got int. diff --git a/test-suite/output/BadOptionValueType.v b/test-suite/output/BadOptionValueType.v new file mode 100644 index 0000000000..b61c3757ba --- /dev/null +++ b/test-suite/output/BadOptionValueType.v @@ -0,0 +1,4 @@ +Fail Set Default Timeout "2". +Fail Set Debug Eauto "yes". +Fail Set Debug Eauto 1. +Fail Set Implicit Arguments 1. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 419dcadb4c..dfab400baa 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -169,3 +169,5 @@ fun x : K => match x with | _ => 2 end : K -> nat +The command has indeed failed with message: +Pattern "S _, _" is redundant in this clause. diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 4740c009a4..e4fa7044e7 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -217,3 +217,6 @@ Check fun x => match x with a3 | a4 => 3 | _ => 2 end. Check fun x => match x with a3 => 3 | a2 | a1 => 4 | _ => 2 end. Check fun x => match x with a4 => 3 | a2 | a1 => 4 | _ => 2 end. Check fun x => match x with a3 | a4 | a1 => 3 | _ => 2 end. + +(* Test redundant clause within a disjunctive pattern *) +Fail Check fun n m => match n, m with 0, 0 | _, S _ | S 0, _ | S (S _ | _), _ => false end. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 5ab616160a..d32cf67e28 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -246,3 +246,9 @@ Notation ============================ ##@% ^^^ +myfoo01 tt + : nat +myfoo01 tt + : nat +myfoo01 tt + : nat diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 876aaa3944..180e8d337e 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -399,3 +399,14 @@ Show. Abort. End Issue7731. + +Module Issue8126. + +Definition myfoo (x : nat) (y : nat) (z : unit) := y. +Notation myfoo0 := (@myfoo 0). +Notation myfoo01 := (@myfoo0 1). +Check myfoo 0 1 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo0 1 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo01 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) + +End Issue8126. diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v index 7ca2767a53..299b08bdd1 100644 --- a/test-suite/success/primitiveproj.v +++ b/test-suite/success/primitiveproj.v @@ -193,12 +193,13 @@ Set Primitive Projections. Record s (x:nat) (y:=S x) := {c:=x; d:x=c}. Lemma f : 0=1. Proof. -Fail apply d. + Fail apply d. (* split. reflexivity. Qed. *) +Abort. (* Primitive projection match compilation *) Require Import List. @@ -220,3 +221,9 @@ Fixpoint split_at {A} (l : list A) (n : nat) : prod (list A) (list A) := Time Eval vm_compute in split_at (repeat 0 20) 10. (* Takes 0s *) Time Eval vm_compute in split_at (repeat 0 40) 20. (* Takes 0.001s *) Timeout 1 Time Eval vm_compute in split_at (repeat 0 60) 30. (* Used to take 60s, now takes 0.001s *) + +Check (@eq_refl _ 0 <: 0 = fst (pair 0 1)). +Fail Check (@eq_refl _ 0 <: 0 = snd (pair 0 1)). + +Check (@eq_refl _ 0 <<: 0 = fst (pair 0 1)). +Fail Check (@eq_refl _ 0 <<: 0 = snd (pair 0 1)). diff --git a/test-suite/unit-tests/clib/inteq.ml b/test-suite/unit-tests/clib/inteq.ml index c07ec293f0..89717c79d5 100644 --- a/test-suite/unit-tests/clib/inteq.ml +++ b/test-suite/unit-tests/clib/inteq.ml @@ -1,5 +1,7 @@ open Utest +let log_out_ch = open_log_out_ch __FILE__ + let eq0 = mk_bool_test "clib-inteq0" "Int.equal on 0" (Int.equal 0 0) @@ -10,4 +12,4 @@ let eq42 = mk_bool_test "clib-inteq42" let tests = [ eq0; eq42 ] -let _ = run_tests __FILE__ tests +let _ = run_tests __FILE__ log_out_ch tests diff --git a/test-suite/unit-tests/clib/unicode_tests.ml b/test-suite/unit-tests/clib/unicode_tests.ml index 9ae405977b..95316ad3aa 100644 --- a/test-suite/unit-tests/clib/unicode_tests.ml +++ b/test-suite/unit-tests/clib/unicode_tests.ml @@ -1,5 +1,7 @@ open Utest +let log_out_ch = open_log_out_ch __FILE__ + let unicode0 = mk_eq_test "clib-unicode0" "split_at_first_letter, first letter is character" None @@ -12,4 +14,4 @@ let unicode1 = mk_eq_test "clib-unicode1" let tests = [ unicode0; unicode1 ] -let _ = run_tests __FILE__ tests +let _ = run_tests __FILE__ log_out_ch tests diff --git a/test-suite/unit-tests/printing/proof_diffs_test.ml b/test-suite/unit-tests/printing/proof_diffs_test.ml new file mode 100644 index 0000000000..526cefec44 --- /dev/null +++ b/test-suite/unit-tests/printing/proof_diffs_test.ml @@ -0,0 +1,333 @@ +open OUnit +open Utest +open Pp_diff +open Proof_diffs + +let tokenize_string = Proof_diffs.tokenize_string +let diff_pp = diff_pp ~tokenize_string +let diff_str = diff_str ~tokenize_string + +let tests = ref [] +let add_test name test = tests := (mk_test name (TestCase test)) :: !tests + +let log_out_ch = open_log_out_ch __FILE__ +let cfprintf oc = Printf.(kfprintf (fun oc -> fprintf oc "") oc) +let cprintf s = cfprintf log_out_ch s +let _ = Proof_diffs.log_out_ch := log_out_ch + +let string_of_string s : string = "\"" ^ s ^ "\"" + +(* todo: OCaml: why can't the body of the test function be given in the add_test line? *) + +let t () = + let expected : diff_list = [] in + let diffs = diff_str "" " " in + + assert_equal ~msg:"empty" ~printer:string_of_diffs expected diffs; + let (has_added, has_removed) = has_changes diffs in + assert_equal ~msg:"has `Added" ~printer:string_of_bool false has_added; + assert_equal ~msg:"has `Removed" ~printer:string_of_bool false has_removed +let _ = add_test "diff_str empty" t + + +let t () = + let expected : diff_list = + [ `Common (0, 0, "a"); `Common (1, 1, "b"); `Common (2, 2, "c")] in + let diffs = diff_str "a b c" " a b\t c\n" in + + assert_equal ~msg:"white space" ~printer:string_of_diffs expected diffs; + let (has_added, has_removed) = has_changes diffs in + assert_equal ~msg:"no `Added" ~printer:string_of_bool false has_added; + assert_equal ~msg:"no `Removed" ~printer:string_of_bool false has_removed +let _ = add_test "diff_str white space" t + +let t () = + let expected : diff_list = [ `Removed (0, "a"); `Added (0, "b")] in + let diffs = diff_str "a" "b" in + + assert_equal ~msg:"add/remove" ~printer:string_of_diffs expected diffs; + let (has_added, has_removed) = has_changes diffs in + assert_equal ~msg:"has `Added" ~printer:string_of_bool true has_added; + assert_equal ~msg:"has `Removed" ~printer:string_of_bool true has_removed +let _ = add_test "diff_str add/remove" t + +(* example of a limitation, not really a test *) +let t () = + try + let _ = diff_str "a" ">" in + assert_failure "unlexable string gives an exception" + with _ -> () +let _ = add_test "diff_str unlexable" t + +(* problematic examples for tokenize_string: + comments omitted + quoted string loses quote marks (are escapes supported/handled?) + char constant split into 2 + *) +let t () = + List.iter (fun x -> cprintf "'%s' " x) (tokenize_string "(* comment *) \"string\" 'c' xx"); + cprintf "\n" +let _ = add_test "tokenize_string examples" t + +open Pp + +(* note pp_to_string concatenates adjacent strings, could become one token, +e.g. str " a" ++ str "b " will give a token "ab" *) +(* checks background is present and correct *) +let t () = + let o_pp = str "a" ++ str "!" ++ str "c" in + let n_pp = str "a" ++ str "?" ++ str "c" in + let (o_exp, n_exp) = (wrap_in_bg "diff.removed" (str "a" ++ (tag "diff.removed" (str "!")) ++ str "c"), + wrap_in_bg "diff.added" (str "a" ++ (tag "diff.added" (str "?")) ++ str "c")) in + let (o_diff, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"removed" ~printer:db_string_of_pp o_exp o_diff; + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp n_diff +let _ = add_test "diff_pp/add_diff_tags add/remove" t + +let t () = + (*Printf.printf "%s\n" (string_of_diffs (diff_str "a d" "a b c d"));*) + let o_pp = str "a" ++ str " d" in + let n_pp = str "a" ++ str " b " ++ str " c " ++ str "d" ++ str " e " in + let n_exp = flatten (wrap_in_bg "diff.added" (seq [ + str "a"; + str " "; (tag "start.diff.added" (str "b ")); + (tag "end.diff.added" (str " c")); str " "; + (str "d"); + str " "; (tag "diff.added" (str "e")); str " " + ])) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff);; +let _ = add_test "diff_pp/add_diff_tags a span with spaces" t + + +let t () = + let o_pp = str " " in + let n_pp = tag "sometag" (str "a") in + let n_exp = flatten (wrap_in_bg "diff.added" (tag "diff.added" (tag "sometag" (str "a")))) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = add_test "diff_pp/add_diff_tags diff tags outside existing tags" t + +let t () = + let o_pp = str " " in + let n_pp = seq [(tag "sometag" (str " a ")); str "b"] in + let n_exp = flatten (wrap_in_bg "diff.added" + (seq [tag "sometag" (str " "); (tag "start.diff.added" (tag "sometag" (str "a "))); + (tag "end.diff.added" (str "b"))]) ) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = add_test "diff_pp/add_diff_tags existing tagged values with spaces" t + +let t () = + let o_pp = str " " in + let n_pp = str " a b " in + let n_exp = flatten (wrap_in_bg "diff.added" + (seq [str " "; tag "diff.added" (str "a b"); str " "])) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = add_test "diff_pp/add_diff_tags multiple tokens in pp" t + +let t () = + let o_pp = str "a d" in + let n_pp = seq [str "a b"; str "c d"] in + let n_exp = flatten (wrap_in_bg "diff.added" + (seq [str "a "; tag "start.diff.added" (str "b"); + tag "end.diff.added" (str "c"); str " d"])) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = add_test "diff_pp/add_diff_tags token spanning multiple Ppcmd_strs" t + +let t () = + let o_pp = seq [str ""; str "a"] in + let n_pp = seq [str ""; str "a b"] in + let n_exp = flatten (wrap_in_bg "diff.added" + (seq [str ""; str "a "; tag "diff.added" (str "b")])) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = add_test "diff_pp/add_diff_tags empty string preserved" t + +(* todo: awaiting a change in the lexer to return the quotes of the string token *) +let t () = + let s = "\"a b\"" in + let o_pp = seq [str s] in + let n_pp = seq [str "\"a b\" "] in + cprintf "ppcmds: %s\n" (string_of_ppcmds n_pp); + let n_exp = flatten (wrap_in_bg "diff.added" + (seq [str ""; str "a "; tag "diff.added" (str "b")])) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"string" ~printer:string_of_string "a b" (List.hd (tokenize_string s)); + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = if false then add_test "diff_pp/add_diff_tags token containing white space" t + +let add_entries map idents rhs_pp = + let make_entry() = { idents; rhs_pp; done_ = false } in + List.iter (fun ident -> map := (StringMap.add ident (make_entry ()) !map); ()) idents;; + +let print_list hyps = List.iter (fun x -> cprintf "%s\n" (string_of_ppcmds (flatten x))) hyps +let db_print_list hyps = List.iter (fun x -> cprintf "%s\n" (db_string_of_pp (flatten x))) hyps + + +(* a : foo + b : bar car -> + b : car + a : foo bar *) +let t () = + write_diffs_option "removed"; (* turn on "removed" option *) + let o_line_idents = [ ["a"]; ["b"]] in + let o_hyp_map = ref StringMap.empty in + add_entries o_hyp_map ["a"] (str " : foo"); + add_entries o_hyp_map ["b"] (str " : bar car"); + let n_line_idents = [ ["b"]; ["a"]] in + let n_hyp_map = ref StringMap.empty in + add_entries n_hyp_map ["b"] (str " : car"); + add_entries n_hyp_map ["a"] (str " : foo bar"); + let expected = [flatten (wrap_in_bg "diff.removed" (seq [str "b"; str " : "; (tag "diff.removed" (str "bar")); str " car" ])); + flatten (wrap_in_bg "diff.added" (seq [str "b"; str " : car" ])); + flatten (wrap_in_bg "diff.added" (seq [str "a"; str " : foo "; (tag "diff.added" (str "bar")) ])) + ] in + + let hyps_diff_list = diff_hyps o_line_idents !o_hyp_map n_line_idents !n_hyp_map in + + (*print_list hyps_diff_list;*) + (*db_print_list hyps_diff_list;*) + + List.iter2 (fun exp act -> + assert_equal ~msg:"added" ~printer:db_string_of_pp exp (flatten act)) + expected hyps_diff_list +let _ = add_test "diff_hyps simple diffs" t + +(* a : nat + c, d : int -> + a, b : nat + d : int + and keeps old order *) +let t () = + write_diffs_option "removed"; (* turn on "removed" option *) + let o_line_idents = [ ["a"]; ["c"; "d"]] in + let o_hyp_map = ref StringMap.empty in + add_entries o_hyp_map ["a"] (str " : nat"); + add_entries o_hyp_map ["c"; "d"] (str " : int"); + let n_line_idents = [ ["a"; "b"]; ["d"]] in + let n_hyp_map = ref StringMap.empty in + add_entries n_hyp_map ["a"; "b"] (str " : nat"); + add_entries n_hyp_map ["d"] (str " : int"); + let expected = [flatten (wrap_in_bg "diff.added" (seq [str "a"; (tag "start.diff.added" (str ", ")); (tag "end.diff.added" (str "b")); str " : nat" ])); + flatten (wrap_in_bg "diff.removed" (seq [(tag "start.diff.removed" (str "c")); (tag "end.diff.removed" (str ",")); str " "; str "d"; str " : int" ])); + flatten (wrap_in_bg "diff.added" (seq [str "d"; str " : int" ])) + ] in + + let hyps_diff_list = diff_hyps o_line_idents !o_hyp_map n_line_idents !n_hyp_map in + + (*print_list hyps_diff_list;*) + (*print_list expected;*) + + (*db_print_list hyps_diff_list;*) + (*db_print_list expected;*) + + List.iter2 (fun exp act -> + assert_equal ~msg:"added" ~printer:db_string_of_pp exp (flatten act)) + expected hyps_diff_list +let _ = add_test "diff_hyps compacted" t + +(* a : foo + b : bar + c : nat -> + b, a, c : nat +DIFFS + b : bar (remove bar) + b : nat (add nat) + a : foo (remove foo) + a : nat (add nat) + c : nat + is this a realistic use case? +*) +let t () = + write_diffs_option "removed"; (* turn on "removed" option *) + let o_line_idents = [ ["a"]; ["b"]; ["c"]] in + let o_hyp_map = ref StringMap.empty in + add_entries o_hyp_map ["a"] (str " : foo"); + add_entries o_hyp_map ["b"] (str " : bar"); + add_entries o_hyp_map ["c"] (str " : nat"); + let n_line_idents = [ ["b"; "a"; "c"] ] in + let n_hyp_map = ref StringMap.empty in + add_entries n_hyp_map ["b"; "a"; "c"] (str " : nat"); + let expected = [flatten (wrap_in_bg "diff.removed" (seq [str "b"; str " : "; (tag "diff.removed" (str "bar"))])); + flatten (wrap_in_bg "diff.added" (seq [str "b"; str " : "; (tag "diff.added" (str "nat"))])); + flatten (wrap_in_bg "diff.removed" (seq [str "a"; str " : "; (tag "diff.removed" (str "foo"))])); + flatten (wrap_in_bg "diff.added" (seq [str "a"; str " : "; (tag "diff.added" (str "nat"))])); + flatten (seq [str "c"; str " : nat"]) + ] in + + let hyps_diff_list = diff_hyps o_line_idents !o_hyp_map n_line_idents !n_hyp_map in + + (*print_list hyps_diff_list;*) + (*db_print_list hyps_diff_list;*) + + List.iter2 (fun exp act -> + assert_equal ~msg:"added" ~printer:db_string_of_pp exp (flatten act)) + expected hyps_diff_list +let _ = add_test "diff_hyps compacted with join" t + +(* b, a, c : nat -> + a : foo + b : bar + c : nat +DIFFS + a : nat (remove nat) + a : foo (add foo) + b : nat (remove nat) + b : bar (add bar) + c : nat + is this a realistic use case? *) +let t () = + write_diffs_option "removed"; (* turn on "removed" option *) + let o_line_idents = [ ["b"; "a"; "c"] ] in + let o_hyp_map = ref StringMap.empty in + add_entries o_hyp_map ["b"; "a"; "c"] (str " : nat"); + let n_line_idents = [ ["a"]; ["b"]; ["c"]] in + let n_hyp_map = ref StringMap.empty in + add_entries n_hyp_map ["a"] (str " : foo"); + add_entries n_hyp_map ["b"] (str " : bar"); + add_entries n_hyp_map ["c"] (str " : nat"); + let expected = [flatten (wrap_in_bg "diff.removed" (seq [str "a"; str " : "; (tag "diff.removed" (str "nat"))])); + flatten (wrap_in_bg "diff.added" (seq [str "a"; str " : "; (tag "diff.added" (str "foo"))])); + flatten (wrap_in_bg "diff.removed" (seq [str "b"; str " : "; (tag "diff.removed" (str "nat"))])); + flatten (wrap_in_bg "diff.added" (seq [str "b"; str " : "; (tag "diff.added" (str "bar"))])); + flatten (seq [str "c"; str " : nat"]) + ] in + + let hyps_diff_list = diff_hyps o_line_idents !o_hyp_map n_line_idents !n_hyp_map in + + (*print_list hyps_diff_list;*) + (*db_print_list hyps_diff_list;*) + + List.iter2 (fun exp act -> + assert_equal ~msg:"added" ~printer:db_string_of_pp exp (flatten act)) + expected hyps_diff_list +let _ = add_test "diff_hyps compacted with split" t + + +(* other potential tests +coqtop/terminal formatting BLOCKED: CAN'T GET TAGS IN FORMATTER + white space at end of line + spanning diffs +shorten_diff_span + +MAYBE NOT WORTH IT +diff_pp/add_diff_tags + add/remove - show it preserves, recurs and processes: + nested in boxes + breaks, etc. preserved +diff_pp_combined with/without removed +*) + + +let _ = run_tests __FILE__ log_out_ch (List.rev !tests) diff --git a/test-suite/unit-tests/src/utest.ml b/test-suite/unit-tests/src/utest.ml index 069e6a4bf3..0cb1780ec9 100644 --- a/test-suite/unit-tests/src/utest.ml +++ b/test-suite/unit-tests/src/utest.ml @@ -42,10 +42,12 @@ let run_one logit test = let results = perform_test (fun _ -> ()) test in process_results results -(* run list of OUnit test cases, log results *) -let run_tests ml_fn tests = +let open_log_out_ch ml_fn = let log_fn = ml_fn ^ ".log" in - let out_ch = open_out log_fn in + open_out log_fn + +(* run list of OUnit test cases, log results *) +let run_tests ml_fn out_ch tests = let cprintf s = cfprintf out_ch s in let ceprintf s = cfprintf stderr s in let logit = logger out_ch in diff --git a/test-suite/unit-tests/src/utest.mli b/test-suite/unit-tests/src/utest.mli index 70928228bf..2e0f26e96b 100644 --- a/test-suite/unit-tests/src/utest.mli +++ b/test-suite/unit-tests/src/utest.mli @@ -9,4 +9,10 @@ val mk_bool_test : string -> string -> bool -> OUnit.test (* the string argument should be the name of the .ml file containing the tests; use __FILE__ for that purpose. *) -val run_tests : string -> OUnit.test list -> unit +val run_tests : string -> out_channel -> OUnit.test list -> unit + +(** open output channel for the test log file *) +(* the string argument should be the name of the .ml file + containing the tests; use __FILE__ for that purpose. + *) +val open_log_out_ch : string -> out_channel diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index edf78ed52d..66a82008d8 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -814,3 +814,10 @@ Defined. (** Reciprocally, from a decidability, we could state a [reflect] as soon as we have a [bool_of_sumbool]. *) + +(** For instance, we could state the correctness of [Bool.eqb] via [reflect]: *) + +Lemma eqb_spec (b b' : bool) : reflect (b = b') (eqb b b'). +Proof. + destruct b, b'; now constructor. +Qed. diff --git a/theories/Numbers/DecimalString.v b/theories/Numbers/DecimalString.v index 1a3220f63a..591024baec 100644 --- a/theories/Numbers/DecimalString.v +++ b/theories/Numbers/DecimalString.v @@ -94,7 +94,7 @@ Definition int_of_string s := match s with | EmptyString => Some (Pos Nil) | String a s' => - if ascii_dec a "-" then option_map Neg (uint_of_string s') + if Ascii.eqb a "-" then option_map Neg (uint_of_string s') else option_map Pos (uint_of_string s) end. @@ -131,8 +131,8 @@ Proof. - unfold int_of_string. destruct (string_of_uint d) eqn:Hd. + now destruct d. - + destruct ascii_dec; subst. - * now destruct d. + + case Ascii.eqb_spec. + * intros ->. now destruct d. * rewrite <- Hd, usu; auto. - rewrite usu; auto. Qed. @@ -141,8 +141,8 @@ Lemma sis s d : int_of_string s = Some d -> string_of_int d = s. Proof. destruct s; [intros [= <-]| ]; simpl; trivial. - destruct ascii_dec; subst; simpl. - - destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + case Ascii.eqb_spec. + - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. simpl; f_equal. now apply sus. - destruct d; [ | now destruct uint_of_char]. simpl string_of_int. @@ -178,7 +178,7 @@ Definition int_of_string s := match s with | EmptyString => None | String a s' => - if ascii_dec a "-" then option_map Neg (uint_of_string s') + if Ascii.eqb a "-" then option_map Neg (uint_of_string s') else option_map Pos (uint_of_string s) end. @@ -228,8 +228,8 @@ Proof. unfold int_of_string. destruct (string_of_uint d) eqn:Hd. + now destruct d. - + destruct ascii_dec; subst. - * now destruct d. + + case Ascii.eqb_spec. + * intros ->. now destruct d. * rewrite <- Hd, usu; auto. now intros ->. - intros _ H. rewrite usu; auto. now intros ->. @@ -253,8 +253,8 @@ Lemma sis s d : int_of_string s = Some d -> string_of_int d = s. Proof. destruct s; [intros [=]| ]; simpl. - destruct ascii_dec; subst; simpl. - - destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + case Ascii.eqb_spec. + - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. simpl; f_equal. now apply sus. - destruct d; [ | now destruct uint_of_char]. simpl string_of_int. diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 5154b75b3f..31a7fb8ad6 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -40,6 +40,40 @@ Proof. decide equality; apply bool_dec. Defined. +Local Open Scope lazy_bool_scope. + +Definition eqb (a b : ascii) : bool := + match a, b with + | Ascii a0 a1 a2 a3 a4 a5 a6 a7, + Ascii b0 b1 b2 b3 b4 b5 b6 b7 => + Bool.eqb a0 b0 &&& Bool.eqb a1 b1 &&& Bool.eqb a2 b2 &&& Bool.eqb a3 b3 + &&& Bool.eqb a4 b4 &&& Bool.eqb a5 b5 &&& Bool.eqb a6 b6 &&& Bool.eqb a7 b7 + end. + +Infix "=?" := eqb : char_scope. + +Lemma eqb_spec (a b : ascii) : reflect (a = b) (a =? b)%char. +Proof. + destruct a, b; simpl. + do 8 (case Bool.eqb_spec; [ intros -> | constructor; now intros [= ] ]). + now constructor. +Qed. + +Local Ltac t_eqb := + repeat first [ congruence + | progress subst + | apply conj + | match goal with + | [ |- context[eqb ?x ?y] ] => destruct (eqb_spec x y) + end + | intro ]. +Lemma eqb_refl x : (x =? x)%char = true. Proof. t_eqb. Qed. +Lemma eqb_sym x y : (x =? y)%char = (y =? x)%char. Proof. t_eqb. Qed. +Lemma eqb_eq n m : (n =? m)%char = true <-> n = m. Proof. t_eqb. Qed. +Lemma eqb_neq x y : (x =? y)%char = false <-> x <> y. Proof. t_eqb. Qed. +Lemma eqb_compat: Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) eqb. +Proof. t_eqb. Qed. + (** * Conversion between natural numbers modulo 256 and ascii characters *) (** Auxiliary function that turns a positive into an ascii by diff --git a/theories/Strings/BinaryString.v b/theories/Strings/BinaryString.v new file mode 100644 index 0000000000..6df0a9170a --- /dev/null +++ b/theories/Strings/BinaryString.v @@ -0,0 +1,147 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +Require Import Ascii String. +Require Import BinNums. +Import BinNatDef. +Import BinIntDef. +Import BinPosDef. + +Local Open Scope positive_scope. +Local Open Scope string_scope. + +Definition ascii_to_digit (ch : ascii) : option N + := (if ascii_dec ch "0" then Some 0 + else if ascii_dec ch "1" then Some 1 + else None)%N. + +Fixpoint pos_bin_app (p q:positive) : positive := + match q with + | q~0 => (pos_bin_app p q)~0 + | q~1 => (pos_bin_app p q)~1 + | 1 => p~1 + end. + +Module Raw. + Fixpoint of_pos (p : positive) (rest : string) : string + := match p with + | 1 => String "1" rest + | p'~0 => of_pos p' (String "0" rest) + | p'~1 => of_pos p' (String "1" rest) + end. + + Fixpoint to_N (s : string) (rest : N) + : N + := match s with + | "" => rest + | String ch s' + => to_N + s' + match ascii_to_digit ch with + | Some v => N.add v (N.double rest) + | None => N0 + end + end. + + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + : to_N (of_pos p rest) base + = to_N rest match base with + | N0 => N.pos p + | Npos v => Npos (pos_bin_app v p) + end. + Proof. + destruct p as [p|p|]; destruct base; try reflexivity; + cbn; rewrite to_N_of_pos; reflexivity. + Qed. +End Raw. + +Definition of_pos (p : positive) : string + := String "0" (String "b" (Raw.of_pos p "")). +Definition of_N (n : N) : string + := match n with + | N0 => "0b0" + | Npos p => of_pos p + end. +Definition of_Z (z : Z) : string + := match z with + | Zneg p => String "-" (of_pos p) + | Z0 => "0b0" + | Zpos p => of_pos p + end. +Definition of_nat (n : nat) : string + := of_N (N.of_nat n). + +Definition to_N (s : string) : N + := match s with + | String s0 (String sb s) + => if ascii_dec s0 "0" + then if ascii_dec sb "b" + then Raw.to_N s N0 + else N0 + else N0 + | _ => N0 + end. +Definition to_pos (s : string) : positive + := match to_N s with + | N0 => 1 + | Npos p => p + end. +Definition to_Z (s : string) : Z + := let '(is_neg, n) := match s with + | String s0 s' + => if ascii_dec s0 "-" + then (true, to_N s') + else (false, to_N s) + | EmptyString => (false, to_N s) + end in + match n with + | N0 => Z0 + | Npos p => if is_neg then Zneg p else Zpos p + end. +Definition to_nat (s : string) : nat + := N.to_nat (to_N s). + +Lemma to_N_of_N (n : N) + : to_N (of_N n) + = n. +Proof. + destruct n; [ reflexivity | apply Raw.to_N_of_pos ]. +Qed. + +Lemma Z_of_of_Z (z : Z) + : to_Z (of_Z z) + = z. +Proof. + cbv [of_Z to_Z]; destruct z as [|z|z]; cbn; + try reflexivity; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Lemma to_nat_of_nat (n : nat) + : to_nat (of_nat n) + = n. +Proof. + cbv [to_nat of_nat]; + rewrite to_N_of_N, Nnat.Nat2N.id; reflexivity. +Qed. + +Lemma to_pos_of_pos (p : positive) + : to_pos (of_pos p) + = p. +Proof. + cbv [of_pos to_pos to_N]; cbn; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Example of_pos_1 : of_pos 1 = "0b1" := eq_refl. +Example of_pos_2 : of_pos 2 = "0b10" := eq_refl. +Example of_pos_3 : of_pos 3 = "0b11" := eq_refl. +Example of_N_0 : of_N 0 = "0b0" := eq_refl. +Example of_Z_0 : of_Z 0 = "0b0" := eq_refl. +Example of_Z_m1 : of_Z (-1) = "-0b1" := eq_refl. +Example of_nat_0 : of_nat 0 = "0b0" := eq_refl. diff --git a/theories/Strings/HexString.v b/theories/Strings/HexString.v new file mode 100644 index 0000000000..9ea93c909e --- /dev/null +++ b/theories/Strings/HexString.v @@ -0,0 +1,229 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +Require Import Ascii String. +Require Import BinNums. +Import BinNatDef. +Import BinIntDef. +Import BinPosDef. + +Local Open Scope positive_scope. +Local Open Scope string_scope. + +Local Notation "a || b" + := (if a then true else if b then true else false). +Definition ascii_to_digit (ch : ascii) : option N + := (if ascii_dec ch "0" then Some 0 + else if ascii_dec ch "1" then Some 1 + else if ascii_dec ch "2" then Some 2 + else if ascii_dec ch "3" then Some 3 + else if ascii_dec ch "4" then Some 4 + else if ascii_dec ch "5" then Some 5 + else if ascii_dec ch "6" then Some 6 + else if ascii_dec ch "7" then Some 7 + else if ascii_dec ch "8" then Some 8 + else if ascii_dec ch "9" then Some 9 + else if ascii_dec ch "a" || ascii_dec ch "A" then Some 10 + else if ascii_dec ch "b" || ascii_dec ch "B" then Some 11 + else if ascii_dec ch "c" || ascii_dec ch "C" then Some 12 + else if ascii_dec ch "d" || ascii_dec ch "D" then Some 13 + else if ascii_dec ch "e" || ascii_dec ch "E" then Some 14 + else if ascii_dec ch "f" || ascii_dec ch "F" then Some 15 + else None)%N. + +Fixpoint pos_hex_app (p q:positive) : positive := + match q with + | 1 => p~0~0~0~1 + | 2 => p~0~0~1~0 + | 3 => p~0~0~1~1 + | 4 => p~0~1~0~0 + | 5 => p~0~1~0~1 + | 6 => p~0~1~1~0 + | 7 => p~0~1~1~1 + | 8 => p~1~0~0~0 + | 9 => p~1~0~0~1 + | 10 => p~1~0~1~0 + | 11 => p~1~0~1~1 + | 12 => p~1~1~0~0 + | 13 => p~1~1~0~1 + | 14 => p~1~1~1~0 + | 15 => p~1~1~1~1 + | q~0~0~0~0 => (pos_hex_app p q)~0~0~0~0 + | q~0~0~0~1 => (pos_hex_app p q)~0~0~0~1 + | q~0~0~1~0 => (pos_hex_app p q)~0~0~1~0 + | q~0~0~1~1 => (pos_hex_app p q)~0~0~1~1 + | q~0~1~0~0 => (pos_hex_app p q)~0~1~0~0 + | q~0~1~0~1 => (pos_hex_app p q)~0~1~0~1 + | q~0~1~1~0 => (pos_hex_app p q)~0~1~1~0 + | q~0~1~1~1 => (pos_hex_app p q)~0~1~1~1 + | q~1~0~0~0 => (pos_hex_app p q)~1~0~0~0 + | q~1~0~0~1 => (pos_hex_app p q)~1~0~0~1 + | q~1~0~1~0 => (pos_hex_app p q)~1~0~1~0 + | q~1~0~1~1 => (pos_hex_app p q)~1~0~1~1 + | q~1~1~0~0 => (pos_hex_app p q)~1~1~0~0 + | q~1~1~0~1 => (pos_hex_app p q)~1~1~0~1 + | q~1~1~1~0 => (pos_hex_app p q)~1~1~1~0 + | q~1~1~1~1 => (pos_hex_app p q)~1~1~1~1 + end. + +Module Raw. + Fixpoint of_pos (p : positive) (rest : string) : string + := match p with + | 1 => String "1" rest + | 2 => String "2" rest + | 3 => String "3" rest + | 4 => String "4" rest + | 5 => String "5" rest + | 6 => String "6" rest + | 7 => String "7" rest + | 8 => String "8" rest + | 9 => String "9" rest + | 10 => String "a" rest + | 11 => String "b" rest + | 12 => String "c" rest + | 13 => String "d" rest + | 14 => String "e" rest + | 15 => String "f" rest + | p'~0~0~0~0 => of_pos p' (String "0" rest) + | p'~0~0~0~1 => of_pos p' (String "1" rest) + | p'~0~0~1~0 => of_pos p' (String "2" rest) + | p'~0~0~1~1 => of_pos p' (String "3" rest) + | p'~0~1~0~0 => of_pos p' (String "4" rest) + | p'~0~1~0~1 => of_pos p' (String "5" rest) + | p'~0~1~1~0 => of_pos p' (String "6" rest) + | p'~0~1~1~1 => of_pos p' (String "7" rest) + | p'~1~0~0~0 => of_pos p' (String "8" rest) + | p'~1~0~0~1 => of_pos p' (String "9" rest) + | p'~1~0~1~0 => of_pos p' (String "a" rest) + | p'~1~0~1~1 => of_pos p' (String "b" rest) + | p'~1~1~0~0 => of_pos p' (String "c" rest) + | p'~1~1~0~1 => of_pos p' (String "d" rest) + | p'~1~1~1~0 => of_pos p' (String "e" rest) + | p'~1~1~1~1 => of_pos p' (String "f" rest) + end. + + Fixpoint to_N (s : string) (rest : N) + : N + := match s with + | "" => rest + | String ch s' + => to_N + s' + match ascii_to_digit ch with + | Some v => N.add v (N.mul 16 rest) + | None => N0 + end + end. + + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + : to_N (of_pos p rest) base + = to_N rest match base with + | N0 => N.pos p + | Npos v => Npos (pos_hex_app v p) + end. + Proof. + do 4 try destruct p as [p|p|]; destruct base; try reflexivity; + cbn; rewrite to_N_of_pos; reflexivity. + Qed. +End Raw. + +Definition of_pos (p : positive) : string + := String "0" (String "x" (Raw.of_pos p "")). +Definition of_N (n : N) : string + := match n with + | N0 => "0x0" + | Npos p => of_pos p + end. +Definition of_Z (z : Z) : string + := match z with + | Zneg p => String "-" (of_pos p) + | Z0 => "0x0" + | Zpos p => of_pos p + end. +Definition of_nat (n : nat) : string + := of_N (N.of_nat n). + +Definition to_N (s : string) : N + := match s with + | String s0 (String so s) + => if ascii_dec s0 "0" + then if ascii_dec so "x" + then Raw.to_N s N0 + else N0 + else N0 + | _ => N0 + end. +Definition to_pos (s : string) : positive + := match to_N s with + | N0 => 1 + | Npos p => p + end. +Definition to_Z (s : string) : Z + := let '(is_neg, n) := match s with + | String s0 s' + => if ascii_dec s0 "-" + then (true, to_N s') + else (false, to_N s) + | EmptyString => (false, to_N s) + end in + match n with + | N0 => Z0 + | Npos p => if is_neg then Zneg p else Zpos p + end. +Definition to_nat (s : string) : nat + := N.to_nat (to_N s). + +Lemma to_N_of_N (n : N) + : to_N (of_N n) + = n. +Proof. + destruct n; [ reflexivity | apply Raw.to_N_of_pos ]. +Qed. + +Lemma to_Z_of_Z (z : Z) + : to_Z (of_Z z) + = z. +Proof. + cbv [of_Z to_Z]; destruct z as [|z|z]; cbn; + try reflexivity; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Lemma to_nat_of_nat (n : nat) + : to_nat (of_nat n) + = n. +Proof. + cbv [to_nat of_nat]; + rewrite to_N_of_N, Nnat.Nat2N.id; reflexivity. +Qed. + +Lemma to_pos_of_pos (p : positive) + : to_pos (of_pos p) + = p. +Proof. + cbv [of_pos to_pos to_N]; cbn; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Example of_pos_1 : of_pos 1 = "0x1" := eq_refl. +Example of_pos_2 : of_pos 2 = "0x2" := eq_refl. +Example of_pos_3 : of_pos 3 = "0x3" := eq_refl. +Example of_pos_7 : of_pos 7 = "0x7" := eq_refl. +Example of_pos_8 : of_pos 8 = "0x8" := eq_refl. +Example of_pos_9 : of_pos 9 = "0x9" := eq_refl. +Example of_pos_10 : of_pos 10 = "0xa" := eq_refl. +Example of_pos_11 : of_pos 11 = "0xb" := eq_refl. +Example of_pos_12 : of_pos 12 = "0xc" := eq_refl. +Example of_pos_13 : of_pos 13 = "0xd" := eq_refl. +Example of_pos_14 : of_pos 14 = "0xe" := eq_refl. +Example of_pos_15 : of_pos 15 = "0xf" := eq_refl. +Example of_pos_16 : of_pos 16 = "0x10" := eq_refl. +Example of_N_0 : of_N 0 = "0x0" := eq_refl. +Example of_Z_0 : of_Z 0 = "0x0" := eq_refl. +Example of_Z_m1 : of_Z (-1) = "-0x1" := eq_refl. +Example of_nat_0 : of_nat 0 = "0x0" := eq_refl. diff --git a/theories/Strings/OctalString.v b/theories/Strings/OctalString.v new file mode 100644 index 0000000000..fe8cc9aae9 --- /dev/null +++ b/theories/Strings/OctalString.v @@ -0,0 +1,179 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +Require Import Ascii String. +Require Import BinNums. +Import BinNatDef. +Import BinIntDef. +Import BinPosDef. + +Local Open Scope positive_scope. +Local Open Scope string_scope. + +Definition ascii_to_digit (ch : ascii) : option N + := (if ascii_dec ch "0" then Some 0 + else if ascii_dec ch "1" then Some 1 + else if ascii_dec ch "2" then Some 2 + else if ascii_dec ch "3" then Some 3 + else if ascii_dec ch "4" then Some 4 + else if ascii_dec ch "5" then Some 5 + else if ascii_dec ch "6" then Some 6 + else if ascii_dec ch "7" then Some 7 + else None)%N. + +Fixpoint pos_oct_app (p q:positive) : positive := + match q with + | 1 => p~0~0~1 + | 2 => p~0~1~0 + | 3 => p~0~1~1 + | 4 => p~1~0~0 + | 5 => p~1~0~1 + | 6 => p~1~1~0 + | 7 => p~1~1~1 + | q~0~0~0 => (pos_oct_app p q)~0~0~0 + | q~0~0~1 => (pos_oct_app p q)~0~0~1 + | q~0~1~0 => (pos_oct_app p q)~0~1~0 + | q~0~1~1 => (pos_oct_app p q)~0~1~1 + | q~1~0~0 => (pos_oct_app p q)~1~0~0 + | q~1~0~1 => (pos_oct_app p q)~1~0~1 + | q~1~1~0 => (pos_oct_app p q)~1~1~0 + | q~1~1~1 => (pos_oct_app p q)~1~1~1 + end. + +Module Raw. + Fixpoint of_pos (p : positive) (rest : string) : string + := match p with + | 1 => String "1" rest + | 2 => String "2" rest + | 3 => String "3" rest + | 4 => String "4" rest + | 5 => String "5" rest + | 6 => String "6" rest + | 7 => String "7" rest + | p'~0~0~0 => of_pos p' (String "0" rest) + | p'~0~0~1 => of_pos p' (String "1" rest) + | p'~0~1~0 => of_pos p' (String "2" rest) + | p'~0~1~1 => of_pos p' (String "3" rest) + | p'~1~0~0 => of_pos p' (String "4" rest) + | p'~1~0~1 => of_pos p' (String "5" rest) + | p'~1~1~0 => of_pos p' (String "6" rest) + | p'~1~1~1 => of_pos p' (String "7" rest) + end. + + Fixpoint to_N (s : string) (rest : N) + : N + := match s with + | "" => rest + | String ch s' + => to_N + s' + match ascii_to_digit ch with + | Some v => N.add v (N.mul 8 rest) + | None => N0 + end + end. + + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + : to_N (of_pos p rest) base + = to_N rest match base with + | N0 => N.pos p + | Npos v => Npos (pos_oct_app v p) + end. + Proof. + do 3 try destruct p as [p|p|]; destruct base; try reflexivity; + cbn; rewrite to_N_of_pos; reflexivity. + Qed. +End Raw. + +Definition of_pos (p : positive) : string + := String "0" (String "o" (Raw.of_pos p "")). +Definition of_N (n : N) : string + := match n with + | N0 => "0o0" + | Npos p => of_pos p + end. +Definition of_Z (z : Z) : string + := match z with + | Zneg p => String "-" (of_pos p) + | Z0 => "0o0" + | Zpos p => of_pos p + end. +Definition of_nat (n : nat) : string + := of_N (N.of_nat n). + +Definition to_N (s : string) : N + := match s with + | String s0 (String so s) + => if ascii_dec s0 "0" + then if ascii_dec so "o" + then Raw.to_N s N0 + else N0 + else N0 + | _ => N0 + end. +Definition to_pos (s : string) : positive + := match to_N s with + | N0 => 1 + | Npos p => p + end. +Definition to_Z (s : string) : Z + := let '(is_neg, n) := match s with + | String s0 s' + => if ascii_dec s0 "-" + then (true, to_N s') + else (false, to_N s) + | EmptyString => (false, to_N s) + end in + match n with + | N0 => Z0 + | Npos p => if is_neg then Zneg p else Zpos p + end. +Definition to_nat (s : string) : nat + := N.to_nat (to_N s). + +Lemma to_N_of_N (n : N) + : to_N (of_N n) + = n. +Proof. + destruct n; [ reflexivity | apply Raw.to_N_of_pos ]. +Qed. + +Lemma to_Z_of_Z (z : Z) + : to_Z (of_Z z) + = z. +Proof. + cbv [of_Z to_Z]; destruct z as [|z|z]; cbn; + try reflexivity; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Lemma to_nat_of_nat (n : nat) + : to_nat (of_nat n) + = n. +Proof. + cbv [to_nat of_nat]; + rewrite to_N_of_N, Nnat.Nat2N.id; reflexivity. +Qed. + +Lemma to_pos_of_pos (p : positive) + : to_pos (of_pos p) + = p. +Proof. + cbv [of_pos to_pos to_N]; cbn; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Example of_pos_1 : of_pos 1 = "0o1" := eq_refl. +Example of_pos_2 : of_pos 2 = "0o2" := eq_refl. +Example of_pos_3 : of_pos 3 = "0o3" := eq_refl. +Example of_pos_7 : of_pos 7 = "0o7" := eq_refl. +Example of_pos_8 : of_pos 8 = "0o10" := eq_refl. +Example of_N_0 : of_N 0 = "0o0" := eq_refl. +Example of_Z_0 : of_Z 0 = "0o0" := eq_refl. +Example of_Z_m1 : of_Z (-1) = "-0o1" := eq_refl. +Example of_nat_0 : of_nat 0 = "0o0" := eq_refl. diff --git a/theories/Strings/String.v b/theories/Strings/String.v index 2be6618ad6..be9a10c6dc 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -14,6 +14,7 @@ Require Import Arith. Require Import Ascii. +Require Import Bool. Declare ML Module "string_syntax_plugin". (** *** Definition of strings *) @@ -35,6 +36,39 @@ Proof. decide equality; apply ascii_dec. Defined. +Local Open Scope lazy_bool_scope. + +Fixpoint eqb s1 s2 : bool := + match s1, s2 with + | EmptyString, EmptyString => true + | String c1 s1', String c2 s2' => Ascii.eqb c1 c2 &&& eqb s1' s2' + | _,_ => false + end. + +Infix "=?" := eqb : string_scope. + +Lemma eqb_spec s1 s2 : Bool.reflect (s1 = s2) (s1 =? s2)%string. +Proof. + revert s2. induction s1; destruct s2; try (constructor; easy); simpl. + case Ascii.eqb_spec; simpl; [intros -> | constructor; now intros [= ]]. + case IHs1; [intros ->; now constructor | constructor; now intros [= ]]. +Qed. + +Local Ltac t_eqb := + repeat first [ congruence + | progress subst + | apply conj + | match goal with + | [ |- context[eqb ?x ?y] ] => destruct (eqb_spec x y) + end + | intro ]. +Lemma eqb_refl x : (x =? x)%string = true. Proof. t_eqb. Qed. +Lemma eqb_sym x y : (x =? y)%string = (y =? x)%string. Proof. t_eqb. Qed. +Lemma eqb_eq n m : (n =? m)%string = true <-> n = m. Proof. t_eqb. Qed. +Lemma eqb_neq x y : (x =? y)%string = false <-> x <> y. Proof. t_eqb. Qed. +Lemma eqb_compat: Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) eqb. +Proof. t_eqb. Qed. + (** *** Concatenation of strings *) Reserved Notation "x ++ y" (right associativity, at level 60). diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 89602c9b56..900964609d 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -68,6 +68,7 @@ type coq_cmdopts = { impredicative_set : Declarations.set_predicativity; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; + diffs_set : bool; time : bool; filter_opts : bool; @@ -117,6 +118,7 @@ let init_args = { impredicative_set = Declarations.PredicativeSet; stm_flags = Stm.AsyncOpts.default_opts; debug = false; + diffs_set = false; time = false; filter_opts = false; @@ -526,6 +528,12 @@ let parse_args arglist : coq_cmdopts * string list = |"-color" -> set_color oval (next ()) |"-config"|"--config" -> { oval with print_config = true } |"-debug" -> Coqinit.set_debug (); oval + |"-diffs" -> let opt = next () in + if List.exists (fun x -> opt = x) ["off"; "on"; "removed"] then + Proof_diffs.write_diffs_option opt + else + (prerr_endline ("Error: on|off|removed expected after -diffs"); exit 1); + { oval with diffs_set = true } |"-stm-debug" -> Stm.stm_debug := true; oval |"-emacs" -> set_emacs oval |"-filteropts" -> { oval with filter_opts = true } diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 9fb6219a61..7b0cdcf127 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -43,6 +43,7 @@ type coq_cmdopts = { impredicative_set : Declarations.set_predicativity; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; + diffs_set : bool; time : bool; filter_opts : bool; diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 7ae15ac100..7b7e1b16c0 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -318,12 +318,6 @@ let loop_flush_all () = Format.pp_print_flush !Topfmt.std_ft (); Format.pp_print_flush !Topfmt.err_ft () -let pr_open_cur_subgoals () = - try - let proof = Proof_global.give_me_the_proof () in - Printer.pr_open_subgoals ~proof - with Proof_global.NoCurrentProof -> Pp.str "" - (* Goal equality heuristic. *) let pequal cmp1 cmp2 (a1,a2) (b1,b2) = cmp1 a1 b1 && cmp2 a2 b2 let evleq e1 e2 = CList.equal Evar.equal e1 e2 @@ -346,7 +340,7 @@ let top_goal_print oldp newp = let proof_changed = not (Option.equal cproof oldp newp) in let print_goals = not !Flags.quiet && proof_changed && Proof_global.there_are_pending_proofs () in - if print_goals then Feedback.msg_notice (pr_open_cur_subgoals ()) + if print_goals then Printer.print_and_diff oldp newp; with | exn -> let (e, info) = CErrors.push exn in diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index e979d0e544..9b68f303a6 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -339,8 +339,8 @@ let do_vio opts = (******************************************************************************) (* Color Options *) (******************************************************************************) -let init_color color_mode = - let has_color = match color_mode with +let init_color opts = + let has_color = match opts.color with | `OFF -> false | `ON -> true | `AUTO -> @@ -350,26 +350,23 @@ let init_color color_mode = its TERM variable is set to "dumb". *) try Sys.getenv "TERM" <> "dumb" with Not_found -> false in - if has_color then begin - let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in - match colors with - | None -> - (** Default colors *) - Topfmt.default_styles (); - Topfmt.init_terminal_output ~color:true - | Some "" -> - (** No color output *) - Topfmt.init_terminal_output ~color:false - | Some s -> - (** Overwrite all colors *) - Topfmt.parse_color_config s; - Topfmt.init_terminal_output ~color:true - end - else - Topfmt.init_terminal_output ~color:false + let term_color = + if has_color then begin + let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in + match colors with + | None -> Topfmt.default_styles (); true (** Default colors *) + | Some "" -> false (** No color output *) + | Some s -> Topfmt.parse_color_config s; true (** Overwrite all colors *) + end + else + false + in + if Proof_diffs.show_diffs () && not term_color && not opts.batch_mode then + CErrors.user_err Pp.(str "Error: -diffs requires enabling -color"); + Topfmt.init_terminal_output ~color:term_color let print_style_tags opts = - let () = init_color opts.color in + let () = init_color opts in let tags = Topfmt.dump_tags () in let iter (t, st) = let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in @@ -520,7 +517,7 @@ type custom_toplevel = { } let coqtop_init ~opts extra = - init_color opts.color; + init_color opts; CoqworkmgrApi.(init !async_proofs_worker_priority); opts, extra diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 504ffa521b..d85fed5f43 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -72,7 +72,8 @@ let print_usage_channel co command = \n -boot boot mode (implies -q and -batch)\ \n -bt print backtraces (requires configure debug flag)\ \n -debug debug mode (implies -bt)\ -\n -stm-debug STM debug mode (will trace every transaction) \ +\n -diffs (on|off|removed) highlight differences between proof steps\ +\n -stm-debug STM debug mode (will trace every transaction)\ \n -emacs tells Coq it is executed under Emacs\ \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ diff --git a/vernac/class.ml b/vernac/class.ml index e425e6474d..614b2181d9 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -73,7 +73,7 @@ let check_reference_arity ref = let check_arity = function | CL_FUN | CL_SORT -> () | CL_CONST cst -> check_reference_arity (ConstRef cst) - | CL_PROJ cst -> check_reference_arity (ConstRef cst) + | CL_PROJ p -> check_reference_arity (ConstRef (Projection.Repr.constant p)) | CL_SECVAR id -> check_reference_arity (VarRef id) | CL_IND kn -> check_reference_arity (IndRef kn) @@ -92,8 +92,8 @@ let uniform_cond sigma ctx lt = let class_of_global = function | ConstRef sp -> - if Environ.is_projection sp (Global.env ()) - then CL_PROJ sp else CL_CONST sp + (match Recordops.find_primitive_projection sp with + | Some p -> CL_PROJ p | None -> CL_CONST sp) | IndRef sp -> CL_IND sp | VarRef id -> CL_SECVAR id | ConstructRef _ as c -> @@ -143,8 +143,8 @@ let get_target t ind = CL_FUN else match pi1 (find_class_type Evd.empty (EConstr.of_constr t)) with - | CL_CONST p when Environ.is_projection p (Global.env ()) -> - CL_PROJ p + | CL_CONST p when Recordops.is_primitive_projection p -> + CL_PROJ (Option.get @@ Recordops.find_primitive_projection p) | x -> x let strength_of_cl = function @@ -165,7 +165,8 @@ let get_strength stre ref cls clt = let ident_key_of_class = function | CL_FUN -> "Funclass" | CL_SORT -> "Sortclass" - | CL_CONST sp | CL_PROJ sp -> Label.to_string (Constant.label sp) + | CL_CONST sp -> Label.to_string (Constant.label sp) + | CL_PROJ sp -> Label.to_string (Projection.Repr.label sp) | CL_IND (sp,_) -> Label.to_string (MutInd.label sp) | CL_SECVAR id -> Id.to_string id diff --git a/vernac/egramml.ml b/vernac/egramml.ml index 048d4d93a0..c5dedc880e 100644 --- a/vernac/egramml.ml +++ b/vernac/egramml.ml @@ -64,6 +64,15 @@ let make_rule f prod = let act = ty_eval ty_rule f in Extend.Rule (symb, act) +let rec proj_symbol : type a b c. (a, b, c) ty_user_symbol -> (a, b, c) genarg_type = function +| TUentry a -> ExtraArg a +| TUentryl (a,l) -> ExtraArg a +| TUopt(o) -> OptArg (proj_symbol o) +| TUlist1 l -> ListArg (proj_symbol l) +| TUlist1sep (l,_) -> ListArg (proj_symbol l) +| TUlist0 l -> ListArg (proj_symbol l) +| TUlist0sep (l,_) -> ListArg (proj_symbol l) + (** Vernac grammar extensions *) let vernac_exts = ref [] diff --git a/vernac/egramml.mli b/vernac/egramml.mli index a5ee036db5..c4f4fcfaa4 100644 --- a/vernac/egramml.mli +++ b/vernac/egramml.mli @@ -26,6 +26,8 @@ val extend_vernac_command_grammar : val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_item list +val proj_symbol : ('a, 'b, 'c) Extend.ty_user_symbol -> ('a, 'b, 'c) Genarg.genarg_type + (** Utility function reused in Egramcoq : *) val make_rule : diff --git a/vernac/himsg.ml b/vernac/himsg.ml index c49ffe2679..b9c47ff475 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -194,12 +194,6 @@ let rec pr_disjunction pr = function | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l | [] -> assert false -let pr_puniverses f env (c,u) = - f env c ++ - (if Flags.is_universe_polymorphism () && not (Univ.Instance.is_empty u) then - str"(*" ++ Univ.Instance.pr UnivNames.pr_with_global_universes u ++ str"*)" - else mt()) - let explain_elim_arity env sigma ind sorts c pj okinds = let open EConstr in let env = make_all_name_different env sigma in @@ -262,7 +256,7 @@ let explain_ill_formed_branch env sigma c ci actty expty = let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++ spc () ++ strbrk "the branch for constructor" ++ spc () ++ - quote (pr_puniverses pr_constructor env ci) ++ + quote (pr_pconstructor env sigma ci) ++ spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++ str "which should be" ++ brk(1,1) ++ pe ++ str "." @@ -1233,12 +1227,7 @@ let explain_wrong_numarg_inductive env ind n = str " expects " ++ decline_string n "argument" ++ str "." let explain_unused_clause env pats = -(* Without localisation - let s = if List.length pats > 1 then "s" else "" in - (str ("Unused clause with pattern"^s) ++ spc () ++ - hov 0 (pr_sequence pr_cases_pattern pats) ++ str ")") -*) - str "This clause is redundant." + str "Pattern \"" ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats) ++ strbrk "\" is redundant in this clause." let explain_non_exhaustive env pats = str "Non exhaustive pattern-matching: no clause found for " ++ diff --git a/vernac/record.ml b/vernac/record.ml index 7a8ce7d25a..6b5c538df2 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -324,12 +324,16 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers u | Name fid -> try let kn, term = if is_local_assum decl && primitive then - (** Already defined in the kernel silently *) - let gr = Nametab.locate (Libnames.qualid_of_ident fid) in - let kn = destConstRef gr in + let p = Projection.Repr.make indsp + ~proj_npars:mib.mind_nparams + ~proj_arg:i + (Label.of_id fid) + in + (** Already defined by declare_mind silently *) + let kn = Projection.Repr.constant p in Declare.definition_message fid; - UnivNames.register_universe_binders gr ubinders; - kn, mkProj (Projection.make kn false,mkRel 1) + UnivNames.register_universe_binders (ConstRef kn) ubinders; + kn, mkProj (Projection.make p false,mkRel 1) else let ccl = subst_projection fid subst ti in let body = match decl with diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 609dac69aa..f842ca5ead 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -181,6 +181,10 @@ let default_tag_map () = let open Terminal in [ ; "tactic.keyword" , make ~bold:true () ; "tactic.primitive" , make ~fg_color:`LIGHT_GREEN () ; "tactic.string" , make ~fg_color:`LIGHT_RED () + ; "diff.added" , make ~bg_color:(`RGB(0,141,0)) ~underline:true () + ; "diff.removed" , make ~bg_color:(`RGB(170,0,0)) ~underline:true () + ; "diff.added.bg" , make ~bg_color:(`RGB(0,91,0)) () + ; "diff.removed.bg" , make ~bg_color:(`RGB(91,0,0)) () ] let tag_map = ref CString.Map.empty @@ -198,72 +202,103 @@ let parse_color_config file = let dump_tags () = CString.Map.bindings !tag_map +let empty = Terminal.make () +let default_style = Terminal.reset_style + +let get_style tag = + try CString.Map.find tag !tag_map + with Not_found -> empty;; + +let get_open_seq tags = + let style = List.fold_left (fun a b -> Terminal.merge a (get_style b)) default_style tags in + Terminal.eval (Terminal.diff default_style style);; + +let get_close_seq tags = + let style = List.fold_left (fun a b -> Terminal.merge a (get_style b)) default_style tags in + Terminal.eval (Terminal.diff style default_style);; + +let diff_tag_stack = ref [] (* global, just like std_ft *) + (** Not thread-safe. We should put a lock somewhere if we print from different threads. Do we? *) let make_style_stack () = (** Default tag is to reset everything *) - let empty = Terminal.make () in - let default_tag = Terminal.({ - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; - prefix = None; - suffix = None; - }) - in let style_stack = ref [] in let peek () = match !style_stack with - | [] -> default_tag (** Anomalous case, but for robustness *) + | [] -> default_style (** Anomalous case, but for robustness *) | st :: _ -> st in - let push tag = - let style = - try CString.Map.find tag !tag_map - with | Not_found -> empty - in - (** Use the merging of the latest tag and the one being currently pushed. - This may be useful if for instance the latest tag changes the background and - the current one the foreground, so that the two effects are additioned. *) + let open_tag tag = + let (tpfx, ttag) = split_tag tag in + if tpfx = end_pfx then "" else + let style = get_style ttag in + (** Merge the current settings and the style being pushed. This allows + restoring the previous settings correctly in a pop when both set the same + attribute. Example: current settings have red FG, the pushed style has + green FG. When popping the style, we should set red FG, not default FG. *) let style = Terminal.merge (peek ()) style in + let diff = Terminal.diff (peek ()) style in style_stack := style :: !style_stack; - Terminal.eval style + if tpfx = start_pfx then diff_tag_stack := ttag :: !diff_tag_stack; + Terminal.eval diff in - let pop _ = match !style_stack with - | [] -> (** Something went wrong, we fallback *) - Terminal.eval default_tag - | _ :: rem -> style_stack := rem; - Terminal.eval (peek ()) + let close_tag tag = + let (tpfx, _) = split_tag tag in + if tpfx = start_pfx then "" else begin + if tpfx = end_pfx then diff_tag_stack := (try List.tl !diff_tag_stack with tl -> []); + match !style_stack with + | [] -> (** Something went wrong, we fallback *) + Terminal.eval default_style + | cur :: rem -> style_stack := rem; + if cur = (peek ()) then "" else + if rem = [] then Terminal.reset else + Terminal.eval (Terminal.diff cur (peek ())) + end in let clear () = style_stack := [] in - push, pop, clear + open_tag, close_tag, clear let make_printing_functions () = - let empty = Terminal.make () in let print_prefix ft tag = - let style = - try CString.Map.find tag !tag_map - with | Not_found -> empty - in - match style.Terminal.prefix with Some s -> Format.pp_print_string ft s | None -> () - in + let (tpfx, ttag) = split_tag tag in + if tpfx <> end_pfx then + let style = get_style ttag in + match style.Terminal.prefix with Some s -> Format.pp_print_string ft s | None -> () in + let print_suffix ft tag = - let style = - try CString.Map.find tag !tag_map - with | Not_found -> empty - in - match style.Terminal.suffix with Some s -> Format.pp_print_string ft s | None -> () - in + let (tpfx, ttag) = split_tag tag in + if tpfx <> start_pfx then + let style = get_style ttag in + match style.Terminal.suffix with Some s -> Format.pp_print_string ft s | None -> () in + print_prefix, print_suffix +let init_output_fns () = + let reopen_highlight = ref "" in + let open Format in + let fns = Format.pp_get_formatter_out_functions !std_ft () in + let newline () = + if !diff_tag_stack <> [] then begin + let close = get_close_seq !diff_tag_stack in + fns.out_string close 0 (String.length close); + reopen_highlight := get_open_seq (List.rev !diff_tag_stack); + end; + fns.out_string "\n" 0 1 in + let string s off n = + if !reopen_highlight <> "" && String.trim (String.sub s off n) <> "" then begin + fns.out_string !reopen_highlight 0 (String.length !reopen_highlight); + reopen_highlight := "" + end; + fns.out_string s off n in + let new_fns = { fns with out_string = string; out_newline = newline } in + Format.pp_set_formatter_out_functions !std_ft new_fns;; + let init_terminal_output ~color = - let push_tag, pop_tag, clear_tag = make_style_stack () in + let open_tag, close_tag, clear_tag = make_style_stack () in let print_prefix, print_suffix = make_printing_functions () in let tag_handler ft = { - Format.mark_open_tag = push_tag; - Format.mark_close_tag = pop_tag; + Format.mark_open_tag = open_tag; + Format.mark_close_tag = close_tag; Format.print_open_tag = print_prefix ft; Format.print_close_tag = print_suffix ft; } in @@ -271,6 +306,7 @@ let init_terminal_output ~color = (* Use 0-length markers *) begin std_logger_cleanup := clear_tag; + init_output_fns (); Format.pp_set_mark_tags !std_ft true; Format.pp_set_mark_tags !err_ft true end diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index b6bc76a2ed..653f8b26e0 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -2436,3 +2436,121 @@ let interp ?verbosely ?proof ~st cmd = let exn = CErrors.push exn in Vernacstate.invalidate_cache (); iraise exn + +(** VERNAC EXTEND registering *) + +open Genarg +open Extend + +type classifier = Genarg.raw_generic_argument list -> vernac_classification + +type (_, _) ty_sig = +| TyNil : (atts:atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig +| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig +| TyNonTerminal : + string option * ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig + +type ty_ml = TyML : bool * ('r, 's) ty_sig * 'r * 's option -> ty_ml + +let type_error () = CErrors.anomaly (Pp.str "Ill-typed VERNAC EXTEND") + +let rec untype_classifier : type r s. (r, s) ty_sig -> s -> classifier = function +| TyNil -> fun f args -> + begin match args with + | [] -> f + | _ :: _ -> type_error () + end +| TyTerminal (_, ty) -> fun f args -> untype_classifier ty f args +| TyNonTerminal (_, tu, ty) -> fun f args -> + begin match args with + | [] -> type_error () + | Genarg.GenArg (Rawwit tag, v) :: args -> + match Genarg.genarg_type_eq tag (Egramml.proj_symbol tu) with + | None -> type_error () + | Some Refl -> untype_classifier ty (f v) args + end + +(** Stupid GADTs forces us to duplicate the definition just for typing *) +let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args vernac_command = function +| TyNil -> fun f args -> + begin match args with + | [] -> f + | _ :: _ -> type_error () + end +| TyTerminal (_, ty) -> fun f args -> untype_command ty f args +| TyNonTerminal (_, tu, ty) -> fun f args -> + begin match args with + | [] -> type_error () + | Genarg.GenArg (Rawwit tag, v) :: args -> + match Genarg.genarg_type_eq tag (Egramml.proj_symbol tu) with + | None -> type_error () + | Some Refl -> untype_command ty (f v) args + end + +let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, a) Extend.symbol = function +| TUlist1 l -> Alist1 (untype_user_symbol l) +| TUlist1sep (l, s) -> Alist1sep (untype_user_symbol l, Atoken (CLexer.terminal s)) +| TUlist0 l -> Alist0 (untype_user_symbol l) +| TUlist0sep (l, s) -> Alist0sep (untype_user_symbol l, Atoken (CLexer.terminal s)) +| TUopt o -> Aopt (untype_user_symbol o) +| TUentry a -> Aentry (Pcoq.genarg_grammar (ExtraArg a)) +| TUentryl (a, i) -> Aentryl (Pcoq.genarg_grammar (ExtraArg a), string_of_int i) + +let rec untype_grammar : type r s. (r, s) ty_sig -> vernac_expr Egramml.grammar_prod_item list = function +| TyNil -> [] +| TyTerminal (tok, ty) -> Egramml.GramTerminal tok :: untype_grammar ty +| TyNonTerminal (id, tu, ty) -> + let t = Option.map (fun _ -> rawwit (Egramml.proj_symbol tu)) id in + let symb = untype_user_symbol tu in + Egramml.GramNonTerminal (Loc.tag (t, symb)) :: untype_grammar ty + +let _ = untype_classifier, untype_command, untype_grammar, untype_user_symbol + +let classifiers : classifier array String.Map.t ref = ref String.Map.empty + +let get_vernac_classifier (name, i) args = + (String.Map.find name !classifiers).(i) args + +let declare_vernac_classifier name f = + classifiers := String.Map.add name f !classifiers + +let vernac_extend ~command ?classifier ?entry ext = + let get_classifier (TyML (_, ty, _, cl)) = match cl with + | Some cl -> untype_classifier ty cl + | None -> + match classifier with + | Some cl -> fun _ -> cl command + | None -> + let e = match entry with + | None -> "COMMAND" + | Some e -> Pcoq.Gram.Entry.name e + in + let msg = Printf.sprintf "\ + Vernac entry \"%s\" misses a classifier. \ + A classifier is a function that returns an expression \ + of type vernac_classification (see Vernacexpr). You can: \n\ + - Use '... EXTEND %s CLASSIFIED AS QUERY ...' if the \ + new vernacular command does not alter the system state;\n\ + - Use '... EXTEND %s CLASSIFIED AS SIDEFF ...' if the \ + new vernacular command alters the system state but not the \ + parser nor it starts a proof or ends one;\n\ + - Use '... EXTEND %s CLASSIFIED BY f ...' to specify \ + a global function f. The function f will be called passing\ + \"%s\" as the only argument;\n\ + - Add a specific classifier in each clause using the syntax:\n\ + '[...] => [ f ] -> [...]'.\n\ + Specific classifiers have precedence over global \ + classifiers. Only one classifier is called." + command e e e command + in + CErrors.user_err (Pp.strbrk msg) + in + let cl = Array.map_of_list get_classifier ext in + let iter i (TyML (depr, ty, f, _)) = + let f = untype_command ty f in + let r = untype_grammar ty in + let () = vinterp_add depr (command, i) f in + Egramml.extend_vernac_command_grammar (command, i) entry r + in + let () = declare_vernac_classifier command cl in + List.iteri iter ext diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 79f9c05ad8..fb2a30bac7 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -42,3 +42,33 @@ val universe_polymorphism_option_name : string list (** Elaborate a [atts] record out of a list of flags. Also returns whether polymorphism is explicitly (un)set. *) val attributes_of_flags : Vernacexpr.vernac_flags -> Vernacinterp.atts -> bool option * Vernacinterp.atts + +(** {5 VERNAC EXTEND} *) + +type classifier = Genarg.raw_generic_argument list -> Vernacexpr.vernac_classification + +type (_, _) ty_sig = +| TyNil : (atts:Vernacinterp.atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig +| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig +| TyNonTerminal : + string option * + ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> + ('a -> 'r, 'a -> 's) ty_sig + +type ty_ml = TyML : bool (** deprecated *) * ('r, 's) ty_sig * 'r * 's option -> ty_ml + +(** Wrapper to dynamically extend vernacular commands. *) +val vernac_extend : + command:string -> + ?classifier:(string -> Vernacexpr.vernac_classification) -> + ?entry:Vernacexpr.vernac_expr Pcoq.Entry.t -> + ty_ml list -> unit + +(** {5 STM classifiers} *) + +val get_vernac_classifier : + Vernacexpr.extend_name -> classifier + +(** Low-level API, not for casual user. *) +val declare_vernac_classifier : + string -> classifier array -> unit |