diff options
141 files changed, 8380 insertions, 7460 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f1dc793ee7..8880ec1d21 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,7 +18,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2020-03-11-V28" + CACHEKEY: "bionic_coq-V2020-03-13-V69" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -41,6 +41,7 @@ docker-boot: except: variables: - $SKIP_DOCKER == "true" + - $ONLY_WINDOWS == "true" tags: - docker @@ -62,6 +63,9 @@ before_script: # TODO figure out how to build doc for installed Coq .build-template: stage: stage-1 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true artifacts: name: "$CI_JOB_NAME" @@ -100,6 +104,9 @@ before_script: # Template for building Coq + stdlib, typical use: overload the switch .dune-template: stage: stage-1 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: [] script: @@ -124,6 +131,9 @@ before_script: .dune-ci-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true needs: - build:edge+flambda:dune:dev @@ -151,6 +161,9 @@ before_script: .doc-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: - not-a-real-job @@ -167,6 +180,9 @@ before_script: # set dependencies when using .test-suite-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: - not-a-real-job @@ -189,6 +205,9 @@ before_script: # set dependencies when using .validate-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: - not-a-real-job @@ -206,6 +225,9 @@ before_script: .ci-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true script: - set -e @@ -249,6 +271,9 @@ before_script: .deploy-template: stage: deploy + except: + variables: + - $ONLY_WINDOWS == "true" before_script: - which ssh-agent || ( apt-get update -y && apt-get install openssh-client -y ) - eval $(ssh-agent -s) @@ -350,6 +375,9 @@ pkg:opam: .nix-template: image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true stage: stage-1 variables: diff --git a/.ocamlformat b/.ocamlformat index 4480935e3b..62e609fb55 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.13.0 +version=0.14.0 profile=ocamlformat # to enable a whole directory, put "disable=false" in dir/.ocamlformat @@ -11,4 +11,4 @@ cases-exp-indent=2 field-space=loose exp-grouping=preserve break-cases=fit -doc-comments=before +doc-comments-val=before diff --git a/Makefile.dune b/Makefile.dune index 9e1747a4c3..b002c7709d 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -59,7 +59,7 @@ voboot: @echo "This target is empty and not needed anymore" states: - dune build --display=short $(DUNEOPT) dev/shim/coqtop-prelude + dune build $(DUNEOPT) dev/shim/coqtop-prelude NONDOC_INSTALL_TARGETS:=coq.install coqide-server.install coqide.install diff --git a/checker/check.ml b/checker/check.ml index bb3255338f..4212aac6ea 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -305,7 +305,7 @@ let marshal_in_segment ~validate ~value f ch = with _ -> user_err (str "Corrupted file " ++ quote (str f)) in - let () = Validate.validate ~debug:!Flags.debug value v in + let () = Validate.validate value v in let v = Analyze.instantiate v in Obj.obj v, stop, digest else diff --git a/checker/validate.ml b/checker/validate.ml index 66367cb002..20884c4d01 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -208,11 +208,10 @@ let print_frame = function | CtxField i -> Printf.sprintf "fld=%i" i | CtxTag i -> Printf.sprintf "tag=%i" i -let validate ~debug v (o, mem) = +let validate v (o, mem) = try val_gen v mem mt_ec o with ValidObjError(msg,ctx,obj) -> - (if debug then - let ctx = List.rev_map print_frame ctx in - print_endline ("Context: "^String.concat"/"ctx); - pr_obj mem obj); + let rctx = List.rev_map print_frame ctx in + print_endline ("Context: "^String.concat"/"rctx); + pr_obj mem obj; failwith ("Validation failed: "^msg^" (in "^(print_frame (List.hd ctx))^")") diff --git a/checker/validate.mli b/checker/validate.mli index 9ddc510e4a..1204b528f9 100644 --- a/checker/validate.mli +++ b/checker/validate.mli @@ -10,4 +10,4 @@ open Analyze -val validate : debug:bool -> Values.value -> data * obj LargeArray.t -> unit +val validate : Values.value -> data * obj LargeArray.t -> unit diff --git a/checker/values.ml b/checker/values.ml index 12f7135cdf..b9efce6948 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -372,6 +372,17 @@ let v_compiled_lib = let v_obj = Dyn +let v_globref = Sum("globref",0,[| + [|v_id|]; + [|v_cst|]; + [|v_ind|]; + [|v_cons|] + |]) + +let v_ext_gref = Sum("extended_global_reference",0,[|[|v_globref|];[|v_kn|]|]) + +let v_open_filter = Sum ("open_filter",1,[|[|v_hset v_ext_gref|]|]) + let rec v_aobjs = Sum("algebraic_objects", 0, [| [|v_libobjs|]; [|v_mp;v_subst|] @@ -383,7 +394,7 @@ and v_libobjt = Sum("Libobject.t",0, [| v_substobjs |]; [| v_aobjs |]; [| v_libobjs |]; - [| List v_mp |]; + [| List (v_pair v_open_filter v_mp)|]; [| v_obj |] |]) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 58677b8496..e240ea3ba1 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2020-03-11-V28" +# CACHEKEY: "bionic_coq-V2020-03-13-V69" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -22,7 +22,7 @@ RUN pip3 install sphinx==1.8.0 sphinx_rtd_theme==0.2.5b2 \ antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.0 # We need to install OPAM 2.0 manually for now. -RUN wget https://github.com/ocaml/opam/releases/download/2.0.5/opam-2.0.5-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam +RUN wget https://github.com/ocaml/opam/releases/download/2.0.6/opam-2.0.6-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam # Basic OPAM setup ENV NJOBS="2" \ @@ -57,7 +57,7 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ # EDGE switch ENV COMPILER_EDGE="4.10.0" \ - BASE_OPAM_EDGE="dune.2.5.0 dune-release.1.3.3 ocamlformat.0.13.0" + BASE_OPAM_EDGE="dune.2.5.0 dune-release.1.3.3 ocamlformat.0.14.0" # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. diff --git a/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh b/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh new file mode 100644 index 0000000000..4170799be7 --- /dev/null +++ b/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "11820" ] || [ "$CI_BRANCH" = "partial-import" ]; then + + elpi_CI_REF=partial-import + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index eac8d86b0a..9498ab8bbb 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -9,6 +9,13 @@ ### ML API +Proof state and constant declaration: + +- A large consolidation of the API handling interactive and + non-interactive constant has been performed; low-level APIs are no + longer available, and the functionality of the `Proof_global` module + has been merged into `Declare`. + Notations: - Most operators on numerals have moved to file numTok.ml. @@ -68,7 +75,6 @@ Proof state: information related to the constant declaration. Some functions have been renamed from `start_proof` to `start_lemma` - Plugins that require access to the information about currently opened lemmas can add one of the `![proof]` attributes to their `mlg` entry, which will refine the type accordingly. See diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 7002cbffac..542893ad0b 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -59,8 +59,8 @@ let prrecarg = function let ppwf_paths x = pp (Rtree.pp_tree prrecarg x) let get_current_context () = - try Vernacstate.Proof_global.get_current_context () - with Vernacstate.Proof_global.NoCurrentProof -> + try Vernacstate.Declare.get_current_context () + with Vernacstate.Declare.NoCurrentProof -> let env = Global.env() in Evd.from_env env, env [@@ocaml.warning "-3"] diff --git a/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst b/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst new file mode 100644 index 0000000000..0f30b5f5e8 --- /dev/null +++ b/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst @@ -0,0 +1,5 @@ +- **Changed:** + Ignore -native-compiler option when built without native compute + support. + (`#12070 <https://github.com/coq/coq/pull/12070>`_, + by Pierre Roux). diff --git a/doc/changelog/08-tools/12037-coqdoc-preformatted.rst b/doc/changelog/08-tools/12037-coqdoc-preformatted.rst new file mode 100644 index 0000000000..bf65719516 --- /dev/null +++ b/doc/changelog/08-tools/12037-coqdoc-preformatted.rst @@ -0,0 +1,6 @@ +- **Fixed:** + ``coqdoc`` now reports the location of a mismatched opening ``[[`` instead of + throwing an uninformative exception. + (`#12037 <https://github.com/coq/coq/pull/12037>`_, + fixes `#9670 <https://github.com/coq/coq/issues/9670>`_, + by Lysxia). diff --git a/doc/changelog/10-standard-library/11957-signotations.rst b/doc/changelog/10-standard-library/11957-signotations.rst new file mode 100644 index 0000000000..fc5d434274 --- /dev/null +++ b/doc/changelog/10-standard-library/11957-signotations.rst @@ -0,0 +1,4 @@ +- **Added:** + notations for sigma types: ``{ x & P & Q }``, ``{ ' pat & P }``, ``{ ' pat & P & Q }`` + (`#11957 <https://github.com/coq/coq/pull/11957>`_, + by Olivier Laurent). diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 73d94c2a51..8c2090f3be 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -286,8 +286,8 @@ END VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY | ![ proof_query ] [ "ExploreProof" ] -> { fun ~pstate -> - let sigma, env = Pfedit.get_current_context pstate in - let pprf = Proof.partial_proof (Proof_global.get_proof pstate) in + let sigma, env = Declare.get_current_context pstate in + let pprf = Proof.partial_proof (Declare.Proof.get_proof pstate) in Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) } diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 8c4dc0e8a6..b94b1fc657 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,8 +1,6 @@ -let edeclare ?hook ~name ~poly ~scope ~kind ~opaque ~udecl ~impargs sigma body tyopt = - DeclareDef.declare_definition ~name ~scope ~kind ~impargs ?hook - ~opaque ~poly ~udecl ~types:tyopt ~body sigma - let declare_definition ~poly name sigma body = let udecl = UState.default_univ_decl in - edeclare ~name ~poly ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsDefinition Definition) ~opaque:false ~impargs:[] ~udecl sigma body None + let scope = DeclareDef.Global Declare.ImportDefaultBehavior in + let kind = Decls.(IsDefinition Definition) in + DeclareDef.declare_definition ~name ~scope ~kind ~impargs:[] ~udecl + ~opaque:false ~poly ~types:None ~body sigma diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 78b1f02383..57c8683aaa 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -422,7 +422,12 @@ are now available through the dot notation. If :n:`@module_binder`\s are specified, declares a functor with parameters given by the list of :token:`module_binder`\s. -.. cmd:: Import {+ @qualid } +.. cmd:: Import {+ @filtered_import } + + .. insertprodn filtered_import filtered_import + + .. prodn:: + filtered_import ::= @qualid {? ( {+, @qualid {? ( .. ) } } ) } If :token:`qualid` denotes a valid basic module (i.e. its module type is a signature), makes its components available by their short names. @@ -465,12 +470,50 @@ are now available through the dot notation. Check B.T. -.. cmd:: Export {+ @qualid } + Appending a module name with a parenthesized list of names will + make only those names available with short names, not other names + defined in the module nor will it activate other features. + + The names to import may be constants, inductive types and + constructors, and notation aliases (for instance, Ltac definitions + cannot be selectively imported). If they are from an inner module + to the one being imported, they must be prefixed by the inner path. + + The name of an inductive type may also be followed by ``(..)`` to + import it, its constructors and its eliminators if they exist. For + this purpose "eliminator" means a constant in the same module whose + name is the inductive type's name suffixed by one of ``_sind``, + ``_ind``, ``_rec`` or ``_rect``. + + .. example:: + + .. coqtop:: reset in + + Module A. + Module B. + Inductive T := C. + Definition U := nat. + End B. + Definition Z := Prop. + End A. + Import A(B.T(..), Z). + + .. coqtop:: all + + Check B.T. + Check B.C. + Check Z. + Fail Check B.U. + Check A.B.U. + +.. cmd:: Export {+ @filtered_import } :name: Export Similar to :cmd:`Import`, except that when the module containing this command is imported, the :n:`{+ @qualid }` are imported as well. + The selective import syntax also works with Export. + .. exn:: @qualid is not a module. :undocumented: diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index a01f57eb22..5034d9a3c9 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -511,6 +511,12 @@ strategy_flag: [ | OPTINREF ] +filtered_import: [ +| REPLACE global "(" LIST1 one_import_filter_name SEP "," ")" +| WITH global OPT [ "(" LIST1 one_import_filter_name SEP "," ")" ] +| DELETE global +] + functor_app_annot: [ | OPTINREF ] @@ -1582,6 +1588,7 @@ SPLICE: [ | searchabout_queries | locatable | scope_delimiter +| one_import_filter_name ] (* end SPLICE *) RENAME: [ diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index dc7e0fba37..04c20a7203 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -1031,8 +1031,8 @@ gallina_ext: [ | "Collection" identref ":=" section_subset_expr | "Require" export_token LIST1 global | "From" global "Require" export_token LIST1 global -| "Import" LIST1 global -| "Export" LIST1 global +| "Import" LIST1 filtered_import +| "Export" LIST1 filtered_import | "Include" module_type_inl LIST0 ext_module_expr | "Include" "Type" module_type_inl LIST0 ext_module_type | "Transparent" LIST1 smart_global @@ -1057,6 +1057,15 @@ gallina_ext: [ | "Export" "Unset" option_table ] +filtered_import: [ +| global +| global "(" LIST1 one_import_filter_name SEP "," ")" +] + +one_import_filter_name: [ +| global OPT [ "(" ".." ")" ] +] + export_token: [ | "Import" | "Export" diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index ac986f9adf..e71c80f829 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -497,6 +497,10 @@ constructor: [ | ident LIST0 binder OPT of_type ] +filtered_import: [ +| qualid OPT [ "(" LIST1 ( qualid OPT [ "(" ".." ")" ] ) SEP "," ")" ] +] + cofix_definition: [ | ident_decl LIST0 binder OPT ( ":" type ) OPT [ ":=" term ] OPT decl_notations ] @@ -849,8 +853,8 @@ command: [ | "Collection" ident ":=" section_subset_expr | "Require" OPT [ "Import" | "Export" ] LIST1 qualid | "From" dirpath "Require" OPT [ "Import" | "Export" ] LIST1 qualid -| "Import" LIST1 qualid -| "Export" LIST1 qualid +| "Import" LIST1 filtered_import +| "Export" LIST1 filtered_import | "Include" module_type_inl LIST0 ( "<+" module_expr_inl ) | "Include" "Type" LIST1 module_type_inl SEP "<+" | "Transparent" LIST1 smart_qualid diff --git a/ide/idetop.ml b/ide/idetop.ml index 0ef7fca41f..fa458e7c6e 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -232,32 +232,32 @@ let goals () = let doc = get_doc () in set_doc @@ Stm.finish ~doc; try - let newp = Vernacstate.Proof_global.give_me_the_proof () in + let newp = Vernacstate.Declare.give_me_the_proof () in if Proof_diffs.show_diffs () then begin let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in let diff_goal_map = Proof_diffs.make_goal_map oldp newp in Some (export_pre_goals Proof.(data newp) (process_goal_diffs diff_goal_map oldp)) end else Some (export_pre_goals Proof.(data newp) process_goal) - with Vernacstate.Proof_global.NoCurrentProof -> None + with Vernacstate.Declare.NoCurrentProof -> None [@@ocaml.warning "-3"];; let evars () = try let doc = get_doc () in set_doc @@ Stm.finish ~doc; - let pfts = Vernacstate.Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Declare.give_me_the_proof () in let Proof.{ sigma } = Proof.data pfts in let exl = Evar.Map.bindings (Evd.undefined_map sigma) in let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in let el = List.map map_evar exl in Some el - with Vernacstate.Proof_global.NoCurrentProof -> None + with Vernacstate.Declare.NoCurrentProof -> None [@@ocaml.warning "-3"] let hints () = try - let pfts = Vernacstate.Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Declare.give_me_the_proof () in let Proof.{ goals; sigma } = Proof.data pfts in match goals with | [] -> None @@ -266,7 +266,7 @@ let hints () = let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in Some (hint_hyps, concl_next_tac) - with Vernacstate.Proof_global.NoCurrentProof -> None + with Vernacstate.Declare.NoCurrentProof -> None [@@ocaml.warning "-3"] (** Other API calls *) @@ -287,11 +287,11 @@ let status force = List.rev_map Names.Id.to_string l in let proof = - try Some (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) - with Vernacstate.Proof_global.NoCurrentProof -> None + try Some (Names.Id.to_string (Vernacstate.Declare.get_current_proof_name ())) + with Vernacstate.Declare.NoCurrentProof -> None in let allproofs = - let l = Vernacstate.Proof_global.get_all_proof_names () in + let l = Vernacstate.Declare.get_all_proof_names () in List.map Names.Id.to_string l in { @@ -340,7 +340,7 @@ let import_search_constraint = function | Interface.Include_Blacklist -> Search.Include_Blacklist let search flags = - let pstate = Vernacstate.Proof_global.get_pstate () in + let pstate = Vernacstate.Declare.get_pstate () in List.map export_coq_object (Search.interface_search ?pstate ( List.map (fun (c, b) -> (import_search_constraint c, b)) flags) ) diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index d4369e9bd1..d6097304ec 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -121,9 +121,10 @@ let rec constr_expr_eq e1 e2 = constr_expr_eq a1 a2 && Option.equal constr_expr_eq t1 t2 && constr_expr_eq b1 b2 - | CAppExpl((proj1,r1,_),al1), CAppExpl((proj2,r2,_),al2) -> + | CAppExpl((proj1,r1,u1),al1), CAppExpl((proj2,r2,u2),al2) -> Option.equal Int.equal proj1 proj2 && qualid_eq r1 r2 && + eq_universes u1 u2 && List.equal constr_expr_eq al1 al2 | CApp((proj1,e1),al1), CApp((proj2,e2),al2) -> Option.equal Int.equal proj1 proj2 && @@ -158,8 +159,8 @@ let rec constr_expr_eq e1 e2 = Id.equal id1 id2 && List.equal instance_eq c1 c2 | CSort s1, CSort s2 -> Glob_ops.glob_sort_eq s1 s2 - | CCast(t1,c1), CCast(t2,c2) -> - constr_expr_eq t1 t2 && cast_expr_eq c1 c2 + | CCast(t1,c1), CCast(t2,c2) -> + constr_expr_eq t1 t2 && cast_expr_eq c1 c2 | CNotation(inscope1, n1, s1), CNotation(inscope2, n2, s2) -> Option.equal notation_with_optional_scope_eq inscope1 inscope2 && notation_eq n1 n2 && diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 905d9f1e5b..45255609e0 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -989,7 +989,7 @@ let string_of_ty = function | Variable -> "var" let gvar (loc, id) us = match us with -| None -> DAst.make ?loc @@ GVar id +| None | Some [] -> DAst.make ?loc @@ GVar id | Some _ -> user_err ?loc (str "Variable " ++ Id.print id ++ str " cannot have a universe instance") diff --git a/interp/notation.ml b/interp/notation.ml index 6291a88bb0..0afbb9cd62 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -206,7 +206,7 @@ let classify_scope (local,_,_ as o) = let inScope : bool * bool * scope_item -> obj = declare_object {(default_object "SCOPE") with cache_function = cache_scope; - open_function = open_scope; + open_function = simple_open open_scope; subst_function = subst_scope; discharge_function = discharge_scope; classify_function = classify_scope } @@ -980,9 +980,12 @@ let subst_prim_token_interpretation (subs,infos) = let classify_prim_token_interpretation infos = if infos.pt_local then Dispose else Substitute infos +let open_prim_token_interpretation i o = + if Int.equal i 1 then cache_prim_token_interpretation o + let inPrimTokenInterp : prim_token_infos -> obj = declare_object {(default_object "PRIM-TOKEN-INTERP") with - open_function = (fun i o -> if Int.equal i 1 then cache_prim_token_interpretation o); + open_function = simple_open open_prim_token_interpretation; cache_function = cache_prim_token_interpretation; subst_function = subst_prim_token_interpretation; classify_function = classify_prim_token_interpretation} diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 767c69e3b6..7184f5ea29 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -67,11 +67,18 @@ let subst_syntax_constant (subst,(local,syndef)) = let classify_syntax_constant (local,_ as o) = if local then Dispose else Substitute o +let filtered_open_syntax_constant f i ((_,kn),_ as o) = + let in_f = match f with + | Unfiltered -> true + | Names ns -> Globnames.(ExtRefSet.mem (SynDef kn) ns) + in + if in_f then open_syntax_constant i o + let in_syntax_constant : (bool * syndef) -> obj = declare_object {(default_object "SYNDEF") with cache_function = cache_syntax_constant; load_function = load_syntax_constant; - open_function = open_syntax_constant; + open_function = filtered_open_syntax_constant; subst_function = subst_syntax_constant; classify_function = classify_syntax_constant } diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 6cfe44c5ff..a5fcfae1fc 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -96,14 +96,14 @@ let mk_accu (a : atom) : t = 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 [@ocaml.alert "--deprecated"] in + let () = Obj.set_tag ans accumulate_tag [@ocaml.warning "-3"] 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 [@ocaml.alert "--deprecated"] in + let () = Obj.set_tag ans accumulate_tag [@ocaml.warning "-3"] in (Obj.obj ans : t) let get_accu (k : accumulator) = diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index f4de53c9fe..58b516dfdd 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -312,6 +312,7 @@ sig type t val repr : t -> side_effect list val empty : t + val is_empty : t -> bool val add : side_effect -> t -> t val concat : t -> t -> t end = @@ -330,6 +331,7 @@ type t = { seff : side_effect list; elts : SeffSet.t } let repr eff = eff.seff let empty = { seff = []; elts = SeffSet.empty } +let is_empty { seff; elts } = List.is_empty seff && SeffSet.is_empty elts let add x es = if SeffSet.mem x es.elts then es else { seff = x :: es.seff; elts = SeffSet.add x es.elts } @@ -360,6 +362,7 @@ let push_private_constants env eff = List.fold_left add_if_undefined env eff let empty_private_constants = SideEffects.empty +let is_empty_private_constants c = SideEffects.is_empty c let concat_private = SideEffects.concat let universes_of_private eff = diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index f8d5d319a9..b42746a882 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -50,6 +50,8 @@ type 'a safe_transformer = safe_environment -> 'a * safe_environment type private_constants val empty_private_constants : private_constants +val is_empty_private_constants : private_constants -> bool + val concat_private : private_constants -> private_constants -> private_constants (** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in [e1] must be more recent than those of [e2]. *) diff --git a/kernel/sorts.ml b/kernel/sorts.ml index 466fbacca4..3a89b73bd5 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -12,6 +12,8 @@ open Univ type family = InSProp | InProp | InSet | InType +let all_families = [InSProp; InProp; InSet; InType] + type t = | SProp | Prop diff --git a/kernel/sorts.mli b/kernel/sorts.mli index 49549e224d..fe939b1d95 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -12,6 +12,8 @@ type family = InSProp | InProp | InSet | InType +val all_families : family list + type t = private | SProp | Prop diff --git a/library/globnames.ml b/library/globnames.ml index 9126a467bf..bc24fbf096 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -117,3 +117,10 @@ module ExtRefOrdered = struct | SynDef kn -> combinesmall 2 (KerName.hash kn) end + +module ExtRefMap = HMap.Make(ExtRefOrdered) +module ExtRefSet = ExtRefMap.Set + +let subst_extended_reference sub = function + | SynDef kn -> SynDef (subst_kn sub kn) + | TrueGlobal gr -> TrueGlobal (subst_global_reference sub gr) diff --git a/library/globnames.mli b/library/globnames.mli index fb1583e16c..8acea5ef28 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -61,3 +61,10 @@ module ExtRefOrdered : sig val equal : t -> t -> bool val hash : t -> int end + +module ExtRefSet : CSig.SetS with type elt = extended_global_reference +module ExtRefMap : CMap.ExtS + with type key = extended_global_reference + and module Set := ExtRefSet + +val subst_extended_reference : substitution -> extended_global_reference -> extended_global_reference diff --git a/library/goptions.ml b/library/goptions.ml index 73132868d7..1418407533 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -90,7 +90,7 @@ module MakeTable = let inGo : option_mark * A.t -> obj = Libobject.declare_object {(Libobject.default_object nick) with Libobject.load_function = load_options; - Libobject.open_function = load_options; + Libobject.open_function = simple_open load_options; Libobject.cache_function = cache_options; Libobject.subst_function = subst_options; Libobject.classify_function = (fun x -> Substitute x)} @@ -262,7 +262,7 @@ let declare_option cast uncast append ?(preprocess = fun x -> x) declare_object { (default_object (nickname key)) with load_function = load_options; - open_function = open_options; + open_function = simple_open open_options; cache_function = cache_options; subst_function = subst_options; discharge_function = discharge_options; diff --git a/library/lib.ml b/library/lib.ml index e7e6dc640a..830777003b 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -46,7 +46,7 @@ let iter_objects f i prefix = List.iter (fun (id,obj) -> f i (make_oname prefix id, obj)) let load_atomic_objects i pr = iter_objects load_object i pr -let open_atomic_objects i pr = iter_objects open_object i pr +let open_atomic_objects f i pr = iter_objects (open_object f) i pr let subst_atomic_objects subst seg = let subst_one = fun (id,obj as node) -> diff --git a/library/lib.mli b/library/lib.mli index 949b5e26c2..56ea35ec60 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -35,7 +35,8 @@ type lib_objects = (Id.t * Libobject.t) list (** {6 Object iteration functions. } *) -val open_atomic_objects : int -> Nametab.object_prefix -> lib_atomic_objects -> unit +val open_atomic_objects : Libobject.open_filter + -> int -> Nametab.object_prefix -> lib_atomic_objects -> unit val load_atomic_objects : int -> Nametab.object_prefix -> lib_atomic_objects -> unit val subst_atomic_objects : Mod_subst.substitution -> lib_atomic_objects -> lib_atomic_objects (*val load_and_subst_objects : int -> Libnames.Nametab.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects*) diff --git a/library/libobject.ml b/library/libobject.ml index 0681e12449..c38e0d891b 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -18,11 +18,36 @@ type 'a substitutivity = type object_name = Libnames.full_path * Names.KerName.t +module NSet = Globnames.ExtRefSet + +type open_filter = + | Unfiltered + | Names of NSet.t + +let simple_open f filter i o = match filter with + | Unfiltered -> f i o + | Names _ -> () + +let filter_and f1 f2 = match f1, f2 with + | Unfiltered, f | f, Unfiltered -> Some f + | Names n1, Names n2 -> + let n = NSet.inter n1 n2 in + if NSet.is_empty n then None + else Some (Names n) + +let filter_or f1 f2 = match f1, f2 with + | Unfiltered, f | f, Unfiltered -> Unfiltered + | Names n1, Names n2 -> Names (NSet.union n1 n2) + +let in_filter_ref gr = function + | Unfiltered -> true + | Names ns -> NSet.mem (Globnames.TrueGlobal gr) ns + type 'a object_declaration = { object_name : string; cache_function : object_name * 'a -> unit; load_function : int -> object_name * 'a -> unit; - open_function : int -> object_name * 'a -> unit; + open_function : open_filter -> int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; subst_function : Mod_subst.substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; @@ -32,7 +57,7 @@ let default_object s = { object_name = s; cache_function = (fun _ -> ()); load_function = (fun _ _ -> ()); - open_function = (fun _ _ -> ()); + open_function = (fun _ _ _ -> ()); subst_function = (fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!")); classify_function = (fun atomic_obj -> Keep atomic_obj); @@ -75,7 +100,7 @@ and t = | ModuleTypeObject of substitutive_objects | IncludeObject of algebraic_objects | KeepObject of objects - | ExportObject of { mpl : ModPath.t list } + | ExportObject of { mpl : (open_filter * ModPath.t) list } | AtomicObject of obj and objects = (Names.Id.t * t) list @@ -105,9 +130,9 @@ let load_object i (sp, Dyn.Dyn (tag, v)) = let decl = DynMap.find tag !cache_tab in decl.load_function i (sp, v) -let open_object i (sp, Dyn.Dyn (tag, v)) = +let open_object f i (sp, Dyn.Dyn (tag, v)) = let decl = DynMap.find tag !cache_tab in - decl.open_function i (sp, v) + decl.open_function f i (sp, v) let subst_object (subs, Dyn.Dyn (tag, v)) = let decl = DynMap.find tag !cache_tab in @@ -147,7 +172,7 @@ let global_object_nodischarge s ~cache ~subst = let import i o = if Int.equal i 1 then cache o in { (default_object s) with cache_function = cache; - open_function = import; + open_function = simple_open import; subst_function = (match subst with | None -> fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!") | Some subst -> subst; diff --git a/library/libobject.mli b/library/libobject.mli index 24cadc2223..1c82349bb6 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -72,16 +72,28 @@ type 'a substitutivity = type object_name = full_path * Names.KerName.t +type open_filter = Unfiltered | Names of Globnames.ExtRefSet.t + type 'a object_declaration = { object_name : string; cache_function : object_name * 'a -> unit; load_function : int -> object_name * 'a -> unit; - open_function : int -> object_name * 'a -> unit; + open_function : open_filter -> int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; subst_function : substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; rebuild_function : 'a -> 'a } +val simple_open : (int -> object_name * 'a -> unit) -> open_filter -> int -> object_name * 'a -> unit +(** Combinator for making objects which are only opened by unfiltered Import *) + +val filter_and : open_filter -> open_filter -> open_filter option +(** Returns [None] when the intersection is empty. *) + +val filter_or : open_filter -> open_filter -> open_filter + +val in_filter_ref : Names.GlobRef.t -> open_filter -> bool + (** The default object is a "Keep" object with empty methods. Object creators are advised to use the construction [{(default_object "MY_OBJECT") with @@ -114,7 +126,7 @@ and t = | ModuleTypeObject of substitutive_objects | IncludeObject of algebraic_objects | KeepObject of objects - | ExportObject of { mpl : Names.ModPath.t list } + | ExportObject of { mpl : (open_filter * Names.ModPath.t) list } | AtomicObject of obj and objects = (Names.Id.t * t) list @@ -129,7 +141,7 @@ val declare_object : val cache_object : object_name * obj -> unit val load_object : int -> object_name * obj -> unit -val open_object : int -> object_name * obj -> unit +val open_object : open_filter -> int -> object_name * obj -> unit val subst_object : substitution * obj -> obj val classify_object : obj -> obj substitutivity val discharge_object : object_name * obj -> obj option diff --git a/library/nametab.ml b/library/nametab.ml index 523fe8af50..d9b4dc9122 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -352,10 +352,8 @@ let the_univtab = Summary.ref ~name:"univtab" (UnivTab.empty : univtab) (* Reversed name tables ***************************************************) (* This table translates extended_global_references back to section paths *) -module Globrevtab = HMap.Make(ExtRefOrdered) - -type globrevtab = full_path Globrevtab.t -let the_globrevtab = Summary.ref ~name:"globrevtab" (Globrevtab.empty : globrevtab) +type globrevtab = full_path ExtRefMap.t +let the_globrevtab = Summary.ref ~name:"globrevtab" (ExtRefMap.empty : globrevtab) type mprevtab = DirPath.t MPmap.t @@ -386,7 +384,7 @@ let push_xref visibility sp xref = match visibility with | Until _ -> the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; - the_globrevtab := Globrevtab.add xref sp !the_globrevtab + the_globrevtab := ExtRefMap.add xref sp !the_globrevtab | _ -> begin if ExtRefTab.exists sp !the_ccitab then @@ -520,7 +518,7 @@ let path_of_global ref = let open GlobRef in match ref with | VarRef id -> make_path DirPath.empty id - | _ -> Globrevtab.find (TrueGlobal ref) !the_globrevtab + | _ -> ExtRefMap.find (TrueGlobal ref) !the_globrevtab let dirpath_of_global ref = fst (repr_path (path_of_global ref)) @@ -529,7 +527,7 @@ let basename_of_global ref = snd (repr_path (path_of_global ref)) let path_of_syndef kn = - Globrevtab.find (SynDef kn) !the_globrevtab + ExtRefMap.find (SynDef kn) !the_globrevtab let dirpath_of_module mp = MPmap.find mp !the_modrevtab @@ -547,7 +545,7 @@ let shortest_qualid_of_global ?loc ctx ref = match ref with | VarRef id -> make_qualid ?loc DirPath.empty id | _ -> - let sp = Globrevtab.find (TrueGlobal ref) !the_globrevtab in + let sp = ExtRefMap.find (TrueGlobal ref) !the_globrevtab in ExtRefTab.shortest_qualid ?loc ctx sp !the_ccitab let shortest_qualid_of_syndef ?loc ctx kn = diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index dca69f06ca..f09b35a6d1 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -42,6 +42,6 @@ let start_deriving f suchthat name : Lemmas.t = let info = Lemmas.Info.make ~proof_ending:(Lemmas.Proof_ending.(End_derive {f; name})) ~kind () in let lemma = Lemmas.start_dependent_lemma ~name ~poly ~info goals in - Lemmas.pf_map (Proof_global.map_proof begin fun p -> + Lemmas.pf_map (Declare.Proof.map_proof begin fun p -> Util.pi1 @@ Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p end) lemma diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 3a90d24c97..02383799a9 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -728,13 +728,13 @@ let extract_and_compile l = (* Show the extraction of the current ongoing proof *) let show_extraction ~pstate = init ~inner:true false false; - let prf = Proof_global.get_proof pstate in - let sigma, env = Pfedit.get_current_context pstate in + let prf = Declare.Proof.get_proof pstate in + let sigma, env = Declare.get_current_context pstate in let trms = Proof.partial_proof prf in let extr_term t = let ast, ty = extract_constr env sigma t in let mp = Lib.current_mp () in - let l = Label.of_id (Proof_global.get_proof_name pstate) in + let l = Label.of_id (Declare.Proof.get_proof_name pstate) in let fake_ref = GlobRef.ConstRef (Constant.make2 mp l) in let decl = Dterm (fake_ref, ast, ty) in print_one_decl [] mp decl diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index edbc1f5ea7..06cc475200 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -40,4 +40,4 @@ val structure_for_compute : (* Show the extraction of the current ongoing proof *) -val show_extraction : pstate:Proof_global.t -> unit +val show_extraction : pstate:Declare.Proof.t -> unit diff --git a/plugins/funind/.ocamlformat b/plugins/funind/.ocamlformat new file mode 100644 index 0000000000..a22a2ff88c --- /dev/null +++ b/plugins/funind/.ocamlformat @@ -0,0 +1 @@ +disable=false diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 9749af1e66..7b2ce671a3 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -15,280 +15,265 @@ open Tactics open Indfun_common open Libnames open Context.Rel.Declaration - module RelDecl = Context.Rel.Declaration -let list_chop ?(msg="") n l = - try - List.chop n l - with Failure (msg') -> - failwith (msg ^ msg') +let list_chop ?(msg = "") n l = + try List.chop n l with Failure msg' -> failwith (msg ^ msg') let pop t = Vars.lift (-1) t -let make_refl_eq constructor type_of_t t = -(* let refl_equal_term = Lazy.force refl_equal in *) - mkApp(constructor,[|type_of_t;t|]) - +let make_refl_eq constructor type_of_t t = + (* let refl_equal_term = Lazy.force refl_equal in *) + mkApp (constructor, [|type_of_t; t|]) type pte_info = - { - proving_tac : (Id.t list -> Tacmach.tactic); - is_valid : constr -> bool - } + {proving_tac : Id.t list -> Tacmach.tactic; is_valid : constr -> bool} type ptes_info = pte_info Id.Map.t type 'a dynamic_info = - { - nb_rec_hyps : int; - rec_hyps : Id.t list ; - eq_hyps : Id.t list; - info : 'a - } + {nb_rec_hyps : int; rec_hyps : Id.t list; eq_hyps : Id.t list; info : 'a} type body_info = constr dynamic_info let observe_tac s = observe_tac (fun _ _ -> Pp.str s) let finish_proof dynamic_infos g = - observe_tac "finish" - (Proofview.V82.of_tactic assumption) - g - + observe_tac "finish" (Proofview.V82.of_tactic assumption) g let refine c = Refiner.refiner ~check:true EConstr.Unsafe.(to_constr c) - let thin l = Proofview.V82.of_tactic (Tactics.clear l) - let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v let is_trivial_eq sigma t = - let res = try - begin + let res = + try match EConstr.kind sigma t with - | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> - eq_constr sigma t1 t2 - | App(f,[|t1;a1;t2;a2|]) when eq_constr sigma f (jmeq ()) -> - eq_constr sigma t1 t2 && eq_constr sigma a1 a2 - | _ -> false - end - with e when CErrors.noncritical e -> false + | App (f, [|_; t1; t2|]) when eq_constr sigma f (Lazy.force eq) -> + eq_constr sigma t1 t2 + | App (f, [|t1; a1; t2; a2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma t1 t2 && eq_constr sigma a1 a2 + | _ -> false + with e when CErrors.noncritical e -> false in -(* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) + (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res let rec incompatible_constructor_terms sigma t1 t2 = - let c1,arg1 = decompose_app sigma t1 - and c2,arg2 = decompose_app sigma t2 - in - (not (eq_constr sigma t1 t2)) && - isConstruct sigma c1 && isConstruct sigma c2 && - ( - not (eq_constr sigma c1 c2) || - List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 - ) + let c1, arg1 = decompose_app sigma t1 and c2, arg2 = decompose_app sigma t2 in + (not (eq_constr sigma t1 t2)) + && isConstruct sigma c1 && isConstruct sigma c2 + && ( (not (eq_constr sigma c1 c2)) + || List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 ) let is_incompatible_eq env sigma t = let res = try match EConstr.kind sigma t with - | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> - incompatible_constructor_terms sigma t1 t2 - | App(f,[|u1;t1;u2;t2|]) when eq_constr sigma f (jmeq ()) -> - (eq_constr sigma u1 u2 && - incompatible_constructor_terms sigma t1 t2) - | _ -> false + | App (f, [|_; t1; t2|]) when eq_constr sigma f (Lazy.force eq) -> + incompatible_constructor_terms sigma t1 t2 + | App (f, [|u1; t1; u2; t2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma u1 u2 && incompatible_constructor_terms sigma t1 t2 + | _ -> false with e when CErrors.noncritical e -> false in if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); res let change_hyp_with_using msg hyp_id t tac : tactic = - fun g -> - let prov_id = pf_get_new_id hyp_id g in - tclTHENS - ((* observe_tac msg *) Proofview.V82.of_tactic (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) - [tclTHENLIST - [ - (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); - (* observe_tac "change_hyp_with_using rename " *) (Proofview.V82.of_tactic (rename_hyp [prov_id,hyp_id])) - ]] g + fun g -> + let prov_id = pf_get_new_id hyp_id g in + tclTHENS + ((* observe_tac msg *) Proofview.V82.of_tactic + (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) + [ tclTHENLIST + [ (* observe_tac "change_hyp_with_using thin" *) + thin [hyp_id] + ; (* observe_tac "change_hyp_with_using rename " *) + Proofview.V82.of_tactic (rename_hyp [(prov_id, hyp_id)]) ] ] + g exception TOREMOVE - -let prove_trivial_eq h_id context (constructor,type_of_term,term) = +let prove_trivial_eq h_id context (constructor, type_of_term, term) = let nb_intros = List.length context in tclTHENLIST - [ - tclDO nb_intros (Proofview.V82.of_tactic intro); (* introducing context *) + [ tclDO nb_intros (Proofview.V82.of_tactic intro) + ; (* introducing context *) (fun g -> - let context_hyps = - fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) - in - let context_hyps' = - (mkApp(constructor,[|type_of_term;term|])):: - (List.map mkVar context_hyps) - in - let to_refine = applist(mkVar h_id,List.rev context_hyps') in - refine to_refine g - ) - ] - - + let context_hyps = + fst + (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) + in + let context_hyps' = + mkApp (constructor, [|type_of_term; term|]) + :: List.map mkVar context_hyps + in + let to_refine = applist (mkVar h_id, List.rev context_hyps') in + refine to_refine g) ] let find_rectype env sigma c = - let (t, l) = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in + let t, l = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in match EConstr.kind sigma t with | Ind ind -> (t, l) - | Construct _ -> (t,l) + | Construct _ -> (t, l) | _ -> raise Not_found - -let isAppConstruct ?(env=Global.env ()) sigma t = +let isAppConstruct ?(env = Global.env ()) sigma t = try - let t',l = find_rectype env sigma t in - observe (str "isAppConstruct : " ++ Printer.pr_leconstr_env env sigma t ++ str " -> " ++ - Printer.pr_leconstr_env env sigma (applist (t',l))); + let t', l = find_rectype env sigma t in + observe + ( str "isAppConstruct : " + ++ Printer.pr_leconstr_env env sigma t + ++ str " -> " + ++ Printer.pr_leconstr_env env sigma (applist (t', l)) ); true with Not_found -> false exception NoChange -let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = - let nochange ?t' msg = - begin - observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr_env env sigma t ++ str " " ++ - match t' with None -> str "" | Some t -> Printer.pr_leconstr_env env sigma t ); - raise NoChange; - end +let change_eq env sigma hyp_id (context : rel_context) x t end_of_type = + let nochange ?t' msg = + observe + ( str ("Not treating ( " ^ msg ^ " )") + ++ pr_leconstr_env env sigma t + ++ str " " + ++ + match t' with + | None -> str "" + | Some t -> Printer.pr_leconstr_env env sigma t ); + raise NoChange in let eq_constr c1 c2 = - try ignore(Evarconv.unify_delay env sigma c1 c2); true - with Evarconv.UnableToUnify _ -> false in - if not (noccurn sigma 1 end_of_type) - then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) - if not (isApp sigma t) then nochange "not an equality"; - let f_eq,args = destApp sigma t in - let constructor,t1,t2,t1_typ = + try + ignore (Evarconv.unify_delay env sigma c1 c2); + true + with Evarconv.UnableToUnify _ -> false + in + if not (noccurn sigma 1 end_of_type) then nochange "dependent"; + (* if end_of_type depends on this term we don't touch it *) + if not (isApp sigma t) then nochange "not an equality"; + let f_eq, args = destApp sigma t in + let constructor, t1, t2, t1_typ = + try + if eq_constr f_eq (Lazy.force eq) then + let t1 = (args.(1), args.(0)) + and t2 = (args.(2), args.(0)) + and t1_typ = args.(0) in + (Lazy.force refl_equal, t1, t2, t1_typ) + else if eq_constr f_eq (jmeq ()) then + (jmeq_refl (), (args.(1), args.(0)), (args.(3), args.(2)), args.(0)) + else nochange "not an equality" + with e when CErrors.noncritical e -> nochange "not an equality" + in + if not (closed0 sigma (fst t1) && closed0 sigma (snd t1)) then + nochange "not a closed lhs"; + let rec compute_substitution sub t1 t2 = + (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) + if isRel sigma t2 then ( + let t2 = destRel sigma t2 in try - if (eq_constr f_eq (Lazy.force eq)) - then - let t1 = (args.(1),args.(0)) - and t2 = (args.(2),args.(0)) - and t1_typ = args.(0) - in - (Lazy.force refl_equal,t1,t2,t1_typ) - else - if (eq_constr f_eq (jmeq ())) - then - (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) - else nochange "not an equality" - with e when CErrors.noncritical e -> nochange "not an equality" - in - if not ((closed0 sigma (fst t1)) && (closed0 sigma (snd t1)))then nochange "not a closed lhs"; - let rec compute_substitution sub t1 t2 = -(* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) - if isRel sigma t2 - then - let t2 = destRel sigma t2 in - begin - try - let t1' = Int.Map.find t2 sub in - if not (eq_constr t1 t1') then nochange "twice bound variable"; - sub - with Not_found -> - assert (closed0 sigma t1); - Int.Map.add t2 t1 sub - end - else if isAppConstruct sigma t1 && isAppConstruct sigma t2 - then - begin - let c1,args1 = find_rectype env sigma t1 - and c2,args2 = find_rectype env sigma t2 - in - if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; - List.fold_left2 compute_substitution sub args1 args2 - end - else - if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) "cannot solve (diff)" - in - let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in - let sub = compute_substitution sub (fst t1) (fst t2) in - let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) - let new_end_of_type = - (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 - Can be safely replaced by the next comment for Ocaml >= 3.08.4 - *) - let sub = Int.Map.bindings sub in - List.fold_left (fun end_of_type (i,t) -> liftn 1 i (substnl [t] (i-1) end_of_type)) - end_of_type_with_pop + let t1' = Int.Map.find t2 sub in + if not (eq_constr t1 t1') then nochange "twice bound variable"; sub - in - let old_context_length = List.length context + 1 in - let witness_fun = - mkLetIn(make_annot Anonymous Sorts.Relevant,make_refl_eq constructor t1_typ (fst t1),t, - mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) - ) - in - let new_type_of_hyp,ctxt_size,witness_fun = - List.fold_left_i - (fun i (end_of_type,ctxt_size,witness_fun) decl -> - try - let witness = Int.Map.find i sub in - if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_annot decl, - witness, RelDecl.get_type decl, witness_fun)) - with Not_found -> - (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) - ) - 1 - (new_end_of_type,0,witness_fun) - context - in - let new_type_of_hyp = - Reductionops.nf_betaiota env sigma new_type_of_hyp in - let new_ctxt,new_end_of_type = - decompose_prod_n_assum sigma ctxt_size new_type_of_hyp - in - let prove_new_hyp : tactic = - tclTHEN - (tclDO ctxt_size (Proofview.V82.of_tactic intro)) - (fun g -> - let all_ids = pf_ids_of_hyps g in - let new_ids,_ = list_chop ctxt_size all_ids in - let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - let evm, _ = pf_apply Typing.type_of g to_refine in - tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g - ) - in - let simpl_eq_tac = - change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp - in -(* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) -(* str "removing an equation " ++ fnl ()++ *) -(* str "old_typ_of_hyp :=" ++ *) -(* Printer.pr_lconstr_env *) -(* env *) -(* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) -(* ++ fnl () ++ *) -(* str "new_typ_of_hyp := "++ *) -(* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) -(* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) -(* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) -(* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) -(* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) -(* ); *) - new_ctxt,new_end_of_type,simpl_eq_tac - - -let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = - if isApp sigma t_x - then - let pte,args = destApp sigma t_x in - if isVar sigma pte && Array.for_all (closed0 sigma) args - then + with Not_found -> + assert (closed0 sigma t1); + Int.Map.add t2 t1 sub ) + else if isAppConstruct sigma t1 && isAppConstruct sigma t2 then begin + let c1, args1 = find_rectype env sigma t1 + and c2, args2 = find_rectype env sigma t2 in + if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; + List.fold_left2 compute_substitution sub args1 args2 + end + else if eq_constr t1 t2 then sub + else + nochange + ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) + "cannot solve (diff)" + in + let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in + let sub = compute_substitution sub (fst t1) (fst t2) in + let end_of_type_with_pop = pop end_of_type in + (*the equation will be removed *) + let new_end_of_type = + (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 + Can be safely replaced by the next comment for Ocaml >= 3.08.4 + *) + let sub = Int.Map.bindings sub in + List.fold_left + (fun end_of_type (i, t) -> liftn 1 i (substnl [t] (i - 1) end_of_type)) + end_of_type_with_pop sub + in + let old_context_length = List.length context + 1 in + let witness_fun = + mkLetIn + ( make_annot Anonymous Sorts.Relevant + , make_refl_eq constructor t1_typ (fst t1) + , t + , mkApp + ( mkVar hyp_id + , Array.init old_context_length (fun i -> + mkRel (old_context_length - i)) ) ) + in + let new_type_of_hyp, ctxt_size, witness_fun = + List.fold_left_i + (fun i (end_of_type, ctxt_size, witness_fun) decl -> + try + let witness = Int.Map.find i sub in + if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); + ( pop end_of_type + , ctxt_size + , mkLetIn + ( RelDecl.get_annot decl + , witness + , RelDecl.get_type decl + , witness_fun ) ) + with Not_found -> + ( mkProd_or_LetIn decl end_of_type + , ctxt_size + 1 + , mkLambda_or_LetIn decl witness_fun )) + 1 + (new_end_of_type, 0, witness_fun) + context + in + let new_type_of_hyp = Reductionops.nf_betaiota env sigma new_type_of_hyp in + let new_ctxt, new_end_of_type = + decompose_prod_n_assum sigma ctxt_size new_type_of_hyp + in + let prove_new_hyp : tactic = + tclTHEN + (tclDO ctxt_size (Proofview.V82.of_tactic intro)) + (fun g -> + let all_ids = pf_ids_of_hyps g in + let new_ids, _ = list_chop ctxt_size all_ids in + let to_refine = applist (witness_fun, List.rev_map mkVar new_ids) in + let evm, _ = pf_apply Typing.type_of g to_refine in + tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g) + in + let simpl_eq_tac = + change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp + prove_new_hyp + in + (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) + (* str "removing an equation " ++ fnl ()++ *) + (* str "old_typ_of_hyp :=" ++ *) + (* Printer.pr_lconstr_env *) + (* env *) + (* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) + (* ++ fnl () ++ *) + (* str "new_typ_of_hyp := "++ *) + (* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) + (* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) + (* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) + (* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) + (* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) + (* ); *) + (new_ctxt, new_end_of_type, simpl_eq_tac) + +let is_property sigma (ptes_info : ptes_info) t_x full_type_of_hyp = + if isApp sigma t_x then + let pte, args = destApp sigma t_x in + if isVar sigma pte && Array.for_all (closed0 sigma) args then try let info = Id.Map.find (destVar sigma pte) ptes_info in info.is_valid full_type_of_hyp @@ -297,19 +282,13 @@ let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = else false let isLetIn sigma t = - match EConstr.kind sigma t with - | LetIn _ -> true - | _ -> false - + match EConstr.kind sigma t with LetIn _ -> true | _ -> false let h_reduce_with_zeta cl = - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) cl) - - + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + cl) let rewrite_until_var arg_num eq_ids : tactic = (* tests if the declares recursive argument is neither a Constructor nor @@ -318,268 +297,247 @@ let rewrite_until_var arg_num eq_ids : tactic = *) let test_var g = let sigma = project g in - let _,args = destApp sigma (pf_concl g) in - not ((isConstruct sigma args.(arg_num)) || isAppConstruct sigma args.(arg_num)) + let _, args = destApp sigma (pf_concl g) in + not (isConstruct sigma args.(arg_num) || isAppConstruct sigma args.(arg_num)) in - let rec do_rewrite eq_ids g = - if test_var g - then tclIDTAC g + let rec do_rewrite eq_ids g = + if test_var g then tclIDTAC g else match eq_ids with - | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property."); - | eq_id::eq_ids -> - tclTHEN - (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) - (do_rewrite eq_ids) - g + | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property.") + | eq_id :: eq_ids -> + tclTHEN + (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) + (do_rewrite eq_ids) g in do_rewrite eq_ids - let rec_pte_id = Id.of_string "Hrec" + let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type") in - let coq_True = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.type") in - let coq_I = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in - let rec scan_type context type_of_hyp : tactic = + let coq_False = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type") + in + let coq_True = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.type") + in + let coq_I = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") + in + let rec scan_type context type_of_hyp : tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in - let reduced_type_of_hyp = Reductionops.nf_betaiotazeta env sigma real_type_of_hyp in + let reduced_type_of_hyp = + Reductionops.nf_betaiotazeta env sigma real_type_of_hyp + in (* length of context didn't change ? *) - let new_context,new_typ_of_hyp = - decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp + let new_context, new_typ_of_hyp = + decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp in + tclTHENLIST + [ h_reduce_with_zeta (Locusops.onHyp hyp_id) + ; scan_type new_context new_typ_of_hyp ] + else if isProd sigma type_of_hyp then + let x, t_x, t' = destProd sigma type_of_hyp in + let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in + if is_property sigma ptes_infos t_x actual_real_type_of_hyp then + let pte, pte_args = destApp sigma t_x in + let (* fix_info *) prove_rec_hyp = + (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac + in + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let prove_new_type_of_hyp = + let context_length = List.length context in + tclTHENLIST + [ tclDO context_length (Proofview.V82.of_tactic intro) + ; (fun g -> + let context_hyps_ids = + fst + (list_chop ~msg:"rec hyp : context_hyps" context_length + (pf_ids_of_hyps g)) + in + let rec_pte_id = pf_get_new_id rec_pte_id g in + let to_refine = + applist + ( mkVar hyp_id + , List.rev_map mkVar (rec_pte_id :: context_hyps_ids) ) + in + (* observe_tac "rec hyp " *) + (tclTHENS + (Proofview.V82.of_tactic + (assert_before (Name rec_pte_id) t_x)) + [ (* observe_tac "prove rec hyp" *) + prove_rec_hyp eq_hyps + ; (* observe_tac "prove rec hyp" *) + refine to_refine ]) + g) ] + in tclTHENLIST - [ h_reduce_with_zeta (Locusops.onHyp hyp_id); - scan_type new_context new_typ_of_hyp ] - else if isProd sigma type_of_hyp - then - begin - let (x,t_x,t') = destProd sigma type_of_hyp in - let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in - if is_property sigma ptes_infos t_x actual_real_type_of_hyp then - begin - let pte,pte_args = (destApp sigma t_x) in - let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac in - let popped_t' = pop t' in - let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in - let prove_new_type_of_hyp = - let context_length = List.length context in - tclTHENLIST - [ - tclDO context_length (Proofview.V82.of_tactic intro); - (fun g -> - let context_hyps_ids = - fst (list_chop ~msg:"rec hyp : context_hyps" - context_length (pf_ids_of_hyps g)) - in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = - applist(mkVar hyp_id, - List.rev_map mkVar (rec_pte_id::context_hyps_ids) - ) - in -(* observe_tac "rec hyp " *) - (tclTHENS - (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) - [ - (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); -(* observe_tac "prove rec hyp" *) - (refine to_refine) - ]) - g - ) - ] - in - tclTHENLIST - [ -(* observe_tac "hyp rec" *) - (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); - scan_type context popped_t' - ] - end - else if eq_constr sigma t_x coq_False then - begin -(* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) -(* str " since it has False in its preconds " *) -(* ); *) - raise TOREMOVE; (* False -> .. useless *) - end - else if is_incompatible_eq env sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) - else if eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) - then -(* observe (str "In "++Ppconstr.pr_id hyp_id++ *) -(* str " removing useless precond True" *) -(* ); *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context - in - let prove_trivial = - let nb_intro = List.length context in - tclTHENLIST [ - tclDO nb_intro (Proofview.V82.of_tactic intro); - (fun g -> - let context_hyps = - fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) - in - let to_refine = - applist (mkVar hyp_id, - List.rev (coq_I::List.map mkVar context_hyps) - ) - in - refine to_refine g - ) - ] - in - tclTHENLIST[ - change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp - ((* observe_tac "prove_trivial" *) prove_trivial); - scan_type context popped_t' - ] - else if is_trivial_eq sigma t_x - then (* t_x := t = t => we remove this precond *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context - in - let hd,args = destApp sigma t_x in - let get_args hd args = - if eq_constr sigma hd (Lazy.force eq) - then (Lazy.force refl_equal,args.(0),args.(1)) - else (jmeq_refl (),args.(0),args.(1)) - in + [ (* observe_tac "hyp rec" *) + change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp + prove_new_type_of_hyp + ; scan_type context popped_t' ] + else if eq_constr sigma t_x coq_False then + (* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) + (* str " since it has False in its preconds " *) + (* ); *) + raise TOREMOVE (* False -> .. useless *) + else if is_incompatible_eq env sigma t_x then raise TOREMOVE + (* t_x := C1 ... = C2 ... *) + else if + eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) + then + (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) + (* str " removing useless precond True" *) + (* ); *) + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let prove_trivial = + let nb_intro = List.length context in tclTHENLIST - [ - change_hyp_with_using - "prove_trivial_eq" - hyp_id - real_type_of_hyp - ((* observe_tac "prove_trivial_eq" *) - (prove_trivial_eq hyp_id context (get_args hd args))); - scan_type context popped_t' - ] - else - begin - try - let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in - tclTHEN - tac - (scan_type new_context new_t') - with NoChange -> - (* Last thing todo : push the rel in the context and continue *) - scan_type (LocalAssum (x,t_x) :: context) t' - end - end - else - tclIDTAC - in - try - scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id] - with TOREMOVE -> - thin [hyp_id],[] - - -let clean_goal_with_heq ptes_infos continue_tac (dyn_infos:body_info) = - fun g -> - let env = pf_env g - and sigma = project g - in - let tac,new_hyps = - List.fold_left ( - fun (hyps_tac,new_hyps) hyp_id -> - let hyp_tac,new_hyp = - clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + [ tclDO nb_intro (Proofview.V82.of_tactic intro) + ; (fun g -> + let context_hyps = + fst + (list_chop ~msg:"removing True : context_hyps " nb_intro + (pf_ids_of_hyps g)) + in + let to_refine = + applist + ( mkVar hyp_id + , List.rev (coq_I :: List.map mkVar context_hyps) ) + in + refine to_refine g) ] + in + tclTHENLIST + [ change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp + (* observe_tac "prove_trivial" *) prove_trivial + ; scan_type context popped_t' ] + else if is_trivial_eq sigma t_x then + (* t_x := t = t => we remove this precond *) + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let hd, args = destApp sigma t_x in + let get_args hd args = + if eq_constr sigma hd (Lazy.force eq) then + (Lazy.force refl_equal, args.(0), args.(1)) + else (jmeq_refl (), args.(0), args.(1)) + in + tclTHENLIST + [ change_hyp_with_using "prove_trivial_eq" hyp_id real_type_of_hyp + ((* observe_tac "prove_trivial_eq" *) + prove_trivial_eq hyp_id context (get_args hd args)) + ; scan_type context popped_t' ] + else + try + let new_context, new_t', tac = + change_eq env sigma hyp_id context x t_x t' in - (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps - ) - (tclIDTAC,[]) - dyn_infos.rec_hyps - in - let new_infos = - { dyn_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in - tclTHENLIST - [ - tac ; - (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) - ] - g + tclTHEN tac (scan_type new_context new_t') + with NoChange -> + (* Last thing todo : push the rel in the context and continue *) + scan_type (LocalAssum (x, t_x) :: context) t' + else tclIDTAC + in + try (scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id]) + with TOREMOVE -> (thin [hyp_id], []) + +let clean_goal_with_heq ptes_infos continue_tac (dyn_infos : body_info) g = + let env = pf_env g and sigma = project g in + let tac, new_hyps = + List.fold_left + (fun (hyps_tac, new_hyps) hyp_id -> + let hyp_tac, new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + in + (tclTHEN hyp_tac hyps_tac, new_hyp @ new_hyps)) + (tclIDTAC, []) dyn_infos.rec_hyps + in + let new_infos = + {dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps} + in + tclTHENLIST + [tac; (* observe_tac "clean_hyp_with_heq continue" *) continue_tac new_infos] + g let heq_id = Id.of_string "Heq" -let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = - fun g -> - let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in - tclTHENLIST - [ - (* We first introduce the variables *) - tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))); - (* Then the equation itself *) - Proofview.V82.of_tactic (intro_using heq_id); - onLastHypId (fun heq_id -> tclTHENLIST [ - (* Then the new hypothesis *) - tclMAP (fun id -> Proofview.V82.of_tactic (introduction id)) dyn_infos.rec_hyps; - observe_tac "after_introduction" (fun g' -> - (* We get infos on the equations introduced*) - let new_term_value_eq = pf_get_hyp_typ g' heq_id in - (* compute the new value of the body *) - let new_term_value = - match EConstr.kind (project g') new_term_value_eq with - | App(f,[| _;_;args2 |]) -> args2 - | _ -> - observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ - pr_leconstr_env (pf_env g') (project g') new_term_value_eq - ); - anomaly (Pp.str "cannot compute new term value.") - in - let g', termtyp = tac_type_of g' term in - let fun_body = - mkLambda(make_annot Anonymous Sorts.Relevant, - termtyp, - Termops.replace_term (project g') term (mkRel 1) dyn_infos.info - ) - in - let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in - let new_infos = - {dyn_infos with - info = new_body; - eq_hyps = heq_id::dyn_infos.eq_hyps - } - in - clean_goal_with_heq ptes_infos continue_tac new_infos g' - )]) - ] - g - +let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos g = + let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in + tclTHENLIST + [ (* We first introduce the variables *) + tclDO nb_first_intro + (Proofview.V82.of_tactic + (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))) + ; (* Then the equation itself *) + Proofview.V82.of_tactic (intro_using heq_id) + ; onLastHypId (fun heq_id -> + tclTHENLIST + [ (* Then the new hypothesis *) + tclMAP + (fun id -> Proofview.V82.of_tactic (introduction id)) + dyn_infos.rec_hyps + ; observe_tac "after_introduction" (fun g' -> + (* We get infos on the equations introduced*) + let new_term_value_eq = pf_get_hyp_typ g' heq_id in + (* compute the new value of the body *) + let new_term_value = + match EConstr.kind (project g') new_term_value_eq with + | App (f, [|_; _; args2|]) -> args2 + | _ -> + observe + ( str "cannot compute new term value : " + ++ pr_gls g' ++ fnl () ++ str "last hyp is" + ++ pr_leconstr_env (pf_env g') (project g') + new_term_value_eq ); + anomaly (Pp.str "cannot compute new term value.") + in + let g', termtyp = tac_type_of g' term in + let fun_body = + mkLambda + ( make_annot Anonymous Sorts.Relevant + , termtyp + , Termops.replace_term (project g') term (mkRel 1) + dyn_infos.info ) + in + let new_body = + pf_nf_betaiota g' (mkApp (fun_body, [|new_term_value|])) + in + let new_infos = + { dyn_infos with + info = new_body + ; eq_hyps = heq_id :: dyn_infos.eq_hyps } + in + clean_goal_with_heq ptes_infos continue_tac new_infos g') ]) + ] + g let my_orelse tac1 tac2 g = - try - tac1 g + try tac1 g with e when CErrors.noncritical e -> -(* observe (str "using snd tac since : " ++ CErrors.print e); *) + (* observe (str "using snd tac since : " ++ CErrors.print e); *) tac2 g -let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = - let args = Array.of_list (List.map mkVar args_id) in +let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = + let args = Array.of_list (List.map mkVar args_id) in let instantiate_one_hyp hid = my_orelse - ( (* we instantiate the hyp if possible *) - fun g -> - let prov_hid = pf_get_new_id hid g in - let c = mkApp(mkVar hid,args) in - let evm, _ = pf_apply Typing.type_of g c in - tclTHENLIST[ - Refiner.tclEVARS evm; - Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); - thin [hid]; - Proofview.V82.of_tactic (rename_hyp [prov_hid,hid]) - ] g - ) - ( (* + (fun (* we instantiate the hyp if possible *) + g -> + let prov_hid = pf_get_new_id hid g in + let c = mkApp (mkVar hid, args) in + let evm, _ = pf_apply Typing.type_of g c in + tclTHENLIST + [ Refiner.tclEVARS evm + ; Proofview.V82.of_tactic (pose_proof (Name prov_hid) c) + ; thin [hid] + ; Proofview.V82.of_tactic (rename_hyp [(prov_hid, hid)]) ] + g) + (fun (* if not then we are in a mutual function block and this hyp is a recursive hyp on an other function. @@ -587,350 +545,314 @@ let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = principle so that we can trash it *) - (fun g -> -(* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) - thin [hid] g - ) - ) + g -> + (* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) + thin [hid] g) in - if List.is_empty args_id - then - tclTHENLIST [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; - do_prove hyps - ] + if List.is_empty args_id then + tclTHENLIST + [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps + ; do_prove hyps ] else tclTHENLIST - [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; - tclMAP instantiate_one_hyp hyps; - (fun g -> - let all_g_hyps_id = - List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty - in - let remaining_hyps = - List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps - in - do_prove remaining_hyps g - ) - ] + [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps + ; tclMAP instantiate_one_hyp hyps + ; (fun g -> + let all_g_hyps_id = + List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty + in + let remaining_hyps = + List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps + in + do_prove remaining_hyps g) ] -let build_proof - (interactive_proof:bool) - (fnames:Constant.t list) - ptes_infos - dyn_infos - : tactic = +let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos + dyn_infos : tactic = let rec build_proof_aux do_finalize dyn_infos : tactic = - fun g -> - let env = pf_env g in - let sigma = project g in -(* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match EConstr.kind sigma dyn_infos.info with - | Case(ci,ct,t,cb) -> - let do_finalize_t dyn_info' = - fun g -> - let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = - mkCase(ci,ct,t,cb)} in - let g_nb_prod = nb_prod (project g) (pf_concl g) in - let g, type_of_term = tac_type_of g t in - let term_eq = - make_refl_eq (Lazy.force refl_equal) type_of_term t - in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps))); - thin dyn_infos.rec_hyps; - Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); - (fun g -> observe_tac "toto" ( - tclTHENLIST [Proofview.V82.of_tactic (Simple.case t); - (fun g' -> - let g'_nb_prod = nb_prod (project g') (pf_concl g') in - let nb_instantiate_partial = g'_nb_prod - g_nb_prod in - observe_tac "treat_new_case" - (treat_new_case - ptes_infos - nb_instantiate_partial - (build_proof do_finalize) - t - dyn_infos) - g' - ) - - ]) g - ) - ] - g - in - build_proof do_finalize_t {dyn_infos with info = t} g - | Lambda(n,t,b) -> - begin - match EConstr.kind sigma (pf_concl g) with - | Prod _ -> - tclTHEN - (Proofview.V82.of_tactic intro) - (fun g' -> - let open Context.Named.Declaration in - let id = pf_last_hyp g' |> get_id in - let new_term = - pf_nf_betaiota g' - (mkApp(dyn_infos.info,[|mkVar id|])) - in - let new_infos = {dyn_infos with info = new_term} in - let do_prove new_hyps = - build_proof do_finalize - {new_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in -(* observe_tac "Lambda" *) (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' - (* build_proof do_finalize new_infos g' *) - ) g - | _ -> - do_finalize dyn_infos g - end - | Cast(t,_,_) -> - build_proof do_finalize {dyn_infos with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ | Float _ -> - do_finalize dyn_infos g - | App(_,_) -> - let f,args = decompose_app sigma dyn_infos.info in - begin - match EConstr.kind sigma f with - | Int _ -> user_err Pp.(str "integer cannot be applied") - | Float _ -> user_err Pp.(str "float cannot be applied") - | App _ -> assert false (* we have collected all the app in decompose_app *) - | Proj _ -> assert false (*FIXME*) - | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in - build_proof_args env sigma do_finalize new_infos g - | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in -(* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) - build_proof_args env sigma do_finalize new_infos g - | Const _ -> - do_finalize dyn_infos g - | Lambda _ -> - let new_term = - Reductionops.nf_beta env sigma dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} - g - | LetIn _ -> - let new_infos = - { dyn_infos with info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> - h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos - ] - g - | Cast(b,_,_) -> - build_proof do_finalize {dyn_infos with info = b } g - | Case _ | Fix _ | CoFix _ -> - let new_finalize dyn_infos = - let new_infos = - { dyn_infos with - info = dyn_infos.info,args - } - in - build_proof_args env sigma do_finalize new_infos - in - build_proof new_finalize {dyn_infos with info = f } g - end - | Fix _ | CoFix _ -> - user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) - - - | Proj _ -> user_err Pp.(str "Prod") - | Prod _ -> do_finalize dyn_infos g - | LetIn _ -> - let new_infos = - { dyn_infos with - info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info - } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos - ] g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - and build_proof do_finalize dyn_infos g = -(* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - Indfun_common.observe_tac (fun env sigma -> - str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g - and build_proof_args env sigma do_finalize dyn_infos (* f_args' args *) :tactic = - fun g -> - let (f_args',args) = dyn_infos.info in - let tac : tactic = - fun g -> - match args with - | [] -> - do_finalize {dyn_infos with info = f_args'} g - | arg::args -> - (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) - (* fnl () ++ *) - (* pr_goal (Tacmach.sig_it g) *) - (* ); *) - let do_finalize dyn_infos = - let new_arg = dyn_infos.info in - (* tclTRYD *) - (build_proof_args env sigma - do_finalize - {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} - ) - in + fun g -> + let env = pf_env g in + let sigma = project g in + (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) + match EConstr.kind sigma dyn_infos.info with + | Case (ci, ct, t, cb) -> + let do_finalize_t dyn_info' g = + let t = dyn_info'.info in + let dyn_infos = {dyn_info' with info = mkCase (ci, ct, t, cb)} in + let g_nb_prod = nb_prod (project g) (pf_concl g) in + let g, type_of_term = tac_type_of g t in + let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in + tclTHENLIST + [ Proofview.V82.of_tactic + (generalize (term_eq :: List.map mkVar dyn_infos.rec_hyps)) + ; thin dyn_infos.rec_hyps + ; Proofview.V82.of_tactic + (pattern_option [(Locus.AllOccurrencesBut [1], t)] None) + ; (fun g -> + observe_tac "toto" + (tclTHENLIST + [ Proofview.V82.of_tactic (Simple.case t) + ; (fun g' -> + let g'_nb_prod = nb_prod (project g') (pf_concl g') in + let nb_instantiate_partial = g'_nb_prod - g_nb_prod in + observe_tac "treat_new_case" + (treat_new_case ptes_infos nb_instantiate_partial + (build_proof do_finalize) t dyn_infos) + g') ]) + g) ] + g + in + build_proof do_finalize_t {dyn_infos with info = t} g + | Lambda (n, t, b) -> ( + match EConstr.kind sigma (pf_concl g) with + | Prod _ -> + tclTHEN + (Proofview.V82.of_tactic intro) + (fun g' -> + let open Context.Named.Declaration in + let id = pf_last_hyp g' |> get_id in + let new_term = + pf_nf_betaiota g' (mkApp (dyn_infos.info, [|mkVar id|])) + in + let new_infos = {dyn_infos with info = new_term} in + let do_prove new_hyps = build_proof do_finalize - {dyn_infos with info = arg } - g + { new_infos with + rec_hyps = new_hyps + ; nb_rec_hyps = List.length new_hyps } + in + (* observe_tac "Lambda" *) + (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' + (* build_proof do_finalize new_infos g' *)) + g + | _ -> do_finalize dyn_infos g ) + | Cast (t, _, _) -> build_proof do_finalize {dyn_infos with info = t} g + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ + |Float _ -> + do_finalize dyn_infos g + | App (_, _) -> ( + let f, args = decompose_app sigma dyn_infos.info in + match EConstr.kind sigma f with + | Int _ -> user_err Pp.(str "integer cannot be applied") + | Float _ -> user_err Pp.(str "float cannot be applied") + | App _ -> + assert false (* we have collected all the app in decompose_app *) + | Proj _ -> assert false (*FIXME*) + | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ + -> + let new_infos = {dyn_infos with info = (f, args)} in + build_proof_args env sigma do_finalize new_infos g + | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> + let new_infos = {dyn_infos with info = (f, args)} in + (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) + build_proof_args env sigma do_finalize new_infos g + | Const _ -> do_finalize dyn_infos g + | Lambda _ -> + let new_term = Reductionops.nf_beta env sigma dyn_infos.info in + build_proof do_finalize {dyn_infos with info = new_term} g + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } + in + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + g + | Cast (b, _, _) -> build_proof do_finalize {dyn_infos with info = b} g + | Case _ | Fix _ | CoFix _ -> + let new_finalize dyn_infos = + let new_infos = {dyn_infos with info = (dyn_infos.info, args)} in + build_proof_args env sigma do_finalize new_infos + in + build_proof new_finalize {dyn_infos with info = f} g ) + | Fix _ | CoFix _ -> + user_err Pp.(str "Anonymous local (co)fixpoints are not handled yet") + | Proj _ -> user_err Pp.(str "Prod") + | Prod _ -> do_finalize dyn_infos g + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } in - (* observe_tac "build_proof_args" *) (tac ) g + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + g + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + and build_proof do_finalize dyn_infos g = + (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) + Indfun_common.observe_tac + (fun env sigma -> + str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info) + (build_proof_aux do_finalize dyn_infos) + g + and build_proof_args env sigma do_finalize dyn_infos : tactic = + (* f_args' args *) + fun g -> + let f_args', args = dyn_infos.info in + let tac : tactic = + fun g -> + match args with + | [] -> do_finalize {dyn_infos with info = f_args'} g + | arg :: args -> + (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) + (* fnl () ++ *) + (* pr_goal (Tacmach.sig_it g) *) + (* ); *) + let do_finalize dyn_infos = + let new_arg = dyn_infos.info in + (* tclTRYD *) + build_proof_args env sigma do_finalize + {dyn_infos with info = (mkApp (f_args', [|new_arg|]), args)} + in + build_proof do_finalize {dyn_infos with info = arg} g + in + (* observe_tac "build_proof_args" *) tac g in let do_finish_proof dyn_infos = - (* tclTRYD *) (clean_goal_with_heq - ptes_infos - finish_proof dyn_infos) + (* tclTRYD *) clean_goal_with_heq ptes_infos finish_proof dyn_infos in - (* observe_tac "build_proof" *) + (* observe_tac "build_proof" *) fun g -> build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g - (* Proof of principles from structural functions *) type static_fix_info = - { - idx : int; - name : Id.t; - types : types; - offset : int; - nb_realargs : int; - body_with_param : constr; - num_in_block : int - } - - - -let prove_rec_hyp_for_struct fix_info = - (fun eq_hyps -> tclTHEN - (rewrite_until_var (fix_info.idx) eq_hyps) - (fun g -> - let _,pte_args = destApp (project g) (pf_concl g) in - let rec_hyp_proof = - mkApp(mkVar fix_info.name,array_get_start pte_args) - in - refine rec_hyp_proof g - )) + { idx : int + ; name : Id.t + ; types : types + ; offset : int + ; nb_realargs : int + ; body_with_param : constr + ; num_in_block : int } + +let prove_rec_hyp_for_struct fix_info eq_hyps = + tclTHEN (rewrite_until_var fix_info.idx eq_hyps) (fun g -> + let _, pte_args = destApp (project g) (pf_concl g) in + let rec_hyp_proof = + mkApp (mkVar fix_info.name, array_get_start pte_args) + in + refine rec_hyp_proof g) -let prove_rec_hyp fix_info = - { proving_tac = prove_rec_hyp_for_struct fix_info - ; - is_valid = fun _ -> true - } +let prove_rec_hyp fix_info = + {proving_tac = prove_rec_hyp_for_struct fix_info; is_valid = (fun _ -> true)} let generalize_non_dep hyp g = -(* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) + (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in let hyp_typ = pf_get_hyp_typ g hyp in - let to_revert,_ = + let to_revert, _ = let open Context.Named.Declaration in - Environ.fold_named_context_reverse (fun (clear,keep) decl -> - let decl = map_named_decl EConstr.of_constr decl in - let hyp = get_id decl in - if Id.List.mem hyp hyps - || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep - || Termops.occur_var env (project g) hyp hyp_typ - || Termops.is_section_variable hyp (* should be dangerous *) - then (clear,decl::keep) - else (hyp::clear,keep)) - ~init:([],[]) (pf_env g) + Environ.fold_named_context_reverse + (fun (clear, keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in + let hyp = get_id decl in + if + Id.List.mem hyp hyps + || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep + || Termops.occur_var env (project g) hyp hyp_typ + || Termops.is_section_variable hyp + (* should be dangerous *) + then (clear, decl :: keep) + else (hyp :: clear, keep)) + ~init:([], []) (pf_env g) in -(* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) + (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN - ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map mkVar to_revert) ))) - ((* observe_tac "thin" *) (thin to_revert)) + ((* observe_tac "h_generalize" *) Proofview.V82.of_tactic + (generalize (List.map mkVar to_revert))) + ((* observe_tac "thin" *) thin to_revert) g let id_of_decl = RelDecl.get_name %> Nameops.Name.get_id let var_of_decl = id_of_decl %> mkVar + let revert idl = - tclTHEN - (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) - (thin idl) + tclTHEN (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) (thin idl) -let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = -(* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) -(* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) -(* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) +let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num + = + (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) + (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) + (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) let f_def = Global.lookup_constant (fst (destConst evd f)) in - let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in - let (f_body, _, _) = Option.get (Global.body_of_constant_body Library.indirect_accessor f_def) in + let eq_lhs = + mkApp + ( f + , Array.init (nb_params + nb_args) (fun i -> + mkRel (nb_params + nb_args - i)) ) + in + let f_body, _, _ = + Option.get (Global.body_of_constant_body Library.indirect_accessor f_def) + in let f_body = EConstr.of_constr f_body in - let params,f_body_with_params = decompose_lam_n evd nb_params f_body in - let (_,num),(_,_,bodies) = destFix evd f_body_with_params in + let params, f_body_with_params = decompose_lam_n evd nb_params f_body in + let (_, num), (_, _, bodies) = destFix evd f_body_with_params in let fnames_with_params = - let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in - let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in + let params = Array.init nb_params (fun i -> mkRel (nb_params - i)) in + let fnames = + List.rev (Array.to_list (Array.map (fun f -> mkApp (f, params)) fnames)) + in fnames in -(* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) -(* observe (str "body " ++ pr_lconstr bodies.(num)); *) - let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in -(* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) - let eq_rhs = Reductionops.nf_betaiotazeta (Global.env ()) evd (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in + (* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) + (* observe (str "body " ++ pr_lconstr bodies.(num)); *) + let f_body_with_params_and_other_fun = + substl fnames_with_params bodies.(num) + in + (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) + let eq_rhs = + Reductionops.nf_betaiotazeta (Global.env ()) evd + (mkApp + ( compose_lam params f_body_with_params_and_other_fun + , Array.init (nb_params + nb_args) (fun i -> + mkRel (nb_params + nb_args - i)) )) + in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) - let (type_ctxt,type_of_f),evd = - let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f - in - decompose_prod_n_assum evd - (nb_params + nb_args) t,evd + let (type_ctxt, type_of_f), evd = + let evd, t = Typing.type_of ~refresh:true (Global.env ()) evd f in + (decompose_prod_n_assum evd (nb_params + nb_args) t, evd) in - let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in + let eqn = mkApp (Lazy.force eq, [|type_of_f; eq_lhs; eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in (* Pp.msgnl (str "lemma type " ++ Printer.pr_lconstr lemma_type ++ fnl () ++ str "f_body " ++ Printer.pr_lconstr f_body); *) let f_id = Label.to_id (Constant.label (fst (destConst evd f))) in let prove_replacement = tclTHENLIST - [ - tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro); - observe_tac "" (fun g -> - let rec_id = pf_nth_hyp_id g 1 in - tclTHENLIST - [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); - observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); - (Proofview.V82.of_tactic intros_reflexivity)] g - ) - ] + [ tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro) + ; observe_tac "" (fun g -> + let rec_id = pf_nth_hyp_id g 1 in + tclTHENLIST + [ observe_tac "generalize_non_dep in generate_equation_lemma" + (generalize_non_dep rec_id) + ; observe_tac "h_case" + (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))) + ; Proofview.V82.of_tactic intros_reflexivity ] + g) ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) - let lemma = Lemmas.start_lemma ~name:(mk_equation_id f_id) ~poly:false evd lemma_type in - let lemma,_ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in + let lemma = + Lemmas.start_lemma ~name:(mk_equation_id f_id) ~poly:false evd lemma_type + in + let lemma, _ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent ~idopt:None + in evd -let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = +let do_replace (evd : Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num + all_funs g = let equation_lemma = try let finfos = @@ -939,376 +861,366 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a | Some finfos -> finfos in mkConst (Option.get finfos.equation_lemma) - with (Not_found | Option.IsNone as e) -> + with (Not_found | Option.IsNone) as e -> let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) - let equation_lemma_id = (mk_equation_id f_id) in - evd := generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; + let equation_lemma_id = mk_equation_id f_id in + evd := + generate_equation_lemma !evd all_funs f fun_num (List.length params) + (List.length rev_args_id) rec_arg_num; let _ = match e with - | Option.IsNone -> - let finfos = match find_Function_infos (fst (destConst !evd f)) with - | None -> raise Not_found - | Some finfos -> finfos - in - update_Function - {finfos with - equation_lemma = Some ( - match Nametab.locate (qualid_of_ident equation_lemma_id) with - | GlobRef.ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant.") - ) - } - | _ -> () + | Option.IsNone -> + let finfos = + match find_Function_infos (fst (destConst !evd f)) with + | None -> raise Not_found + | Some finfos -> finfos + in + update_Function + { finfos with + equation_lemma = + Some + ( match Nametab.locate (qualid_of_ident equation_lemma_id) with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } + | _ -> () in (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) - let evd',res = - Evd.fresh_global - (Global.env ()) !evd + let evd', res = + Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in - evd:=evd'; + evd := evd'; let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd res in evd := sigma; res in let nb_intro_to_do = nb_prod (project g) (pf_concl g) in - tclTHEN - (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) - ( - fun g' -> - let just_introduced = nLastDecls nb_intro_to_do g' in - let open Context.Named.Declaration in - let just_introduced_id = List.map get_id just_introduced in - tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) - (revert just_introduced_id) g' - ) - g + tclTHEN + (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) + (fun g' -> + let just_introduced = nLastDecls nb_intro_to_do g' in + let open Context.Named.Declaration in + let just_introduced_id = List.map get_id just_introduced in + tclTHEN + (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) + (revert just_introduced_id) + g') + g -let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnames all_funs _nparams : tactic = - fun g -> +let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num + fnames all_funs _nparams : tactic = + fun g -> let princ_type = pf_concl g in (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) (* Pp.msgnl (str "all_funs "); *) (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) - let princ_info = compute_elim_sig (project g) princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps g) in - (fun na -> - let new_id = - match na with - Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" - in - avoid := new_id :: !avoid; - (Name new_id) - ) - in - let fresh_decl = RelDecl.map_name fresh_id in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args - } - in - let get_body const = - match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let env = Global.env () in - let sigma = Evd.from_env env in - Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - env - sigma - (EConstr.of_constr body) - | None -> user_err Pp.(str "Cannot define a principle over an axiom ") - in - let fbody = get_body fnames.(fun_num) in - let f_ctxt,f_body = decompose_lam (project g) fbody in - let f_ctxt_length = List.length f_ctxt in - let diff_params = princ_info.nparams - f_ctxt_length in - let full_params,princ_params,fbody_with_full_params = - if diff_params > 0 - then - let princ_params,full_params = - list_chop diff_params princ_info.params - in - (full_params, (* real params *) - princ_params, (* the params of the principle which are not params of the function *) - substl (* function instantiated with real params *) - (List.map var_of_decl full_params) - f_body - ) - else - let f_ctxt_other,f_ctxt_params = - list_chop (- diff_params) f_ctxt in - let f_body = compose_lam f_ctxt_other f_body in - (princ_info.params, (* real params *) - [],(* all params are full params *) - substl (* function instantiated with real params *) - (List.map var_of_decl princ_info.params) - f_body - ) - in - observe (str "full_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - full_params - ); - observe (str "princ_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - princ_params - ); - observe (str "fbody_with_full_params := " ++ - pr_leconstr_env (Global.env ()) !evd fbody_with_full_params - ); - let all_funs_with_full_params = - Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs - in - let fix_offset = List.length princ_params in - let ptes_to_fix,infos = - match EConstr.kind (project g) fbody_with_full_params with - | Fix((idxs,i),(names,typess,bodies)) -> - let bodies_with_all_params = - Array.map - (fun body -> - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, - List.rev_map var_of_decl princ_params)) - ) - bodies + let princ_info = compute_elim_sig (project g) princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps g) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id + in + let fresh_decl = RelDecl.map_name fresh_id in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } + in + let get_body const = + match Global.body_of_constant Library.indirect_accessor const with + | Some (body, _, _) -> + let env = Global.env () in + let sigma = Evd.from_env env in + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + env sigma (EConstr.of_constr body) + | None -> user_err Pp.(str "Cannot define a principle over an axiom ") + in + let fbody = get_body fnames.(fun_num) in + let f_ctxt, f_body = decompose_lam (project g) fbody in + let f_ctxt_length = List.length f_ctxt in + let diff_params = princ_info.nparams - f_ctxt_length in + let full_params, princ_params, fbody_with_full_params = + if diff_params > 0 then + let princ_params, full_params = list_chop diff_params princ_info.params in + ( full_params + , (* real params *) + princ_params + , (* the params of the principle which are not params of the function *) + substl (* function instantiated with real params *) + (List.map var_of_decl full_params) + f_body ) + else + let f_ctxt_other, f_ctxt_params = list_chop (-diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in + ( princ_info.params + , (* real params *) + [] + , (* all params are full params *) + substl (* function instantiated with real params *) + (List.map var_of_decl princ_info.params) + f_body ) + in + observe + ( str "full_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + full_params ); + observe + ( str "princ_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + princ_params ); + observe + ( str "fbody_with_full_params := " + ++ pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); + let all_funs_with_full_params = + Array.map + (fun f -> applist (f, List.rev_map var_of_decl full_params)) + all_funs + in + let fix_offset = List.length princ_params in + let ptes_to_fix, infos = + match EConstr.kind (project g) fbody_with_full_params with + | Fix ((idxs, i), (names, typess, bodies)) -> + let bodies_with_all_params = + Array.map + (fun body -> + Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( substl + (List.rev (Array.to_list all_funs_with_full_params)) + body + , List.rev_map var_of_decl princ_params ))) + bodies + in + let info_array = + Array.mapi + (fun i types -> + let types = + prod_applist (project g) types + (List.rev_map var_of_decl princ_params) in - let info_array = - Array.mapi - (fun i types -> - let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in - { idx = idxs.(i) - fix_offset; - name = Nameops.Name.get_id (fresh_id names.(i).binder_name); - types = types; - offset = fix_offset; - nb_realargs = - List.length - (fst (decompose_lam (project g) bodies.(i))) - fix_offset; - body_with_param = bodies_with_all_params.(i); - num_in_block = i - } - ) - typess + { idx = idxs.(i) - fix_offset + ; name = Nameops.Name.get_id (fresh_id names.(i).binder_name) + ; types + ; offset = fix_offset + ; nb_realargs = + List.length (fst (decompose_lam (project g) bodies.(i))) + - fix_offset + ; body_with_param = bodies_with_all_params.(i) + ; num_in_block = i }) + typess + in + let pte_to_fix, rev_info = + List.fold_left_i + (fun i (acc_map, acc_info) decl -> + let pte = RelDecl.get_name decl in + let infos = info_array.(i) in + let type_args, _ = decompose_prod (project g) infos.types in + let nargs = List.length type_args in + let f = + applist + (mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in - let pte_to_fix,rev_info = - List.fold_left_i - (fun i (acc_map,acc_info) decl -> - let pte = RelDecl.get_name decl in - let infos = info_array.(i) in - let type_args,_ = decompose_prod (project g) infos.types in - let nargs = List.length type_args in - let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in - let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in - let app_f = mkApp(f,first_args) in - let pte_args = (Array.to_list first_args)@[app_f] in - let app_pte = applist(mkVar (Nameops.Name.get_id pte),pte_args) in - let body_with_param,num = - let body = get_body fnames.(i) in - let body_with_full_params = - Reductionops.nf_betaiota (pf_env g) (project g) ( - applist(body,List.rev_map var_of_decl full_params)) - in - match EConstr.kind (project g) body_with_full_params with - | Fix((_,num),(_,_,bs)) -> - Reductionops.nf_betaiota (pf_env g) (project g) - ( - (applist - (substl - (List.rev - (Array.to_list all_funs_with_full_params)) - bs.(num), - List.rev_map var_of_decl princ_params)) - ),num - | _ -> user_err Pp.(str "Not a mutual block") - in - let info = - {infos with - types = compose_prod type_args app_pte; - body_with_param = body_with_param; - num_in_block = num - } - in -(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) -(* str " to " ++ Ppconstr.pr_id info.name); *) - (Id.Map.add (Nameops.Name.get_id pte) info acc_map,info::acc_info) - ) - 0 - (Id.Map.empty,[]) - (List.rev princ_info.predicates) + let first_args = Array.init nargs (fun i -> mkRel (nargs - i)) in + let app_f = mkApp (f, first_args) in + let pte_args = Array.to_list first_args @ [app_f] in + let app_pte = applist (mkVar (Nameops.Name.get_id pte), pte_args) in + let body_with_param, num = + let body = get_body fnames.(i) in + let body_with_full_params = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist (body, List.rev_map var_of_decl full_params)) + in + match EConstr.kind (project g) body_with_full_params with + | Fix ((_, num), (_, _, bs)) -> + ( Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( substl + (List.rev (Array.to_list all_funs_with_full_params)) + bs.(num) + , List.rev_map var_of_decl princ_params )) + , num ) + | _ -> user_err Pp.(str "Not a mutual block") in - pte_to_fix,List.rev rev_info - | _ -> - Id.Map.empty,[] - in - let mk_fixes : tactic = - let pre_info,infos = list_chop fun_num infos in - match pre_info,infos with - | _,[] -> tclIDTAC - | _, this_fix_info::others_infos -> - let other_fix_infos = - List.map - (fun fi -> fi.name,fi.idx + 1 ,fi.types) - (pre_info@others_infos) + let info = + { infos with + types = compose_prod type_args app_pte + ; body_with_param + ; num_in_block = num } in - if List.is_empty other_fix_infos - then - if this_fix_info.idx + 1 = 0 - then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) - else - Indfun_common.observe_tac (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx +1)) - (Proofview.V82.of_tactic (fix this_fix_info.name (this_fix_info.idx +1))) - else - Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) - other_fix_infos 0) - in - let first_tac : tactic = (* every operations until fix creations *) + (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) + (* str " to " ++ Ppconstr.pr_id info.name); *) + (Id.Map.add (Nameops.Name.get_id pte) info acc_map, info :: acc_info)) + 0 (Id.Map.empty, []) + (List.rev princ_info.predicates) + in + (pte_to_fix, List.rev rev_info) + | _ -> (Id.Map.empty, []) + in + let mk_fixes : tactic = + let pre_info, infos = list_chop fun_num infos in + match (pre_info, infos) with + | _, [] -> tclIDTAC + | _, this_fix_info :: others_infos -> + let other_fix_infos = + List.map + (fun fi -> (fi.name, fi.idx + 1, fi.types)) + (pre_info @ others_infos) + in + if List.is_empty other_fix_infos then + if this_fix_info.idx + 1 = 0 then tclIDTAC + (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) + else + Indfun_common.observe_tac + (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx + 1)) + (Proofview.V82.of_tactic + (fix this_fix_info.name (this_fix_info.idx + 1))) + else + Proofview.V82.of_tactic + (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) + other_fix_infos 0) + in + let first_tac : tactic = + (* every operations until fix creations *) + tclTHENLIST + [ observe_tac "introducing params" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.params))) + ; observe_tac "introducing predictes" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.predicates))) + ; observe_tac "introducing branches" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.branches))) + ; observe_tac "building fixes" mk_fixes ] + in + let intros_after_fixes : tactic = + fun gl -> + let ctxt, pte_app = decompose_prod_assum (project gl) (pf_concl gl) in + let pte, pte_args = decompose_app (project gl) pte_app in + try + let pte = + try destVar (project gl) pte + with DestKO -> anomaly (Pp.str "Property is not a variable.") + in + let fix_info = Id.Map.find pte ptes_to_fix in + let nb_args = fix_info.nb_realargs in tclTHENLIST - [ observe_tac "introducing params" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params))); - observe_tac "introducing predictes" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates))); - observe_tac "introducing branches" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches))); - observe_tac "building fixes" mk_fixes; - ] - in - let intros_after_fixes : tactic = - fun gl -> - let ctxt,pte_app = (decompose_prod_assum (project gl) (pf_concl gl)) in - let pte,pte_args = (decompose_app (project gl) pte_app) in - try - let pte = - try destVar (project gl) pte - with DestKO -> anomaly (Pp.str "Property is not a variable.") - in - let fix_info = Id.Map.find pte ptes_to_fix in - let nb_args = fix_info.nb_realargs in - tclTHENLIST - [ - (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro)); - (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let fix_body = fix_info.body_with_param in -(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(fix_body,List.rev_map mkVar args_id)); - eq_hyps = [] - } + [ (* observe_tac ("introducing args") *) + tclDO nb_args (Proofview.V82.of_tactic intro) + ; (fun g -> + (* replacement of the function by its body *) + let args = nLastDecls nb_args g in + let fix_body = fix_info.body_with_param in + (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist (fix_body, List.rev_map mkVar args_id)) + ; eq_hyps = [] } + in + tclTHENLIST + [ observe_tac "do_replace" + (do_replace evd full_params + (fix_info.idx + List.length princ_params) + ( args_id + @ List.map + (RelDecl.get_name %> Nameops.Name.get_id) + princ_params ) + all_funs.(fix_info.num_in_block) + fix_info.num_in_block all_funs) + ; (let do_prove = + build_proof interactive_proof (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) in - tclTHENLIST - [ - observe_tac "do_replace" - (do_replace evd - full_params - (fix_info.idx + List.length princ_params) - (args_id@(List.map (RelDecl.get_name %> Nameops.Name.get_id) princ_params)) - (all_funs.(fix_info.num_in_block)) - fix_info.num_in_block - all_funs - ); - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - observe_tac "cleaning" (clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos) - in -(* observe (str "branches := " ++ *) -(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) -(* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) - -(* ); *) - (* observe_tac "instancing" *) (instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) - ] - g - ); - ] gl - with Not_found -> - let nb_args = min (princ_info.nargs) (List.length ctxt) in - tclTHENLIST - [ - tclDO nb_args (Proofview.V82.of_tactic intro); - (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(fbody_with_full_params, - (List.rev_map var_of_decl princ_params)@ - (List.rev_map mkVar args_id) - )); - eq_hyps = [] - } + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + observe_tac "cleaning" + (clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos) in - let fname = destConst (project g) (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) in - tclTHENLIST - [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos - in - instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id) - ] - g - ) - ] - gl - in - tclTHEN - first_tac - intros_after_fixes - g - - - - - + (* observe (str "branches := " ++ *) + (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) + (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) + + (* ); *) + (* observe_tac "instancing" *) + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ] + g) ] + gl + with Not_found -> + let nb_args = min princ_info.nargs (List.length ctxt) in + tclTHENLIST + [ tclDO nb_args (Proofview.V82.of_tactic intro) + ; (fun g -> + (* replacement of the function by its body *) + let args = nLastDecls nb_args g in + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( fbody_with_full_params + , List.rev_map var_of_decl princ_params + @ List.rev_map mkVar args_id )) + ; eq_hyps = [] } + in + let fname = + destConst (project g) + (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) + in + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]) + ; (let do_prove = + build_proof interactive_proof (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos + in + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ] + g) ] + gl + in + tclTHEN first_tac intros_after_fixes g (* Proof of principles of general functions *) (* let hrec_id = Recdef.hrec_id *) @@ -1319,132 +1231,119 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (* and list_rewrite = Recdef.list_rewrite *) (* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *) - - - - let prove_with_tcc tcc_lemma_constr eqs : tactic = match !tcc_lemma_constr with | Undefined -> anomaly (Pp.str "No tcc proof !!") | Value lemma -> - fun gls -> -(* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) -(* let ids = hid::pf_ids_of_hyps gls in *) - tclTHENLIST - [ -(* generalize [lemma]; *) -(* h_intro hid; *) -(* Elim.h_decompose_and (mkVar hid); *) - tclTRY(list_rewrite true eqs); -(* (fun g -> *) -(* let ids' = pf_ids_of_hyps g in *) -(* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) -(* rewrite *) -(* ) *) - Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some [])) - ] - gls + fun gls -> + (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) + (* let ids = hid::pf_ids_of_hyps gls in *) + tclTHENLIST + [ (* generalize [lemma]; *) + (* h_intro hid; *) + (* Elim.h_decompose_and (mkVar hid); *) + tclTRY (list_rewrite true eqs) + ; (* (fun g -> *) + (* let ids' = pf_ids_of_hyps g in *) + (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) + (* rewrite *) + (* ) *) + Proofview.V82.of_tactic (Eauto.gen_eauto (false, 5) [] (Some [])) ] + gls | Not_needed -> tclIDTAC let backtrack_eqs_until_hrec hrec eqs : tactic = - fun gls -> - let eqs = List.map mkVar eqs in - let rewrite = - tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) - in - let _,hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in - let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in - let f = (fst (destApp (project gls) f_app)) in - let rec backtrack : tactic = - fun g -> - let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in - match EConstr.kind (project g) f_app with - | App(f',_) when eq_constr (project g) f' f -> tclIDTAC g - | _ -> tclTHEN rewrite backtrack g - in - backtrack gls - + fun gls -> + let eqs = List.map mkVar eqs in + let rewrite = + tclFIRST + (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs) + in + let _, hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in + let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in + let f = fst (destApp (project gls) f_app) in + let rec backtrack : tactic = + fun g -> + let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in + match EConstr.kind (project g) f_app with + | App (f', _) when eq_constr (project g) f' f -> tclIDTAC g + | _ -> tclTHEN rewrite backtrack g + in + backtrack gls let rec rewrite_eqs_in_eqs eqs = match eqs with - | [] -> tclIDTAC - | eq::eqs -> - - tclTHEN - (tclMAP - (fun id gl -> - observe_tac - (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) - (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences - true (* dep proofs also: *) true id (mkVar eq) false))) - gl - ) - eqs - ) - (rewrite_eqs_in_eqs eqs) + | [] -> tclIDTAC + | eq :: eqs -> + tclTHEN + (tclMAP + (fun id gl -> + observe_tac + (Format.sprintf "rewrite %s in %s " (Id.to_string eq) + (Id.to_string id)) + (tclTRY + (Proofview.V82.of_tactic + (Equality.general_rewrite_in true Locus.AllOccurrences true + (* dep proofs also: *) true id (mkVar eq) false))) + gl) + eqs) + (rewrite_eqs_in_eqs eqs) let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = - fun gls -> - (tclTHENLIST - [ - backtrack_eqs_until_hrec hrec eqs; - (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) - (tclTHENS (* We must have exactly ONE subgoal !*) - (Proofview.V82.of_tactic (apply (mkVar hrec))) - [ tclTHENLIST - [ - (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); - (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); - (fun g -> - if is_mes - then - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) g - else tclIDTAC g - ); - observe_tac "rew_and_finish" - (tclTHENLIST - [tclTRY(list_rewrite false (List.map (fun v -> (mkVar v,true)) eqs)); - observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); - (observe_tac "finishing using" - ( - tclCOMPLETE( - Proofview.V82.of_tactic @@ - Eauto.eauto_with_bases - (true,5) + fun gls -> + (tclTHENLIST + [ backtrack_eqs_until_hrec hrec eqs + ; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) + tclTHENS (* We must have exactly ONE subgoal !*) + (Proofview.V82.of_tactic (apply (mkVar hrec))) + [ tclTHENLIST + [ Proofview.V82.of_tactic (keep (tcc_hyps @ eqs)) + ; Proofview.V82.of_tactic (apply (Lazy.force acc_inv)) + ; (fun g -> + if is_mes then + Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , evaluable_of_global_reference + (delayed_force ltof_ref) ) ]) + g + else tclIDTAC g) + ; observe_tac "rew_and_finish" + (tclTHENLIST + [ tclTRY + (list_rewrite false + (List.map (fun v -> (mkVar v, true)) eqs)) + ; observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs) + ; observe_tac "finishing using" + (tclCOMPLETE + ( Proofview.V82.of_tactic + @@ Eauto.eauto_with_bases (true, 5) [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [Hints.Hint_db.empty TransparentState.empty false] - ) - ) - ) - ] - ) - ] - ]) - ]) - gls - + [ Hints.Hint_db.empty TransparentState.empty + false ] )) ]) ] ] ]) + gls let is_valid_hypothesis sigma predicates_name = - let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in + let predicates_name = + List.fold_right Id.Set.add predicates_name Id.Set.empty + in let is_pte typ = - if isApp sigma typ - then - let pte,_ = destApp sigma typ in - if isVar sigma pte - then Id.Set.mem (destVar sigma pte) predicates_name + if isApp sigma typ then + let pte, _ = destApp sigma typ in + if isVar sigma pte then Id.Set.mem (destVar sigma pte) predicates_name else false else false in let rec is_valid_hypothesis typ = - is_pte typ || - match EConstr.kind sigma typ with - | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' - | _ -> false + is_pte typ + || + match EConstr.kind sigma typ with + | Prod (_, pte, typ') -> is_pte pte && is_valid_hypothesis typ' + | _ -> false in is_valid_hypothesis -let prove_principle_for_gen - (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes +let prove_principle_for_gen (f_ref, functional_ref, eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation gl = let princ_type = pf_concl gl in let princ_info = compute_elim_sig (project gl) princ_type in @@ -1452,9 +1351,9 @@ let prove_principle_for_gen let avoid = ref (pf_ids_of_hyps gl) in fun na -> let new_id = - match na with - | Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; Name new_id @@ -1462,200 +1361,182 @@ let prove_principle_for_gen let fresh_decl = map_name fresh_id in let princ_info : elim_scheme = { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args - } + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } in let wf_tac = - if is_mes - then - (fun b -> - Proofview.V82.of_tactic @@ - Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None) + if is_mes then fun b -> + Proofview.V82.of_tactic + @@ Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None else fun _ -> prove_with_tcc tcc_lemma_ref [] in let real_rec_arg_num = rec_arg_num - princ_info.nparams in let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in -(* observe ( *) -(* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) -(* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) - -(* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) -(* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) -(* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) -(* str "npost_rec_arg := " ++ int npost_rec_arg ); *) - let (post_rec_arg,pre_rec_arg) = + (* observe ( *) + (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) + (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) + + (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) + (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) + (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) + (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) + let post_rec_arg, pre_rec_arg = Util.List.chop npost_rec_arg princ_info.args in let rec_arg_id = match List.rev post_rec_arg with - | (LocalAssum ({binder_name=Name id},_) | LocalDef ({binder_name=Name id},_,_)) :: _ -> id - | _ -> assert false + | ( LocalAssum ({binder_name = Name id}, _) + | LocalDef ({binder_name = Name id}, _, _) ) + :: _ -> + id + | _ -> assert false + in + (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) + let subst_constrs = + List.map + (get_name %> Nameops.Name.get_id %> mkVar) + (pre_rec_arg @ princ_info.params) in -(* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (get_name %> Nameops.Name.get_id %> mkVar) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in let wf_thm_id = Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) in let acc_rec_arg_id = - Nameops.Name.get_id (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) + Nameops.Name.get_id + (fresh_id (Name (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)))) in let revert l = - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l)) + tclTHEN + (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) + (Proofview.V82.of_tactic (clear l)) in let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = - ((* observe_tac "prove_rec_arg_acc" *) - (tclCOMPLETE - (tclTHEN - (Proofview.V82.of_tactic (assert_by (Name wf_thm_id) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)))) - ( - (* observe_tac *) -(* "apply wf_thm" *) - Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) - ) - ) - ) - ) + ((* observe_tac "prove_rec_arg_acc" *) + tclCOMPLETE + (tclTHEN + (Proofview.V82.of_tactic + (assert_by (Name wf_thm_id) + (mkApp (delayed_force well_founded, [|input_type; relation|])) + (Proofview.V82.tactic (fun g -> + (* observe_tac "prove wf" *) + (tclCOMPLETE (wf_tac is_mes)) g)))) + ((* observe_tac *) + (* "apply wf_thm" *) + Proofview.V82.of_tactic + (Tactics.Simple.apply + (mkApp (mkVar wf_thm_id, [|mkVar rec_arg_id|])))))) g in let args_ids = List.map (get_name %> Nameops.Name.get_id) princ_info.args in let lemma = match !tcc_lemma_ref with - | Undefined -> user_err Pp.(str "No tcc proof !!") - | Value lemma -> EConstr.of_constr lemma - | Not_needed -> EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") + | Undefined -> user_err Pp.(str "No tcc proof !!") + | Value lemma -> EConstr.of_constr lemma + | Not_needed -> + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in -(* let rec list_diff del_list check_list = *) -(* match del_list with *) -(* [] -> *) -(* [] *) -(* | f::r -> *) -(* if List.mem f check_list then *) -(* list_diff r check_list *) -(* else *) -(* f::(list_diff r check_list) *) -(* in *) + (* let rec list_diff del_list check_list = *) + (* match del_list with *) + (* [] -> *) + (* [] *) + (* | f::r -> *) + (* if List.mem f check_list then *) + (* list_diff r check_list *) + (* else *) + (* f::(list_diff r check_list) *) + (* in *) let tcc_list = ref [] in let start_tac gls = let hyps = pf_ids_of_hyps gls in - let hid = - next_ident_away_in_goal - (Id.of_string "prov") - (Id.Set.of_list hyps) - in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize [lemma]); - Proofview.V82.of_tactic (Simple.intro hid); - Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)); - (fun g -> - let new_hyps = pf_ids_of_hyps g in - tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps)); - if List.is_empty !tcc_list - then - begin - tcc_list := [hid]; - tclIDTAC g - end - else thin [hid] g - ) - ] - gls + let hid = + next_ident_away_in_goal (Id.of_string "prov") (Id.Set.of_list hyps) + in + tclTHENLIST + [ Proofview.V82.of_tactic (generalize [lemma]) + ; Proofview.V82.of_tactic (Simple.intro hid) + ; Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)) + ; (fun g -> + let new_hyps = pf_ids_of_hyps g in + tcc_list := List.rev (List.subtract Id.equal new_hyps (hid :: hyps)); + if List.is_empty !tcc_list then begin + tcc_list := [hid]; + tclIDTAC g + end + else thin [hid] g) ] + gls in tclTHENLIST - [ - observe_tac "start_tac" start_tac; - h_intros - (List.rev_map (get_name %> Nameops.Name.get_id) - (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) - ); - Proofview.V82.of_tactic - (assert_by - (Name acc_rec_arg_id) - (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) - (Proofview.V82.tactic prove_rec_arg_acc)); - (revert (List.rev (acc_rec_arg_id::args_ids))); - (Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1))); - h_intros (List.rev (acc_rec_arg_id::args_ids)); - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); - (fun gl' -> - let body = - let _,args = destApp (project gl') (pf_concl gl') in - Array.last args - in - let body_info rec_hyps = - { - nb_rec_hyps = List.length rec_hyps; - rec_hyps = rec_hyps; - eq_hyps = []; - info = body - } - in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in - let predicates_names = - List.map (get_name %> Nameops.Name.get_id) princ_info.predicates - in - let pte_info = - { proving_tac = - (fun eqs -> -(* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) -(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) -(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) -(* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) -(* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) - - (* observe_tac "new_prove_with_tcc" *) - (new_prove_with_tcc - is_mes acc_inv fix_id - - (!tcc_list@(List.map - (get_name %> Nameops.Name.get_id) - (princ_info.args@princ_info.params) - )@ ([acc_rec_arg_id])) eqs - ) - - ); - is_valid = is_valid_hypothesis (project gl') predicates_names - } - in - let ptes_info : pte_info Id.Map.t = - List.fold_left - (fun map pte_id -> - Id.Map.add pte_id - pte_info - map - ) - Id.Map.empty - predicates_names - in - let make_proof rec_hyps = - build_proof - false - [f_ref] - ptes_info - (body_info rec_hyps) - in - (* observe_tac "instantiate_hyps_with_args" *) - (instantiate_hyps_with_args - make_proof - (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) - (List.rev args_ids) - ) - gl' - ) - - ] + [ observe_tac "start_tac" start_tac + ; h_intros + (List.rev_map + (get_name %> Nameops.Name.get_id) + ( princ_info.args @ princ_info.branches @ princ_info.predicates + @ princ_info.params )) + ; Proofview.V82.of_tactic + (assert_by (Name acc_rec_arg_id) + (mkApp + (delayed_force acc_rel, [|input_type; relation; mkVar rec_arg_id|])) + (Proofview.V82.tactic prove_rec_arg_acc)) + ; revert (List.rev (acc_rec_arg_id :: args_ids)) + ; Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1)) + ; h_intros (List.rev (acc_rec_arg_id :: args_ids)) + ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)) + ; (fun gl' -> + let body = + let _, args = destApp (project gl') (pf_concl gl') in + Array.last args + in + let body_info rec_hyps = + { nb_rec_hyps = List.length rec_hyps + ; rec_hyps + ; eq_hyps = [] + ; info = body } + in + let acc_inv = + lazy + (mkApp + ( delayed_force acc_inv_id + , [|input_type; relation; mkVar rec_arg_id|] )) + in + let acc_inv = + lazy (mkApp (Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) + in + let predicates_names = + List.map (get_name %> Nameops.Name.get_id) princ_info.predicates + in + let pte_info = + { proving_tac = + (fun eqs -> + (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) + (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) + (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) + (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) + (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) + + (* observe_tac "new_prove_with_tcc" *) + new_prove_with_tcc is_mes acc_inv fix_id + ( !tcc_list + @ List.map + (get_name %> Nameops.Name.get_id) + (princ_info.args @ princ_info.params) + @ [acc_rec_arg_id] ) + eqs) + ; is_valid = is_valid_hypothesis (project gl') predicates_names } + in + let ptes_info : pte_info Id.Map.t = + List.fold_left + (fun map pte_id -> Id.Map.add pte_id pte_info map) + Id.Map.empty predicates_names + in + let make_proof rec_hyps = + build_proof false [f_ref] ptes_info (body_info rec_hyps) + in + (* observe_tac "instantiate_hyps_with_args" *) + (instantiate_hyps_with_args make_proof + (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) + (List.rev args_ids)) + gl') ] gl diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 64fbfaeedf..52089ca7fb 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -1,19 +1,27 @@ open Names val prove_princ_for_struct : - Evd.evar_map ref -> - bool -> - int -> Constant.t array -> EConstr.constr array -> int -> Tacmach.tactic - + Evd.evar_map ref + -> bool + -> int + -> Constant.t array + -> EConstr.constr array + -> int + -> Tacmach.tactic val prove_principle_for_gen : - Constant.t * Constant.t * Constant.t -> (* name of the function, the functional and the fixpoint equation *) - Indfun_common.tcc_lemma_value ref -> (* a pointer to the obligation proofs lemma *) - bool -> (* is that function uses measure *) - int -> (* the number of recursive argument *) - EConstr.types -> (* the type of the recursive argument *) - EConstr.constr -> (* the wf relation used to prove the function *) - Tacmach.tactic - + Constant.t * Constant.t * Constant.t + -> (* name of the function, the functional and the fixpoint equation *) + Indfun_common.tcc_lemma_value ref + -> (* a pointer to the obligation proofs lemma *) + bool + -> (* is that function uses measure *) + int + -> (* the number of recursive argument *) + EConstr.types + -> (* the type of the recursive argument *) + EConstr.constr + -> (* the wf relation used to prove the function *) + Tacmach.tactic (* val is_pte : rel_declaration -> bool *) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 163645b719..1ab747ca09 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -20,16 +20,12 @@ open Pp open Tactics open Context.Rel.Declaration open Indfun_common - module RelDecl = Context.Rel.Declaration -exception Toberemoved_with_rel of int*constr +exception Toberemoved_with_rel of int * constr exception Toberemoved -let observe s = - if do_observe () - then Feedback.msg_debug s - +let observe s = if do_observe () then Feedback.msg_debug s let pop t = Vars.lift (-1) t (* @@ -42,203 +38,211 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let env = Global.env () in let env_with_params = EConstr.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:Id.t list) (predicates:EConstr.rel_context) : EConstr.rel_context = + let rec change_predicates_names (avoid : Id.t list) + (predicates : EConstr.rel_context) : EConstr.rel_context = match predicates with | [] -> [] - | decl :: predicates -> - (match Context.Rel.Declaration.get_name decl with - | Name x -> - let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in - Hashtbl.add tbl id x; - RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates - | Anonymous -> anomaly (Pp.str "Anonymous property binder.")) + | decl :: predicates -> ( + match Context.Rel.Declaration.get_name decl with + | Name x -> + let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in + Hashtbl.add tbl id x; + RelDecl.set_name (Name id) decl + :: change_predicates_names (id :: avoid) predicates + | Anonymous -> anomaly (Pp.str "Anonymous property binder.") ) in - let avoid = (Termops.ids_of_context env_with_params ) in + let avoid = Termops.ids_of_context env_with_params in let princ_type_info = { princ_type_info with - predicates = change_predicates_names avoid princ_type_info.predicates - } + predicates = change_predicates_names avoid princ_type_info.predicates } in -(* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) -(* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) + (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) + (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod_assum (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) in + let args, _ = + decompose_prod_assum (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) + in let real_args = - if princ_type_info.indarg_in_concl - then List.tl args - else args + if princ_type_info.indarg_in_concl then List.tl args else args in - Context.Named.Declaration.LocalAssum (map_annot Nameops.Name.get_id (Context.Rel.Declaration.get_annot decl), - Term.it_mkProd_or_LetIn (mkSort new_sort) real_args) + Context.Named.Declaration.LocalAssum + ( map_annot Nameops.Name.get_id (Context.Rel.Declaration.get_annot decl) + , Term.it_mkProd_or_LetIn (mkSort new_sort) real_args ) in let new_predicates = - List.map_i - change_predicate_sort - 0 - princ_type_info.predicates + List.map_i change_predicate_sort 0 princ_type_info.predicates + in + let env_with_params_and_predicates = + List.fold_right Environ.push_named new_predicates env_with_params in - let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in let rel_as_kn = - fst (match princ_type_info.indref with - | Some (GlobRef.IndRef ind) -> ind - | _ -> user_err Pp.(str "Not a valid predicate") - ) + fst + ( match princ_type_info.indref with + | Some (GlobRef.IndRef ind) -> ind + | _ -> user_err Pp.(str "Not a valid predicate") ) in let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in let is_pte = let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in - fun t -> - match Constr.kind t with - | Var id -> Id.Set.mem id set - | _ -> false + fun t -> match Constr.kind t with Var id -> Id.Set.mem id set | _ -> false in let pre_princ = let open EConstr in it_mkProd_or_LetIn (it_mkProd_or_LetIn - (Option.fold_right - mkProd_or_LetIn - princ_type_info.indarg - princ_type_info.concl - ) - princ_type_info.args - ) + (Option.fold_right mkProd_or_LetIn princ_type_info.indarg + princ_type_info.concl) + princ_type_info.args) princ_type_info.branches in let pre_princ = EConstr.Unsafe.to_constr pre_princ in let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match Constr.kind c with - | Ind((u,_),_) -> MutInd.equal u rel_as_kn - | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn - | _ -> false + | Ind ((u, _), _) -> MutInd.equal u rel_as_kn + | Construct (((u, _), _), _) -> MutInd.equal u rel_as_kn + | _ -> false in let get_fun_num c = match Constr.kind c with - | Ind((_,num),_) -> num - | Construct(((_,num),_),_) -> num - | _ -> assert false + | Ind ((_, num), _) -> num + | Construct (((_, num), _), _) -> num + | _ -> assert false in let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i), Array.map pop (array_get_start args)) in - observe (str "replacing " ++ - pr_lconstr_env env Evd.empty c ++ str " by " ++ - pr_lconstr_env env Evd.empty res); + let res = mkApp (rel_to_fun.(i), Array.map pop (array_get_start args)) in + observe + ( str "replacing " + ++ pr_lconstr_env env Evd.empty c + ++ str " by " + ++ pr_lconstr_env env Evd.empty res ); res in - let rec compute_new_princ_type remove env pre_princ : types*(constr list) = - let (new_princ_type,_) as res = + let rec compute_new_princ_type remove env pre_princ : types * constr list = + let ((new_princ_type, _) as res) = match Constr.kind pre_princ with - | Rel n -> - begin - try match Environ.lookup_rel n env with - | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved - | _ -> pre_princ,[] - with Not_found -> assert false - end - | Prod(x,t,b) -> - compute_new_princ_type_for_binder remove mkProd env x t b - | Lambda(x,t,b) -> - compute_new_princ_type_for_binder remove mkLambda env x t b - | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved - | App(f,args) when is_dom f -> - let var_to_be_removed = destRel (Array.last args) in - let num = get_fun_num f in - raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) - | App(f,args) -> - let args = - if is_pte f && remove - then array_get_start args - else args - in - let new_args,binders_to_remove = - Array.fold_right (compute_new_princ_type_with_acc remove env) - args - ([],[]) - in - let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in - applistc new_f new_args, - list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove - | LetIn(x,v,t,b) -> - compute_new_princ_type_for_letin remove env x v t b - | _ -> pre_princ,[] + | Rel n -> ( + try + match Environ.lookup_rel n env with + | (LocalAssum (_, t) | LocalDef (_, _, t)) when is_dom t -> + raise Toberemoved + | _ -> (pre_princ, []) + with Not_found -> assert false ) + | Prod (x, t, b) -> + compute_new_princ_type_for_binder remove mkProd env x t b + | Lambda (x, t, b) -> + compute_new_princ_type_for_binder remove mkLambda env x t b + | (Ind _ | Construct _) when is_dom pre_princ -> raise Toberemoved + | App (f, args) when is_dom f -> + let var_to_be_removed = destRel (Array.last args) in + let num = get_fun_num f in + raise + (Toberemoved_with_rel + (var_to_be_removed, mk_replacement pre_princ num args)) + | App (f, args) -> + let args = if is_pte f && remove then array_get_start args else args in + let new_args, binders_to_remove = + Array.fold_right + (compute_new_princ_type_with_acc remove env) + args ([], []) + in + let new_f, binders_to_remove_from_f = + compute_new_princ_type remove env f + in + ( applistc new_f new_args + , list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove + ) + | LetIn (x, v, t, b) -> + compute_new_princ_type_for_letin remove env x v t b + | _ -> (pre_princ, []) in -(* let _ = match Constr.kind pre_princ with *) -(* | Prod _ -> *) -(* observe(str "compute_new_princ_type for "++ *) -(* pr_lconstr_env env pre_princ ++ *) -(* str" is "++ *) -(* pr_lconstr_env env new_princ_type ++ fnl ()) *) -(* | _ -> () in *) + (* let _ = match Constr.kind pre_princ with *) + (* | Prod _ -> *) + (* observe(str "compute_new_princ_type for "++ *) + (* pr_lconstr_env env pre_princ ++ *) + (* str" is "++ *) + (* pr_lconstr_env env new_princ_type ++ fnl ()) *) + (* | _ -> () in *) res - and compute_new_princ_type_for_binder remove bind_fun env x t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_x = map_annot (get_name (Termops.ids_of_context env)) x in - let new_env = Environ.push_rel (LocalAssum (x,t)) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b - then (pop new_b), filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b - else - ( - bind_fun(new_x,new_t,new_b), - list_union_eq - Constr.equal - binders_to_remove_from_t - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) - end + try + let new_t, binders_to_remove_from_t = + compute_new_princ_type remove env t + in + let new_x = map_annot (get_name (Termops.ids_of_context env)) x in + let new_env = Environ.push_rel (LocalAssum (x, t)) env in + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove new_env b + in + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b then + ( pop new_b + , filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b ) + else + ( bind_fun (new_x, new_t, new_b) + , list_union_eq Constr.equal binders_to_remove_from_t + (List.map pop binders_to_remove_from_b) ) + with + | Toberemoved -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [dummy_var] 1 b) + in + (new_b, List.map pop binders_to_remove_from_b) + | Toberemoved_with_rel (n, c) -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [c] n b) + in + ( new_b + , list_add_set_eq Constr.equal (mkRel n) + (List.map pop binders_to_remove_from_b) ) and compute_new_princ_type_for_letin remove env x v t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in - let new_x = map_annot (get_name (Termops.ids_of_context env)) x in - let new_env = Environ.push_rel (LocalDef (x,v,t)) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b - else - ( - mkLetIn(new_x,new_v,new_t,new_b), - list_union_eq - Constr.equal - (list_union_eq Constr.equal binders_to_remove_from_t binders_to_remove_from_v) - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) - end - and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = - let new_e,to_remove_from_e = compute_new_princ_type remove env e - in - new_e::c_acc,list_union_eq Constr.equal to_remove_from_e to_remove_acc + try + let new_t, binders_to_remove_from_t = + compute_new_princ_type remove env t + in + let new_v, binders_to_remove_from_v = + compute_new_princ_type remove env v + in + let new_x = map_annot (get_name (Termops.ids_of_context env)) x in + let new_env = Environ.push_rel (LocalDef (x, v, t)) env in + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove new_env b + in + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b then + ( pop new_b + , filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b ) + else + ( mkLetIn (new_x, new_v, new_t, new_b) + , list_union_eq Constr.equal + (list_union_eq Constr.equal binders_to_remove_from_t + binders_to_remove_from_v) + (List.map pop binders_to_remove_from_b) ) + with + | Toberemoved -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [dummy_var] 1 b) + in + (new_b, List.map pop binders_to_remove_from_b) + | Toberemoved_with_rel (n, c) -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [c] n b) + in + ( new_b + , list_add_set_eq Constr.equal (mkRel n) + (List.map pop binders_to_remove_from_b) ) + and compute_new_princ_type_with_acc remove env e (c_acc, to_remove_acc) = + let new_e, to_remove_from_e = compute_new_princ_type remove env e in + (new_e :: c_acc, list_union_eq Constr.equal to_remove_from_e to_remove_acc) in -(* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) - let pre_res,_ = - compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ + (* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) + let pre_res, _ = + compute_new_princ_type princ_type_info.indarg_in_concl + env_with_params_and_predicates pre_princ in let pre_res = replace_vars @@ -246,12 +250,18 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (lift (List.length ptes_vars) pre_res) in it_mkProd_or_LetIn - (it_mkProd_or_LetIn - pre_res (List.map (function - | Context.Named.Declaration.LocalAssum (id,b) -> - LocalAssum (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, b) - | Context.Named.Declaration.LocalDef (id,t,b) -> - LocalDef (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, t, b)) - new_predicates) - ) - (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params) + (it_mkProd_or_LetIn pre_res + (List.map + (function + | Context.Named.Declaration.LocalAssum (id, b) -> + LocalAssum + (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, b) + | Context.Named.Declaration.LocalDef (id, t, b) -> + LocalDef + ( map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id + , t + , b )) + new_predicates)) + (List.map + (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) + princ_type_info.params) diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index c870603a43..4bbb7180f0 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -8,8 +8,5 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val compute_new_princ_type_from_rel - : Constr.constr array - -> Sorts.t array - -> Constr.t - -> Constr.types +val compute_new_princ_type_from_rel : + Constr.constr array -> Sorts.t array -> Constr.t -> Constr.types diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index d38c3c869b..eec78391af 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -10,9 +10,7 @@ open Util open Names - open Indfun_common - module RelDecl = Context.Rel.Declaration let observe_tac s = observe_tac (fun _ _ -> Pp.str s) @@ -23,73 +21,92 @@ let observe_tac s = observe_tac (fun _ _ -> Pp.str s) *) let rec abstract_glob_constr c = function | [] -> c - | Constrexpr.CLocalDef (x,b,t)::bl -> Constrexpr_ops.mkLetInC(x,b,t,abstract_glob_constr c bl) - | Constrexpr.CLocalAssum (idl,k,t)::bl -> - List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl + | Constrexpr.CLocalDef (x, b, t) :: bl -> + Constrexpr_ops.mkLetInC (x, b, t, abstract_glob_constr c bl) + | Constrexpr.CLocalAssum (idl, k, t) :: bl -> + List.fold_right + (fun x b -> Constrexpr_ops.mkLambdaC ([x], k, t, b)) + idl (abstract_glob_constr c bl) - | Constrexpr.CLocalPattern _::bl -> assert false + | Constrexpr.CLocalPattern _ :: bl -> assert false -let interp_casted_constr_with_implicits env sigma impls c = +let interp_casted_constr_with_implicits env sigma impls c = Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls c let build_newrecursive lnameargsardef = - let env0 = Global.env() in + let env0 = Global.env () in let sigma = Evd.from_env env0 in - let (rec_sign,rec_impls) = + let rec_sign, rec_impls = List.fold_left - (fun (env,impls) { Vernacexpr.fname={CAst.v=recname}; binders; rtype } -> - let arityc = Constrexpr_ops.mkCProdN binders rtype in - let arity,_ctx = Constrintern.interp_type env0 sigma arityc in - let evd = Evd.from_env env0 in - let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd binders in - let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in - let open Context.Named.Declaration in - let r = Sorts.Relevant in (* TODO relevance *) - (EConstr.push_named (LocalAssum (Context.make_annot recname r,arity)) env, Id.Map.add recname impl impls)) - (env0,Constrintern.empty_internalization_env) lnameargsardef in + (fun (env, impls) {Vernacexpr.fname = {CAst.v = recname}; binders; rtype} -> + let arityc = Constrexpr_ops.mkCProdN binders rtype in + let arity, _ctx = Constrintern.interp_type env0 sigma arityc in + let evd = Evd.from_env env0 in + let evd, (_, (_, impls')) = + Constrintern.interp_context_evars ~program_mode:false env evd binders + in + let impl = + Constrintern.compute_internalization_data env0 evd + Constrintern.Recursive arity impls' + in + let open Context.Named.Declaration in + let r = Sorts.Relevant in + (* TODO relevance *) + ( EConstr.push_named + (LocalAssum (Context.make_annot recname r, arity)) + env + , Id.Map.add recname impl impls )) + (env0, Constrintern.empty_internalization_env) + lnameargsardef + in let recdef = (* Declare local notations *) - let f { Vernacexpr.binders; body_def } = + let f {Vernacexpr.binders; body_def} = match body_def with | Some body_def -> let def = abstract_glob_constr body_def binders in - interp_casted_constr_with_implicits - rec_sign sigma rec_impls def - | None -> CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") + interp_casted_constr_with_implicits rec_sign sigma rec_impls def + | None -> + CErrors.user_err ~hdr:"Function" + (Pp.str "Body of Function must be given") in States.with_state_protection (List.map f) lnameargsardef in - recdef,rec_impls + (recdef, rec_impls) (* Checks whether or not the mutual bloc is recursive *) let is_rec names = let open Glob_term in let names = List.fold_right Id.Set.add names Id.Set.empty in - let check_id id names = Id.Set.mem id names in - let rec lookup names gt = match DAst.get gt with - | GVar(id) -> check_id id names - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> false - | GCast(b,_) -> lookup names b + let check_id id names = Id.Set.mem id names in + let rec lookup names gt = + match DAst.get gt with + | GVar id -> check_id id names + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> + false + | GCast (b, _) -> lookup names b | GRec _ -> CErrors.user_err (Pp.str "GRec not handled") - | GIf(b,_,lhs,rhs) -> - (lookup names b) || (lookup names lhs) || (lookup names rhs) - | GProd(na,_,t,b) | GLambda(na,_,t,b) -> - lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b - | GLetIn(na,b,t,c) -> - lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c - | GLetTuple(nal,_,t,b) -> lookup names t || - lookup - (List.fold_left - (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) - names - nal - ) - b - | GApp(f,args) -> List.exists (lookup names) (f::args) - | GCases(_,_,el,brl) -> - List.exists (fun (e,_) -> lookup names e) el || - List.exists (lookup_br names) brl - and lookup_br names {CAst.v=(idl,_,rt)} = + | GIf (b, _, lhs, rhs) -> + lookup names b || lookup names lhs || lookup names rhs + | GProd (na, _, t, b) | GLambda (na, _, t, b) -> + lookup names t + || lookup (Nameops.Name.fold_right Id.Set.remove na names) b + | GLetIn (na, b, t, c) -> + lookup names b + || Option.cata (lookup names) true t + || lookup (Nameops.Name.fold_right Id.Set.remove na names) c + | GLetTuple (nal, _, t, b) -> + lookup names t + || lookup + (List.fold_left + (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) + names nal) + b + | GApp (f, args) -> List.exists (lookup names) (f :: args) + | GCases (_, _, el, brl) -> + List.exists (fun (e, _) -> lookup names e) el + || List.exists (lookup_br names) brl + and lookup_br names {CAst.v = idl, _, rt} = let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt in @@ -97,114 +114,138 @@ let is_rec names = let rec rebuild_bl aux bl typ = let open Constrexpr in - match bl,typ with - | [], _ -> List.rev aux,typ - | (CLocalAssum(nal,bk,_))::bl',typ -> - rebuild_nal aux bk bl' nal typ - | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> - rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) - bl' typ' + match (bl, typ) with + | [], _ -> (List.rev aux, typ) + | CLocalAssum (nal, bk, _) :: bl', typ -> rebuild_nal aux bk bl' nal typ + | CLocalDef (na, _, _) :: bl', {CAst.v = CLetIn (_, nat, ty, typ')} -> + rebuild_bl (Constrexpr.CLocalDef (na, nat, ty) :: aux) bl' typ' | _ -> assert false + and rebuild_nal aux bk bl' nal typ = let open Constrexpr in - match nal,typ with - | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ + match (nal, typ) with + | _, {CAst.v = CProdN ([], typ)} -> rebuild_nal aux bk bl' nal typ | [], _ -> rebuild_bl aux bl' typ - | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } -> - if Name.equal (na.CAst.v) (na'.CAst.v) || Name.is_anonymous (na'.CAst.v) - then - let assum = CLocalAssum([na],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - nal - (CAst.make @@ CProdN(new_rest,typ')) + | ( na :: nal + , {CAst.v = CProdN (CLocalAssum (na' :: nal', bk', nal't) :: rest, typ')} ) + -> + if Name.equal na.CAst.v na'.CAst.v || Name.is_anonymous na'.CAst.v then + let assum = CLocalAssum ([na], bk, nal't) in + let new_rest = + if nal' = [] then rest else CLocalAssum (nal', bk', nal't) :: rest + in + rebuild_nal (assum :: aux) bk bl' nal + (CAst.make @@ CProdN (new_rest, typ')) else - let assum = CLocalAssum([na'],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - (na::nal) - (CAst.make @@ CProdN(new_rest,typ')) - | _ -> - assert false + let assum = CLocalAssum ([na'], bk, nal't) in + let new_rest = + if nal' = [] then rest else CLocalAssum (nal', bk', nal't) :: rest + in + rebuild_nal (assum :: aux) bk bl' (na :: nal) + (CAst.make @@ CProdN (new_rest, typ')) + | _ -> assert false let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list fixpoint_exprl = let fixl = - List.map (fun fix -> Vernacexpr.{ - fix - with rec_order = ComFixpoint.adjust_rec_order ~structonly:false fix.binders fix.rec_order }) fixpoint_exprl in - let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl in + List.map + (fun fix -> + Vernacexpr. + { fix with + rec_order = + ComFixpoint.adjust_rec_order ~structonly:false fix.binders + fix.rec_order }) + fixpoint_exprl + in + let (_, _, _, typel), _, ctx, _ = + ComFixpoint.interp_fixpoint ~cofix:false fixl + in let constr_expr_typel = - with_full_print (List.map (fun c -> Constrextern.extern_constr (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in + with_full_print + (List.map (fun c -> + Constrextern.extern_constr (Global.env ()) (Evd.from_ctx ctx) + (EConstr.of_constr c))) + typel + in let fixpoint_exprl_with_new_bl = - List.map2 (fun ({ Vernacexpr.binders } as fp) fix_typ -> + List.map2 + (fun ({Vernacexpr.binders} as fp) fix_typ -> let binders, rtype = rebuild_bl [] binders fix_typ in - { fp with Vernacexpr.binders; rtype } - ) fixpoint_exprl constr_expr_typel + {fp with Vernacexpr.binders; rtype}) + fixpoint_exprl constr_expr_typel in fixpoint_exprl_with_new_bl let rec local_binders_length = function (* Assume that no `{ ... } contexts occur *) | [] -> 0 - | Constrexpr.CLocalDef _::bl -> 1 + local_binders_length bl - | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl - | Constrexpr.CLocalPattern _::bl -> assert false + | Constrexpr.CLocalDef _ :: bl -> 1 + local_binders_length bl + | Constrexpr.CLocalAssum (idl, _, _) :: bl -> + List.length idl + local_binders_length bl + | Constrexpr.CLocalPattern _ :: bl -> assert false -let prepare_body { Vernacexpr.binders } rt = +let prepare_body {Vernacexpr.binders} rt = let n = local_binders_length binders in (* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) - let fun_args,rt' = chop_rlambda_n n rt in - (fun_args,rt') + let fun_args, rt' = chop_rlambda_n n rt in + (fun_args, rt') -let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_map ref) old_princ_type sorts funs _i proof_tac hook = +let build_functional_principle ?(opaque = Declare.Transparent) + (evd : Evd.evar_map ref) old_princ_type sorts funs _i proof_tac hook = (* First we get the type of the old graph principle *) - let mutr_nparams = (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)).Tactics.nparams in + let mutr_nparams = + (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)) + .Tactics.nparams + in (* let time1 = System.get_time () in *) let new_principle_type = Functional_principles_types.compute_new_princ_type_from_rel (Array.map Constr.mkConstU funs) - sorts - old_princ_type + sorts old_princ_type in (* let time2 = System.get_time () in *) (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) let new_princ_name = - Namegen.next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty + Namegen.next_ident_away_in_goal + (Id.of_string "___________princ_________") + Id.Set.empty + in + let sigma, _ = + Typing.type_of ~refresh:true (Global.env ()) !evd + (EConstr.of_constr new_principle_type) in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in evd := sigma; let hook = DeclareDef.Hook.make (hook new_principle_type) in let lemma = - Lemmas.start_lemma - ~name:new_princ_name - ~poly:false - !evd + Lemmas.start_lemma ~name:new_princ_name ~poly:false !evd (EConstr.of_constr new_principle_type) in (* let _tim1 = System.get_time () in *) let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let lemma,_ = Lemmas.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) lemma in + let lemma, _ = + Lemmas.by + (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) + lemma + in (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) - - let open Proof_global in - let { entries } = Lemmas.pf_fold (close_proof ~opaque ~keep_body_ucst_separate:false) lemma in + let {Declare.entries} = + Lemmas.pf_fold + (Declare.close_proof ~opaque ~keep_body_ucst_separate:false) + lemma + in match entries with - | [entry] -> - entry, hook + | [entry] -> (entry, hook) | _ -> - CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") + CErrors.anomaly + Pp.( + str + "[build_functional_principle] close_proof returned more than one \ + proof term") let change_property_sort evd toSort princ princName = let open Context.Rel.Declaration in @@ -212,207 +253,221 @@ let change_property_sort evd toSort princ princName = let princ_info = Tactics.compute_elim_sig evd princ in let change_sort_in_predicate decl = LocalAssum - (get_annot decl, - let args,ty = Term.decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in - let s = Constr.destSort ty in - Global.add_constraints (Univ.enforce_leq (Sorts.univ_of_sort toSort) (Sorts.univ_of_sort s) Univ.Constraint.empty); - Term.compose_prod args (Constr.mkSort toSort) - ) + ( get_annot decl + , let args, ty = + Term.decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) + in + let s = Constr.destSort ty in + Global.add_constraints + (Univ.enforce_leq + (Sorts.univ_of_sort toSort) + (Sorts.univ_of_sort s) Univ.Constraint.empty); + Term.compose_prod args (Constr.mkSort toSort) ) + in + let evd, princName_as_constr = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in - let evd,princName_as_constr = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in let init = - let nargs = (princ_info.Tactics.nparams + (List.length princ_info.Tactics.predicates)) in - Constr.mkApp(EConstr.Unsafe.to_constr princName_as_constr, - Array.init nargs - (fun i -> Constr.mkRel (nargs - i ))) + let nargs = + princ_info.Tactics.nparams + List.length princ_info.Tactics.predicates + in + Constr.mkApp + ( EConstr.Unsafe.to_constr princName_as_constr + , Array.init nargs (fun i -> Constr.mkRel (nargs - i)) ) in - evd, Term.it_mkLambda_or_LetIn - (Term.it_mkLambda_or_LetIn init - (List.map change_sort_in_predicate princ_info.Tactics.predicates) - ) - (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.Tactics.params) - -let generate_functional_principle (evd: Evd.evar_map ref) - old_princ_type sorts new_princ_name funs i proof_tac - = + ( evd + , Term.it_mkLambda_or_LetIn + (Term.it_mkLambda_or_LetIn init + (List.map change_sort_in_predicate princ_info.Tactics.predicates)) + (List.map + (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) + princ_info.Tactics.params) ) + +let generate_functional_principle (evd : Evd.evar_map ref) old_princ_type sorts + new_princ_name funs i proof_tac = try - - let f = funs.(i) in - let sigma, type_sort = Evd.fresh_sort_in_family !evd Sorts.InType in - evd := sigma; - let new_sorts = - match sorts with - | None -> Array.make (Array.length funs) (type_sort) + let f = funs.(i) in + let sigma, type_sort = Evd.fresh_sort_in_family !evd Sorts.InType in + evd := sigma; + let new_sorts = + match sorts with + | None -> Array.make (Array.length funs) type_sort | Some a -> a - in - let base_new_princ_name,new_princ_name = - match new_princ_name with - | Some (id) -> id,id + in + let base_new_princ_name, new_princ_name = + match new_princ_name with + | Some id -> (id, id) | None -> - let id_of_f = Label.to_id (Constant.label (fst f)) in - id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort) - in - let names = ref [new_princ_name] in - let hook = - fun new_principle_type _ -> - if Option.is_empty sorts - then - (* let id_of_f = Label.to_id (con_label f) in *) - let register_with_sort fam_sort = - let evd' = Evd.from_env (Global.env ()) in - let evd',s = Evd.fresh_sort_in_family evd' fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in - (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let univs = Evd.univ_entry ~poly:false evd' in - let ce = Declare.definition_entry ~univs value in - ignore( - Declare.declare_constant - ~name - ~kind:Decls.(IsDefinition Scheme) - (Declare.DefinitionEntry ce) - ); - Declare.definition_message name; - names := name :: !names - in - register_with_sort Sorts.InProp; - register_with_sort Sorts.InSet - in - let entry, hook = - build_functional_principle evd old_princ_type new_sorts funs i - proof_tac hook + let id_of_f = Label.to_id (Constant.label (fst f)) in + (id_of_f, Indrec.make_elimination_ident id_of_f (Sorts.family type_sort)) + in + let names = ref [new_princ_name] in + let hook new_principle_type _ = + if Option.is_empty sorts then ( + (* let id_of_f = Label.to_id (con_label f) in *) + let register_with_sort fam_sort = + let evd' = Evd.from_env (Global.env ()) in + let evd', s = Evd.fresh_sort_in_family evd' fam_sort in + let name = + Indrec.make_elimination_ident base_new_princ_name fam_sort + in + let evd', value = + change_property_sort evd' s new_principle_type new_princ_name + in + let evd' = + fst + (Typing.type_of ~refresh:true (Global.env ()) evd' + (EConstr.of_constr value)) + in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let univs = Evd.univ_entry ~poly:false evd' in + let ce = Declare.definition_entry ~univs value in + ignore + (Declare.declare_constant ~name + ~kind:Decls.(IsDefinition Scheme) + (Declare.DefinitionEntry ce)); + Declare.definition_message name; + names := name :: !names + in + register_with_sort Sorts.InProp; + register_with_sort Sorts.InSet ) + in + let entry, hook = + build_functional_principle evd old_princ_type new_sorts funs i proof_tac + hook + in + (* Pr 1278 : + Don't forget to close the goal if an error is raised !!!! + *) + let uctx = Evd.evar_universe_context sigma in + let (_ : Names.GlobRef.t) = + DeclareDef.declare_entry ~name:new_princ_name ~hook + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:Decls.(IsProof Theorem) + ~impargs:[] ~uctx entry + in + () + with e when CErrors.noncritical e -> raise (Defining_principle e) + +let generate_principle (evd : Evd.evar_map ref) pconstants on_error is_general + do_built fix_rec_l recdefs + (continue_proof : + int + -> Names.Constant.t array + -> EConstr.constr array + -> int + -> Tacmach.tactic) : unit = + let names = + List.map (function {Vernacexpr.fname = {CAst.v = name}} -> name) fix_rec_l in - (* Pr 1278 : - Don't forget to close the goal if an error is raised !!!! - *) - let uctx = Evd.evar_universe_context sigma in - let _ : Names.GlobRef.t = DeclareDef.declare_entry - ~name:new_princ_name ~hook - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsProof Theorem) - ~impargs:[] - ~uctx entry in - () - with e when CErrors.noncritical e -> - raise (Defining_principle e) - -let generate_principle (evd:Evd.evar_map ref) pconstants on_error - is_general do_built fix_rec_l recdefs - (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> - Tacmach.tactic) : unit = - let names = List.map (function { Vernacexpr.fname = {CAst.v=name} } -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in - let funs_types = List.map (function { Vernacexpr.rtype } -> rtype) fix_rec_l in + let funs_types = + List.map (function {Vernacexpr.rtype} -> rtype) fix_rec_l + in try (* We then register the Inductive graphs of the functions *) - Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types recdefs; - if do_built - then - begin - (*i The next call to mk_rel_id is valid since we have just construct the graph - Ensures by : do_built - i*) - let f_R_mut = Libnames.qualid_of_ident @@ mk_rel_id (List.nth names 0) in - let ind_kn = - fst (locate_with_msg - Pp.(Libnames.pr_qualid f_R_mut ++ str ": Not an inductive type!") - locate_ind - f_R_mut) - in - let fname_kn { Vernacexpr.fname } = - let f_ref = Libnames.qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in - locate_with_msg - Pp.(Libnames.pr_qualid f_ref++str ": Not an inductive type!") - locate_constant - f_ref - in - let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in - let _ = - List.map_i - (fun i _x -> - let env = Global.env () in - let princ = Indrec.lookup_eliminator env (ind_kn,i) (Sorts.InProp) in - let evd = ref (Evd.from_env env) in - let evd',uprinc = Evd.fresh_global env !evd princ in - let _ = evd := evd' in - let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in - evd := sigma; - let princ_type = EConstr.Unsafe.to_constr princ_type in - generate_functional_principle - evd - princ_type - None - None - (Array.of_list pconstants) - (* funs_kn *) - i - (continue_proof 0 [|funs_kn.(i)|]) - ) - 0 - fix_rec_l - in - Array.iter (add_Function is_general) funs_kn; - () - end - with e when CErrors.noncritical e -> - on_error names e + Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types + recdefs; + if do_built then begin + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : do_built + i*) + let f_R_mut = Libnames.qualid_of_ident @@ mk_rel_id (List.nth names 0) in + let ind_kn = + fst + (locate_with_msg + Pp.(Libnames.pr_qualid f_R_mut ++ str ": Not an inductive type!") + locate_ind f_R_mut) + in + let fname_kn {Vernacexpr.fname} = + let f_ref = Libnames.qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in + locate_with_msg + Pp.(Libnames.pr_qualid f_ref ++ str ": Not an inductive type!") + locate_constant f_ref + in + let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in + let _ = + List.map_i + (fun i _x -> + let env = Global.env () in + let princ = Indrec.lookup_eliminator env (ind_kn, i) Sorts.InProp in + let evd = ref (Evd.from_env env) in + let evd', uprinc = Evd.fresh_global env !evd princ in + let _ = evd := evd' in + let sigma, princ_type = + Typing.type_of ~refresh:true env !evd uprinc + in + evd := sigma; + let princ_type = EConstr.Unsafe.to_constr princ_type in + generate_functional_principle evd princ_type None None + (Array.of_list pconstants) (* funs_kn *) + i + (continue_proof 0 [|funs_kn.(i)|])) + 0 fix_rec_l + in + Array.iter (add_Function is_general) funs_kn; + () + end + with e when CErrors.noncritical e -> on_error names e let register_struct is_rec fixpoint_exprl = let open EConstr in match fixpoint_exprl with - | [{ Vernacexpr.fname; univs; binders; rtype; body_def }] when not is_rec -> + | [{Vernacexpr.fname; univs; binders; rtype; body_def}] when not is_rec -> let body = match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in - ComDefinition.do_definition - ~name:fname.CAst.v - ~poly:false + CErrors.user_err ~hdr:"Function" + Pp.(str "Body of Function must be given") + in + ComDefinition.do_definition ~name:fname.CAst.v ~poly:false ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.Definition univs - binders None body (Some rtype); - let evd,rev_pconstants = + ~kind:Decls.Definition univs binders None body (Some rtype); + let evd, rev_pconstants = List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) + (fun (evd, l) {Vernacexpr.fname} -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident fname.CAst.v)) + in + let cst, u = destConst evd c in + let u = EInstance.kind evd u in + (evd, (cst, u) :: l)) + (Evd.from_env (Global.env ()), []) fixpoint_exprl in - None, evd,List.rev rev_pconstants + (None, evd, List.rev rev_pconstants) | _ -> - ComFixpoint.do_fixpoint ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false fixpoint_exprl; - let evd,rev_pconstants = + ComFixpoint.do_fixpoint + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false + fixpoint_exprl; + let evd, rev_pconstants = List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) + (fun (evd, l) {Vernacexpr.fname} -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident fname.CAst.v)) + in + let cst, u = destConst evd c in + let u = EInstance.kind evd u in + (evd, (cst, u) :: l)) + (Evd.from_env (Global.env ()), []) fixpoint_exprl in - None,evd,List.rev rev_pconstants + (None, evd, List.rev rev_pconstants) -let generate_correction_proof_wf f_ref tcc_lemma_ref - is_mes functional_ref eq_ref rec_arg_num rec_arg_type relation - (_: int) (_:Names.Constant.t array) (_:EConstr.constr array) (_:int) : Tacmach.tactic = +let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref + eq_ref rec_arg_num rec_arg_type relation (_ : int) + (_ : Names.Constant.t array) (_ : EConstr.constr array) (_ : int) : + Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen - (f_ref,functional_ref,eq_ref) - tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation + (f_ref, functional_ref, eq_ref) + tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. @@ -431,34 +486,38 @@ let generate_type evd g_to_f f graph = let open EConstr in let open EConstr.Vars in (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let evd',graph = - Evd.fresh_global (Global.env ()) !evd (GlobRef.IndRef (fst (destInd !evd graph))) + let evd', graph = + Evd.fresh_global (Global.env ()) !evd + (GlobRef.IndRef (fst (destInd !evd graph))) in - evd:=evd'; + evd := evd'; let sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in evd := sigma; - let ctxt,_ = decompose_prod_assum !evd graph_arity in - let fun_ctxt,res_type = + let ctxt, _ = decompose_prod_assum !evd graph_arity in + let fun_ctxt, res_type = match ctxt with | [] | [_] -> CErrors.anomaly (Pp.str "Not a valid context.") - | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl + | decl :: fun_ctxt -> (fun_ctxt, RelDecl.get_type decl) in let rec args_from_decl i accu = function | [] -> accu - | LocalDef _ :: l -> - args_from_decl (succ i) accu l + | LocalDef _ :: l -> args_from_decl (succ i) accu l | _ :: l -> let t = mkRel i in args_from_decl (succ i) (t :: accu) l in (*i We need to name the vars [res] and [fv] i*) - let filter = fun decl -> match RelDecl.get_name decl with - | Name id -> Some id - | Anonymous -> None + let filter decl = + match RelDecl.get_name decl with Name id -> Some id | Anonymous -> None in let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in - let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in - let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (Id.Set.add res_id named_ctxt) in + let res_id = + Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt + in + let fv_id = + Namegen.next_ident_away_in_goal (Id.of_string "fv") + (Id.Set.add res_id named_ctxt) + in (*i we can then type the argument to be applied to the function [f] i*) let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in (*i @@ -467,7 +526,7 @@ let generate_type evd g_to_f f graph = i*) let make_eq = make_eq () in let res_eq_f_of_args = - mkApp(make_eq ,[|lift 2 res_type;mkRel 1;mkRel 2|]) + mkApp (make_eq, [|lift 2 res_type; mkRel 1; mkRel 2|]) in (*i The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed @@ -475,18 +534,29 @@ let generate_type evd g_to_f f graph = i*) let args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in - let graph_applied = mkApp(graph, args_and_res_as_rels) in + let graph_applied = mkApp (graph, args_and_res_as_rels) in (*i The [pre_context] is the defined to be the context corresponding to \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = - LocalAssum (Context.make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) :: - LocalDef (Context.make_annot (Name fv_id) Sorts.Relevant, mkApp (f,args_as_rels), res_type) :: fun_ctxt + LocalAssum (Context.make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) + :: LocalDef + ( Context.make_annot (Name fv_id) Sorts.Relevant + , mkApp (f, args_as_rels) + , res_type ) + :: fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) - if g_to_f - then LocalAssum (Context.make_annot Anonymous Sorts.Relevant,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else LocalAssum (Context.make_annot Anonymous Sorts.Relevant,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + if g_to_f then + ( LocalAssum (Context.make_annot Anonymous Sorts.Relevant, graph_applied) + :: pre_ctxt + , lift 1 res_eq_f_of_args + , graph ) + else + ( LocalAssum (Context.make_annot Anonymous Sorts.Relevant, res_eq_f_of_args) + :: pre_ctxt + , lift 1 graph_applied + , graph ) (** [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] @@ -494,21 +564,25 @@ let generate_type evd g_to_f f graph = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle evd f = - let f_as_constant, _u = match EConstr.kind !evd f with + let f_as_constant, _u = + match EConstr.kind !evd f with | Constr.Const c' -> c' | _ -> CErrors.user_err Pp.(str "Must be used with a function") in match find_Function_infos f_as_constant with - | None -> - raise Not_found - | Some infos -> + | None -> raise Not_found + | Some infos -> ( match infos.rect_lemma with | None -> raise Not_found | Some rect_lemma -> - let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) in - let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in - evd:=evd'; - rect_lemma,typ + let evd', rect_lemma = + Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) + in + let evd', typ = + Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma + in + evd := evd'; + (rect_lemma, typ) ) (* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. @@ -535,13 +609,13 @@ let find_induction_principle evd f = *) let rec generate_fresh_id x avoid i = - if i == 0 - then [] + if i == 0 then [] else let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in - id::(generate_fresh_id x (id::avoid) (pred i)) + id :: generate_fresh_id x (id :: avoid) (pred i) -let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = +let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : + Tacmach.tactic = let open Constr in let open EConstr in let open Context.Rel.Declaration in @@ -554,22 +628,25 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) (* we the get the definition of the graphs block *) - let graph_ind,u = destInd evd graphs_constr.(i) in + let graph_ind, u = destInd evd graphs_constr.(i) in let kn = fst graph_ind in - let mib,_ = Global.lookup_inductive graph_ind in + let mib, _ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) - let f_principle,princ_type = schemes.(i) in + let f_principle, princ_type = schemes.(i) in let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in + let ids = args_names @ pf_ids_of_hyps g in (* Since we cannot ensure that the functional principle is defined in the environment and due to the bug #1174, we will need to pose the principle using a name *) - let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") (Id.Set.of_list ids) in + let principle_id = + Namegen.next_ident_away_in_goal (Id.of_string "princ") + (Id.Set.of_list ids) + in let ids = principle_id :: ids in (* We get the branches of the principle *) let branches = List.rev princ_infos.Tactics.branches in @@ -577,28 +654,28 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t let intro_pats = List.map (fun decl -> - List.map - (fun id -> CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) - ) + List.map + (fun id -> + CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) + (generate_fresh_id (Id.of_string "y") ids + (List.length + (fst (decompose_prod_assum evd (RelDecl.get_type decl)))))) branches in (* before building the full intro pattern for the principle *) let eq_ind = make_eq () in let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) - let ind_number = ref 0 - and min_constr_number = ref 0 in + let ind_number = ref 0 and min_constr_number = ref 0 in (* The tactic to prove the ith branch of the principle *) let prove_branche i g = (* We get the identifiers of this branch *) let pre_args = List.fold_right - (fun {CAst.v=pat} acc -> - match pat with - | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id::acc - | _ -> CErrors.anomaly (Pp.str "Not an identifier.") - ) + (fun {CAst.v = pat} acc -> + match pat with + | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id :: acc + | _ -> CErrors.anomaly (Pp.str "Not an identifier.")) (List.nth intro_pats (pred i)) [] in @@ -613,32 +690,35 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t let constructor_args g = List.fold_right (fun hid acc -> - let type_of_hid = pf_get_hyp_typ g hid in - let sigma = project g in - match EConstr.kind sigma type_of_hid with - | Prod(_,_,t') -> - begin - match EConstr.kind sigma t' with - | Prod(_,t'',t''') -> - begin - match EConstr.kind sigma t'',EConstr.kind sigma t''' with - | App(eq,args), App(graph',_) - when - (EConstr.eq_constr sigma eq eq_ind) && - Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> - (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) - ::acc) - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - ) pre_args [] + let type_of_hid = pf_get_hyp_typ g hid in + let sigma = project g in + match EConstr.kind sigma type_of_hid with + | Prod (_, _, t') -> ( + match EConstr.kind sigma t' with + | Prod (_, t'', t''') -> ( + match (EConstr.kind sigma t'', EConstr.kind sigma t''') with + | App (eq, args), App (graph', _) + when EConstr.eq_constr sigma eq eq_ind + && Array.exists + (EConstr.eq_constr_nounivs sigma graph') + graphs_constr -> + args.(2) + :: mkApp + ( mkVar hid + , [| args.(2) + ; mkApp (eq_construct, [|args.(0); args.(2)|]) |] ) + :: acc + | _ -> mkVar hid :: acc ) + | _ -> mkVar hid :: acc ) + | _ -> mkVar hid :: acc) + pre_args [] in (* in fact we must also add the parameters to the constructor args *) let constructor_args g = - let params_id = fst (List.chop princ_infos.Tactics.nparams args_names) in - (List.map mkVar params_id)@((constructor_args g)) + let params_id = + fst (List.chop princ_infos.Tactics.nparams args_names) + in + List.map mkVar params_id @ constructor_args g in (* We then get the constructor corresponding to this branch and modifies the references has needed i.e. @@ -648,120 +728,136 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t *) let constructor = let constructor_num = i - !min_constr_number in - let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then - begin - (kn,!ind_number),constructor_num - end - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length ; - (kn,!ind_number),1 - end + let length = + Array.length + mib.Declarations.mind_packets.(!ind_number) + .Declarations.mind_consnames + in + if constructor_num <= length then ((kn, !ind_number), constructor_num) + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + ((kn, !ind_number), 1) + end in (* we can then build the final proof term *) - let app_constructor g = applist((mkConstructU(constructor,u)),constructor_args g) in + let app_constructor g = + applist (mkConstructU (constructor, u), constructor_args g) + in (* an apply the tactic *) - let res,hres = - match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with - | [res;hres] -> res,hres + let res, hres = + match + generate_fresh_id (Id.of_string "z") ids (* @this_branche_ids *) 2 + with + | [res; hres] -> (res, hres) | _ -> assert false in (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) - ( - tclTHENLIST - [ - observe_tac ("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in - match l with - | [] -> tclIDTAC - | _ -> Proofview.V82.of_tactic (intro_patterns false l)); - (* unfolding of all the defined variables introduced by this branch *) - (* observe_tac "unfolding" pre_tac; *) - (* $zeta$ normalizing of the conclusion *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - { Redops.all_flags with - Genredexpr.rDelta = false ; - Genredexpr.rConst = [] - } - ) - Locusops.onConcl); - observe_tac ("toto ") tclIDTAC; - - (* introducing the result of the graph and the equality hypothesis *) - observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); - (* replacing [res] with its value *) - observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); - (* Conclusion *) - observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (app_constructor g)) g) - ] - ) + (tclTHENLIST + [ observe_tac "h_intro_patterns " + (let l = List.nth intro_pats (pred i) in + match l with + | [] -> tclIDTAC + | _ -> Proofview.V82.of_tactic (intro_patterns false l)) + ; (* unfolding of all the defined variables introduced by this branch *) + (* observe_tac "unfolding" pre_tac; *) + (* $zeta$ normalizing of the conclusion *) + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + { Redops.all_flags with + Genredexpr.rDelta = false + ; Genredexpr.rConst = [] }) + Locusops.onConcl) + ; observe_tac "toto " tclIDTAC + ; (* introducing the result of the graph and the equality hypothesis *) + observe_tac "introducing" + (tclMAP + (fun x -> Proofview.V82.of_tactic (Simple.intro x)) + [res; hres]) + ; (* replacing [res] with its value *) + observe_tac "rewriting res value" + (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))) + ; (* Conclusion *) + observe_tac "exact" (fun g -> + Proofview.V82.of_tactic (exact_check (app_constructor g)) g) ]) g in (* end of branche proof *) let lemmas = Array.map - (fun ((_,(ctxt,concl))) -> - match ctxt with - | [] | [_] | [_;_] -> CErrors.anomaly (Pp.str "bad context.") - | hres::res::decl::ctxt -> - let res = EConstr.it_mkLambda_or_LetIn - (EConstr.it_mkProd_or_LetIn concl [hres;res]) - (LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) :: ctxt) - in - res) + (fun (_, (ctxt, concl)) -> + match ctxt with + | [] | [_] | [_; _] -> CErrors.anomaly (Pp.str "bad context.") + | hres :: res :: decl :: ctxt -> + let res = + EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres; res]) + ( LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) + :: ctxt ) + in + res) lemmas_types_infos in let param_names = fst (List.chop princ_infos.nparams args_names) in let params = List.map mkVar param_names in - let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in + let lemmas = + Array.to_list (Array.map (fun c -> applist (c, params)) lemmas) + in (* The bindings of the principle that is the params of the principle and the different lemma types *) let bindings = - let params_bindings,avoid = + let params_bindings, avoid = List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - p::bindings,id::avoid - ) - ([],pf_ids_of_hyps g) - princ_infos.params - (List.rev params) + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + (p :: bindings, id :: avoid)) + ([], pf_ids_of_hyps g) + princ_infos.params (List.rev params) in let lemmas_bindings = - List.rev (fst (List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - (Reductionops.nf_zeta (pf_env g) (project g) p)::bindings,id::avoid) - ([],avoid) - princ_infos.predicates - (lemmas))) + List.rev + (fst + (List.fold_left2 + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + ( Reductionops.nf_zeta (pf_env g) (project g) p :: bindings + , id :: avoid )) + ([], avoid) princ_infos.predicates lemmas)) in - (params_bindings@lemmas_bindings) + params_bindings @ lemmas_bindings in tclTHENLIST - [ - observe_tac "principle" (Proofview.V82.of_tactic (assert_by - (Name principle_id) - princ_type - (exact_check f_principle))); - observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); - (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) - observe_tac "idtac" tclIDTAC; - tclTHEN_i - (observe_tac - "functional_induction" ( - (fun gl -> - let term = mkApp (mkVar principle_id,Array.of_list bindings) in - let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in - Proofview.V82.of_tactic (apply term) gl') - )) - (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) - ] + [ observe_tac "principle" + (Proofview.V82.of_tactic + (assert_by (Name principle_id) princ_type + (exact_check f_principle))) + ; observe_tac "intro args_names" + (tclMAP + (fun id -> Proofview.V82.of_tactic (Simple.intro id)) + args_names) + ; (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + observe_tac "idtac" tclIDTAC + ; tclTHEN_i + (observe_tac "functional_induction" (fun gl -> + let term = mkApp (mkVar principle_id, Array.of_list bindings) in + let gl', _ty = + pf_eapply (Typing.type_of ~refresh:true) gl term + in + Proofview.V82.of_tactic (apply term) gl')) + (fun i g -> + observe_tac + ("proving branche " ^ string_of_int i) + (prove_branche i) g) ] g (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] @@ -798,13 +894,12 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl *) let tauto = let open Ltac_plugin in - let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in + let dp = List.map Id.of_string ["Tauto"; "Init"; "Coq"] in let mp = ModPath.MPfile (DirPath.make dp) in let kn = KerName.make mp (Label.make "tauto") in - Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> - let body = Tacenv.interp_ltac kn in - Tacinterp.eval_tactic body - end + Proofview.tclBIND (Proofview.tclUNIT ()) (fun () -> + let body = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic body) (* [generalize_dependent_of x hyp g] generalize every hypothesis which depends of [x] but [hyp] @@ -815,16 +910,18 @@ let generalize_dependent_of x hyp g = let open Tacticals in tclMAP (function - | LocalAssum ({Context.binder_name=id},t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) (project g) x t) -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (thin [id]) - | _ -> tclIDTAC - ) - (pf_hyps g) - g + | LocalAssum ({Context.binder_name = id}, t) + when (not (Id.equal id hyp)) + && Termops.occur_var (pf_env g) (project g) x t -> + tclTHEN + (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) + (thin [id]) + | _ -> tclIDTAC) + (pf_hyps g) g let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g + and intros_with_rewrite_aux : Tacmach.tactic = let open Constr in let open EConstr in @@ -835,88 +932,111 @@ and intros_with_rewrite_aux : Tacmach.tactic = let eq_ind = make_eq () in let sigma = project g in match EConstr.kind sigma (pf_concl g) with - | Prod(_,t,t') -> - begin - match EConstr.kind sigma t with - | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> - if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g - else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(1) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(1)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] - g - else if isVar sigma args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(2)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); - intros_with_rewrite - ] - g - else - begin - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST[ - Proofview.V82.of_tactic (Simple.intro id); - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] g - end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type")) -> - Proofview.V82.of_tactic tauto g - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - intros_with_rewrite - ] g - | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g - | _ -> - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g - end + | Prod (_, t, t') -> ( + match EConstr.kind sigma t with + | App (eq, args) when EConstr.eq_constr sigma eq eq_ind -> + if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; thin [id] + ; intros_with_rewrite ] + g + else if + isVar sigma args.(1) + && Environ.evaluable_named (destVar sigma args.(1)) (pf_env g) + then + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ]) + ; tclMAP + (fun id -> + tclTRY + (Proofview.V82.of_tactic + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ] + (destVar sigma args.(1), Locus.InHyp)))) + (pf_ids_of_hyps g) + ; intros_with_rewrite ] + g + else if + isVar sigma args.(2) + && Environ.evaluable_named (destVar sigma args.(2)) (pf_env g) + then + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ]) + ; tclMAP + (fun id -> + tclTRY + (Proofview.V82.of_tactic + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ] + (destVar sigma args.(2), Locus.InHyp)))) + (pf_ids_of_hyps g) + ; intros_with_rewrite ] + g + else if isVar sigma args.(1) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; generalize_dependent_of (destVar sigma args.(1)) id + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) + ; intros_with_rewrite ] + g + else if isVar sigma args.(2) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; generalize_dependent_of (destVar sigma args.(2)) id + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))) + ; intros_with_rewrite ] + g + else + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) + ; intros_with_rewrite ] + g + | Ind _ + when EConstr.eq_constr sigma t + (EConstr.of_constr + ( UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.False.type" )) -> + Proofview.V82.of_tactic tauto g + | Case (_, _, v, _) -> + tclTHENLIST + [Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite] + g + | LetIn _ -> + tclTHENLIST + [ Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; intros_with_rewrite ] + g + | _ -> + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [Proofview.V82.of_tactic (Simple.intro id); intros_with_rewrite] + g ) | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g + tclTHENLIST + [ Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; intros_with_rewrite ] + g | _ -> tclIDTAC g let rec reflexivity_with_destruct_cases g = @@ -927,52 +1047,66 @@ let rec reflexivity_with_destruct_cases g = let open Tacticals in let destruct_case () = try - match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - Proofview.V82.of_tactic intros; - observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases - ] + match + EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) + with + | Case (_, _, v, _) -> + tclTHENLIST + [ Proofview.V82.of_tactic (simplest_case v) + ; Proofview.V82.of_tactic intros + ; observe_tac "reflexivity_with_destruct_cases" + reflexivity_with_destruct_cases ] | _ -> Proofview.V82.of_tactic reflexivity with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity in let eq_ind = make_eq () in - let my_inj_flags = Some { - Equality.keep_proof_equalities = false; - injection_in_context = false; (* for compatibility, necessary *) - injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *) - } in + let my_inj_flags = + Some + { Equality.keep_proof_equalities = false + ; injection_in_context = false + ; (* for compatibility, necessary *) + injection_pattern_l2r_order = + false (* probably does not matter; except maybe with dependent hyps *) + } + in let discr_inject = - Tacticals.onAllHypsAndConcl ( - fun sc g -> + Tacticals.onAllHypsAndConcl (fun sc g -> match sc with - None -> tclIDTAC g - | Some id -> + | None -> tclIDTAC g + | Some id -> ( match EConstr.kind (project g) (pf_get_hyp_typ g id) with - | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> - if Equality.discriminable (pf_env g) (project g) t1 t2 - then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 - then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g + | App (eq, [|_; t1; t2|]) when EConstr.eq_constr (project g) eq eq_ind + -> + if Equality.discriminable (pf_env g) (project g) t1 t2 then + Proofview.V82.of_tactic (Equality.discrHyp id) g + else if + Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 + then + tclTHENLIST + [ Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id) + ; thin [id] + ; intros_with_rewrite ] + g else tclIDTAC g - | _ -> tclIDTAC g - ) + | _ -> tclIDTAC g )) in (tclFIRST - [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); - observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); - (* We reach this point ONLY if - the same value is matched (at least) two times - along binding path. - In this case, either we have a discriminable hypothesis and we are done, - either at least an injectable one and we do the injection before continuing + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" + (Proofview.V82.of_tactic reflexivity) + ; observe_tac "reflexivity_with_destruct_cases : destruct_case" + (destruct_case ()) + ; (* We reach this point ONLY if + the same value is matched (at least) two times + along binding path. + In this case, either we have a discriminable hypothesis and we are done, + either at least an injectable one and we do the injection before continuing *) - observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) - ]) + observe_tac "reflexivity_with_destruct_cases : others" + (tclTHEN (tclPROGRESS discr_inject) reflexivity_with_destruct_cases) ]) g -let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tactic = +let prove_fun_complete funcs graphs schemes lemmas_types_infos i : + Tacmach.tactic = let open EConstr in let open Tacmach in let open Tactics in @@ -983,12 +1117,17 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> Reductionops.nf_zeta (pf_env g) (project g) (EConstr.it_mkLambda_or_LetIn concl ctxt)) + (fun (_, (ctxt, concl)) -> + Reductionops.nf_zeta (pf_env g) (project g) + (EConstr.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in - let graph_principle = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in + let graph_principle = + Reductionops.nf_zeta (pf_env g) (project g) + (EConstr.of_constr schemes.(i)) + in let g, princ_type = tac_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function @@ -996,24 +1135,24 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in + let ids = args_names @ pf_ids_of_hyps g in (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res,hres,graph_principle_id = + let res, hres, graph_principle_id = match generate_fresh_id (Id.of_string "z") ids 3 with - | [res;hres;graph_principle_id] -> res,hres,graph_principle_id + | [res; hres; graph_principle_id] -> (res, hres, graph_principle_id) | _ -> assert false in - let ids = res::hres::graph_principle_id::ids in + let ids = res :: hres :: graph_principle_id :: ids in (* we also compute fresh names for each hyptohesis of each branch of the principle *) let branches = List.rev princ_infos.branches in let intro_pats = List.map (fun decl -> - List.map - (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (Termops.nb_prod (project g) (RelDecl.get_type decl))) - ) + List.map + (fun id -> id) + (generate_fresh_id (Id.of_string "y") ids + (Termops.nb_prod (project g) (RelDecl.get_type decl)))) branches in (* We will need to change the function by its body @@ -1022,34 +1161,38 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let rewrite_tac j ids : Tacmach.tactic = let graph_def = graphs.(j) in - let infos = match find_Function_infos (fst (destConst (project g) funcs.(j))) with - | None -> - CErrors.user_err Pp.(str "No graph found") + let infos = + match find_Function_infos (fst (destConst (project g) funcs.(j))) with + | None -> CErrors.user_err Pp.(str "No graph found") | Some infos -> infos in - if infos.is_general || Rtree.is_infinite Declareops.eq_recarg graph_def.Declarations.mind_recargs + if + infos.is_general + || Rtree.is_infinite Declareops.eq_recarg + graph_def.Declarations.mind_recargs then let eq_lemma = - try Option.get (infos).equation_lemma - with Option.IsNone -> CErrors.anomaly (Pp.str "Cannot find equation lemma.") + try Option.get infos.equation_lemma + with Option.IsNone -> + CErrors.anomaly (Pp.str "Cannot find equation lemma.") in - tclTHENLIST[ - tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); - (* Don't forget to $\zeta$ normlize the term since the principles - have been $\zeta$-normalized *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - Proofview.V82.of_tactic (generalize (List.map mkVar ids)); - thin ids - ] + tclTHENLIST + [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids + ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)) + ; (* Don't forget to $\zeta$ normlize the term since the principles + have been $\zeta$-normalized *) + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; Proofview.V82.of_tactic (generalize (List.map mkVar ids)) + ; thin ids ] else - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) + Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalConstRef (fst (destConst (project g) f)) ) ]) in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -1058,40 +1201,49 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti (* we fist compute the inductive corresponding to the branch *) let this_ind_number = let constructor_num = i - !min_constr_number in - let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then !ind_number - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length; - !ind_number - end + let length = + Array.length graphs.(!ind_number).Declarations.mind_consnames + in + if constructor_num <= length then !ind_number + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end in let this_branche_ids = List.nth intro_pats (pred i) in - tclTHENLIST[ - (* we expand the definition of the function *) - observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); - (* introduce hypothesis with some rewrite *) - observe_tac "intros_with_rewrite (all)" intros_with_rewrite; - (* The proof is (almost) complete *) - observe_tac "reflexivity" (reflexivity_with_destruct_cases) - ] + tclTHENLIST + [ (* we expand the definition of the function *) + observe_tac "rewrite_tac" + (rewrite_tac this_ind_number this_branche_ids) + ; (* introduce hypothesis with some rewrite *) + observe_tac "intros_with_rewrite (all)" intros_with_rewrite + ; (* The proof is (almost) complete *) + observe_tac "reflexivity" reflexivity_with_destruct_cases ] g in let params_names = fst (List.chop princ_infos.nparams args_names) in let open EConstr in let params = List.map mkVar params_names in tclTHENLIST - [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); - observe_tac "h_generalize" - (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); - Proofview.V82.of_tactic (Simple.intro graph_principle_id); - observe_tac "" (tclTHEN_i - (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres, Tactypes.NoBindings) - (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) - (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) - ] + [ tclMAP + (fun id -> Proofview.V82.of_tactic (Simple.intro id)) + (args_names @ [res; hres]) + ; observe_tac "h_generalize" + (Proofview.V82.of_tactic + (generalize + [ mkApp + ( applist (graph_principle, params) + , Array.map (fun c -> applist (c, params)) lemmas ) ])) + ; Proofview.V82.of_tactic (Simple.intro graph_principle_id) + ; observe_tac "" + (tclTHEN_i + (observe_tac "elim" + (Proofview.V82.of_tactic + (elim false None + (mkVar hres, Tactypes.NoBindings) + (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) + (fun i g -> observe_tac "prove_branche" (prove_branche i) g)) ] g exception No_graph_found @@ -1099,35 +1251,35 @@ exception No_graph_found let get_funs_constant mp = let open Constr in let exception Not_Rec in - let get_funs_constant const e : (Names.Constant.t*int) array = + let get_funs_constant const e : (Names.Constant.t * int) array = match Constr.kind (Term.strip_lam e) with - | Fix((_,(na,_,_))) -> + | Fix (_, (na, _, _)) -> Array.mapi (fun i na -> - match na.Context.binder_name with - | Name id -> - let const = Constant.make2 mp (Label.of_id id) in - const,i - | Anonymous -> - CErrors.anomaly (Pp.str "Anonymous fix.") - ) + match na.Context.binder_name with + | Name id -> + let const = Constant.make2 mp (Label.of_id id) in + (const, i) + | Anonymous -> CErrors.anomaly (Pp.str "Anonymous fix.")) na - | _ -> [|const,0|] + | _ -> [|(const, 0)|] in - function const -> + function + | const -> let find_constant_body const = match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let body = Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - (Global.env ()) - (Evd.from_env (Global.env ())) - (EConstr.of_constr body) - in - let body = EConstr.Unsafe.to_constr body in - body - | None -> - CErrors.user_err Pp.(str ( "Cannot define a principle over an axiom ")) + | Some (body, _, _) -> + let body = + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + (Global.env ()) + (Evd.from_env (Global.env ())) + (EConstr.of_constr body) + in + let body = EConstr.Unsafe.to_constr body in + body + | None -> + CErrors.user_err Pp.(str "Cannot define a principle over an axiom ") in let f = find_constant_body const in let l_const = get_funs_constant const f in @@ -1135,17 +1287,24 @@ let get_funs_constant mp = We need to check that all the functions found are in the same block to prevent Reset strange thing *) - let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in - let l_params, _l_fixes = List.split (List.map Term.decompose_lam l_bodies) in + let l_bodies = + List.map find_constant_body (Array.to_list (Array.map fst l_const)) + in + let l_params, _l_fixes = + List.split (List.map Term.decompose_lam l_bodies) + in (* all the parameters must be equal*) let _check_params = - let first_params = List.hd l_params in + let first_params = List.hd l_params in List.iter (fun params -> - if not (List.equal (fun (n1, c1) (n2, c2) -> - Context.eq_annot Name.equal n1 n2 && Constr.equal c1 c2) first_params params) - then CErrors.user_err Pp.(str "Not a mutal recursive block") - ) + if + not + (List.equal + (fun (n1, c1) (n2, c2) -> + Context.eq_annot Name.equal n1 n2 && Constr.equal c1 c2) + first_params params) + then CErrors.user_err Pp.(str "Not a mutal recursive block")) l_params in (* The bodies has to be very similar *) @@ -1153,27 +1312,30 @@ let get_funs_constant mp = try let extract_info is_first body = match Constr.kind body with - | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) - | _ -> - if is_first && Int.equal (List.length l_bodies) 1 - then raise Not_Rec - else CErrors.user_err Pp.(str "Not a mutal recursive block") + | Fix ((idxs, _), (na, ta, ca)) -> (idxs, na, ta, ca) + | _ -> + if is_first && Int.equal (List.length l_bodies) 1 then raise Not_Rec + else CErrors.user_err Pp.(str "Not a mutal recursive block") in let first_infos = extract_info true (List.hd l_bodies) in - let check body = (* Hope this is correct *) + let check body = + (* Hope this is correct *) let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = - Array.equal Int.equal ia1 ia2 && Array.equal (Context.eq_annot Name.equal) na1 na2 && - Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 + Array.equal Int.equal ia1 ia2 + && Array.equal (Context.eq_annot Name.equal) na1 na2 + && Array.equal Constr.equal ta1 ta2 + && Array.equal Constr.equal ca1 ca2 in - if not (eq_infos first_infos (extract_info false body)) - then CErrors.user_err Pp.(str "Not a mutal recursive block") + if not (eq_infos first_infos (extract_info false body)) then + CErrors.user_err Pp.(str "Not a mutal recursive block") in List.iter check l_bodies with Not_Rec -> () in l_const -let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_effects Declare.proof_entry list = +let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : + Evd.side_effects Declare.proof_entry list = let exception Found_type of int in let env = Global.env () in let funs = List.map fst fas in @@ -1185,42 +1347,47 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef | Some finfos -> fst finfos.graph_ind in let this_block_funs_indexes = get_funs_constant funs_mp (fst first_fun) in - let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in + let this_block_funs = + Array.map (fun (c, _) -> (c, snd first_fun)) this_block_funs_indexes + in let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.map - (function cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) + (function + | cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) funs in let ind_list = List.map - (fun (idx) -> - let ind = first_fun_kn,idx in - (ind,snd first_fun),true,prop_sort - ) + (fun idx -> + let ind = (first_fun_kn, idx) in + ((ind, snd first_fun), true, prop_sort)) funs_indexes in - let sigma, schemes = - Indrec.build_mutual_induction_scheme env !evd ind_list - in + let sigma, schemes = Indrec.build_mutual_induction_scheme env !evd ind_list in let _ = evd := sigma in let l_schemes = - List.map (EConstr.of_constr %> Retyping.get_type_of env sigma %> EConstr.Unsafe.to_constr) schemes + List.map + ( EConstr.of_constr + %> Retyping.get_type_of env sigma + %> EConstr.Unsafe.to_constr ) + schemes in let i = ref (-1) in let sorts = - List.rev_map (fun (_,x) -> + List.rev_map + (fun (_, x) -> let sigma, fs = Evd.fresh_sort_in_family !evd x in - evd := sigma; fs - ) + evd := sigma; + fs) fas in (* We create the first principle by tactic *) - let first_type,other_princ_types = + let first_type, other_princ_types = match l_schemes with - s::l_schemes -> s,l_schemes - | _ -> CErrors.anomaly (Pp.str "") + | s :: l_schemes -> (s, l_schemes) + | _ -> CErrors.anomaly (Pp.str "") in let opaque = let finfos = @@ -1228,280 +1395,298 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef | None -> raise Not_found | Some finfos -> finfos in - let open Proof_global in + let open Declare in match finfos.equation_lemma with | None -> Transparent (* non recursive definition *) | Some equation -> - if Declareops.is_opaque (Global.lookup_constant equation) then Opaque else Transparent + if Declareops.is_opaque (Global.lookup_constant equation) then Opaque + else Transparent in let entry, _hook = try - build_functional_principle ~opaque evd - first_type - (Array.of_list sorts) - this_block_funs - 0 - (Functional_principles_proofs.prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) + build_functional_principle ~opaque evd first_type (Array.of_list sorts) + this_block_funs 0 + (Functional_principles_proofs.prove_princ_for_struct evd false 0 + (Array.of_list (List.map fst funs))) (fun _ _ -> ()) - with e when CErrors.noncritical e -> - raise (Defining_principle e) - + with e when CErrors.noncritical e -> raise (Defining_principle e) in incr i; (* The others are just deduced *) - if List.is_empty other_princ_types - then [entry] + if List.is_empty other_princ_types then [entry] else let other_fun_princ_types = let funs = Array.map Constr.mkConstU this_block_funs in let sorts = Array.of_list sorts in - List.map (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) other_princ_types + List.map + (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) + other_princ_types in let first_princ_body = entry.Declare.proof_entry_body in - let ctxt,fix = Term.decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) - let (idxs,_),(_,ta,_ as decl) = Constr.destFix fix in + let ctxt, fix = + Term.decompose_lam_assum (fst (fst (Future.force first_princ_body))) + in + (* the principle has for forall ...., fix .*) + let (idxs, _), ((_, ta, _) as decl) = Constr.destFix fix in let other_result = List.map (* we can now compute the other principles *) (fun scheme_type -> - incr i; - observe (Printer.pr_lconstr_env env sigma scheme_type); - let type_concl = (Term.strip_prod_assum scheme_type) in - let applied_f = List.hd (List.rev (snd (Constr.decompose_app type_concl))) in - let f = fst (Constr.decompose_app applied_f) in - try (* we search the number of the function in the fix block (name of the function) *) - Array.iteri - (fun j t -> - let t = (Term.strip_prod_assum t) in - let applied_g = List.hd (List.rev (snd (Constr.decompose_app t))) in + incr i; + observe (Printer.pr_lconstr_env env sigma scheme_type); + let type_concl = Term.strip_prod_assum scheme_type in + let applied_f = + List.hd (List.rev (snd (Constr.decompose_app type_concl))) + in + let f = fst (Constr.decompose_app applied_f) in + try + (* we search the number of the function in the fix block (name of the function) *) + Array.iteri + (fun j t -> + let t = Term.strip_prod_assum t in + let applied_g = + List.hd (List.rev (snd (Constr.decompose_app t))) + in let g = fst (Constr.decompose_app applied_g) in - if Constr.equal f g - then raise (Found_type j); - observe Pp.(Printer.pr_lconstr_env env sigma f ++ str " <> " ++ - Printer.pr_lconstr_env env sigma g) - - ) - ta; - (* If we reach this point, the two principle are not mutually recursive - We fall back to the previous method - *) - let entry, _hook = - build_functional_principle - evd - (List.nth other_princ_types (!i - 1)) - (Array.of_list sorts) - this_block_funs - !i - (Functional_principles_proofs.prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) - (fun _ _ -> ()) - in - entry - with Found_type i -> - let princ_body = - Termops.it_mkLambda_or_LetIn (Constr.mkFix((idxs,i),decl)) ctxt - in - Declare.definition_entry ~types:scheme_type princ_body - ) - other_fun_princ_types + if Constr.equal f g then raise (Found_type j); + observe + Pp.( + Printer.pr_lconstr_env env sigma f + ++ str " <> " + ++ Printer.pr_lconstr_env env sigma g)) + ta; + (* If we reach this point, the two principle are not mutually recursive + We fall back to the previous method + *) + let entry, _hook = + build_functional_principle evd + (List.nth other_princ_types (!i - 1)) + (Array.of_list sorts) this_block_funs !i + (Functional_principles_proofs.prove_princ_for_struct evd false + !i + (Array.of_list (List.map fst funs))) + (fun _ _ -> ()) + in + entry + with Found_type i -> + let princ_body = + Termops.it_mkLambda_or_LetIn (Constr.mkFix ((idxs, i), decl)) ctxt + in + Declare.definition_entry ~types:scheme_type princ_body) + other_fun_princ_types in - entry::other_result + entry :: other_result (* [derive_correctness funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] *) -let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = +let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) + = let open EConstr in assert (funs <> []); assert (graphs <> []); let funs = Array.of_list funs and graphs = Array.of_list graphs in let map (c, u) = mkConstU (c, EInstance.make u) in - let funs_constr = Array.map map funs in + let funs_constr = Array.map map funs in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) funind_purify (fun () -> - let env = Global.env () in - let evd = ref (Evd.from_env env) in - let graphs_constr = Array.map mkInd graphs in - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd false f_constr graph - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in - evd := sigma; - let type_of_lemma = Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma in - observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - let schemes = - (* The functional induction schemes are computed and not saved if there is more that one function - if the block contains only one function we can safely reuse [f_rect] - *) - try - if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; - [| find_induction_principle evd funs_constr.(0) |] - with Not_found -> - ( - - Array.of_list - (List.map - (fun entry -> - (EConstr.of_constr (fst (fst (Future.force entry.Declare.proof_entry_body))), - EConstr.of_constr (Option.get entry.Declare.proof_entry_type )) - ) - (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) - ) - ) - in - let proving_tac = - prove_fun_correct !evd graphs_constr schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_correct_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_correct_id f_id in - let (typ,_) = lemmas_types_infos.(i) in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false !evd typ in - let lemma = fst @@ Lemmas.by - (Proofview.V82.tactic (proving_tac i)) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = - match find_Function_infos (fst f_as_constant) with - | None -> raise Not_found - | Some finfo -> finfo + let env = Global.env () in + let evd = ref (Evd.from_env env) in + let graphs_constr = Array.map mkInd graphs in + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + let type_of_lemma_ctxt, type_of_lemma_concl, graph = + generate_type evd false f_constr graph in - (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = EConstr.destConst !evd lem_cst_constr in - update_Function {finfo with correctness_lemma = Some lem_cst}; - - ) - funs; - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd true f_constr graph - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = - EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt - in - let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in - observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - - let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in - let mib, _mip = Global.lookup_inductive graph_ind in - let sigma, scheme = - (Indrec.build_mutual_induction_scheme (Global.env ()) !evd - (Array.to_list - (Array.mapi - (fun i _ -> ((kn,i), EInstance.kind !evd u),true, Sorts.InType) - mib.Declarations.mind_packets - ) - ) - ) - in - let schemes = - Array.of_list scheme - in - let proving_tac = - prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_complete_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_complete_id f_id in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false sigma (fst lemmas_types_infos.(i)) in - let lemma = fst (Lemmas.by - (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i))) lemma) in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = - match find_Function_infos (fst f_as_constant) with - | None -> raise Not_found - | Some finfo -> finfo + let type_info = (type_of_lemma_ctxt, type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst !evd lem_cst_constr in - update_Function {finfo with completeness_lemma = Some lem_cst} - ) - funs) + let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in + evd := sigma; + let type_of_lemma = + Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma + in + observe + Pp.( + str "type_of_lemma := " + ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); + (type_of_lemma, type_info)) + funs_constr graphs_constr + in + let schemes = + (* The functional induction schemes are computed and not saved if there is more that one function + if the block contains only one function we can safely reuse [f_rect] + *) + try + if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; + [|find_induction_principle evd funs_constr.(0)|] + with Not_found -> + Array.of_list + (List.map + (fun entry -> + ( EConstr.of_constr + (fst (fst (Future.force entry.Declare.proof_entry_body))) + , EConstr.of_constr (Option.get entry.Declare.proof_entry_type) + )) + (make_scheme evd + (Array.map_to_list (fun const -> (const, Sorts.InType)) funs))) + in + let proving_tac = + prove_fun_correct !evd graphs_constr schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_correct_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_correct_id f_id in + let typ, _ = lemmas_types_infos.(i) in + let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false !evd typ in + let lemma = + fst @@ Lemmas.by (Proofview.V82.tactic (proving_tac i)) lemma + in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent + ~idopt:None + in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in + (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) + let _, lem_cst_constr = + Evd.fresh_global (Global.env ()) !evd + (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) + in + let lem_cst, _ = EConstr.destConst !evd lem_cst_constr in + update_Function {finfo with correctness_lemma = Some lem_cst}) + funs; + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + let type_of_lemma_ctxt, type_of_lemma_concl, graph = + generate_type evd true f_constr graph + in + let type_info = (type_of_lemma_ctxt, type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + in + let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in + observe + Pp.( + str "type_of_lemma := " + ++ Printer.pr_leconstr_env env !evd type_of_lemma); + (type_of_lemma, type_info)) + funs_constr graphs_constr + in + let ((kn, _) as graph_ind), u = destInd !evd graphs_constr.(0) in + let mib, _mip = Global.lookup_inductive graph_ind in + let sigma, scheme = + Indrec.build_mutual_induction_scheme (Global.env ()) !evd + (Array.to_list + (Array.mapi + (fun i _ -> + (((kn, i), EInstance.kind !evd u), true, Sorts.InType)) + mib.Declarations.mind_packets)) + in + let schemes = Array.of_list scheme in + let proving_tac = + prove_fun_complete funs_constr mib.Declarations.mind_packets schemes + lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_complete_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_complete_id f_id in + let lemma = + Lemmas.start_lemma ~name:lem_id ~poly:false sigma + (fst lemmas_types_infos.(i)) + in + let lemma = + fst + (Lemmas.by + (Proofview.V82.tactic + (observe_tac + ("prove completeness (" ^ Id.to_string f_id ^ ")") + (proving_tac i))) + lemma) + in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent + ~idopt:None + in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in + let _, lem_cst_constr = + Evd.fresh_global (Global.env ()) !evd + (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) + in + let lem_cst, _ = destConst !evd lem_cst_constr in + update_Function {finfo with completeness_lemma = Some lem_cst}) + funs) () let warn_funind_cannot_build_inversion = CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind" - Pp.(fun e' -> strbrk "Cannot build inversion information" ++ - if do_observe () then (fnl() ++ CErrors.print e') else mt ()) + Pp.( + fun e' -> + strbrk "Cannot build inversion information" + ++ if do_observe () then fnl () ++ CErrors.print e' else mt ()) let derive_inversion fix_names = try let evd' = Evd.from_env (Global.env ()) in (* we first transform the fix_names identifier into their corresponding constant *) - let evd',fix_names_as_constant = + let evd', fix_names_as_constant = List.fold_right - (fun id (evd,l) -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - let (cst, u) = EConstr.destConst evd c in - evd, (cst, EConstr.EInstance.kind evd u) :: l - ) - fix_names - (evd',[]) + (fun id (evd, l) -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident id)) + in + let cst, u = EConstr.destConst evd c in + (evd, (cst, EConstr.EInstance.kind evd u) :: l)) + fix_names (evd', []) in (* Then we check that the graphs have been defined If one of the graphs haven't been defined we do nothing *) - List.iter (fun c -> ignore (find_Function_infos (fst c))) fix_names_as_constant ; + List.iter + (fun c -> ignore (find_Function_infos (fst c))) + fix_names_as_constant; try let _evd', lind = List.fold_right - (fun id (evd,l) -> - let evd,id = - Evd.fresh_global - (Global.env ()) evd - (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) - in - evd,(fst (EConstr.destInd evd id))::l - ) - fix_names - (evd',[]) + (fun id (evd, l) -> + let evd, id = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident (mk_rel_id id))) + in + (evd, fst (EConstr.destInd evd id) :: l)) + fix_names (evd', []) in - derive_correctness - fix_names_as_constant - lind; - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - -let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body - pre_hook - = + derive_correctness fix_names_as_constant lind + with e when CErrors.noncritical e -> warn_funind_cannot_build_inversion e + with e when CErrors.noncritical e -> warn_funind_cannot_build_inversion e + +let register_wf interactive_proof ?(is_mes = false) fname rec_impls wf_rel_expr + wf_arg using_lemmas args ret_type body pre_hook = let type_of_f = Constrexpr_ops.mkCProdN args ret_type in let rec_arg_num = let names = @@ -1513,226 +1698,233 @@ let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf in let unbounded_eq = let f_app_args = - CAst.make @@ Constrexpr.CAppExpl( - (None, Libnames.qualid_of_ident fname,None) , - (List.map - (function - | {CAst.v=Anonymous} -> assert false - | {CAst.v=Name e} -> (Constrexpr_ops.mkIdentC e) - ) - (Constrexpr_ops.names_of_local_assums args) - ) - ) + CAst.make + @@ Constrexpr.CAppExpl + ( (None, Libnames.qualid_of_ident fname, None) + , List.map + (function + | {CAst.v = Anonymous} -> assert false + | {CAst.v = Name e} -> Constrexpr_ops.mkIdentC e) + (Constrexpr_ops.names_of_local_assums args) ) in - CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (Libnames.qualid_of_string "Logic.eq")), - [(f_app_args,None);(body,None)]) + CAst.make + @@ Constrexpr.CApp + ( (None, Constrexpr_ops.mkRefC (Libnames.qualid_of_string "Logic.eq")) + , [(f_app_args, None); (body, None)] ) in let eq = Constrexpr_ops.mkCProdN args unbounded_eq in - let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type - _nb_args relation = + let hook ((f_ref, _) as fconst) tcc_lemma_ref (functional_ref, _) (eq_ref, _) + rec_arg_num rec_arg_type _nb_args relation = try pre_hook [fconst] - (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes - functional_ref eq_ref rec_arg_num rec_arg_type relation - ); + (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref + eq_ref rec_arg_num rec_arg_type relation); derive_inversion [fname] - with e when CErrors.noncritical e -> - (* No proof done *) - () + with e when CErrors.noncritical e -> (* No proof done *) + () in - Recdef.recursive_definition ~interactive_proof - ~is_mes fname rec_impls - type_of_f - wf_rel_expr - rec_arg_num - eq - hook - using_lemmas - -let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = - let wf_arg_type,wf_arg = + Recdef.recursive_definition ~interactive_proof ~is_mes fname rec_impls + type_of_f wf_rel_expr rec_arg_num eq hook using_lemmas + +let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt + wf_arg using_lemmas args ret_type body = + let wf_arg_type, wf_arg = match wf_arg with - | None -> - begin - match args with - | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],_k,t)] -> t,x - | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") - end - | Some wf_args -> + | None -> ( + match args with + | [Constrexpr.CLocalAssum ([{CAst.v = Name x}], _k, t)] -> (t, x) + | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") ) + | Some wf_args -> ( try match List.find (function - | Constrexpr.CLocalAssum(l,_k,t) -> + | Constrexpr.CLocalAssum (l, _k, t) -> List.exists - (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) + (function + | {CAst.v = Name id} -> Id.equal id wf_args | _ -> false) l - | _ -> false - ) + | _ -> false) args with - | Constrexpr.CLocalAssum(_,_k,t) -> t,wf_args + | Constrexpr.CLocalAssum (_, _k, t) -> (t, wf_args) | _ -> assert false - with Not_found -> assert false + with Not_found -> assert false ) in - let wf_rel_from_mes,is_mes = + let wf_rel_from_mes, is_mes = match wf_rel_expr_opt with | None -> let ltof = let make_dir l = DirPath.make (List.rev_map Id.of_string l) in Libnames.qualid_of_path - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")) + (Libnames.make_path + (make_dir ["Arith"; "Wf_nat"]) + (Id.of_string "ltof")) in let fun_from_mes = let applied_mes = - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in - Constrexpr_ops.mkLambdaC ([CAst.make @@ Name wf_arg],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) + Constrexpr_ops.mkAppC (wf_mes_expr, [Constrexpr_ops.mkIdentC wf_arg]) + in + Constrexpr_ops.mkLambdaC + ( [CAst.make @@ Name wf_arg] + , Constrexpr_ops.default_binder_kind + , wf_arg_type + , applied_mes ) in let wf_rel_from_mes = - Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) + Constrexpr_ops.mkAppC + (Constrexpr_ops.mkRefC ltof, [wf_arg_type; fun_from_mes]) in - wf_rel_from_mes,true + (wf_rel_from_mes, true) | Some wf_rel_expr -> let wf_rel_with_mes = let a = Names.Id.of_string "___a" in let b = Names.Id.of_string "___b" in - Constrexpr_ops.mkLambdaC( - [CAst.make @@ Name a; CAst.make @@ Name b], - Constrexpr.Default Glob_term.Explicit, - wf_arg_type, - Constrexpr_ops.mkAppC(wf_rel_expr, - [ - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) - ]) - ) + Constrexpr_ops.mkLambdaC + ( [CAst.make @@ Name a; CAst.make @@ Name b] + , Constrexpr.Default Glob_term.Explicit + , wf_arg_type + , Constrexpr_ops.mkAppC + ( wf_rel_expr + , [ Constrexpr_ops.mkAppC + (wf_mes_expr, [Constrexpr_ops.mkIdentC a]) + ; Constrexpr_ops.mkAppC + (wf_mes_expr, [Constrexpr_ops.mkIdentC b]) ] ) ) in - wf_rel_with_mes,false + (wf_rel_with_mes, false) in - register_wf interactive_proof ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg + register_wf interactive_proof ~is_mes fname rec_impls wf_rel_from_mes wf_arg using_lemmas args ret_type body -let do_generate_principle_aux pconstants on_error register_built interactive_proof fixpoint_exprl : Lemmas.t option = - List.iter (fun { Vernacexpr.notations } -> - if not (List.is_empty notations) - then CErrors.user_err (Pp.str "Function does not support notations for now")) fixpoint_exprl; +let do_generate_principle_aux pconstants on_error register_built + interactive_proof fixpoint_exprl : Lemmas.t option = + List.iter + (fun {Vernacexpr.notations} -> + if not (List.is_empty notations) then + CErrors.user_err (Pp.str "Function does not support notations for now")) + fixpoint_exprl; let lemma, _is_struct = match fixpoint_exprl with - | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs = _; binders; rtype; body_def } as fixpoint_expr = + | [ ( { Vernacexpr.rec_order = + Some {CAst.v = Constrexpr.CWfRec (wf_x, wf_rel)} } as + fixpoint_expr ) ] -> + let ( {Vernacexpr.fname; univs = _; binders; rtype; body_def} as + fixpoint_expr ) = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let body = match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let body = + match body_def with + | Some body -> body + | None -> + CErrors.user_err ~hdr:"Function" + (Pp.str "Body of Function must be given") + in + let recdefs, rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs + pconstants on_error true register_built fixpoint_exprl recdefs in - if register_built - then register_wf interactive_proof fname.CAst.v rec_impls wf_rel wf_x.CAst.v using_lemmas binders rtype body pre_hook, false - else None, false - | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs = _; binders; rtype; body_def} as fixpoint_expr = + if register_built then + ( register_wf interactive_proof fname.CAst.v rec_impls wf_rel + wf_x.CAst.v using_lemmas binders rtype body pre_hook + , false ) + else (None, false) + | [ ( { Vernacexpr.rec_order = + Some {CAst.v = Constrexpr.CMeasureRec (wf_x, wf_mes, wf_rel_opt)} + } as fixpoint_expr ) ] -> + let ( {Vernacexpr.fname; univs = _; binders; rtype; body_def} as + fixpoint_expr ) = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let recdefs, rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in - let body = match body_def with + let body = + match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in + CErrors.user_err ~hdr:"Function" + Pp.(str "Body of Function must be given") + in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs + pconstants on_error true register_built fixpoint_exprl recdefs in - if register_built - then register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt - (Option.map (fun x -> x.CAst.v) wf_x) using_lemmas binders rtype body pre_hook, true - else None, true + if register_built then + ( register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt + (Option.map (fun x -> x.CAst.v) wf_x) + using_lemmas binders rtype body pre_hook + , true ) + else (None, true) | _ -> - List.iter (function { Vernacexpr.rec_order } -> - match rec_order with - | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> - CErrors.user_err - (Pp.str "Cannot use mutual definition with well-founded recursion or measure") - | _ -> () - ) + List.iter + (function + | {Vernacexpr.rec_order} -> ( + match rec_order with + | Some {CAst.v = Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _} -> + CErrors.user_err + (Pp.str + "Cannot use mutual definition with well-founded recursion \ + or measure") + | _ -> () )) fixpoint_exprl; let fixpoint_exprl = recompute_binder_list fixpoint_exprl in - let fix_names = List.map (function { Vernacexpr.fname } -> fname.CAst.v) fixpoint_exprl in + let fix_names = + List.map (function {Vernacexpr.fname} -> fname.CAst.v) fixpoint_exprl + in (* ok all the expressions are structural *) let recdefs, _rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in - let lemma,evd,pconstants = - if register_built - then register_struct is_rec fixpoint_exprl - else None, Evd.from_env (Global.env ()), pconstants + let lemma, evd, pconstants = + if register_built then register_struct is_rec fixpoint_exprl + else (None, Evd.from_env (Global.env ()), pconstants) in let evd = ref evd in - generate_principle - (ref !evd) - pconstants - on_error - false - register_built - fixpoint_exprl - recdefs - (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); - if register_built then - begin derive_inversion fix_names; end; - lemma, true + generate_principle (ref !evd) pconstants on_error false register_built + fixpoint_exprl recdefs + (Functional_principles_proofs.prove_princ_for_struct evd + interactive_proof); + if register_built then derive_inversion fix_names; + (lemma, true) in lemma let warn_cannot_define_graph = CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind" - (fun (names,error) -> - Pp.(strbrk "Cannot define graph(s) for " ++ - h 1 names ++ error)) + (fun (names, error) -> + Pp.(strbrk "Cannot define graph(s) for " ++ h 1 names ++ error)) let warn_cannot_define_principle = CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind" - (fun (names,error) -> - Pp.(strbrk "Cannot define induction principle(s) for "++ - h 1 names ++ error)) + (fun (names, error) -> + Pp.( + strbrk "Cannot define induction principle(s) for " ++ h 1 names ++ error)) let warning_error names e = let e_explain e = match e with - | ToShow e -> - Pp.(spc () ++ CErrors.print e) - | _ -> - if do_observe () - then Pp.(spc () ++ CErrors.print e) - else Pp.mt () + | ToShow e -> Pp.(spc () ++ CErrors.print e) + | _ -> if do_observe () then Pp.(spc () ++ CErrors.print e) else Pp.mt () in match e with | Building_graph e -> - let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in - warn_cannot_define_graph (names,e_explain e) + let names = + Pp.(prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + in + warn_cannot_define_graph (names, e_explain e) | Defining_principle e -> - let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in - warn_cannot_define_principle (names,e_explain e) + let names = + Pp.(prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + in + warn_cannot_define_principle (names, e_explain e) | _ -> raise e let error_error names e = @@ -1744,9 +1936,11 @@ let error_error names e = match e with | Building_graph e -> CErrors.user_err - Pp.(str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - e_explain e) + Pp.( + str "Cannot define graph(s) for " + ++ h 1 + (prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + ++ e_explain e) | _ -> raise e (* [chop_n_arrow n t] chops the [n] first arrows in [t] @@ -1755,272 +1949,307 @@ let error_error names e = let rec chop_n_arrow n t = let exception Stop of Constrexpr.constr_expr in let open Constrexpr in - if n <= 0 - then t (* If we have already removed all the arrows then return the type *) - else (* If not we check the form of [t] *) + if n <= 0 then t + (* If we have already removed all the arrows then return the type *) + else + (* If not we check the form of [t] *) match t.CAst.v with - | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results are possible : - either we need to discard more than the number of arrows contained - in this product declaration then we just recall [chop_n_arrow] on - the remaining number of arrow to chop and [t'] we discard it and - recall [chop_n_arrow], either this product contains more arrows - than the number we need to chop and then we return the new type - *) - begin - try - let new_n = - let rec aux (n:int) = function - [] -> n - | CLocalAssum(nal,k,t'')::nal_ta' -> - let nal_l = List.length nal in - if n >= nal_l - then - aux (n - nal_l) nal_ta' - else - let new_t' = CAst.make @@ - Constrexpr.CProdN( - CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t') - in - raise (Stop new_t') - | _ -> CErrors.anomaly (Pp.str "Not enough products.") - in - aux n nal_ta' + | Constrexpr.CProdN (nal_ta', t') -> ( + try + (* If we have a forall, two results are possible : + either we need to discard more than the number of arrows contained + in this product declaration then we just recall [chop_n_arrow] on + the remaining number of arrow to chop and [t'] we discard it and + recall [chop_n_arrow], either this product contains more arrows + than the number we need to chop and then we return the new type + *) + let new_n = + let rec aux (n : int) = function + | [] -> n + | CLocalAssum (nal, k, t'') :: nal_ta' -> + let nal_l = List.length nal in + if n >= nal_l then aux (n - nal_l) nal_ta' + else + let new_t' = + CAst.make + @@ Constrexpr.CProdN + ( CLocalAssum (snd (List.chop n nal), k, t'') :: nal_ta' + , t' ) + in + raise (Stop new_t') + | _ -> CErrors.anomaly (Pp.str "Not enough products.") in - chop_n_arrow new_n t' - with Stop t -> t - end + aux n nal_ta' + in + chop_n_arrow new_n t' + with Stop t -> t ) | _ -> CErrors.anomaly (Pp.str "Not enough products.") let rec add_args id new_args = let open Libnames in let open Constrexpr in CAst.map (function - | CRef (qid,_) as b -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((None,qid,None),new_args) - else b - | CFix _ | CCoFix _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "todo.") - | CProdN(nal,b1) -> - CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> - CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLambdaN(nal,b1) -> - CLambdaN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> - CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLetIn(na,b1,t,b2) -> - CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) - | CAppExpl((pf,qid,us),exprl) -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((pf,qid,us),new_args@(List.map (add_args id new_args) exprl)) - else CAppExpl((pf,qid,us),List.map (add_args id new_args) exprl) - | CApp((pf,b),bl) -> - CApp((pf,add_args id new_args b), - List.map (fun (e,o) -> add_args id new_args e,o) bl) - | CCases(sty,b_option,cel,cal) -> - CCases(sty,Option.map (add_args id new_args) b_option, - List.map (fun (b,na,b_option) -> - add_args id new_args b, - na, b_option) cel, - List.map CAst.(map (fun (cpl,e) -> (cpl,add_args id new_args e))) cal - ) - | CLetTuple(nal,(na,b_option),b1,b2) -> - CLetTuple(nal,(na,Option.map (add_args id new_args) b_option), - add_args id new_args b1, - add_args id new_args b2 - ) - - | CIf(b1,(na,b_option),b2,b3) -> - CIf(add_args id new_args b1, - (na,Option.map (add_args id new_args) b_option), - add_args id new_args b2, - add_args id new_args b3 - ) - | CHole _ - | CPatVar _ - | CEvar _ - | CPrim _ - | CSort _ as b -> b - | CCast(b1,b2) -> - CCast(add_args id new_args b1, - Glob_ops.map_cast_type (add_args id new_args) b2) - | CRecord pars -> - CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) - | CNotation _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CNotation.") - | CGeneralization _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CGeneralization.") - | CDelimiters _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.") - ) - -let rec get_args b t : Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr = + | CRef (qid, _) as b -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl ((None, qid, None), new_args) + else b + | CFix _ | CCoFix _ -> CErrors.anomaly ~label:"add_args " (Pp.str "todo.") + | CProdN (nal, b1) -> + CProdN + ( List.map + (function + | CLocalAssum (nal, k, b2) -> + CLocalAssum (nal, k, add_args id new_args b2) + | CLocalDef (na, b1, t) -> + CLocalDef + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t ) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) + nal + , add_args id new_args b1 ) + | CLambdaN (nal, b1) -> + CLambdaN + ( List.map + (function + | CLocalAssum (nal, k, b2) -> + CLocalAssum (nal, k, add_args id new_args b2) + | CLocalDef (na, b1, t) -> + CLocalDef + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t ) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) + nal + , add_args id new_args b1 ) + | CLetIn (na, b1, t, b2) -> + CLetIn + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t + , add_args id new_args b2 ) + | CAppExpl ((pf, qid, us), exprl) -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl + ((pf, qid, us), new_args @ List.map (add_args id new_args) exprl) + else CAppExpl ((pf, qid, us), List.map (add_args id new_args) exprl) + | CApp ((pf, b), bl) -> + CApp + ( (pf, add_args id new_args b) + , List.map (fun (e, o) -> (add_args id new_args e, o)) bl ) + | CCases (sty, b_option, cel, cal) -> + CCases + ( sty + , Option.map (add_args id new_args) b_option + , List.map + (fun (b, na, b_option) -> (add_args id new_args b, na, b_option)) + cel + , List.map + CAst.(map (fun (cpl, e) -> (cpl, add_args id new_args e))) + cal ) + | CLetTuple (nal, (na, b_option), b1, b2) -> + CLetTuple + ( nal + , (na, Option.map (add_args id new_args) b_option) + , add_args id new_args b1 + , add_args id new_args b2 ) + | CIf (b1, (na, b_option), b2, b3) -> + CIf + ( add_args id new_args b1 + , (na, Option.map (add_args id new_args) b_option) + , add_args id new_args b2 + , add_args id new_args b3 ) + | (CHole _ | CPatVar _ | CEvar _ | CPrim _ | CSort _) as b -> b + | CCast (b1, b2) -> + CCast + ( add_args id new_args b1 + , Glob_ops.map_cast_type (add_args id new_args) b2 ) + | CRecord pars -> + CRecord (List.map (fun (e, o) -> (e, add_args id new_args o)) pars) + | CNotation _ -> CErrors.anomaly ~label:"add_args " (Pp.str "CNotation.") + | CGeneralization _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CGeneralization.") + | CDelimiters _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.")) + +let rec get_args b t : + Constrexpr.local_binder_expr list + * Constrexpr.constr_expr + * Constrexpr.constr_expr = let open Constrexpr in match b.CAst.v with - | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') -> - begin - let n = List.length nal in - let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in - d :: nal_tas, b'',t'' - end - | Constrexpr.CLambdaN ([], b) -> [],b,t - | _ -> [],b,t + | Constrexpr.CLambdaN ((CLocalAssum (nal, k, ta) as d) :: rest, b') -> + let n = List.length nal in + let nal_tas, b'', t'' = + get_args + (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest, b')) + (chop_n_arrow n t) + in + (d :: nal_tas, b'', t'') + | Constrexpr.CLambdaN ([], b) -> ([], b, t) + | _ -> ([], b, t) let make_graph (f_ref : GlobRef.t) = let open Constrexpr in - let env = Global.env() in + let env = Global.env () in let sigma = Evd.from_env env in - let c,c_body = + let c, c_body = match f_ref with - | GlobRef.ConstRef c -> - begin - try c,Global.lookup_constant c - with Not_found -> - CErrors.user_err Pp.(str "Cannot find " ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) - end - | _ -> - CErrors.user_err Pp.(str "Not a function reference") + | GlobRef.ConstRef c -> ( + try (c, Global.lookup_constant c) + with Not_found -> + CErrors.user_err + Pp.( + str "Cannot find " + ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) ) + | _ -> CErrors.user_err Pp.(str "Not a function reference") in - (match Global.body_of_constant_body Library.indirect_accessor c_body with - | None -> - CErrors.user_err (Pp.str "Cannot build a graph over an axiom!") - | Some (body, _, _) -> - let env = Global.env () in - let extern_body,extern_type = - with_full_print (fun () -> - (Constrextern.extern_constr env sigma (EConstr.of_constr body), - Constrextern.extern_type env sigma - (EConstr.of_constr (*FIXME*) c_body.Declarations.const_type) - ) - ) - () - in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b.CAst.v with - | Constrexpr.CFix(l_id,fixexprl) -> - let l = - List.map - (fun (id,recexp,bl,t,b) -> - let { CAst.loc; v=rec_id } = match Option.get recexp with - | { CAst.v = CStructRec id } -> id - | { CAst.v = CWfRec (id,_) } -> id - | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid - in - let new_args = - List.flatten - (List.map - (function - | Constrexpr.CLocalDef (na,_,_)-> [] - | Constrexpr.CLocalAssum (nal,_,_) -> - List.map - (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) - nal - | Constrexpr.CLocalPattern _ -> assert false - ) - nal_tas - ) - in - let b' = add_args id.CAst.v new_args b in - { Vernacexpr.fname=id; univs=None - ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) - ; binders = nal_tas@bl; rtype=t; body_def=Some b'; notations = []} - ) - fixexprl - in - l - | _ -> - let fname = CAst.make (Label.to_id (Constant.label c)) in - [{ Vernacexpr.fname; univs=None; rec_order = None; binders=nal_tas; rtype=t; body_def=Some b; notations=[]}] - in - let mp = Constant.modpath c in - let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in - assert (Option.is_empty pstate); - (* We register the infos *) - List.iter - (fun { Vernacexpr.fname= {CAst.v=id} } -> - add_Function false (Constant.make2 mp (Label.of_id id))) - expr_list) + match Global.body_of_constant_body Library.indirect_accessor c_body with + | None -> CErrors.user_err (Pp.str "Cannot build a graph over an axiom!") + | Some (body, _, _) -> + let env = Global.env () in + let extern_body, extern_type = + with_full_print + (fun () -> + ( Constrextern.extern_constr env sigma (EConstr.of_constr body) + , Constrextern.extern_type env sigma + (EConstr.of_constr (*FIXME*) c_body.Declarations.const_type) )) + () + in + let nal_tas, b, t = get_args extern_body extern_type in + let expr_list = + match b.CAst.v with + | Constrexpr.CFix (l_id, fixexprl) -> + let l = + List.map + (fun (id, recexp, bl, t, b) -> + let {CAst.loc; v = rec_id} = + match Option.get recexp with + | {CAst.v = CStructRec id} -> id + | {CAst.v = CWfRec (id, _)} -> id + | {CAst.v = CMeasureRec (oid, _, _)} -> Option.get oid + in + let new_args = + List.flatten + (List.map + (function + | Constrexpr.CLocalDef (na, _, _) -> [] + | Constrexpr.CLocalAssum (nal, _, _) -> + List.map + (fun {CAst.loc; v = n} -> + CAst.make ?loc + @@ CRef + ( Libnames.qualid_of_ident ?loc + @@ Nameops.Name.get_id n + , None )) + nal + | Constrexpr.CLocalPattern _ -> assert false) + nal_tas) + in + let b' = add_args id.CAst.v new_args b in + { Vernacexpr.fname = id + ; univs = None + ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) + ; binders = nal_tas @ bl + ; rtype = t + ; body_def = Some b' + ; notations = [] }) + fixexprl + in + l + | _ -> + let fname = CAst.make (Label.to_id (Constant.label c)) in + [ { Vernacexpr.fname + ; univs = None + ; rec_order = None + ; binders = nal_tas + ; rtype = t + ; body_def = Some b + ; notations = [] } ] + in + let mp = Constant.modpath c in + let pstate = + do_generate_principle_aux [(c, Univ.Instance.empty)] error_error false + false expr_list + in + assert (Option.is_empty pstate); + (* We register the infos *) + List.iter + (fun {Vernacexpr.fname = {CAst.v = id}} -> + add_Function false (Constant.make2 mp (Label.of_id id))) + expr_list (* *************** statically typed entrypoints ************************* *) let do_generate_principle_interactive fixl : Lemmas.t = - match - do_generate_principle_aux [] warning_error true true fixl - with + match do_generate_principle_aux [] warning_error true true fixl with | Some lemma -> lemma | None -> - CErrors.anomaly - (Pp.str"indfun: leaving no open proof in interactive mode") + CErrors.anomaly (Pp.str "indfun: leaving no open proof in interactive mode") let do_generate_principle fixl : unit = - match do_generate_principle_aux [] warning_error true false fixl with + match do_generate_principle_aux [] warning_error true false fixl with | Some _lemma -> CErrors.anomaly - (Pp.str"indfun: leaving a goal open in non-interactive mode") + (Pp.str "indfun: leaving a goal open in non-interactive mode") | None -> () - let build_scheme fas = - let evd = (ref (Evd.from_env (Global.env ()))) in - let pconstants = (List.map - (fun (_,f,sort) -> - let f_as_constant = - try - Smartlocate.global_with_alias f - with Not_found -> - CErrors.user_err ~hdr:"FunInd.build_scheme" - Pp.(str "Cannot find " ++ Libnames.pr_qualid f) - in - let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in - let _ = evd := evd' in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in - evd := sigma; - let c, u = - try EConstr.destConst !evd f - with Constr.DestKO -> - CErrors.user_err Pp.(Printer.pr_econstr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") - in - (c, EConstr.EInstance.kind !evd u), sort - ) - fas - ) in + let evd = ref (Evd.from_env (Global.env ())) in + let pconstants = + List.map + (fun (_, f, sort) -> + let f_as_constant = + try Smartlocate.global_with_alias f + with Not_found -> + CErrors.user_err ~hdr:"FunInd.build_scheme" + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) + in + let evd', f = Evd.fresh_global (Global.env ()) !evd f_as_constant in + let _ = evd := evd' in + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in + evd := sigma; + let c, u = + try EConstr.destConst !evd f + with Constr.DestKO -> + CErrors.user_err + Pp.( + Printer.pr_econstr_env (Global.env ()) !evd f + ++ spc () + ++ str "should be the named of a globally defined function") + in + ((c, EConstr.EInstance.kind !evd u), sort)) + fas + in let bodies_types = make_scheme evd pconstants in - List.iter2 - (fun (princ_id,_,_) def_entry -> - ignore - (Declare.declare_constant - ~name:princ_id - ~kind:Decls.(IsProof Theorem) - (Declare.DefinitionEntry def_entry)); - Declare.definition_message princ_id - ) - fas - bodies_types + (fun (princ_id, _, _) def_entry -> + ignore + (Declare.declare_constant ~name:princ_id + ~kind:Decls.(IsProof Theorem) + (Declare.DefinitionEntry def_entry)); + Declare.definition_message princ_id) + fas bodies_types let build_case_scheme fa = - let env = Global.env () - and sigma = (Evd.from_env (Global.env ())) in -(* let id_to_constr id = *) -(* Constrintern.global_reference id *) -(* in *) + let env = Global.env () and sigma = Evd.from_env (Global.env ()) in + (* let id_to_constr id = *) + (* Constrintern.global_reference id *) + (* in *) let funs = - let (_,f,_) = fa in - try (let open GlobRef in - match Smartlocate.global_with_alias f with - | ConstRef c -> c - | IndRef _ | ConstructRef _ | VarRef _ -> assert false) + let _, f, _ = fa in + try + let open GlobRef in + match Smartlocate.global_with_alias f with + | ConstRef c -> c + | IndRef _ | ConstructRef _ | VarRef _ -> assert false with Not_found -> CErrors.user_err ~hdr:"FunInd.build_case_scheme" - Pp.(str "Cannot find " ++ Libnames.pr_qualid f) in - let sigma, (_,u) = Evd.fresh_constant_instance env sigma funs in + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) + in + let sigma, (_, u) = Evd.fresh_constant_instance env sigma funs in let first_fun = funs in let funs_mp = Constant.modpath first_fun in let first_fun_kn = @@ -2029,39 +2258,39 @@ let build_case_scheme fa = | Some finfos -> fst finfos.graph_ind in let this_block_funs_indexes = get_funs_constant funs_mp first_fun in - let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in + let this_block_funs = + Array.map (fun (c, _) -> (c, u)) this_block_funs_indexes + in let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.assoc_f Constant.equal funs this_block_funs_indexes in - let (ind, sf) = - let ind = first_fun_kn,funs_indexes in - (ind,Univ.Instance.empty)(*FIXME*),prop_sort + let ind, sf = + let ind = (first_fun_kn, funs_indexes) in + ((ind, Univ.Instance.empty) (*FIXME*), prop_sort) in - let (sigma, scheme) = - Indrec.build_case_analysis_scheme_default env sigma ind sf + let sigma, scheme = + Indrec.build_case_analysis_scheme_default env sigma ind sf in - let scheme_type = EConstr.Unsafe.to_constr ((Retyping.get_type_of env sigma) (EConstr.of_constr scheme)) in - let sorts = - (fun (_,_,x) -> - fst @@ UnivGen.fresh_sort_in_family x - ) - fa + let scheme_type = + EConstr.Unsafe.to_constr + ((Retyping.get_type_of env sigma) (EConstr.of_constr scheme)) in - let princ_name = (fun (x,_,_) -> x) fa in - let _ : unit = - (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ - pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs - ); - *) + let sorts = (fun (_, _, x) -> fst @@ UnivGen.fresh_sort_in_family x) fa in + let princ_name = (fun (x, _, _) -> x) fa in + let (_ : unit) = + (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ + pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs + ); + *) generate_functional_principle (ref (Evd.from_env (Global.env ()))) scheme_type - (Some ([|sorts|])) - (Some princ_name) - this_block_funs - 0 - (Functional_principles_proofs.prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|funs|]) + (Some [|sorts|]) + (Some princ_name) this_block_funs 0 + (Functional_principles_proofs.prove_princ_for_struct + (ref (Evd.from_env (Global.env ()))) + false 0 [|funs|]) in () diff --git a/plugins/funind/gen_principle.mli b/plugins/funind/gen_principle.mli index 6313a2b16e..3c04d6cb7d 100644 --- a/plugins/funind/gen_principle.mli +++ b/plugins/funind/gen_principle.mli @@ -11,13 +11,14 @@ val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit -val do_generate_principle_interactive : Vernacexpr.fixpoint_expr list -> Lemmas.t -val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit +val do_generate_principle_interactive : + Vernacexpr.fixpoint_expr list -> Lemmas.t +val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit val make_graph : Names.GlobRef.t -> unit (* Can be thrown by build_{,case}_scheme *) exception No_graph_found val build_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) list -> unit -val build_case_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) -> unit +val build_case_scheme : Names.Id.t * Libnames.qualid * Sorts.family -> unit diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index e08ad9af3a..11e4fa0ac7 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -10,34 +10,27 @@ open Indfun_common open CErrors open Util open Glob_termops - module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () +let observe strm = if do_observe () then Feedback.msg_debug strm else () + (*let observennl strm = if do_observe () then Pp.msg strm else ()*) - -type binder_type = - | Lambda of Name.t - | Prod of Name.t - | LetIn of Name.t - -type glob_context = (binder_type*glob_constr) list - +type binder_type = Lambda of Name.t | Prod of Name.t | LetIn of Name.t +type glob_context = (binder_type * glob_constr) list let rec solve_trivial_holes pat_as_term e = - match DAst.get pat_as_term, DAst.get e with - | GHole _,_ -> e - | GApp(fp,argsp),GApp(fe,argse) when glob_constr_eq fp fe -> - DAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse)) - | _,_ -> pat_as_term + match (DAst.get pat_as_term, DAst.get e) with + | GHole _, _ -> e + | GApp (fp, argsp), GApp (fe, argse) when glob_constr_eq fp fe -> + DAst.make + (GApp + (solve_trivial_holes fp fe, List.map2 solve_trivial_holes argsp argse)) + | _, _ -> pat_as_term (* compose_glob_context [(bt_1,n_1,t_1);......] rt returns @@ -45,31 +38,26 @@ let rec solve_trivial_holes pat_as_term e = binders corresponding to the bt_i's *) let compose_glob_context = - let compose_binder (bt,t) acc = + let compose_binder (bt, t) acc = match bt with - | Lambda n -> mkGLambda(n,t,acc) - | Prod n -> mkGProd(n,t,acc) - | LetIn n -> mkGLetIn(n,t,None,acc) + | Lambda n -> mkGLambda (n, t, acc) + | Prod n -> mkGProd (n, t, acc) + | LetIn n -> mkGLetIn (n, t, None, acc) in List.fold_right compose_binder - (* The main part deals with building a list of globalized constructor expressions from the rhs of a fixpoint equation. *) type 'a build_entry_pre_return = - { - context : glob_context; (* the binding context of the result *) - value : 'a; (* The value *) - } + { context : glob_context + ; (* the binding context of the result *) + value : 'a (* The value *) } type 'a build_entry_return = - { - result : 'a build_entry_pre_return list; - to_avoid : Id.t list - } + {result : 'a build_entry_pre_return list; to_avoid : Id.t list} (* [combine_results combine_fun res1 res2] combine two results [res1] and [res2] @@ -81,64 +69,55 @@ type 'a build_entry_return = *) let combine_results - (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> - 'c build_entry_pre_return - ) - (res1: 'a build_entry_return) - (res2 : 'b build_entry_return) - : 'c build_entry_return - = - let pre_result = List.map - ( fun res1 -> (* for each result in arg_res *) - List.map (* we add it in each args_res *) - (fun res2 -> - combine_fun res1 res2 - ) - res2.result - ) + (combine_fun : + 'a build_entry_pre_return + -> 'b build_entry_pre_return + -> 'c build_entry_pre_return) (res1 : 'a build_entry_return) + (res2 : 'b build_entry_return) : 'c build_entry_return = + let pre_result = + List.map + (fun res1 -> + (* for each result in arg_res *) + List.map (* we add it in each args_res *) + (fun res2 -> combine_fun res1 res2) + res2.result) res1.result - in (* and then we flatten the map *) - { - result = List.concat pre_result; - to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid - } - + in + (* and then we flatten the map *) + { result = List.concat pre_result + ; to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid } (* The combination function for an argument with a list of argument *) let combine_args arg args = - { - context = arg.context@args.context; - (* Note that the binding context of [arg] MUST be placed before the one of + { context = arg.context @ args.context + ; (* Note that the binding context of [arg] MUST be placed before the one of [args] in order to preserve possible type dependencies *) - value = arg.value::args.value; - } + value = arg.value :: args.value } - -let ids_of_binder = function +let ids_of_binder = function | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> Id.Set.empty - | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> Id.Set.singleton id + | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> Id.Set.singleton id let rec change_vars_in_binder mapping = function - [] -> [] - | (bt,t)::l -> - let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in - (bt,change_vars mapping t):: - (if Id.Map.is_empty new_mapping - then l - else change_vars_in_binder new_mapping l - ) + | [] -> [] + | (bt, t) :: l -> + let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in + (bt, change_vars mapping t) + :: + ( if Id.Map.is_empty new_mapping then l + else change_vars_in_binder new_mapping l ) let rec replace_var_by_term_in_binder x_id term = function | [] -> [] - | (bt,t)::l -> - (bt,replace_var_by_term x_id term t):: - if Id.Set.mem x_id (ids_of_binder bt) - then l - else replace_var_by_term_in_binder x_id term l + | (bt, t) :: l -> + (bt, replace_var_by_term x_id term t) + :: + ( if Id.Set.mem x_id (ids_of_binder bt) then l + else replace_var_by_term_in_binder x_id term l ) let add_bt_names bt = Id.Set.union (ids_of_binder bt) @@ -146,128 +125,116 @@ let apply_args ctxt body args = let need_convert_id avoid id = List.exists (is_free_in id) args || Id.Set.mem id avoid in - let need_convert avoid bt = + let need_convert avoid bt = Id.Set.exists (need_convert_id avoid) (ids_of_binder bt) in - let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.Set.t) = + let next_name_away (na : Name.t) (mapping : Id.t Id.Map.t) (avoid : Id.Set.t) + = match na with - | Name id when Id.Set.mem id avoid -> - let new_id = Namegen.next_ident_away id avoid in - Name new_id,Id.Map.add id new_id mapping,Id.Set.add new_id avoid - | _ -> na,mapping,avoid + | Name id when Id.Set.mem id avoid -> + let new_id = Namegen.next_ident_away id avoid in + (Name new_id, Id.Map.add id new_id mapping, Id.Set.add new_id avoid) + | _ -> (na, mapping, avoid) in - let next_bt_away bt (avoid:Id.Set.t) = + let next_bt_away bt (avoid : Id.Set.t) = match bt with - | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - LetIn new_na,mapping,new_avoid - | Prod na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - Prod new_na,mapping,new_avoid - | Lambda na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - Lambda new_na,mapping,new_avoid + | LetIn na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (LetIn new_na, mapping, new_avoid) + | Prod na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (Prod new_na, mapping, new_avoid) + | Lambda na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (Lambda new_na, mapping, new_avoid) in let rec do_apply avoid ctxt body args = - match ctxt,args with - | _,[] -> (* No more args *) - (ctxt,body) - | [],_ -> (* no more fun *) - let f,args' = glob_decompose_app body in - (ctxt,mkGApp(f,args'@args)) - | (Lambda Anonymous,t)::ctxt',arg::args' -> - do_apply avoid ctxt' body args' - | (Lambda (Name id),t)::ctxt',arg::args' -> - let new_avoid,new_ctxt',new_body,new_id = - if need_convert_id avoid id - then - let new_avoid = Id.Set.add id avoid in - let new_id = Namegen.next_ident_away id new_avoid in - let new_avoid' = Id.Set.add new_id new_avoid in - let mapping = Id.Map.add id new_id Id.Map.empty in - let new_ctxt' = change_vars_in_binder mapping ctxt' in - let new_body = change_vars mapping body in - new_avoid',new_ctxt',new_body,new_id - else - Id.Set.add id avoid,ctxt',body,id - in - let new_body = replace_var_by_term new_id arg new_body in - let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in - do_apply avoid new_ctxt' new_body args' - | (bt,t)::ctxt',_ -> - let new_avoid,new_ctxt',new_body,new_bt = - let new_avoid = add_bt_names bt avoid in - if need_convert avoid bt - then - let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in - ( - new_avoid, - change_vars_in_binder mapping ctxt', - change_vars mapping body, - new_bt - ) - else new_avoid,ctxt',body,bt - in - let new_ctxt',new_body = - do_apply new_avoid new_ctxt' new_body args - in - (new_bt,t)::new_ctxt',new_body + match (ctxt, args) with + | _, [] -> + (* No more args *) + (ctxt, body) + | [], _ -> + (* no more fun *) + let f, args' = glob_decompose_app body in + (ctxt, mkGApp (f, args' @ args)) + | (Lambda Anonymous, t) :: ctxt', arg :: args' -> + do_apply avoid ctxt' body args' + | (Lambda (Name id), t) :: ctxt', arg :: args' -> + let new_avoid, new_ctxt', new_body, new_id = + if need_convert_id avoid id then + let new_avoid = Id.Set.add id avoid in + let new_id = Namegen.next_ident_away id new_avoid in + let new_avoid' = Id.Set.add new_id new_avoid in + let mapping = Id.Map.add id new_id Id.Map.empty in + let new_ctxt' = change_vars_in_binder mapping ctxt' in + let new_body = change_vars mapping body in + (new_avoid', new_ctxt', new_body, new_id) + else (Id.Set.add id avoid, ctxt', body, id) + in + let new_body = replace_var_by_term new_id arg new_body in + let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in + do_apply avoid new_ctxt' new_body args' + | (bt, t) :: ctxt', _ -> + let new_avoid, new_ctxt', new_body, new_bt = + let new_avoid = add_bt_names bt avoid in + if need_convert avoid bt then + let new_bt, mapping, new_avoid = next_bt_away bt new_avoid in + ( new_avoid + , change_vars_in_binder mapping ctxt' + , change_vars mapping body + , new_bt ) + else (new_avoid, ctxt', body, bt) + in + let new_ctxt', new_body = do_apply new_avoid new_ctxt' new_body args in + ((new_bt, t) :: new_ctxt', new_body) in do_apply Id.Set.empty ctxt body args - let combine_app f args = - let new_ctxt,new_value = apply_args f.context f.value args.value in - { - (* Note that the binding context of [args] MUST be placed before the one of + let new_ctxt, new_value = apply_args f.context f.value args.value in + { (* Note that the binding context of [args] MUST be placed before the one of the applied value in order to preserve possible type dependencies *) - context = args.context@new_ctxt; - value = new_value; - } + context = args.context @ new_ctxt + ; value = new_value } let combine_lam n t b = - { - context = []; - value = mkGLambda(n, compose_glob_context t.context t.value, - compose_glob_context b.context b.value ) - } + { context = [] + ; value = + mkGLambda + ( n + , compose_glob_context t.context t.value + , compose_glob_context b.context b.value ) } let combine_prod2 n t b = - { - context = []; - value = mkGProd(n, compose_glob_context t.context t.value, - compose_glob_context b.context b.value ) - } + { context = [] + ; value = + mkGProd + ( n + , compose_glob_context t.context t.value + , compose_glob_context b.context b.value ) } let combine_prod n t b = - { context = t.context@((Prod n,t.value)::b.context); value = b.value} + {context = t.context @ ((Prod n, t.value) :: b.context); value = b.value} let combine_letin n t b = - { context = t.context@((LetIn n,t.value)::b.context); value = b.value} - + {context = t.context @ ((LetIn n, t.value) :: b.context); value = b.value} let mk_result ctxt value avoid = - { - result = - [{context = ctxt; - value = value}] - ; - to_avoid = avoid - } + {result = [{context = ctxt; value}]; to_avoid = avoid} + (************************************************* Some functions to deal with overlapping patterns **************************************************) -let coq_True_ref = lazy (Coqlib.lib_ref "core.True.type") +let coq_True_ref = lazy (Coqlib.lib_ref "core.True.type") let coq_False_ref = lazy (Coqlib.lib_ref "core.False.type") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with (the list of expressions on which we will do the matching) *) -let make_discr_match_el = - List.map (fun e -> (e,(Anonymous,None))) +let make_discr_match_el = List.map (fun e -> (e, (Anonymous, None))) (* [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. @@ -283,23 +250,21 @@ let make_discr_match_el = *) let make_discr_match_brl i = List.map_i - (fun j {CAst.v=(idl,patl,_)} -> CAst.make @@ - if Int.equal j i - then (idl,patl, mkGRef (Lazy.force coq_True_ref)) - else (idl,patl, mkGRef (Lazy.force coq_False_ref)) - ) + (fun j {CAst.v = idl, patl, _} -> + CAst.make + @@ + if Int.equal j i then (idl, patl, mkGRef (Lazy.force coq_True_ref)) + else (idl, patl, mkGRef (Lazy.force coq_False_ref))) 0 + (* [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff brl_{i} is the first branch matched by [el] Used when we want to simulate the coq pattern matching algorithm *) -let make_discr_match brl = - fun el i -> - mkGCases(None, - make_discr_match_el el, - make_discr_match_brl i brl) +let make_discr_match brl el i = + mkGCases (None, make_discr_match_el el, make_discr_match_brl i brl) (**********************************************************************) (* functions used to build case expression from lettuple and if ones *) @@ -307,140 +272,159 @@ let make_discr_match brl = (* [build_constructors_of_type] construct the array of pattern of its inductive argument*) let build_constructors_of_type ind' argl = - let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in + let mib, ind = Inductive.lookup_mind_specif (Global.env ()) ind' in let npar = mib.Declarations.mind_nparams in - Array.mapi (fun i _ -> - let construct = ind',i+1 in - let constructref = GlobRef.ConstructRef(construct) in - let _implicit_positions_of_cst = - Impargs.implicits_of_global constructref - in - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - construct - in - let argl = - if List.is_empty argl then - List.make cst_narg (mkGHole ()) - else - List.make npar (mkGHole ()) @ argl - in - let pat_as_term = - mkGApp(mkGRef (GlobRef.ConstructRef(ind',i+1)),argl) - in - cases_pattern_of_glob_constr (Global.env()) Anonymous pat_as_term - ) + Array.mapi + (fun i _ -> + let construct = (ind', i + 1) in + let constructref = GlobRef.ConstructRef construct in + let _implicit_positions_of_cst = + Impargs.implicits_of_global constructref + in + let cst_narg = + Inductiveops.constructor_nallargs (Global.env ()) construct + in + let argl = + if List.is_empty argl then List.make cst_narg (mkGHole ()) + else List.make npar (mkGHole ()) @ argl + in + let pat_as_term = + mkGApp (mkGRef (GlobRef.ConstructRef (ind', i + 1)), argl) + in + cases_pattern_of_glob_constr (Global.env ()) Anonymous pat_as_term) ind.Declarations.mind_consnames (******************) (* Main functions *) (******************) - - -let raw_push_named (na,raw_value,raw_typ) env = +let raw_push_named (na, raw_value, raw_typ) env = match na with - | Anonymous -> env - | Name id -> - let typ,_ = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in - let na = make_annot id Sorts.Relevant in (* TODO relevance *) - (match raw_value with - | None -> - EConstr.push_named (NamedDecl.LocalAssum (na,typ)) env - | Some value -> - EConstr.push_named (NamedDecl.LocalDef (na, value, typ)) env) - + | Anonymous -> env + | Name id -> ( + let typ, _ = + Pretyping.understand env (Evd.from_env env) + ~expected_type:Pretyping.IsType raw_typ + in + let na = make_annot id Sorts.Relevant in + (* TODO relevance *) + match raw_value with + | None -> EConstr.push_named (NamedDecl.LocalAssum (na, typ)) env + | Some value -> EConstr.push_named (NamedDecl.LocalDef (na, value, typ)) env + ) let add_pat_variables sigma pat typ env : Environ.env = - let rec add_pat_variables env pat typ : Environ.env = - observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); - + let rec add_pat_variables env pat typ : Environ.env = + observe + (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); match DAst.get pat with - | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (make_annot na Sorts.Relevant,typ)) env - | PatCstr(c,patl,na) -> - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) - with Not_found -> assert false - in - let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in - let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in - List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) + | PatVar na -> + Environ.push_rel + (RelDecl.LocalAssum (make_annot na Sorts.Relevant, typ)) + env + | PatCstr (c, patl, na) -> + let (Inductiveops.IndType (indf, indargs)) = + try + Inductiveops.find_rectype env (Evd.from_env env) + (EConstr.of_constr typ) + with Not_found -> assert false + in + let constructors = Inductiveops.get_constructors env indf in + let constructor : Inductiveops.constructor_summary = + List.find + (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) + (Array.to_list constructors) + in + let cs_args_types : types list = + List.map RelDecl.get_type constructor.Inductiveops.cs_args + in + List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in let res = - fst ( - Context.Rel.fold_outside - (fun decl (env,ctxt) -> + fst + (Context.Rel.fold_outside + (fun decl (env, ctxt) -> let open Context.Rel.Declaration in match decl with - | LocalAssum ({binder_name=Anonymous},_) | LocalDef ({binder_name=Anonymous},_,_) -> assert false - | LocalAssum ({binder_name=Name id} as na, t) -> - let na = {na with binder_name=id} in - let new_t = substl ctxt t in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () - ); + | LocalAssum ({binder_name = Anonymous}, _) + |LocalDef ({binder_name = Anonymous}, _, _) -> + assert false + | LocalAssum (({binder_name = Name id} as na), t) -> + let na = {na with binder_name = id} in + let new_t = substl ctxt t in + observe + ( str "for variable " ++ Ppconstr.pr_id id ++ fnl () + ++ str "old type := " + ++ Printer.pr_lconstr_env env sigma t + ++ fnl () ++ str "new type := " + ++ Printer.pr_lconstr_env env sigma new_t + ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (LocalAssum (na,new_t)) env,mkVar id::ctxt) - | LocalDef ({binder_name=Name id} as na, v, t) -> - let na = {na with binder_name=id} in - let new_t = substl ctxt t in + (Environ.push_named (LocalAssum (na, new_t)) env, mkVar id :: ctxt) + | LocalDef (({binder_name = Name id} as na), v, t) -> + let na = {na with binder_name = id} in + let new_t = substl ctxt t in let new_v = substl ctxt v in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () ++ - str "old value := " ++ Printer.pr_lconstr_env env sigma v ++ fnl () ++ - str "new value := " ++ Printer.pr_lconstr_env env sigma new_v ++ fnl () - ); + observe + ( str "for variable " ++ Ppconstr.pr_id id ++ fnl () + ++ str "old type := " + ++ Printer.pr_lconstr_env env sigma t + ++ fnl () ++ str "new type := " + ++ Printer.pr_lconstr_env env sigma new_t + ++ fnl () ++ str "old value := " + ++ Printer.pr_lconstr_env env sigma v + ++ fnl () ++ str "new value := " + ++ Printer.pr_lconstr_env env sigma new_v + ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (LocalDef (na,new_v,new_t)) env,mkVar id::ctxt) - ) - (Environ.rel_context new_env) - ~init:(env,[]) - ) + ( Environ.push_named (LocalDef (na, new_v, new_t)) env + , mkVar id :: ctxt )) + (Environ.rel_context new_env) + ~init:(env, [])) in - observe (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); + observe + (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); res - - - -let rec pattern_to_term_and_type env typ = DAst.with_val (function - | PatVar Anonymous -> assert false - | PatVar (Name id) -> - mkGVar id - | PatCstr(constr,patternl,_) -> - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - constr - in - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) +let rec pattern_to_term_and_type env typ = + DAst.with_val (function + | PatVar Anonymous -> assert false + | PatVar (Name id) -> mkGVar id + | PatCstr (constr, patternl, _) -> + let cst_narg = Inductiveops.constructor_nallargs (Global.env ()) constr in + let (Inductiveops.IndType (indf, indargs)) = + try + Inductiveops.find_rectype env (Evd.from_env env) + (EConstr.of_constr typ) with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in - let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in - let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in - let _,cstl = Inductiveops.dest_ind_family indf in + let constructor = + List.find + (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) + (Array.to_list constructors) + in + let cs_args_types : types list = + List.map RelDecl.get_type constructor.Inductiveops.cs_args + in + let _, cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) (EConstr.of_constr csta.(i))) - ) + (fun i -> + Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) + (EConstr.of_constr csta.(i)))) in let patl_as_term = - List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl + List.map2 + (pattern_to_term_and_type env) + (List.rev cs_args_types) patternl in - mkGApp(mkGRef(GlobRef.ConstructRef constr), - implicit_args@patl_as_term - ) - ) + mkGApp (mkGRef (GlobRef.ConstructRef constr), implicit_args @ patl_as_term)) (* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the @@ -473,448 +457,427 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function but only the value of the function *) - -let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_return = +let rec build_entry_lc env sigma funnames avoid rt : + glob_constr build_entry_return = observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); let open CAst in match DAst.get rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> - (* do nothing (except changing type of course) *) - mk_result [] rt avoid - | GApp(_,_) -> - let f,args = glob_decompose_app rt in - let args_res : (glob_constr list) build_entry_return = - List.fold_right (* create the arguments lists of constructors and combine them *) - (fun arg ctxt_argsl -> - let arg_res = build_entry_lc env sigma funnames ctxt_argsl.to_avoid arg in - combine_results combine_args arg_res ctxt_argsl - ) - args - (mk_result [] [] avoid) - in - begin - match DAst.get f with - | GLambda _ -> - let rec aux t l = - match l with - | [] -> t - | u::l -> DAst.make @@ - match DAst.get t with - | GLambda(na,_,nat,b) -> - GLetIn(na,u,None,aux b l) - | _ -> - GApp(t,l) - in - build_entry_lc env sigma funnames avoid (aux f args) - | GVar id when Id.Set.mem id funnames -> - (* if we have [f t1 ... tn] with [f]$\in$[fnames] - then we create a fresh variable [res], - add [res] and its "value" (i.e. [res v1 ... vn]) to each - pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and - a pseudo value "v1 ... vn". - The "value" of this branch is then simply [res] - *) - (* XXX here and other [understand] calls drop the ctx *) - let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in - let rt_typ = Retyping.get_type_of env (Evd.from_env env) rt_as_constr in - let res_raw_type = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) rt_typ in - let res = fresh_id args_res.to_avoid "_res" in - let new_avoid = res::args_res.to_avoid in - let res_rt = mkGVar res in - let new_result = - List.map - (fun arg_res -> - let new_hyps = - [Prod (Name res),res_raw_type; - Prod Anonymous,mkGApp(res_rt,(mkGVar id)::arg_res.value)] - in - {context = arg_res.context@new_hyps; value = res_rt } - ) - args_res.result - in - { result = new_result; to_avoid = new_avoid } - | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> - (* if have [g t1 ... tn] with [g] not appearing in [funnames] - then - foreach [ctxt,v1 ... vn] in [args_res] we return - [ctxt, g v1 .... vn] - *) - { - args_res with - result = - List.map - (fun args_res -> - {args_res with value = mkGApp(f,args_res.value)}) - args_res.result - } - | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) - | GLetIn(n,v,t,b) -> - (* if we have [(let x := v in b) t1 ... tn] , - we discard our work and compute the list of constructor for - [let x = v in (b t1 ... tn)] up to alpha conversion - *) - let new_n,new_b,new_avoid = - match n with - | Name id when List.exists (is_free_in id) args -> - (* need to alpha-convert the name *) - let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in - let new_avoid = id:: avoid in - let new_b = - replace_var_by_term - id - (DAst.make @@ GVar id) - b - in - (Name new_id,new_b,new_avoid) - | _ -> n,b,avoid - in - build_entry_lc - env - sigma - funnames - avoid - (mkGLetIn(new_n,v,t,mkGApp(new_b,args))) - | GCases _ | GIf _ | GLetTuple _ -> - (* we have [(match e1, ...., en with ..... end) t1 tn] - we first compute the result from the case and - then combine each of them with each of args one - *) - let f_res = build_entry_lc env sigma funnames args_res.to_avoid f in - combine_results combine_app f_res args_res - | GCast(b,_) -> - (* for an applied cast we just trash the cast part - and restart the work. - - WARNING: We need to restart since [b] itself should be an application term - *) - build_entry_lc env sigma funnames avoid (mkGApp(b,args)) - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GProd _ -> user_err Pp.(str "Cannot apply a type") - | GInt _ -> user_err Pp.(str "Cannot apply an integer") - | GFloat _ -> user_err Pp.(str "Cannot apply a float") - end (* end of the application treatement *) - - | GLambda(n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env sigma funnames avoid t in - let new_n = - match n with - | Name _ -> n - | Anonymous -> Name (Indfun_common.fresh_id [] "_x") - in - let new_env = raw_push_named (new_n,None,t) env in - let b_res = build_entry_lc new_env sigma funnames avoid b in - combine_results (combine_lam new_n) t_res b_res - | GProd(n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env sigma funnames avoid t in - let new_env = raw_push_named (n,None,t) env in - let b_res = build_entry_lc new_env sigma funnames avoid b in - if List.length t_res.result = 1 && List.length b_res.result = 1 - then combine_results (combine_prod2 n) t_res b_res - else combine_results (combine_prod n) t_res b_res - | GLetIn(n,v,typ,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the value [t] - and combine the two result - *) - let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in - let v_res = build_entry_lc env sigma funnames avoid v in - let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in - let v_type = Retyping.get_type_of env (Evd.from_env env) v_as_constr in - let v_r = Sorts.Relevant in (* TODO relevance *) - let new_env = - match n with - Anonymous -> env - | Name id -> EConstr.push_named (NamedDecl.LocalDef (make_annot id v_r,v_as_constr,v_type)) env - in - let b_res = build_entry_lc new_env sigma funnames avoid b in - combine_results (combine_letin n) v_res b_res - | GCases(_,_,el,brl) -> - (* we create the discrimination function - and treat the case itself - *) - let make_discr = make_discr_match brl in - build_entry_lc_from_case env sigma funnames make_discr el brl avoid - | GIf(b,(na,e_option),lhs,rhs) -> - let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ - with Not_found -> - user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr_env env b ++ str " in " ++ - Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") - in - let case_pats = build_constructors_of_type (fst ind) [] in - assert (Int.equal (Array.length case_pats) 2); - let brl = - List.map_i - (fun i x -> CAst.make ([],[case_pats.(i)],x)) - 0 - [lhs;rhs] - in - let match_expr = - mkGCases(None,[(b,(Anonymous,None))],brl) - in - (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) - build_entry_lc env sigma funnames avoid match_expr - | GLetTuple(nal,_,b,e) -> - begin - let nal_as_glob_constr = - List.map - (function - Name id -> mkGVar id - | Anonymous -> mkGHole () - ) - nal - in - let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ - with Not_found -> - user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr_env env b ++ str " in " ++ - Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ + |GFloat _ -> + (* do nothing (except changing type of course) *) + mk_result [] rt avoid + | GApp (_, _) -> ( + let f, args = glob_decompose_app rt in + let args_res : glob_constr list build_entry_return = + List.fold_right + (* create the arguments lists of constructors and combine them *) + (fun arg ctxt_argsl -> + let arg_res = + build_entry_lc env sigma funnames ctxt_argsl.to_avoid arg in - let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in - assert (Int.equal (Array.length case_pats) 1); - let br = CAst.make ([],[case_pats.(0)],e) in - let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in - build_entry_lc env sigma funnames avoid match_expr - - end + combine_results combine_args arg_res ctxt_argsl) + args (mk_result [] [] avoid) + in + match DAst.get f with + | GLambda _ -> + let rec aux t l = + match l with + | [] -> t + | u :: l -> ( + DAst.make + @@ + match DAst.get t with + | GLambda (na, _, nat, b) -> GLetIn (na, u, None, aux b l) + | _ -> GApp (t, l) ) + in + build_entry_lc env sigma funnames avoid (aux f args) + | GVar id when Id.Set.mem id funnames -> + (* if we have [f t1 ... tn] with [f]$\in$[fnames] + then we create a fresh variable [res], + add [res] and its "value" (i.e. [res v1 ... vn]) to each + pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and + a pseudo value "v1 ... vn". + The "value" of this branch is then simply [res] + *) + (* XXX here and other [understand] calls drop the ctx *) + let rt_as_constr, ctx = Pretyping.understand env (Evd.from_env env) rt in + let rt_typ = Retyping.get_type_of env (Evd.from_env env) rt_as_constr in + let res_raw_type = + Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) + rt_typ + in + let res = fresh_id args_res.to_avoid "_res" in + let new_avoid = res :: args_res.to_avoid in + let res_rt = mkGVar res in + let new_result = + List.map + (fun arg_res -> + let new_hyps = + [ (Prod (Name res), res_raw_type) + ; (Prod Anonymous, mkGApp (res_rt, mkGVar id :: arg_res.value)) ] + in + {context = arg_res.context @ new_hyps; value = res_rt}) + args_res.result + in + {result = new_result; to_avoid = new_avoid} + | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> + (* if have [g t1 ... tn] with [g] not appearing in [funnames] + then + foreach [ctxt,v1 ... vn] in [args_res] we return + [ctxt, g v1 .... vn] + *) + { args_res with + result = + List.map + (fun args_res -> {args_res with value = mkGApp (f, args_res.value)}) + args_res.result } + | GApp _ -> + assert false (* we have collected all the app in [glob_decompose_app] *) + | GLetIn (n, v, t, b) -> + (* if we have [(let x := v in b) t1 ... tn] , + we discard our work and compute the list of constructor for + [let x = v in (b t1 ... tn)] up to alpha conversion + *) + let new_n, new_b, new_avoid = + match n with + | Name id when List.exists (is_free_in id) args -> + (* need to alpha-convert the name *) + let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in + let new_avoid = id :: avoid in + let new_b = replace_var_by_term id (DAst.make @@ GVar id) b in + (Name new_id, new_b, new_avoid) + | _ -> (n, b, avoid) + in + build_entry_lc env sigma funnames avoid + (mkGLetIn (new_n, v, t, mkGApp (new_b, args))) + | GCases _ | GIf _ | GLetTuple _ -> + (* we have [(match e1, ...., en with ..... end) t1 tn] + we first compute the result from the case and + then combine each of them with each of args one + *) + let f_res = build_entry_lc env sigma funnames args_res.to_avoid f in + combine_results combine_app f_res args_res + | GCast (b, _) -> + (* for an applied cast we just trash the cast part + and restart the work. + + WARNING: We need to restart since [b] itself should be an application term + *) + build_entry_lc env sigma funnames avoid (mkGApp (b, args)) | GRec _ -> user_err Pp.(str "Not handled GRec") - | GCast(b,_) -> - build_entry_lc env sigma funnames avoid b -and build_entry_lc_from_case env sigma funname make_discr - (el:tomatch_tuples) - (brl:Glob_term.cases_clauses) avoid : - glob_constr build_entry_return = + | GProd _ -> user_err Pp.(str "Cannot apply a type") + | GInt _ -> user_err Pp.(str "Cannot apply an integer") + | GFloat _ -> user_err Pp.(str "Cannot apply a float") + (* end of the application treatement *) ) + | GLambda (n, _, t, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env sigma funnames avoid t in + let new_n = + match n with + | Name _ -> n + | Anonymous -> Name (Indfun_common.fresh_id [] "_x") + in + let new_env = raw_push_named (new_n, None, t) env in + let b_res = build_entry_lc new_env sigma funnames avoid b in + combine_results (combine_lam new_n) t_res b_res + | GProd (n, _, t, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env sigma funnames avoid t in + let new_env = raw_push_named (n, None, t) env in + let b_res = build_entry_lc new_env sigma funnames avoid b in + if List.length t_res.result = 1 && List.length b_res.result = 1 then + combine_results (combine_prod2 n) t_res b_res + else combine_results (combine_prod n) t_res b_res + | GLetIn (n, v, typ, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the value [t] + and combine the two result + *) + let v = + match typ with + | None -> v + | Some t -> DAst.make ?loc:rt.loc @@ GCast (v, CastConv t) + in + let v_res = build_entry_lc env sigma funnames avoid v in + let v_as_constr, ctx = Pretyping.understand env (Evd.from_env env) v in + let v_type = Retyping.get_type_of env (Evd.from_env env) v_as_constr in + let v_r = Sorts.Relevant in + (* TODO relevance *) + let new_env = + match n with + | Anonymous -> env + | Name id -> + EConstr.push_named + (NamedDecl.LocalDef (make_annot id v_r, v_as_constr, v_type)) + env + in + let b_res = build_entry_lc new_env sigma funnames avoid b in + combine_results (combine_letin n) v_res b_res + | GCases (_, _, el, brl) -> + (* we create the discrimination function + and treat the case itself + *) + let make_discr = make_discr_match brl in + build_entry_lc_from_case env sigma funnames make_discr el brl avoid + | GIf (b, (na, e_option), lhs, rhs) -> + let b_as_constr, ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in + let ind, _ = + try Inductiveops.find_inductive env (Evd.from_env env) b_typ + with Not_found -> + user_err + ( str "Cannot find the inductive associated to " + ++ Printer.pr_glob_constr_env env b + ++ str " in " + ++ Printer.pr_glob_constr_env env rt + ++ str ". try again with a cast" ) + in + let case_pats = build_constructors_of_type (fst ind) [] in + assert (Int.equal (Array.length case_pats) 2); + let brl = + List.map_i (fun i x -> CAst.make ([], [case_pats.(i)], x)) 0 [lhs; rhs] + in + let match_expr = mkGCases (None, [(b, (Anonymous, None))], brl) in + (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) + build_entry_lc env sigma funnames avoid match_expr + | GLetTuple (nal, _, b, e) -> + let nal_as_glob_constr = + List.map (function Name id -> mkGVar id | Anonymous -> mkGHole ()) nal + in + let b_as_constr, ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in + let ind, _ = + try Inductiveops.find_inductive env (Evd.from_env env) b_typ + with Not_found -> + user_err + ( str "Cannot find the inductive associated to " + ++ Printer.pr_glob_constr_env env b + ++ str " in " + ++ Printer.pr_glob_constr_env env rt + ++ str ". try again with a cast" ) + in + let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in + assert (Int.equal (Array.length case_pats) 1); + let br = CAst.make ([], [case_pats.(0)], e) in + let match_expr = mkGCases (None, [(b, (Anonymous, None))], [br]) in + build_entry_lc env sigma funnames avoid match_expr + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast (b, _) -> build_entry_lc env sigma funnames avoid b + +and build_entry_lc_from_case env sigma funname make_discr (el : tomatch_tuples) + (brl : Glob_term.cases_clauses) avoid : glob_constr build_entry_return = match el with - | [] -> assert false (* this case correspond to match <nothing> with .... !*) - | el -> - (* this case correspond to - match el with brl end - we first compute the list of lists corresponding to [el] and - combine them . - Then for each element of the combinations, - we compute the result we compute one list per branch in [brl] and - finally we just concatenate those list - *) - let case_resl = - List.fold_right - (fun (case_arg,_) ctxt_argsl -> - let arg_res = build_entry_lc env sigma funname ctxt_argsl.to_avoid case_arg in - combine_results combine_args arg_res ctxt_argsl - ) - el - (mk_result [] [] avoid) - in - let types = - List.map (fun (case_arg,_) -> - let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in - EConstr.Unsafe.to_constr (Retyping.get_type_of env (Evd.from_env env) case_arg_as_constr) - ) el - in - (****** The next works only if the match is not dependent ****) - let results = - List.map - (fun ca -> - let res = build_entry_lc_from_case_term - env sigma types - funname (make_discr) - [] brl - case_resl.to_avoid - ca - in - res - ) - case_resl.result - in - { - result = List.concat (List.map (fun r -> r.result) results); - to_avoid = - List.fold_left (fun acc r -> List.union Id.equal acc r.to_avoid) - [] results - } - -and build_entry_lc_from_case_term env sigma types funname make_discr patterns_to_prevent brl avoid - matched_expr = + | [] -> assert false (* this case correspond to match <nothing> with .... !*) + | el -> + (* this case correspond to + match el with brl end + we first compute the list of lists corresponding to [el] and + combine them . + Then for each element of the combinations, + we compute the result we compute one list per branch in [brl] and + finally we just concatenate those list + *) + let case_resl = + List.fold_right + (fun (case_arg, _) ctxt_argsl -> + let arg_res = + build_entry_lc env sigma funname ctxt_argsl.to_avoid case_arg + in + combine_results combine_args arg_res ctxt_argsl) + el (mk_result [] [] avoid) + in + let types = + List.map + (fun (case_arg, _) -> + let case_arg_as_constr, ctx = + Pretyping.understand env (Evd.from_env env) case_arg + in + EConstr.Unsafe.to_constr + (Retyping.get_type_of env (Evd.from_env env) case_arg_as_constr)) + el + in + (****** The next works only if the match is not dependent ****) + let results = + List.map + (fun ca -> + let res = + build_entry_lc_from_case_term env sigma types funname make_discr [] + brl case_resl.to_avoid ca + in + res) + case_resl.result + in + { result = List.concat (List.map (fun r -> r.result) results) + ; to_avoid = + List.fold_left + (fun acc r -> List.union Id.equal acc r.to_avoid) + [] results } + +and build_entry_lc_from_case_term env sigma types funname make_discr + patterns_to_prevent brl avoid matched_expr = match brl with - | [] -> (* computed_branches *) {result = [];to_avoid = avoid} - | br::brl' -> - (* alpha conversion to prevent name clashes *) - let {CAst.v=(idl,patl,return)} = alpha_br avoid br in - let new_avoid = idl@avoid in (* for now we can no more use idl as an identifier *) - (* building a list of precondition stating that we are not in this branch - (will be used in the following recursive calls) - *) - let new_env = List.fold_right2 (add_pat_variables sigma) patl types env in - let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = - List.map2 - (fun pat typ -> - fun avoid pat'_as_term -> - let renamed_pat,_,_ = alpha_pat avoid pat in - let pat_ids = get_pattern_id renamed_pat in - let env_with_pat_ids = add_pat_variables sigma pat typ new_env in - List.fold_right - (fun id acc -> - let typ_of_id = Typing.type_of_variable env_with_pat_ids id in - let raw_typ_of_id = - Detyping.detype Detyping.Now false Id.Set.empty - env_with_pat_ids (Evd.from_env env) typ_of_id - in - mkGProd (Name id,raw_typ_of_id,acc)) - pat_ids - (glob_make_neq pat'_as_term (pattern_to_term renamed_pat)) - ) - patl - types - in - (* Checking if we can be in this branch - (will be used in the following recursive calls) - *) - let unify_with_those_patterns : (cases_pattern -> bool*bool) list = - List.map - (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') - patl - in - (* + | [] -> (* computed_branches *) {result = []; to_avoid = avoid} + | br :: brl' -> + (* alpha conversion to prevent name clashes *) + let {CAst.v = idl, patl, return} = alpha_br avoid br in + let new_avoid = idl @ avoid in + (* for now we can no more use idl as an identifier *) + (* building a list of precondition stating that we are not in this branch + (will be used in the following recursive calls) + *) + let new_env = List.fold_right2 (add_pat_variables sigma) patl types env in + let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = + List.map2 + (fun pat typ avoid pat'_as_term -> + let renamed_pat, _, _ = alpha_pat avoid pat in + let pat_ids = get_pattern_id renamed_pat in + let env_with_pat_ids = add_pat_variables sigma pat typ new_env in + List.fold_right + (fun id acc -> + let typ_of_id = Typing.type_of_variable env_with_pat_ids id in + let raw_typ_of_id = + Detyping.detype Detyping.Now false Id.Set.empty env_with_pat_ids + (Evd.from_env env) typ_of_id + in + mkGProd (Name id, raw_typ_of_id, acc)) + pat_ids + (glob_make_neq pat'_as_term (pattern_to_term renamed_pat))) + patl types + in + (* Checking if we can be in this branch + (will be used in the following recursive calls) + *) + let unify_with_those_patterns : (cases_pattern -> bool * bool) list = + List.map + (fun pat pat' -> (are_unifiable pat pat', eq_cases_pattern pat pat')) + patl + in + (* we first compute the other branch result (in ordrer to keep the order of the matching as much as possible) *) - let brl'_res = - build_entry_lc_from_case_term - env - sigma - types - funname - make_discr - ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) - brl' - avoid - matched_expr - in - (* We now create the precondition of this branch i.e. - 1- the list of variable appearing in the different patterns of this branch and - the list of equation stating than el = patl (List.flatten ...) - 2- If there exists a previous branch which pattern unify with the one of this branch - then a discrimination precond stating that we are not in a previous branch (if List.exists ...) - *) - let those_pattern_preconds = - (List.flatten - ( - List.map3 - (fun pat e typ_as_constr -> - let this_pat_ids = ids_of_pat pat in - let typ_as_constr = EConstr.of_constr typ_as_constr in - let typ = Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_as_constr in - let pat_as_term = pattern_to_term pat in - (* removing trivial holes *) - let pat_as_term = solve_trivial_holes pat_as_term e in - (* observe (str "those_pattern_preconds" ++ spc () ++ *) - (* str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *) - (* str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *) - (* str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *) - List.fold_right - (fun id acc -> - if Id.Set.mem id this_pat_ids - then (Prod (Name id), - let typ_of_id = Typing.type_of_variable new_env id in - let raw_typ_of_id = - Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_of_id - in - raw_typ_of_id - )::acc - else acc - ) - idl - [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)] - ) - patl - matched_expr.value - types - ) - ) - @ - (if List.exists (function (unifl,_) -> - let (unif,_) = - List.split (List.map2 (fun x y -> x y) unifl patl) - in - List.for_all (fun x -> x) unif) patterns_to_prevent - then - let i = List.length patterns_to_prevent in - let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in - [(Prod Anonymous,make_discr pats_as_constr i )] - else - [] - ) - in - (* We compute the result of the value returned by the branch*) - let return_res = build_entry_lc new_env sigma funname new_avoid return in - (* and combine it with the preconds computed for this branch *) - let this_branch_res = - List.map - (fun res -> - { context = matched_expr.context@those_pattern_preconds@res.context ; - value = res.value} - ) - return_res.result + let brl'_res = + build_entry_lc_from_case_term env sigma types funname make_discr + ((unify_with_those_patterns, not_those_patterns) :: patterns_to_prevent) + brl' avoid matched_expr + in + (* We now create the precondition of this branch i.e. + 1- the list of variable appearing in the different patterns of this branch and + the list of equation stating than el = patl (List.flatten ...) + 2- If there exists a previous branch which pattern unify with the one of this branch + then a discrimination precond stating that we are not in a previous branch (if List.exists ...) + *) + let those_pattern_preconds = + List.flatten + (List.map3 + (fun pat e typ_as_constr -> + let this_pat_ids = ids_of_pat pat in + let typ_as_constr = EConstr.of_constr typ_as_constr in + let typ = + Detyping.detype Detyping.Now false Id.Set.empty new_env + (Evd.from_env env) typ_as_constr + in + let pat_as_term = pattern_to_term pat in + (* removing trivial holes *) + let pat_as_term = solve_trivial_holes pat_as_term e in + (* observe (str "those_pattern_preconds" ++ spc () ++ *) + (* str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *) + (* str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *) + (* str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *) + List.fold_right + (fun id acc -> + if Id.Set.mem id this_pat_ids then + ( Prod (Name id) + , let typ_of_id = Typing.type_of_variable new_env id in + let raw_typ_of_id = + Detyping.detype Detyping.Now false Id.Set.empty new_env + (Evd.from_env env) typ_of_id + in + raw_typ_of_id ) + :: acc + else acc) + idl + [(Prod Anonymous, glob_make_eq ~typ pat_as_term e)]) + patl matched_expr.value types) + @ + if + List.exists + (function + | unifl, _ -> + let unif, _ = + List.split (List.map2 (fun x y -> x y) unifl patl) + in + List.for_all (fun x -> x) unif) + patterns_to_prevent + then + let i = List.length patterns_to_prevent in + let pats_as_constr = + List.map2 (pattern_to_term_and_type new_env) types patl in - { brl'_res with result = this_branch_res@brl'_res.result } - + [(Prod Anonymous, make_discr pats_as_constr i)] + else [] + in + (* We compute the result of the value returned by the branch*) + let return_res = build_entry_lc new_env sigma funname new_avoid return in + (* and combine it with the preconds computed for this branch *) + let this_branch_res = + List.map + (fun res -> + { context = matched_expr.context @ those_pattern_preconds @ res.context + ; value = res.value }) + return_res.result + in + {brl'_res with result = this_branch_res @ brl'_res.result} -let is_res r = match DAst.get r with -| GVar id -> - begin try - String.equal (String.sub (Id.to_string id) 0 4) "_res" - with Invalid_argument _ -> false end -| _ -> false +let is_res r = + match DAst.get r with + | GVar id -> ( + try String.equal (String.sub (Id.to_string id) 0 4) "_res" + with Invalid_argument _ -> false ) + | _ -> false -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> GlobRef.equal r gr -| _ -> false +let is_gr c gr = + match DAst.get c with GRef (r, _) -> GlobRef.equal r gr | _ -> false -let is_gvar c = match DAst.get c with -| GVar id -> true -| _ -> false +let is_gvar c = match DAst.get c with GVar id -> true | _ -> false let same_raw_term rt1 rt2 = - match DAst.get rt1, DAst.get rt2 with - | GRef(r1,_), GRef (r2,_) -> GlobRef.equal r1 r2 - | GHole _, GHole _ -> true - | _ -> false + match (DAst.get rt1, DAst.get rt2) with + | GRef (r1, _), GRef (r2, _) -> GlobRef.equal r1 r2 + | GHole _, GHole _ -> true + | _ -> false + let decompose_raw_eq env lhs rhs = let rec decompose_raw_eq lhs rhs acc = - observe (str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " ++ pr_glob_constr_env env rhs); - let (rhd,lrhs) = glob_decompose_app rhs in - let (lhd,llhs) = glob_decompose_app lhs in + observe + ( str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " + ++ pr_glob_constr_env env rhs ); + let rhd, lrhs = glob_decompose_app rhs in + let lhd, llhs = glob_decompose_app lhs in observe (str "lhd := " ++ pr_glob_constr_env env lhd); observe (str "rhd := " ++ pr_glob_constr_env env rhd); observe (str "llhs := " ++ int (List.length llhs)); observe (str "lrhs := " ++ int (List.length lrhs)); let sllhs = List.length llhs in let slrhs = List.length lrhs in - if same_raw_term lhd rhd && Int.equal sllhs slrhs - then + if same_raw_term lhd rhd && Int.equal sllhs slrhs then (* let _ = assert false in *) - List.fold_right2 decompose_raw_eq llhs lrhs acc - else (lhs,rhs)::acc + List.fold_right2 decompose_raw_eq llhs lrhs acc + else (lhs, rhs) :: acc in decompose_raw_eq lhs rhs [] exception Continue + (* The second phase which reconstruct the real type of the constructor. rebuild the globalized constructors expression. @@ -925,304 +888,283 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let open Context.Rel.Declaration in let open CAst in match DAst.get rt with - | GProd(n,k,t,b) -> - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t::crossed_types in - begin - match DAst.get t with - | GApp(res_rt ,args') when is_res res_rt -> - begin - let arg = List.hd args' in - match DAst.get arg with - | GVar this_relname -> - (*i The next call to mk_rel_id is - valid since we are constructing the graph - Ensures by: obvious - i*) - - let new_t = - mkGApp(mkGVar(mk_rel_id this_relname),List.tl args'@[res_rt]) - in - let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - mkGProd(n,new_t,new_b), - Id.Set.filter not_free_in_t id_to_exclude - | _ -> (* the first args is the name of the function! *) - assert false - end - | GApp(eq_as_ref,[ty; id ;rt]) - when is_gvar id && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous - -> - let loc1 = rt.CAst.loc in - let loc2 = eq_as_ref.CAst.loc in - let loc3 = id.CAst.loc in - let id = match DAst.get id with GVar id -> id | _ -> assert false in - begin - try - observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); - let t' = - try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) - with e when CErrors.noncritical e -> raise Continue - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = List.map (replace_var_by_term id rt) args in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkGProd(n,t,new_b),id_to_exclude - with Continue -> - let jmeq = GlobRef.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in - let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in - let ind,args' = Inductiveops.find_inductive env Evd.(from_env env) ty' in - let mib,_ = Global.lookup_inductive (fst ind) in - let nparam = mib.Declarations.mind_nparams in - let params,arg' = - ((Util.List.chop nparam args')) - in - let rt_typ = DAst.make @@ - GApp(DAst.make @@ GRef (GlobRef.IndRef (fst ind),None), - (List.map - (fun p -> Detyping.detype Detyping.Now false Id.Set.empty - env (Evd.from_env env) - (EConstr.of_constr p)) params)@(Array.to_list - (Array.make - (List.length args' - nparam) - (mkGHole ())))) - in - let eq' = - DAst.make ?loc:loc1 @@ GApp(DAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;DAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) - in - observe (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); - let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in - observe (str " computing new type for jmeq : done") ; - let sigma = Evd.(from_env env) in - let new_args = - match EConstr.kind sigma eq'_as_constr with - | App(_,[|_;_;ty;_|]) -> - let ty = Array.to_list (snd (EConstr.destApp sigma ty)) in - let ty' = snd (Util.List.chop nparam ty) in - List.fold_left2 - (fun acc var_as_constr arg -> - if isRel var_as_constr - then - let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in - match na with - | Anonymous -> acc - | Name id' -> - (id',Detyping.detype Detyping.Now false Id.Set.empty - env - (Evd.from_env env) - arg)::acc - else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype Detyping.Now false Id.Set.empty - env - (Evd.from_env env) - arg)::acc - else acc - ) - [] - arg' - ty' - | _ -> assert false - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = - List.fold_left - (fun args (id,rt) -> - List.map (replace_var_by_term id rt) args - ) - args - ((id,rt)::new_args) - in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let new_env = - let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in - let r = Sorts.Relevant in (* TODO relevance *) - EConstr.push_rel (LocalAssum (make_annot n r,t')) env - in - let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkGProd(n,eq',new_b),id_to_exclude - end - (* J.F:. keep this comment it explain how to remove some meaningless equalities - if keep_eq then - mkGProd(n,t,new_b),id_to_exclude - else new_b, Id.Set.add id id_to_exclude - *) - | GApp(eq_as_ref,[ty;rt1;rt2]) - when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous - -> - begin - try - let l = decompose_raw_eq env rt1 rt2 in - if List.length l > 1 - then - let new_rt = - List.fold_left - (fun acc (lhs,rhs) -> - mkGProd(Anonymous, - mkGApp(mkGRef Coqlib.(lib_ref "core.eq.type"),[mkGHole ();lhs;rhs]),acc) - ) - b - l - in - rebuild_cons env nb_args relname args crossed_types depth new_rt - else raise Continue - with Continue -> - observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id - (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - end - | _ -> - observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id - (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - end - | GLambda(n,k,t,b) -> - begin - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t :: crossed_types in - observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - match n with - | Name id -> - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - (args@[mkGVar id])new_crossed_types - (depth + 1 ) b - in - if Id.Set.mem id id_to_exclude && depth >= nb_args - then - new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - else - DAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - | _ -> anomaly (Pp.str "Should not have an anonymous function here.") - (* We have renamed all the anonymous functions during alpha_renaming phase *) - - end - | GLetIn(n,v,t,b) -> - begin - let t = match t with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in - let not_free_in_t id = not (is_free_in id t) in - let evd = (Evd.from_env env) in - let t',ctx = Pretyping.understand env evd t in - let evd = Evd.from_ctx ctx in - let type_t' = Retyping.get_type_of env evd t' in - let t' = EConstr.Unsafe.to_constr t' in - let type_t' = EConstr.Unsafe.to_constr type_t' in - let new_env = Environ.push_rel (LocalDef (make_annot n Sorts.Relevant,t',type_t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1 ) b in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> DAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) - Id.Set.filter not_free_in_t id_to_exclude - end - | GLetTuple(nal,(na,rto),t,b) -> - assert (Option.is_empty rto); - begin - let not_free_in_t id = not (is_free_in id t) in - let new_t,id_to_exclude' = - rebuild_cons env - nb_args - relname - args (crossed_types) - depth t - in - let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot na r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1) b + | GProd (n, k, t, b) -> ( + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t :: crossed_types in + match DAst.get t with + | GApp (res_rt, args') when is_res res_rt -> ( + let arg = List.hd args' in + match DAst.get arg with + | GVar this_relname -> + (*i The next call to mk_rel_id is + valid since we are constructing the graph + Ensures by: obvious + i*) + let new_t = + mkGApp (mkGVar (mk_rel_id this_relname), List.tl args' @ [res_rt]) + in + let t', ctx = Pretyping.understand env (Evd.from_env env) new_t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types + (depth + 1) b + in + (mkGProd (n, new_t, new_b), Id.Set.filter not_free_in_t id_to_exclude) + | _ -> + (* the first args is the name of the function! *) + assert false ) + | GApp (eq_as_ref, [ty; id; rt]) + when is_gvar id + && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") + && n == Anonymous -> ( + let loc1 = rt.CAst.loc in + let loc2 = eq_as_ref.CAst.loc in + let loc3 = id.CAst.loc in + let id = match DAst.get id with GVar id -> id | _ -> assert false in + try + observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); + let t' = + try fst (Pretyping.understand env (Evd.from_env env) t) (*FIXME*) + with e when CErrors.noncritical e -> raise Continue + in + let is_in_b = is_free_in id b in + let _keep_eq = + (not (List.exists (is_free_in id) args)) + || is_in_b + || List.exists (is_free_in id) crossed_types + in + let new_args = List.map (replace_var_by_term id rt) args in + let subst_b = if is_in_b then b else replace_var_by_term id rt b in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types + (depth + 1) subst_b + in + (mkGProd (n, t, new_b), id_to_exclude) + with Continue -> + let jmeq = GlobRef.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in + let ty', ctx = Pretyping.understand env (Evd.from_env env) ty in + let ind, args' = + Inductiveops.find_inductive env Evd.(from_env env) ty' + in + let mib, _ = Global.lookup_inductive (fst ind) in + let nparam = mib.Declarations.mind_nparams in + let params, arg' = Util.List.chop nparam args' in + let rt_typ = + DAst.make + @@ GApp + ( DAst.make @@ GRef (GlobRef.IndRef (fst ind), None) + , List.map + (fun p -> + Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) (EConstr.of_constr p)) + params + @ Array.to_list + (Array.make (List.length args' - nparam) (mkGHole ())) ) + in + let eq' = + DAst.make ?loc:loc1 + @@ GApp + ( DAst.make ?loc:loc2 @@ GRef (jmeq, None) + , [ty; DAst.make ?loc:loc3 @@ GVar id; rt_typ; rt] ) + in + observe + (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); + let eq'_as_constr, ctx = + Pretyping.understand env (Evd.from_env env) eq' + in + observe (str " computing new type for jmeq : done"); + let sigma = Evd.(from_env env) in + let new_args = + match EConstr.kind sigma eq'_as_constr with + | App (_, [|_; _; ty; _|]) -> + let ty = Array.to_list (snd (EConstr.destApp sigma ty)) in + let ty' = snd (Util.List.chop nparam ty) in + List.fold_left2 + (fun acc var_as_constr arg -> + if isRel var_as_constr then + let na = + RelDecl.get_name + (Environ.lookup_rel (destRel var_as_constr) env) + in + match na with + | Anonymous -> acc + | Name id' -> + ( id' + , Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) arg ) + :: acc + else if isVar var_as_constr then + ( destVar var_as_constr + , Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) arg ) + :: acc + else acc) + [] arg' ty' + | _ -> assert false + in + let is_in_b = is_free_in id b in + let _keep_eq = + (not (List.exists (is_free_in id) args)) + || is_in_b + || List.exists (is_free_in id) crossed_types + in + let new_args = + List.fold_left + (fun args (id, rt) -> List.map (replace_var_by_term id rt) args) + args ((id, rt) :: new_args) + in + let subst_b = if is_in_b then b else replace_var_by_term id rt b in + let new_env = + let t', ctx = Pretyping.understand env (Evd.from_env env) eq' in + let r = Sorts.Relevant in + (* TODO relevance *) + EConstr.push_rel (LocalAssum (make_annot n r, t')) env + in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types + (depth + 1) subst_b + in + (mkGProd (n, eq', new_b), id_to_exclude) + (* J.F:. keep this comment it explain how to remove some meaningless equalities + if keep_eq then + mkGProd(n,t,new_b),id_to_exclude + else new_b, Id.Set.add id id_to_exclude + *) ) + | GApp (eq_as_ref, [ty; rt1; rt2]) + when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous + -> ( + try + let l = decompose_raw_eq env rt1 rt2 in + if List.length l > 1 then + let new_rt = + List.fold_left + (fun acc (lhs, rhs) -> + mkGProd + ( Anonymous + , mkGApp + ( mkGRef Coqlib.(lib_ref "core.eq.type") + , [mkGHole (); lhs; rhs] ) + , acc )) + b l in -(* match n with *) -(* | Name id when Id.Set.mem id id_to_exclude -> *) -(* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) -(* | _ -> *) - DAst.make @@ GLetTuple(nal,(na,None),t,new_b), - Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') - - end - - | _ -> mkGApp(mkGVar relname,args@[rt]),Id.Set.empty - + rebuild_cons env nb_args relname args crossed_types depth new_rt + else raise Continue + with Continue -> ( + observe + (str "computing new type for prod : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types + (depth + 1) b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> (mkGProd (n, t, new_b), Id.Set.filter not_free_in_t id_to_exclude) ) + ) + | _ -> ( + observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) + b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> (mkGProd (n, t, new_b), Id.Set.filter not_free_in_t id_to_exclude) + ) ) + | GLambda (n, k, t, b) -> ( + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t :: crossed_types in + observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + match n with + | Name id -> + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname + (args @ [mkGVar id]) + new_crossed_types (depth + 1) b + in + if Id.Set.mem id id_to_exclude && depth >= nb_args then + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + else + ( DAst.make @@ GProd (n, k, t, new_b) + , Id.Set.filter not_free_in_t id_to_exclude ) + | _ -> anomaly (Pp.str "Should not have an anonymous function here.") + (* We have renamed all the anonymous functions during alpha_renaming phase *) + ) + | GLetIn (n, v, t, b) -> ( + let t = + match t with + | None -> v + | Some t -> DAst.make ?loc:rt.loc @@ GCast (v, CastConv t) + in + let not_free_in_t id = not (is_free_in id t) in + let evd = Evd.from_env env in + let t', ctx = Pretyping.understand env evd t in + let evd = Evd.from_ctx ctx in + let type_t' = Retyping.get_type_of env evd t' in + let t' = EConstr.Unsafe.to_constr t' in + let type_t' = EConstr.Unsafe.to_constr type_t' in + let new_env = + Environ.push_rel (LocalDef (make_annot n Sorts.Relevant, t', type_t')) env + in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args (t :: crossed_types) (depth + 1) + b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> + ( DAst.make @@ GLetIn (n, t, None, new_b) + , (* HOPING IT WOULD WORK *) + Id.Set.filter not_free_in_t id_to_exclude ) ) + | GLetTuple (nal, (na, rto), t, b) -> + assert (Option.is_empty rto); + let not_free_in_t id = not (is_free_in id t) in + let new_t, id_to_exclude' = + rebuild_cons env nb_args relname args crossed_types depth t + in + let t', ctx = Pretyping.understand env (Evd.from_env env) new_t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot na r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args (t :: crossed_types) (depth + 1) + b + in + (* match n with *) + (* | Name id when Id.Set.mem id id_to_exclude -> *) + (* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) + (* | _ -> *) + ( DAst.make @@ GLetTuple (nal, (na, None), t, new_b) + , Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') ) + | _ -> (mkGApp (mkGVar relname, args @ [rt]), Id.Set.empty) (* debugging wrapper *) let rebuild_cons env nb_args relname args crossed_types rt = -(* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) -(* str "nb_args := " ++ str (string_of_int nb_args)); *) - let res = - rebuild_cons env nb_args relname args crossed_types 0 rt - in -(* observe (str " leads to "++ pr_glob_constr (fst res)); *) + (* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) + (* str "nb_args := " ++ str (string_of_int nb_args)); *) + let res = rebuild_cons env nb_args relname args crossed_types 0 rt in + (* observe (str " leads to "++ pr_glob_constr (fst res)); *) res - (* naive implementation of parameter detection. A parameter is an argument which is only preceded by parameters and whose @@ -1230,92 +1172,103 @@ let rebuild_cons env nb_args relname args crossed_types rt = TODO: Find a valid way to deal with implicit arguments here! *) -let rec compute_cst_params relnames params gt = DAst.with_val (function - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ -> params - | GApp(f,args) -> - begin match DAst.get f with - | GVar relname' when Id.Set.mem relname' relnames -> - compute_cst_params_from_app [] (params,args) - | _ -> - List.fold_left (compute_cst_params relnames) params (f::args) - end - | GLambda(_,_,t,b) | GProd(_,_,t,b) | GLetTuple(_,_,t,b) -> - let t_params = compute_cst_params relnames params t in - compute_cst_params relnames t_params b - | GLetIn(_,v,t,b) -> - let v_params = compute_cst_params relnames params v in - let t_params = Option.fold_left (compute_cst_params relnames) v_params t in - compute_cst_params relnames t_params b - | GCases _ -> - params (* If there is still cases at this point they can only be - discrimination ones *) - | GSort _ -> params - | GHole _ -> params - | GIf _ | GRec _ | GCast _ -> - CErrors.user_err ~hdr:"compute_cst_params" (str "Not handled case") - ) gt -and compute_cst_params_from_app acc (params,rtl) = - let is_gid id c = match DAst.get c with GVar id' -> Id.equal id id' | _ -> false in - match params,rtl with - | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,None) as param)::params', c::rtl' when is_gid id c -> - compute_cst_params_from_app (param::acc) (params',rtl') - | _ -> List.rev acc - -let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) csts = +let rec compute_cst_params relnames params gt = + DAst.with_val + (function + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ -> params + | GApp (f, args) -> ( + match DAst.get f with + | GVar relname' when Id.Set.mem relname' relnames -> + compute_cst_params_from_app [] (params, args) + | _ -> List.fold_left (compute_cst_params relnames) params (f :: args) ) + | GLambda (_, _, t, b) | GProd (_, _, t, b) | GLetTuple (_, _, t, b) -> + let t_params = compute_cst_params relnames params t in + compute_cst_params relnames t_params b + | GLetIn (_, v, t, b) -> + let v_params = compute_cst_params relnames params v in + let t_params = + Option.fold_left (compute_cst_params relnames) v_params t + in + compute_cst_params relnames t_params b + | GCases _ -> + params + (* If there is still cases at this point they can only be + discrimination ones *) + | GSort _ -> params + | GHole _ -> params + | GIf _ | GRec _ | GCast _ -> + CErrors.user_err ~hdr:"compute_cst_params" (str "Not handled case")) + gt + +and compute_cst_params_from_app acc (params, rtl) = + let is_gid id c = + match DAst.get c with GVar id' -> Id.equal id id' | _ -> false + in + match (params, rtl) with + | _ :: _, [] -> assert false (* the rel has at least nargs + 1 arguments ! *) + | ((Name id, _, None) as param) :: params', c :: rtl' when is_gid id c -> + compute_cst_params_from_app (param :: acc) (params', rtl') + | _ -> List.rev acc + +let compute_params_name relnames + (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) + csts = let rels_params = Array.mapi (fun i args -> - List.fold_left - (fun params (_,cst) -> compute_cst_params relnames params cst) - args - csts.(i) - ) + List.fold_left + (fun params (_, cst) -> compute_cst_params relnames params cst) + args csts.(i)) args in let l = ref [] in let _ = try List.iteri - (fun i ((n,nt,typ) as param) -> - if Array.for_all - (fun l -> - let (n',nt',typ') = List.nth l i in - Name.equal n n' && glob_constr_eq nt nt' && Option.equal glob_constr_eq typ typ') - rels_params - then - l := param::!l - ) + (fun i ((n, nt, typ) as param) -> + if + Array.for_all + (fun l -> + let n', nt', typ' = List.nth l i in + Name.equal n n' && glob_constr_eq nt nt' + && Option.equal glob_constr_eq typ typ') + rels_params + then l := param :: !l) rels_params.(0) - with e when CErrors.noncritical e -> - () + with e when CErrors.noncritical e -> () in List.rev !l let rec rebuild_return_type rt = let loc = rt.CAst.loc in match rt.CAst.v with - | Constrexpr.CProdN(n,t') -> - CAst.make ?loc @@ Constrexpr.CProdN(n,rebuild_return_type t') - | Constrexpr.CLetIn(na,v,t,t') -> - CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t') - | _ -> CAst.make ?loc @@ Constrexpr.CProdN([Constrexpr.CLocalAssum ([CAst.make Anonymous], - Constrexpr.Default Explicit, rt)], - CAst.make @@ Constrexpr.CSort(UAnonymous {rigid=true})) - -let do_build_inductive - evd (funconstants: pconstant list) (funsargs: (Name.t * glob_constr * glob_constr option) list list) - returned_types - (rtl:glob_constr list) = + | Constrexpr.CProdN (n, t') -> + CAst.make ?loc @@ Constrexpr.CProdN (n, rebuild_return_type t') + | Constrexpr.CLetIn (na, v, t, t') -> + CAst.make ?loc @@ Constrexpr.CLetIn (na, v, t, rebuild_return_type t') + | _ -> + CAst.make ?loc + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ([CAst.make Anonymous], Constrexpr.Default Explicit, rt) ] + , CAst.make @@ Constrexpr.CSort (UAnonymous {rigid = true}) ) + +let do_build_inductive evd (funconstants : pconstant list) + (funsargs : (Name.t * glob_constr * glob_constr option) list list) + returned_types (rtl : glob_constr list) = let _time1 = System.get_time () in - let funnames = List.map (fun c -> Label.to_id (KerName.label (Constant.canonical (fst c)))) funconstants in + let funnames = + List.map + (fun c -> Label.to_id (KerName.label (Constant.canonical (fst c)))) + funconstants + in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) let funnames_as_set = List.fold_right Id.Set.add funnames Id.Set.empty in let funnames = Array.of_list funnames in let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in (* alpha_renaming of the body to prevent variable capture during manipulation *) - let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in + let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in let rta = Array.of_list rtl_alpha in (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious @@ -1324,46 +1277,64 @@ let do_build_inductive let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in (* Construction of the pseudo constructors *) let open Context.Named.Declaration in - let evd,env = + let evd, env = Array.fold_right2 - (fun id (c, u) (evd,env) -> - let u = EConstr.EInstance.make u in - let evd,t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in - let t = EConstr.Unsafe.to_constr t in - evd, - Environ.push_named (LocalAssum (make_annot id Sorts.Relevant,t)) - env - ) + (fun id (c, u) (evd, env) -> + let u = EConstr.EInstance.make u in + let evd, t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in + let t = EConstr.Unsafe.to_constr t in + ( evd + , Environ.push_named (LocalAssum (make_annot id Sorts.Relevant, t)) env + )) funnames (Array.of_list funconstants) - (evd,Global.env ()) + (evd, Global.env ()) in (* we solve and replace the implicits *) let rta = - Array.mapi (fun i rt -> - let _,t = Typing.type_of env evd (EConstr.of_constr (mkConstU ((Array.of_list funconstants).(i)))) in - resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env evd rt - ) rta + Array.mapi + (fun i rt -> + let _, t = + Typing.type_of env evd + (EConstr.of_constr (mkConstU (Array.of_list funconstants).(i))) + in + resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env + evd rt) + rta in let resa = Array.map (build_entry_lc env evd funnames_as_set []) rta in let env_with_graphs = - let rel_arity i funargs = (* Rebuilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = + let rel_arity i funargs = + (* Rebuilding arities (with parameters) *) + let rel_first_args : + (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list = funargs in List.fold_right - (fun (n,t,typ) acc -> + (fun (n, t, typ) acc -> match typ with | Some typ -> - CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), - acc) + CAst.make + @@ Constrexpr.CLetIn + ( CAst.make n + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) + , acc ) | None -> - CAst.make @@ Constrexpr.CProdN - ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], - acc - ) - ) + CAst.make + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t ) ] + , acc )) rel_first_args (rebuild_return_type returned_types.(i)) in @@ -1372,67 +1343,87 @@ let do_build_inductive Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in - Util.Array.fold_left2 (fun env rel_name rel_ar -> - let rex = fst (with_full_print (Constrintern.interp_constr env evd) rel_ar) in + Util.Array.fold_left2 + (fun env rel_name rel_ar -> + let rex = + fst (with_full_print (Constrintern.interp_constr env evd) rel_ar) + in let rex = EConstr.Unsafe.to_constr rex in - let r = Sorts.Relevant in (* TODO relevance *) - Environ.push_named (LocalAssum (make_annot rel_name r,rex)) env) env relnames rel_arities + let r = Sorts.Relevant in + (* TODO relevance *) + Environ.push_named (LocalAssum (make_annot rel_name r, rex)) env) + env relnames rel_arities in (* and of the real constructors*) let constr i res = List.map - (function result (* (args',concl') *) -> - let rt = compose_glob_context result.context result.value in - let nb_args = List.length funsargs.(i) in - (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) - fst ( - rebuild_cons env_with_graphs nb_args relnames.(i) - [] - [] - rt - ) - ) + (function + | result (* (args',concl') *) -> + let rt = compose_glob_context result.context result.value in + let nb_args = List.length funsargs.(i) in + (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) + fst (rebuild_cons env_with_graphs nb_args relnames.(i) [] [] rt)) res.result in (* adding names to constructors *) - let next_constructor_id = ref (-1) in + let next_constructor_id = ref (-1) in let mk_constructor_id i = incr next_constructor_id; (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) - Id.of_string ((Id.to_string (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) + Id.of_string + ( Id.to_string (mk_rel_id funnames.(i)) + ^ "_" + ^ string_of_int !next_constructor_id ) in - let rel_constructors i rt : (Id.t*glob_constr) list = - next_constructor_id := (-1); - List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) + let rel_constructors i rt : (Id.t * glob_constr) list = + next_constructor_id := -1; + List.map (fun constr -> (mk_constructor_id i, constr)) (constr i rt) in let rel_constructors = Array.mapi rel_constructors resa in (* Computing the set of parameters if asked *) - let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in + let rels_params = + compute_params_name relnames_as_set funsargs rel_constructors + in let nrel_params = List.length rels_params in - let rel_constructors = (* Taking into account the parameters in constructors *) - Array.map (List.map - (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) - rel_constructors + let rel_constructors = + (* Taking into account the parameters in constructors *) + Array.map + (List.map (fun (id, rt) -> (id, snd (chop_rprod_n nrel_params rt)))) + rel_constructors in - let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = - (snd (List.chop nrel_params funargs)) + let rel_arity i funargs = + (* Reduilding arities (with parameters) *) + let rel_first_args : + (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list = + snd (List.chop nrel_params funargs) in List.fold_right - (fun (n,t,typ) acc -> - match typ with - | Some typ -> - CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), - acc) - | None -> - CAst.make @@ Constrexpr.CProdN - ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], - acc - ) - ) + (fun (n, t, typ) acc -> + match typ with + | Some typ -> + CAst.make + @@ Constrexpr.CLetIn + ( CAst.make n + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) + , acc ) + | None -> + CAst.make + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t ) ] + , acc )) rel_first_args (rebuild_return_type returned_types.(i)) in @@ -1443,103 +1434,123 @@ let do_build_inductive let rel_arities = Array.mapi rel_arity funsargs in let rel_params_ids = List.fold_left - (fun acc (na,_,_) -> - match na with - Anonymous -> acc - | Name id -> id::acc - ) - [] - rels_params + (fun acc (na, _, _) -> + match na with Anonymous -> acc | Name id -> id :: acc) + [] rels_params in let rel_params = List.map - (fun (n,t,typ) -> - match typ with - | Some typ -> - Constrexpr.CLocalDef((CAst.make n), Constrextern.extern_glob_constr Id.Set.empty t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ)) - | None -> - Constrexpr.CLocalAssum - ([(CAst.make n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) - ) + (fun (n, t, typ) -> + match typ with + | Some typ -> + Constrexpr.CLocalDef + ( CAst.make n + , Constrextern.extern_glob_constr Id.Set.empty t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) ) + | None -> + Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , Constrextern.extern_glob_constr Id.Set.empty t )) rels_params in let ext_rels_constructors = - Array.map (List.map - (fun (id,t) -> - false,((CAst.make id), - with_full_print - (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t)) - ) - )) - (rel_constructors) + Array.map + (List.map (fun (id, t) -> + ( false + , ( CAst.make id + , with_full_print + (Constrextern.extern_glob_type Id.Set.empty) + ((* zeta_normalize *) alpha_rt rel_params_ids t) ) ))) + rel_constructors in let rel_ind i ext_rel_constructors = - ((CAst.make @@ relnames.(i)), - (rel_params,None), - Some rel_arities.(i), - ext_rel_constructors),[] + ( ( CAst.make @@ relnames.(i) + , (rel_params, None) + , Some rel_arities.(i) + , ext_rel_constructors ) + , [] ) in - let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in + let ext_rel_constructors = Array.mapi rel_ind ext_rels_constructors in let rel_inds = Array.to_list ext_rel_constructors in -(* let _ = *) -(* Pp.msgnl (\* observe *\) ( *) -(* str "Inductive" ++ spc () ++ *) -(* prlist_with_sep *) -(* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) -(* (function ((_,id),_,params,ar,constr) -> *) -(* Ppconstr.pr_id id ++ spc () ++ *) -(* Ppconstr.pr_binders params ++ spc () ++ *) -(* str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) -(* prlist_with_sep *) -(* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) -(* (function (_,((_,id),t)) -> *) -(* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr t) *) -(* constr *) -(* ) *) -(* rel_inds *) -(* ) *) -(* in *) + (* let _ = *) + (* Pp.msgnl (\* observe *\) ( *) + (* str "Inductive" ++ spc () ++ *) + (* prlist_with_sep *) + (* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) + (* (function ((_,id),_,params,ar,constr) -> *) + (* Ppconstr.pr_id id ++ spc () ++ *) + (* Ppconstr.pr_binders params ++ spc () ++ *) + (* str ":" ++ spc () ++ *) + (* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) + (* prlist_with_sep *) + (* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) + (* (function (_,((_,id),t)) -> *) + (* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) + (* Ppconstr.pr_lconstr_expr t) *) + (* constr *) + (* ) *) + (* rel_inds *) + (* ) *) + (* in *) let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds ~cumulative:false ~poly:false ~private_ind:false ~uniform:ComInductive.NonUniformParameters)) + (Flags.silently + (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds + ~cumulative:false ~poly:false ~private_ind:false + ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with - | UserError(s,msg) as e -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(Vernacexpr.Inductive_kw,repacked_rel_inds)}) - ++ fnl () ++ - msg - in - observe (msg); - raise e - | reraise -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make @@ Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(Vernacexpr.Inductive_kw,repacked_rel_inds)}) - ++ fnl () ++ - CErrors.print reraise - in - observe msg; - raise reraise - - + | UserError (s, msg) as e -> + let _time3 = System.get_time () in + (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map + (fun ((a, b, c, l), ntn) -> + (((false, (a, None)), b, c, Vernacexpr.Constructors l), ntn)) + rel_inds + in + let msg = + str "while trying to define" + ++ spc () + ++ Ppvernac.pr_vernac + (CAst.make + Vernacexpr. + { control = [] + ; attrs = [] + ; expr = + VernacInductive (Vernacexpr.Inductive_kw, repacked_rel_inds) + }) + ++ fnl () ++ msg + in + observe msg; raise e + | reraise -> + let _time3 = System.get_time () in + (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map + (fun ((a, b, c, l), ntn) -> + (((false, (a, None)), b, c, Vernacexpr.Constructors l), ntn)) + rel_inds + in + let msg = + str "while trying to define" + ++ spc () + ++ Ppvernac.pr_vernac + ( CAst.make + @@ Vernacexpr. + { control = [] + ; attrs = [] + ; expr = + VernacInductive (Vernacexpr.Inductive_kw, repacked_rel_inds) + } ) + ++ fnl () ++ CErrors.print reraise + in + observe msg; raise reraise let build_inductive evd funconstants funsargs returned_types rtl = let pu = !Detyping.print_universes in diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index a29e5dff23..8dfeafe7c9 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -7,13 +7,15 @@ open Names *) val build_inductive : -(* (ModPath.t * DirPath.t) option -> - Id.t list -> (* The list of function name *) - *) - Evd.evar_map -> - Constr.pconstant list -> - (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list list -> (* The list of function args *) - Constrexpr.constr_expr list -> (* The list of function returned type *) - Glob_term.glob_constr list -> (* the list of body *) - unit - + (* (ModPath.t * DirPath.t) option -> + Id.t list -> (* The list of function name *) + *) + Evd.evar_map + -> Constr.pconstant list + -> (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list list + -> (* The list of function args *) + Constrexpr.constr_expr list + -> (* The list of function returned type *) + Glob_term.glob_constr list + -> (* the list of body *) + unit diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 9fa72919ce..5026120849 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -18,14 +18,17 @@ open Names Some basic functions to rebuild glob_constr In each of them the location is Loc.ghost *) -let mkGRef ref = DAst.make @@ GRef(ref,None) -let mkGVar id = DAst.make @@ GVar(id) -let mkGApp(rt,rtl) = DAst.make @@ GApp(rt,rtl) -let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b) -let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b) -let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c) -let mkGCases(rto,l,brl) = DAst.make @@ GCases(RegularStyle,rto,l,brl) -let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) +let mkGRef ref = DAst.make @@ GRef (ref, None) +let mkGVar id = DAst.make @@ GVar id +let mkGApp (rt, rtl) = DAst.make @@ GApp (rt, rtl) +let mkGLambda (n, t, b) = DAst.make @@ GLambda (n, Explicit, t, b) +let mkGProd (n, t, b) = DAst.make @@ GProd (n, Explicit, t, b) +let mkGLetIn (n, b, t, c) = DAst.make @@ GLetIn (n, b, t, c) +let mkGCases (rto, l, brl) = DAst.make @@ GCases (RegularStyle, rto, l, brl) + +let mkGHole () = + DAst.make + @@ GHole (Evar_kinds.BinderType Anonymous, Namegen.IntroAnonymous, None) (* Some basic functions to decompose glob_constrs @@ -33,532 +36,483 @@ let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Nam *) let glob_decompose_app = let rec decompose_rapp acc rt = -(* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) + (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) match DAst.get rt with - | GApp(rt,rtl) -> - decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt - | _ -> rt,List.rev acc + | GApp (rt, rtl) -> + decompose_rapp (List.fold_left (fun y x -> x :: y) acc rtl) rt + | _ -> (rt, List.rev acc) in decompose_rapp [] - - - (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) -let glob_make_eq ?(typ= mkGHole ()) t1 t2 = - mkGApp(mkGRef (Coqlib.lib_ref "core.eq.type"),[typ;t2;t1]) +let glob_make_eq ?(typ = mkGHole ()) t1 t2 = + mkGApp (mkGRef (Coqlib.lib_ref "core.eq.type"), [typ; t2; t1]) (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) let glob_make_neq t1 t2 = - mkGApp(mkGRef (Coqlib.lib_ref "core.not.type"),[glob_make_eq t1 t2]) + mkGApp (mkGRef (Coqlib.lib_ref "core.not.type"), [glob_make_eq t1 t2]) let remove_name_from_mapping mapping na = - match na with - | Anonymous -> mapping - | Name id -> Id.Map.remove id mapping + match na with Anonymous -> mapping | Name id -> Id.Map.remove id mapping let change_vars = let rec change_vars mapping rt = - DAst.map_with_loc (fun ?loc -> function - | GRef _ as x -> x - | GVar id -> - let new_id = - try - Id.Map.find id mapping - with Not_found -> id + DAst.map_with_loc + (fun ?loc -> function GRef _ as x -> x + | GVar id -> + let new_id = try Id.Map.find id mapping with Not_found -> id in + GVar new_id | GEvar _ as x -> x | GPatVar _ as x -> x + | GApp (rt', rtl) -> + GApp (change_vars mapping rt', List.map (change_vars mapping) rtl) + | GLambda (name, k, t, b) -> + GLambda + ( name + , k + , change_vars mapping t + , change_vars (remove_name_from_mapping mapping name) b ) + | GProd (name, k, t, b) -> + GProd + ( name + , k + , change_vars mapping t + , change_vars (remove_name_from_mapping mapping name) b ) + | GLetIn (name, def, typ, b) -> + GLetIn + ( name + , change_vars mapping def + , Option.map (change_vars mapping) typ + , change_vars (remove_name_from_mapping mapping name) b ) + | GLetTuple (nal, (na, rto), b, e) -> + let new_mapping = + List.fold_left remove_name_from_mapping mapping nal in - GVar(new_id) - | GEvar _ as x -> x - | GPatVar _ as x -> x - | GApp(rt',rtl) -> - GApp(change_vars mapping rt', - List.map (change_vars mapping) rtl - ) - | GLambda(name,k,t,b) -> - GLambda(name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | GProd(name,k,t,b) -> - GProd( name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | GLetIn(name,def,typ,b) -> - GLetIn(name, - change_vars mapping def, - Option.map (change_vars mapping) typ, - change_vars (remove_name_from_mapping mapping name) b - ) - | GLetTuple(nal,(na,rto),b,e) -> - let new_mapping = List.fold_left remove_name_from_mapping mapping nal in - GLetTuple(nal, - (na, Option.map (change_vars mapping) rto), - change_vars mapping b, - change_vars new_mapping e - ) - | GCases(sty,infos,el,brl) -> - GCases(sty, - infos, - List.map (fun (e,x) -> (change_vars mapping e,x)) el, - List.map (change_vars_br mapping) brl - ) - | GIf(b,(na,e_option),lhs,rhs) -> - GIf(change_vars mapping b, - (na,Option.map (change_vars mapping) e_option), - change_vars mapping lhs, - change_vars mapping rhs - ) - | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") - | GSort _ as x -> x - | GHole _ as x -> x - | GInt _ as x -> x - | GFloat _ as x -> x - | GCast(b,c) -> - GCast(change_vars mapping b, - Glob_ops.map_cast_type (change_vars mapping) c) - ) rt - and change_vars_br mapping ({CAst.loc;v=(idl,patl,res)} as br) = + GLetTuple + ( nal + , (na, Option.map (change_vars mapping) rto) + , change_vars mapping b + , change_vars new_mapping e ) + | GCases (sty, infos, el, brl) -> + GCases + ( sty + , infos + , List.map (fun (e, x) -> (change_vars mapping e, x)) el + , List.map (change_vars_br mapping) brl ) + | GIf (b, (na, e_option), lhs, rhs) -> + GIf + ( change_vars mapping b + , (na, Option.map (change_vars mapping) e_option) + , change_vars mapping lhs + , change_vars mapping rhs ) + | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") + | GSort _ as x -> x | GHole _ as x -> x | GInt _ as x -> x + | GFloat _ as x -> x + | GCast (b, c) -> + GCast + ( change_vars mapping b + , Glob_ops.map_cast_type (change_vars mapping) c )) + rt + and change_vars_br mapping ({CAst.loc; v = idl, patl, res} as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in - if Id.Map.is_empty new_mapping - then br - else CAst.make ?loc (idl,patl,change_vars new_mapping res) + if Id.Map.is_empty new_mapping then br + else CAst.make ?loc (idl, patl, change_vars new_mapping res) in change_vars - - let rec alpha_pat excluded pat = let loc = pat.CAst.loc in match DAst.get pat with - | PatVar Anonymous -> - let new_id = Indfun_common.fresh_id excluded "_x" in - (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty - | PatVar(Name id) -> - if Id.List.mem id excluded - then - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), - (Id.Map.add id new_id Id.Map.empty) - else pat, excluded,Id.Map.empty - | PatCstr(constr,patl,na) -> - let new_na,new_excluded,map = - match na with - | Name id when Id.List.mem id excluded -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty - | _ -> na,excluded,Id.Map.empty - in - let new_patl,new_excluded,new_map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - (new_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map) - ) - ([],new_excluded,map) - patl - in - (DAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map - -let alpha_patl excluded patl = - let patl,new_excluded,map = + | PatVar Anonymous -> + let new_id = Indfun_common.fresh_id excluded "_x" in + (DAst.make ?loc @@ PatVar (Name new_id), new_id :: excluded, Id.Map.empty) + | PatVar (Name id) -> + if Id.List.mem id excluded then + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + ( DAst.make ?loc @@ PatVar (Name new_id) + , new_id :: excluded + , Id.Map.add id new_id Id.Map.empty ) + else (pat, excluded, Id.Map.empty) + | PatCstr (constr, patl, na) -> + let new_na, new_excluded, map = + match na with + | Name id when Id.List.mem id excluded -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + (Name new_id, new_id :: excluded, Id.Map.add id new_id Id.Map.empty) + | _ -> (na, excluded, Id.Map.empty) + in + let new_patl, new_excluded, new_map = + List.fold_left + (fun (patl, excluded, map) pat -> + let new_pat, new_excluded, new_map = alpha_pat excluded pat in + (new_pat :: patl, new_excluded, Id.Map.fold Id.Map.add new_map map)) + ([], new_excluded, map) patl + in + ( DAst.make ?loc @@ PatCstr (constr, List.rev new_patl, new_na) + , new_excluded + , new_map ) + +let alpha_patl excluded patl = + let patl, new_excluded, map = List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - new_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map) - ) - ([],excluded,Id.Map.empty) + (fun (patl, excluded, map) pat -> + let new_pat, new_excluded, new_map = alpha_pat excluded pat in + (new_pat :: patl, new_excluded, Id.Map.fold Id.Map.add new_map map)) + ([], excluded, Id.Map.empty) patl in - (List.rev patl,new_excluded,map) - - - + (List.rev patl, new_excluded, map) let raw_get_pattern_id pat acc = let rec get_pattern_id pat = match DAst.get pat with - | PatVar(Anonymous) -> assert false - | PatVar(Name id) -> - [id] - | PatCstr(constr,patternl,_) -> - List.fold_right - (fun pat idl -> - let idl' = get_pattern_id pat in - idl'@idl - ) - patternl - [] + | PatVar Anonymous -> assert false + | PatVar (Name id) -> [id] + | PatCstr (constr, patternl, _) -> + List.fold_right + (fun pat idl -> + let idl' = get_pattern_id pat in + idl' @ idl) + patternl [] in - (get_pattern_id pat)@acc + get_pattern_id pat @ acc let get_pattern_id pat = raw_get_pattern_id pat [] let rec alpha_rt excluded rt = let loc = rt.CAst.loc in - let new_rt = DAst.make ?loc @@ + let new_rt = + DAst.make ?loc + @@ match DAst.get rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt - | GLambda(Anonymous,k,t,b) -> - let new_id = Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) in - let new_excluded = new_id :: excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GLambda(Name new_id,k,new_t,new_b) - | GProd(Anonymous,k,t,b) -> - let new_t = alpha_rt excluded t in - let new_b = alpha_rt excluded b in - GProd(Anonymous,k,new_t,new_b) - | GLetIn(Anonymous,b,t,c) -> - let new_b = alpha_rt excluded b in - let new_t = Option.map (alpha_rt excluded) t in - let new_c = alpha_rt excluded c in - GLetIn(Anonymous,new_b,new_t,new_c) - | GLambda(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let t,b = - if Id.equal new_id id - then t, b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) - in - let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GLambda(Name new_id,k,new_t,new_b) - | GProd(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let new_excluded = new_id::excluded in - let t,b = - if Id.equal new_id id - then t,b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) - in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GProd(Name new_id,k,new_t,new_b) - | GLetIn(Name id,b,t,c) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let c = - if Id.equal new_id id then c - else change_vars (Id.Map.add id new_id Id.Map.empty) c - in - let new_excluded = new_id::excluded in - let new_b = alpha_rt new_excluded b in - let new_t = Option.map (alpha_rt new_excluded) t in - let new_c = alpha_rt new_excluded c in - GLetIn(Name new_id,new_b,new_t,new_c) - - | GLetTuple(nal,(na,rto),t,b) -> - let rev_new_nal,new_excluded,mapping = - List.fold_left - (fun (nal,excluded,mapping) na -> - match na with - | Anonymous -> (na::nal,excluded,mapping) - | Name id -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - if Id.equal new_id id - then - na::nal,id::excluded,mapping - else - (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping) - ) - ([],excluded,Id.Map.empty) - nal - in - let new_nal = List.rev rev_new_nal in - let new_rto,new_t,new_b = - if Id.Map.is_empty mapping - then rto,t,b - else let replace = change_vars mapping in - (Option.map replace rto, t,replace b) - in - let new_t = alpha_rt new_excluded new_t in - let new_b = alpha_rt new_excluded new_b in - let new_rto = Option.map (alpha_rt new_excluded) new_rto in - GLetTuple(new_nal,(na,new_rto),new_t,new_b) - | GCases(sty,infos,el,brl) -> - let new_el = - List.map (function (rt,i) -> alpha_rt excluded rt, i) el - in - GCases(sty,infos,new_el,List.map (alpha_br excluded) brl) - | GIf(b,(na,e_o),lhs,rhs) -> - GIf(alpha_rt excluded b, - (na,Option.map (alpha_rt excluded) e_o), - alpha_rt excluded lhs, - alpha_rt excluded rhs - ) + | (GRef _ | GVar _ | GEvar _ | GPatVar _) as rt -> rt + | GLambda (Anonymous, k, t, b) -> + let new_id = + Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) + in + let new_excluded = new_id :: excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GLambda (Name new_id, k, new_t, new_b) + | GProd (Anonymous, k, t, b) -> + let new_t = alpha_rt excluded t in + let new_b = alpha_rt excluded b in + GProd (Anonymous, k, new_t, new_b) + | GLetIn (Anonymous, b, t, c) -> + let new_b = alpha_rt excluded b in + let new_t = Option.map (alpha_rt excluded) t in + let new_c = alpha_rt excluded c in + GLetIn (Anonymous, new_b, new_t, new_c) + | GLambda (Name id, k, t, b) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let t, b = + if Id.equal new_id id then (t, b) + else + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in + (t, replace b) + in + let new_excluded = new_id :: excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GLambda (Name new_id, k, new_t, new_b) + | GProd (Name id, k, t, b) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let new_excluded = new_id :: excluded in + let t, b = + if Id.equal new_id id then (t, b) + else + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in + (t, replace b) + in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GProd (Name new_id, k, new_t, new_b) + | GLetIn (Name id, b, t, c) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let c = + if Id.equal new_id id then c + else change_vars (Id.Map.add id new_id Id.Map.empty) c + in + let new_excluded = new_id :: excluded in + let new_b = alpha_rt new_excluded b in + let new_t = Option.map (alpha_rt new_excluded) t in + let new_c = alpha_rt new_excluded c in + GLetIn (Name new_id, new_b, new_t, new_c) + | GLetTuple (nal, (na, rto), t, b) -> + let rev_new_nal, new_excluded, mapping = + List.fold_left + (fun (nal, excluded, mapping) na -> + match na with + | Anonymous -> (na :: nal, excluded, mapping) + | Name id -> + let new_id = + Namegen.next_ident_away id (Id.Set.of_list excluded) + in + if Id.equal new_id id then (na :: nal, id :: excluded, mapping) + else + ( Name new_id :: nal + , id :: excluded + , Id.Map.add id new_id mapping )) + ([], excluded, Id.Map.empty) + nal + in + let new_nal = List.rev rev_new_nal in + let new_rto, new_t, new_b = + if Id.Map.is_empty mapping then (rto, t, b) + else + let replace = change_vars mapping in + (Option.map replace rto, t, replace b) + in + let new_t = alpha_rt new_excluded new_t in + let new_b = alpha_rt new_excluded new_b in + let new_rto = Option.map (alpha_rt new_excluded) new_rto in + GLetTuple (new_nal, (na, new_rto), new_t, new_b) + | GCases (sty, infos, el, brl) -> + let new_el = + List.map (function rt, i -> (alpha_rt excluded rt, i)) el + in + GCases (sty, infos, new_el, List.map (alpha_br excluded) brl) + | GIf (b, (na, e_o), lhs, rhs) -> + GIf + ( alpha_rt excluded b + , (na, Option.map (alpha_rt excluded) e_o) + , alpha_rt excluded lhs + , alpha_rt excluded rhs ) | GRec _ -> user_err Pp.(str "Not handled GRec") - | GSort _ - | GInt _ - | GFloat _ - | GHole _ as rt -> rt - | GCast (b,c) -> - GCast(alpha_rt excluded b, - Glob_ops.map_cast_type (alpha_rt excluded) c) - | GApp(f,args) -> - GApp(alpha_rt excluded f, - List.map (alpha_rt excluded) args - ) + | (GSort _ | GInt _ | GFloat _ | GHole _) as rt -> rt + | GCast (b, c) -> + GCast (alpha_rt excluded b, Glob_ops.map_cast_type (alpha_rt excluded) c) + | GApp (f, args) -> + GApp (alpha_rt excluded f, List.map (alpha_rt excluded) args) in new_rt -and alpha_br excluded {CAst.loc;v=(ids,patl,res)} = - let new_patl,new_excluded,mapping = alpha_patl excluded patl in +and alpha_br excluded {CAst.loc; v = ids, patl, res} = + let new_patl, new_excluded, mapping = alpha_patl excluded patl in let new_ids = List.fold_right raw_get_pattern_id new_patl [] in - let new_excluded = new_ids@excluded in + let new_excluded = new_ids @ excluded in let renamed_res = change_vars mapping res in let new_res = alpha_rt new_excluded renamed_res in - CAst.make ?loc (new_ids,new_patl,new_res) + CAst.make ?loc (new_ids, new_patl, new_res) (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = - let rec is_free_in x = DAst.with_loc_val (fun ?loc -> function - | GRef _ -> false - | GVar id' -> Id.compare id' id == 0 - | GEvar _ -> false - | GPatVar _ -> false - | GApp(rt,rtl) -> List.exists is_free_in (rt::rtl) - | GLambda(n,_,t,b) | GProd(n,_,t,b) -> - let check_in_b = - match n with - | Name id' -> not (Id.equal id' id) - | _ -> true - in - is_free_in t || (check_in_b && is_free_in b) - | GLetIn(n,b,t,c) -> - let check_in_c = - match n with - | Name id' -> not (Id.equal id' id) - | _ -> true - in - is_free_in b || Option.cata is_free_in true t || (check_in_c && is_free_in c) - | GCases(_,_,el,brl) -> - (List.exists (fun (e,_) -> is_free_in e) el) || - List.exists is_free_in_br brl - | GLetTuple(nal,_,b,t) -> - let check_in_nal = - not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal) - in - is_free_in t || (check_in_nal && is_free_in b) - - | GIf(cond,_,br1,br2) -> - is_free_in cond || is_free_in br1 || is_free_in br2 - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GSort _ -> false - | GHole _ -> false - | GCast (b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t - | GCast (b,CastCoerce) -> is_free_in b - | GInt _ | GFloat _ -> false - ) x - and is_free_in_br {CAst.v=(ids,_,rt)} = + let rec is_free_in x = + DAst.with_loc_val + (fun ?loc -> function GRef _ -> false | GVar id' -> Id.compare id' id == 0 + | GEvar _ -> false | GPatVar _ -> false + | GApp (rt, rtl) -> List.exists is_free_in (rt :: rtl) + | GLambda (n, _, t, b) | GProd (n, _, t, b) -> + let check_in_b = + match n with Name id' -> not (Id.equal id' id) | _ -> true + in + is_free_in t || (check_in_b && is_free_in b) + | GLetIn (n, b, t, c) -> + let check_in_c = + match n with Name id' -> not (Id.equal id' id) | _ -> true + in + is_free_in b + || Option.cata is_free_in true t + || (check_in_c && is_free_in c) + | GCases (_, _, el, brl) -> + List.exists (fun (e, _) -> is_free_in e) el + || List.exists is_free_in_br brl + | GLetTuple (nal, _, b, t) -> + let check_in_nal = + not + (List.exists + (function Name id' -> Id.equal id' id | _ -> false) + nal) + in + is_free_in t || (check_in_nal && is_free_in b) + | GIf (cond, _, br1, br2) -> + is_free_in cond || is_free_in br1 || is_free_in br2 + | GRec _ -> user_err Pp.(str "Not handled GRec") | GSort _ -> false + | GHole _ -> false + | GCast (b, (CastConv t | CastVM t | CastNative t)) -> + is_free_in b || is_free_in t | GCast (b, CastCoerce) -> is_free_in b + | GInt _ | GFloat _ -> false) + x + and is_free_in_br {CAst.v = ids, _, rt} = (not (Id.List.mem id ids)) && is_free_in rt in is_free_in - - -let rec pattern_to_term pt = DAst.with_val (function - | PatVar Anonymous -> assert false - | PatVar(Name id) -> - mkGVar id - | PatCstr(constr,patternl,_) -> - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - constr - in - let implicit_args = - Array.to_list - (Array.init - (cst_narg - List.length patternl) - (fun _ -> mkGHole ()) - ) - in - let patl_as_term = - List.map pattern_to_term patternl - in - mkGApp(mkGRef(GlobRef.ConstructRef constr), - implicit_args@patl_as_term - ) - ) pt - +let rec pattern_to_term pt = + DAst.with_val + (function + | PatVar Anonymous -> assert false + | PatVar (Name id) -> mkGVar id + | PatCstr (constr, patternl, _) -> + let cst_narg = + Inductiveops.constructor_nallargs (Global.env ()) constr + in + let implicit_args = + Array.to_list + (Array.init (cst_narg - List.length patternl) (fun _ -> mkGHole ())) + in + let patl_as_term = List.map pattern_to_term patternl in + mkGApp + (mkGRef (GlobRef.ConstructRef constr), implicit_args @ patl_as_term)) + pt let replace_var_by_term x_id term = - let rec replace_var_by_pattern x = DAst.map (function - | GVar id when Id.compare id x_id == 0 -> DAst.get term - | GRef _ - | GVar _ - | GEvar _ - | GPatVar _ as rt -> rt - | GApp(rt',rtl) -> - GApp(replace_var_by_pattern rt', - List.map replace_var_by_pattern rtl - ) - | GLambda(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GLambda(name,k,t,b) -> - GLambda(name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) - | GProd(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GProd(name,k,t,b) -> - GProd( name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) - | GLetIn(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GLetIn(name,def,typ,b) -> - GLetIn(name, - replace_var_by_pattern def, - Option.map (replace_var_by_pattern) typ, - replace_var_by_pattern b - ) - | GLetTuple(nal,_,_,_) as rt - when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal -> + let rec replace_var_by_pattern x = + DAst.map + (function + | GVar id when Id.compare id x_id == 0 -> DAst.get term + | (GRef _ | GVar _ | GEvar _ | GPatVar _) as rt -> rt + | GApp (rt', rtl) -> + GApp (replace_var_by_pattern rt', List.map replace_var_by_pattern rtl) + | GLambda (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GLambda (name, k, t, b) -> + GLambda (name, k, replace_var_by_pattern t, replace_var_by_pattern b) + | GProd (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GProd (name, k, t, b) -> + GProd (name, k, replace_var_by_pattern t, replace_var_by_pattern b) + | GLetIn (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GLetIn (name, def, typ, b) -> + GLetIn + ( name + , replace_var_by_pattern def + , Option.map replace_var_by_pattern typ + , replace_var_by_pattern b ) + | GLetTuple (nal, _, _, _) as rt + when List.exists + (function Name id -> Id.equal id x_id | _ -> false) + nal -> rt - | GLetTuple(nal,(na,rto),def,b) -> - GLetTuple(nal, - (na,Option.map replace_var_by_pattern rto), - replace_var_by_pattern def, - replace_var_by_pattern b - ) - | GCases(sty,infos,el,brl) -> - GCases(sty, - infos, - List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, - List.map replace_var_by_pattern_br brl - ) - | GIf(b,(na,e_option),lhs,rhs) -> - GIf(replace_var_by_pattern b, - (na,Option.map replace_var_by_pattern e_option), - replace_var_by_pattern lhs, - replace_var_by_pattern rhs - ) - | GRec _ -> - CErrors.user_err (Pp.str "Not handled GRec") - | GSort _ - | GHole _ as rt -> rt - | GInt _ as rt -> rt - | GFloat _ as rt -> rt - | GCast(b,c) -> - GCast(replace_var_by_pattern b, - Glob_ops.map_cast_type replace_var_by_pattern c) - ) x - and replace_var_by_pattern_br ({CAst.loc;v=(idl,patl,res)} as br) = - if List.exists (fun id -> Id.compare id x_id == 0) idl - then br - else CAst.make ?loc (idl,patl,replace_var_by_pattern res) + | GLetTuple (nal, (na, rto), def, b) -> + GLetTuple + ( nal + , (na, Option.map replace_var_by_pattern rto) + , replace_var_by_pattern def + , replace_var_by_pattern b ) + | GCases (sty, infos, el, brl) -> + GCases + ( sty + , infos + , List.map (fun (e, x) -> (replace_var_by_pattern e, x)) el + , List.map replace_var_by_pattern_br brl ) + | GIf (b, (na, e_option), lhs, rhs) -> + GIf + ( replace_var_by_pattern b + , (na, Option.map replace_var_by_pattern e_option) + , replace_var_by_pattern lhs + , replace_var_by_pattern rhs ) + | GRec _ -> CErrors.user_err (Pp.str "Not handled GRec") + | (GSort _ | GHole _) as rt -> rt + | GInt _ as rt -> rt + | GFloat _ as rt -> rt + | GCast (b, c) -> + GCast + ( replace_var_by_pattern b + , Glob_ops.map_cast_type replace_var_by_pattern c )) + x + and replace_var_by_pattern_br ({CAst.loc; v = idl, patl, res} as br) = + if List.exists (fun id -> Id.compare id x_id == 0) idl then br + else CAst.make ?loc (idl, patl, replace_var_by_pattern res) in replace_var_by_pattern - - - (* checking unifiability of patterns *) exception NotUnifiable -let rec are_unifiable_aux = function +let rec are_unifiable_aux = function | [] -> () - | (l, r) ::eqs -> - match DAst.get l, DAst.get r with - | PatVar _ ,_ | _, PatVar _-> are_unifiable_aux eqs - | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> - if not (eq_constructor constructor2 constructor1) - then raise NotUnifiable - else - let eqs' = - try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") - in - are_unifiable_aux eqs' + | (l, r) :: eqs -> ( + match (DAst.get l, DAst.get r) with + | PatVar _, _ | _, PatVar _ -> are_unifiable_aux eqs + | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + else + let eqs' = + try List.combine cpl1 cpl2 @ eqs + with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") + in + are_unifiable_aux eqs' ) let are_unifiable pat1 pat2 = try - are_unifiable_aux [pat1,pat2]; + are_unifiable_aux [(pat1, pat2)]; true with NotUnifiable -> false - -let rec eq_cases_pattern_aux = function +let rec eq_cases_pattern_aux = function | [] -> () - | (l, r) ::eqs -> - match DAst.get l, DAst.get r with - | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs - | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> - if not (eq_constructor constructor2 constructor1) - then raise NotUnifiable - else - let eqs' = - try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") - in - eq_cases_pattern_aux eqs' - | _ -> raise NotUnifiable + | (l, r) :: eqs -> ( + match (DAst.get l, DAst.get r) with + | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + else + let eqs' = + try List.combine cpl1 cpl2 @ eqs + with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") + in + eq_cases_pattern_aux eqs' + | _ -> raise NotUnifiable ) let eq_cases_pattern pat1 pat2 = try - eq_cases_pattern_aux [pat1,pat2]; + eq_cases_pattern_aux [(pat1, pat2)]; true with NotUnifiable -> false - - let ids_of_pat = - let rec ids_of_pat ids = DAst.with_val (function - | PatVar Anonymous -> ids - | PatVar(Name id) -> Id.Set.add id ids - | PatCstr(_,patl,_) -> List.fold_left ids_of_pat ids patl - ) + let rec ids_of_pat ids = + DAst.with_val (function + | PatVar Anonymous -> ids + | PatVar (Name id) -> Id.Set.add id ids + | PatCstr (_, patl, _) -> List.fold_left ids_of_pat ids patl) in ids_of_pat Id.Set.empty let expand_as = - let rec add_as map rt = match DAst.get rt with - | PatVar _ -> map - | PatCstr(_,patl,Name id) -> - Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) - | PatCstr(_,patl,_) -> List.fold_left add_as map patl + | PatVar _ -> map + | PatCstr (_, patl, Name id) -> + Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) + | PatCstr (_, patl, _) -> List.fold_left add_as map patl in - let rec expand_as map = DAst.map (function - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ as rt -> rt - | GVar id as rt -> - begin - try - DAst.get (Id.Map.find id map) - with Not_found -> rt - end - | GApp(f,args) -> GApp(expand_as map f,List.map (expand_as map) args) - | GLambda(na,k,t,b) -> GLambda(na,k,expand_as map t, expand_as map b) - | GProd(na,k,t,b) -> GProd(na,k,expand_as map t, expand_as map b) - | GLetIn(na,v,typ,b) -> GLetIn(na, expand_as map v,Option.map (expand_as map) typ,expand_as map b) - | GLetTuple(nal,(na,po),v,b) -> - GLetTuple(nal,(na,Option.map (expand_as map) po), - expand_as map v, expand_as map b) - | GIf(e,(na,po),br1,br2) -> - GIf(expand_as map e,(na,Option.map (expand_as map) po), - expand_as map br1, expand_as map br2) - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GCast(b,c) -> - GCast(expand_as map b, - Glob_ops.map_cast_type (expand_as map) c) - | GCases(sty,po,el,brl) -> - GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, - List.map (expand_as_br map) brl) - ) - and expand_as_br map {CAst.loc; v=(idl,cpl,rt)} = - CAst.make ?loc (idl,cpl, expand_as (List.fold_left add_as map cpl) rt) + let rec expand_as map = + DAst.map (function + | (GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _) + as rt -> + rt + | GVar id as rt -> ( + try DAst.get (Id.Map.find id map) with Not_found -> rt ) + | GApp (f, args) -> GApp (expand_as map f, List.map (expand_as map) args) + | GLambda (na, k, t, b) -> + GLambda (na, k, expand_as map t, expand_as map b) + | GProd (na, k, t, b) -> GProd (na, k, expand_as map t, expand_as map b) + | GLetIn (na, v, typ, b) -> + GLetIn + (na, expand_as map v, Option.map (expand_as map) typ, expand_as map b) + | GLetTuple (nal, (na, po), v, b) -> + GLetTuple + ( nal + , (na, Option.map (expand_as map) po) + , expand_as map v + , expand_as map b ) + | GIf (e, (na, po), br1, br2) -> + GIf + ( expand_as map e + , (na, Option.map (expand_as map) po) + , expand_as map br1 + , expand_as map br2 ) + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast (b, c) -> + GCast (expand_as map b, Glob_ops.map_cast_type (expand_as map) c) + | GCases (sty, po, el, brl) -> + GCases + ( sty + , Option.map (expand_as map) po + , List.map (fun (rt, t) -> (expand_as map rt, t)) el + , List.map (expand_as_br map) brl )) + and expand_as_br map {CAst.loc; v = idl, cpl, rt} = + CAst.make ?loc (idl, cpl, expand_as (List.fold_left add_as map cpl) rt) in expand_as Id.Map.empty @@ -566,65 +520,75 @@ let expand_as = *) exception Found of Evd.evar_info -let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expected_type=Pretyping.WithoutTypeConstraint) env sigma rt = + +let resolve_and_replace_implicits ?(flags = Pretyping.all_and_fail_flags) + ?(expected_type = Pretyping.WithoutTypeConstraint) env sigma rt = let open Evd in let open Evar_kinds in (* we first (pseudo) understand [rt] and get back the computed evar_map *) (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. -If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) - let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in + If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) + let ctx, _, _ = + Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type + rt + in let ctx = Evd.minimize_universes ctx in - let f c = EConstr.of_constr (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) in - + let f c = + EConstr.of_constr + (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) + in (* then we map [rt] to replace the implicit holes by their values *) let rec change rt = match DAst.get rt with - | GHole(ImplicitArg(grk,pk,bk),_,_) -> (* we only want to deal with implicit arguments *) - ( - try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) - Evd.fold (* to simulate an iter *) - (fun _ evi _ -> - match evi.evar_source with - | (loc_evi,ImplicitArg(gr_evi,p_evi,b_evi)) -> - if GlobRef.equal grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi - then raise (Found evi) - | _ -> () - ) - ctx - (); - (* the hole was not solved : we do nothing *) - rt - with Found evi -> (* we found the evar corresponding to this hole *) - match evi.evar_body with - | Evar_defined c -> - (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) - | Evar_empty -> rt (* the hole was not solved : we do nothing *) - ) - | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) - ( - let res = - try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) - Evd.fold (* to simulate an iter *) - (fun _ evi _ -> - match evi.evar_source with - | (loc_evi,BinderType na') -> - if Name.equal na na' && rt.CAst.loc = loc_evi then raise (Found evi) - | _ -> () - ) - ctx - (); - (* the hole was not solved : we do nothing *) - rt - with Found evi -> (* we found the evar corresponding to this hole *) - match evi.evar_body with - | Evar_defined c -> - (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) - | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) - in - res - ) + | GHole (ImplicitArg (grk, pk, bk), _, _) -> ( + try + (* we only want to deal with implicit arguments *) + + (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | loc_evi, ImplicitArg (gr_evi, p_evi, b_evi) -> + if + GlobRef.equal grk gr_evi && pk = p_evi && bk = b_evi + && rt.CAst.loc = loc_evi + then raise (Found evi) + | _ -> ()) + ctx (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> ( + (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) + | Evar_empty -> rt (* the hole was not solved : we do nothing *) ) ) + | GHole (BinderType na, _, _) -> + (* we only want to deal with implicit arguments *) + let res = + try + (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | loc_evi, BinderType na' -> + if Name.equal na na' && rt.CAst.loc = loc_evi then + raise (Found evi) + | _ -> ()) + ctx (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> ( + (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) + | Evar_empty -> rt ) + (* the hole was not solved : we d when falseo nothing *) + in + res | _ -> Glob_ops.map_glob_constr change rt in change rt diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index c55fdc017c..8eff7926da 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -25,33 +25,37 @@ val pattern_to_term : cases_pattern -> glob_constr *) val mkGRef : GlobRef.t -> glob_constr val mkGVar : Id.t -> glob_constr -val mkGApp : glob_constr*(glob_constr list) -> glob_constr +val mkGApp : glob_constr * glob_constr list -> glob_constr val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr -val mkGLetIn : Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr -val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr -val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *) + +val mkGLetIn : + Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr + +val mkGCases : + glob_constr option * tomatch_tuples * cases_clauses -> glob_constr + +val mkGHole : unit -> glob_constr + +(* we only build Evd.BinderType Anonymous holes *) + (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) -val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) - +val glob_decompose_app : glob_constr -> glob_constr * glob_constr list (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) -val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr +val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr + (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) -val glob_make_neq : glob_constr -> glob_constr -> glob_constr +val glob_make_neq : glob_constr -> glob_constr -> glob_constr (* alpha_conversion functions *) - - (* Replace the var mapped in the glob_constr/context *) val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr - - (* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. the result does not share variables with [avoid]. This function create a fresh variable for each occurrence of the anonymous pattern. @@ -59,11 +63,10 @@ val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr Also returns a mapping from old variables to new ones and the concatenation of [avoid] with the variables appearing in the result. *) - val alpha_pat : - Id.Map.key list -> - Glob_term.cases_pattern -> - Glob_term.cases_pattern * Id.Map.key list * - Id.t Id.Map.t +val alpha_pat : + Id.Map.key list + -> Glob_term.cases_pattern + -> Glob_term.cases_pattern * Id.Map.key list * Id.t Id.Map.t (* [alpha_rt avoid rt] alpha convert [rt] s.t. the result respects barendregt conventions and does not share bound variables with avoid @@ -71,38 +74,35 @@ val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr val alpha_rt : Id.t list -> glob_constr -> glob_constr (* same as alpha_rt but for case branches *) -val alpha_br : Id.t list -> - Glob_term.cases_clause -> - Glob_term.cases_clause +val alpha_br : Id.t list -> Glob_term.cases_clause -> Glob_term.cases_clause (* Reduction function *) -val replace_var_by_term : - Id.t -> - Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr - - +val replace_var_by_term : + Id.t + -> Glob_term.glob_constr + -> Glob_term.glob_constr + -> Glob_term.glob_constr (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) val is_free_in : Id.t -> glob_constr -> bool - - val are_unifiable : cases_pattern -> cases_pattern -> bool val eq_cases_pattern : cases_pattern -> cases_pattern -> bool - - (* ids_of_pat : cases_pattern -> Id.Set.t returns the set of variables appearing in a pattern *) -val ids_of_pat : cases_pattern -> Id.Set.t - +val ids_of_pat : cases_pattern -> Id.Set.t val expand_as : glob_constr -> glob_constr (* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution *) val resolve_and_replace_implicits : - ?flags:Pretyping.inference_flags -> - ?expected_type:Pretyping.typing_constraint -> Environ.env -> Evd.evar_map -> glob_constr -> glob_constr + ?flags:Pretyping.inference_flags + -> ?expected_type:Pretyping.typing_constraint + -> Environ.env + -> Evd.evar_map + -> glob_constr + -> glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 1f2f56ec34..4e0e2dc501 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -15,48 +15,49 @@ open Names open Sorts open Constr open EConstr - open Tacmach.New open Tacticals.New open Tactics - open Indfun_common - module RelDecl = Context.Rel.Declaration let is_rec_info sigma scheme_info = let test_branche min acc decl = - acc || ( - let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) in - let free_rels_in_br = Termops.free_rels sigma new_branche in - let max = min + scheme_info.Tactics.npredicates in - Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br - ) + acc + || + let new_branche = + it_mkProd_or_LetIn mkProp + (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) + in + let free_rels_in_br = Termops.free_rels sigma new_branche in + let max = min + scheme_info.Tactics.npredicates in + Int.Set.exists (fun i -> i >= min && i < max) free_rels_in_br in List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) let choose_dest_or_ind scheme_info args = Proofview.tclBIND Proofview.tclEVARMAP (fun sigma -> - Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) + Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) let functional_induction with_clean c princl pat = let open Proofview.Notations in Proofview.Goal.enter_one (fun gl -> - let sigma = project gl in - let f,args = decompose_app sigma c in - match princl with - | None -> (* No principle is given let's find the good one *) - begin + let sigma = project gl in + let f, args = decompose_app sigma c in + match princl with + | None -> ( + (* No principle is given let's find the good one *) match EConstr.kind sigma f with - | Const (c',u) -> + | Const (c', u) -> let princ_option = - let finfo = (* we first try to find out a graph on f *) + let finfo = + (* we first try to find out a graph on f *) match find_Function_infos c' with | Some finfo -> finfo | None -> - user_err (str "Cannot find induction information on "++ - Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) + user_err + ( str "Cannot find induction information on " + ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in match elimination_sort_of_goal gl with | InSProp -> finfo.sprop_lemma @@ -64,7 +65,8 @@ let functional_induction with_clean c princl pat = | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma in - let sigma, princ = (* then we get the principle *) + let sigma, princ = + (* then we get the principle *) match princ_option with | Some princ -> Evd.fresh_global (pf_env gl) (project gl) (GlobRef.ConstRef princ) @@ -79,66 +81,74 @@ let functional_induction with_clean c princl pat = in let princ_ref = try - Constrintern.locate_reference (Libnames.qualid_of_ident princ_name) - with - | Not_found -> - user_err (str "Cannot find induction principle for " - ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) + Constrintern.locate_reference + (Libnames.qualid_of_ident princ_name) + with Not_found -> + user_err + ( str "Cannot find induction principle for " + ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in Evd.fresh_global (pf_env gl) (project gl) princ_ref in let princt = Retyping.get_type_of (pf_env gl) sigma princ in - Proofview.Unsafe.tclEVARS sigma <*> - Proofview.tclUNIT (princ, Tactypes.NoBindings, princt, args) + Proofview.Unsafe.tclEVARS sigma + <*> Proofview.tclUNIT (princ, Tactypes.NoBindings, princt, args) | _ -> - CErrors.user_err (str "functional induction must be used with a function" ) - end - | Some ((princ,binding)) -> - let sigma, princt = pf_type_of gl princ in - Proofview.Unsafe.tclEVARS sigma <*> - Proofview.tclUNIT (princ, binding, princt, args) - ) >>= fun (princ, bindings, princ_type, args) -> + CErrors.user_err + (str "functional induction must be used with a function") ) + | Some (princ, binding) -> + let sigma, princt = pf_type_of gl princ in + Proofview.Unsafe.tclEVARS sigma + <*> Proofview.tclUNIT (princ, binding, princt, args)) + >>= fun (princ, bindings, princ_type, args) -> Proofview.Goal.enter (fun gl -> - let sigma = project gl in - let princ_infos = compute_elim_sig (project gl) princ_type in - let args_as_induction_constr = - let c_list = - if princ_infos.Tactics.farg_in_concl - then [c] else [] - in - if List.length args + List.length c_list = 0 - then user_err Pp.(str "Cannot recognize a valid functional scheme" ); - let encoded_pat_as_patlist = - List.make (List.length args + List.length c_list - 1) None @ [pat] - in - List.map2 - (fun c pat -> - ((None, ElimOnConstr (fun env sigma -> (sigma,(c,Tactypes.NoBindings)))), - (None,pat), None)) - (args@c_list) - encoded_pat_as_patlist - in - let princ' = Some (princ,bindings) in - let princ_vars = - List.fold_right - (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) - args - Id.Set.empty - in - let old_idl = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in - let old_idl = Id.Set.diff old_idl princ_vars in - let subst_and_reduce gl = - if with_clean - then - let idl = List.filter (fun id -> not (Id.Set.mem id old_idl))(pf_ids_of_hyps gl) in - let flag = Genredexpr.Cbv { Redops.all_flags with Genredexpr.rDelta = false } in + let sigma = project gl in + let princ_infos = compute_elim_sig (project gl) princ_type in + let args_as_induction_constr = + let c_list = if princ_infos.Tactics.farg_in_concl then [c] else [] in + if List.length args + List.length c_list = 0 then + user_err Pp.(str "Cannot recognize a valid functional scheme"); + let encoded_pat_as_patlist = + List.make (List.length args + List.length c_list - 1) None @ [pat] + in + List.map2 + (fun c pat -> + ( ( None + , ElimOnConstr + (fun env sigma -> (sigma, (c, Tactypes.NoBindings))) ) + , (None, pat) + , None )) + (args @ c_list) encoded_pat_as_patlist + in + let princ' = Some (princ, bindings) in + let princ_vars = + List.fold_right + (fun a acc -> + try Id.Set.add (destVar sigma a) acc with DestKO -> acc) + args Id.Set.empty + in + let old_idl = + List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty + in + let old_idl = Id.Set.diff old_idl princ_vars in + let subst_and_reduce gl = + if with_clean then + let idl = + List.filter + (fun id -> not (Id.Set.mem id old_idl)) + (pf_ids_of_hyps gl) + in + let flag = + Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false} + in + tclTHEN + (tclMAP + (fun id -> + tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) + idl) + (reduce flag Locusops.allHypsAndConcl) + else tclIDTAC + in tclTHEN - (tclMAP (fun id -> tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl) - (reduce flag Locusops.allHypsAndConcl) - else tclIDTAC - in - tclTHEN - (choose_dest_or_ind - princ_infos - (args_as_induction_constr,princ')) - (Proofview.Goal.enter subst_and_reduce)) + (choose_dest_or_ind princ_infos (args_as_induction_constr, princ')) + (Proofview.Goal.enter subst_and_reduce)) diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 4f3d4a1587..daabc4e7c6 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -8,8 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val functional_induction - : bool +val functional_induction : + bool -> EConstr.constr -> (EConstr.constr * EConstr.constr Tactypes.bindings) option -> Ltac_plugin.Tacexpr.or_and_intro_pattern option diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index ec23355ce1..e83fe56cc9 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -4,112 +4,96 @@ open Constr open Libnames open Refiner -let mk_prefix pre id = Id.of_string (pre^(Id.to_string id)) +let mk_prefix pre id = Id.of_string (pre ^ Id.to_string id) let mk_rel_id = mk_prefix "R_" let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" let mk_equation_id id = Nameops.add_suffix id "_equation" -let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) +let fresh_id avoid s = + Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) let fresh_name avoid s = Name (fresh_id avoid s) -let get_name avoid ?(default="H") = function +let get_name avoid ?(default = "H") = function | Anonymous -> fresh_name avoid default | Name n -> Name n -let array_get_start a = - Array.init - (Array.length a - 1) - (fun i -> a.(i)) - +let array_get_start a = Array.init (Array.length a - 1) (fun i -> a.(i)) let locate qid = Nametab.locate qid let locate_ind ref = - match locate ref with - | GlobRef.IndRef x -> x - | _ -> raise Not_found + match locate ref with GlobRef.IndRef x -> x | _ -> raise Not_found let locate_constant ref = - match locate ref with - | GlobRef.ConstRef x -> x - | _ -> raise Not_found - - -let locate_with_msg msg f x = - try f x - with - | Not_found -> - CErrors.user_err msg + match locate ref with GlobRef.ConstRef x -> x | _ -> raise Not_found +let locate_with_msg msg f x = try f x with Not_found -> CErrors.user_err msg let filter_map filter f = let rec it = function | [] -> [] - | e::l -> - if filter e - then - (f e) :: it l - else it l + | e :: l -> if filter e then f e :: it l else it l in it - -let chop_rlambda_n = +let chop_rlambda_n = let rec chop_lambda_n acc n rt = - if n == 0 - then List.rev acc,rt - else - match DAst.get rt with - | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b - | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b - | _ -> - CErrors.user_err ~hdr:"chop_rlambda_n" (str "chop_rlambda_n: Not enough Lambdas") + if n == 0 then (List.rev acc, rt) + else + match DAst.get rt with + | Glob_term.GLambda (name, k, t, b) -> + chop_lambda_n ((name, t, None) :: acc) (n - 1) b + | Glob_term.GLetIn (name, v, t, b) -> + chop_lambda_n ((name, v, t) :: acc) (n - 1) b + | _ -> + CErrors.user_err ~hdr:"chop_rlambda_n" + (str "chop_rlambda_n: Not enough Lambdas") in chop_lambda_n [] -let chop_rprod_n = +let chop_rprod_n = let rec chop_prod_n acc n rt = - if n == 0 - then List.rev acc,rt - else - match DAst.get rt with - | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> - CErrors.user_err ~hdr:"chop_rprod_n" (str "chop_rprod_n: Not enough products") + if n == 0 then (List.rev acc, rt) + else + match DAst.get rt with + | Glob_term.GProd (name, k, t, b) -> + chop_prod_n ((name, t) :: acc) (n - 1) b + | _ -> + CErrors.user_err ~hdr:"chop_rprod_n" + (str "chop_rprod_n: Not enough products") in chop_prod_n [] - - let list_union_eq eq_fun l1 l2 = let rec urec = function | [] -> l2 - | a::l -> if List.exists (eq_fun a) l2 then urec l else a::urec l + | a :: l -> if List.exists (eq_fun a) l2 then urec l else a :: urec l in urec l1 -let list_add_set_eq eq_fun x l = - if List.exists (eq_fun x) l then l else x::l - -let coq_constant s = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s;; +let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x :: l +let coq_constant s = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in Nametab.locate (make_qualid dp (Id.of_string s)) -let eq = lazy(EConstr.of_constr (coq_constant "core.eq.type")) -let refl_equal = lazy(EConstr.of_constr (coq_constant "core.eq.refl")) +let eq = lazy (EConstr.of_constr (coq_constant "core.eq.type")) +let refl_equal = lazy (EConstr.of_constr (coq_constant "core.eq.refl")) let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () - and old_strict_implicit_args = Impargs.is_strict_implicit_args () + and old_strict_implicit_args = Impargs.is_strict_implicit_args () and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in let old_printuniverses = !Constrextern.print_universes in - let old_printallowmatchdefaultclause = Detyping.print_allow_match_default_clause () in + let old_printallowmatchdefaultclause = + Detyping.print_allow_match_default_clause () + in Constrextern.print_universes := true; - Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name false; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + false; Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; @@ -122,47 +106,41 @@ let with_full_print f a = Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Constrextern.print_universes := old_printuniverses; - Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name old_printallowmatchdefaultclause; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + old_printallowmatchdefaultclause; Dumpglob.continue (); res - with - | reraise -> - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Flags.raw_print := old_rawprint; - Constrextern.print_universes := old_printuniverses; - Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name old_printallowmatchdefaultclause; - Dumpglob.continue (); - raise reraise - - - - - + with reraise -> + Impargs.make_implicit_args old_implicit_args; + Impargs.make_strict_implicit_args old_strict_implicit_args; + Impargs.make_contextual_implicit_args old_contextual_implicit_args; + Flags.raw_print := old_rawprint; + Constrextern.print_universes := old_printuniverses; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + old_printallowmatchdefaultclause; + Dumpglob.continue (); + raise reraise (**********************) type function_info = - { - function_constant : Constant.t; - graph_ind : inductive; - equation_lemma : Constant.t option; - correctness_lemma : Constant.t option; - completeness_lemma : Constant.t option; - rect_lemma : Constant.t option; - rec_lemma : Constant.t option; - prop_lemma : Constant.t option; - sprop_lemma : Constant.t option; - is_general : bool; (* Has this function been defined using general recursive definition *) - } - + { function_constant : Constant.t + ; graph_ind : inductive + ; equation_lemma : Constant.t option + ; correctness_lemma : Constant.t option + ; completeness_lemma : Constant.t option + ; rect_lemma : Constant.t option + ; rec_lemma : Constant.t option + ; prop_lemma : Constant.t option + ; sprop_lemma : Constant.t option + ; is_general : bool + (* Has this function been defined using general recursive definition *) + } (* type function_db = function_info list *) (* let function_table = ref ([] : function_db) *) - let from_function = Summary.ref Cmap_env.empty ~name:"functions_db_fn" let from_graph = Summary.ref Indmap.empty ~name:"functions_db_gr" @@ -187,91 +165,105 @@ let cache_Function (_,(finfos)) = then function_table := new_tbl *) -let cache_Function (_,finfos) = +let cache_Function (_, finfos) = from_function := Cmap_env.add finfos.function_constant finfos !from_function; from_graph := Indmap.add finfos.graph_ind finfos !from_graph - -let subst_Function (subst,finfos) = +let subst_Function (subst, finfos) = let do_subst_con c = Mod_subst.subst_constant subst c - and do_subst_ind i = Mod_subst.subst_ind subst i - in + and do_subst_ind i = Mod_subst.subst_ind subst i in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in let equation_lemma' = Option.Smart.map do_subst_con finfos.equation_lemma in - let correctness_lemma' = Option.Smart.map do_subst_con finfos.correctness_lemma in - let completeness_lemma' = Option.Smart.map do_subst_con finfos.completeness_lemma in + let correctness_lemma' = + Option.Smart.map do_subst_con finfos.correctness_lemma + in + let completeness_lemma' = + Option.Smart.map do_subst_con finfos.completeness_lemma + in let rect_lemma' = Option.Smart.map do_subst_con finfos.rect_lemma in let rec_lemma' = Option.Smart.map do_subst_con finfos.rec_lemma in - let prop_lemma' = Option.Smart.map do_subst_con finfos.prop_lemma in + let prop_lemma' = Option.Smart.map do_subst_con finfos.prop_lemma in let sprop_lemma' = Option.Smart.map do_subst_con finfos.sprop_lemma in - if function_constant' == finfos.function_constant && - graph_ind' == finfos.graph_ind && - equation_lemma' == finfos.equation_lemma && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma && - sprop_lemma' == finfos.sprop_lemma + if + function_constant' == finfos.function_constant + && graph_ind' == finfos.graph_ind + && equation_lemma' == finfos.equation_lemma + && correctness_lemma' == finfos.correctness_lemma + && completeness_lemma' == finfos.completeness_lemma + && rect_lemma' == finfos.rect_lemma + && rec_lemma' == finfos.rec_lemma + && prop_lemma' == finfos.prop_lemma + && sprop_lemma' == finfos.sprop_lemma then finfos else - { function_constant = function_constant'; - graph_ind = graph_ind'; - equation_lemma = equation_lemma' ; - correctness_lemma = correctness_lemma' ; - completeness_lemma = completeness_lemma' ; - rect_lemma = rect_lemma' ; - rec_lemma = rec_lemma'; - prop_lemma = prop_lemma'; - sprop_lemma = sprop_lemma'; - is_general = finfos.is_general - } - -let discharge_Function (_,finfos) = Some finfos + { function_constant = function_constant' + ; graph_ind = graph_ind' + ; equation_lemma = equation_lemma' + ; correctness_lemma = correctness_lemma' + ; completeness_lemma = completeness_lemma' + ; rect_lemma = rect_lemma' + ; rec_lemma = rec_lemma' + ; prop_lemma = prop_lemma' + ; sprop_lemma = sprop_lemma' + ; is_general = finfos.is_general } + +let discharge_Function (_, finfos) = Some finfos let pr_ocst env sigma c = - Option.fold_right (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) c (mt ()) + Option.fold_right + (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) + c (mt ()) let pr_info env sigma f_info = - str "function_constant := " ++ - Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant)++ fnl () ++ - str "function_constant_type := " ++ - (try - Printer.pr_lconstr_env env sigma - (fst (Typeops.type_of_global_in_context env (GlobRef.ConstRef f_info.function_constant))) - with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ - str "equation_lemma := " ++ pr_ocst env sigma f_info.equation_lemma ++ fnl () ++ - str "completeness_lemma :=" ++ pr_ocst env sigma f_info.completeness_lemma ++ fnl () ++ - str "correctness_lemma := " ++ pr_ocst env sigma f_info.correctness_lemma ++ fnl () ++ - str "rect_lemma := " ++ pr_ocst env sigma f_info.rect_lemma ++ fnl () ++ - str "rec_lemma := " ++ pr_ocst env sigma f_info.rec_lemma ++ fnl () ++ - str "prop_lemma := " ++ pr_ocst env sigma f_info.prop_lemma ++ fnl () ++ - str "graph_ind := " ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) ++ fnl () + str "function_constant := " + ++ Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant) + ++ fnl () + ++ str "function_constant_type := " + ++ ( try + Printer.pr_lconstr_env env sigma + (fst + (Typeops.type_of_global_in_context env + (GlobRef.ConstRef f_info.function_constant))) + with e when CErrors.noncritical e -> mt () ) + ++ fnl () ++ str "equation_lemma := " + ++ pr_ocst env sigma f_info.equation_lemma + ++ fnl () + ++ str "completeness_lemma :=" + ++ pr_ocst env sigma f_info.completeness_lemma + ++ fnl () + ++ str "correctness_lemma := " + ++ pr_ocst env sigma f_info.correctness_lemma + ++ fnl () ++ str "rect_lemma := " + ++ pr_ocst env sigma f_info.rect_lemma + ++ fnl () ++ str "rec_lemma := " + ++ pr_ocst env sigma f_info.rec_lemma + ++ fnl () ++ str "prop_lemma := " + ++ pr_ocst env sigma f_info.prop_lemma + ++ fnl () ++ str "graph_ind := " + ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) + ++ fnl () let pr_table env sigma tb = - let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in + let l = Cmap_env.fold (fun k v acc -> v :: acc) tb [] in Pp.prlist_with_sep fnl (pr_info env sigma) l let in_Function : function_info -> Libobject.obj = let open Libobject in - declare_object @@ superglobal_object "FUNCTIONS_DB" - ~cache:cache_Function - ~subst:(Some subst_Function) - ~discharge:discharge_Function - + declare_object + @@ superglobal_object "FUNCTIONS_DB" ~cache:cache_Function + ~subst:(Some subst_Function) ~discharge:discharge_Function let find_or_none id = - try Some - (match Nametab.locate (qualid_of_ident id) with GlobRef.ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant.") - ) + try + Some + ( match Nametab.locate (qualid_of_ident id) with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) with Not_found -> None -let find_Function_infos f = - Cmap_env.find_opt f !from_function - -let find_Function_of_graph ind = - Indmap.find_opt ind !from_graph +let find_Function_infos f = Cmap_env.find_opt f !from_function +let find_Function_of_graph ind = Indmap.find_opt ind !from_graph let update_Function finfo = (* Pp.msgnl (pr_info finfo); *) @@ -287,113 +279,101 @@ let add_Function is_general f = and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") and sprop_lemma = find_or_none (Nameops.add_suffix f_id "_sind") and graph_ind = - match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) - with | GlobRef.IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive.") + match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) with + | GlobRef.IndRef ind -> ind + | _ -> CErrors.anomaly (Pp.str "Not an inductive.") in let finfos = - { function_constant = f; - equation_lemma = equation_lemma; - completeness_lemma = completeness_lemma; - correctness_lemma = correctness_lemma; - rect_lemma = rect_lemma; - rec_lemma = rec_lemma; - prop_lemma = prop_lemma; - sprop_lemma = sprop_lemma; - graph_ind = graph_ind; - is_general = is_general - - } + { function_constant = f + ; equation_lemma + ; completeness_lemma + ; correctness_lemma + ; rect_lemma + ; rec_lemma + ; prop_lemma + ; sprop_lemma + ; graph_ind + ; is_general } in update_Function finfos let pr_table env sigma = pr_table env sigma !from_function + (*********************************) (* Debugging *) let do_rewrite_dependent = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Functional";"Induction";"Rewrite";"Dependent"] + Goptions.declare_bool_option_and_ref ~depr:false + ~key:["Functional"; "Induction"; "Rewrite"; "Dependent"] ~value:true let do_observe = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Function_debug"] + Goptions.declare_bool_option_and_ref ~depr:false ~key:["Function_debug"] ~value:false -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () - +let observe strm = if do_observe () then Feedback.msg_debug strm else () let debug_queue = Stack.create () let print_debug_queue b e = - if not (Stack.is_empty debug_queue) - then - let lmsg,goal = Stack.pop debug_queue in - (if b then - Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) - else - Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)) - (* print_debug_queue false e; *) - ) + if not (Stack.is_empty debug_queue) then + let lmsg, goal = Stack.pop debug_queue in + if b then + Feedback.msg_debug + (hov 1 + ( lmsg + ++ (str " raised exception " ++ CErrors.print e) + ++ str " on goal" ++ fnl () ++ goal )) + else + Feedback.msg_debug + (hov 1 (str " from " ++ lmsg ++ str " on goal" ++ fnl () ++ goal)) + +(* print_debug_queue false e; *) let do_observe_tac s tac g = let goal = Printer.pr_goal g in let s = s (pf_env g) (project g) in - let lmsg = (str "observation : ") ++ s in - Stack.push (lmsg,goal) debug_queue; + let lmsg = str "observation : " ++ s in + Stack.push (lmsg, goal) debug_queue; try let v = tac g in - ignore(Stack.pop debug_queue); + ignore (Stack.pop debug_queue); v with reraise -> let reraise = Exninfo.capture reraise in - if not (Stack.is_empty debug_queue) - then print_debug_queue true (fst reraise); + if not (Stack.is_empty debug_queue) then + print_debug_queue true (fst reraise); Exninfo.iraise reraise let observe_tac s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g + if do_observe () then do_observe_tac s tac g else tac g module New = struct - -let do_observe_tac ~header s tac = - let open Proofview.Notations in - let open Proofview in - Goal.enter begin fun gl -> - let goal = Printer.pr_goal (Goal.print gl) in - let env, sigma = Goal.env gl, Goal.sigma gl in - let s = s env sigma in - let lmsg = seq [header; str " : " ++ s] in - tclLIFT (NonLogical.make (fun () -> - Feedback.msg_debug (s++fnl()))) >>= fun () -> - tclOR ( - Stack.push (lmsg, goal) debug_queue; - tac >>= fun v -> - ignore(Stack.pop debug_queue); - Proofview.tclUNIT v) - (fun (exn, info) -> - if not (Stack.is_empty debug_queue) - then print_debug_queue true exn; - tclZERO ~info exn) - end - -let observe_tac ~header s tac = - if do_observe () - then do_observe_tac ~header s tac - else tac - + let do_observe_tac ~header s tac = + let open Proofview.Notations in + let open Proofview in + Goal.enter (fun gl -> + let goal = Printer.pr_goal (Goal.print gl) in + let env, sigma = (Goal.env gl, Goal.sigma gl) in + let s = s env sigma in + let lmsg = seq [header; str " : " ++ s] in + tclLIFT (NonLogical.make (fun () -> Feedback.msg_debug (s ++ fnl ()))) + >>= fun () -> + tclOR + ( Stack.push (lmsg, goal) debug_queue; + tac + >>= fun v -> + ignore (Stack.pop debug_queue); + Proofview.tclUNIT v ) + (fun (exn, info) -> + if not (Stack.is_empty debug_queue) then print_debug_queue true exn; + tclZERO ~info exn)) + + let observe_tac ~header s tac = + if do_observe () then do_observe_tac ~header s tac else tac end let is_strict_tcc = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Function_raw_tcc"] + Goptions.declare_bool_option_and_ref ~depr:false ~key:["Function_raw_tcc"] ~value:false exception Building_graph of exn @@ -403,17 +383,15 @@ exception ToShow of exn let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - EConstr.of_constr @@ - UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref "core.JMeq.type" + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.JMeq.type" with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - EConstr.of_constr @@ - UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref "core.JMeq.refl" + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.JMeq.refl" with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = @@ -421,49 +399,67 @@ let h_intros l = let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" -let well_founded = function () -> EConstr.of_constr (coq_constant "core.wf.well_founded") + +let well_founded = function + | () -> EConstr.of_constr (coq_constant "core.wf.well_founded") + let acc_rel = function () -> EConstr.of_constr (coq_constant "core.wf.acc") -let acc_inv_id = function () -> EConstr.of_constr (coq_constant "core.wf.acc_inv") -let well_founded_ltof () = EConstr.of_constr (coq_constant "num.nat.well_founded_ltof") +let acc_inv_id = function + | () -> EConstr.of_constr (coq_constant "core.wf.acc_inv") -let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") +let well_founded_ltof () = + EConstr.of_constr (coq_constant "num.nat.well_founded_ltof") + +let ltof_ref = function () -> find_reference ["Coq"; "Arith"; "Wf_nat"] "ltof" let make_eq () = - try EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) + try + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) with _ -> assert false -let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) +let evaluable_of_global_reference r = + (* Tacred.evaluable_of_global_reference (Global.env ()) *) match r with - GlobRef.ConstRef sp -> EvalConstRef sp - | GlobRef.VarRef id -> EvalVarRef id - | _ -> assert false;; + | GlobRef.ConstRef sp -> EvalConstRef sp + | GlobRef.VarRef id -> EvalVarRef id + | _ -> assert false -let list_rewrite (rev:bool) (eqs: (EConstr.constr*bool) list) = +let list_rewrite (rev : bool) (eqs : (EConstr.constr * bool) list) = tclREPEAT (List.fold_right - (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i) - (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; + (fun (eq, b) i -> + tclORELSE + (Proofview.V82.of_tactic + ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) + i) + (if rev then List.rev eqs else eqs) + (tclFAIL 0 (mt ()))) let decompose_lam_n sigma n = - if n < 0 then CErrors.user_err Pp.(str "decompose_lam_n: integer parameter must be positive"); + if n < 0 then + CErrors.user_err + Pp.(str "decompose_lam_n: integer parameter must be positive"); let rec lamdec_rec l n c = - if Int.equal n 0 then l,c - else match EConstr.kind sigma c with - | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c - | Cast (c,_,_) -> lamdec_rec l n c - | _ -> CErrors.user_err Pp.(str "decompose_lam_n: not enough abstractions") + if Int.equal n 0 then (l, c) + else + match EConstr.kind sigma c with + | Lambda (x, t, c) -> lamdec_rec ((x, t) :: l) (n - 1) c + | Cast (c, _, _) -> lamdec_rec l n c + | _ -> + CErrors.user_err Pp.(str "decompose_lam_n: not enough abstractions") in lamdec_rec [] n let lamn n env b = let open EConstr in let rec lamrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) + | 0, env, b -> b + | n, (v, t) :: l, b -> lamrec (n - 1, l, mkLambda (v, t, b)) | _ -> assert false in - lamrec (n,env,b) + lamrec (n, env, b) (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) let compose_lam l b = lamn (List.length l) l b @@ -472,19 +468,16 @@ let compose_lam l b = lamn (List.length l) l b let prodn n env b = let open EConstr in let rec prodrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) + | 0, env, b -> b + | n, (v, t) :: l, b -> prodrec (n - 1, l, mkProd (v, t, b)) | _ -> assert false in - prodrec (n,env,b) + prodrec (n, env, b) (* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) let compose_prod l b = prodn (List.length l) l b -type tcc_lemma_value = - | Undefined - | Value of constr - | Not_needed +type tcc_lemma_value = Undefined | Value of constr | Not_needed (* We only "purify" on exceptions. XXX: What is this doing here? *) let funind_purify f x = @@ -497,4 +490,4 @@ let funind_purify f x = let tac_type_of g c = let sigma, t = Tacmach.pf_type_of g c in - {g with Evd.sigma}, t + ({g with Evd.sigma}, t) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index bd8b34088b..396db55458 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -8,30 +8,27 @@ val mk_rel_id : Id.t -> Id.t val mk_correct_id : Id.t -> Id.t val mk_complete_id : Id.t -> Id.t val mk_equation_id : Id.t -> Id.t - val fresh_id : Id.t list -> string -> Id.t val fresh_name : Id.t list -> string -> Name.t val get_name : Id.t list -> ?default:string -> Name.t -> Name.t - val array_get_start : 'a array -> 'a array - val locate_ind : Libnames.qualid -> inductive val locate_constant : Libnames.qualid -> Constant.t -val locate_with_msg : - Pp.t -> (Libnames.qualid -> 'a) -> - Libnames.qualid -> 'a - +val locate_with_msg : Pp.t -> (Libnames.qualid -> 'a) -> Libnames.qualid -> 'a val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list -val list_union_eq : - ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list -val list_add_set_eq : - ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list +val list_union_eq : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list +val list_add_set_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list -val chop_rlambda_n : int -> Glob_term.glob_constr -> - (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list * Glob_term.glob_constr +val chop_rlambda_n : + int + -> Glob_term.glob_constr + -> (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list + * Glob_term.glob_constr -val chop_rprod_n : int -> Glob_term.glob_constr -> - (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr +val chop_rprod_n : + int + -> Glob_term.glob_constr + -> (Name.t * Glob_term.glob_constr) list * Glob_term.glob_constr val eq : EConstr.constr Lazy.t val refl_equal : EConstr.constr Lazy.t @@ -45,44 +42,41 @@ val make_eq : unit -> EConstr.constr *) val with_full_print : ('a -> 'b) -> 'a -> 'b - (*****************) type function_info = - { - function_constant : Constant.t; - graph_ind : inductive; - equation_lemma : Constant.t option; - correctness_lemma : Constant.t option; - completeness_lemma : Constant.t option; - rect_lemma : Constant.t option; - rec_lemma : Constant.t option; - prop_lemma : Constant.t option; - sprop_lemma : Constant.t option; - is_general : bool; - } + { function_constant : Constant.t + ; graph_ind : inductive + ; equation_lemma : Constant.t option + ; correctness_lemma : Constant.t option + ; completeness_lemma : Constant.t option + ; rect_lemma : Constant.t option + ; rec_lemma : Constant.t option + ; prop_lemma : Constant.t option + ; sprop_lemma : Constant.t option + ; is_general : bool } val find_Function_infos : Constant.t -> function_info option val find_Function_of_graph : inductive -> function_info option + (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> Constant.t -> unit val update_Function : function_info -> unit (** debugging *) val pr_info : Environ.env -> Evd.evar_map -> function_info -> Pp.t + val pr_table : Environ.env -> Evd.evar_map -> Pp.t -val observe_tac - : (Environ.env -> Evd.evar_map -> Pp.t) - -> Tacmach.tactic -> Tacmach.tactic +val observe_tac : + (Environ.env -> Evd.evar_map -> Pp.t) -> Tacmach.tactic -> Tacmach.tactic module New : sig - - val observe_tac - : header:Pp.t + val observe_tac : + header:Pp.t -> (Environ.env -> Evd.evar_map -> Pp.t) - -> unit Proofview.tactic -> unit Proofview.tactic - + -> unit Proofview.tactic + -> unit Proofview.tactic end (* val function_debug : bool ref *) @@ -96,28 +90,35 @@ exception Defining_principle of exn exception ToShow of exn val is_strict_tcc : unit -> bool - -val h_intros: Names.Id.t list -> Tacmach.tactic -val h_id : Names.Id.t -val hrec_id : Names.Id.t -val acc_inv_id : EConstr.constr Util.delayed +val h_intros : Names.Id.t list -> Tacmach.tactic +val h_id : Names.Id.t +val hrec_id : Names.Id.t +val acc_inv_id : EConstr.constr Util.delayed val ltof_ref : GlobRef.t Util.delayed val well_founded_ltof : EConstr.constr Util.delayed val acc_rel : EConstr.constr Util.delayed val well_founded : EConstr.constr Util.delayed -val evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_reference -val list_rewrite : bool -> (EConstr.constr*bool) list -> Tacmach.tactic -val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> - (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t -val compose_lam : (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t -val compose_prod : (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t +val evaluable_of_global_reference : + GlobRef.t -> Names.evaluable_global_reference + +val list_rewrite : bool -> (EConstr.constr * bool) list -> Tacmach.tactic + +val decompose_lam_n : + Evd.evar_map + -> int + -> EConstr.t + -> (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t + +val compose_lam : + (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t + +val compose_prod : + (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t -type tcc_lemma_value = - | Undefined - | Value of Constr.t - | Not_needed +type tcc_lemma_value = Undefined | Value of Constr.t | Not_needed -val funind_purify : ('a -> 'b) -> ('a -> 'b) +val funind_purify : ('a -> 'b) -> 'a -> 'b -val tac_type_of : Goal.goal Evd.sigma -> EConstr.constr -> Goal.goal Evd.sigma * EConstr.types +val tac_type_of : + Goal.goal Evd.sigma -> EConstr.constr -> Goal.goal Evd.sigma * EConstr.types diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 44d2cb4a3d..5d631aac84 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -15,7 +15,6 @@ open EConstr open Tacmach.New open Tactics open Tacticals.New - open Indfun_common (***********************************************) @@ -26,36 +25,40 @@ open Indfun_common if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) -let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> - let sigma = project gl in - let typ = pf_get_hyp_typ hid gl in - match EConstr.kind sigma typ with - | App(i,args) when isInd sigma i -> - let ((kn',num) as ind'),u = destInd sigma i in - if MutInd.equal kn kn' - then (* We have generated a graph hypothesis so that we must change it if we can *) - let info = match find_Function_of_graph ind' with - | Some info -> info - | None -> - (* The graphs are mutually recursive but we cannot find one of them !*) - CErrors.anomaly (Pp.str "Cannot retrieve infos about a mutual block.") - in - (* if we can find a completeness lemma for this function - then we can come back to the functional form. If not, we do nothing - *) - match info.completeness_lemma with - | None -> tclIDTAC - | Some f_complete -> - let f_args,res = Array.chop (Array.length args - 1) args in - tclTHENLIST - [ generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])] - ; clear [hid] - ; Simple.intro hid - ; post_tac hid - ] - else tclIDTAC - | _ -> tclIDTAC - ) +let revert_graph kn post_tac hid = + Proofview.Goal.enter (fun gl -> + let sigma = project gl in + let typ = pf_get_hyp_typ hid gl in + match EConstr.kind sigma typ with + | App (i, args) when isInd sigma i -> + let ((kn', num) as ind'), u = destInd sigma i in + if MutInd.equal kn kn' then + (* We have generated a graph hypothesis so that we must change it if we can *) + let info = + match find_Function_of_graph ind' with + | Some info -> info + | None -> + (* The graphs are mutually recursive but we cannot find one of them !*) + CErrors.anomaly + (Pp.str "Cannot retrieve infos about a mutual block.") + in + (* if we can find a completeness lemma for this function + then we can come back to the functional form. If not, we do nothing + *) + match info.completeness_lemma with + | None -> tclIDTAC + | Some f_complete -> + let f_args, res = Array.chop (Array.length args - 1) args in + tclTHENLIST + [ generalize + [ applist + ( mkConst f_complete + , Array.to_list f_args @ [res.(0); mkVar hid] ) ] + ; clear [hid] + ; Simple.intro hid + ; post_tac hid ] + else tclIDTAC + | _ -> tclIDTAC) (* [functional_inversion hid fconst f_correct ] is the functional version of [inversion] @@ -74,52 +77,55 @@ let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> \end{enumerate} *) -let functional_inversion kn hid fconst f_correct = Proofview.Goal.enter (fun gl -> - let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in - let sigma = project gl in - let type_of_h = pf_get_hyp_typ hid gl in - match EConstr.kind sigma type_of_h with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - let pre_tac,f_args,res = - match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with - | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> - ((fun hid -> intros_symmetry (Locusops.onHyp hid))),f_args,args.(2) - |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> - ((fun hid -> tclIDTAC),f_args,args.(1)) - | _ -> (fun hid -> tclFAIL 1 Pp.(mt ())),[||],args.(2) - in - tclTHENLIST - [ pre_tac hid - ; generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])] - ; clear [hid] - ; Simple.intro hid - ; Inv.inv Inv.FullInversion None (Tactypes.NamedHyp hid) - ; Proofview.Goal.enter (fun gl -> - let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps gl) in - tclMAP (revert_graph kn pre_tac) (hid::new_ids) - ) - ] - | _ -> tclFAIL 1 Pp.(mt ()) - ) +let functional_inversion kn hid fconst f_correct = + Proofview.Goal.enter (fun gl -> + let old_ids = + List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty + in + let sigma = project gl in + let type_of_h = pf_get_hyp_typ hid gl in + match EConstr.kind sigma type_of_h with + | App (eq, args) when EConstr.eq_constr sigma eq (make_eq ()) -> + let pre_tac, f_args, res = + match (EConstr.kind sigma args.(1), EConstr.kind sigma args.(2)) with + | App (f, f_args), _ when EConstr.eq_constr sigma f fconst -> + ((fun hid -> intros_symmetry (Locusops.onHyp hid)), f_args, args.(2)) + | _, App (f, f_args) when EConstr.eq_constr sigma f fconst -> + ((fun hid -> tclIDTAC), f_args, args.(1)) + | _ -> ((fun hid -> tclFAIL 1 Pp.(mt ())), [||], args.(2)) + in + tclTHENLIST + [ pre_tac hid + ; generalize + [applist (f_correct, Array.to_list f_args @ [res; mkVar hid])] + ; clear [hid] + ; Simple.intro hid + ; Inv.inv Inv.FullInversion None (Tactypes.NamedHyp hid) + ; Proofview.Goal.enter (fun gl -> + let new_ids = + List.filter + (fun id -> not (Id.Set.mem id old_ids)) + (pf_ids_of_hyps gl) + in + tclMAP (revert_graph kn pre_tac) (hid :: new_ids)) ] + | _ -> tclFAIL 1 Pp.(mt ())) -let invfun qhyp f = +let invfun qhyp f = let f = match f with | GlobRef.ConstRef f -> f - | _ -> - CErrors.user_err Pp.(str "Not a function") + | _ -> CErrors.user_err Pp.(str "Not a function") in match find_Function_infos f with - | None -> - CErrors.user_err (Pp.str "No graph found") - | Some finfos -> + | None -> CErrors.user_err (Pp.str "No graph found") + | Some finfos -> ( match finfos.correctness_lemma with - | None -> - CErrors.user_err (Pp.str "Cannot use equivalence with graph!") + | None -> CErrors.user_err (Pp.str "Cannot use equivalence with graph!") | Some f_correct -> - let f_correct = mkConst f_correct - and kn = fst finfos.graph_ind in - Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp + let f_correct = mkConst f_correct and kn = fst finfos.graph_ind in + Tactics.try_intros_until + (fun hid -> functional_inversion kn hid (mkConst f) f_correct) + qhyp ) let invfun qhyp f = let exception NoFunction in @@ -128,41 +134,55 @@ let invfun qhyp f = | None -> let tac_action hid gl = let sigma = project gl in - let hyp_typ = pf_get_hyp_typ hid gl in + let hyp_typ = pf_get_hyp_typ hid gl in match EConstr.kind sigma hyp_typ with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - begin - let f1,_ = decompose_app sigma args.(1) in - try - if not (isConst sigma f1) then raise NoFunction; - let finfos = Option.get (find_Function_infos (fst (destConst sigma f1))) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f1 f_correct - with - | NoFunction | Option.IsNone -> - let f2,_ = decompose_app sigma args.(2) in - if isConst sigma f2 then - match find_Function_infos (fst (destConst sigma f2)) with + | App (eq, args) when EConstr.eq_constr sigma eq (make_eq ()) -> ( + let f1, _ = decompose_app sigma args.(1) in + try + if not (isConst sigma f1) then raise NoFunction; + let finfos = + Option.get (find_Function_infos (fst (destConst sigma f1))) + in + let f_correct = mkConst (Option.get finfos.correctness_lemma) + and kn = fst finfos.graph_ind in + functional_inversion kn hid f1 f_correct + with NoFunction | Option.IsNone -> + let f2, _ = decompose_app sigma args.(2) in + if isConst sigma f2 then + match find_Function_infos (fst (destConst sigma f2)) with + | None -> + if do_observe () then + CErrors.user_err + (Pp.str "No graph found for any side of equality") + else + CErrors.user_err + Pp.( + str "Cannot find inversion information for hypothesis " + ++ Ppconstr.pr_id hid) + | Some finfos -> ( + match finfos.correctness_lemma with | None -> - if do_observe () - then CErrors.user_err (Pp.str "No graph found for any side of equality") - else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Some finfos -> - match finfos.correctness_lemma with - | None -> - if do_observe () - then CErrors.user_err (Pp.str "Cannot use equivalence with graph for any side of the equality") - else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Some f_correct -> - let f_correct = mkConst f_correct - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f2 f_correct - else (* NoFunction *) - CErrors.user_err Pp.(str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") - end - | _ -> CErrors.user_err Pp.(Ppconstr.pr_id hid ++ str " must be an equality ") + if do_observe () then + CErrors.user_err + (Pp.str + "Cannot use equivalence with graph for any side of the \ + equality") + else + CErrors.user_err + Pp.( + str "Cannot find inversion information for hypothesis " + ++ Ppconstr.pr_id hid) + | Some f_correct -> + let f_correct = mkConst f_correct + and kn = fst finfos.graph_ind in + functional_inversion kn hid f2 f_correct ) + else + (* NoFunction *) + CErrors.user_err + Pp.( + str "Hypothesis " ++ Ppconstr.pr_id hid + ++ str " must contain at least one Function") ) + | _ -> + CErrors.user_err Pp.(Ppconstr.pr_id hid ++ str " must be an equality ") in try_intros_until (tac_action %> Proofview.Goal.enter) qhyp diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli index 41dbe1437c..a117df32df 100644 --- a/plugins/funind/invfun.mli +++ b/plugins/funind/invfun.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val invfun - : Tactypes.quantified_hypothesis +val invfun : + Tactypes.quantified_hypothesis -> Names.GlobRef.t option -> unit Proofview.tactic diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 19a762d33d..ffb9a7e69b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -8,9 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) - module CVars = Vars - open Constr open Context open EConstr @@ -29,7 +27,6 @@ open Tacticals open Tacmach open Tactics open Nametab -open Declare open Tacred open Glob_term open Pretyping @@ -37,58 +34,58 @@ open Termops open Constrintern open Tactypes open Genredexpr - open Equality open Auto open Eauto - open Indfun_common open Context.Rel.Declaration (* Ugly things which should not be here *) -let coq_constant s = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref s +let coq_constant s = + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s let coq_init_constant s = - EConstr.of_constr(UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s) -;; + EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s) let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in locate (make_qualid dp (Id.of_string s)) let declare_fun name kind ?univs value = - let ce = definition_entry ?univs value (*FIXME *) in - GlobRef.ConstRef(declare_constant ~name ~kind (DefinitionEntry ce)) + let ce = Declare.definition_entry ?univs value (*FIXME *) in + GlobRef.ConstRef + (Declare.declare_constant ~name ~kind (Declare.DefinitionEntry ce)) let defined lemma = - Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent ~idopt:None let def_of_const t = - match (Constr.kind t) with - Const sp -> - (try (match constant_opt_value_in (Global.env ()) sp with - | Some c -> c - | _ -> raise Not_found) - with Not_found -> - anomaly (str "Cannot find definition of constant " ++ - (Id.print (Label.to_id (Constant.label (fst sp)))) ++ str ".") - ) - |_ -> assert false + match Constr.kind t with + | Const sp -> ( + try + match constant_opt_value_in (Global.env ()) sp with + | Some c -> c + | _ -> raise Not_found + with Not_found -> + anomaly + ( str "Cannot find definition of constant " + ++ Id.print (Label.to_id (Constant.label (fst sp))) + ++ str "." ) ) + | _ -> assert false let type_of_const sigma t = - match (EConstr.kind sigma t) with - | Const (sp, u) -> - let u = EInstance.kind sigma u in - (* FIXME discarding universe constraints *) - Typeops.type_of_constant_in (Global.env()) (sp, u) - |_ -> assert false + match EConstr.kind sigma t with + | Const (sp, u) -> + let u = EInstance.kind sigma u in + (* FIXME discarding universe constraints *) + Typeops.type_of_constant_in (Global.env ()) (sp, u) + | _ -> assert false let constant sl s = UnivGen.constr_of_monomorphic_global (find_reference sl s) let const_of_ref = function - GlobRef.ConstRef kn -> kn + | GlobRef.ConstRef kn -> kn | _ -> anomaly (Pp.str "ConstRef expected.") (* Generic values *) @@ -96,16 +93,16 @@ let pf_get_new_ids idl g = let ids = pf_ids_of_hyps g in let ids = Id.Set.of_list ids in List.fold_right - (fun id acc -> next_global_ident_away id (Id.Set.union (Id.Set.of_list acc) ids)::acc) - idl - [] + (fun id acc -> + next_global_ident_away id (Id.Set.union (Id.Set.of_list acc) ids) :: acc) + idl [] let next_ident_away_in_goal ids avoid = next_ident_away_in_goal ids (Id.Set.of_list avoid) let compute_renamed_type gls id = - rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty (*no rels*) [] - (pf_get_hyp_typ gls id) + rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty + (*no rels*) [] (pf_get_hyp_typ gls id) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" @@ -115,112 +112,140 @@ let k_id = Id.of_string "k" let v_id = Id.of_string "v" let def_id = Id.of_string "def" let p_id = Id.of_string "p" -let rec_res_id = Id.of_string "rec_res";; -let lt = function () -> (coq_init_constant "num.nat.lt") +let rec_res_id = Id.of_string "rec_res" +let lt = function () -> coq_init_constant "num.nat.lt" let le = function () -> Coqlib.lib_ref "num.nat.le" +let ex = function () -> coq_init_constant "core.ex.type" +let nat = function () -> coq_init_constant "num.nat.type" -let ex = function () -> (coq_init_constant "core.ex.type") -let nat = function () -> (coq_init_constant "num.nat.type") let iter_ref () = try find_reference ["Recdef"] "iter" with Not_found -> user_err Pp.(str "module Recdef not loaded") -let iter_rd = function () -> (constr_of_monomorphic_global (delayed_force iter_ref)) -let eq = function () -> (coq_init_constant "core.eq.type") -let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") -let le_lt_n_Sm = function () -> (coq_constant "num.nat.le_lt_n_Sm") -let le_trans = function () -> (coq_constant "num.nat.le_trans") -let le_lt_trans = function () -> (coq_constant "num.nat.le_lt_trans") -let lt_S_n = function () -> (coq_constant "num.nat.lt_S_n") -let le_n = function () -> (coq_init_constant "num.nat.le_n") -let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") -let coq_O = function () -> (coq_init_constant "num.nat.O") -let coq_S = function () -> (coq_init_constant"num.nat.S") -let lt_n_O = function () -> (coq_constant "num.nat.nlt_0_r") -let max_ref = function () -> (find_reference ["Recdef"] "max") -let max_constr = function () -> EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) - -let f_S t = mkApp(delayed_force coq_S, [|t|]);; + +let iter_rd = function + | () -> constr_of_monomorphic_global (delayed_force iter_ref) + +let eq = function () -> coq_init_constant "core.eq.type" +let le_lt_SS = function () -> constant ["Recdef"] "le_lt_SS" +let le_lt_n_Sm = function () -> coq_constant "num.nat.le_lt_n_Sm" +let le_trans = function () -> coq_constant "num.nat.le_trans" +let le_lt_trans = function () -> coq_constant "num.nat.le_lt_trans" +let lt_S_n = function () -> coq_constant "num.nat.lt_S_n" +let le_n = function () -> coq_init_constant "num.nat.le_n" + +let coq_sig_ref = function + | () -> find_reference ["Coq"; "Init"; "Specif"] "sig" + +let coq_O = function () -> coq_init_constant "num.nat.O" +let coq_S = function () -> coq_init_constant "num.nat.S" +let lt_n_O = function () -> coq_constant "num.nat.nlt_0_r" +let max_ref = function () -> find_reference ["Recdef"] "max" + +let max_constr = function + | () -> + EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) + +let f_S t = mkApp (delayed_force coq_S, [|t|]) let rec n_x_id ids n = if Int.equal n 0 then [] - else let x = next_ident_away_in_goal x_id ids in - x::n_x_id (x::ids) (n-1);; - + else + let x = next_ident_away_in_goal x_id ids in + x :: n_x_id (x :: ids) (n - 1) let simpl_iter clause = reduce (Lazy - {rBeta=true;rMatch=true;rFix=true;rCofix=true;rZeta=true;rDelta=false; - rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) + { rBeta = true + ; rMatch = true + ; rFix = true + ; rCofix = true + ; rZeta = true + ; rDelta = false + ; rConst = [EvalConstRef (const_of_ref (delayed_force iter_ref))] }) clause (* Others ugly things ... *) -let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = +let (value_f : Constr.t list -> GlobRef.t -> Constr.t) = let open Term in let open Constr in fun al fterm -> let rev_x_id_l = - ( - List.fold_left - (fun x_id_l _ -> - let x_id = next_ident_away_in_goal x_id x_id_l in - x_id::x_id_l - ) - [] - al - ) + List.fold_left + (fun x_id_l _ -> + let x_id = next_ident_away_in_goal x_id x_id_l in + x_id :: x_id_l) + [] al in - let context = List.map - (fun (x, c) -> LocalAssum (make_annot (Name x) Sorts.Relevant, c)) (List.combine rev_x_id_l (List.rev al)) + let context = + List.map + (fun (x, c) -> LocalAssum (make_annot (Name x) Sorts.Relevant, c)) + (List.combine rev_x_id_l (List.rev al)) in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = - DAst.make @@ - GCases - (RegularStyle,None, - [DAst.make @@ GApp(DAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> DAst.make @@ GVar x_id) rev_x_id_l), - (Anonymous,None)], - [CAst.make ([v_id], [DAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), - [DAst.make @@ PatVar(Name v_id); DAst.make @@ PatVar Anonymous], - Anonymous)], - DAst.make @@ GVar v_id)]) + DAst.make + @@ GCases + ( RegularStyle + , None + , [ ( DAst.make + @@ GApp + ( DAst.make @@ GRef (fterm, None) + , List.rev_map + (fun x_id -> DAst.make @@ GVar x_id) + rev_x_id_l ) + , (Anonymous, None) ) ] + , [ CAst.make + ( [v_id] + , [ DAst.make + @@ PatCstr + ( (destIndRef (delayed_force coq_sig_ref), 1) + , [ DAst.make @@ PatVar (Name v_id) + ; DAst.make @@ PatVar Anonymous ] + , Anonymous ) ] + , DAst.make @@ GVar v_id ) ] ) in - let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in + let body = fst (understand env (Evd.from_env env) glob_body) (*FIXME*) in let body = EConstr.Unsafe.to_constr body in it_mkLambda_or_LetIn body context -let (declare_f : Id.t -> Decls.logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = - fun f_id kind input_type fterm_ref -> - declare_fun f_id kind (value_f input_type fterm_ref);; +let (declare_f : + Id.t -> Decls.logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = + fun f_id kind input_type fterm_ref -> + declare_fun f_id kind (value_f input_type fterm_ref) let observe_tclTHENLIST s tacl = - if do_observe () - then + if do_observe () then let rec aux n = function | [] -> tclIDTAC - | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac - | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) + | [tac] -> + observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac :: tacl -> + observe_tac + (fun env sigma -> s env sigma ++ spc () ++ int n) + (tclTHEN tac (aux (succ n) tacl)) in aux 0 tacl else tclTHENLIST tacl module New = struct - open Tacticals.New - let observe_tac = New.observe_tac ~header:(Pp.mt()) + let observe_tac = New.observe_tac ~header:(Pp.mt ()) let observe_tclTHENLIST s tacl = - if do_observe () - then - let rec aux n = function - | [] -> tclIDTAC - | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac - | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) - in - aux 0 tacl - else tclTHENLIST tacl - + if do_observe () then + let rec aux n = function + | [] -> tclIDTAC + | [tac] -> + observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac :: tacl -> + observe_tac + (fun env sigma -> s env sigma ++ spc () ++ int n) + (tclTHEN tac (aux (succ n) tacl)) + in + aux 0 tacl + else tclTHENLIST tacl end (* Conclusion tactics *) @@ -234,23 +259,25 @@ let tclUSER tac is_mes l = | None -> tclIDTAC | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l) in - New.observe_tclTHENLIST (fun _ _ -> str "tclUSER1") - [ clear_tac; - if is_mes - then - New.observe_tclTHENLIST (fun _ _ -> str "tclUSER2") - [ unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference - (delayed_force Indfun_common.ltof_ref))] - ; tac - ] - else tac - ] + New.observe_tclTHENLIST + (fun _ _ -> str "tclUSER1") + [ clear_tac + ; ( if is_mes then + New.observe_tclTHENLIST + (fun _ _ -> str "tclUSER2") + [ unfold_in_concl + [ ( Locus.AllOccurrences + , evaluable_of_global_reference + (delayed_force Indfun_common.ltof_ref) ) ] + ; tac ] + else tac ) ] let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = - if is_mes - then Tacticals.New.tclCOMPLETE (Simple.apply (delayed_force well_founded_ltof)) - else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) - (tclUSER concl_tac is_mes names_to_suppress) + if is_mes then + Tacticals.New.tclCOMPLETE (Simple.apply (delayed_force well_founded_ltof)) + else + (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) + tclUSER concl_tac is_mes names_to_suppress (* Traveling term. Both definitions of [f_terminate] and [f_equation] use the same generic @@ -263,210 +290,243 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = let check_not_nested env sigma forbidden e = let rec check_not_nested e = match EConstr.kind sigma e with - | Rel _ -> () - | Int _ | Float _ -> () - | Var x -> - if Id.List.mem x forbidden - then user_err ~hdr:"Recdef.check_not_nested" - (str "check_not_nested: failure " ++ Id.print x) - | Meta _ | Evar _ | Sort _ -> () - | Cast(e,_,t) -> check_not_nested e;check_not_nested t - | Prod(_,t,b) -> check_not_nested t;check_not_nested b - | Lambda(_,t,b) -> check_not_nested t;check_not_nested b - | LetIn(_,v,t,b) -> check_not_nested t;check_not_nested b;check_not_nested v - | App(f,l) -> check_not_nested f;Array.iter check_not_nested l - | Proj (p,c) -> check_not_nested c - | Const _ -> () - | Ind _ -> () - | Construct _ -> () - | Case(_,t,e,a) -> - check_not_nested t;check_not_nested e;Array.iter check_not_nested a - | Fix _ -> user_err Pp.(str "check_not_nested : Fix") - | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") + | Rel _ -> () + | Int _ | Float _ -> () + | Var x -> + if Id.List.mem x forbidden then + user_err ~hdr:"Recdef.check_not_nested" + (str "check_not_nested: failure " ++ Id.print x) + | Meta _ | Evar _ | Sort _ -> () + | Cast (e, _, t) -> check_not_nested e; check_not_nested t + | Prod (_, t, b) -> check_not_nested t; check_not_nested b + | Lambda (_, t, b) -> check_not_nested t; check_not_nested b + | LetIn (_, v, t, b) -> + check_not_nested t; check_not_nested b; check_not_nested v + | App (f, l) -> + check_not_nested f; + Array.iter check_not_nested l + | Proj (p, c) -> check_not_nested c + | Const _ -> () + | Ind _ -> () + | Construct _ -> () + | Case (_, t, e, a) -> + check_not_nested t; + check_not_nested e; + Array.iter check_not_nested a + | Fix _ -> user_err Pp.(str "check_not_nested : Fix") + | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") in - try - check_not_nested e - with UserError(_,p) -> - user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) + try check_not_nested e + with UserError (_, p) -> + user_err ~hdr:"_" + (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = - { nb_arg : int; (* function number of arguments *) - concl_tac : unit Proofview.tactic; (* final tactic to finish proofs *) - rec_arg_id : Id.t; (*name of the declared recursive argument *) - is_mes : bool; (* type of recursion *) - ih : Id.t; (* induction hypothesis name *) - f_id : Id.t; (* function name *) - f_constr : constr; (* function term *) - f_terminate : constr; (* termination proof term *) - func : GlobRef.t; (* functional reference *) - info : 'a; - is_main_branch : bool; (* on the main branch or on a matched expression *) - is_final : bool; (* final first order term or not *) - values_and_bounds : (Id.t*Id.t) list; - eqs : Id.t list; - forbidden_ids : Id.t list; - acc_inv : constr lazy_t; - acc_id : Id.t; - args_assoc : ((constr list)*constr) list; - } - - -type ('a,'b) journey_info_tac = - 'a -> (* the arguments of the constructor *) - 'b infos -> (* infos of the caller *) - ('b infos -> tactic) -> (* the continuation tactic of the caller *) - 'b infos -> (* argument of the tactic *) - tactic + { nb_arg : int + ; (* function number of arguments *) + concl_tac : unit Proofview.tactic + ; (* final tactic to finish proofs *) + rec_arg_id : Id.t + ; (*name of the declared recursive argument *) + is_mes : bool + ; (* type of recursion *) + ih : Id.t + ; (* induction hypothesis name *) + f_id : Id.t + ; (* function name *) + f_constr : constr + ; (* function term *) + f_terminate : constr + ; (* termination proof term *) + func : GlobRef.t + ; (* functional reference *) + info : 'a + ; is_main_branch : bool + ; (* on the main branch or on a matched expression *) + is_final : bool + ; (* final first order term or not *) + values_and_bounds : (Id.t * Id.t) list + ; eqs : Id.t list + ; forbidden_ids : Id.t list + ; acc_inv : constr lazy_t + ; acc_id : Id.t + ; args_assoc : (constr list * constr) list } + +type ('a, 'b) journey_info_tac = + 'a + -> (* the arguments of the constructor *) + 'b infos + -> (* infos of the caller *) + ('b infos -> tactic) + -> (* the continuation tactic of the caller *) + 'b infos + -> (* argument of the tactic *) + tactic (* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) type journey_info = - { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac; - lambdA : ((Name.t*types*constr),constr) journey_info_tac; - casE : ((constr infos -> tactic) -> constr infos -> tactic) -> - ((case_info * constr * constr * constr array),constr) journey_info_tac; - otherS : (unit,constr) journey_info_tac; - apP : (constr*(constr list),constr) journey_info_tac; - app_reC : (constr*(constr list),constr) journey_info_tac; - message : string - } - - + { letiN : (Name.t * constr * types * constr, constr) journey_info_tac + ; lambdA : (Name.t * types * constr, constr) journey_info_tac + ; casE : + ((constr infos -> tactic) -> constr infos -> tactic) + -> (case_info * constr * constr * constr array, constr) journey_info_tac + ; otherS : (unit, constr) journey_info_tac + ; apP : (constr * constr list, constr) journey_info_tac + ; app_reC : (constr * constr list, constr) journey_info_tac + ; message : string } let add_vars sigma forbidden e = let rec aux forbidden e = - match EConstr.kind sigma e with - | Var x -> x::forbidden + match EConstr.kind sigma e with + | Var x -> x :: forbidden | _ -> EConstr.fold sigma aux forbidden e in aux forbidden e let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = - fun g -> - let rev_context,b = decompose_lam_n (project g) nb_lam e in - let ids = List.fold_left (fun acc (na,_) -> - let pre_id = - match na.binder_name with - | Name x -> x - | Anonymous -> ano_id - in - pre_id::acc - ) [] rev_context in - let rev_ids = pf_get_new_ids (List.rev ids) g in - let new_b = substl (List.map mkVar rev_ids) b in - observe_tclTHENLIST (fun _ _ -> str "treat_case1") - [ - h_intros (List.rev rev_ids); - Proofview.V82.of_tactic (intro_using teq_id); - onLastHypId (fun heq -> - observe_tclTHENLIST (fun _ _ -> str "treat_case2")[ - Proofview.V82.of_tactic (clear to_intros); - h_intros to_intros; - (fun g' -> - let ty_teq = pf_get_hyp_typ g' heq in - let teq_lhs,teq_rhs = - let _,args = try destApp (project g') ty_teq with DestKO -> assert false in - args.(1),args.(2) - in - let new_b' = Termops.replace_term (project g') teq_lhs teq_rhs new_b in - let new_infos = { - infos with - info = new_b'; - eqs = heq::infos.eqs; - forbidden_ids = - if forbid_new_ids - then add_vars (project g') infos.forbidden_ids new_b' - else infos.forbidden_ids - } in - finalize_tac new_infos g' - ) - ] - ) - ] g - -let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = + fun g -> + let rev_context, b = decompose_lam_n (project g) nb_lam e in + let ids = + List.fold_left + (fun acc (na, _) -> + let pre_id = + match na.binder_name with Name x -> x | Anonymous -> ano_id + in + pre_id :: acc) + [] rev_context + in + let rev_ids = pf_get_new_ids (List.rev ids) g in + let new_b = substl (List.map mkVar rev_ids) b in + observe_tclTHENLIST + (fun _ _ -> str "treat_case1") + [ h_intros (List.rev rev_ids) + ; Proofview.V82.of_tactic (intro_using teq_id) + ; onLastHypId (fun heq -> + observe_tclTHENLIST + (fun _ _ -> str "treat_case2") + [ Proofview.V82.of_tactic (clear to_intros) + ; h_intros to_intros + ; (fun g' -> + let ty_teq = pf_get_hyp_typ g' heq in + let teq_lhs, teq_rhs = + let _, args = + try destApp (project g') ty_teq + with DestKO -> assert false + in + (args.(1), args.(2)) + in + let new_b' = + Termops.replace_term (project g') teq_lhs teq_rhs new_b + in + let new_infos = + { infos with + info = new_b' + ; eqs = heq :: infos.eqs + ; forbidden_ids = + ( if forbid_new_ids then + add_vars (project g') infos.forbidden_ids new_b' + else infos.forbidden_ids ) } + in + finalize_tac new_infos g') ]) ] + g + +let rec travel_aux jinfo continuation_tac (expr_info : constr infos) g = let sigma = project g in let env = pf_env g in match EConstr.kind sigma expr_info.info with - | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") - | Proj _ -> user_err Pp.(str "Function cannot treat projections") - | LetIn(na,b,t,e) -> - begin + | CoFix _ | Fix _ -> + user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") + | Proj _ -> user_err Pp.(str "Function cannot treat projections") + | LetIn (na, b, t, e) -> + let new_continuation_tac = + jinfo.letiN (na.binder_name, b, t, e) expr_info continuation_tac + in + travel jinfo new_continuation_tac + {expr_info with info = b; is_final = false} + g + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + | Prod _ -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Lambda (n, t, b) -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Case (ci, t, a, l) -> + let continuation_tac_a = + jinfo.casE (travel jinfo) (ci, t, a, l) expr_info continuation_tac + in + travel jinfo continuation_tac_a + {expr_info with info = a; is_main_branch = false; is_final = false} + g + | App _ -> ( + let f, args = decompose_app sigma expr_info.info in + if EConstr.eq_constr sigma f expr_info.f_constr then + jinfo.app_reC (f, args) expr_info continuation_tac expr_info g + else + match EConstr.kind sigma f with + | App _ -> assert false (* f is coming from a decompose_app *) + | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ + |Prod _ | Var _ -> + let new_infos = {expr_info with info = (f, args)} in let new_continuation_tac = - jinfo.letiN (na.binder_name,b,t,e) expr_info continuation_tac + jinfo.apP (f, args) expr_info continuation_tac in - travel jinfo new_continuation_tac - {expr_info with info = b; is_final=false} g - end - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - | Prod _ -> - begin - try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) - end - | Lambda(n,t,b) -> - begin - try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) - end - | Case(ci,t,a,l) -> - begin - let continuation_tac_a = - jinfo.casE - (travel jinfo) (ci,t,a,l) - expr_info continuation_tac in - travel - jinfo continuation_tac_a - {expr_info with info = a; is_main_branch = false; - is_final = false} g - end - | App _ -> - let f,args = decompose_app sigma expr_info.info in - if EConstr.eq_constr sigma f (expr_info.f_constr) - then jinfo.app_reC (f,args) expr_info continuation_tac expr_info g - else - begin - match EConstr.kind sigma f with - | App _ -> assert false (* f is coming from a decompose_app *) - | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ - | Sort _ | Prod _ | Var _ -> - let new_infos = {expr_info with info=(f,args)} in - let new_continuation_tac = - jinfo.apP (f,args) expr_info continuation_tac in - travel_args jinfo - expr_info.is_main_branch new_continuation_tac new_infos g - | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") - | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env env sigma expr_info.info ++ Pp.str ".") - end - | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ | Float _ -> - let new_continuation_tac = - jinfo.otherS () expr_info continuation_tac in - new_continuation_tac expr_info g + travel_args jinfo expr_info.is_main_branch new_continuation_tac + new_infos g + | Case _ -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str + " can not contain an applied match (See Limitation in Section \ + 2.3 of refman)" ) + | _ -> + anomaly + ( Pp.str "travel_aux : unexpected " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ Pp.str "." ) ) + | Cast (t, _, _) -> travel jinfo continuation_tac {expr_info with info = t} g + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ + |Float _ -> + let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in + new_continuation_tac expr_info g + and travel_args jinfo is_final continuation_tac infos = - let (f_args',args) = infos.info in + let f_args', args = infos.info in match args with - | [] -> - continuation_tac {infos with info = f_args'; is_final = is_final} - | arg::args' -> - let new_continuation_tac new_infos = - let new_arg = new_infos.info in - travel_args jinfo is_final - continuation_tac - {new_infos with info = (mkApp(f_args',[|new_arg|]),args')} - in - travel jinfo new_continuation_tac - {infos with info=arg;is_final=false} + | [] -> continuation_tac {infos with info = f_args'; is_final} + | arg :: args' -> + let new_continuation_tac new_infos = + let new_arg = new_infos.info in + travel_args jinfo is_final continuation_tac + {new_infos with info = (mkApp (f_args', [|new_arg|]), args')} + in + travel jinfo new_continuation_tac {infos with info = arg; is_final = false} + and travel jinfo continuation_tac expr_info = observe_tac - (fun env sigma -> str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) + (fun env sigma -> + str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) @@ -475,164 +535,185 @@ let rec prove_lt hyple g = let sigma = project g in begin try - let (varx,varz) = match decompose_app sigma (pf_concl g) with - | _, x::z::_ when isVar sigma x && isVar sigma z -> x, z + let varx, varz = + match decompose_app sigma (pf_concl g) with + | _, x :: z :: _ when isVar sigma x && isVar sigma z -> (x, z) | _ -> assert false in let h = - List.find (fun id -> - match decompose_app sigma (pf_get_hyp_typ g id) with - | _, t::_ -> EConstr.eq_constr sigma t varx - | _ -> false - ) hyple + List.find + (fun id -> + match decompose_app sigma (pf_get_hyp_typ g id) with + | _, t :: _ -> EConstr.eq_constr sigma t varx + | _ -> false) + hyple in let y = - List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) in - observe_tclTHENLIST (fun _ _ -> str "prove_lt1")[ - Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); - observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) - ] + List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) + in + observe_tclTHENLIST + (fun _ _ -> str "prove_lt1") + [ Proofview.V82.of_tactic + (apply (mkApp (le_lt_trans (), [|varx; y; varz; mkVar h|]))) + ; observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] with Not_found -> - ( - ( - observe_tclTHENLIST (fun _ _ -> str "prove_lt2")[ - Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); - (observe_tac (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) - ]) - ) + observe_tclTHENLIST + (fun _ _ -> str "prove_lt2") + [ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)) + ; observe_tac + (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) + (Proofview.V82.of_tactic assumption) ] end g -let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = +let rec destruct_bounds_aux infos (bound, hyple, rechyps) lbounds g = match lbounds with - | [] -> - let ids = pf_ids_of_hyps g in - let s_max = mkApp(delayed_force coq_S, [|bound|]) in - let k = next_ident_away_in_goal k_id ids in - let ids = k::ids in - let h' = next_ident_away_in_goal (h'_id) ids in - let ids = h'::ids in - let def = next_ident_away_in_goal def_id ids in - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux1")[ - Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); - Proofview.V82.of_tactic (intro_then - (fun id -> - Proofview.V82.tactic begin - observe_tac (fun _ _ -> str "destruct_bounds_aux") - (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) - [ - observe_tclTHENLIST (fun _ _ -> str "")[Proofview.V82.of_tactic (intro_using h_id); - Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); - Proofview.V82.of_tactic default_full_auto]; - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux2")[ - observe_tac (fun _ _ -> str "clearing k ") (Proofview.V82.of_tactic (clear [id])); - h_intros [k;h';def]; - observe_tac (fun _ _ -> str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); - observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference infos.func)])); - ( - observe_tclTHENLIST (fun _ _ -> str "test")[ - list_rewrite true - (List.fold_right - (fun e acc -> (mkVar e,true)::acc) - infos.eqs - (List.map (fun e -> (e,true)) rechyps) - ); - (* list_rewrite true *) - (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) - (* ; *) - - (observe_tac (fun _ _ -> str "finishing") - (tclORELSE - (Proofview.V82.of_tactic intros_reflexivity) - (observe_tac (fun _ _ -> str "calling prove_lt") (prove_lt hyple))))]) - ] - ] - )end)) - ] g - | (_,v_bound)::l -> - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux3")[ - Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); - Proofview.V82.of_tactic (clear [v_bound]); - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 - (fun p_hyp -> - (onNthHypId 2 - (fun p -> - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux4")[ - Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); - tclDO 3 (Proofview.V82.of_tactic intro); - onNLastHypsId 3 (fun lids -> - match lids with - [hle2;hle1;pmax] -> - destruct_bounds_aux infos - ((mkVar pmax), - hle1::hle2::hyple,(mkVar p_hyp)::rechyps) - l - | _ -> assert false) ; - ] - ) - ) - ) - ] g + | [] -> + let ids = pf_ids_of_hyps g in + let s_max = mkApp (delayed_force coq_S, [|bound|]) in + let k = next_ident_away_in_goal k_id ids in + let ids = k :: ids in + let h' = next_ident_away_in_goal h'_id ids in + let ids = h' :: ids in + let def = next_ident_away_in_goal def_id ids in + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux1") + [ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])) + ; Proofview.V82.of_tactic + (intro_then (fun id -> + Proofview.V82.tactic + (observe_tac + (fun _ _ -> str "destruct_bounds_aux") + (tclTHENS + (Proofview.V82.of_tactic (simplest_case (mkVar id))) + [ observe_tclTHENLIST + (fun _ _ -> str "") + [ Proofview.V82.of_tactic (intro_using h_id) + ; Proofview.V82.of_tactic + (simplest_elim + (mkApp (delayed_force lt_n_O, [|s_max|]))) + ; Proofview.V82.of_tactic default_full_auto ] + ; observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux2") + [ observe_tac + (fun _ _ -> str "clearing k ") + (Proofview.V82.of_tactic (clear [id])) + ; h_intros [k; h'; def] + ; observe_tac + (fun _ _ -> str "simple_iter") + (Proofview.V82.of_tactic + (simpl_iter Locusops.onConcl)) + ; observe_tac + (fun _ _ -> str "unfold functional") + (Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference + infos.func ) ])) + ; observe_tclTHENLIST + (fun _ _ -> str "test") + [ list_rewrite true + (List.fold_right + (fun e acc -> (mkVar e, true) :: acc) + infos.eqs + (List.map (fun e -> (e, true)) rechyps)) + ; (* list_rewrite true *) + (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) + (* ; *) + observe_tac + (fun _ _ -> str "finishing") + (tclORELSE + (Proofview.V82.of_tactic + intros_reflexivity) + (observe_tac + (fun _ _ -> str "calling prove_lt") + (prove_lt hyple))) ] ] ])))) ] + g + | (_, v_bound) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux3") + [ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)) + ; Proofview.V82.of_tactic (clear [v_bound]) + ; tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun p_hyp -> + onNthHypId 2 (fun p -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux4") + [ Proofview.V82.of_tactic + (simplest_elim + (mkApp (delayed_force max_constr, [|bound; mkVar p|]))) + ; tclDO 3 (Proofview.V82.of_tactic intro) + ; onNLastHypsId 3 (fun lids -> + match lids with + | [hle2; hle1; pmax] -> + destruct_bounds_aux infos + ( mkVar pmax + , hle1 :: hle2 :: hyple + , mkVar p_hyp :: rechyps ) + l + | _ -> assert false) ])) ] + g let destruct_bounds infos = - destruct_bounds_aux infos (delayed_force coq_O,[],[]) infos.values_and_bounds + destruct_bounds_aux infos + (delayed_force coq_O, [], []) + infos.values_and_bounds let terminate_app f_and_args expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app1")[ - continuation_tac infos; - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (1)") (destruct_bounds infos) - ] - else continuation_tac infos + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app1") + [ continuation_tac infos + ; observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (1)") + (destruct_bounds infos) ] + else continuation_tac infos let terminate_others _ expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_others")[ - continuation_tac infos; - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) - ] + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_others") + [ continuation_tac infos + ; observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) + ; observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) + ] else continuation_tac infos -let terminate_letin (na,b,t,e) expr_info continuation_tac info g = +let terminate_letin (na, b, t, e) expr_info continuation_tac info g = let sigma = project g in let env = pf_env g in let new_e = subst1 info.info e in let new_forbidden = let forbid = try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in - if forbid - then + if forbid then match na with - | Anonymous -> info.forbidden_ids - | Name id -> id::info.forbidden_ids + | Anonymous -> info.forbidden_ids + | Name id -> id :: info.forbidden_ids else info.forbidden_ids in continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g let pf_type c tac gl = let evars, ty = Typing.type_of (pf_env gl) (project gl) c in - tclTHEN (Refiner.tclEVARS evars) (tac ty) gl + tclTHEN (Refiner.tclEVARS evars) (tac ty) gl let pf_typel l tac = let rec aux tys l = match l with | [] -> tac (List.rev tys) - | hd :: tl -> pf_type hd (fun ty -> aux (ty::tys) tl) - in aux [] l + | hd :: tl -> pf_type hd (fun ty -> aux (ty :: tys) tl) + in + aux [] l (* This is like the previous one except that it also rewrite on all hypotheses except the ones given in the first argument. All the @@ -646,351 +727,431 @@ let mkDestructEq not_on_hyp expr g = (fun decl -> let open Context.Named.Declaration in let id = get_id decl in - if Id.List.mem id not_on_hyp || not (Termops.dependent (project g) expr (get_type decl)) - then None else Some id) hyps in + if + Id.List.mem id not_on_hyp + || not (Termops.dependent (project g) expr (get_type decl)) + then None + else Some id) + hyps + in let to_revert_constr = List.rev_map mkVar to_revert in let g, type_of_expr = tac_type_of g expr in - let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|])::to_revert_constr in + let new_hyps = + mkApp (Lazy.force refl_equal, [|type_of_expr; expr|]) :: to_revert_constr + in let tac = pf_typel new_hyps (fun _ -> - observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") - [Proofview.V82.of_tactic (generalize new_hyps); - (fun g2 -> - let changefun patvars env sigma = - pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) - in - Proofview.V82.of_tactic (change_in_concl ~check:true None changefun) g2); - Proofview.V82.of_tactic (simplest_case expr)]) + observe_tclTHENLIST + (fun _ _ -> str "mkDestructEq") + [ Proofview.V82.of_tactic (generalize new_hyps) + ; (fun g2 -> + let changefun patvars env sigma = + pattern_occs + [(Locus.AllOccurrencesBut [1], expr)] + (pf_env g2) sigma (pf_concl g2) + in + Proofview.V82.of_tactic + (change_in_concl ~check:true None changefun) + g2) + ; Proofview.V82.of_tactic (simplest_case expr) ]) in - g, tac, to_revert + (g, tac, to_revert) -let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = +let terminate_case next_step (ci, a, t, l) expr_info continuation_tac infos g = let sigma = project g in let env = pf_env g in let f_is_present = try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) a; false - with e when CErrors.noncritical e -> - true + with e when CErrors.noncritical e -> true in let a' = infos.info in let new_info = - {infos with - info = mkCase(ci,t,a',l); - is_main_branch = expr_info.is_main_branch; - is_final = expr_info.is_final} in - let g,destruct_tac,rev_to_thin_intro = - mkDestructEq [expr_info.rec_arg_id] a' g in + { infos with + info = mkCase (ci, t, a', l) + ; is_main_branch = expr_info.is_main_branch + ; is_final = expr_info.is_final } + in + let g, destruct_tac, rev_to_thin_intro = + mkDestructEq [expr_info.rec_arg_id] a' g + in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (fun _ _ -> str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') - (try - (tclTHENS - destruct_tac - (List.map_i (fun i e -> observe_tac (fun _ _ -> str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) - )) - with - | UserError(Some "Refiner.thensn_tac3",_) - | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (fun _ _ -> str "is computable " ++ Printer.pr_leconstr_env env sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) - )) + observe_tac + (fun _ _ -> + str "treating cases (" + ++ int (Array.length l) + ++ str ")" ++ spc () + ++ Printer.pr_leconstr_env (pf_env g) sigma a') + ( try + tclTHENS destruct_tac + (List.map_i + (fun i e -> + observe_tac + (fun _ _ -> str "do treat case") + (treat_case f_is_present to_thin_intro + (next_step continuation_tac) + ci.ci_cstr_ndecls.(i) e new_info)) + 0 (Array.to_list l)) + with + | UserError (Some "Refiner.thensn_tac3", _) + |UserError (Some "Refiner.tclFAIL_s", _) + -> + observe_tac + (fun _ _ -> + str "is computable " + ++ Printer.pr_leconstr_env env sigma new_info.info) + (next_step continuation_tac + { new_info with + info = + Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info }) + ) g -let terminate_app_rec (f,args) expr_info continuation_tac _ g = +let terminate_app_rec (f, args) expr_info continuation_tac _ g = let sigma = project g in let env = pf_env g in - List.iter (check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids)) + List.iter + (check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids)) args; - begin - try - let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in - let new_infos = {expr_info with info = v} in - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec")[ - continuation_tac new_infos; - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec1")[ - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (3)") - (destruct_bounds new_infos) - ] - else - tclIDTAC - ] g - with Not_found -> - observe_tac (fun _ _ -> str "terminate_app_rec not found") (tclTHENS - (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) - [ - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec2")[ - Proofview.V82.of_tactic (intro_using rec_res_id); - Proofview.V82.of_tactic intro; - onNthHypId 1 - (fun v_bound -> - (onNthHypId 2 - (fun v -> - let new_infos = { expr_info with - info = (mkVar v); - values_and_bounds = - (v,v_bound)::expr_info.values_and_bounds; - args_assoc=(args,mkVar v)::expr_info.args_assoc - } in - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec3")[ - continuation_tac new_infos; - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec4")[ - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (2)") - (destruct_bounds new_infos) - ] - else - tclIDTAC - ] - ) - ) - ) - ]; - observe_tac (fun _ _ -> str "proving decreasing") ( - tclTHENS (* proof of args < formal args *) - (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) - [ - observe_tac (fun _ _ -> str "assumption") (Proofview.V82.of_tactic assumption); - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec5") - [ - tclTRY(list_rewrite true - (List.map - (fun e -> mkVar e,true) - expr_info.eqs - ) - ); - Proofview.V82.of_tactic @@ - tclUSER expr_info.concl_tac true - (Some ( - expr_info.ih::expr_info.acc_id:: - (fun (x,y) -> y) - (List.split expr_info.values_and_bounds) - ) - ); - ] - ]) - ]) g - end + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec") + [ continuation_tac new_infos + ; ( if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec1") + [ observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic + (split (ImplicitBindings [new_infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (3)") + (destruct_bounds new_infos) ] + else tclIDTAC ) ] + g + with Not_found -> + observe_tac + (fun _ _ -> str "terminate_app_rec not found") + (tclTHENS + (Proofview.V82.of_tactic + (simplest_elim (mkApp (mkVar expr_info.ih, Array.of_list args)))) + [ observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec2") + [ Proofview.V82.of_tactic (intro_using rec_res_id) + ; Proofview.V82.of_tactic intro + ; onNthHypId 1 (fun v_bound -> + onNthHypId 2 (fun v -> + let new_infos = + { expr_info with + info = mkVar v + ; values_and_bounds = + (v, v_bound) :: expr_info.values_and_bounds + ; args_assoc = (args, mkVar v) :: expr_info.args_assoc + } + in + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec3") + [ continuation_tac new_infos + ; ( if expr_info.is_final && expr_info.is_main_branch + then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec4") + [ observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic + (split + (ImplicitBindings [new_infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (2)") + (destruct_bounds new_infos) ] + else tclIDTAC ) ])) ] + ; observe_tac + (fun _ _ -> str "proving decreasing") + (tclTHENS (* proof of args < formal args *) + (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) + [ observe_tac + (fun _ _ -> str "assumption") + (Proofview.V82.of_tactic assumption) + ; observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec5") + [ tclTRY + (list_rewrite true + (List.map (fun e -> (mkVar e, true)) expr_info.eqs)) + ; Proofview.V82.of_tactic + @@ tclUSER expr_info.concl_tac true + (Some + ( expr_info.ih :: expr_info.acc_id + :: (fun (x, y) -> y) + (List.split expr_info.values_and_bounds) )) + ] ]) ]) + g let terminate_info = - { message = "prove_terminate with term "; - letiN = terminate_letin; - lambdA = (fun _ _ _ _ -> assert false); - casE = terminate_case; - otherS = terminate_others; - apP = terminate_app; - app_reC = terminate_app_rec; - } + { message = "prove_terminate with term " + ; letiN = terminate_letin + ; lambdA = (fun _ _ _ _ -> assert false) + ; casE = terminate_case + ; otherS = terminate_others + ; apP = terminate_app + ; app_reC = terminate_app_rec } let prove_terminate = travel terminate_info - (* Equation proof *) -let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = - observe_tac (fun _ _ -> str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) +let equation_case next_step (ci, a, t, l) expr_info continuation_tac infos = + observe_tac + (fun _ _ -> str "equation case") + (terminate_case next_step (ci, a, t, l) expr_info continuation_tac infos) let rec prove_le g = let sigma = project g in - let x,z = - let _,args = decompose_app sigma (pf_concl g) in - (List.hd args,List.hd (List.tl args)) + let x, z = + let _, args = decompose_app sigma (pf_concl g) in + (List.hd args, List.hd (List.tl args)) in - tclFIRST[ - Proofview.V82.of_tactic assumption; - Proofview.V82.of_tactic (apply (delayed_force le_n)); - begin - try - let matching_fun c = match EConstr.kind sigma c with - | App (c, [| x0 ; _ |]) -> - EConstr.isVar sigma x0 && - Id.equal (destVar sigma x0) (destVar sigma x) && - EConstr.isRefX sigma (le ()) c - | _ -> false - in - let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in - let h = h.binder_name in - let y = - let _,args = decompose_app sigma t in - List.hd (List.tl args) - in - observe_tclTHENLIST (fun _ _ -> str "prove_le")[ - Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); - observe_tac (fun _ _ -> str "prove_le (rec)") (prove_le) - ] - with Not_found -> tclFAIL 0 (mt()) - end; - ] + tclFIRST + [ Proofview.V82.of_tactic assumption + ; Proofview.V82.of_tactic (apply (delayed_force le_n)) + ; begin + try + let matching_fun c = + match EConstr.kind sigma c with + | App (c, [|x0; _|]) -> + EConstr.isVar sigma x0 + && Id.equal (destVar sigma x0) (destVar sigma x) + && EConstr.isRefX sigma (le ()) c + | _ -> false + in + let h, t = + List.find (fun (_, t) -> matching_fun t) (pf_hyps_types g) + in + let h = h.binder_name in + let y = + let _, args = decompose_app sigma t in + List.hd (List.tl args) + in + observe_tclTHENLIST + (fun _ _ -> str "prove_le") + [ Proofview.V82.of_tactic + (apply (mkApp (le_trans (), [|x; y; z; mkVar h|]))) + ; observe_tac (fun _ _ -> str "prove_le (rec)") prove_le ] + with Not_found -> tclFAIL 0 (mt ()) + end ] g let rec make_rewrite_list expr_info max = function | [] -> tclIDTAC - | (_,p,hp)::l -> - observe_tac (fun _ _ -> str "make_rewrite_list") (tclTHENS - (observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p ) ( - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k,def = - let k_na,_,t = destProd sigma t_eq in - let _,_,t = destProd sigma t in - let def_na,_,_ = destProd sigma t in - Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name - in - Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences - true (* dep proofs also: *) true - (mkVar hp, - ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); - CAst.make @@ (NamedHyp k, f_S max)]) false) g) ) - ) - [make_rewrite_list expr_info max l; - observe_tclTHENLIST (fun _ _ -> str "make_rewrite_list")[ (* x < S max proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); - observe_tac (fun _ _ -> str "prove_le(2)") prove_le - ] - ] ) + | (_, p, hp) :: l -> + observe_tac + (fun _ _ -> str "make_rewrite_list") + (tclTHENS + (observe_tac + (fun _ _ -> str "rewrite heq on " ++ Id.print p) + (fun g -> + let sigma = project g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + Proofview.V82.of_tactic + (general_rewrite_bindings false Locus.AllOccurrences true + (* dep proofs also: *) true + ( mkVar hp + , ExplicitBindings + [ CAst.make @@ (NamedHyp def, expr_info.f_constr) + ; CAst.make @@ (NamedHyp k, f_S max) ] ) + false) + g)) + [ make_rewrite_list expr_info max l + ; observe_tclTHENLIST + (fun _ _ -> str "make_rewrite_list") + [ (* x < S max proof *) + Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)) + ; observe_tac (fun _ _ -> str "prove_le(2)") prove_le ] ]) let make_rewrite expr_info l hp max = tclTHENFIRST - (observe_tac (fun _ _ -> str "make_rewrite") (make_rewrite_list expr_info max l)) - (observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k,def = - let k_na,_,t = destProd sigma t_eq in - let _,_,t = destProd sigma t in - let def_na,_,_ = destProd sigma t in - Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name - in - observe_tac (fun _ _ -> str "general_rewrite_bindings") - (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences - true (* dep proofs also: *) true - (mkVar hp, - ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); - CAst.make @@ (NamedHyp k, f_S (f_S max))]) false)) g) - [observe_tac(fun _ _ -> str "make_rewrite finalize") ( - (* tclORELSE( h_reflexivity) *) - (observe_tclTHENLIST (fun _ _ -> str "make_rewrite")[ - Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); - observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference expr_info.func)])); - - (list_rewrite true - (List.map (fun e -> mkVar e,true) expr_info.eqs)); - (observe_tac (fun _ _ -> str "h_reflexivity") - (Proofview.V82.of_tactic intros_reflexivity) - ) - ])) - ; - observe_tclTHENLIST (fun _ _ -> str "make_rewrite1")[ (* x < S (S max) proof *) - Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); - observe_tac (fun _ _ -> str "prove_le (3)") prove_le - ] - ]) - ) + (observe_tac + (fun _ _ -> str "make_rewrite") + (make_rewrite_list expr_info max l)) + (observe_tac + (fun _ _ -> str "make_rewrite") + (tclTHENS + (fun g -> + let sigma = project g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + observe_tac + (fun _ _ -> str "general_rewrite_bindings") + (Proofview.V82.of_tactic + (general_rewrite_bindings false Locus.AllOccurrences true + (* dep proofs also: *) true + ( mkVar hp + , ExplicitBindings + [ CAst.make @@ (NamedHyp def, expr_info.f_constr) + ; CAst.make @@ (NamedHyp k, f_S (f_S max)) ] ) + false)) + g) + [ observe_tac + (fun _ _ -> str "make_rewrite finalize") + ((* tclORELSE( h_reflexivity) *) + observe_tclTHENLIST + (fun _ _ -> str "make_rewrite") + [ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl) + ; observe_tac + (fun _ _ -> str "unfold functional") + (Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference expr_info.func ) ])) + ; list_rewrite true + (List.map (fun e -> (mkVar e, true)) expr_info.eqs) + ; observe_tac + (fun _ _ -> str "h_reflexivity") + (Proofview.V82.of_tactic intros_reflexivity) ]) + ; observe_tclTHENLIST + (fun _ _ -> str "make_rewrite1") + [ (* x < S (S max) proof *) + Proofview.V82.of_tactic + (apply (EConstr.of_constr (delayed_force le_lt_SS))) + ; observe_tac (fun _ _ -> str "prove_le (3)") prove_le ] ])) let rec compute_max rew_tac max l = match l with - | [] -> rew_tac max - | (_,p,_)::l -> - observe_tclTHENLIST (fun _ _ -> str "compute_max")[ - Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| max; mkVar p|]))); - tclDO 3 (Proofview.V82.of_tactic intro); - onNLastHypsId 3 (fun lids -> - match lids with - | [hle2;hle1;pmax] -> compute_max rew_tac (mkVar pmax) l - | _ -> assert false - )] + | [] -> rew_tac max + | (_, p, _) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "compute_max") + [ Proofview.V82.of_tactic + (simplest_elim (mkApp (delayed_force max_constr, [|max; mkVar p|]))) + ; tclDO 3 (Proofview.V82.of_tactic intro) + ; onNLastHypsId 3 (fun lids -> + match lids with + | [hle2; hle1; pmax] -> compute_max rew_tac (mkVar pmax) l + | _ -> assert false) ] let rec destruct_hex expr_info acc l = match l with - | [] -> - begin - match List.rev acc with - | [] -> tclIDTAC - | (_,p,hp)::tl -> - observe_tac (fun _ _ -> str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) - end - | (v,hex)::l -> - observe_tclTHENLIST (fun _ _ -> str "destruct_hex")[ - Proofview.V82.of_tactic (simplest_case (mkVar hex)); - Proofview.V82.of_tactic (clear [hex]); - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 (fun hp -> - onNthHypId 2 (fun p -> - observe_tac - (fun _ _ -> str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) - (destruct_hex expr_info ((v,p,hp)::acc) l) - ) - ) - ] + | [] -> ( + match List.rev acc with + | [] -> tclIDTAC + | (_, p, hp) :: tl -> + observe_tac + (fun _ _ -> str "compute max ") + (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) ) + | (v, hex) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_hex") + [ Proofview.V82.of_tactic (simplest_case (mkVar hex)) + ; Proofview.V82.of_tactic (clear [hex]) + ; tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun hp -> + onNthHypId 2 (fun p -> + observe_tac + (fun _ _ -> + str "destruct_hex after " ++ Id.print hp ++ spc () + ++ Id.print p) + (destruct_hex expr_info ((v, p, hp) :: acc) l))) ] let rec intros_values_eq expr_info acc = - tclORELSE( - observe_tclTHENLIST (fun _ _ -> str "intros_values_eq")[ - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 (fun hex -> - (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) - ) - ]) - (tclCOMPLETE ( - destruct_hex expr_info [] acc - )) + tclORELSE + (observe_tclTHENLIST + (fun _ _ -> str "intros_values_eq") + [ tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun hex -> + onNthHypId 2 (fun v -> + intros_values_eq expr_info ((v, hex) :: acc))) ]) + (tclCOMPLETE (destruct_hex expr_info [] acc)) let equation_others _ expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tac (fun env sigma -> str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) - (tclTHEN + if expr_info.is_final && expr_info.is_main_branch then + observe_tac + (fun env sigma -> + str "equation_others (cont_tac +intros) " + ++ Printer.pr_leconstr_env env sigma expr_info.info) + (tclTHEN (continuation_tac infos) + (observe_tac + (fun env sigma -> + str "intros_values_eq equation_others " + ++ Printer.pr_leconstr_env env sigma expr_info.info) + (intros_values_eq expr_info []))) + else + observe_tac + (fun env sigma -> + str "equation_others (cont_tac) " + ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) - (observe_tac (fun env sigma -> str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []))) - else observe_tac (fun env sigma -> str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then ((observe_tac (fun _ _ -> str "intros_values_eq equation_app") (intros_values_eq expr_info []))) - else continuation_tac infos + if expr_info.is_final && expr_info.is_main_branch then + observe_tac + (fun _ _ -> str "intros_values_eq equation_app") + (intros_values_eq expr_info []) + else continuation_tac infos -let equation_app_rec (f,args) expr_info continuation_tac info g = +let equation_app_rec (f, args) expr_info continuation_tac info g = let sigma = project g in - begin - try - let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in - let new_infos = {expr_info with info = v} in - observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g - with Not_found -> - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "equation_app_rec") - [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; - observe_tac (fun _ _ -> str "app_rec intros_values_eq") (intros_values_eq expr_info []) - ] g - else - observe_tclTHENLIST (fun _ _ -> str "equation_app_rec1")[ - Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - observe_tac (fun _ _ -> str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) - ] g - end + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g + with Not_found -> + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec") + [ Proofview.V82.of_tactic + (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) + ; continuation_tac + { expr_info with + args_assoc = (args, delayed_force coq_O) :: expr_info.args_assoc + } + ; observe_tac + (fun _ _ -> str "app_rec intros_values_eq") + (intros_values_eq expr_info []) ] + g + else + observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec1") + [ Proofview.V82.of_tactic + (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) + ; observe_tac + (fun _ _ -> str "app_rec not_found") + (continuation_tac + { expr_info with + args_assoc = + (args, delayed_force coq_O) :: expr_info.args_assoc }) ] + g let equation_info = - {message = "prove_equation with term "; - letiN = (fun _ -> assert false); - lambdA = (fun _ _ _ _ -> assert false); - casE = equation_case; - otherS = equation_others; - apP = equation_app; - app_reC = equation_app_rec -} + { message = "prove_equation with term " + ; letiN = (fun _ -> assert false) + ; lambdA = (fun _ _ _ _ -> assert false) + ; casE = equation_case + ; otherS = equation_others + ; apP = equation_app + ; app_reC = equation_app_rec } let prove_eq = travel equation_info @@ -1001,271 +1162,268 @@ let compute_terminate_type nb_args func = let open Term in let open Constr in let open CVars in - let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_monomorphic_global func)) in - let rev_args,b = decompose_prod_n nb_args a_arrow_b in + let _, a_arrow_b, _ = + destLambda (def_of_const (constr_of_monomorphic_global func)) + in + let rev_args, b = decompose_prod_n nb_args a_arrow_b in let left = - mkApp(delayed_force iter_rd, - Array.of_list - (lift 5 a_arrow_b:: mkRel 3:: - constr_of_monomorphic_global func::mkRel 1:: - List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) - ) - ) + mkApp + ( delayed_force iter_rd + , Array.of_list + ( lift 5 a_arrow_b :: mkRel 3 + :: constr_of_monomorphic_global func + :: mkRel 1 + :: List.rev (List.map_i (fun i _ -> mkRel (6 + i)) 0 rev_args) ) ) in let right = mkRel 5 in let delayed_force c = EConstr.Unsafe.to_constr (delayed_force c) in - let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in - let result = (mkProd (make_annot (Name def_id) Sorts.Relevant, lift 4 a_arrow_b, equality)) in - let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in + let equality = mkApp (delayed_force eq, [|lift 5 b; left; right|]) in + let result = + mkProd (make_annot (Name def_id) Sorts.Relevant, lift 4 a_arrow_b, equality) + in + let cond = mkApp (delayed_force lt, [|mkRel 2; mkRel 1|]) in let nb_iter = - mkApp(delayed_force ex, - [|delayed_force nat; - (mkLambda - (make_annot (Name p_id) Sorts.Relevant, - delayed_force nat, - (mkProd (make_annot (Name k_id) Sorts.Relevant, delayed_force nat, - mkArrow cond Sorts.Relevant result))))|])in - let value = mkApp(constr_of_monomorphic_global (Util.delayed_force coq_sig_ref), - [|b; - (mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter))|]) in + mkApp + ( delayed_force ex + , [| delayed_force nat + ; mkLambda + ( make_annot (Name p_id) Sorts.Relevant + , delayed_force nat + , mkProd + ( make_annot (Name k_id) Sorts.Relevant + , delayed_force nat + , mkArrow cond Sorts.Relevant result ) ) |] ) + in + let value = + mkApp + ( constr_of_monomorphic_global (Util.delayed_force coq_sig_ref) + , [|b; mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter)|] ) + in compose_prod rev_args value - -let termination_proof_header is_mes input_type ids args_id relation - rec_arg_num rec_arg_id tac wf_tac : tactic = - begin - fun g -> - let nargs = List.length args_id in - let pre_rec_args = - List.rev_map - mkVar (fst (List.chop (rec_arg_num - 1) args_id)) - in - let relation = substl pre_rec_args relation in - let input_type = substl pre_rec_args input_type in - let wf_thm = next_ident_away_in_goal (Id.of_string ("wf_R")) ids in - let wf_rec_arg = - next_ident_away_in_goal - (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))) - (wf_thm::ids) - in - let hrec = next_ident_away_in_goal hrec_id - (wf_rec_arg::wf_thm::ids) in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - tclTHEN - (h_intros args_id) - (tclTHENS +let termination_proof_header is_mes input_type ids args_id relation rec_arg_num + rec_arg_id tac wf_tac : tactic = + fun g -> + let nargs = List.length args_id in + let pre_rec_args = + List.rev_map mkVar (fst (List.chop (rec_arg_num - 1) args_id)) + in + let relation = substl pre_rec_args relation in + let input_type = substl pre_rec_args input_type in + let wf_thm = next_ident_away_in_goal (Id.of_string "wf_R") ids in + let wf_rec_arg = + next_ident_away_in_goal + (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)) + (wf_thm :: ids) + in + let hrec = next_ident_away_in_goal hrec_id (wf_rec_arg :: wf_thm :: ids) in + let acc_inv = + lazy + (mkApp + (delayed_force acc_inv_id, [|input_type; relation; mkVar rec_arg_id|])) + in + tclTHEN (h_intros args_id) + (tclTHENS + (observe_tac + (fun _ _ -> str "first assert") + (Proofview.V82.of_tactic + (assert_before (Name wf_rec_arg) + (mkApp + ( delayed_force acc_rel + , [|input_type; relation; mkVar rec_arg_id|] ))))) + [ (* accesibility proof *) + tclTHENS (observe_tac - (fun _ _ -> str "first assert") - (Proofview.V82.of_tactic (assert_before - (Name wf_rec_arg) - (mkApp (delayed_force acc_rel, - [|input_type;relation;mkVar rec_arg_id|]) - ) - )) - ) - [ - (* accesibility proof *) - tclTHENS - (observe_tac - (fun _ _ -> str "second assert") - (Proofview.V82.of_tactic (assert_before - (Name wf_thm) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - )) - ) - [ - (* interactive proof that the relation is well_founded *) - observe_tac (fun _ _ -> str "wf_tac") (wf_tac is_mes (Some args_id)); - (* this gives the accessibility argument *) - observe_tac - (fun _ _ -> str "apply wf_thm") - (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) - ) - ] - ; - (* rest of the proof *) - observe_tclTHENLIST (fun _ _ -> str "rest of proof") - [observe_tac (fun _ _ -> str "generalize") - (onNLastHypsId (nargs+1) - (tclMAP (fun id -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) - )) - ; - observe_tac (fun _ _ -> str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); - h_intros args_id; - Proofview.V82.of_tactic (Simple.intro wf_rec_arg); - observe_tac (fun _ _ -> str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) - ] + (fun _ _ -> str "second assert") + (Proofview.V82.of_tactic + (assert_before (Name wf_thm) + (mkApp + (delayed_force well_founded, [|input_type; relation|]))))) + [ (* interactive proof that the relation is well_founded *) + observe_tac + (fun _ _ -> str "wf_tac") + (wf_tac is_mes (Some args_id)) + ; (* this gives the accessibility argument *) + observe_tac + (fun _ _ -> str "apply wf_thm") + (Proofview.V82.of_tactic + (Simple.apply (mkApp (mkVar wf_thm, [|mkVar rec_arg_id|])))) ] - ) g - end - - + ; (* rest of the proof *) + observe_tclTHENLIST + (fun _ _ -> str "rest of proof") + [ observe_tac + (fun _ _ -> str "generalize") + (onNLastHypsId (nargs + 1) + (tclMAP (fun id -> + tclTHEN + (Proofview.V82.of_tactic + (Tactics.generalize [mkVar id])) + (Proofview.V82.of_tactic (clear [id]))))) + ; observe_tac + (fun _ _ -> str "fix") + (Proofview.V82.of_tactic (fix hrec (nargs + 1))) + ; h_intros args_id + ; Proofview.V82.of_tactic (Simple.intro wf_rec_arg) + ; observe_tac + (fun _ _ -> str "tac") + (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ]) + g let rec instantiate_lambda sigma t l = match l with | [] -> t - | a::l -> - let (_, _, body) = destLambda sigma t in - instantiate_lambda sigma (subst1 a body) l + | a :: l -> + let _, _, body = destLambda sigma t in + instantiate_lambda sigma (subst1 a body) l -let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : tactic = - begin - fun g -> - let sigma = project g in - let ids = Termops.ids_of_named_context (pf_hyps g) in - let func_body = (def_of_const (constr_of_monomorphic_global func)) in - let func_body = EConstr.of_constr func_body in - let (f_name, _, body1) = destLambda sigma func_body in - let f_id = - match f_name.binder_name with - | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly (Pp.str "Anonymous function.") - in - let n_names_types,_ = decompose_lam_n sigma nb_args body1 in - let n_ids,ids = - List.fold_left - (fun (n_ids,ids) (n_name,_) -> - match n_name.binder_name with - | Name id -> - let n_id = next_ident_away_in_goal id ids in - n_id::n_ids,n_id::ids - | _ -> anomaly (Pp.str "anonymous argument.") - ) - ([],(f_id::ids)) - n_names_types - in - let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = instantiate_lambda sigma func_body (mkVar f_id::(List.map mkVar n_ids)) in - termination_proof_header - is_mes - input_type - ids - n_ids - relation - rec_arg_num - rec_arg_id - (fun rec_arg_id hrec acc_id acc_inv g -> - (prove_terminate (fun infos -> tclIDTAC) - { is_main_branch = true; (* we are on the main branche (i.e. still on a match ... with .... end *) - is_final = true; (* and on leaf (more or less) *) - f_terminate = delayed_force coq_O; - nb_arg = nb_args; - concl_tac; - rec_arg_id = rec_arg_id; - is_mes = is_mes; - ih = hrec; - f_id = f_id; - f_constr = mkVar f_id; - func = func; - info = expr; - acc_inv = acc_inv; - acc_id = acc_id; - values_and_bounds = []; - eqs = []; - forbidden_ids = []; - args_assoc = [] - } - ) - g - ) - (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) - g - end +let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : + tactic = + fun g -> + let sigma = project g in + let ids = Termops.ids_of_named_context (pf_hyps g) in + let func_body = def_of_const (constr_of_monomorphic_global func) in + let func_body = EConstr.of_constr func_body in + let f_name, _, body1 = destLambda sigma func_body in + let f_id = + match f_name.binder_name with + | Name f_id -> next_ident_away_in_goal f_id ids + | Anonymous -> anomaly (Pp.str "Anonymous function.") + in + let n_names_types, _ = decompose_lam_n sigma nb_args body1 in + let n_ids, ids = + List.fold_left + (fun (n_ids, ids) (n_name, _) -> + match n_name.binder_name with + | Name id -> + let n_id = next_ident_away_in_goal id ids in + (n_id :: n_ids, n_id :: ids) + | _ -> anomaly (Pp.str "anonymous argument.")) + ([], f_id :: ids) + n_names_types + in + let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in + let expr = + instantiate_lambda sigma func_body (mkVar f_id :: List.map mkVar n_ids) + in + termination_proof_header is_mes input_type ids n_ids relation rec_arg_num + rec_arg_id + (fun rec_arg_id hrec acc_id acc_inv g -> + (prove_terminate + (fun infos -> tclIDTAC) + { is_main_branch = true + ; (* we are on the main branche (i.e. still on a match ... with .... end *) + is_final = true + ; (* and on leaf (more or less) *) + f_terminate = delayed_force coq_O + ; nb_arg = nb_args + ; concl_tac + ; rec_arg_id + ; is_mes + ; ih = hrec + ; f_id + ; f_constr = mkVar f_id + ; func + ; info = expr + ; acc_inv + ; acc_id + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; args_assoc = [] }) + g) + (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) + g let get_current_subgoals_types pstate = - let p = Proof_global.get_proof pstate in - let Proof.{ goals=sgs; sigma; _ } = Proof.data p in - sigma, List.map (Goal.V82.abstract_type sigma) sgs + let p = Declare.Proof.get_proof pstate in + let Proof.{goals = sgs; sigma; _} = Proof.data p in + (sigma, List.map (Goal.V82.abstract_type sigma) sgs) exception EmptySubgoals + let build_and_l sigma l = - let and_constr = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.and.type" in + let and_constr = + UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.and.type" + in let conj_constr = Coqlib.lib_ref "core.and.conj" in - let mk_and p1 p2 = - mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in + let mk_and p1 p2 = mkApp (EConstr.of_constr and_constr, [|p1; p2|]) in let rec is_well_founded t = match EConstr.kind sigma t with - | Prod(_,_,t') -> is_well_founded t' - | App(_,_) -> - let (f,_) = decompose_app sigma t in - EConstr.eq_constr sigma f (well_founded ()) - | _ -> - false + | Prod (_, _, t') -> is_well_founded t' + | App (_, _) -> + let f, _ = decompose_app sigma t in + EConstr.eq_constr sigma f (well_founded ()) + | _ -> false in let compare t1 t2 = - let b1,b2= is_well_founded t1,is_well_founded t2 in - if (b1&&b2) || not (b1 || b2) then 0 - else if b1 && not b2 then 1 else -1 + let b1, b2 = (is_well_founded t1, is_well_founded t2) in + if (b1 && b2) || not (b1 || b2) then 0 else if b1 && not b2 then 1 else -1 in let l = List.sort compare l in - let rec f = function + let rec f = function | [] -> raise EmptySubgoals - | [p] -> p,tclIDTAC,1 - | p1::pl -> - let c,tac,nb = f pl in - mk_and p1 c, - tclTHENS - (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) - [tclIDTAC; - tac - ],nb+1 - in f l - + | [p] -> (p, tclIDTAC, 1) + | p1 :: pl -> + let c, tac, nb = f pl in + ( mk_and p1 c + , tclTHENS + (Proofview.V82.of_tactic + (apply + (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) + [tclIDTAC; tac] + , nb + 1 ) + in + f l let is_rec_res id = - let rec_res_name = Id.to_string rec_res_id in + let rec_res_name = Id.to_string rec_res_id in let id_name = Id.to_string id in try - String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name + String.equal + (String.sub id_name 0 (String.length rec_res_name)) + rec_res_name with Invalid_argument _ -> false let clear_goals sigma = let rec clear_goal t = match EConstr.kind sigma t with - | Prod({binder_name=Name id} as na,t',b) -> - let b' = clear_goal b in - if noccurn sigma 1 b' && (is_rec_res id) - then Vars.lift (-1) b' - else if b' == b then t - else mkProd(na,t',b') - | _ -> EConstr.map sigma clear_goal t + | Prod (({binder_name = Name id} as na), t', b) -> + let b' = clear_goal b in + if noccurn sigma 1 b' && is_rec_res id then Vars.lift (-1) b' + else if b' == b then t + else mkProd (na, t', b') + | _ -> EConstr.map sigma clear_goal t in List.map clear_goal - let build_new_goal_type lemma = let sigma, sub_gls_types = Lemmas.pf_fold get_current_subgoals_types lemma in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let res = build_and_l sigma sub_gls_types in - sigma, res + (sigma, res) let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> Proof_global.Opaque - | Declarations.Undef _ -> Proof_global.Opaque - | Declarations.Def _ -> Proof_global.Transparent - | Declarations.Primitive _ -> Proof_global.Opaque + | Declarations.OpaqueDef _ -> Declare.Opaque + | Declarations.Undef _ -> Declare.Opaque + | Declarations.Def _ -> Declare.Transparent + | Declarations.Primitive _ -> Declare.Opaque -let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name + (gls_type, decompose_and_tac, nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) - let current_proof_name = Lemmas.pf_fold Proof_global.get_proof_name lemma in - let name = match goal_name with + let current_proof_name = Lemmas.pf_fold Declare.Proof.get_proof_name lemma in + let name = + match goal_name with | Some s -> s - | None -> - try add_suffix current_proof_name "_subproof" - with e when CErrors.noncritical e -> - anomaly (Pp.str "open_new_goal with an unnamed theorem.") + | None -> ( + try add_suffix current_proof_name "_subproof" + with e when CErrors.noncritical e -> + anomaly (Pp.str "open_new_goal with an unnamed theorem.") ) in let na = next_global_ident_away name Id.Set.empty in if Termops.occur_existential sigma gls_type then @@ -1275,8 +1433,8 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let na_ref = qualid_of_ident na in let na_global = Smartlocate.global_with_alias na_ref in match na_global with - GlobRef.ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") + | GlobRef.ConstRef c -> is_opaque_constant c + | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in ref_ := Value (EConstr.Unsafe.to_constr lemma); @@ -1288,7 +1446,8 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let open Tacticals.New in Proofview.Goal.enter (fun gl -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gl) in - New.observe_tclTHENLIST (fun _ _ -> mt ()) + New.observe_tclTHENLIST + (fun _ _ -> mt ()) [ generalize [lemma] ; Simple.intro hid ; Proofview.Goal.enter (fun gl -> @@ -1299,195 +1458,252 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let ids' = pf_ids_of_hyps gl in lid := List.rev (List.subtract Id.equal ids' ids); if List.is_empty !lid then lid := [hid]; - tclIDTAC))) - ]) in + tclIDTAC))) ]) + in let end_tac = let open Tacmach.New in let open Tacticals.New in Proofview.Goal.enter (fun gl -> let sigma = project gl in match EConstr.kind sigma (pf_concl gl) with - | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> + | App (f, _) when EConstr.eq_constr sigma f (well_founded ()) -> Auto.h_auto None [] (Some []) | _ -> incr h_num; - tclCOMPLETE( - tclFIRST - [ tclTHEN - (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) - e_assumption - ; Eauto.eauto_with_bases - (true,5) - [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] - [Hints.Hint_db.empty TransparentState.empty false - ] - ] - )) in + tclCOMPLETE + (tclFIRST + [ tclTHEN + (eapply_with_bindings + (mkVar (List.nth !lid !h_num), NoBindings)) + e_assumption + ; Eauto.eauto_with_bases (true, 5) + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] + [Hints.Hint_db.empty TransparentState.empty false] ])) + in let lemma = build_proof env (Evd.from_env env) start_tac end_tac in Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None in let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) () in - let lemma = Lemmas.start_lemma - ~name:na - ~poly:false (* FIXME *) ~info - sigma gls_type in - let lemma = if Indfun_common.is_strict_tcc () - then - fst @@ Lemmas.by (Proofview.V82.tactic (tclIDTAC)) lemma - else - fst @@ Lemmas.by (Proofview.V82.tactic begin - fun g -> - tclTHEN - (decompose_and_tac) - (tclORELSE - (tclFIRST - (List.map - (fun c -> - Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST - [intros; - Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); - Tacticals.New.tclCOMPLETE Auto.default_auto - ]) - ) - using_lemmas) - ) tclIDTAC) - g end) lemma + let lemma = + Lemmas.start_lemma ~name:na ~poly:false (* FIXME *) ~info sigma gls_type + in + let lemma = + if Indfun_common.is_strict_tcc () then + fst @@ Lemmas.by (Proofview.V82.tactic tclIDTAC) lemma + else + fst + @@ Lemmas.by + (Proofview.V82.tactic (fun g -> + tclTHEN decompose_and_tac + (tclORELSE + (tclFIRST + (List.map + (fun c -> + Proofview.V82.of_tactic + (Tacticals.New.tclTHENLIST + [ intros + ; Simple.apply + (fst + (interp_constr (Global.env ()) + Evd.empty c)) + (*FIXME*) + ; Tacticals.New.tclCOMPLETE Auto.default_auto + ])) + using_lemmas)) + tclIDTAC) + g)) + lemma in - if Lemmas.(pf_fold Proof_global.get_open_goals) lemma = 0 then (defined lemma; None) else Some lemma - -let com_terminate - interactive_proof - tcc_lemma_name - tcc_lemma_ref - is_mes - fonctional_ref - input_type - relation - rec_arg_num - thm_name using_lemmas - nb_args ctx - hook = + if Lemmas.(pf_fold Declare.Proof.get_open_goals) lemma = 0 then ( + defined lemma; None ) + else Some lemma + +let com_terminate interactive_proof tcc_lemma_name tcc_lemma_ref is_mes + fonctional_ref input_type relation rec_arg_num thm_name using_lemmas nb_args + ctx hook = let start_proof env ctx tac_start tac_end = let info = Lemmas.Info.make ~hook () in - let lemma = Lemmas.start_lemma ~name:thm_name - ~poly:false (*FIXME*) - ~info - ctx - (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) in - let lemma = fst @@ Lemmas.by (New.observe_tac (fun _ _ -> str "starting_tac") tac_start) lemma in - fst @@ Lemmas.by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref - input_type relation rec_arg_num ))) lemma + let lemma = + Lemmas.start_lemma ~name:thm_name ~poly:false (*FIXME*) ~info ctx + (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) + in + let lemma = + fst + @@ Lemmas.by + (New.observe_tac (fun _ _ -> str "starting_tac") tac_start) + lemma + in + fst + @@ Lemmas.by + (Proofview.V82.tactic + (observe_tac + (fun _ _ -> str "whole_start") + (whole_start tac_end nb_args is_mes fonctional_ref input_type + relation rec_arg_num))) + lemma + in + let lemma = + start_proof + Global.(env ()) + ctx Tacticals.New.tclIDTAC Tacticals.New.tclIDTAC in - let lemma = start_proof Global.(env ()) ctx Tacticals.New.tclIDTAC Tacticals.New.tclIDTAC in try let sigma, new_goal_type = build_new_goal_type lemma in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in - open_new_goal ~lemma start_proof sigma - using_lemmas tcc_lemma_ref - (Some tcc_lemma_name) - (new_goal_type) + open_new_goal ~lemma start_proof sigma using_lemmas tcc_lemma_ref + (Some tcc_lemma_name) new_goal_type with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - if interactive_proof then Some lemma - else (defined lemma; None) + if interactive_proof then Some lemma else (defined lemma; None) -let start_equation (f:GlobRef.t) (term_f:GlobRef.t) - (cont_tactic:Id.t list -> tactic) g = +let start_equation (f : GlobRef.t) (term_f : GlobRef.t) + (cont_tactic : Id.t list -> tactic) g = let sigma = project g in let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_monomorphic_global term_f in let terminate_constr = EConstr.of_constr terminate_constr in - let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in + let nargs = + nb_prod (project g) + (EConstr.of_constr (type_of_const sigma terminate_constr)) + in let x = n_x_id ids nargs in - observe_tac (fun _ _ -> str "start_equation") (observe_tclTHENLIST (fun _ _ -> str "start_equation") [ - h_intros x; - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); - observe_tac (fun _ _ -> str "simplest_case") - (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, - Array.of_list (List.map mkVar x))))); - observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x)]) g;; - -let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = - let open CVars in - let opacity = - match terminate_ref with - | GlobRef.ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") - in - let evd = Evd.from_ctx uctx in - let f_constr = constr_of_monomorphic_global f_ref in - let equation_lemma_type = subst1 f_constr equation_lemma_type in - let lemma = Lemmas.start_lemma ~name:eq_name ~poly:false evd - (EConstr.of_constr equation_lemma_type) in - let lemma = fst @@ Lemmas.by - (Proofview.V82.tactic (start_equation f_ref terminate_ref - (fun x -> - prove_eq (fun _ -> tclIDTAC) - {nb_arg=nb_arg; - f_terminate = EConstr.of_constr (constr_of_monomorphic_global terminate_ref); - f_constr = EConstr.of_constr f_constr; - concl_tac = Tacticals.New.tclIDTAC; - func=functional_ref; - info=(instantiate_lambda Evd.empty - (EConstr.of_constr (def_of_const (constr_of_monomorphic_global functional_ref))) - (EConstr.of_constr f_constr::List.map mkVar x) - ); - is_main_branch = true; - is_final = true; - values_and_bounds = []; - eqs = []; - forbidden_ids = []; - acc_inv = lazy (assert false); - acc_id = Id.of_string "____"; - args_assoc = []; - f_id = Id.of_string "______"; - rec_arg_id = Id.of_string "______"; - is_mes = false; - ih = Id.of_string "______"; - } - ) - )) lemma in - let _ = Flags.silently (fun () -> Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None) () in - () -(* Pp.msgnl (fun _ _ -> str "eqn finished"); *) + observe_tac + (fun _ _ -> str "start_equation") + (observe_tclTHENLIST + (fun _ _ -> str "start_equation") + [ h_intros x + ; Proofview.V82.of_tactic + (unfold_in_concl + [(Locus.AllOccurrences, evaluable_of_global_reference f)]) + ; observe_tac + (fun _ _ -> str "simplest_case") + (Proofview.V82.of_tactic + (simplest_case + (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))) + ; observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x) ]) + g +let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref + equation_lemma_type = + let open CVars in + let opacity = + match terminate_ref with + | GlobRef.ConstRef c -> is_opaque_constant c + | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") + in + let evd = Evd.from_ctx uctx in + let f_constr = constr_of_monomorphic_global f_ref in + let equation_lemma_type = subst1 f_constr equation_lemma_type in + let lemma = + Lemmas.start_lemma ~name:eq_name ~poly:false evd + (EConstr.of_constr equation_lemma_type) + in + let lemma = + fst + @@ Lemmas.by + (Proofview.V82.tactic + (start_equation f_ref terminate_ref (fun x -> + prove_eq + (fun _ -> tclIDTAC) + { nb_arg + ; f_terminate = + EConstr.of_constr + (constr_of_monomorphic_global terminate_ref) + ; f_constr = EConstr.of_constr f_constr + ; concl_tac = Tacticals.New.tclIDTAC + ; func = functional_ref + ; info = + instantiate_lambda Evd.empty + (EConstr.of_constr + (def_of_const + (constr_of_monomorphic_global functional_ref))) + (EConstr.of_constr f_constr :: List.map mkVar x) + ; is_main_branch = true + ; is_final = true + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; acc_inv = lazy (assert false) + ; acc_id = Id.of_string "____" + ; args_assoc = [] + ; f_id = Id.of_string "______" + ; rec_arg_id = Id.of_string "______" + ; is_mes = false + ; ih = Id.of_string "______" }))) + lemma + in + let _ = + Flags.silently + (fun () -> Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None) + () + in + () -let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : Lemmas.t option = +(* Pp.msgnl (fun _ _ -> str "eqn finished"); *) + +let recursive_definition ~interactive_proof ~is_mes function_name rec_impls + type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : + Lemmas.t option = let open Term in let open Constr in let open CVars in - let env = Global.env() in + let env = Global.env () in let evd = Evd.from_env env in - let evd, function_type = interp_type_evars ~program_mode:false env evd type_of_f in - let function_r = Sorts.Relevant in (* TODO relevance *) - let env = EConstr.push_named (Context.Named.Declaration.LocalAssum (make_annot function_name function_r,function_type)) env in + let evd, function_type = + interp_type_evars ~program_mode:false env evd type_of_f + in + let function_r = Sorts.Relevant in + (* TODO relevance *) + let env = + EConstr.push_named + (Context.Named.Declaration.LocalAssum + (make_annot function_name function_r, function_type)) + env + in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let evd, ty = interp_type_evars ~program_mode:false env evd ~impls:rec_impls eq in + let evd, ty = + interp_type_evars ~program_mode:false env evd ~impls:rec_impls eq + in let evd = Evd.minimize_universes evd in - let equation_lemma_type = Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) in - let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd function_type in + let equation_lemma_type = + Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) + in + let function_type = + EConstr.to_constr ~abort_on_undefined_evars:false evd function_type + in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in - (* Pp.msgnl (fun _ _ -> str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) - let res_vars,eq' = decompose_prod equation_lemma_type in - let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in + (* Pp.msgnl (fun _ _ -> str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) + let res_vars, eq' = decompose_prod equation_lemma_type in + let env_eq' = + Environ.push_rel_context + (List.map (fun (x, y) -> LocalAssum (x, y)) res_vars) + env + in let eq' = Reductionops.nf_zeta env_eq' evd (EConstr.of_constr eq') in let eq' = EConstr.Unsafe.to_constr eq' in let res = -(* Pp.msgnl (fun _ _ -> str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) -(* Pp.msgnl (fun _ _ -> str "rec_arg_num := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) -(* Pp.msgnl (fun _ _ -> str "eq' := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) + (* Pp.msgnl (fun _ _ -> str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) + (* Pp.msgnl (fun _ _ -> str "rec_arg_num := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) + (* Pp.msgnl (fun _ _ -> str "eq' := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) match Constr.kind eq' with - | App(e,[|_;_;eq_fix|]) -> - mkLambda (make_annot (Name function_name) Sorts.Relevant,function_type,subst_var function_name (compose_lam res_vars eq_fix)) - | _ -> failwith "Recursive Definition (res not eq)" + | App (e, [|_; _; eq_fix|]) -> + mkLambda + ( make_annot (Name function_name) Sorts.Relevant + , function_type + , subst_var function_name (compose_lam res_vars eq_fix) ) + | _ -> failwith "Recursive Definition (res not eq)" + in + let pre_rec_args, function_type_before_rec_arg = + decompose_prod_n (rec_arg_num - 1) function_type + in + let _, rec_arg_type, _ = destProd function_type_before_rec_arg in + let arg_types = + List.rev_map snd + (fst (decompose_prod_n (List.length res_vars) function_type)) in - let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in - let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in - let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in let equation_id = add_suffix function_name "_equation" in - let functional_id = add_suffix function_name "_F" in + let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = let univs = Evd.univ_entry ~poly:false evd in @@ -1495,57 +1711,61 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type in (* Refresh the global universes, now including those of _F *) let evd = Evd.from_env (Global.env ()) in - let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in - let relation, evuctx = - interp_constr env_with_pre_rec_args evd r + let env_with_pre_rec_args = + push_rel_context + (List.map (function x, t -> LocalAssum (x, t)) pre_rec_args) + env in + let relation, evuctx = interp_constr env_with_pre_rec_args evd r in let evd = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref Undefined in (* let _ = Pp.msgnl (fun _ _ -> str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook { DeclareDef.Hook.S.uctx ; _ } = + let hook {DeclareDef.Hook.S.uctx; _} = let term_ref = Nametab.locate (qualid_of_ident term_id) in - let f_ref = declare_f function_name Decls.(IsProof Lemma) arg_types term_ref in - let _ = Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] in + let f_ref = + declare_f function_name Decls.(IsProof Lemma) arg_types term_ref + in + let _ = + Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] + in (* message "start second proof"; *) let stop = (* XXX: What is the correct way to get sign at hook time *) try - com_eqn uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); + com_eqn uctx (List.length res_vars) equation_id functional_ref f_ref + term_ref + (subst_var function_name equation_lemma_type); false with e when CErrors.noncritical e -> - begin - if do_observe () - then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) - else CErrors.user_err ~hdr:"Cannot create equation Lemma" - (str "Cannot create equation lemma." ++ spc () ++ - str "This may be because the function is nested-recursive.") - ; - true - end + if do_observe () then + Feedback.msg_debug + (str "Cannot create equation Lemma " ++ CErrors.print e) + else + CErrors.user_err ~hdr:"Cannot create equation Lemma" + ( str "Cannot create equation lemma." + ++ spc () + ++ str "This may be because the function is nested-recursive." ); + true in - if not stop - then - let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in + if not stop then + let eq_ref = Nametab.locate (qualid_of_ident equation_id) in let f_ref = destConst (constr_of_monomorphic_global f_ref) - and functional_ref = destConst (constr_of_monomorphic_global functional_ref) + and functional_ref = + destConst (constr_of_monomorphic_global functional_ref) and eq_ref = destConst (constr_of_monomorphic_global eq_ref) in - generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num + generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref + rec_arg_num (EConstr.of_constr rec_arg_type) - (nb_prod evd (EConstr.of_constr res)) relation + (nb_prod evd (EConstr.of_constr res)) + relation in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) - funind_purify (fun () -> - com_terminate - interactive_proof - tcc_lemma_name - tcc_lemma_constr - is_mes functional_ref + funind_purify + (fun () -> + com_terminate interactive_proof tcc_lemma_name tcc_lemma_constr is_mes + functional_ref (EConstr.of_constr rec_arg_type) - relation rec_arg_num - term_id - using_lemmas - (List.length res_vars) - evd (DeclareDef.Hook.make hook)) + relation rec_arg_num term_id using_lemmas (List.length res_vars) evd + (DeclareDef.Hook.make hook)) () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 3225411c85..4e5146e37c 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -1,13 +1,13 @@ open Constr -val tclUSER_if_not_mes - : unit Proofview.tactic +val tclUSER_if_not_mes : + unit Proofview.tactic -> bool -> Names.Id.t list option -> unit Proofview.tactic -val recursive_definition - : interactive_proof:bool +val recursive_definition : + interactive_proof:bool -> is_mes:bool -> Names.Id.t -> Constrintern.internalization_env @@ -15,7 +15,14 @@ val recursive_definition -> Constrexpr.constr_expr -> int -> Constrexpr.constr_expr - -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) + -> ( pconstant + -> Indfun_common.tcc_lemma_value ref + -> pconstant + -> pconstant + -> int + -> EConstr.types + -> int + -> EConstr.constr + -> unit) -> Constrexpr.constr_expr list -> Lemmas.t option diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 7b1aa7a07a..7754fe401e 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -346,7 +346,7 @@ open Vars let constr_flags () = { Pretyping.use_typeclasses = Pretyping.UseTC; - Pretyping.solve_unification_constraints = Pfedit.use_unification_heuristics (); + Pretyping.solve_unification_constraints = Proof.use_unification_heuristics (); Pretyping.fail_evar = false; Pretyping.expand_evars = true; Pretyping.program_mode = false; @@ -918,7 +918,7 @@ END VERNAC COMMAND EXTEND GrabEvars STATE proof | [ "Grab" "Existential" "Variables" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.V82.grab_evars p) pstate } + -> { fun ~pstate -> Declare.Proof.map_proof (fun p -> Proof.V82.grab_evars p) pstate } END (* Shelves all the goals under focus. *) @@ -950,7 +950,7 @@ END VERNAC COMMAND EXTEND Unshelve STATE proof | [ "Unshelve" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.unshelve p) pstate } + -> { fun ~pstate -> Declare.Proof.map_proof (fun p -> Proof.unshelve p) pstate } END (* Gives up on the goals under focus: the goals are considered solved, @@ -1102,7 +1102,7 @@ END VERNAC COMMAND EXTEND OptimizeProof | ![ proof ] [ "Optimize" "Proof" ] => { classify_as_proofstep } -> - { fun ~pstate -> Proof_global.compact_the_proof pstate } + { fun ~pstate -> Declare.Proof.compact pstate } | [ "Optimize" "Heap" ] => { classify_as_proofstep } -> { Gc.compact () } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 2bd4211c90..e713ab13b2 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -364,12 +364,12 @@ let print_info_trace = let vernac_solve ~pstate n info tcom b = let open Goal_select in - let pstate, status = Proof_global.map_fold_proof_endline (fun etac p -> + let pstate, status = Declare.Proof.map_fold_proof_endline (fun etac p -> let with_end_tac = if b then Some etac else None in let global = match n with SelectAll | SelectList _ -> true | _ -> false in let info = Option.append info (print_info_trace ()) in let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + Proof.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p in (* in case a strict subtree was completed, go back to the top of the prooftree *) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 321b05b97c..35e131020b 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -639,7 +639,7 @@ let solve_remaining_by env sigma holes by = let env = Environ.reset_with_named_context evi.evar_hyps env in let ty = evi.evar_concl in let name, poly = Id.of_string "rewrite", false in - let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma ty solve_tac in + let c, sigma = Proof.refine_by_tactic ~name ~poly env sigma ty solve_tac in Evd.define evk (EConstr.of_constr c) sigma in List.fold_left solve sigma indep @@ -1864,14 +1864,14 @@ let proper_projection env sigma r ty = Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx -let declare_projection n instance_id r = +let declare_projection name instance_id r = let poly = Global.is_polymorphic r in let env = Global.env () in let sigma = Evd.from_env env in let sigma,c = Evd.fresh_global env sigma r in let ty = Retyping.get_type_of env sigma c in - let term = proper_projection env sigma c ty in - let sigma, typ = Typing.type_of env sigma term in + let body = proper_projection env sigma c ty in + let sigma, typ = Typing.type_of env sigma body in let ctx, typ = decompose_prod_assum sigma typ in let typ = let n = @@ -1892,14 +1892,11 @@ let declare_projection n instance_id r = let ctx,ccl = Reductionops.splay_prod_n env sigma (3 * n) typ in it_mkProd_or_LetIn ccl ctx in - let typ = it_mkProd_or_LetIn typ ctx in - let univs = Evd.univ_entry ~poly sigma in - let typ = EConstr.to_constr sigma typ in - let term = EConstr.to_constr sigma term in - let cst = Declare.definition_entry ~types:typ ~univs term in - let _ : Constant.t = - Declare.declare_constant ~name:n ~kind:Decls.(IsDefinition Definition) - (Declare.DefinitionEntry cst) + let types = Some (it_mkProd_or_LetIn typ ctx) in + let kind, opaque, scope = Decls.(IsDefinition Definition), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let impargs, udecl = [], UState.default_univ_decl in + let _r : GlobRef.t = + DeclareDef.declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ~poly ~types ~body sigma in () let build_morphism_signature env sigma m = @@ -1927,10 +1924,7 @@ let build_morphism_signature env sigma m = in let morph = e_app_poly env evd (PropGlobal.proper_type env) [| t; sig_; m |] in let evd = solve_constraints env !evd in - let evd = Evd.minimize_universes evd in - let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in - Pretyping.check_evars env evd (EConstr.of_constr m); - Evd.evar_universe_context evd, m + evd, morph let default_morphism sign m = let env = Global.env () in @@ -1965,22 +1959,24 @@ let add_morphism_as_parameter atts m n : unit = let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in - let uctx, instance = build_morphism_signature env evd m in - let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in - let cst = Declare.declare_constant ~name:instance_id - ~kind:Decls.(IsAssumption Logical) - (Declare.ParameterEntry (None,(instance,uctx),None)) - in - Classes.add_instance (Classes.mk_instance - (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (GlobRef.ConstRef cst)); - declare_projection n instance_id (GlobRef.ConstRef cst) + let poly = atts.polymorphic in + let kind, opaque, scope = Decls.(IsAssumption Logical), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let impargs, udecl = [], UState.default_univ_decl in + let evd, types = build_morphism_signature env evd m in + let evd, pe = DeclareDef.prepare_parameter ~poly ~udecl ~types evd in + let cst = Declare.declare_constant ~name:instance_id ~kind (Declare.ParameterEntry pe) in + let cst = GlobRef.ConstRef cst in + Classes.add_instance + (Classes.mk_instance + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global cst); + declare_projection n instance_id cst let add_morphism_interactive atts m n : Lemmas.t = init_setoid (); let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in - let uctx, instance = build_morphism_signature env evd m in + let evd, morph = build_morphism_signature env evd m in let poly = atts.polymorphic in let kind = Decls.(IsDefinition Instance) in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in @@ -1996,7 +1992,7 @@ let add_morphism_interactive atts m n : Lemmas.t = let info = Lemmas.Info.make ~hook ~kind () in Flags.silently (fun () -> - let lemma = Lemmas.start_lemma ~name:instance_id ~poly ~info (Evd.from_ctx uctx) (EConstr.of_constr instance) in + let lemma = Lemmas.start_lemma ~name:instance_id ~poly ~info evd morph in fst (Lemmas.by (Tacinterp.interp tac) lemma)) () let add_morphism atts binders m s n = diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 4127d28bae..9910796d9c 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -299,7 +299,7 @@ let classify_tactic_notation tacobj = Substitute tacobj let inTacticGrammar : tactic_grammar_obj -> obj = declare_object {(default_object "TacticGrammar") with - open_function = open_tactic_notation; + open_function = simple_open open_tactic_notation; load_function = load_tactic_notation; cache_function = cache_tactic_notation; subst_function = subst_tactic_notation; diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index ce9189792e..76d47f5482 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -182,7 +182,7 @@ let inMD : bool * ltac_constant option * bool * glob_tactic_expr * declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; - open_function = open_md; + open_function = simple_open open_md; subst_function = subst_md; classify_function = classify_md} diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index b0e26e1def..dda7f0742c 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -2070,7 +2070,7 @@ let _ = *) let name, poly = Id.of_string "ltac_gen", poly in let name, poly = Id.of_string "ltac_gen", poly in - let (c, sigma) = Pfedit.refine_by_tactic ~name ~poly env sigma ty tac in + let (c, sigma) = Proof.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_tactic eval diff --git a/plugins/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml index 4f00f17892..922d2f7792 100644 --- a/plugins/ltac/tactic_option.ml +++ b/plugins/ltac/tactic_option.ml @@ -32,7 +32,7 @@ let declare_tactic_option ?(default=Tacexpr.TacId []) name = { (default_object name) with cache_function = cache; load_function = (fun _ -> load); - open_function = (fun _ -> load); + open_function = simple_open (fun _ -> load); classify_function = (fun (local, tac) -> if local then Dispose else Substitute (local, tac)); subst_function = subst} diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index a006c82993..cb868e0480 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -60,12 +60,20 @@ let glob_sort_family = let open Sorts in function | UNamed [GSet,0] -> InSet | _ -> raise ComplexSort -let glob_sort_eq u1 u2 = match u1, u2 with +let glob_sort_expr_eq f u1 u2 = + match u1, u2 with | UAnonymous {rigid=r1}, UAnonymous {rigid=r2} -> r1 = r2 - | UNamed l1, UNamed l2 -> - List.equal (fun (x,m) (y,n) -> glob_sort_name_eq x y && Int.equal m n) l1 l2 + | UNamed l1, UNamed l2 -> f l1 l2 | (UNamed _ | UAnonymous _), _ -> false +let glob_sort_eq u1 u2 = + glob_sort_expr_eq + (List.equal (fun (x,m) (y,n) -> glob_sort_name_eq x y && Int.equal m n)) + u1 u2 + +let glob_level_eq u1 u2 = + glob_sort_expr_eq glob_sort_name_eq u1 u2 + let binding_kind_eq bk1 bk2 = match bk1, bk2 with | Explicit, Explicit -> true | NonMaxImplicit, NonMaxImplicit -> true @@ -123,7 +131,9 @@ let instance_eq f (x1,c1) (x2,c2) = Id.equal x1 x2 && f c1 c2 let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with - | GRef (gr1, _), GRef (gr2, _) -> GlobRef.equal gr1 gr2 + | GRef (gr1, u1), GRef (gr2, u2) -> + GlobRef.equal gr1 gr2 && + Option.equal (List.equal glob_level_eq) u1 u2 | GVar id1, GVar id2 -> Id.equal id1 id2 | GEvar (id1, arg1), GEvar (id2, arg2) -> Id.equal id1 id2 && List.equal (instance_eq f) arg1 arg2 diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 14bf2f6764..6da8173dce 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -15,6 +15,8 @@ open Glob_term val glob_sort_eq : Glob_term.glob_sort -> Glob_term.glob_sort -> bool +val glob_level_eq : Glob_term.glob_level -> Glob_term.glob_level -> bool + val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool (** Expect a Prop/SProp/Set/Type universe; raise [ComplexSort] if diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 015c26531a..940150b15a 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -438,7 +438,15 @@ let pretype_ref ?loc sigma env ref us = match ref with | GlobRef.VarRef id -> (* Section variable *) - (try sigma, make_judge (mkVar id) (NamedDecl.get_type (lookup_named id !!env)) + (try + let ty = NamedDecl.get_type (lookup_named id !!env) in + (match us with + | None | Some [] -> () + | Some (_ :: _) -> + CErrors.user_err ?loc + Pp.(str "Section variables are not polymorphic:" ++ spc () + ++ str "universe instance should have length 0.")); + sigma, make_judge (mkVar id) ty with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal diff --git a/proofs/proof.ml b/proofs/proof.ml index 21006349d2..75aca7e7ff 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -63,7 +63,7 @@ exception CannotUnfocusThisWay (* Cannot focus on non-existing subgoals *) exception NoSuchGoals of int * int -exception NoSuchGoal of Names.Id.t +exception NoSuchGoal of Names.Id.t option exception FullyUnfocused @@ -74,8 +74,10 @@ let _ = CErrors.register_handler begin function Some Pp.(str "[Focus] No such goal (" ++ int i ++ str").") | NoSuchGoals (i,j) -> Some Pp.(str "[Focus] Not every goal in range ["++ int i ++ str","++int j++str"] exist.") - | NoSuchGoal id -> + | NoSuchGoal (Some id) -> Some Pp.(str "[Focus] No such goal: " ++ str (Names.Id.to_string id) ++ str ".") + | NoSuchGoal None -> + Some Pp.(str "[Focus] No such goal.") | FullyUnfocused -> Some (Pp.str "The proof is not focused") | _ -> None @@ -233,7 +235,7 @@ let focus_id cond inf id pr = raise CannotUnfocusThisWay end | None -> - raise (NoSuchGoal id) + raise (NoSuchGoal (Some id)) end let rec unfocus kind pr () = @@ -506,3 +508,124 @@ let pr_proof p = str "given up: " ++ pr_goal_list given_up ++ str "]" ) + +let use_unification_heuristics = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Solve";"Unification";"Constraints"] + ~value:true + +exception SuggestNoSuchGoals of int * t + +let solve ?with_end_tac gi info_lvl tac pr = + let tac = match with_end_tac with + | None -> tac + | Some etac -> Proofview.tclTHEN tac etac in + let tac = match info_lvl with + | None -> tac + | Some _ -> Proofview.Trace.record_info_trace tac + in + let nosuchgoal = Proofview.tclZERO (SuggestNoSuchGoals (1,pr)) in + let tac = let open Goal_select in match gi with + | SelectAlreadyFocused -> + let open Proofview.Notations in + Proofview.numgoals >>= fun n -> + if n == 1 then tac + else + let e = CErrors.UserError + (None, + Pp.(str "Expected a single focused goal but " ++ + int n ++ str " goals are focused.")) + in + Proofview.tclZERO e + + | SelectNth i -> Proofview.tclFOCUS ~nosuchgoal i i tac + | SelectList l -> Proofview.tclFOCUSLIST ~nosuchgoal l tac + | SelectId id -> Proofview.tclFOCUSID ~nosuchgoal id tac + | SelectAll -> tac + in + let tac = + if use_unification_heuristics () then + Proofview.tclTHEN tac Refine.solve_constraints + else tac + in + let env = Global.env () in + let (p,(status,info),()) = run_tactic env tac pr in + let env = Global.env () in + let sigma = Evd.from_env env in + let () = + match info_lvl with + | None -> () + | Some i -> Feedback.msg_info (Pp.hov 0 (Proofview.Trace.pr_info env sigma ~lvl:i info)) + in + (p,status) + +(**********************************************************************) +(* Shortcut to build a term using tactics *) + +let refine_by_tactic ~name ~poly env sigma ty tac = + (* Save the initial side-effects to restore them afterwards. We set the + current set of side-effects to be empty so that we can retrieve the + ones created during the tactic invocation easily. *) + let eff = Evd.eval_side_effects sigma in + let sigma = Evd.drop_side_effects sigma in + (* Save the existing goals *) + let prev_future_goals = Evd.save_future_goals sigma in + (* Start a proof *) + let prf = start ~name ~poly sigma [env, ty] in + let (prf, _, ()) = + try run_tactic env tac prf + with Logic_monad.TacticFailure e as src -> + (* Catch the inner error of the monad tactic *) + let (_, info) = Exninfo.capture src in + Exninfo.iraise (e, info) + in + (* Plug back the retrieved sigma *) + let { goals; stack; shelf; given_up; sigma; entry } = data prf in + assert (stack = []); + let ans = match Proofview.initial_goals entry with + | [c, _] -> c + | _ -> assert false + in + let ans = EConstr.to_constr ~abort_on_undefined_evars:false sigma ans in + (* [neff] contains the freshly generated side-effects *) + let neff = Evd.eval_side_effects sigma in + (* Reset the old side-effects *) + let sigma = Evd.drop_side_effects sigma in + let sigma = Evd.emit_side_effects eff sigma in + (* Restore former goals *) + let sigma = Evd.restore_future_goals sigma prev_future_goals in + (* Push remaining goals as future_goals which is the only way we + have to inform the caller that there are goals to collect while + not being encapsulated in the monad *) + (* Goals produced by tactic "shelve" *) + let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToShelve) shelf sigma in + (* Goals produced by tactic "give_up" *) + let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToGiveUp) given_up sigma in + (* Other goals *) + let sigma = List.fold_right Evd.declare_future_goal goals sigma in + (* Get rid of the fresh side-effects by internalizing them in the term + itself. Note that this is unsound, because the tactic may have solved + other goals that were already present during its invocation, so that + those goals rely on effects that are not present anymore. Hopefully, + this hack will work in most cases. *) + let neff = neff.Evd.seff_private in + let (ans, _) = Safe_typing.inline_private_constants env ((ans, Univ.ContextSet.empty), neff) in + ans, sigma + +let get_nth_V82_goal p i = + let { sigma; goals } = data p in + try { Evd.it = List.nth goals (i-1) ; sigma } + with Failure _ -> raise (NoSuchGoal None) + +let get_goal_context_gen pf i = + let { Evd.it=goal ; sigma=sigma; } = get_nth_V82_goal pf i in + (sigma, Global.env_of_context (Goal.V82.hyps sigma goal)) + +let get_proof_context p = + try get_goal_context_gen p 1 + with + | NoSuchGoal _ -> + (* No more focused goals *) + let { sigma } = data p in + sigma, Global.env () diff --git a/proofs/proof.mli b/proofs/proof.mli index 1a0b105723..0e5bdaf07d 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -143,6 +143,8 @@ exception CannotUnfocusThisWay Bullet.push. *) exception NoSuchGoals of int * int +exception NoSuchGoal of Names.Id.t option + (* Unfocusing command. Raises [FullyUnfocused] if the proof is not focused. Raises [CannotUnfocusThisWay] if the proof the unfocusing condition @@ -207,3 +209,41 @@ end (* returns the set of all goals in the proof *) val all_goals : t -> Goal.Set.t + +(** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th + subgoal of the current focused proof. [solve SelectAll + tac] applies [tac] to all subgoals. *) + +val solve : + ?with_end_tac:unit Proofview.tactic + -> Goal_select.t + -> int option + -> unit Proofview.tactic + -> t + -> t * bool + +(** Option telling if unification heuristics should be used. *) +val use_unification_heuristics : unit -> bool + +val refine_by_tactic + : name:Names.Id.t + -> poly:bool + -> Environ.env + -> Evd.evar_map + -> EConstr.types + -> unit Proofview.tactic + -> Constr.constr * Evd.evar_map +(** A variant of the above function that handles open terms as well. + Caveat: all effects are purged in the returned term at the end, but other + evars solved by side-effects are NOT purged, so that unexpected failures may + occur. Ideally all code using this function should be rewritten in the + monad. *) + +exception SuggestNoSuchGoals of int * t + +(** {6 Helpers to obtain proof state when in an interactive proof } *) +val get_goal_context_gen : t -> int -> Evd.evar_map * Environ.env + +(** [get_proof_context ()] gets the goal context for the first subgoal + of the proof *) +val get_proof_context : t -> Evd.evar_map * Environ.env diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index f619bc86a1..41cb7399da 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -191,11 +191,8 @@ let put p b = let suggest p = (current_behavior ()).suggest p -(* Better printing for bullet exceptions *) -exception SuggestNoSuchGoals of int * Proof.t - let _ = CErrors.register_handler begin function - | SuggestNoSuchGoals(n,proof) -> + | Proof.SuggestNoSuchGoals(n,proof) -> let suffix = suggest proof in Some (Pp.(str "No such " ++ str (CString.plural n "goal") ++ str "." ++ pr_non_empty_arg (fun x -> x) suffix)) diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli index 687781361c..f15b7824ff 100644 --- a/proofs/proof_bullet.mli +++ b/proofs/proof_bullet.mli @@ -44,5 +44,3 @@ val register_behavior : behavior -> unit *) val put : Proof.t -> t -> Proof.t val suggest : Proof.t -> Pp.t - -exception SuggestNoSuchGoals of int * Proof.t diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 6a78dd5529..2ff76e69f8 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -50,7 +50,7 @@ let is_focused_goal_simple ~doc id = | `Expired | `Error _ | `Valid None -> `Not | `Valid (Some { Vernacstate.lemmas }) -> Option.cata (Vernacstate.LemmaStack.with_top_pstate ~f:(fun proof -> - let proof = Proof_global.get_proof proof in + let proof = Declare.Proof.get_proof proof in let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in if List.for_all (fun x -> simple_goal sigma x rest) focused diff --git a/stm/stm.ml b/stm/stm.ml index 5b88ee3d68..f3768e9b99 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -27,7 +27,7 @@ open Feedback open Vernacexpr open Vernacextend -module PG_compat = Vernacstate.Proof_global [@@ocaml.warning "-3"] +module PG_compat = Vernacstate.Declare [@@ocaml.warning "-3"] let is_vtkeep = function VtKeep _ -> true | _ -> false let get_vtkeep = function VtKeep x -> x | _ -> assert false @@ -147,7 +147,7 @@ let update_global_env () = PG_compat.update_global_env () module Vcs_ = Vcs.Make(Stateid.Self) -type future_proof = Proof_global.closed_proof_output Future.computation +type future_proof = Declare.closed_proof_output Future.computation type depth = int type branch_type = @@ -1164,7 +1164,7 @@ end = struct (* {{{ *) let get_proof ~doc id = match state_of_id ~doc id with - | `Valid (Some vstate) -> Option.map (Vernacstate.LemmaStack.with_top_pstate ~f:Proof_global.get_proof) vstate.Vernacstate.lemmas + | `Valid (Some vstate) -> Option.map (Vernacstate.LemmaStack.with_top_pstate ~f:Declare.Proof.get_proof) vstate.Vernacstate.lemmas | _ -> None let undo_vernac_classifier v ~doc = @@ -1358,7 +1358,7 @@ module rec ProofTask : sig t_stop : Stateid.t; t_drop : bool; t_states : competence; - t_assign : Proof_global.closed_proof_output Future.assignment -> unit; + t_assign : Declare.closed_proof_output Future.assignment -> unit; t_loc : Loc.t option; t_uuid : Future.UUID.t; t_name : string } @@ -1381,7 +1381,7 @@ module rec ProofTask : sig ?loc:Loc.t -> drop_pt:bool -> Stateid.t * Stateid.t -> Stateid.t -> - Proof_global.closed_proof_output Future.computation + Declare.closed_proof_output Future.computation (* If set, only tasks overlapping with this list are processed *) val set_perspective : Stateid.t list -> unit @@ -1397,7 +1397,7 @@ end = struct (* {{{ *) t_stop : Stateid.t; t_drop : bool; t_states : competence; - t_assign : Proof_global.closed_proof_output Future.assignment -> unit; + t_assign : Declare.closed_proof_output Future.assignment -> unit; t_loc : Loc.t option; t_uuid : Future.UUID.t; t_name : string } @@ -1419,7 +1419,7 @@ end = struct (* {{{ *) e_safe_states : Stateid.t list } type response = - | RespBuiltProof of Proof_global.closed_proof_output * float + | RespBuiltProof of Declare.closed_proof_output * float | RespError of error | RespStates of (Stateid.t * State.partial_state) list @@ -1530,7 +1530,7 @@ end = struct (* {{{ *) PG_compat.close_future_proof ~feedback_id:stop (Future.from_val ~fix_exn p) in let st = Vernacstate.freeze_interp_state ~marshallable:false in - let opaque = Proof_global.Opaque in + let opaque = Declare.Opaque in stm_qed_delay_proof ~st ~id:stop ~proof:pobject ~info:(Lemmas.Info.make ()) ~loc ~control:[] (Proved (opaque,None))) in ignore(Future.join checked_proof); @@ -1664,7 +1664,7 @@ end = struct (* {{{ *) let _proof = PG_compat.return_partial_proof () in `OK_ADMITTED else begin - let opaque = Proof_global.Opaque in + let opaque = Declare.Opaque in (* The original terminator, a hook, has not been saved in the .vio*) let proof, _info = @@ -1723,7 +1723,7 @@ end = struct (* {{{ *) | `ERROR -> exit 1 | `ERROR_ADMITTED -> cst, false | `OK_ADMITTED -> cst, false - | `OK { Proof_global.name } -> + | `OK { Declare.name } -> let con = Nametab.locate_constant (Libnames.qualid_of_ident name) in let c = Global.lookup_constant con in let o = match c.Declarations.const_body with @@ -2149,7 +2149,7 @@ let collect_proof keep cur hd brkind id = | id :: _ -> Names.Id.to_string id in let loc = (snd cur).expr.CAst.loc in let is_defined_expr = function - | VernacEndProof (Proved (Proof_global.Transparent,_)) -> true + | VernacEndProof (Proved (Declare.Transparent,_)) -> true | _ -> false in let is_defined = function | _, { expr = e } -> is_defined_expr e.CAst.v.expr @@ -2310,7 +2310,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = Option.iter PG_compat.unfreeze lemmas; PG_compat.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; - fst (Pfedit.solve Goal_select.SelectAll None tac p), ()); + fst (Proof.solve Goal_select.SelectAll None tac p), ()); (* STATE SPEC: * - start: Modifies the input state adding a proof. * - end : maybe after recovery command. @@ -2514,7 +2514,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeep VtKeepAxiom -> qed.fproof <- Some (None, ref false); None | VtKeep opaque -> - let opaque = let open Proof_global in match opaque with + let opaque = let open Declare in match opaque with | VtKeepOpaque -> Opaque | VtKeepDefined -> Transparent | VtKeepAxiom -> assert false in diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 567acb1c73..cf127648b4 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -37,7 +37,7 @@ let string_of_vernac_classification = function | VtMeta -> "Meta " | VtProofMode _ -> "Proof Mode" -let vtkeep_of_opaque = let open Proof_global in function +let vtkeep_of_opaque = let open Declare in function | Opaque -> VtKeepOpaque | Transparent -> VtKeepDefined diff --git a/tactics/abstract.ml b/tactics/abstract.ml index e85d94cd72..0e78a03f45 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -11,7 +11,6 @@ open Util open Termops open EConstr -open Evarutil module NamedDecl = Context.Named.Declaration @@ -76,61 +75,9 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = | None -> Proofview.Goal.concl gl | Some ty -> ty in let concl = it_mkNamedProd_or_LetIn concl sign in - let concl = - try flush_and_check_evars sigma concl - with Uninstantiated_evar _ -> - CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials.") in - - let sigma, ctx, concl = - (* FIXME: should be done only if the tactic succeeds *) - let sigma = Evd.minimize_universes sigma in - let ctx = Evd.universe_context_set sigma in - sigma, ctx, Evarutil.nf_evars_universes sigma concl - in - let concl = EConstr.of_constr concl in let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) Tactics.intro) tac) in - let ectx = Evd.evar_universe_context sigma in - let (const, safe, ectx) = - try Pfedit.build_constant_by_tactic ~name ~opaque:Proof_global.Transparent ~poly ~uctx:ectx ~sign:secsign concl solve_tac - with Logic_monad.TacticFailure e as src -> - (* if the tactic [tac] fails, it reports a [TacticFailure e], - which is an error irrelevant to the proof system (in fact it - means that [e] comes from [tac] failing to yield enough - success). Hence it reraises [e]. *) - let (_, info) = Exninfo.capture src in - Exninfo.iraise (e, info) - in - let body, effs = Future.force const.Declare.proof_entry_body in - (* We drop the side-effects from the entry, they already exist in the ambient environment *) - let const = Declare.Internal.map_entry_body const ~f:(fun _ -> body, ()) in - (* EJGA: Hack related to the above call to - `build_constant_by_tactic` with `~opaque:Transparent`. Even if - the abstracted term is destined to be opaque, if we trigger the - `if poly && opaque && private_poly_univs ()` in `Proof_global` - kernel will boom. This deserves more investigation. *) - let const = Declare.Internal.set_opacity ~opaque const in - let const, args = Declare.Internal.shrink_entry sign const in - let args = List.map EConstr.of_constr args in - let cst () = - (* do not compute the implicit arguments, it may be costly *) - let () = Impargs.make_implicit_args false in - (* ppedrot: seems legit to have abstracted subproofs as local*) - Declare.declare_private_constant ~local:Declare.ImportNeedQualified ~name ~kind const - in - let cst, eff = Impargs.with_implicit_protection cst () in - let inst = match const.Declare.proof_entry_universes with - | Entries.Monomorphic_entry _ -> EInstance.empty - | Entries.Polymorphic_entry (_, ctx) -> - (* We mimic what the kernel does, that is ensuring that no additional - constraints appear in the body of polymorphic constants. Ideally this - should be enforced statically. *) - let (_, body_uctx), _ = Future.force const.Declare.proof_entry_body in - let () = assert (Univ.ContextSet.is_empty body_uctx) in - EInstance.make (Univ.UContext.instance ctx) - in - let lem = mkConstU (cst, inst) in - let sigma = Evd.set_universe_context sigma ectx in - let effs = Evd.concat_side_effects eff effs in + let effs, sigma, lem, args, safe = + Declare.declare_abstract ~name ~poly ~sign ~secsign ~kind ~opaque ~solve_tac sigma concl in let solve = Proofview.tclEFFECTS effs <*> tacK lem args diff --git a/tactics/declare.ml b/tactics/declare.ml index 324007930a..cce43e833e 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -13,11 +13,112 @@ open Pp open Util open Names -open Declarations -open Entries open Safe_typing -open Libobject -open Lib +module NamedDecl = Context.Named.Declaration + +type opacity_flag = Opaque | Transparent + +type t = + { endline_tactic : Genarg.glob_generic_argument option + ; section_vars : Id.Set.t option + ; proof : Proof.t + ; udecl: UState.universe_decl + (** Initial universe declarations *) + ; initial_euctx : UState.t + (** The initial universe context (for the statement) *) + } + +(*** Proof Global manipulation ***) + +let get_proof ps = ps.proof +let get_proof_name ps = (Proof.data ps.proof).Proof.name + +let get_initial_euctx ps = ps.initial_euctx + +let map_proof f p = { p with proof = f p.proof } +let map_fold_proof f p = let proof, res = f p.proof in { p with proof }, res + +let map_fold_proof_endline f ps = + let et = + match ps.endline_tactic with + | None -> Proofview.tclUNIT () + | Some tac -> + let open Geninterp in + let {Proof.poly} = Proof.data ps.proof in + let ist = { lfun = Id.Map.empty; poly; extra = TacStore.empty } in + let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in + let tac = Geninterp.interp tag ist tac in + Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) + in + let (newpr,ret) = f et ps.proof in + let ps = { ps with proof = newpr } in + ps, ret + +let compact_the_proof pf = map_proof Proof.compact pf + +(* Sets the tactic to be used when a tactic line is closed with [...] *) +let set_endline_tactic tac ps = + { ps with endline_tactic = Some tac } + +(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of + name [name] with goals [goals] (a list of pairs of environment and + conclusion). The proof is started in the evar map [sigma] (which + can typically contain universe constraints), and with universe + bindings [udecl]. *) +let start_proof ~name ~udecl ~poly sigma goals = + let proof = Proof.start ~name ~poly sigma goals in + let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in + { proof + ; endline_tactic = None + ; section_vars = None + ; udecl + ; initial_euctx + } + +let start_dependent_proof ~name ~udecl ~poly goals = + let proof = Proof.dependent_start ~name ~poly goals in + let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in + { proof + ; endline_tactic = None + ; section_vars = None + ; udecl + ; initial_euctx + } + +let get_used_variables pf = pf.section_vars +let get_universe_decl pf = pf.udecl + +let set_used_variables ps l = + let open Context.Named.Declaration in + let env = Global.env () in + let ids = List.fold_right Id.Set.add l Id.Set.empty in + let ctx = Environ.keep_hyps env ids in + let ctx_set = + List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in + let vars_of = Environ.global_vars_set in + let aux env entry (ctx, all_safe as orig) = + match entry with + | LocalAssum ({Context.binder_name=x},_) -> + if Id.Set.mem x all_safe then orig + else (ctx, all_safe) + | LocalDef ({Context.binder_name=x},bo, ty) as decl -> + if Id.Set.mem x all_safe then orig else + let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in + if Id.Set.subset vars all_safe + then (decl :: ctx, Id.Set.add x all_safe) + else (ctx, all_safe) in + let ctx, _ = + Environ.fold_named_context aux env ~init:(ctx,ctx_set) in + if not (Option.is_empty ps.section_vars) then + CErrors.user_err Pp.(str "Used section variables can be declared only once"); + ctx, { ps with section_vars = Some (Context.Named.to_vars ctx) } + +let get_open_goals ps = + let Proof.{ goals; stack; shelf } = Proof.data ps.proof in + List.length goals + + List.fold_left (+) 0 + (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + + List.length shelf (* object_kind , id *) exception AlreadyDeclared of (string option * Id.t) @@ -30,8 +131,6 @@ let _ = CErrors.register_handler (function | _ -> None) -module NamedDecl = Context.Named.Declaration - type import_status = ImportDefaultBehavior | ImportNeedQualified (** Monomorphic universes need to survive sections. *) @@ -78,10 +177,118 @@ type 'a proof_entry = { proof_entry_inline_code : bool; } +let default_univ_entry = Entries.Monomorphic_entry Univ.ContextSet.empty + +let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?feedback_id ?section_vars ?types + ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) ?(univsbody=Univ.ContextSet.empty) body = + { proof_entry_body = Future.from_val ?fix_exn ((body,univsbody), eff); + proof_entry_secctx = section_vars; + proof_entry_type = types; + proof_entry_universes = univs; + proof_entry_opaque = opaque; + proof_entry_feedback = feedback_id; + proof_entry_inline_code = inline} + +type proof_object = + { name : Names.Id.t + (* [name] only used in the STM *) + ; entries : Evd.side_effects proof_entry list + ; uctx: UState.t + } + +let private_poly_univs = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Private";"Polymorphic";"Universes"] + ~value:true + +(* XXX: This is still separate from close_proof below due to drop_pt in the STM *) +(* XXX: Unsafe_typ:true is needed by vio files, see bf0499bc507d5a39c3d5e3bf1f69191339270729 *) +let prepare_proof ~unsafe_typ { proof } = + let Proof.{name=pid;entry;poly} = Proof.data proof in + let initial_goals = Proofview.initial_goals entry in + let evd = Proof.return ~pid proof in + let eff = Evd.eval_side_effects evd in + let evd = Evd.minimize_universes evd in + let to_constr_body c = + match EConstr.to_constr_opt evd c with + | Some p -> p + | None -> CErrors.user_err Pp.(str "Some unresolved existential variables remain") + in + let to_constr_typ t = + if unsafe_typ then EConstr.Unsafe.to_constr t else to_constr_body t + in + (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate + side-effects... This may explain why one need to uniquize side-effects + thereafter... *) + (* EJGA: actually side-effects de-duplication and this codepath is + unrelated. Duplicated side-effects arise from incorrect scheme + generation code, the main bulk of it was mostly fixed by #9836 + but duplication can still happen because of rewriting schemes I + think; however the code below is mostly untested, the only + code-paths that generate several proof entries are derive and + equations and so far there is no code in the CI that will + actually call those and do a side-effect, TTBOMK *) + (* EJGA: likely the right solution is to attach side effects to the first constant only? *) + let proofs = List.map (fun (body, typ) -> (to_constr_body body, eff), to_constr_typ typ) initial_goals in + proofs, Evd.evar_universe_context evd + +let close_proof ~opaque ~keep_body_ucst_separate ps = + + let { section_vars; proof; udecl; initial_euctx } = ps in + let { Proof.name; poly } = Proof.data proof in + let unsafe_typ = keep_body_ucst_separate && not poly in + let elist, uctx = prepare_proof ~unsafe_typ ps in + let opaque = match opaque with Opaque -> true | Transparent -> false in + + let make_entry ((body, eff), typ) = + + let allow_deferred = + not poly && + (keep_body_ucst_separate + || not (Safe_typing.is_empty_private_constants eff.Evd.seff_private)) + in + let used_univs_body = Vars.universes_of_constr body in + let used_univs_typ = Vars.universes_of_constr typ in + let used_univs = Univ.LSet.union used_univs_body used_univs_typ in + let utyp, ubody = + if allow_deferred then + let utyp = UState.univ_entry ~poly initial_euctx in + let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in + (* For vi2vo compilation proofs are computed now but we need to + complement the univ constraints of the typ with the ones of + the body. So we keep the two sets distinct. *) + let uctx_body = UState.restrict uctx used_univs in + let ubody = UState.check_mono_univ_decl uctx_body udecl in + utyp, ubody + else if poly && opaque && private_poly_univs () then + let universes = UState.restrict uctx used_univs in + let typus = UState.restrict universes used_univs_typ in + let utyp = UState.check_univ_decl ~poly typus udecl in + let ubody = Univ.ContextSet.diff + (UState.context_set universes) + (UState.context_set typus) + in + utyp, ubody + else + (* Since the proof is computed now, we can simply have 1 set of + constraints in which we merge the ones for the body and the ones + for the typ. We recheck the declaration after restricting with + the actually used universes. + TODO: check if restrict is really necessary now. *) + let ctx = UState.restrict uctx used_univs in + let utyp = UState.check_univ_decl ~poly ctx udecl in + utyp, Univ.ContextSet.empty + in + definition_entry ~opaque ?section_vars ~univs:utyp ~univsbody:ubody ~types:typ ~eff body + in + let entries = CList.map make_entry elist in + { name; entries; uctx } + type 'a constant_entry = | DefinitionEntry of 'a proof_entry - | ParameterEntry of parameter_entry - | PrimitiveEntry of primitive_entry + | ParameterEntry of Entries.parameter_entry + | PrimitiveEntry of Entries.primitive_entry (* At load-time, the segment starting from the module name to the discharge *) (* section (if Remark or Fact) is needed to access a construction *) @@ -93,13 +300,14 @@ let load_constant i ((sp,kn), obj) = Dumpglob.add_constant_kind con obj.cst_kind (* Opening means making the name without its module qualification available *) -let open_constant i ((sp,kn), obj) = +let open_constant f i ((sp,kn), obj) = (* Never open a local definition *) match obj.cst_locl with | ImportNeedQualified -> () | ImportDefaultBehavior -> let con = Global.constant_of_delta_kn kn in - Nametab.push (Nametab.Exactly i) sp (GlobRef.ConstRef con) + if Libobject.in_filter_ref (GlobRef.ConstRef con) f then + Nametab.push (Nametab.Exactly i) sp (GlobRef.ConstRef con) let exists_name id = Decls.variable_exists id || Global.exists_objlabel (Label.of_id id) @@ -129,9 +337,10 @@ let dummy_constant cst = { cst_locl = cst.cst_locl; } -let classify_constant cst = Substitute (dummy_constant cst) +let classify_constant cst = Libobject.Substitute (dummy_constant cst) let (objConstant : constant_obj Libobject.Dyn.tag) = + let open Libobject in declare_object_full { (default_object "CONSTANT") with cache_function = cache_constant; load_function = load_constant; @@ -152,7 +361,7 @@ let register_constant kn kind local = cst_locl = local; } in let id = Label.to_id (Constant.label kn) in - let _ = add_leaf id o in + let _ = Lib.add_leaf id o in update_tables kn let register_side_effect (c, role) = @@ -185,18 +394,6 @@ let record_aux env s_ty s_bo = (keep_hyps env s_bo)) in Aux_file.record_in_aux "context_used" v -let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty - -let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?feedback_id ?section_vars ?types - ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) ?(univsbody=Univ.ContextSet.empty) body = - { proof_entry_body = Future.from_val ?fix_exn ((body,univsbody), eff); - proof_entry_secctx = section_vars; - proof_entry_type = types; - proof_entry_universes = univs; - proof_entry_opaque = opaque; - proof_entry_feedback = feedback_id; - proof_entry_inline_code = inline} - let pure_definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types ?(univs=default_univ_entry) body = { proof_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), ()); @@ -207,14 +404,14 @@ let pure_definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types proof_entry_feedback = None; proof_entry_inline_code = inline} -let delayed_definition_entry ?(opaque=false) ?(inline=false) ?feedback_id ?section_vars ?(univs=default_univ_entry) ?types body = +let delayed_definition_entry ~opaque ?feedback_id ~section_vars ~univs ?types body = { proof_entry_body = body ; proof_entry_secctx = section_vars ; proof_entry_type = types ; proof_entry_universes = univs ; proof_entry_opaque = opaque ; proof_entry_feedback = feedback_id - ; proof_entry_inline_code = inline + ; proof_entry_inline_code = false } let cast_proof_entry e = @@ -222,14 +419,13 @@ let cast_proof_entry e = let univs = if Univ.ContextSet.is_empty ctx then e.proof_entry_universes else match e.proof_entry_universes with - | Monomorphic_entry ctx' -> + | Entries.Monomorphic_entry ctx' -> (* This can actually happen, try compiling EqdepFacts for instance *) - Monomorphic_entry (Univ.ContextSet.union ctx' ctx) - | Polymorphic_entry _ -> + Entries.Monomorphic_entry (Univ.ContextSet.union ctx' ctx) + | Entries.Polymorphic_entry _ -> CErrors.anomaly Pp.(str "Local universes in non-opaque polymorphic definition."); in - { - const_entry_body = body; + { Entries.const_entry_body = body; const_entry_secctx = e.proof_entry_secctx; const_entry_feedback = e.proof_entry_feedback; const_entry_type = e.proof_entry_type; @@ -241,7 +437,7 @@ type ('a, 'b) effect_entry = | EffectEntry : (private_constants, private_constants Entries.const_entry_body) effect_entry | PureEntry : (unit, Constr.constr) effect_entry -let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proof_entry) : b opaque_entry = +let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proof_entry) : b Entries.opaque_entry = let typ = match e.proof_entry_type with | None -> assert false | Some typ -> typ @@ -275,16 +471,16 @@ let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proo | PureEntry -> let (body, uctx), () = Future.force e.proof_entry_body in let univs = match e.proof_entry_universes with - | Monomorphic_entry uctx' -> Monomorphic_entry (Univ.ContextSet.union uctx uctx') - | Polymorphic_entry _ -> + | Entries.Monomorphic_entry uctx' -> + Entries.Monomorphic_entry (Univ.ContextSet.union uctx uctx') + | Entries.Polymorphic_entry _ -> assert (Univ.ContextSet.is_empty uctx); e.proof_entry_universes in body, univs | EffectEntry -> e.proof_entry_body, e.proof_entry_universes in - { - opaque_entry_body = body; + { Entries.opaque_entry_body = body; opaque_entry_secctx = secctx; opaque_entry_feedback = e.proof_entry_feedback; opaque_entry_type = typ; @@ -294,6 +490,7 @@ let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proo let feedback_axiom () = Feedback.(feedback AddedAxiom) let is_unsafe_typing_flags () = + let open Declarations in let flags = Environ.typing_flags (Global.env()) in not (flags.check_universes && flags.check_guarded && flags.check_positive) @@ -365,6 +562,7 @@ type variable_declaration = (* This object is only for things which iterate over objects to find variables (only Prettyp.print_context AFAICT) *) let objVariable : unit Libobject.Dyn.tag = + let open Libobject in declare_object_full { (default_object "VARIABLE") with classify_function = (fun () -> Dispose)} @@ -385,15 +583,15 @@ let declare_variable ~name ~kind d = let ((body, body_ui), eff) = Future.force de.proof_entry_body in let () = export_side_effects eff in let poly, entry_ui = match de.proof_entry_universes with - | Monomorphic_entry uctx -> false, uctx - | Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx + | Entries.Monomorphic_entry uctx -> false, uctx + | Entries.Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx in let univs = Univ.ContextSet.union body_ui entry_ui in (* We must declare the universe constraints before type-checking the term. *) let () = declare_universe_context ~poly univs in let se = { - secdef_body = body; + Entries.secdef_body = body; secdef_secctx = de.proof_entry_secctx; secdef_feedback = de.proof_entry_feedback; secdef_type = de.proof_entry_type; @@ -403,7 +601,7 @@ let declare_variable ~name ~kind d = in Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); Decls.(add_variable_data name {opaque;kind}); - ignore(add_leaf name (inVariable ()) : Libobject.object_name); + ignore(Lib.add_leaf name (inVariable ()) : Libobject.object_name); Impargs.declare_var_implicits ~impl name; Notation.declare_ref_arguments_scope Evd.empty (GlobRef.VarRef name) @@ -510,3 +708,194 @@ module Internal = struct let objConstant = objConstant end +(*** Proof Global Environment ***) + +type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t + +let close_proof_delayed ~feedback_id ps (fpl : closed_proof_output Future.computation) = + let { section_vars; proof; udecl; initial_euctx } = ps in + let { Proof.name; poly; entry; sigma } = Proof.data proof in + + (* We don't allow poly = true in this path *) + if poly then + CErrors.anomaly (Pp.str "Cannot delay universe-polymorphic constants."); + + let fpl, uctx = Future.split2 fpl in + (* Because of dependent subgoals at the beginning of proofs, we could + have existential variables in the initial types of goals, we need to + normalise them for the kernel. *) + let subst_evar k = Evd.existential_opt_value0 sigma k in + let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst initial_euctx) in + + (* We only support opaque proofs, this will be enforced by using + different entries soon *) + let opaque = true in + let make_entry p (_, types) = + (* Already checked the univ_decl for the type universes when starting the proof. *) + let univs = UState.univ_entry ~poly:false initial_euctx in + let types = nf (EConstr.Unsafe.to_constr types) in + + Future.chain p (fun (pt,eff) -> + (* Deferred proof, we already checked the universe declaration with + the initial universes, ensure that the final universes respect + the declaration as well. If the declaration is non-extensible, + this will prevent the body from adding universes and constraints. *) + let uctx = Future.force uctx in + let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in + let used_univs = Univ.LSet.union + (Vars.universes_of_constr types) + (Vars.universes_of_constr pt) + in + let univs = UState.restrict uctx used_univs in + let univs = UState.check_mono_univ_decl univs udecl in + (pt,univs),eff) + |> delayed_definition_entry ~opaque ~feedback_id ~section_vars ~univs ~types + in + let entries = Future.map2 make_entry fpl (Proofview.initial_goals entry) in + { name; entries; uctx = initial_euctx } + +let close_future_proof = close_proof_delayed + +let return_partial_proof { proof } = + let proofs = Proof.partial_proof proof in + let Proof.{sigma=evd} = Proof.data proof in + let eff = Evd.eval_side_effects evd in + (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate + side-effects... This may explain why one need to uniquize side-effects + thereafter... *) + let proofs = List.map (fun c -> EConstr.Unsafe.to_constr c, eff) proofs in + proofs, Evd.evar_universe_context evd + +let return_proof ps = + let p, uctx = prepare_proof ~unsafe_typ:false ps in + List.map fst p, uctx + +let update_global_env = + map_proof (fun p -> + let { Proof.sigma } = Proof.data p in + let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in + let p, (status,info), _ = Proof.run_tactic (Global.env ()) tac p in + p) + +let next = let n = ref 0 in fun () -> incr n; !n + +let by tac = map_fold_proof (Proof.solve (Goal_select.SelectNth 1) None tac) + +let build_constant_by_tactic ~name ?(opaque=Transparent) ~uctx ~sign ~poly typ tac = + let evd = Evd.from_ctx uctx in + let goals = [ (Global.env_of_context sign , typ) ] in + let pf = start_proof ~name ~poly ~udecl:UState.default_univ_decl evd goals in + let pf, status = by tac pf in + let { entries; uctx } = close_proof ~opaque ~keep_body_ucst_separate:false pf in + match entries with + | [entry] -> + entry, status, uctx + | _ -> + CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") + +let build_by_tactic ?(side_eff=true) env ~uctx ~poly ~typ tac = + let name = Id.of_string ("temporary_proof"^string_of_int (next())) in + let sign = Environ.(val_of_named_context (named_context env)) in + let ce, status, univs = build_constant_by_tactic ~name ~uctx ~sign ~poly typ tac in + let cb, uctx = + if side_eff then inline_private_constants ~uctx env ce + else + (* GG: side effects won't get reset: no need to treat their universes specially *) + let (cb, ctx), _eff = Future.force ce.proof_entry_body in + cb, UState.merge ~sideff:false Evd.univ_rigid uctx ctx + in + cb, ce.proof_entry_type, status, univs + +let declare_abstract ~name ~poly ~kind ~sign ~secsign ~opaque ~solve_tac sigma concl = + (* EJGA: flush_and_check_evars is only used in abstract, could we + use a different API? *) + let concl = + try Evarutil.flush_and_check_evars sigma concl + with Evarutil.Uninstantiated_evar _ -> + CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials.") + in + let sigma, concl = + (* FIXME: should be done only if the tactic succeeds *) + let sigma = Evd.minimize_universes sigma in + sigma, Evarutil.nf_evars_universes sigma concl + in + let concl = EConstr.of_constr concl in + let uctx = Evd.evar_universe_context sigma in + let (const, safe, uctx) = + try build_constant_by_tactic ~name ~opaque:Transparent ~poly ~uctx ~sign:secsign concl solve_tac + with Logic_monad.TacticFailure e as src -> + (* if the tactic [tac] fails, it reports a [TacticFailure e], + which is an error irrelevant to the proof system (in fact it + means that [e] comes from [tac] failing to yield enough + success). Hence it reraises [e]. *) + let (_, info) = Exninfo.capture src in + Exninfo.iraise (e, info) + in + let sigma = Evd.set_universe_context sigma uctx in + let body, effs = Future.force const.proof_entry_body in + (* We drop the side-effects from the entry, they already exist in the ambient environment *) + let const = Internal.map_entry_body const ~f:(fun _ -> body, ()) in + (* EJGA: Hack related to the above call to + `build_constant_by_tactic` with `~opaque:Transparent`. Even if + the abstracted term is destined to be opaque, if we trigger the + `if poly && opaque && private_poly_univs ()` in `Proof_global` + kernel will boom. This deserves more investigation. *) + let const = Internal.set_opacity ~opaque const in + let const, args = Internal.shrink_entry sign const in + let cst () = + (* do not compute the implicit arguments, it may be costly *) + let () = Impargs.make_implicit_args false in + (* ppedrot: seems legit to have abstracted subproofs as local*) + declare_private_constant ~local:ImportNeedQualified ~name ~kind const + in + let cst, eff = Impargs.with_implicit_protection cst () in + let inst = match const.proof_entry_universes with + | Entries.Monomorphic_entry _ -> EConstr.EInstance.empty + | Entries.Polymorphic_entry (_, ctx) -> + (* We mimic what the kernel does, that is ensuring that no additional + constraints appear in the body of polymorphic constants. Ideally this + should be enforced statically. *) + let (_, body_uctx), _ = Future.force const.proof_entry_body in + let () = assert (Univ.ContextSet.is_empty body_uctx) in + EConstr.EInstance.make (Univ.UContext.instance ctx) + in + let args = List.map EConstr.of_constr args in + let lem = EConstr.mkConstU (cst, inst) in + let effs = Evd.concat_side_effects eff effs in + effs, sigma, lem, args, safe + +let get_goal_context pf i = + let p = get_proof pf in + Proof.get_goal_context_gen p i + +let get_current_goal_context pf = + let p = get_proof pf in + try Proof.get_goal_context_gen p 1 + with + | Proof.NoSuchGoal _ -> + (* spiwack: returning empty evar_map, since if there is no goal, + under focus, there is no accessible evar either. EJGA: this + seems strange, as we have pf *) + let env = Global.env () in + Evd.from_env env, env + +let get_current_context pf = + let p = get_proof pf in + Proof.get_proof_context p + +module Proof = struct + type nonrec t = t + let get_proof = get_proof + let get_proof_name = get_proof_name + let get_used_variables = get_used_variables + let get_universe_decl = get_universe_decl + let get_initial_euctx = get_initial_euctx + let map_proof = map_proof + let map_fold_proof = map_fold_proof + let map_fold_proof_endline = map_fold_proof_endline + let set_endline_tactic = set_endline_tactic + let set_used_variables = set_used_variables + let compact = compact_the_proof + let update_global_env = update_global_env + let get_open_goals = get_open_goals +end diff --git a/tactics/declare.mli b/tactics/declare.mli index 615cffeae7..1fabf80b2a 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -12,14 +12,92 @@ open Names open Constr open Entries -(** This module provides the official functions to declare new variables, - parameters, constants and inductive types. Using the following functions - will add the entries in the global environment (module [Global]), will - register the declarations in the library (module [Lib]) --- so that the - reset works properly --- and will fill some global tables such as - [Nametab] and [Impargs]. *) - -(** Proof entries *) +(** This module provides the official functions to declare new + variables, parameters, constants and inductive types in the global + environment. It also updates some accesory tables such as [Nametab] + (name resolution), [Impargs], and [Notations]. *) + +(** We provide two kind of fuctions: + + - one go functions, that will register a constant in one go, suited + for non-interactive definitions where the term is given. + + - two-phase [start/declare] functions which will create an + interactive proof, allow its modification, and saving when + complete. + + Internally, these functions mainly differ in that usually, the first + case doesn't require setting up the tactic engine. + + *) + +(** [Declare.Proof.t] Construction of constants using interactive proofs. *) +module Proof : sig + + type t + + (** XXX: These are internal and will go away from publis API once + lemmas is merged here *) + val get_proof : t -> Proof.t + val get_proof_name : t -> Names.Id.t + + (** XXX: These 3 are only used in lemmas *) + val get_used_variables : t -> Names.Id.Set.t option + val get_universe_decl : t -> UState.universe_decl + val get_initial_euctx : t -> UState.t + + val map_proof : (Proof.t -> Proof.t) -> t -> t + val map_fold_proof : (Proof.t -> Proof.t * 'a) -> t -> t * 'a + val map_fold_proof_endline : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a + + (** Sets the tactic to be used when a tactic line is closed with [...] *) + val set_endline_tactic : Genarg.glob_generic_argument -> t -> t + + (** Sets the section variables assumed by the proof, returns its closure + * (w.r.t. type dependencies and let-ins covered by it) *) + val set_used_variables : t -> + Names.Id.t list -> Constr.named_context * t + + val compact : t -> t + + (** Update the proofs global environment after a side-effecting command + (e.g. a sublemma definition) has been run inside it. Assumes + there_are_pending_proofs. *) + val update_global_env : t -> t + + val get_open_goals : t -> int + +end + +type opacity_flag = Opaque | Transparent + +(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of + name [name] with goals [goals] (a list of pairs of environment and + conclusion); [poly] determines if the proof is universe + polymorphic. The proof is started in the evar map [sigma] (which + can typically contain universe constraints), and with universe + bindings [udecl]. *) +val start_proof + : name:Names.Id.t + -> udecl:UState.universe_decl + -> poly:bool + -> Evd.evar_map + -> (Environ.env * EConstr.types) list + -> Proof.t + +(** Like [start_proof] except that there may be dependencies between + initial goals. *) +val start_dependent_proof + : name:Names.Id.t + -> udecl:UState.universe_decl + -> poly:bool + -> Proofview.telescope + -> Proof.t + +(** Proof entries represent a proof that has been finished, but still + not registered with the kernel. + + XXX: Scheduled for removal from public API, don't rely on it *) type 'a proof_entry = private { proof_entry_body : 'a Entries.const_entry_body; (* List of section variables *) @@ -32,12 +110,26 @@ type 'a proof_entry = private { proof_entry_inline_code : bool; } +(** XXX: Scheduled for removal from public API, don't rely on it *) +type proof_object = private + { name : Names.Id.t + (** name of the proof *) + ; entries : Evd.side_effects proof_entry list + (** list of the proof terms (in a form suitable for definitions). *) + ; uctx: UState.t + (** universe state *) + } + +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Proof.t -> proof_object + (** Declaration of local constructions (Variable/Hypothesis/Local) *) +(** XXX: Scheduled for removal from public API, don't rely on it *) type variable_declaration = | SectionLocalDef of Evd.side_effects proof_entry | SectionLocalAssum of { typ:types; impl:Glob_term.binding_kind; } +(** XXX: Scheduled for removal from public API, don't rely on it *) type 'a constant_entry = | DefinitionEntry of 'a proof_entry | ParameterEntry of parameter_entry @@ -52,9 +144,9 @@ val declare_variable -> unit (** Declaration of global constructions - i.e. Definition/Theorem/Axiom/Parameter/... *) + i.e. Definition/Theorem/Axiom/Parameter/... -(* Default definition entries, transparent with no secctx or proj information *) + XXX: Scheduled for removal from public API, use `DeclareDef` instead *) val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool @@ -70,6 +162,7 @@ val definition_entry -> constr -> Evd.side_effects proof_entry +(** XXX: Scheduled for removal from public API, use `DeclareDef` instead *) val pure_definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool @@ -79,17 +172,6 @@ val pure_definition_entry -> constr -> unit proof_entry -(* Delayed definition entries *) -val delayed_definition_entry - : ?opaque:bool - -> ?inline:bool - -> ?feedback_id:Stateid.t - -> ?section_vars:Id.Set.t - -> ?univs:Entries.universes_entry - -> ?types:types - -> 'a Entries.const_entry_body - -> 'a proof_entry - type import_status = ImportDefaultBehavior | ImportNeedQualified (** [declare_constant id cd] declares a global declaration @@ -97,7 +179,9 @@ type import_status = ImportDefaultBehavior | ImportNeedQualified the full path of the declaration internal specify if the constant has been created by the kernel or by the - user, and in the former case, if its errors should be silent *) + user, and in the former case, if its errors should be silent + + XXX: Scheduled for removal from public API, use `DeclareDef` instead *) val declare_constant : ?local:import_status -> name:Id.t @@ -115,7 +199,9 @@ val declare_private_constant (** [inline_private_constants ~sideff ~uctx env ce] will inline the constants in [ce]'s body and return the body plus the updated - [UState.t]. *) + [UState.t]. + + XXX: Scheduled for removal from public API, don't rely on it *) val inline_private_constants : uctx:UState.t -> Environ.env @@ -124,10 +210,10 @@ val inline_private_constants (** Declaration messages *) +(** XXX: Scheduled for removal from public API, do not use *) val definition_message : Id.t -> unit val assumption_message : Id.t -> unit val fixpoint_message : int array option -> Id.t list -> unit -val cofixpoint_message : Id.t list -> unit val recursive_message : bool (** true = fixpoint *) -> int array option -> Id.t list -> unit @@ -157,3 +243,72 @@ module Internal : sig val objVariable : unit Libobject.Dyn.tag end + +(* Intermediate step necessary to delegate the future. + * Both access the current proof state. The former is supposed to be + * chained with a computation that completed the proof *) +type closed_proof_output + +(** Requires a complete proof. *) +val return_proof : Proof.t -> closed_proof_output + +(** An incomplete proof is allowed (no error), and a warn is given if + the proof is complete. *) +val return_partial_proof : Proof.t -> closed_proof_output +val close_future_proof : feedback_id:Stateid.t -> Proof.t -> closed_proof_output Future.computation -> proof_object + +(** [by tac] applies tactic [tac] to the 1st subgoal of the current + focused proof. + Returns [false] if an unsafe tactic has been used. *) +val by : unit Proofview.tactic -> Proof.t -> Proof.t * bool + +(** Declare abstract constant; will check no evars are possible; *) +val declare_abstract : + name:Names.Id.t + -> poly:bool + -> kind:Decls.logical_kind + -> sign:EConstr.named_context + -> secsign:Environ.named_context_val + -> opaque:bool + -> solve_tac:unit Proofview.tactic + -> Evd.evar_map + -> EConstr.t + -> Evd.side_effects * Evd.evar_map * EConstr.t * EConstr.t list * bool + +val build_by_tactic + : ?side_eff:bool + -> Environ.env + -> uctx:UState.t + -> poly:bool + -> typ:EConstr.types + -> unit Proofview.tactic + -> Constr.constr * Constr.types option * bool * UState.t + +(** {6 Helpers to obtain proof state when in an interactive proof } *) + +(** [get_goal_context n] returns the context of the [n]th subgoal of + the current focused proof or raises a [UserError] if there is no + focused proof or if there is no more subgoals *) + +val get_goal_context : Proof.t -> int -> Evd.evar_map * Environ.env + +(** [get_current_goal_context ()] works as [get_goal_context 1] *) +val get_current_goal_context : Proof.t -> Evd.evar_map * Environ.env + +(** [get_current_context ()] returns the context of the + current focused goal. If there is no focused goal but there + is a proof in progress, it returns the corresponding evar_map. + If there is no pending proof then it returns the current global + environment and empty evar_map. *) +val get_current_context : Proof.t -> Evd.evar_map * Environ.env + +(** Temporarily re-exported for 3rd party code; don't use *) +val build_constant_by_tactic : + name:Names.Id.t -> + ?opaque:opacity_flag -> + uctx:UState.t -> + sign:Environ.named_context_val -> + poly:bool -> + EConstr.types -> + unit Proofview.tactic -> + Evd.side_effects proof_entry * bool * UState.t diff --git a/tactics/hints.ml b/tactics/hints.ml index f8a46fcb1d..ffb0e030db 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1163,7 +1163,7 @@ let inAutoHint : hint_obj -> obj = declare_object {(default_object "AUTOHINT") with cache_function = cache_autohint; load_function = load_autohint; - open_function = open_autohint; + open_function = simple_open open_autohint; subst_function = subst_autohint; classify_function = classify_autohint; } @@ -1562,7 +1562,7 @@ let pr_hint_term env sigma cl = (* print all hints that apply to the concl of the current goal *) let pr_applicable_hint pf = let env = Global.env () in - let pts = Proof_global.get_proof pf in + let pts = Declare.Proof.get_proof pf in let Proof.{goals;sigma} = Proof.data pts in match goals with | [] -> CErrors.user_err Pp.(str "No focused goal.") diff --git a/tactics/hints.mli b/tactics/hints.mli index 9e11931247..eed0e37fac 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -306,7 +306,7 @@ val wrap_hint_warning_fun : env -> evar_map -> (** Printing hints *) val pr_searchtable : env -> evar_map -> Pp.t -val pr_applicable_hint : Proof_global.t -> Pp.t +val pr_applicable_hint : Declare.Proof.t -> Pp.t val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t diff --git a/tactics/pfedit.ml b/tactics/pfedit.ml deleted file mode 100644 index c139594f13..0000000000 --- a/tactics/pfedit.ml +++ /dev/null @@ -1,189 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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) *) -(************************************************************************) - -open Pp -open Util -open Names -open Environ -open Evd - -let use_unification_heuristics = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Solve";"Unification";"Constraints"] - ~value:true - -exception NoSuchGoal -let () = CErrors.register_handler begin function - | NoSuchGoal -> Some Pp.(str "No such goal.") - | _ -> None -end - -let get_nth_V82_goal p i = - let Proof.{ sigma; goals } = Proof.data p in - try { it = List.nth goals (i-1) ; sigma } - with Failure _ -> raise NoSuchGoal - -let get_goal_context_gen pf i = - let { it=goal ; sigma=sigma; } = get_nth_V82_goal pf i in - (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) - -let get_goal_context pf i = - let p = Proof_global.get_proof pf in - get_goal_context_gen p i - -let get_current_goal_context pf = - let p = Proof_global.get_proof pf in - try get_goal_context_gen p 1 - with - | NoSuchGoal -> - (* spiwack: returning empty evar_map, since if there is no goal, - under focus, there is no accessible evar either. EJGA: this - seems strange, as we have pf *) - let env = Global.env () in - Evd.from_env env, env - -let get_proof_context p = - try get_goal_context_gen p 1 - with - | NoSuchGoal -> - (* No more focused goals *) - let { Proof.sigma } = Proof.data p in - sigma, Global.env () - -let get_current_context pf = - let p = Proof_global.get_proof pf in - get_proof_context p - -let solve ?with_end_tac gi info_lvl tac pr = - let tac = match with_end_tac with - | None -> tac - | Some etac -> Proofview.tclTHEN tac etac in - let tac = match info_lvl with - | None -> tac - | Some _ -> Proofview.Trace.record_info_trace tac - in - let nosuchgoal = Proofview.tclZERO (Proof_bullet.SuggestNoSuchGoals (1,pr)) in - let tac = let open Goal_select in match gi with - | SelectAlreadyFocused -> - let open Proofview.Notations in - Proofview.numgoals >>= fun n -> - if n == 1 then tac - else - let e = CErrors.UserError - (None, - Pp.(str "Expected a single focused goal but " ++ - int n ++ str " goals are focused.")) - in - Proofview.tclZERO e - - | SelectNth i -> Proofview.tclFOCUS ~nosuchgoal i i tac - | SelectList l -> Proofview.tclFOCUSLIST ~nosuchgoal l tac - | SelectId id -> Proofview.tclFOCUSID ~nosuchgoal id tac - | SelectAll -> tac - in - let tac = - if use_unification_heuristics () then - Proofview.tclTHEN tac Refine.solve_constraints - else tac - in - let env = Global.env () in - let (p,(status,info),()) = Proof.run_tactic env tac pr in - let env = Global.env () in - let sigma = Evd.from_env env in - let () = - match info_lvl with - | None -> () - | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info env sigma ~lvl:i info)) - in - (p,status) - -let by tac = Proof_global.map_fold_proof (solve (Goal_select.SelectNth 1) None tac) - -(**********************************************************************) -(* Shortcut to build a term using tactics *) - -let next = let n = ref 0 in fun () -> incr n; !n - -let build_constant_by_tactic ~name ?(opaque=Proof_global.Transparent) ~uctx ~sign ~poly typ tac = - let evd = Evd.from_ctx uctx in - let goals = [ (Global.env_of_context sign , typ) ] in - let pf = Proof_global.start_proof ~name ~poly ~udecl:UState.default_univ_decl evd goals in - let pf, status = by tac pf in - let open Proof_global in - let { entries; uctx } = close_proof ~opaque ~keep_body_ucst_separate:false pf in - match entries with - | [entry] -> - entry, status, uctx - | _ -> - CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") - -let build_by_tactic ?(side_eff=true) env ~uctx ~poly ~typ tac = - let name = Id.of_string ("temporary_proof"^string_of_int (next())) in - let sign = val_of_named_context (named_context env) in - let ce, status, univs = build_constant_by_tactic ~name ~uctx ~sign ~poly typ tac in - let cb, uctx = - if side_eff then Declare.inline_private_constants ~uctx env ce - else - (* GG: side effects won't get reset: no need to treat their universes specially *) - let (cb, ctx), _eff = Future.force ce.Declare.proof_entry_body in - cb, UState.merge ~sideff:false Evd.univ_rigid uctx ctx - in - cb, ce.Declare.proof_entry_type, status, univs - -let refine_by_tactic ~name ~poly env sigma ty tac = - (* Save the initial side-effects to restore them afterwards. We set the - current set of side-effects to be empty so that we can retrieve the - ones created during the tactic invocation easily. *) - let eff = Evd.eval_side_effects sigma in - let sigma = Evd.drop_side_effects sigma in - (* Save the existing goals *) - let prev_future_goals = save_future_goals sigma in - (* Start a proof *) - let prf = Proof.start ~name ~poly sigma [env, ty] in - let (prf, _, ()) = - try Proof.run_tactic env tac prf - with Logic_monad.TacticFailure e as src -> - (* Catch the inner error of the monad tactic *) - let (_, info) = Exninfo.capture src in - Exninfo.iraise (e, info) - in - (* Plug back the retrieved sigma *) - let Proof.{ goals; stack; shelf; given_up; sigma; entry } = Proof.data prf in - assert (stack = []); - let ans = match Proofview.initial_goals entry with - | [c, _] -> c - | _ -> assert false - in - let ans = EConstr.to_constr ~abort_on_undefined_evars:false sigma ans in - (* [neff] contains the freshly generated side-effects *) - let neff = Evd.eval_side_effects sigma in - (* Reset the old side-effects *) - let sigma = Evd.drop_side_effects sigma in - let sigma = Evd.emit_side_effects eff sigma in - (* Restore former goals *) - let sigma = restore_future_goals sigma prev_future_goals in - (* Push remaining goals as future_goals which is the only way we - have to inform the caller that there are goals to collect while - not being encapsulated in the monad *) - (* Goals produced by tactic "shelve" *) - let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToShelve) shelf sigma in - (* Goals produced by tactic "give_up" *) - let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToGiveUp) given_up sigma in - (* Other goals *) - let sigma = List.fold_right Evd.declare_future_goal goals sigma in - (* Get rid of the fresh side-effects by internalizing them in the term - itself. Note that this is unsound, because the tactic may have solved - other goals that were already present during its invocation, so that - those goals rely on effects that are not present anymore. Hopefully, - this hack will work in most cases. *) - let neff = neff.Evd.seff_private in - let (ans, _) = Safe_typing.inline_private_constants env ((ans, Univ.ContextSet.empty), neff) in - ans, sigma diff --git a/tactics/pfedit.mli b/tactics/pfedit.mli deleted file mode 100644 index c49e997757..0000000000 --- a/tactics/pfedit.mli +++ /dev/null @@ -1,94 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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) *) -(************************************************************************) - -(** Global proof state. A quite redundant wrapper on {!Proof_global}. *) - -open Names -open Constr -open Environ - -(** {6 ... } *) - -exception NoSuchGoal - -(** [get_goal_context n] returns the context of the [n]th subgoal of - the current focused proof or raises a [UserError] if there is no - focused proof or if there is no more subgoals *) - -val get_goal_context : Proof_global.t -> int -> Evd.evar_map * env - -(** [get_current_goal_context ()] works as [get_goal_context 1] *) -val get_current_goal_context : Proof_global.t -> Evd.evar_map * env - -(** [get_proof_context ()] gets the goal context for the first subgoal - of the proof *) -val get_proof_context : Proof.t -> Evd.evar_map * env - -(** [get_current_context ()] returns the context of the - current focused goal. If there is no focused goal but there - is a proof in progress, it returns the corresponding evar_map. - If there is no pending proof then it returns the current global - environment and empty evar_map. *) -val get_current_context : Proof_global.t -> Evd.evar_map * env - -(** {6 ... } *) - -(** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th - subgoal of the current focused proof. [solve SelectAll - tac] applies [tac] to all subgoals. *) - -val solve : ?with_end_tac:unit Proofview.tactic -> - Goal_select.t -> int option -> unit Proofview.tactic -> - Proof.t -> Proof.t * bool - -(** [by tac] applies tactic [tac] to the 1st subgoal of the current - focused proof. - Returns [false] if an unsafe tactic has been used. *) - -val by : unit Proofview.tactic -> Proof_global.t -> Proof_global.t * bool - -(** Option telling if unification heuristics should be used. *) -val use_unification_heuristics : unit -> bool - -(** [build_by_tactic typ tac] returns a term of type [typ] by calling - [tac]. The return boolean, if [false] indicates the use of an unsafe - tactic. *) - -val build_constant_by_tactic - : name:Id.t - -> ?opaque:Proof_global.opacity_flag - -> uctx:UState.t - -> sign:named_context_val - -> poly:bool - -> EConstr.types - -> unit Proofview.tactic - -> Evd.side_effects Declare.proof_entry * bool * UState.t - -val build_by_tactic - : ?side_eff:bool - -> env - -> uctx:UState.t - -> poly:bool - -> typ:EConstr.types - -> unit Proofview.tactic - -> constr * types option * bool * UState.t - -val refine_by_tactic - : name:Id.t - -> poly:bool - -> env -> Evd.evar_map - -> EConstr.types - -> unit Proofview.tactic - -> constr * Evd.evar_map -(** A variant of the above function that handles open terms as well. - Caveat: all effects are purged in the returned term at the end, but other - evars solved by side-effects are NOT purged, so that unexpected failures may - occur. Ideally all code using this function should be rewritten in the - monad. *) diff --git a/tactics/proof_global.ml b/tactics/proof_global.ml deleted file mode 100644 index 68de9c7a00..0000000000 --- a/tactics/proof_global.ml +++ /dev/null @@ -1,283 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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) *) -(************************************************************************) - -open Util -open Names -open Context - -module NamedDecl = Context.Named.Declaration - -(*** Proof Global Environment ***) - -type proof_object = - { name : Names.Id.t - (* [name] only used in the STM *) - ; entries : Evd.side_effects Declare.proof_entry list - ; uctx: UState.t - } - -type opacity_flag = Opaque | Transparent - -type t = - { endline_tactic : Genarg.glob_generic_argument option - ; section_vars : Id.Set.t option - ; proof : Proof.t - ; udecl: UState.universe_decl - (** Initial universe declarations *) - ; initial_euctx : UState.t - (** The initial universe context (for the statement) *) - } - -(*** Proof Global manipulation ***) - -let get_proof ps = ps.proof -let get_proof_name ps = (Proof.data ps.proof).Proof.name - -let get_initial_euctx ps = ps.initial_euctx - -let map_proof f p = { p with proof = f p.proof } -let map_fold_proof f p = let proof, res = f p.proof in { p with proof }, res - -let map_fold_proof_endline f ps = - let et = - match ps.endline_tactic with - | None -> Proofview.tclUNIT () - | Some tac -> - let open Geninterp in - let {Proof.poly} = Proof.data ps.proof in - let ist = { lfun = Id.Map.empty; poly; extra = TacStore.empty } in - let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in - let tac = Geninterp.interp tag ist tac in - Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) - in - let (newpr,ret) = f et ps.proof in - let ps = { ps with proof = newpr } in - ps, ret - -let compact_the_proof pf = map_proof Proof.compact pf - -(* Sets the tactic to be used when a tactic line is closed with [...] *) -let set_endline_tactic tac ps = - { ps with endline_tactic = Some tac } - -(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of - name [name] with goals [goals] (a list of pairs of environment and - conclusion). The proof is started in the evar map [sigma] (which - can typically contain universe constraints), and with universe - bindings [udecl]. *) -let start_proof ~name ~udecl ~poly sigma goals = - let proof = Proof.start ~name ~poly sigma goals in - let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in - { proof - ; endline_tactic = None - ; section_vars = None - ; udecl - ; initial_euctx - } - -let start_dependent_proof ~name ~udecl ~poly goals = - let proof = Proof.dependent_start ~name ~poly goals in - let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in - { proof - ; endline_tactic = None - ; section_vars = None - ; udecl - ; initial_euctx - } - -let get_used_variables pf = pf.section_vars -let get_universe_decl pf = pf.udecl - -let set_used_variables ps l = - let open Context.Named.Declaration in - let env = Global.env () in - let ids = List.fold_right Id.Set.add l Id.Set.empty in - let ctx = Environ.keep_hyps env ids in - let ctx_set = - List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in - let vars_of = Environ.global_vars_set in - let aux env entry (ctx, all_safe as orig) = - match entry with - | LocalAssum ({binder_name=x},_) -> - if Id.Set.mem x all_safe then orig - else (ctx, all_safe) - | LocalDef ({binder_name=x},bo, ty) as decl -> - if Id.Set.mem x all_safe then orig else - let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in - if Id.Set.subset vars all_safe - then (decl :: ctx, Id.Set.add x all_safe) - else (ctx, all_safe) in - let ctx, _ = - Environ.fold_named_context aux env ~init:(ctx,ctx_set) in - if not (Option.is_empty ps.section_vars) then - CErrors.user_err Pp.(str "Used section variables can be declared only once"); - ctx, { ps with section_vars = Some (Context.Named.to_vars ctx) } - -let get_open_goals ps = - let Proof.{ goals; stack; shelf } = Proof.data ps.proof in - List.length goals + - List.fold_left (+) 0 - (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + - List.length shelf - -type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t - -let private_poly_univs = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Private";"Polymorphic";"Universes"] - ~value:true - -(* XXX: This is still separate from close_proof below due to drop_pt in the STM *) -let return_proof { proof } = - let Proof.{name=pid;entry} = Proof.data proof in - let initial_goals = Proofview.initial_goals entry in - let evd = Proof.return ~pid proof in - let eff = Evd.eval_side_effects evd in - let evd = Evd.minimize_universes evd in - let proof_opt c = - match EConstr.to_constr_opt evd c with - | Some p -> p - | None -> CErrors.user_err Pp.(str "Some unresolved existential variables remain") - in - (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate - side-effects... This may explain why one need to uniquize side-effects - thereafter... *) - (* EJGA: actually side-effects de-duplication and this codepath is - unrelated. Duplicated side-effects arise from incorrect scheme - generation code, the main bulk of it was mostly fixed by #9836 - but duplication can still happen because of rewriting schemes I - think; however the code below is mostly untested, the only - code-paths that generate several proof entries are derive and - equations and so far there is no code in the CI that will - actually call those and do a side-effect, TTBOMK *) - (* EJGA: likely the right solution is to attach side effects to the first constant only? *) - let proofs = List.map (fun (c, _) -> (proof_opt c, eff)) initial_goals in - proofs, Evd.evar_universe_context evd - -let close_proof ~opaque ~keep_body_ucst_separate ps = - let elist, uctx = return_proof ps in - let { section_vars; proof; udecl; initial_euctx } = ps in - let { Proof.name; poly; entry; sigma } = Proof.data proof in - let opaque = match opaque with Opaque -> true | Transparent -> false in - - (* Because of dependent subgoals at the beginning of proofs, we could - have existential variables in the initial types of goals, we need to - normalise them for the kernel. *) - let subst_evar k = Evd.existential_opt_value0 sigma k in - let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst uctx) in - - let make_entry (body, eff) (_, typ) = - let allow_deferred = - not poly && (keep_body_ucst_separate || - not (Safe_typing.empty_private_constants = eff.Evd.seff_private)) - in - (* EJGA: Why are we doing things this way? *) - let typ = EConstr.Unsafe.to_constr typ in - let typ = if allow_deferred then typ else nf typ in - (* EJGA: End "Why are we doing things this way?" *) - - let used_univs_body = Vars.universes_of_constr body in - let used_univs_typ = Vars.universes_of_constr typ in - let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let utyp, ubody = - if allow_deferred then - let utyp = UState.univ_entry ~poly initial_euctx in - let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in - (* For vi2vo compilation proofs are computed now but we need to - complement the univ constraints of the typ with the ones of - the body. So we keep the two sets distinct. *) - let uctx_body = UState.restrict uctx used_univs in - let ubody = UState.check_mono_univ_decl uctx_body udecl in - utyp, ubody - else if poly && opaque && private_poly_univs () then - let universes = UState.restrict uctx used_univs in - let typus = UState.restrict universes used_univs_typ in - let utyp = UState.check_univ_decl ~poly typus udecl in - let ubody = Univ.ContextSet.diff - (UState.context_set universes) - (UState.context_set typus) - in - utyp, ubody - else - (* Since the proof is computed now, we can simply have 1 set of - constraints in which we merge the ones for the body and the ones - for the typ. We recheck the declaration after restricting with - the actually used universes. - TODO: check if restrict is really necessary now. *) - let ctx = UState.restrict uctx used_univs in - let utyp = UState.check_univ_decl ~poly ctx udecl in - utyp, Univ.ContextSet.empty - in - Declare.definition_entry ~opaque ?section_vars ~univs:utyp ~univsbody:ubody ~types:typ ~eff body - in - let entries = CList.map2 make_entry elist (Proofview.initial_goals entry) in - { name; entries; uctx } - -let close_proof_delayed ~feedback_id ps (fpl : closed_proof_output Future.computation) = - let { section_vars; proof; udecl; initial_euctx } = ps in - let { Proof.name; poly; entry; sigma } = Proof.data proof in - - (* We don't allow poly = true in this path *) - if poly then - CErrors.anomaly (Pp.str "Cannot delay universe-polymorphic constants."); - - let fpl, uctx = Future.split2 fpl in - (* Because of dependent subgoals at the beginning of proofs, we could - have existential variables in the initial types of goals, we need to - normalise them for the kernel. *) - let subst_evar k = Evd.existential_opt_value0 sigma k in - let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst initial_euctx) in - - (* We only support opaque proofs, this will be enforced by using - different entries soon *) - let opaque = true in - let make_entry p (_, types) = - (* Already checked the univ_decl for the type universes when starting the proof. *) - let univs = UState.univ_entry ~poly:false initial_euctx in - let types = nf (EConstr.Unsafe.to_constr types) in - - Future.chain p (fun (pt,eff) -> - (* Deferred proof, we already checked the universe declaration with - the initial universes, ensure that the final universes respect - the declaration as well. If the declaration is non-extensible, - this will prevent the body from adding universes and constraints. *) - let uctx = Future.force uctx in - let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in - let used_univs = Univ.LSet.union - (Vars.universes_of_constr types) - (Vars.universes_of_constr pt) - in - let univs = UState.restrict uctx used_univs in - let univs = UState.check_mono_univ_decl univs udecl in - (pt,univs),eff) - |> Declare.delayed_definition_entry ~opaque ~feedback_id ?section_vars ~univs ~types - in - let entries = Future.map2 make_entry fpl (Proofview.initial_goals entry) in - { name; entries; uctx = initial_euctx } - -let close_future_proof = close_proof_delayed - -let return_partial_proof { proof } = - let proofs = Proof.partial_proof proof in - let Proof.{sigma=evd} = Proof.data proof in - let eff = Evd.eval_side_effects evd in - (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate - side-effects... This may explain why one need to uniquize side-effects - thereafter... *) - let proofs = List.map (fun c -> EConstr.Unsafe.to_constr c, eff) proofs in - proofs, Evd.evar_universe_context evd - -let update_global_env = - map_proof (fun p -> - let { Proof.sigma } = Proof.data p in - let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in - let p, (status,info), _ = Proof.run_tactic (Global.env ()) tac p in - p) diff --git a/tactics/proof_global.mli b/tactics/proof_global.mli deleted file mode 100644 index 874708ded8..0000000000 --- a/tactics/proof_global.mli +++ /dev/null @@ -1,98 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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) *) -(************************************************************************) - -(** State for interactive proofs. *) - -type t - -(* Should be moved into a proper view *) -val get_proof : t -> Proof.t -val get_proof_name : t -> Names.Id.t -val get_used_variables : t -> Names.Id.Set.t option - -(** Get the universe declaration associated to the current proof. *) -val get_universe_decl : t -> UState.universe_decl - -(** Get initial universe state *) -val get_initial_euctx : t -> UState.t - -val compact_the_proof : t -> t - -(** When a proof is closed, it is reified into a [proof_object] *) -type proof_object = - { name : Names.Id.t - (** name of the proof *) - ; entries : Evd.side_effects Declare.proof_entry list - (** list of the proof terms (in a form suitable for definitions). *) - ; uctx: UState.t - (** universe state *) - } - -type opacity_flag = Opaque | Transparent - -(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of - name [name] with goals [goals] (a list of pairs of environment and - conclusion); [poly] determines if the proof is universe - polymorphic. The proof is started in the evar map [sigma] (which - can typically contain universe constraints), and with universe - bindings [udecl]. *) -val start_proof - : name:Names.Id.t - -> udecl:UState.universe_decl - -> poly:bool - -> Evd.evar_map - -> (Environ.env * EConstr.types) list - -> t - -(** Like [start_proof] except that there may be dependencies between - initial goals. *) -val start_dependent_proof - : name:Names.Id.t - -> udecl:UState.universe_decl - -> poly:bool - -> Proofview.telescope - -> t - -(** Update the proofs global environment after a side-effecting command - (e.g. a sublemma definition) has been run inside it. Assumes - there_are_pending_proofs. *) -val update_global_env : t -> t - -(* Takes a function to add to the exceptions data relative to the - state in which the proof was built *) -val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> t -> proof_object - -(* Intermediate step necessary to delegate the future. - * Both access the current proof state. The former is supposed to be - * chained with a computation that completed the proof *) - -type closed_proof_output - -(** Requires a complete proof. *) -val return_proof : t -> closed_proof_output - -(** An incomplete proof is allowed (no error), and a warn is given if - the proof is complete. *) -val return_partial_proof : t -> closed_proof_output -val close_future_proof : feedback_id:Stateid.t -> t -> closed_proof_output Future.computation -> proof_object - -val get_open_goals : t -> int - -val map_proof : (Proof.t -> Proof.t) -> t -> t -val map_fold_proof : (Proof.t -> Proof.t * 'a) -> t -> t * 'a -val map_fold_proof_endline : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a - -(** Sets the tactic to be used when a tactic line is closed with [...] *) -val set_endline_tactic : Genarg.glob_generic_argument -> t -> t - -(** Sets the section variables assumed by the proof, returns its closure - * (w.r.t. type dependencies and let-ins covered by it) *) -val set_used_variables : t -> - Names.Id.t list -> Constr.named_context * t diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 0c4e496650..537d111f23 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -1,7 +1,5 @@ DeclareScheme Declare -Proof_global -Pfedit Dnet Dn Btermdn diff --git a/test-suite/Makefile b/test-suite/Makefile index eade52b6eb..954a922c8c 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -354,8 +354,7 @@ $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v primit } > "$@" @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi $(HIDE)if ! grep -q -F "Error!" $@; then { \ - opts="$(if $(findstring modules/,$<),-R modules Mods -norec Mods.$(shell basename $< .v),-I $(shell dirname $<) -norec $(shell basename $< .v))"; \ - $(coqchk) -silent $(call get_set_impredicativity,$<) $$opts 2>&1; R=$$?; \ + $(coqchk) -silent $(call get_set_impredicativity,$<) $(if $(findstring modules/,$<),-R modules Mods -norec Mods.$(shell basename $< .v),-Q $(shell dirname $<) "" -norec $(shell basename $< .v)) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ @@ -381,7 +380,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v } > "$@" @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi $(HIDE)if ! grep -q -F "Error!" $@; then { \ - $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ + $(coqchk) -silent -Q $(shell dirname $<) "" -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ @@ -405,7 +404,7 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) } > "$@" @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi $(HIDE)if ! grep -q -F "Error!" $@; then { \ - $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ + $(coqchk) -silent -Q $(shell dirname $<) "" -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ diff --git a/test-suite/bugs/closed/bug_11935.v b/test-suite/bugs/closed/bug_11935.v new file mode 100644 index 0000000000..ad5ffc68b5 --- /dev/null +++ b/test-suite/bugs/closed/bug_11935.v @@ -0,0 +1,6 @@ +Section S. + Variable A : Prop. + + Fail Check A@{Type}. + Check A@{}. +End S. diff --git a/test-suite/coq-makefile/native1/_CoqProject b/test-suite/coq-makefile/native1/_CoqProject index 3dfca7ffc0..85276fd9b9 100644 --- a/test-suite/coq-makefile/native1/_CoqProject +++ b/test-suite/coq-makefile/native1/_CoqProject @@ -1,6 +1,8 @@ -R src test -R theories test -I src +-arg -w +-arg +native-compiler-disabled -arg -native-compiler -arg yes diff --git a/test-suite/coq-makefile/native2/run.sh b/test-suite/coq-makefile/native2/run.sh index 857f70fdff..aaae81630f 100755 --- a/test-suite/coq-makefile/native2/run.sh +++ b/test-suite/coq-makefile/native2/run.sh @@ -7,7 +7,7 @@ if [[ $(which ocamlopt) && ! $NONATIVECOMP ]]; then coq_makefile -f _CoqProject -o Makefile cat Makefile.conf -COQEXTRAFLAGS="-native-compiler yes" make +COQEXTRAFLAGS="-w +native-compiler-disabled -native-compiler yes" make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index abc7f0f88e..e0aa758812 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -2,9 +2,9 @@ The command has indeed failed with message: Flag "rename" expected to rename A into B. File "stdin", line 3, characters 0-25: Warning: This command is just asserting the names of arguments of identity. -If this is what you want add ': assert' to silence the warning. If you want -to clear implicit arguments add ': clear implicits'. If you want to clear -notation scopes add ': clear scopes' [arguments-assert,vernacular] +If this is what you want, add ': assert' to silence the warning. If you want +to clear implicit arguments, add ': clear implicits'. If you want to clear +notation scopes, add ': clear scopes' [arguments-assert,vernacular] @eq_refl : forall (B : Type) (y : B), y = y eq_refl diff --git a/test-suite/output/NotationsSigma.out b/test-suite/output/NotationsSigma.out new file mode 100644 index 0000000000..0e4df87148 --- /dev/null +++ b/test-suite/output/NotationsSigma.out @@ -0,0 +1,40 @@ +{0 = 0} + {0 < 1} + : Set +(0 = 0) + {0 < 1} + : Set +{x : nat | x = 1} + : Set +{x : nat | x = 1 & 0 < x} + : Set +{x : nat | x = 1} + : Set +{x : nat | x = 1 & 0 < x} + : Set +{x : nat & x = 1} + : Set +{x : nat & x = 1 & 0 < x} + : Set +{x : nat & x = 1} + : Set +{x : nat & x = 1 & 0 < x} + : Set +{'(x, _) : nat * ?T | x = 1} + : Type +where +?T : [pat : nat * ?T |- Type] (pat cannot be used) +{'(x, y) : nat * nat | x = 1 & y = 0} + : Set +{'(x, _) : nat * nat | x = 1} + : Set +{'(x, y) : nat * nat | x = 1 & y = 0} + : Set +{'(x, _) : nat * ?T & x = 1} + : Type +where +?T : [pat : nat * ?T |- Type] (pat cannot be used) +{'(x, y) : nat * nat & x = 1 & y = 0} + : Type +{'(x, _) : nat * nat & x = 1} + : Type +{'(x, y) : nat * nat & x = 1 & y = 0} + : Type diff --git a/test-suite/output/NotationsSigma.v b/test-suite/output/NotationsSigma.v new file mode 100644 index 0000000000..6780d63a04 --- /dev/null +++ b/test-suite/output/NotationsSigma.v @@ -0,0 +1,22 @@ +(* Check notations for sigma types *) + +Check { 0 = 0 } + { 0 < 1 }. +Check (0 = 0) + { 0 < 1 }. + +Check { x | x = 1 }. +Check { x | x = 1 & 0 < x }. +Check { x : nat | x = 1 }. +Check { x : nat | x = 1 & 0 < x }. +Check { x & x = 1 }. +Check { x & x = 1 & 0 < x }. +Check { x : nat & x = 1 }. +Check { x : nat & x = 1 & 0 < x }. + +Check {'(x,y) | x = 1 }. +Check {'(x,y) | x = 1 & y = 0 }. +Check {'(x,y) : nat * nat | x = 1 }. +Check {'(x,y) : nat * nat | x = 1 & y = 0 }. +Check {'(x,y) & x = 1 }. +Check {'(x,y) & x = 1 & y = 0 }. +Check {'(x,y) : nat * nat & x = 1 }. +Check {'(x,y) : nat * nat & x = 1 & y = 0 }. diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index 9d8e830d64..593d0c7f67 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -136,7 +136,7 @@ h': newdef n <> n (use "About" for full details on implicit arguments) (use "About" for full details on implicit arguments) The command has indeed failed with message: -No such goal. +[Focus] No such goal. The command has indeed failed with message: Query commands only support the single numbered goal selector. The command has indeed failed with message: diff --git a/test-suite/output/UselessSyndef.out b/test-suite/output/UselessSyndef.out new file mode 100644 index 0000000000..ce484889b3 --- /dev/null +++ b/test-suite/output/UselessSyndef.out @@ -0,0 +1,2 @@ +a + : nat diff --git a/test-suite/output/UselessSyndef.v b/test-suite/output/UselessSyndef.v new file mode 100644 index 0000000000..96ad6e9f5c --- /dev/null +++ b/test-suite/output/UselessSyndef.v @@ -0,0 +1,10 @@ +Module M. + Definition a := 0. +End M. +Module N. + Notation a := M.a (only parsing). +End N. + +Import M. Import N. + +Check a. diff --git a/test-suite/output/bug_11934.out b/test-suite/output/bug_11934.out new file mode 100644 index 0000000000..072136c82e --- /dev/null +++ b/test-suite/output/bug_11934.out @@ -0,0 +1,13 @@ +thing = forall x y : foo, bla x y + : Prop +thing = +forall (x : foo@{thing.u0}) (y : foo@{thing.u1}), bla x y + : Prop +(* {thing.u1 thing.u0} |= bla.u0 = thing.u0 + bla.u1 = thing.u1 *) +thing = +forall (x : @foo@{thing.u0} True) (y : @foo@{thing.u1} True), +@bla True True x y + : Prop +(* {thing.u1 thing.u0} |= bla.u0 = thing.u0 + bla.u1 = thing.u1 *) diff --git a/test-suite/output/bug_11934.v b/test-suite/output/bug_11934.v new file mode 100644 index 0000000000..fe9772dc62 --- /dev/null +++ b/test-suite/output/bug_11934.v @@ -0,0 +1,13 @@ +Polymorphic Axiom foo@{u} : Prop -> Prop. +Arguments foo {_}. + +Axiom bla : forall {A B}, @foo A -> @foo B -> Prop. +Definition thing := forall (x:@foo@{Type} True) (y:@foo@{Type} True), bla x y. + +Print thing. (* forall x y : foo, bla x y *) + +Set Printing Universes. +Print thing. (* forall (x : foo@{thing.u0}) (y : foo@{thing.u1}), bla x y *) + +Set Printing Implicit. +Print thing. (* BAD: forall x y : @foo@{thing.u0} True, @bla True True x y *) diff --git a/test-suite/success/PartialImport.v b/test-suite/success/PartialImport.v new file mode 100644 index 0000000000..720083aec5 --- /dev/null +++ b/test-suite/success/PartialImport.v @@ -0,0 +1,58 @@ +Module M. + + Definition a := 0. + Definition b := 1. + + Module N. + + Notation c := (a + b). + + End N. + + Inductive even : nat -> Prop := + | even_0 : even 0 + | even_S n : odd n -> even (S n) + with odd : nat -> Set := + odd_S n : even n -> odd (S n). + +End M. + +Module Simple. + + Import M(a). + + Check a. + Fail Check b. + Fail Check N.c. + + (* todo output test: this prints a+M.b since the notation isn't imported *) + Check M.N.c. + + Fail Import M(c). + Fail Import M(M.b). + + Import M(N.c). + Check N.c. + (* interestingly prints N.c (also does with unfiltered Import M) *) + + Import M(even(..)). + Check even. Check even_0. Check even_S. + Check even_sind. Check even_ind. + Fail Check even_rect. (* doesn't exist *) + Fail Check odd. Check M.odd. + Fail Check odd_S. Fail Check odd_sind. + +End Simple. + +Module WithExport. + + Module X. + Export M(a, N.c). + End X. + + Import X. + Check a. + Check N.c. (* also prints N.c *) + Fail Check b. + +End WithExport. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index fdb88a0c82..a5e4178b93 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -68,33 +68,40 @@ Reserved Notation "{ x }" (at level 0, x at level 99). (** Notations for sigma-types or subsets *) -Reserved Notation "{ A } + { B }" (at level 50, left associativity). -Reserved Notation "A + { B }" (at level 50, left associativity). +Reserved Notation "{ A } + { B }" (at level 50, left associativity). +Reserved Notation "A + { B }" (at level 50, left associativity). -Reserved Notation "{ x | P }" (at level 0, x at level 99). -Reserved Notation "{ x | P & Q }" (at level 0, x at level 99). +Reserved Notation "{ x | P }" (at level 0, x at level 99). +Reserved Notation "{ x | P & Q }" (at level 0, x at level 99). -Reserved Notation "{ x : A | P }" (at level 0, x at level 99). -Reserved Notation "{ x : A | P & Q }" (at level 0, x at level 99). +Reserved Notation "{ x : A | P }" (at level 0, x at level 99). +Reserved Notation "{ x : A | P & Q }" (at level 0, x at level 99). -Reserved Notation "{ x & P }" (at level 0, x at level 99). -Reserved Notation "{ x : A & P }" (at level 0, x at level 99). -Reserved Notation "{ x : A & P & Q }" (at level 0, x at level 99). +Reserved Notation "{ x & P }" (at level 0, x at level 99). +Reserved Notation "{ x & P & Q }" (at level 0, x at level 99). + +Reserved Notation "{ x : A & P }" (at level 0, x at level 99). +Reserved Notation "{ x : A & P & Q }" (at level 0, x at level 99). Reserved Notation "{ ' pat | P }" - (at level 0, pat strict pattern, format "{ ' pat | P }"). + (at level 0, pat strict pattern, format "{ ' pat | P }"). Reserved Notation "{ ' pat | P & Q }" - (at level 0, pat strict pattern, format "{ ' pat | P & Q }"). + (at level 0, pat strict pattern, format "{ ' pat | P & Q }"). Reserved Notation "{ ' pat : A | P }" (at level 0, pat strict pattern, format "{ ' pat : A | P }"). Reserved Notation "{ ' pat : A | P & Q }" - (at level 0, pat strict pattern, format "{ ' pat : A | P & Q }"). + (at level 0, pat strict pattern, format "{ ' pat : A | P & Q }"). + +Reserved Notation "{ ' pat & P }" + (at level 0, pat strict pattern, format "{ ' pat & P }"). +Reserved Notation "{ ' pat & P & Q }" + (at level 0, pat strict pattern, format "{ ' pat & P & Q }"). Reserved Notation "{ ' pat : A & P }" - (at level 0, pat strict pattern, format "{ ' pat : A & P }"). + (at level 0, pat strict pattern, format "{ ' pat : A & P }"). Reserved Notation "{ ' pat : A & P & Q }" - (at level 0, pat strict pattern, format "{ ' pat : A & P & Q }"). + (at level 0, pat strict pattern, format "{ ' pat : A & P & Q }"). (** Support for Gonthier-Ssreflect's "if c is pat then u else v" *) diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 692fe3d8d0..59ee252d35 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -58,23 +58,26 @@ Arguments sig2 (A P Q)%type. Arguments sigT (A P)%type. Arguments sigT2 (A P Q)%type. -Notation "{ x | P }" := (sig (fun x => P)) : type_scope. -Notation "{ x | P & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope. -Notation "{ x : A | P }" := (sig (A:=A) (fun x => P)) : type_scope. -Notation "{ x : A | P & Q }" := (sig2 (A:=A) (fun x => P) (fun x => Q)) : +Notation "{ x | P }" := (sig (fun x => P)) : type_scope. +Notation "{ x | P & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope. +Notation "{ x : A | P }" := (sig (A:=A) (fun x => P)) : type_scope. +Notation "{ x : A | P & Q }" := (sig2 (A:=A) (fun x => P) (fun x => Q)) : type_scope. -Notation "{ x & P }" := (sigT (fun x => P)) : type_scope. -Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope. -Notation "{ x : A & P & Q }" := (sigT2 (A:=A) (fun x => P) (fun x => Q)) : +Notation "{ x & P }" := (sigT (fun x => P)) : type_scope. +Notation "{ x & P & Q }" := (sigT2 (fun x => P) (fun x => Q)) : type_scope. +Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope. +Notation "{ x : A & P & Q }" := (sigT2 (A:=A) (fun x => P) (fun x => Q)) : type_scope. -Notation "{ ' pat | P }" := (sig (fun pat => P)) : type_scope. -Notation "{ ' pat | P & Q }" := (sig2 (fun pat => P) (fun pat => Q)) : type_scope. -Notation "{ ' pat : A | P }" := (sig (A:=A) (fun pat => P)) : type_scope. -Notation "{ ' pat : A | P & Q }" := (sig2 (A:=A) (fun pat => P) (fun pat => Q)) : +Notation "{ ' pat | P }" := (sig (fun pat => P)) : type_scope. +Notation "{ ' pat | P & Q }" := (sig2 (fun pat => P) (fun pat => Q)) : type_scope. +Notation "{ ' pat : A | P }" := (sig (A:=A) (fun pat => P)) : type_scope. +Notation "{ ' pat : A | P & Q }" := (sig2 (A:=A) (fun pat => P) (fun pat => Q)) : type_scope. -Notation "{ ' pat : A & P }" := (sigT (A:=A) (fun pat => P)) : type_scope. -Notation "{ ' pat : A & P & Q }" := (sigT2 (A:=A) (fun pat => P) (fun pat => Q)) : +Notation "{ ' pat & P }" := (sigT (fun pat => P)) : type_scope. +Notation "{ ' pat & P & Q }" := (sigT2 (fun pat => P) (fun pat => Q)) : type_scope. +Notation "{ ' pat : A & P }" := (sigT (A:=A) (fun pat => P)) : type_scope. +Notation "{ ' pat : A & P & Q }" := (sigT2 (A:=A) (fun pat => P) (fun pat => Q)) : type_scope. Add Printing Let sig. diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 0f25bc8e12..86d213453b 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -32,6 +32,19 @@ in count 0 0 + let count_newlines s = + let len = String.length s in + let n = ref 0 in + String.iteri (fun i c -> + match c with (* skip "\r\n" *) + | '\r' when i + 1 = len || s.[i+1] = '\n' -> incr n + | '\n' -> incr n + | _ -> ()) s; + !n + + (* Whether a string starts with a newline (used on strings that might match the [nl] regexp) *) + let is_nl s = String.length s = 0 || let c = s.[0] in c = '\n' || c = '\r' + let remove_newline s = let n = String.length s in let rec count i = if i == n || s.[i] <> '\n' then i else count (i + 1) in @@ -65,8 +78,12 @@ let eol = s.[String.length s - 1] = '\n' in (eol, if eol then String.sub s 1 (String.length s - 1) else s) + let is_none x = + match x with + | None -> true + | Some _ -> false - let formatted = ref false + let formatted : position option ref = ref None let brackets = ref 0 let comment_level = ref 0 let in_proof = ref None @@ -124,7 +141,7 @@ (* Reset the globals *) let reset () = - formatted := false; + formatted := None; brackets := 0; comment_level := 0 @@ -252,13 +269,28 @@ let parse_comments () = !Cdglobals.parse_comments && not (only_gallina ()) + (* Advance lexbuf by n lines. Equivalent to calling [Lexing.new_line lexbuf] n times *) + let new_lines n lexbuf = + let lcp = lexbuf.lex_curr_p in + if lcp != dummy_pos then + lexbuf.lex_curr_p <- + { lcp with + pos_lnum = lcp.pos_lnum + n; + pos_bol = lcp.pos_cnum } + + let print_position chan p = + Printf.fprintf chan "%s:%d:%d" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) + + exception MismatchPreformatted of position + + (* let debug lexbuf msg = Printf.printf "%a %s\n" print_position lexbuf.lex_start_p msg *) } (*s Regular expressions *) let space = [' ' '\t'] -let space_nl = [' ' '\t' '\n' '\r'] -let nl = "\r\n" | '\n' +let nl = "\r\n" | '\n' | '\r' +let space_nl = space | nl let firstchar = ['A'-'Z' 'a'-'z' '_'] | @@ -435,12 +467,12 @@ let section = "*" | "**" | "***" | "****" let item_space = " " -let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* nl -let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* nl -let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* nl -let end_show = "(*" space* "end" space+ "show" space* "*)" space* nl +let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* +let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* +let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* +let end_show = "(*" space* "end" space+ "show" space* "*)" space* let begin_details = "(*" space* "begin" space+ "details" space* -let end_details = "(*" space* "end" space+ "details" space* "*)" space* nl +let end_details = "(*" space* "end" space+ "details" space* "*)" space* (* let begin_verb = "(*" space* "begin" space+ "verb" space* "*)" let end_verb = "(*" space* "end" space+ "verb" space* "*)" @@ -449,29 +481,36 @@ let end_verb = "(*" space* "end" space+ "verb" space* "*)" (*s Scanning Coq, at beginning of line *) rule coq_bol = parse - | space* nl+ - { if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) + | space* (nl+ as s) + { new_lines (String.length s) lexbuf; + if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) then Output.empty_line_of_code (); coq_bol lexbuf } - | space* "(**" space_nl - { Output.end_coq (); Output.start_doc (); + | space* "(**" (space_nl as s) + { if is_nl s then Lexing.new_line lexbuf; + Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } - | space* "Comments" space_nl - { Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc (); - Output.start_coq (); coq lexbuf } - | space* begin_hide - { skip_hide lexbuf; coq_bol lexbuf } - | space* begin_show - { begin_show (); coq_bol lexbuf } - | space* end_show - { end_show (); coq_bol lexbuf } - | space* begin_details - { let s = details_body lexbuf in + | space* "Comments" (space_nl as s) + { if is_nl s then Lexing.new_line lexbuf; + Output.end_coq (); Output.start_doc (); + comments lexbuf; + Output.end_doc (); Output.start_coq (); + coq lexbuf } + | space* begin_hide nl + { Lexing.new_line lexbuf; skip_hide lexbuf; coq_bol lexbuf } + | space* begin_show nl + { Lexing.new_line lexbuf; begin_show (); coq_bol lexbuf } + | space* end_show nl + { Lexing.new_line lexbuf; end_show (); coq_bol lexbuf } + | space* begin_details nl + { Lexing.new_line lexbuf; + let s = details_body lexbuf in Output.end_coq (); begin_details s; Output.start_coq (); coq_bol lexbuf } - | space* end_details - { Output.end_coq (); end_details (); Output.start_coq (); coq_bol lexbuf } + | space* end_details nl + { Lexing.new_line lexbuf; + Output.end_coq (); end_details (); Output.start_coq (); coq_bol lexbuf } | space* (("Local"|"Global") space+)? gallina_kw_to_hide { let s = lexeme lexbuf in if !Cdglobals.light && section_or_end s then @@ -577,9 +616,10 @@ rule coq_bol = parse and coq = parse | nl - { if not (only_gallina ()) then Output.line_break(); coq_bol lexbuf } - | "(**" space_nl - { Output.end_coq (); Output.start_doc (); + { Lexing.new_line lexbuf; if not (only_gallina ()) then Output.line_break(); coq_bol lexbuf } + | "(**" (space_nl as s) + { if is_nl s then Lexing.new_line lexbuf; + Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } @@ -591,8 +631,9 @@ and coq = parse comment lexbuf end else skipped_comment lexbuf in if eol then coq_bol lexbuf else coq lexbuf } - | nl+ space* "]]" - { if not !formatted then + | (nl+ as s) space* "]]" + { new_lines (count_newlines s) lexbuf; + if is_none !formatted then begin (* Isn't this an anomaly *) let s = lexeme lexbuf in @@ -677,8 +718,9 @@ and coq = parse (*s Scanning documentation, at beginning of line *) and doc_bol = parse - | space* section space+ ([^'\n' '*'] | '*'+ [^'\n' ')' '*'])* ('*'+ '\n')? - { let eol, lex = strip_eol (lexeme lexbuf) in + | space* section space+ ([^'\n' '\r' '*'] | '*'+ [^'\n' '\r' ')' '*'])* ('*'+ (nl as s))? + { if not (is_none s) then Lexing.new_line lexbuf; + let eol, lex = strip_eol (lexeme lexbuf) in let lev, s = sec_title lex in if (!Cdglobals.lib_subtitles) && (subtitle (Output.get_module false) s) then @@ -686,24 +728,20 @@ and doc_bol = parse else Output.section lev (fun () -> ignore (doc None (from_string s))); if eol then doc_bol lexbuf else doc None lexbuf } - | space_nl* '-'+ - { let buf' = lexeme lexbuf in - let bufs = Str.split_delim (Str.regexp "['\n']") buf' in - let lines = (List.length bufs) - 1 in - let line = - match bufs with - | [] -> eprintf "Internal error bad_split1 - please report\n"; - exit 1 - | _ -> List.nth bufs lines - in - match check_start_list line with - | Neither -> backtrack_past_newline lexbuf; doc None lexbuf - | List n -> if lines > 0 then Output.paragraph (); - Output.item 1; doc (Some [n]) lexbuf - | Rule -> Output.rule (); doc None lexbuf + | (space_nl* as s) ('-'+ as line) + { let nl_count = count_newlines s in + match check_start_list line with + | Neither -> backtrack_past_newline lexbuf; Lexing.new_line lexbuf; doc None lexbuf + | List n -> + new_lines nl_count lexbuf; + if nl_count > 0 then Output.paragraph (); + Output.item 1; doc (Some [n]) lexbuf + | Rule -> + new_lines nl_count lexbuf; + Output.rule (); doc None lexbuf } - | space* nl+ - { Output.paragraph (); doc_bol lexbuf } + | (space_nl* nl) as s + { new_lines (count_newlines s) lexbuf; Output.paragraph (); doc_bol lexbuf } | "<<" space* { Output.start_verbatim false; verbatim 0 false lexbuf; doc_bol lexbuf } | eof @@ -711,8 +749,7 @@ and doc_bol = parse | '_' { if !Cdglobals.plain_comments then Output.char '_' else start_emph (); doc None lexbuf } - | _ - { backtrack lexbuf; doc None lexbuf } + | "" { doc None lexbuf } (*s Scanning lists - using whitespace *) and doc_list_bol indents = parse @@ -733,11 +770,11 @@ and doc_list_bol indents = parse verbatim 0 false lexbuf; doc_list_bol indents lexbuf } | "[[" nl - { formatted := true; + { formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); ignore(body_bol lexbuf); Output.end_inline_coq_block (); - formatted := false; + formatted := None; doc_list_bol indents lexbuf } | "[[[" nl { inf_rules (Some indents) lexbuf } @@ -800,10 +837,10 @@ and doc indents = parse | "[[" nl { if !Cdglobals.plain_comments then (Output.char '['; Output.char '['; doc indents lexbuf) - else (formatted := true; + else (formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); let eol = body_bol lexbuf in - Output.end_inline_coq_block (); formatted := false; + Output.end_inline_coq_block (); formatted := None; if eol then match indents with | Some ls -> doc_list_bol ls lexbuf @@ -828,16 +865,15 @@ and doc indents = parse if !Cdglobals.parse_comments then comment lexbuf else skipped_comment lexbuf in if eol then bol_parse lexbuf else doc indents lexbuf } - | '*'* "*)" space_nl* "(**" - {(match indents with + | '*'* "*)" (space_nl* as s) "(**" + { let nl_count = count_newlines s in + new_lines nl_count lexbuf; + (match indents with | Some _ -> Output.stop_item () | None -> ()); (* this says - if there is a blank line between the two comments, insert one in the output too *) - let lines = List.length (Str.split_delim (Str.regexp "['\n']") - (lexeme lexbuf)) - in - if lines > 2 then Output.paragraph (); + if nl_count > 1 then Output.paragraph (); doc_bol lexbuf } | '*'* "*)" space* nl @@ -1029,10 +1065,10 @@ and comment = parse comment lexbuf } | "[[" nl { if !Cdglobals.plain_comments then (Output.char '['; Output.char '[') - else (formatted := true; + else (formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); let _ = body_bol lexbuf in - Output.end_inline_coq_block (); formatted := false); + Output.end_inline_coq_block (); formatted := None); comment lexbuf } | "$" { if !Cdglobals.plain_comments then Output.char '$' @@ -1095,13 +1131,14 @@ and skip_to_dot_or_brace = parse and body_bol = parse | space+ { Output.indentation (fst (count_spaces (lexeme lexbuf))); body lexbuf } - | _ { backtrack lexbuf; Output.indentation 0; body lexbuf } + | "" { Output.indentation 0; body lexbuf } and body = parse | nl {Tokens.flush_sublexer(); Output.line_break(); Lexing.new_line lexbuf; body_bol lexbuf} - | nl+ space* "]]" space* nl - { Tokens.flush_sublexer(); - if not !formatted then + | (nl+ as s) space* "]]" space* nl + { new_lines (count_newlines s + 1) lexbuf; + Tokens.flush_sublexer(); + if is_none !formatted then begin let s = lexeme lexbuf in let nlsp,s = remove_newline s in @@ -1119,7 +1156,8 @@ and body = parse end } | "]]" space* nl { Tokens.flush_sublexer(); - if not !formatted then + Lexing.new_line lexbuf; + if is_none !formatted then begin let loc = lexeme_start lexbuf in Output.sublexer ']' loc; @@ -1133,13 +1171,19 @@ and body = parse Output.paragraph (); true end } - | eof { Tokens.flush_sublexer(); false } - | '.' space* nl | '.' space* eof - { Tokens.flush_sublexer(); Output.char '.'; Output.line_break(); - if not !formatted then true else body_bol lexbuf } + | eof + { Tokens.flush_sublexer(); + match !formatted with + | None -> false + | Some p -> raise (MismatchPreformatted p) } + | '.' space* (nl as s | eof) + { if not (is_none s) then new_line lexbuf; + Tokens.flush_sublexer(); Output.char '.'; Output.line_break(); + if is_none !formatted then true else body_bol lexbuf } | '.' space* nl "]]" space* nl - { Tokens.flush_sublexer(); Output.char '.'; - if not !formatted then + { new_lines 2 lexbuf; + Tokens.flush_sublexer(); Output.char '.'; + if is_none !formatted then begin eprintf "Error: stray ]] at %d\n" (lexeme_start lexbuf); flush stderr; @@ -1153,9 +1197,10 @@ and body = parse } | '.' space+ { Tokens.flush_sublexer(); Output.char '.'; Output.char ' '; - if not !formatted then false else body lexbuf } - | "(**" space_nl - { Tokens.flush_sublexer(); Output.end_coq (); Output.start_doc (); + if is_none !formatted then false else body lexbuf } + | "(**" (space_nl as s) + { if is_nl s then new_line lexbuf; + Tokens.flush_sublexer(); Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then body_bol lexbuf else body lexbuf } @@ -1220,27 +1265,32 @@ and string = parse | _ { let c = lexeme_char lexbuf 0 in Output.char c; string lexbuf } and skip_hide = parse - | eof | end_hide { () } + | eof | end_hide nl { Lexing.new_line lexbuf; () } | _ { skip_hide lexbuf } (*s Reading token pretty-print *) and printing_token_body = parse - | "*)" nl? | eof - { let s = Buffer.contents token_buffer in + | "*)" (nl as s)? | eof + { if not (is_none s) then Lexing.new_line lexbuf; + let s = Buffer.contents token_buffer in Buffer.clear token_buffer; s } - | _ { Buffer.add_string token_buffer (lexeme lexbuf); + | (nl | _) as s + { if is_nl s then Lexing.new_line lexbuf; + Buffer.add_string token_buffer (lexeme lexbuf); printing_token_body lexbuf } and details_body = parse - | "*)" space* nl? | eof - { None } + | "*)" space* (nl as s)? | eof + { if not (is_none s) then Lexing.new_line lexbuf; + None } | ":" space* { details_body_rec lexbuf } and details_body_rec = parse - | "*)" space* nl? | eof - { let s = Buffer.contents token_buffer in + | "*)" space* (nl as s)? | eof + { if not (is_none s) then Lexing.new_line lexbuf; + let s = Buffer.contents token_buffer in Buffer.clear token_buffer; Some s } | _ { Buffer.add_string token_buffer (lexeme lexbuf); @@ -1343,6 +1393,14 @@ and st_subtitle = parse (*s Applying the scanners to files *) { + (* coq_bol with error handling *) + let coq_bol' f lb = + Lexing.new_line lb; (* Start numbering lines from 1 *) + try coq_bol lb with + | MismatchPreformatted p -> + Printf.eprintf "%a: mismatched \"[[\"\n" print_position { p with pos_fname = f }; + exit 1 + let coq_file f m = reset (); let c = open_in f in @@ -1350,7 +1408,7 @@ and st_subtitle = parse (Index.current_library := m; Output.initialize (); Output.start_module (); - Output.start_coq (); coq_bol lb; Output.end_coq (); + Output.start_coq (); coq_bol' f lb; Output.end_coq (); close_in c) let detect_subtitle f m = diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index a7a9b77b56..c8b8660b92 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -131,7 +131,7 @@ let set_options = List.iter set_option let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = - let pfs = Vernacstate.Proof_global.get_all_proof_names () [@ocaml.warning "-3"] in + let pfs = Vernacstate.Declare.get_all_proof_names () [@ocaml.warning "-3"] in if not (CList.is_empty pfs) then fatal_error (str "There are pending proofs: " ++ (pfs diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 1988c7cc42..cfc89782a1 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -286,6 +286,30 @@ let parse_option_set opt = let v = String.sub opt (eqi+1) (len - eqi - 1) in to_opt_key (String.sub opt 0 eqi), Some v +let warn_no_native_compiler = + CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" + Pp.(fun s -> strbrk "Native compiler is disabled," ++ + strbrk " -native-compiler " ++ strbrk s ++ + strbrk " option ignored.") + +let get_native_compiler s = + (* We use two boolean flags because the four states make sense, even if + only three are accessible to the user at the moment. The selection of the + produced artifact(s) (`.vo`, `.vio`, `.coq-native`, ...) should be done by + a separate flag, and the "ondemand" value removed. Once this is done, use + [get_bool] here. *) + let n = match s with + | ("yes" | "on") -> NativeOn {ondemand=false} + | "ondemand" -> NativeOn {ondemand=true} + | ("no" | "off") -> NativeOff + | _ -> + error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") in + if not Coq_config.native_compiler && n <> NativeOff then + let () = warn_no_native_compiler s in + NativeOff + else + n + (* Main parsing routine *) (*s Parsing of the command line *) @@ -455,20 +479,7 @@ let parse_args ~help ~init arglist : t * string list = { oval with config = { oval.config with enable_VM = get_bool opt (next ()) }} |"-native-compiler" -> - - (* We use two boolean flags because the four states make sense, even if - only three are accessible to the user at the moment. The selection of the - produced artifact(s) (`.vo`, `.vio`, `.coq-native`, ...) should be done by - a separate flag, and the "ondemand" value removed. Once this is done, use - [get_bool] here. *) - let native_compiler = - match (next ()) with - | ("yes" | "on") -> NativeOn {ondemand=false} - | "ondemand" -> NativeOn {ondemand=true} - | ("no" | "off") -> NativeOff - | _ -> - error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") - in + let native_compiler = get_native_compiler (next ()) in { oval with config = { oval.config with native_compiler }} | "-set" -> diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index b8acdd3af1..2c5faa4df7 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -191,8 +191,8 @@ end from cycling. *) let make_prompt () = try - (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) ^ " < " - with Vernacstate.Proof_global.NoCurrentProof -> + (Names.Id.to_string (Vernacstate.Declare.get_current_proof_name ())) ^ " < " + with Vernacstate.Declare.NoCurrentProof -> "Coq < " [@@ocaml.warning "-3"] @@ -352,7 +352,7 @@ let print_anyway c = let top_goal_print ~doc c oldp newp = try let proof_changed = not (Option.equal cproof oldp newp) in - let print_goals = proof_changed && Vernacstate.Proof_global.there_are_pending_proofs () || + let print_goals = proof_changed && Vernacstate.Declare.there_are_pending_proofs () || print_anyway c in if not !Flags.quiet && print_goals then begin let dproof = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in @@ -375,7 +375,7 @@ let exit_on_error = point we should consolidate the code *) let show_proof_diff_to_pp pstate = let p = Option.get pstate in - let sigma, env = Pfedit.get_proof_context p in + let sigma, env = Proof.get_proof_context p in let pprf = Proof.partial_proof p in Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf @@ -392,7 +392,7 @@ let show_proof_diff_cmd ~state removed = let show_removed = Some removed in Pp_diff.diff_pp_combined ~tokenize_string ?show_removed o_pp n_pp with - | Pfedit.NoSuchGoal + | Proof.NoSuchGoal _ | Option.IsNone -> n_pp | Pp_diff.Diff_Failure msg -> begin (* todo: print the unparsable string (if we know it) *) @@ -403,7 +403,7 @@ let show_proof_diff_cmd ~state removed = else n_pp with - | Pfedit.NoSuchGoal + | Proof.NoSuchGoal _ | Option.IsNone -> CErrors.user_err (str "No goals to show.") diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 076796468f..c4c8492a4a 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -66,7 +66,7 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = (* Force the command *) let ndoc = if check then Stm.observe ~doc nsid else doc in - let new_proof = Vernacstate.Proof_global.give_me_the_proof_opt () [@ocaml.warning "-3"] in + let new_proof = Vernacstate.Declare.give_me_the_proof_opt () [@ocaml.warning "-3"] in { state with doc = ndoc; sid = nsid; proof = new_proof; } with reraise -> let (reraise, info) = Exninfo.capture reraise in diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 72df4d75c8..2102cd1172 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1290,7 +1290,7 @@ let () = let ist = Tac2interp.get_env ist in let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in let name, poly = Id.of_string "ltac2", poly in - let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma concl tac in + let c, sigma = Proof.refine_by_tactic ~name ~poly env sigma concl tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_ltac2_constr interp diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index ebc63ddd01..28e877491e 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -91,7 +91,7 @@ let inTacDef : tacdef -> obj = declare_object {(default_object "TAC2-DEFINITION") with cache_function = cache_tacdef; load_function = load_tacdef; - open_function = open_tacdef; + open_function = simple_open open_tacdef; subst_function = subst_tacdef; classify_function = classify_tacdef} @@ -198,7 +198,7 @@ let inTypDef : typdef -> obj = declare_object {(default_object "TAC2-TYPE-DEFINITION") with cache_function = cache_typdef; load_function = load_typdef; - open_function = open_typdef; + open_function = simple_open open_typdef; subst_function = subst_typdef; classify_function = classify_typdef} @@ -268,7 +268,7 @@ let inTypExt : typext -> obj = declare_object {(default_object "TAC2-TYPE-EXTENSION") with cache_function = cache_typext; load_function = load_typext; - open_function = open_typext; + open_function = simple_open open_typext; subst_function = subst_typext; classify_function = classify_typext} @@ -664,7 +664,7 @@ let classify_synext o = let inTac2Notation : synext -> obj = declare_object {(default_object "TAC2-NOTATION") with cache_function = cache_synext; - open_function = open_synext; + open_function = simple_open open_synext; subst_function = subst_synext; classify_function = classify_synext} @@ -694,7 +694,7 @@ let inTac2Abbreviation : abbreviation -> obj = declare_object {(default_object "TAC2-ABBREVIATION") with cache_function = cache_abbreviation; load_function = load_abbreviation; - open_function = open_abbreviation; + open_function = simple_open open_abbreviation; subst_function = subst_abbreviation; classify_function = classify_abbreviation} @@ -747,7 +747,7 @@ let classify_redefinition o = Substitute o let inTac2Redefinition : redefinition -> obj = declare_object {(default_object "TAC2-REDEFINITION") with cache_function = perform_redefinition; - open_function = (fun _ -> perform_redefinition); + open_function = simple_open (fun _ -> perform_redefinition); subst_function = subst_redefinition; classify_function = classify_redefinition } @@ -795,7 +795,7 @@ let perform_eval ~pstate e = Goal_select.SelectAll, Proof.start ~name ~poly sigma [] | Some pstate -> Goal_select.get_default_goal_selector (), - Proof_global.get_proof pstate + Declare.Proof.get_proof pstate in let v = match selector with | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v @@ -899,10 +899,10 @@ let print_ltac qid = (** Calling tactics *) let solve ~pstate default tac = - let pstate, status = Proof_global.map_fold_proof_endline begin fun etac p -> + let pstate, status = Declare.Proof.map_fold_proof_endline begin fun etac p -> let with_end_tac = if default then Some etac else None in let g = Goal_select.get_default_goal_selector () in - let (p, status) = Pfedit.solve g None tac ?with_end_tac p in + let (p, status) = Proof.solve g None tac ?with_end_tac p in (* in case a strict subtree was completed, go back to the top of the prooftree *) let p = Proof.maximal_unfocus Vernacentries.command_focus p in @@ -962,7 +962,7 @@ let inTac2Init : unit -> obj = declare_object {(default_object "TAC2-INIT") with cache_function = cache_ltac2_init; load_function = load_ltac2_init; - open_function = open_ltac2_init; + open_function = simple_open open_ltac2_init; } let _ = Mltop.declare_cache_obj begin fun () -> diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index edad118dc9..fc56a54e3a 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -31,7 +31,7 @@ val register_struct val register_notation : ?local:bool -> sexpr list -> int option -> raw_tacexpr -> unit -val perform_eval : pstate:Proof_global.t option -> raw_tacexpr -> unit +val perform_eval : pstate:Declare.Proof.t option -> raw_tacexpr -> unit (** {5 Notations} *) @@ -53,7 +53,7 @@ val print_ltac : Libnames.qualid -> unit (** {5 Eval loop} *) (** Evaluate a tactic expression in the current environment *) -val call : pstate:Proof_global.t -> default:bool -> raw_tacexpr -> Proof_global.t +val call : pstate:Declare.Proof.t -> default:bool -> raw_tacexpr -> Declare.Proof.t (** {5 Toplevel exceptions} *) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index f3ad324aa5..215d5d97a0 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -699,7 +699,7 @@ let make_bl_scheme mode mind = let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let bl_goal = EConstr.of_constr bl_goal in - let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:bl_goal + let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:bl_goal (compute_bl_tact mode (!bl_scheme_kind_aux()) (ind, EConstr.EInstance.empty) lnamesparrec nparrec) in ([|ans|], ctx), eff @@ -829,7 +829,7 @@ let make_lb_scheme mode mind = let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let lb_goal = EConstr.of_constr lb_goal in - let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:lb_goal + let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:lb_goal (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) in ([|ans|], ctx), eff @@ -1006,7 +1006,7 @@ let make_eq_decidability mode mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let side_eff = side_effect_of_mode mode in - let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx + let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:(EConstr.of_constr (compute_dec_goal (ind,u) lnamesparrec nparrec)) (compute_dec_tact ind lnamesparrec nparrec) in diff --git a/vernac/canonical.ml b/vernac/canonical.ml index 390ed62bee..eaa6c84791 100644 --- a/vernac/canonical.ml +++ b/vernac/canonical.ml @@ -28,7 +28,7 @@ let discharge_canonical_structure (_,((gref, _ as x), local)) = let inCanonStruc : (GlobRef.t * inductive) * bool -> obj = declare_object {(default_object "CANONICAL-STRUCTURE") with - open_function = open_canonical_structure; + open_function = simple_open open_canonical_structure; cache_function = cache_canonical_structure; subst_function = (fun (subst,(c,local)) -> subst_canonical_structure subst c, local); classify_function = (fun x -> Substitute x); diff --git a/vernac/classes.ml b/vernac/classes.ml index 3d38713e09..eb735b7cdf 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -116,7 +116,7 @@ let instance_input : instance -> obj = { (default_object "type classes instances state") with cache_function = cache_instance; load_function = (fun _ x -> cache_instance x); - open_function = (fun _ x -> cache_instance x); + open_function = simple_open (fun _ x -> cache_instance x); classify_function = classify_instance; discharge_function = discharge_instance; rebuild_function = rebuild_instance; @@ -237,7 +237,7 @@ let class_input : typeclass -> obj = { (default_object "type classes state") with cache_function = cache_class; load_function = (fun _ -> cache_class); - open_function = (fun _ -> cache_class); + open_function = simple_open (fun _ -> cache_class); classify_function = (fun x -> Substitute x); discharge_function = (fun a -> Some (discharge_class a)); rebuild_function = rebuild_class; @@ -485,10 +485,8 @@ let do_instance env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imp interp_props ~program_mode:false env' cty k u ctx ctx' subst sigma props in let termtype, sigma = do_instance_resolve_TC termtype sigma env in - if Evd.has_undefined sigma then - CErrors.user_err Pp.(str "Unsolved obligations remaining.") - else - declare_instance_constant pri global imps ?hook id decl poly sigma term termtype + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + declare_instance_constant pri global imps ?hook id decl poly sigma term termtype let do_instance_program env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props = let term, termtype, sigma = diff --git a/vernac/comArguments.ml b/vernac/comArguments.ml index 90791a0906..360e228bfc 100644 --- a/vernac/comArguments.ml +++ b/vernac/comArguments.ml @@ -52,10 +52,10 @@ let warn_arguments_assert = CWarnings.create ~name:"arguments-assert" ~category:"vernacular" Pp.(fun sr -> strbrk "This command is just asserting the names of arguments of " ++ - Printer.pr_global sr ++ strbrk". If this is what you want add " ++ + Printer.pr_global sr ++ strbrk". If this is what you want, add " ++ strbrk "': assert' to silence the warning. If you want " ++ - strbrk "to clear implicit arguments add ': clear implicits'. " ++ - strbrk "If you want to clear notation scopes add ': clear scopes'") + strbrk "to clear implicit arguments, add ': clear implicits'. " ++ + strbrk "If you want to clear notation scopes, add ': clear scopes'") (* [nargs_for_red] is the number of arguments required to trigger reduction, [args] is the main list of arguments statuses, diff --git a/vernac/comCoercion.ml b/vernac/comCoercion.ml index c339c53a9b..4a8e217fc1 100644 --- a/vernac/comCoercion.ml +++ b/vernac/comCoercion.ml @@ -256,7 +256,7 @@ let classify_coercion obj = let inCoercion : coercion -> obj = declare_object {(default_object "COERCION") with - open_function = open_coercion; + open_function = simple_open open_coercion; cache_function = cache_coercion; subst_function = (fun (subst,c) -> subst_coercion subst c); classify_function = classify_coercion; diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 1607771598..601e7e060c 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -171,7 +171,7 @@ let prepare_obligation ?opaque ?inline ~name ~poly ~udecl ~types ~body sigma = let ce = definition_entry ?opaque ?inline ?types ~univs body in let env = Global.env () in let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in - assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); + assert(Safe_typing.is_empty_private_constants sideff.Evd.seff_private); assert(Univ.ContextSet.is_empty ctx); RetrieveObl.check_evars env sigma; let c = EConstr.of_constr c in diff --git a/vernac/declareInd.ml b/vernac/declareInd.ml index 2610f16d92..3e6552c8d2 100644 --- a/vernac/declareInd.ml +++ b/vernac/declareInd.ml @@ -49,9 +49,12 @@ let load_inductive i ((sp, kn), names) = let names = inductive_names sp kn names in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref ) names -let open_inductive i ((sp, kn), names) = +let open_inductive f i ((sp, kn), names) = let names = inductive_names sp kn names in - List.iter (fun (sp, ref) -> Nametab.push (Nametab.Exactly i) sp ref) names + List.iter (fun (sp, ref) -> + if Libobject.in_filter_ref ref f then + Nametab.push (Nametab.Exactly i) sp ref) + names let cache_inductive ((sp, kn), names) = let names = inductive_names sp kn names in diff --git a/vernac/declareUniv.ml b/vernac/declareUniv.ml index 300dfe6c35..20fa43c8e7 100644 --- a/vernac/declareUniv.ml +++ b/vernac/declareUniv.ml @@ -56,7 +56,7 @@ let input_univ_names : universe_name_decl -> Libobject.obj = { (default_object "Global universe name state") with cache_function = cache_univ_names; load_function = load_univ_names; - open_function = open_univ_names; + open_function = simple_open open_univ_names; discharge_function = discharge_univ_names; subst_function = (fun (subst, a) -> (* Actually the name is generated once and for all. *) a); classify_function = (fun a -> Substitute a) } diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index 4f527b73d0..438509e28a 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -81,6 +81,19 @@ module ModSubstObjs : let sobjs_no_functor (mbids,_) = List.is_empty mbids +let subst_filtered sub (f,mp) = + let f = match f with + | Unfiltered -> Unfiltered + | Names ns -> + let module NSet = Globnames.ExtRefSet in + let ns = + NSet.fold (fun n ns -> NSet.add (Globnames.subst_extended_reference sub n) ns) + ns NSet.empty + in + Names ns + in + f, subst_mp sub mp + let rec subst_aobjs sub = function | Objs o as objs -> let o' = subst_objects sub o in @@ -109,7 +122,7 @@ and subst_objects subst seg = let aobjs' = subst_aobjs subst aobjs in if aobjs' == aobjs then node else (id, IncludeObject aobjs') | ExportObject { mpl } -> - let mpl' = List.map (subst_mp subst) mpl in + let mpl' = List.Smart.map (subst_filtered subst) mpl in if mpl'==mpl then node else (id, ExportObject { mpl = mpl' }) | KeepObject _ -> assert false in @@ -285,86 +298,103 @@ and load_keep i ((sp,kn),kobjs) = (** {6 Implementation of Import and Export commands} *) -let mark_object obj (exports,acc) = - (exports, obj::acc) +let mark_object f obj (exports,acc) = + (exports, (f,obj)::acc) -let rec collect_module_objects mp acc = +let rec collect_module_objects (f,mp) acc = (* May raise Not_found for unknown module and for functors *) let modobjs = ModObjs.get mp in let prefix = modobjs.module_prefix in - let acc = collect_objects 1 prefix modobjs.module_keep_objects acc in - collect_objects 1 prefix modobjs.module_substituted_objects acc + let acc = collect_objects f 1 prefix modobjs.module_keep_objects acc in + collect_objects f 1 prefix modobjs.module_substituted_objects acc -and collect_object i (name, obj as o) acc = +and collect_object f i (name, obj as o) acc = match obj with - | ExportObject { mpl; _ } -> collect_export i mpl acc + | ExportObject { mpl } -> collect_export f i mpl acc | AtomicObject _ | IncludeObject _ | KeepObject _ - | ModuleObject _ | ModuleTypeObject _ -> mark_object o acc + | ModuleObject _ | ModuleTypeObject _ -> mark_object f o acc + +and collect_objects f i prefix objs acc = + List.fold_right (fun (id, obj) acc -> collect_object f i (Lib.make_oname prefix id, obj) acc) objs acc + +and collect_one_export f (f',mp) (exports,objs as acc) = + match filter_and f f' with + | None -> acc + | Some f -> + let exports' = MPmap.update mp (function + | None -> Some f + | Some f0 -> Some (filter_or f f0)) + exports + in + (* If the map doesn't change there is nothing new to export. -and collect_objects i prefix objs acc = - List.fold_right (fun (id, obj) acc -> collect_object i (Lib.make_oname prefix id, obj) acc) objs acc + It's possible that [filter_and] or [filter_or] mangled precise + filters such that we repeat uselessly, but the important + [Unfiltered] case is handled correctly. + *) + if exports == exports' then acc + else + collect_module_objects (f,mp) (exports', objs) -and collect_one_export mp (exports,objs as acc) = - if not (MPset.mem mp exports) then - collect_module_objects mp (MPset.add mp exports, objs) - else acc -and collect_export i mpl acc = +and collect_export f i mpl acc = if Int.equal i 1 then - List.fold_right collect_one_export mpl acc + List.fold_right (collect_one_export f) mpl acc else acc -let rec open_object i (name, obj) = +let open_modtype i ((sp,kn),_) = + let mp = mp_of_kn kn in + let mp' = + try Nametab.locate_modtype (qualid_of_path sp) + with Not_found -> + anomaly (pr_path sp ++ str " should already exist!"); + in + assert (ModPath.equal mp mp'); + Nametab.push_modtype (Nametab.Exactly i) sp mp + +let rec open_object f i (name, obj) = match obj with - | AtomicObject o -> Libobject.open_object i (name, o) + | AtomicObject o -> Libobject.open_object f i (name, o) | ModuleObject sobjs -> let dir = dir_of_sp (fst name) in let mp = mp_of_kn (snd name) in - open_module i dir mp sobjs + open_module f i dir mp sobjs | ModuleTypeObject sobjs -> open_modtype i (name, sobjs) - | IncludeObject aobjs -> open_include i (name, aobjs) - | ExportObject { mpl; _ } -> open_export i mpl - | KeepObject objs -> open_keep i (name, objs) + | IncludeObject aobjs -> open_include f i (name, aobjs) + | ExportObject { mpl } -> open_export f i mpl + | KeepObject objs -> open_keep f i (name, objs) -and open_module i obj_dir obj_mp sobjs = +and open_module f i obj_dir obj_mp sobjs = let prefix = Nametab.{ obj_dir ; obj_mp; } in let dirinfo = Nametab.GlobDirRef.DirModule prefix in consistency_checks true obj_dir dirinfo; - Nametab.push_dir (Nametab.Exactly i) obj_dir dirinfo; + (match f with + | Unfiltered -> Nametab.push_dir (Nametab.Exactly i) obj_dir dirinfo + | Names _ -> ()); (* If we're not a functor, let's iter on the internal components *) if sobjs_no_functor sobjs then begin let modobjs = ModObjs.get obj_mp in - open_objects (i+1) modobjs.module_prefix modobjs.module_substituted_objects + open_objects f (i+1) modobjs.module_prefix modobjs.module_substituted_objects end -and open_objects i prefix objs = - List.iter (fun (id, obj) -> open_object i (Lib.make_oname prefix id, obj)) objs - -and open_modtype i ((sp,kn),_) = - let mp = mp_of_kn kn in - let mp' = - try Nametab.locate_modtype (qualid_of_path sp) - with Not_found -> - anomaly (pr_path sp ++ str " should already exist!"); - in - assert (ModPath.equal mp mp'); - Nametab.push_modtype (Nametab.Exactly i) sp mp +and open_objects f i prefix objs = + List.iter (fun (id, obj) -> open_object f i (Lib.make_oname prefix id, obj)) objs -and open_include i ((sp,kn), aobjs) = +and open_include f i ((sp,kn), aobjs) = let obj_dir = Libnames.dirpath sp in let obj_mp = KerName.modpath kn in let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in - open_objects i prefix o + open_objects f i prefix o -and open_export i mpl = - let _,objs = collect_export i mpl (MPset.empty, []) in - List.iter (open_object 1) objs +and open_export f i mpl = + let _,objs = collect_export f i mpl (MPmap.empty, []) in + List.iter (fun (f,o) -> open_object f 1 o) objs -and open_keep i ((sp,kn),kobjs) = +and open_keep f i ((sp,kn),kobjs) = let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in let prefix = Nametab.{ obj_dir; obj_mp; } in - open_objects i prefix kobjs + open_objects f i prefix kobjs let rec cache_object (name, obj) = match obj with @@ -383,7 +413,7 @@ and cache_include ((sp,kn), aobjs) = let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in load_objects 1 prefix o; - open_objects 1 prefix o + open_objects Unfiltered 1 prefix o and cache_keep ((sp,kn),kobjs) = anomaly (Pp.str "This module should not be cached!") @@ -1023,12 +1053,12 @@ let end_library ?except ~output_native_objects dir = cenv,(substitute,keep),ast let import_modules ~export mpl = - let _,objs = List.fold_right collect_module_objects mpl (MPset.empty, []) in - List.iter (open_object 1) objs; + let _,objs = List.fold_right collect_module_objects mpl (MPmap.empty, []) in + List.iter (fun (f,o) -> open_object f 1 o) objs; if export then Lib.add_anonymous_entry (Lib.Leaf (ExportObject { mpl })) -let import_module ~export mp = - import_modules ~export [mp] +let import_module f ~export mp = + import_modules ~export [f,mp] (** {6 Iterators} *) @@ -1073,6 +1103,6 @@ let debug_print_modtab _ = let mod_ops = { - Printmod.import_module = import_module; + Printmod.import_module = import_module Unfiltered; process_module_binding = process_module_binding; } diff --git a/vernac/declaremods.mli b/vernac/declaremods.mli index e37299aad6..5e45957e83 100644 --- a/vernac/declaremods.mli +++ b/vernac/declaremods.mli @@ -97,11 +97,11 @@ val append_end_library_hook : (unit -> unit) -> unit or when [mp] corresponds to a functor. If [export] is [true], the module is also opened every time the module containing it is. *) -val import_module : export:bool -> ModPath.t -> unit +val import_module : Libobject.open_filter -> export:bool -> ModPath.t -> unit (** Same as [import_module] but for multiple modules, and more optimized than iterating [import_module]. *) -val import_modules : export:bool -> ModPath.t list -> unit +val import_modules : export:bool -> (Libobject.open_filter * ModPath.t) list -> unit (** Include *) diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index 247f80181a..058fa691ee 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -14,7 +14,6 @@ open Glob_term open Constrexpr open Vernacexpr open Hints -open Proof_global open Pcoq open Pcoq.Prim @@ -65,12 +64,12 @@ GRAMMAR EXTEND Gram | IDENT "Existential"; n = natural; c = constr_body -> { VernacSolveExistential (n,c) } | IDENT "Admitted" -> { VernacEndProof Admitted } - | IDENT "Qed" -> { VernacEndProof (Proved (Opaque,None)) } + | IDENT "Qed" -> { VernacEndProof (Proved (Declare.Opaque,None)) } | IDENT "Save"; id = identref -> - { VernacEndProof (Proved (Opaque, Some id)) } - | IDENT "Defined" -> { VernacEndProof (Proved (Transparent,None)) } + { VernacEndProof (Proved (Declare.Opaque, Some id)) } + | IDENT "Defined" -> { VernacEndProof (Proved (Declare.Transparent,None)) } | IDENT "Defined"; id=identref -> - { VernacEndProof (Proved (Transparent,Some id)) } + { VernacEndProof (Proved (Declare.Transparent,Some id)) } | IDENT "Restart" -> { VernacRestart } | IDENT "Undo" -> { VernacUndo 1 } | IDENT "Undo"; n = natural -> { VernacUndo n } diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 1f52641b82..08ba49f92b 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -566,14 +566,21 @@ GRAMMAR EXTEND Gram | IDENT "From" ; ns = global ; IDENT "Require"; export = export_token ; qidl = LIST1 global -> { VernacRequire (Some ns, export, qidl) } - | IDENT "Import"; qidl = LIST1 global -> { VernacImport (false,qidl) } - | IDENT "Export"; qidl = LIST1 global -> { VernacImport (true,qidl) } + | IDENT "Import"; qidl = LIST1 filtered_import -> { VernacImport (false,qidl) } + | IDENT "Export"; qidl = LIST1 filtered_import -> { VernacImport (true,qidl) } | IDENT "Include"; e = module_type_inl; l = LIST0 ext_module_expr -> { VernacInclude(e::l) } | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type -> { warn_deprecated_include_type ~loc (); VernacInclude(e::l) } ] ] ; + filtered_import: + [ [ m = global -> { (m, ImportAll) } + | m = global; "("; ns = LIST1 one_import_filter_name SEP ","; ")" -> { (m, ImportNames ns) } ] ] + ; + one_import_filter_name: + [ [ n = global; etc = OPT [ "("; ".."; ")" -> { () } ] -> { n, Option.has_some etc } ] ] + ; export_token: [ [ IDENT "Import" -> { Some false } | IDENT "Export" -> { Some true } diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 7f7340bb34..b13e5bf653 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -62,14 +62,14 @@ end (* Proofs with a save constant function *) type t = - { proof : Proof_global.t + { proof : Declare.Proof.t ; info : Info.t } let pf_map f pf = { pf with proof = f pf.proof } let pf_fold f pf = f pf.proof -let set_endline_tactic t = pf_map (Proof_global.set_endline_tactic t) +let set_endline_tactic t = pf_map (Declare.Proof.set_endline_tactic t) (* To be removed *) module Internal = struct @@ -81,7 +81,7 @@ module Internal = struct end let by tac pf = - let proof, res = Pfedit.by tac pf.proof in + let proof, res = Declare.by tac pf.proof in { pf with proof }, res (************************************************************************) @@ -113,7 +113,7 @@ let start_lemma ~name ~poly "opaque", this is a hack tho, see #10446 *) let sign = initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in - let proof = Proof_global.start_proof sigma ~name ~udecl ~poly goals in + let proof = Declare.start_proof sigma ~name ~udecl ~poly goals in let info = add_first_thm ~info ~name ~typ:c ~impargs in { proof; info } @@ -123,7 +123,7 @@ let start_lemma ~name ~poly let start_dependent_lemma ~name ~poly ?(udecl=UState.default_univ_decl) ?(info=Info.make ()) telescope = - let proof = Proof_global.start_dependent_proof ~name ~udecl ~poly telescope in + let proof = Declare.start_dependent_proof ~name ~udecl ~poly telescope in { proof; info } let rec_tac_initializer finite guard thms snl = @@ -173,7 +173,7 @@ let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recgua (* start_lemma has the responsibility to add (name, impargs, typ) to thms, once Info.t is more refined this won't be necessary *) let lemma = start_lemma ~name ~impargs ~poly ~udecl ~info sigma (EConstr.of_constr typ) in - pf_map (Proof_global.map_proof (fun p -> + pf_map (Declare.Proof.map_proof (fun p -> pi1 @@ Proof.run_tactic Global.(env ()) init_tac p)) lemma (************************************************************************) @@ -275,7 +275,7 @@ let get_keep_admitted_vars = let compute_proof_using_for_admitted proof typ pproofs = if not (get_keep_admitted_vars ()) then None - else match Proof_global.get_used_variables proof, pproofs with + else match Declare.Proof.get_used_variables proof, pproofs with | Some _ as x, _ -> x | None, pproof :: _ -> let env = Global.env () in @@ -291,17 +291,17 @@ let finish_admitted ~info ~uctx pe = () let save_lemma_admitted ~(lemma : t) : unit = - let udecl = Proof_global.get_universe_decl lemma.proof in - let Proof.{ poly; entry } = Proof.data (Proof_global.get_proof lemma.proof) in + let udecl = Declare.Proof.get_universe_decl lemma.proof in + let Proof.{ poly; entry } = Proof.data (Declare.Proof.get_proof lemma.proof) in let typ = match Proofview.initial_goals entry with | [typ] -> snd typ | _ -> CErrors.anomaly ~label:"Lemmas.save_lemma_admitted" (Pp.str "more than one statement.") in let typ = EConstr.Unsafe.to_constr typ in - let proof = Proof_global.get_proof lemma.proof in + let proof = Declare.Proof.get_proof lemma.proof in let pproofs = Proof.partial_proof proof in let sec_vars = compute_proof_using_for_admitted lemma.proof typ pproofs in - let uctx = Proof_global.get_initial_euctx lemma.proof in + let uctx = Declare.Proof.get_initial_euctx lemma.proof in let univs = UState.check_univ_decl ~poly uctx udecl in finish_admitted ~info:lemma.info ~uctx (sec_vars, (typ, univs), None) @@ -310,7 +310,7 @@ let save_lemma_admitted ~(lemma : t) : unit = (************************************************************************) let finish_proved po info = - let open Proof_global in + let open Declare in match po with | { entries=[const]; uctx } -> let _r : Names.GlobRef.t list = MutualEntry.declare_mutdef ~info ~uctx const in @@ -343,7 +343,7 @@ let finish_derived ~f ~name ~entries = let lemma_pretype typ = match typ with | Some t -> Some (substf t) - | None -> assert false (* Proof_global always sets type here. *) + | None -> assert false (* Declare always sets type here. *) in (* The references of [f] are subsituted appropriately. *) let lemma_def = Declare.Internal.map_entry_type lemma_def ~f:lemma_pretype in @@ -368,12 +368,12 @@ let finish_proved_equations ~kind ~hook i proof_obj types sigma0 = let sigma, app = Evarutil.new_global sigma (GlobRef.ConstRef cst) in let sigma = Evd.define ev (EConstr.applist (app, List.map EConstr.of_constr args)) sigma in sigma, cst) sigma0 - types proof_obj.Proof_global.entries + types proof_obj.Declare.entries in hook recobls sigma let finalize_proof proof_obj proof_info = - let open Proof_global in + let open Declare in let open Proof_ending in match CEphemeron.default proof_info.Info.proof_ending Regular with | Regular -> @@ -403,7 +403,7 @@ let process_idopt_for_save ~idopt info = let save_lemma_proved ~lemma ~opaque ~idopt = (* Env and sigma are just used for error printing in save_remaining_recthms *) - let proof_obj = Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false lemma.proof in + let proof_obj = Declare.close_proof ~opaque ~keep_body_ucst_separate:false lemma.proof in let proof_info = process_idopt_for_save ~idopt lemma.info in finalize_proof proof_obj proof_info @@ -411,7 +411,7 @@ let save_lemma_proved ~lemma ~opaque ~idopt = (* Special case to close a lemma without forcing a proof *) (***********************************************************************) let save_lemma_admitted_delayed ~proof ~info = - let open Proof_global in + let open Declare in let { entries; uctx } = proof in if List.length entries <> 1 then CErrors.user_err Pp.(str "Admitted does not support multiple statements"); @@ -430,7 +430,7 @@ let save_lemma_proved_delayed ~proof ~info ~idopt = (* vio2vo calls this but with invalid info, we have to workaround that to add the name to the info structure *) if CList.is_empty info.Info.thms then - let info = add_first_thm ~info ~name:proof.Proof_global.name ~typ:EConstr.mkSet ~impargs:[] in + let info = add_first_thm ~info ~name:proof.Declare.name ~typ:EConstr.mkSet ~impargs:[] in finalize_proof proof info else let info = process_idopt_for_save ~idopt info in diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 8a23daa85f..bd2e87ac3a 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -19,10 +19,10 @@ type t val set_endline_tactic : Genarg.glob_generic_argument -> t -> t (** [set_endline_tactic tac lemma] set ending tactic for [lemma] *) -val pf_map : (Proof_global.t -> Proof_global.t) -> t -> t +val pf_map : (Declare.Proof.t -> Declare.Proof.t) -> t -> t (** [pf_map f l] map the underlying proof object *) -val pf_fold : (Proof_global.t -> 'a) -> t -> 'a +val pf_fold : (Declare.Proof.t -> 'a) -> t -> 'a (** [pf_fold f l] fold over the underlying proof object *) val by : unit Proofview.tactic -> t -> t * bool @@ -101,21 +101,21 @@ val start_lemma_with_initialization val save_lemma_admitted : lemma:t -> unit val save_lemma_proved : lemma:t - -> opaque:Proof_global.opacity_flag + -> opaque:Declare.opacity_flag -> idopt:Names.lident option -> unit (** To be removed, don't use! *) module Internal : sig val get_info : t -> Info.t - (** Only needed due to the Proof_global compatibility layer. *) + (** Only needed due to the Declare compatibility layer. *) end (** Special cases for delayed proofs, in this case we must provide the proof information so the proof won't be forced. *) -val save_lemma_admitted_delayed : proof:Proof_global.proof_object -> info:Info.t -> unit +val save_lemma_admitted_delayed : proof:Declare.proof_object -> info:Info.t -> unit val save_lemma_proved_delayed - : proof:Proof_global.proof_object + : proof:Declare.proof_object -> info:Info.t -> idopt:Names.lident option -> unit diff --git a/vernac/library.ml b/vernac/library.ml index 1b0bd4c0f7..01f5101764 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -335,7 +335,11 @@ let load_require _ (_,(needed,modl,_)) = List.iter register_library needed let open_require i (_,(_,modl,export)) = - Option.iter (fun export -> Declaremods.import_modules ~export @@ List.map (fun m -> MPfile m) modl) export + Option.iter (fun export -> + let mpl = List.map (fun m -> Unfiltered, MPfile m) modl in + (* TODO support filters in Require *) + Declaremods.import_modules ~export mpl) + export (* [needed] is the ordered list of libraries not already loaded *) let cache_require o = @@ -370,16 +374,17 @@ let require_library_from_dirpath ~lib_resolver modrefl export = let needed, contents = List.fold_left (rec_intern_library ~lib_resolver) ([], DPmap.empty) modrefl in let needed = List.rev_map (fun dir -> DPmap.find dir contents) needed in let modrefl = List.map fst modrefl in - if Lib.is_module_or_modtype () then - begin - warn_require_in_module (); - add_anonymous_leaf (in_require (needed,modrefl,None)); - Option.iter (fun export -> - List.iter (fun m -> Declaremods.import_module ~export (MPfile m)) modrefl) - export - end - else - add_anonymous_leaf (in_require (needed,modrefl,export)); + if Lib.is_module_or_modtype () then + begin + warn_require_in_module (); + add_anonymous_leaf (in_require (needed,modrefl,None)); + Option.iter (fun export -> + (* TODO import filters *) + List.iter (fun m -> Declaremods.import_module Unfiltered ~export (MPfile m)) modrefl) + export + end + else + add_anonymous_leaf (in_require (needed,modrefl,export)); () (************************************************************************) diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 475d5c31f7..3b9c771b93 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -877,9 +877,12 @@ let subst_syntax_extension (subst, (local, (pa_sy,pp_sy))) = let classify_syntax_definition (local, _ as o) = if local then Dispose else Substitute o +let open_syntax_extension i o = + if Int.equal i 1 then cache_syntax_extension o + let inSyntaxExtension : syntax_extension_obj -> obj = declare_object {(default_object "SYNTAX-EXTENSION") with - open_function = (fun i o -> if Int.equal i 1 then cache_syntax_extension o); + open_function = simple_open open_syntax_extension; cache_function = cache_syntax_extension; subst_function = subst_syntax_extension; classify_function = classify_syntax_definition} @@ -1454,7 +1457,7 @@ let classify_notation nobj = let inNotation : notation_obj -> obj = declare_object {(default_object "NOTATION") with - open_function = open_notation; + open_function = simple_open open_notation; cache_function = cache_notation; subst_function = subst_notation; load_function = load_notation; @@ -1765,7 +1768,7 @@ let classify_scope_command (local, _, _ as o) = let inScopeCommand : locality_flag * scope_name * scope_command -> obj = declare_object {(default_object "DELIMITERS") with cache_function = cache_scope_command; - open_function = open_scope_command; + open_function = simple_open open_scope_command; load_function = load_scope_command; subst_function = subst_scope_command; classify_function = classify_scope_command} @@ -1831,7 +1834,7 @@ let classify_custom_entry (local,s as o) = let inCustomEntry : locality_flag * string -> obj = declare_object {(default_object "CUSTOM-ENTRIES") with cache_function = cache_custom_entry; - open_function = open_custom_entry; + open_function = simple_open open_custom_entry; load_function = load_custom_entry; subst_function = subst_custom_entry; classify_function = classify_custom_entry} diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 435085793c..060f069419 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -134,7 +134,7 @@ let solve_by_tac ?loc name evi t poly uctx = (* the status is dropped. *) let env = Global.env () in let body, types, _, uctx = - Pfedit.build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in + Declare.build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in Inductiveops.control_only_guard env (Evd.from_ctx uctx) (EConstr.of_constr body); Some (body, types, uctx) with diff --git a/vernac/pfedit.ml b/vernac/pfedit.ml new file mode 100644 index 0000000000..d6b9592176 --- /dev/null +++ b/vernac/pfedit.ml @@ -0,0 +1,9 @@ +(* Compat API / *) +let get_current_context = Declare.get_current_context +let solve = Proof.solve +let by = Declare.by +let refine_by_tactic = Proof.refine_by_tactic + +(* We don't want to export this anymore, but we do for now *) +let build_by_tactic = Declare.build_by_tactic +let build_constant_by_tactic = Declare.build_constant_by_tactic diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 054b60853f..7a2e6d8b03 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -86,7 +86,13 @@ open Pputils let pr_module = Libnames.pr_qualid - let pr_import_module = Libnames.pr_qualid + let pr_one_import_filter_name (q,etc) = + Libnames.pr_qualid q ++ if etc then str "(..)" else mt() + + let pr_import_module (m,f) = + Libnames.pr_qualid m ++ match f with + | ImportAll -> mt() + | ImportNames ns -> surround (prlist_with_sep pr_comma pr_one_import_filter_name ns) let sep_end = function | VernacBullet _ @@ -785,7 +791,7 @@ let string_of_definition_object_kind = let open Decls in function return (keyword "Admitted") | VernacEndProof (Proved (opac,o)) -> return ( - let open Proof_global in + let open Declare in match o with | None -> (match opac with | Transparent -> keyword "Defined" diff --git a/vernac/proof_global.ml b/vernac/proof_global.ml new file mode 100644 index 0000000000..b6c07042e2 --- /dev/null +++ b/vernac/proof_global.ml @@ -0,0 +1,7 @@ +(* compatibility module; can be removed once we agree on the API *) + +type t = Declare.Proof.t +let map_proof = Declare.Proof.map_proof +let get_proof = Declare.Proof.get_proof + +type opacity_flag = Declare.opacity_flag = Opaque | Transparent diff --git a/vernac/search.ml b/vernac/search.ml index 68a30b4231..8b54b696f2 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -61,7 +61,7 @@ let iter_named_context_name_type f = let get_current_or_goal_context ?pstate glnum = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) - | Some p -> Pfedit.get_goal_context p glnum + | Some p -> Declare.get_goal_context p glnum (* General search over hypothesis of a goal *) let iter_hypothesis ?pstate glnum (fn : GlobRef.t -> env -> constr -> unit) = diff --git a/vernac/search.mli b/vernac/search.mli index 6dbbff3a8c..d3b8444b5f 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -38,13 +38,13 @@ val search_filter : glob_search_about_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_by_head : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_rewrite : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_rewrite : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_pattern : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_pattern : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list +val search : ?pstate:Declare.Proof.t -> int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = @@ -65,12 +65,12 @@ type 'a coq_object = { coq_object_object : 'a; } -val interface_search : ?pstate:Proof_global.t -> ?glnum:int -> (search_constraint * bool) list -> +val interface_search : ?pstate:Declare.Proof.t -> ?glnum:int -> (search_constraint * bool) list -> constr coq_object list (** {6 Generic search function} *) -val generic_search : ?pstate:Proof_global.t -> int option -> display_function -> unit +val generic_search : ?pstate:Declare.Proof.t -> int option -> display_function -> unit (** This function iterates over all hypothesis of the goal numbered [glnum] (if present) and all known declarations. *) diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 5a2bdb43d4..b7728fe699 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -44,3 +44,5 @@ ComArguments Vernacentries Vernacstate Vernacinterp +Proof_global +Pfedit diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 3195f339b6..044e479aeb 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -34,12 +34,12 @@ let (f_interp_redexp, interp_redexp_hook) = Hook.make () let get_current_or_global_context ~pstate = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) - | Some p -> Pfedit.get_current_context p + | Some p -> Declare.get_current_context p let get_goal_or_global_context ~pstate glnum = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) - | Some p -> Pfedit.get_goal_context p glnum + | Some p -> Declare.get_goal_context p glnum let cl_of_qualid = function | FunClass -> Coercionops.CL_FUN @@ -94,13 +94,13 @@ let show_proof ~pstate = (* spiwack: this would probably be cooler with a bit of polishing. *) try let pstate = Option.get pstate in - let p = Proof_global.get_proof pstate in - let sigma, env = Pfedit.get_current_context pstate in + let p = Declare.Proof.get_proof pstate in + let sigma, env = Declare.get_current_context pstate in let pprf = Proof.partial_proof p in Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf (* We print nothing if there are no goals left *) with - | Pfedit.NoSuchGoal + | Proof.NoSuchGoal _ | Option.IsNone -> user_err (str "No goals to show.") @@ -476,7 +476,7 @@ let program_inference_hook env sigma ev = then None else let c, _, _, ctx = - Pfedit.build_by_tactic ~poly:false env ~uctx:(Evd.evar_universe_context sigma) ~typ:concl tac + Declare.build_by_tactic ~poly:false env ~uctx:(Evd.evar_universe_context sigma) ~typ:concl tac in Some (Evd.set_universe_context sigma ctx, EConstr.of_constr c) with @@ -593,7 +593,7 @@ let vernac_exact_proof ~lemma c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the beginning of a proof. *) let lemma, status = Lemmas.by (Tactics.exact_proof c) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Opaque ~idopt:None in + let () = Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Opaque ~idopt:None in if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption ~atts discharge kind l nl = @@ -872,12 +872,62 @@ let vernac_constraint ~poly l = (**********************) (* Modules *) +let add_subnames_of ns full_n n = + let open GlobRef in + let module NSet = Globnames.ExtRefSet in + let add1 r ns = NSet.add (Globnames.TrueGlobal r) ns in + match n with + | Globnames.SynDef _ | Globnames.TrueGlobal (ConstRef _ | ConstructRef _ | VarRef _) -> + CErrors.user_err Pp.(str "Only inductive types can be used with Import (...).") + | Globnames.TrueGlobal (IndRef (mind,i)) -> + let open Declarations in + let dp = Libnames.dirpath full_n in + let mib = Global.lookup_mind mind in + let mip = mib.mind_packets.(i) in + let ns = add1 (IndRef (mind,i)) ns in + let ns = Array.fold_left_i (fun j ns _ -> add1 (ConstructRef ((mind,i),j+1)) ns) + ns mip.mind_consnames + in + List.fold_left (fun ns f -> + let s = Indrec.elimination_suffix f in + let n_elim = Id.of_string (Id.to_string mip.mind_typename ^ s) in + match Nametab.extended_global_of_path (Libnames.make_path dp n_elim) with + | exception Not_found -> ns + | n_elim -> NSet.add n_elim ns) + ns Sorts.all_families + +let interp_filter_in m = function + | ImportAll -> Libobject.Unfiltered + | ImportNames ns -> + let module NSet = Globnames.ExtRefSet in + let dp_m = Nametab.dirpath_of_module m in + let ns = + List.fold_left (fun ns (n,etc) -> + let full_n = + let dp_n,n = repr_qualid n in + make_path (append_dirpath dp_m dp_n) n + in + let n = try Nametab.extended_global_of_path full_n + with Not_found -> + CErrors.user_err + Pp.(str "Cannot find name " ++ pr_qualid n ++ spc() ++ + str "in module " ++ pr_qualid (Nametab.shortest_qualid_of_module m)) + in + let ns = NSet.add n ns in + if etc then add_subnames_of ns full_n n else ns) + NSet.empty ns + in + Libobject.Names ns + let vernac_import export refl = - let import_mod qid = - try Declaremods.import_module ~export @@ Nametab.locate_module qid - with Not_found -> - CErrors.user_err Pp.(str "Cannot find module " ++ pr_qualid qid) - in + let import_mod (qid,f) = + let m = try Nametab.locate_module qid + with Not_found -> + CErrors.user_err Pp.(str "Cannot find module " ++ pr_qualid qid) + in + let f = interp_filter_in m f in + Declaremods.import_module f ~export m + in List.iter import_mod refl let vernac_declare_module export {loc;v=id} binders_ast mty_ast = @@ -893,7 +943,7 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = let mp = Declaremods.declare_module id binders_ast (Declaremods.Enforce mty_ast) [] in Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is declared"); - Option.iter (fun export -> vernac_import export [qualid_of_ident id]) export + Option.iter (fun export -> vernac_import export [qualid_of_ident id, ImportAll]) export let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) @@ -914,7 +964,7 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt List.iter (fun (export,id) -> Option.iter - (fun export -> vernac_import export [qualid_of_ident id]) export + (fun export -> vernac_import export [qualid_of_ident id, ImportAll]) export ) argsexport | _::_ -> let binders_ast = List.map @@ -929,14 +979,14 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); - Option.iter (fun export -> vernac_import export [qualid_of_ident id]) + Option.iter (fun export -> vernac_import export [qualid_of_ident id, ImportAll]) export let vernac_end_module export {loc;v=id} = let mp = Declaremods.end_module () in Dumpglob.dump_modref ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); - Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id]) export + Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id, ImportAll]) export let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = if Global.sections_are_opened () then @@ -957,7 +1007,7 @@ let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = List.iter (fun (export,id) -> Option.iter - (fun export -> vernac_import export [qualid_of_ident ?loc id]) export + (fun export -> vernac_import export [qualid_of_ident ?loc id, ImportAll]) export ) argsexport | _ :: _ -> @@ -1117,7 +1167,7 @@ let focus_command_cond = Proof.no_cond command_focus all tactics fail if there are no further goals to prove. *) let vernac_solve_existential ~pstate n com = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> let intern env sigma = Constrintern.intern_constr env sigma com in Proof.V82.instantiate_evar (Global.env ()) n intern p) pstate @@ -1125,12 +1175,12 @@ let vernac_set_end_tac ~pstate tac = let env = Genintern.empty_glob_sign (Global.env ()) in let _, tac = Genintern.generic_intern env tac in (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) - Proof_global.set_endline_tactic tac pstate + Declare.Proof.set_endline_tactic tac pstate -let vernac_set_used_variables ~pstate e : Proof_global.t = +let vernac_set_used_variables ~pstate e : Declare.Proof.t = let env = Global.env () in let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in - let tys = List.map snd (initial_goals (Proof_global.get_proof pstate)) in + let tys = List.map snd (initial_goals (Declare.Proof.get_proof pstate)) in let tys = List.map EConstr.Unsafe.to_constr tys in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in @@ -1139,7 +1189,7 @@ let vernac_set_used_variables ~pstate e : Proof_global.t = user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ Id.print id)) l; - let _, pstate = Proof_global.set_used_variables pstate l in + let _, pstate = Declare.Proof.set_used_variables pstate l in pstate (*****************************) @@ -1539,8 +1589,8 @@ let get_current_context_of_args ~pstate = let env = Global.env () in Evd.(from_env env, env) | Some lemma -> function - | Some n -> Pfedit.get_goal_context lemma n - | None -> Pfedit.get_current_context lemma + | Some n -> Declare.get_goal_context lemma n + | None -> Declare.get_current_context lemma let query_command_selector ?loc = function | None -> None @@ -1605,7 +1655,7 @@ let vernac_global_check c = let get_nth_goal ~pstate n = - let pf = Proof_global.get_proof pstate in + let pf = Declare.Proof.get_proof pstate in let Proof.{goals;sigma} = Proof.data pf in let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl @@ -1640,7 +1690,7 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = let natureofid = match decl with | LocalAssum _ -> "Hypothesis" | LocalDef (_,bdy,_) ->"Constant (let in)" in - let sigma, env = Pfedit.get_current_context pstate in + let sigma, env = Declare.get_current_context pstate in v 0 (Id.print id ++ str":" ++ pr_econstr_env env sigma (NamedDecl.get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) @@ -1843,7 +1893,7 @@ let vernac_register qid r = (* Proof management *) let vernac_focus ~pstate gln = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> match gln with | None -> Proof.focus focus_command_cond () 1 p | Some 0 -> @@ -1854,13 +1904,13 @@ let vernac_focus ~pstate gln = (* Unfocuses one step in the focus stack. *) let vernac_unfocus ~pstate = - Proof_global.map_proof + Declare.Proof.map_proof (fun p -> Proof.unfocus command_focus p ()) pstate (* Checks that a proof is fully unfocused. Raises an error if not. *) let vernac_unfocused ~pstate = - let p = Proof_global.get_proof pstate in + let p = Declare.Proof.get_proof pstate in if Proof.unfocused p then str"The proof is indeed fully unfocused." else @@ -1873,7 +1923,7 @@ let subproof_kind = Proof.new_focus_kind () let subproof_cond = Proof.done_cond subproof_kind let vernac_subproof gln ~pstate = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> match gln with | None -> Proof.focus subproof_cond () 1 p | Some (Goal_select.SelectNth n) -> Proof.focus subproof_cond () n p @@ -1883,12 +1933,12 @@ let vernac_subproof gln ~pstate = pstate let vernac_end_subproof ~pstate = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> Proof.unfocus subproof_kind p ()) pstate let vernac_bullet (bullet : Proof_bullet.t) ~pstate = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> Proof_bullet.put p bullet) pstate (* Stack is needed due to show proof names, should deprecate / remove @@ -1905,7 +1955,7 @@ let vernac_show ~pstate = end (* Show functions that require a proof state *) | Some pstate -> - let proof = Proof_global.get_proof pstate in + let proof = Declare.Proof.get_proof pstate in begin function | ShowGoal goalref -> begin match goalref with @@ -1917,14 +1967,14 @@ let vernac_show ~pstate = | ShowUniverses -> show_universes ~proof (* Deprecate *) | ShowProofNames -> - Id.print (Proof_global.get_proof_name pstate) + Id.print (Declare.Proof.get_proof_name pstate) | ShowIntros all -> show_intro ~proof all | ShowProof -> show_proof ~pstate:(Some pstate) | ShowMatch id -> show_match id end let vernac_check_guard ~pstate = - let pts = Proof_global.get_proof pstate in + let pts = Declare.Proof.get_proof pstate in let pfterm = List.hd (Proof.partial_proof pts) in let message = try diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index d6e7a3947a..c32ac414ba 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -101,7 +101,14 @@ type verbose_flag = bool (* true = Verbose; false = Silent *) type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) + type export_flag = bool (* true = Export; false = Import *) + +type one_import_filter_name = qualid * bool (* import inductive components *) +type import_filter_expr = + | ImportAll + | ImportNames of one_import_filter_name list + type onlyparsing_flag = { onlyparsing : bool } (* Some v = Parse only; None = Print also. If v<>Current, it contains the name of the coq version @@ -195,7 +202,7 @@ type syntax_modifier = type proof_end = | Admitted (* name in `Save ident` when closing goal *) - | Proved of Proof_global.opacity_flag * lident option + | Proved of Declare.opacity_flag * lident option type scheme = | InductionScheme of bool * qualid or_by_notation * sort_expr @@ -320,7 +327,7 @@ type nonrec vernac_expr = | VernacEndSegment of lident | VernacRequire of qualid option * export_flag option * qualid list - | VernacImport of export_flag * qualid list + | VernacImport of export_flag * (qualid * import_filter_expr) list | VernacCanonical of qualid or_by_notation | VernacCoercion of qualid or_by_notation * class_rawexpr * class_rawexpr diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 1920c276af..d772f274a2 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -57,9 +57,9 @@ type typed_vernac = | VtNoProof of (unit -> unit) | VtCloseProof of (lemma:Lemmas.t -> unit) | VtOpenProof of (unit -> Lemmas.t) - | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) - | VtReadProofOpt of (pstate:Proof_global.t option -> unit) - | VtReadProof of (pstate:Proof_global.t -> unit) + | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) + | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) + | VtReadProof of (pstate:Declare.Proof.t -> unit) type vernac_command = atts:Attributes.vernac_flags -> typed_vernac diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 0d0ebc1086..58c267080a 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -75,9 +75,9 @@ type typed_vernac = | VtNoProof of (unit -> unit) | VtCloseProof of (lemma:Lemmas.t -> unit) | VtOpenProof of (unit -> Lemmas.t) - | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) - | VtReadProofOpt of (pstate:Proof_global.t option -> unit) - | VtReadProof of (pstate:Proof_global.t -> unit) + | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) + | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) + | VtReadProof of (pstate:Declare.Proof.t -> unit) type vernac_command = atts:Attributes.vernac_flags -> typed_vernac diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index eb299222dd..19d41c4770 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -209,7 +209,7 @@ and interp_control ~st ({ CAst.v = cmd } as vernac) = let before_univs = Global.universes () in let pstack = interp_expr ~atts:cmd.attrs ~st cmd.expr in if before_univs == Global.universes () then pstack - else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Proof_global.update_global_env) pstack) + else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Declare.Proof.update_global_env) pstack) ~st (* XXX: This won't properly set the proof mode, as of today, it is @@ -251,7 +251,7 @@ let interp_gen ~verbosely ~st ~interp_fn cmd = try vernac_timeout (fun st -> let v_mod = if verbosely then Flags.verbosely else Flags.silently in let ontop = v_mod (interp_fn ~st) cmd in - Vernacstate.Proof_global.set ontop [@ocaml.warning "-3"]; + Vernacstate.Declare.set ontop [@ocaml.warning "-3"]; Vernacstate.freeze_interp_state ~marshallable:false ) st with exn -> diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index 9f5bfb46ee..e3e708e87d 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -14,7 +14,7 @@ val interp : ?verbosely:bool -> st:Vernacstate.t -> Vernacexpr.vernac_control -> (** Execute a Qed but with a proof_object which may contain a delayed proof and won't be forced *) val interp_qed_delayed_proof - : proof:Proof_global.proof_object + : proof:Declare.proof_object -> info:Lemmas.Info.t -> st:Vernacstate.t -> control:Vernacexpr.control_flag list diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index a4e9c8e1ab..0fca1e9078 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -45,7 +45,7 @@ module LemmaStack = struct | Some (l,ls) -> a, (l :: ls) let get_all_proof_names (pf : t) = - let prj x = Lemmas.pf_fold Proof_global.get_proof x in + let prj x = Lemmas.pf_fold Declare.Proof.get_proof x in let (pn, pns) = map Proof.(function pf -> (data (prj pf)).name) pf in pn :: pns @@ -105,7 +105,7 @@ let make_shallow st = } (* Compatibility module *) -module Proof_global = struct +module Declare = struct let get () = !s_lemmas let set x = s_lemmas := x @@ -126,7 +126,7 @@ module Proof_global = struct end open Lemmas - open Proof_global + open Declare let cc f = match !s_lemmas with | None -> raise NoCurrentProof @@ -145,23 +145,23 @@ module Proof_global = struct | Some x -> s_lemmas := Some (LemmaStack.map_top_pstate ~f x) let there_are_pending_proofs () = !s_lemmas <> None - let get_open_goals () = cc get_open_goals + let get_open_goals () = cc Proof.get_open_goals - let give_me_the_proof_opt () = Option.map (LemmaStack.with_top_pstate ~f:get_proof) !s_lemmas - let give_me_the_proof () = cc get_proof - let get_current_proof_name () = cc get_proof_name + let give_me_the_proof_opt () = Option.map (LemmaStack.with_top_pstate ~f:Proof.get_proof) !s_lemmas + let give_me_the_proof () = cc Proof.get_proof + let get_current_proof_name () = cc Proof.get_proof_name - let map_proof f = dd (map_proof f) + let map_proof f = dd (Proof.map_proof f) let with_current_proof f = match !s_lemmas with | None -> raise NoCurrentProof | Some stack -> - let pf, res = LemmaStack.with_top_pstate stack ~f:(map_fold_proof_endline f) in + let pf, res = LemmaStack.with_top_pstate stack ~f:(Proof.map_fold_proof_endline f) in let stack = LemmaStack.map_top_pstate stack ~f:(fun _ -> pf) in s_lemmas := Some stack; res - type closed_proof = Proof_global.proof_object * Lemmas.Info.t + type closed_proof = Declare.proof_object * Lemmas.Info.t let return_proof () = cc return_proof @@ -169,16 +169,16 @@ module Proof_global = struct let close_future_proof ~feedback_id pf = cc_lemma (fun pt -> pf_fold (fun st -> close_future_proof ~feedback_id st pf) pt, - Internal.get_info pt) + Lemmas.Internal.get_info pt) let close_proof ~opaque ~keep_body_ucst_separate = cc_lemma (fun pt -> pf_fold ((close_proof ~opaque ~keep_body_ucst_separate)) pt, - Internal.get_info pt) + Lemmas.Internal.get_info pt) let discard_all () = s_lemmas := None - let update_global_env () = dd (update_global_env) + let update_global_env () = dd (Proof.update_global_env) - let get_current_context () = cc Pfedit.get_current_context + let get_current_context () = cc Declare.get_current_context let get_all_proof_names () = try cc_stack LemmaStack.get_all_proof_names diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index 9c4de7720c..fb6d8b6db6 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -25,8 +25,8 @@ module LemmaStack : sig val pop : t -> Lemmas.t * t option val push : t option -> Lemmas.t -> t - val map_top_pstate : f:(Proof_global.t -> Proof_global.t) -> t -> t - val with_top_pstate : t -> f:(Proof_global.t -> 'a ) -> 'a + val map_top_pstate : f:(Declare.Proof.t -> Declare.Proof.t) -> t -> t + val with_top_pstate : t -> f:(Declare.Proof.t -> 'a ) -> 'a end @@ -50,7 +50,7 @@ val make_shallow : t -> t val invalidate_cache : unit -> unit (* Compatibility module: Do Not Use *) -module Proof_global : sig +module Declare : sig exception NoCurrentProof @@ -65,16 +65,16 @@ module Proof_global : sig val with_current_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a - val return_proof : unit -> Proof_global.closed_proof_output - val return_partial_proof : unit -> Proof_global.closed_proof_output + val return_proof : unit -> Declare.closed_proof_output + val return_partial_proof : unit -> Declare.closed_proof_output - type closed_proof = Proof_global.proof_object * Lemmas.Info.t + type closed_proof = Declare.proof_object * Lemmas.Info.t val close_future_proof : feedback_id:Stateid.t -> - Proof_global.closed_proof_output Future.computation -> closed_proof + Declare.closed_proof_output Future.computation -> closed_proof - val close_proof : opaque:Proof_global.opacity_flag -> keep_body_ucst_separate:bool -> closed_proof + val close_proof : opaque:Declare.opacity_flag -> keep_body_ucst_separate:bool -> closed_proof val discard_all : unit -> unit val update_global_env : unit -> unit @@ -89,7 +89,7 @@ module Proof_global : sig val get : unit -> LemmaStack.t option val set : LemmaStack.t option -> unit - val get_pstate : unit -> Proof_global.t option + val get_pstate : unit -> Declare.Proof.t option val freeze : marshallable:bool -> LemmaStack.t option val unfreeze : LemmaStack.t -> unit |